phonetische Textsuche mit DoubleMetaphone

Anwendungen, Tools, Userlibs und anderes nützliches.
Antworten
Benutzeravatar
freedimension
Admin
Beiträge: 1987
Registriert: 08.09.2004 13:19
Wohnort: Ludwigsburg
Kontaktdaten:
Kontaktdaten von freedimension

Re: Deutsch

Beitrag von freedimension »

Hroudtwolf hat geschrieben:Ich hab mal gehört ,daß Deutsch (inklusive nicht benutzte Wörter) um die
6000 Wörter hat.
Wo hast du die Info her? 6000 Wörter ist viel zu wenig, mein einfacher Duden hat ja schon mehr als zehnmal so viele.
Soll ja die umfangreichste Sprache Europas sein.
Das ist meines Erachtens nach Englisch. Im Englischen gibt es viele Besonderheiten, die das Neubilden von Wörtern vereinfachen, z.B. dass du auf einfache Weise Substantive in Verben und umgekehrt umwandeln kannst.
Siehe hier:
http://www.askoxford.com/asktheexperts/ ... ds?view=uk
http://www.askoxford.com/asktheexperts/ ... ds?view=uk
Wie ich finde sogar die schönste..Aber das ist Geschmacksache.
Finde ich auch, aber das behauptet wohl jeder von seiner Muttersprache ;)
Beginne jeden Tag als ob es Absicht wäre!
Bild
BILDblog
Nach oben
schic
Beiträge: 68
Registriert: 25.12.2004 19:04

Beitrag von schic »

Hallo Volker,

danke für den Link. Die Wortlisten kann ich in der Tat gut gebrauchen.

Gruß von schic
Nach oben
MenschMarkus
Beiträge: 227
Registriert: 30.04.2009 21:21
Computerausstattung: i5-2300 (2.8 Ghz) Win10 -64bit / PB 5.73 LTS

Beitrag von MenschMarkus »

Als Dankeschön, weils zum Einen hier hinein passt und ich den metaphone code gebrauchen konnte. Hier eine Soundex Umsetzung. Den Block nach 'Anfangsbuchstaben zusammenfassen' habe selbst mit eingebracht, da er die Schwäche bei Schreibfehlern des Anfangsbuchstabens ausgleicht.

Code: Alles auswählen

Enumeration
#Text1
#Text2
#String1
#Button1

EndEnumeration      
Global SoundexIn$,SoundexOut$

Procedure soundex()
SDEXTMP = Len(SoundexIn$)
If SDEXTMP >= 4
    SDEX_Suchwort$ = UCase(SoundexIn$)
    SDEX_TMP2$ = ""
    For i = 1 To Len(SDEX_Suchwort$)
        SDEX_TMP1$ = Mid(SDEX_Suchwort$,i,1)
        If Asc(SDEX_TMP1$) > 65                      ; Zahlen herausfiltern
            SDEX_TMP2$ + SDEX_TMP1$
        EndIf     
    Next
     SDEX_TMP3$ = Mid(SDEX_TMP2$,1,1)
     SDEX_TMP4$ = Mid(SDEX_TMP2$,2,1)
     If SDEX_TMP3$ = "P" And SDEX_TMP4$ = "S" : ReplaceString(Left(SDEX_TMP2$,2),"PS","S") : EndIf
     If SDEX_TMP3$ = "P" And SDEX_TMP4$ = "F" : ReplaceString(Left(SDEX_TMP2$,2),"PF","F") : EndIf
     ReplaceString(SDEX_TMP2$,"DG","_G",#PB_String_InPlace)
     ReplaceString(SDEX_TMP2$,"GH","_H",#PB_String_InPlace)
     ReplaceString(SDEX_TMP2$,"KN","_N",#PB_String_InPlace)
     ReplaceString(SDEX_TMP2$,"GN","_N",#PB_String_InPlace)
     ReplaceString(SDEX_TMP2$,"MB","M_",#PB_String_InPlace)
     ReplaceString(SDEX_TMP2$,"PH","F_",#PB_String_InPlace)
     ReplaceString(SDEX_TMP2$,"TCH","_CH",#PB_String_InPlace)
     ReplaceString(SDEX_TMP2$,"MPS","M_S",#PB_String_InPlace)
     ReplaceString(SDEX_TMP2$,"MPT","M_T",#PB_String_InPlace)
     ReplaceString(SDEX_TMP2$,"MPZ","M_Z",#PB_String_InPlace)
     ReplaceString(SDEX_TMP2$,"_","")
     SDEX_Start$ = Left(UCase(SoundexIn$),1)          ; Anfangsbuchstabe festhalten
     
     ReplaceString(SDEX_Start$,"P","B",#PB_String_InPlace)   ; Anfangsbuchstaben zusammenfassen
     ReplaceString(SDEX_Start$,"T","D",#PB_String_InPlace)
     ReplaceString(SDEX_Start$,"V","F",#PB_String_InPlace)
     ReplaceString(SDEX_Start$,"W","F",#PB_String_InPlace)
     ReplaceString(SDEX_Start$,"K","G",#PB_String_InPlace)
     ReplaceString(SDEX_Start$,"Q","G",#PB_String_InPlace)
     ReplaceString(SDEX_Start$,"X","G",#PB_String_InPlace)
     ReplaceString(SDEX_Start$,"C","G",#PB_String_InPlace)
     ReplaceString(SDEX_Start$,"J","I",#PB_String_InPlace)
     ReplaceString(SDEX_Start$,"Y","I",#PB_String_InPlace)
     ReplaceString(SDEX_Start$,"N","M",#PB_String_InPlace)
     ReplaceString(SDEX_Start$,"U","O",#PB_String_InPlace)
     ReplaceString(SDEX_Start$,"Z","S",#PB_String_InPlace)     
     
     If SDEX_Start$ = "H" Or SDEX_Start$ = "W" : SDEX_TMP2$ = "-" + Mid(SDEX_TMP2$,2) : EndIf
     
     ReplaceString(SDEX_TMP2$,"A","0",#PB_String_InPlace)                ; Soundex Kodieren
     ReplaceString(SDEX_TMP2$,"E","0",#PB_String_InPlace)
     ReplaceString(SDEX_TMP2$,"I","0",#PB_String_InPlace)
     ReplaceString(SDEX_TMP2$,"O","0",#PB_String_InPlace)
     ReplaceString(SDEX_TMP2$,"U","0",#PB_String_InPlace)
     ReplaceString(SDEX_TMP2$,"Y","0",#PB_String_InPlace)
     ReplaceString(SDEX_TMP2$,"H","0",#PB_String_InPlace)
     ReplaceString(SDEX_TMP2$,"W","0",#PB_String_InPlace)
     
     ReplaceString(SDEX_TMP2$,"B","1",#PB_String_InPlace)
     ReplaceString(SDEX_TMP2$,"P","1",#PB_String_InPlace)
     ReplaceString(SDEX_TMP2$,"F","1",#PB_String_InPlace)
     ReplaceString(SDEX_TMP2$,"V","1",#PB_String_InPlace)
     
     ReplaceString(SDEX_TMP2$,"C","2",#PB_String_InPlace)
     ReplaceString(SDEX_TMP2$,"S","2",#PB_String_InPlace)
     ReplaceString(SDEX_TMP2$,"G","2",#PB_String_InPlace)
     ReplaceString(SDEX_TMP2$,"J","2",#PB_String_InPlace)
     ReplaceString(SDEX_TMP2$,"K","2",#PB_String_InPlace)
     ReplaceString(SDEX_TMP2$,"Q","2",#PB_String_InPlace)
     ReplaceString(SDEX_TMP2$,"X","2",#PB_String_InPlace)
     ReplaceString(SDEX_TMP2$,"Z","2",#PB_String_InPlace)
    
     ReplaceString(SDEX_TMP2$,"D","3",#PB_String_InPlace)
     ReplaceString(SDEX_TMP2$,"T","3",#PB_String_InPlace)
     
     ReplaceString(SDEX_TMP2$,"L","4",#PB_String_InPlace)
     
     ReplaceString(SDEX_TMP2$,"M","5",#PB_String_InPlace)
     ReplaceString(SDEX_TMP2$,"N","5",#PB_String_InPlace)
     
     ReplaceString(SDEX_TMP2$,"R","6",#PB_String_InPlace)
     
     SDEX_TMP3$ = ""
     SDEX_TMP4$ = ""
     SDEX_TMP$ = ""
     For i = 1 To Len(SDEX_TMP2$)                  ; doppelte Buchstaben herausfiltern
        SDEX_TMP3$ = Mid(SDEX_TMP2$,i,1)
        SDEX_TMP4$ = Mid(SDEX_TMP2$,i+1,1)
        If SDEX_TMP3$ <> SDEX_TMP4$
            SDEX_TMP$ + SDEX_TMP3$
        EndIf
     Next
    SDEX_TMP2$ = SDEX_TMP$
    SDEX_TMP4$ = ""                                 ; A E I O U H W Y löschen
    For i = 1 To Len(SDEX_TMP2$)
        SDEX_TMP3$ = Mid(SDEX_TMP2$,i,1)
        If SDEX_TMP3$ <> "0" : SDEX_TMP4$ + SDEX_TMP3$ : EndIf
    Next
    SDEX_TMP2$ = SDEX_TMP4$
    SDEX_TMP2$ = Mid(SDEX_TMP2$,2)
    SDEX_TMP2$ = SDEX_Start$ + SDEX_TMP2$
    SDEX_TMP2$ + "0000"
    SoundexOut$ = Left(SDEX_TMP2$,4)
EndIf
EndProcedure

Procedure OpenWindow_0()
    If OpenWindow(0,100,100,400,100,"Soundex")
        TextGadget(#Text1,10,10,100,20,"Eingabe :")
        TextGadget(#Text2,10,40,200,20,"Ausgabe :         ")
        StringGadget(#String1,120,10,100,20,"")
        ButtonGadget(#Button1,10,60,100,30,"Wandeln")
    EndIf
    
EndProcedure

OpenWindow_0()
Repeat
   EventID = WaitWindowEvent()
    If EventID = #PB_Event_Gadget
    Select EventGadget()
        Case #Button1
        SoundexIn$ = GetGadgetText(#String1)
        soundex()
        SetGadgetText(#Text2,"Ausgabe :                    " + SoundexOut$)
    EndSelect
   EndIf
Until EventID = #PB_Event_CloseWindow

End
Viel Spass wers gebrauchen kann


~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Ergänzung 18.06.2014

der Vollständigkeit halber hier eine Umsetzung der Kölner Phonetik, welche im Vergleich zu Soundex etwas besser auf die deutsche Spracheigenheiten eingeht.

Code: Alles auswählen

;*************************
; 18.06.2014
; Koelner Phonetik
; Eine alternative zu Soundex für deutschen Sprachgebrauch
;
; gefunden in VBForum
; Umsetzung in PB Code:  menschmarkus
; 
;*************************
EnableExplicit

Declare.s Conv_Ersten(value.s)
Declare.s Conv_Rest(value.s)

Procedure.s Koelner_Phonetic(Name.s)
    Protected Rueckgabe.s, Zaehler.i, Kette.s, Wert.s, Endwert.s
    ;Generelle Wandlung von gleichklingenden Buchstaben
    Name = LCase(Trim(Name))
    ReplaceString(Name,"ph","f",#PB_String_InPlace)
    ReplaceString(Name,"ü","u",#PB_String_InPlace)
    ReplaceString(Name,"ä","e",#PB_String_InPlace)
    ReplaceString(Name,"ö","o",#PB_String_InPlace)
    ReplaceString(Name,"ß","s",#PB_String_InPlace)
    ReplaceString(Name,"ç","c",#PB_String_InPlace) ;hier können auch Buchstaben mit Sonderzeichen ergänzt werden
    ReplaceString(Name,"ph","f",#PB_String_InPlace)
    Name = "#" + Name + "#"
    For zaehler = 1 To Len(Name)-2
        Kette = Mid(Name,Zaehler,3)
        If Zaehler = 1
            Wert.s = Conv_Ersten(Kette.s)
        Else
            Wert.s = Conv_Rest(Kette.s)
        EndIf
        Rueckgabe + Wert
    Next
    ;Buchstaben "h" komplett löschen
    Rueckgabe = RemoveString(Rueckgabe,"-")

    ;Wörter bei unbekannten Buchstaben trennen.
    ReplaceString(Rueckgabe,"?"," ",#PB_String_InPlace)

    ;Der Erste Buchstabe bleibt immer erhalten, auch Vokale
    If Left(Rueckgabe,1) = "0"
        Rueckgabe = "0" + RemoveString(Rueckgabe,"0")
    Else
        ;Alle Vokale löschen
        Rueckgabe = RemoveString(Rueckgabe,"0")
    EndIf

    ;Doppelte Buchstaben löschen
    Endwert = Left(Rueckgabe,1)
    For Zaehler = 2 To Len(Rueckgabe)
        If Mid(Rueckgabe,Zaehler,1) <> Right(Endwert,1)
            Endwert + Mid(Rueckgabe,Zaehler,1)
        EndIf
    Next
    ProcedureReturn Endwert
EndProcedure

Procedure.s Conv_Ersten(Kette.s)
    Protected Conv_Ersten.s, strTMP1.s, strTMP2.s, InVal.s, RetVal.s
    
    strTMP1 = Mid(Kette, 2, 1)
    strTMP2 = Mid(Kette, 2, 2)
    ;Die Reihenfolge der Abfragen darf nicht geändert werden
    If strTMP1 = "a" Or strTMP1 = "i" Or strTMP1 = "j" Or strTMP1 = "y" Or strTMP1 = "o" Or strTMP1 = "u"
        Conv_Ersten = "0" 
    ElseIf strTMP2 = "ca" Or strTMP2 = "ch" Or strTMP2 = "ck" Or strTMP2 = "cl" Or strTMP2 = "co" Or 
       strTMP2 = "cq" Or strTMP2 = "cr" Or strTMP2 = "cu" Or strTMP2 = "cx" 
        Conv_Ersten = "4"
    ElseIf strTMP1 = "c"
        Conv_Ersten = "8"
    Else       ;wurde hier kein Buchstabe gefunden wird ersatzweise wie innerhalb eines Wortes gewandelt
        InVal = Kette
        Conv_Ersten = Conv_Rest(InVal)
    EndIf
    ProcedureReturn Conv_Ersten
EndProcedure

Procedure.s Conv_Rest(Kette.s)
    Protected strTMP1.s, strTMP2.s, strTMP3.s,Conv_Rest.s
    strTMP1 = Mid(Kette,2,1)
    strTMP2 = Mid(Kette,2,2)
    strTMP3 = Mid(Kette,1,2)

    ;Die Reihenfolge der Abfragen darf nicht geändert werden
    If strTMP2 = "ds" Or strTMP2 = "dc" Or strTMP2 = "dz" Or 
       strTMP2 = "ts" Or strTMP2 = "tc" Or strTMP2 = "tz" Or 
       Conv_Rest = "8"
    ElseIf strTMP1 = "d" Or strTMP1 = "t"
        Conv_Rest = "2"
    ElseIf strTMP3 = "cx" Or strTMP3 = "kx" Or strTMP3 = "qx"
        Conv_Rest = "8"
    ElseIf strTMP1 = "x"
        Conv_Rest = "48"
    ElseIf strTMP3 = "sc" Or strTMP3 = "sz"
        Conv_Rest = "8"
    ElseIf strTMP2 = "ca" Or strTMP2 = "co" Or strTMP2 = "cu" Or strTMP2 = "ch" Or 
           strTMP2 = "ch" Or strTMP2 = "ck" Or strTMP2 = "cx" Or strTMP2 = "cq"
        Conv_Rest = "4"
    ElseIf strTMP1 = "c"
        Conv_Rest = "8"
    ElseIf strTMP1 = "a" Or strTMP1 = "e" Or strTMP1 = "i" Or strTMP1 = "j" Or 
           strTMP1 = "y" Or strTMP1 = "o" Or strTMP1 = "u"
        Conv_Rest = "0"
    ElseIf strTMP1 = "h"
        Conv_Rest = "-"
    ElseIf strTMP1 = "l"
        Conv_Rest = "5"
    ElseIf strTMP1 = "r"
        Conv_Rest = "7"
    ElseIf strTMP1 = "m" Or strTMP1 = "n"
        Conv_Rest = "6"
    ElseIf strTMP1 = "s" Or strTMP1 = "z"
        Conv_Rest = "8"
    ElseIf strTMP1 = "b" Or strTMP1 = "p"
        Conv_Rest = "1"        
    ElseIf strTMP1 = "f" Or strTMP1 = "v" Or strTMP1 = "w"
        Conv_Rest = "3"
    ElseIf strTMP1 = "g" Or strTMP1 = "k" Or strTMP1 = "q"
        Conv_Rest = "4"
    Else
        Conv_Rest = "?"    ;Buchstabe konnte anderweitig nicht umgesetzt werden
    EndIf
    ProcedureReturn Conv_Rest
EndProcedure

;Wortabfrage mit Anzeige des Ergebniscodes !
MessageRequester("Kölner Phonetik",Koelner_Phonetic(InputRequester("Namensabfrage","Bitte einen Namen eingeben","")))
Hier ein Wiki Link: http://de.wikipedia.org/wiki/Kölner_Phonetik

Viel Spass damit

menschmarkus
Wissen schadet nur dem, der es nicht hat !
Nach oben
Antworten

Zurück zu „Feedback - Anwendungen“