XProfan

' phonetische Suche
' - Soundex
' - Kölner Phonetik
' XProfan X2

Proc Soundex

    Parameters String Wort
    Declare String c,d,e
    Var String erg = ""
    Wort = Upper$(Wort)
    Wort = Translate$(Wort,"ß","S")
    c = "" : d = "" : e = ""

    WhileLoop Len(Wort)

        Case InStr(Mid$(Wort,&loop,1),"ABCDEFGHIJKLMNOPQRSTUVWXYZß") : c = c + Mid$(Wort,&loop,1)

    EndWhile

    Wort = c

    If Len(Wort) = 1

        erg = Wort

    ElseIf Len(Wort) > 1

        erg = Left$(Wort,1)

        WhileLoop 2,Len(Wort)

            c = Mid$(Wort,&loop,1)

            If InStr(c,"BFPV")

                d = "1"

            ElseIf InStr(c,"CGJKQSXZ")

                d = "2"

            ElseIf InStr(c,"DT")

                d = "3"

            ElseIf InStr(c,"L")

                d = "4"

            ElseIf InStr(c,"MN")

                d = "5"

            ElseIf InStr(c,"R")

                d = "6"

            EndIf

            If d <> e

                erg = erg + d
                e = d

            EndIf

            Case Len(erg) >= 4 : BREAK

        EndWhile

    EndIf

    erg = Left$(erg + "0000",4)
    Return erg

EndProc

Proc KPhon

    Parameters String Wort
    Declare String c,Pre,Post, Long WPos,WLen, i
    Var String erg = ""

    If Len(Wort) > 0

        c = ""
        Wort = Upper$(Wort)

        WhileLoop Len(Wort)

            Case InStr(Mid$(Wort,&loop,1),"ABCDEFGHIJKLMNOPQRSTUVWXYZÄÖÜß") : c = c + Mid$(Wort,&loop,1)

        EndWhile

        Wort = c

    EndIf

    If Len(Wort) > 0

        WLen = Len(Wort)

        WhileLoop WLen

            Pre  = if(&loop > 1,Mid$(Wort,&loop - 1,1),"")
            c    = Mid$(Wort,&loop,1)
            Post = if(&loop < WLen,Mid$(Wort,&loop + 1,1),"")

            If InStr(c,"AEIJOUYÄÖÜ")

                erg = erg + "0"

            ElseIf c = "H"

                'ignore

            ElseIf (c = "B") or ((c = "P") and (Post <> "H"))

                erg = erg + "1"

            ElseIf InStr(c,"DT") and not(InStr(Post,"CSZ"))

                erg = erg + "2"

            ElseIf InStr(c,"FVW") or ((c = "P") and (Post = "H"))

                erg = erg + "3"

            ElseIf InStr(c,"GKQ")

                erg = erg + "4"

            ElseIf (c = "C") and (InStr(Post,"AHKLOQRUX")) and (&loop = 0)

                erg = erg + "4"

            ElseIf (c = "C") and (InStr(Post,"AHKOQUX")) and not(InStr(Pre,"SZ"))

                erg = erg + "4"

            ElseIf (c = "X") and not(InStr(Pre,"CKQ"))

                erg = erg + "48"

            ElseIf (c = "L")

                erg = erg + "5"

            ElseIf InStr(c,"MN")

                erg = erg + "6"

            ElseIf (c = "R")

                erg = erg + "7"

            ElseIf InStr(c,"SZß")

                erg = erg + "8"

            ElseIf (c = "C") and (InStr(Pre,"SZ"))

                erg = erg + "8"

            ElseIf (c = "C") and Not(InStr(Post,"AHKLOQRUX")) and (&loop = 0)

                erg = erg + "8"

            ElseIf (c = "C") and Not(InStr(Post,"AHKOQUX"))

                erg = erg + "8"

            ElseIf InStr(c,"DT") and (InStr(Post,"CSZ"))

                erg = erg + "8"

            ElseIf (c = "X") and (InStr(Pre,"CKQ"))

                erg = erg + "8"

            Else

                'Fehler

            EndIf

        EndWhile

        ' jetzt erg ausdünnen
        i = Len(erg)

        While i > 1

            c = Mid$(erg,i,1)
            Case (c = Mid$(erg,i - 1,1)) or (c = "0") : erg = Del$(erg,i,1)
            Dec i

        EndWhile

    EndIf

    Return erg

EndProc

proc x

    parameters string s
    print s,"=",KPhon(s),"--",Soundex(s)

endproc

Cls
x("Wikipedia")
x("Breschnew")
x("Müller-Lüdenscheidt")
x("Meier")
x("Maier")
x("Mayer")
x("Mayr")
x("Haus")
x("Maus")
x("frisch")
x("Fisch")
x("Waage")
x("wiegen")
x("Britney")
x("Spears")
x("bewährten")
xass=s2>("Superzicke")
waitkey
end