Suchalgorithmen (phonetisch)

    • Suchalgorithmen (phonetisch)

      ... und auch mal ein Paar andere Suchroutinen ...

      Quellcode

      1. ' phonetische Suche
      2. ' - Soundex
      3. ' - Kölner Phonetik
      4. ' XProfan X2
      5. Proc Soundex
      6. Parameters String Wort
      7. Declare String c,d,e
      8. Var String erg = ""
      9. Wort = Upper$(Wort)
      10. Wort = Translate$(Wort,"ß","S")
      11. c = "" : d = "" : e = ""
      12. WhileLoop Len(Wort)
      13. Case InStr(Mid$(Wort,&loop,1),"ABCDEFGHIJKLMNOPQRSTUVWXYZß") : c = c + Mid$(Wort,&loop,1)
      14. EndWhile
      15. Wort = c
      16. If Len(Wort) = 1
      17. erg = Wort
      18. ElseIf Len(Wort) > 1
      19. erg = Left$(Wort,1)
      20. WhileLoop 2,Len(Wort)
      21. c = Mid$(Wort,&loop,1)
      22. If InStr(c,"BFPV")
      23. d = "1"
      24. ElseIf InStr(c,"CGJKQSXZ")
      25. d = "2"
      26. ElseIf InStr(c,"DT")
      27. d = "3"
      28. ElseIf InStr(c,"L")
      29. d = "4"
      30. ElseIf InStr(c,"MN")
      31. d = "5"
      32. ElseIf InStr(c,"R")
      33. d = "6"
      34. EndIf
      35. If d <> e
      36. erg = erg + d
      37. e = d
      38. EndIf
      39. Case Len(erg) >= 4 : BREAK
      40. EndWhile
      41. EndIf
      42. erg = Left$(erg + "0000",4)
      43. Return erg
      44. EndProc
      45. Proc KPhon
      46. Parameters String Wort
      47. Declare String c,Pre,Post, Long WPos,WLen, i
      48. Var String erg = ""
      49. If Len(Wort) > 0
      50. c = ""
      51. Wort = Upper$(Wort)
      52. WhileLoop Len(Wort)
      53. Case InStr(Mid$(Wort,&loop,1),"ABCDEFGHIJKLMNOPQRSTUVWXYZÄÖÜß") : c = c + Mid$(Wort,&loop,1)
      54. EndWhile
      55. Wort = c
      56. EndIf
      57. If Len(Wort) > 0
      58. WLen = Len(Wort)
      59. WhileLoop WLen
      60. Pre = if(&loop > 1,Mid$(Wort,&loop - 1,1),"")
      61. c = Mid$(Wort,&loop,1)
      62. Post = if(&loop < WLen,Mid$(Wort,&loop + 1,1),"")
      63. If InStr(c,"AEIJOUYÄÖÜ")
      64. erg = erg + "0"
      65. ElseIf c = "H"
      66. 'ignore
      67. ElseIf (c = "B") or ((c = "P") and (Post <> "H"))
      68. erg = erg + "1"
      69. ElseIf InStr(c,"DT") and not(InStr(Post,"CSZ"))
      70. erg = erg + "2"
      71. ElseIf InStr(c,"FVW") or ((c = "P") and (Post = "H"))
      72. erg = erg + "3"
      73. ElseIf InStr(c,"GKQ")
      74. erg = erg + "4"
      75. ElseIf (c = "C") and (InStr(Post,"AHKLOQRUX")) and (&loop = 0)
      76. erg = erg + "4"
      77. ElseIf (c = "C") and (InStr(Post,"AHKOQUX")) and not(InStr(Pre,"SZ"))
      78. erg = erg + "4"
      79. ElseIf (c = "X") and not(InStr(Pre,"CKQ"))
      80. erg = erg + "48"
      81. ElseIf (c = "L")
      82. erg = erg + "5"
      83. ElseIf InStr(c,"MN")
      84. erg = erg + "6"
      85. ElseIf (c = "R")
      86. erg = erg + "7"
      87. ElseIf InStr(c,"SZß")
      88. erg = erg + "8"
      89. ElseIf (c = "C") and (InStr(Pre,"SZ"))
      90. erg = erg + "8"
      91. ElseIf (c = "C") and Not(InStr(Post,"AHKLOQRUX")) and (&loop = 0)
      92. erg = erg + "8"
      93. ElseIf (c = "C") and Not(InStr(Post,"AHKOQUX"))
      94. erg = erg + "8"
      95. ElseIf InStr(c,"DT") and (InStr(Post,"CSZ"))
      96. erg = erg + "8"
      97. ElseIf (c = "X") and (InStr(Pre,"CKQ"))
      98. erg = erg + "8"
      99. Else
      100. 'Fehler
      101. EndIf
      102. EndWhile
      103. ' jetzt erg ausdünnen
      104. i = Len(erg)
      105. While i > 1
      106. c = Mid$(erg,i,1)
      107. Case (c = Mid$(erg,i - 1,1)) or (c = "0") : erg = Del$(erg,i,1)
      108. Dec i
      109. EndWhile
      110. EndIf
      111. Return erg
      112. EndProc
      113. proc x
      114. parameters string s
      115. print s,"=",KPhon(s),"--",Soundex(s)
      116. endproc
      117. Cls
      118. x("Wikipedia")
      119. x("Breschnew")
      120. x("Müller-Lüdenscheidt")
      121. x("Meier")
      122. x("Maier")
      123. x("Mayer")
      124. x("Mayr")
      125. x("Haus")
      126. x("Maus")
      127. x("frisch")
      128. x("Fisch")
      129. x("Waage")
      130. x("wiegen")
      131. x("Britney")
      132. x("Spears")
      133. x("bewährten")
      134. x("Superzicke")
      135. waitkey
      136. end
      Alles anzeigen
      Programmieren, das spannendste Detektivspiel der Welt.
    • Hallo Michael! Sehr nützliches Teil, ähnlich dem Levenshtein-Algorithmus (Wenn ich das richtig verstehe, müssten aus Effizienzgründen die Datenbankeinträge zusätzlich auch mit ihrem phonetischen Wert gemäß einem der beiden Systeme geführt werden).

      Bitte um Dein OK für Bekanntgabe meiner Rückübersetzung deiner Algorithmen nach XProfan11, in dem ich (zumindest bis X3 fertig ist) weiterhin programmiere. Selbstverständlich mit Hinweis auf deine Urheberschaft.
      Gruss, P. Specht

      P.S.: Deine Suchalgorithmen-Sammlung ist mir leider nicht zugänglich, der Provider verlangt ein Login. Ich kenne aber File-Provider, die das nicht erfordern, teste doch mal meinen und hole dir die Textdatei "Textdatei.txt" mit dem Inhalt "Textdatei" hier.
      Win7-64HomPremSP1,XProfan11.2a,XPIA,JWasm,xpse,IntelCoreQuad2.5GHz/4GB/je1TB HD intern:esataBay:USB3
    • Das Du immer alles so schnell haben willst -- wenn Du Slow Download wählst, dann bekommst das auch ohne Login...
      Sonst hätte ich weitergesucht oder die eigene Seite wieder entstaubt...

      Natürlich darfst Du alles verwursten, es sollen ja möglichst viele davon profitieren. Die Quelle war übrigens in allen Fällen die Wikipedia (nur den BoyerMoore Good_Tab hab ich weiter recherchieren müssen).
      Programmieren, das spannendste Detektivspiel der Welt.
    • Dankeeeeeeeeeeeeeeeeeeeeeeeeeeee!

      Quellcode

      1. ' Phonetische Suche
      2. ' - Soundex
      3. ' - Kölner Phonetik
      4. ' XProfan X11.2a
      5. Proc Soundex
      6. Parameters Wort$
      7. Declare c$,d$,e$
      8. Var erg$ = ""
      9. Wort$ = Upper$(Wort$)
      10. Wort$ = Translate$(Wort$,"ß","S")
      11. c$= "" : d$= "" : e$= ""
      12. WhileLoop Len(Wort$)
      13. Case InStr(Mid$(Wort$,&loop,1),"ABCDEFGHIJKLMNOPQRSTUVWXYZß")
      14. c$= c$+ Mid$(Wort$,&loop,1)
      15. EndWhile
      16. Wort$ = c$
      17. If Len(Wort$) = 1
      18. erg$ = Wort$
      19. ElseIf Len(Wort$) > 1
      20. erg$ = Left$(Wort$,1)
      21. WhileLoop 2,Len(Wort$)
      22. c$ = Mid$(Wort$,&loop,1)
      23. If InStr(c$,"BFPV")
      24. d$ = "1"
      25. ElseIf InStr(c$,"CGJKQSXZ")
      26. d$ = "2"
      27. ElseIf InStr(c$,"DT")
      28. d$ = "3"
      29. ElseIf InStr(c$,"L")
      30. d$ = "4"
      31. ElseIf InStr(c$,"MN")
      32. d$ = "5"
      33. ElseIf InStr(c$,"R")
      34. d$ = "6"
      35. EndIf
      36. If d$ <> e$
      37. erg$ = erg$ + d$
      38. e$ = d$
      39. EndIf
      40. Case Len(erg$) >= 4 : BREAK
      41. EndWhile
      42. EndIf
      43. erg$ = Left$(erg$ + "0000",4)
      44. Return erg$
      45. EndProc
      46. Proc KPhon
      47. Parameters Wort$
      48. Declare c$,Pre$,Post$, WLen&, i&
      49. Var erg$ = ""
      50. If Len(Wort$) > 0
      51. c$ = ""
      52. Wort$ = Upper$(Wort$)
      53. WhileLoop Len(Wort$)
      54. Case InStr(Mid$(Wort$,&loop,1),"ABCDEFGHIJKLMNOPQRSTUVWXYZÄÖÜß")
      55. c$ = c$ + Mid$(Wort$,&loop,1)
      56. EndWhile
      57. Wort$ = c$
      58. EndIf
      59. If Len(Wort$) > 0
      60. WLen& = Len(Wort$)
      61. WhileLoop WLen&
      62. Pre$ = if(&loop > 1,Mid$(Wort$,&loop - 1,1),"")
      63. c$ = Mid$(Wort$,&loop,1)
      64. Post$ = if(&loop < WLen&,Mid$(Wort$,&loop + 1,1),"")
      65. If InStr(c$,"AEIJOUYÄÖÜ")
      66. erg$ = erg$ + "0"
      67. ElseIf c$= "H"
      68. 'ignore
      69. ElseIf (c$ = "B") or ((c$ = "P") and (Post$ <> "H"))
      70. erg$ = erg$ + "1"
      71. ElseIf InStr(c$,"DT") and not(InStr(Post$,"CSZ"))
      72. erg$ = erg$ + "2"
      73. ElseIf InStr(c$,"FVW") or ((c$ = "P") and (Post$ = "H"))
      74. erg$ = erg$ + "3"
      75. ElseIf InStr(c$,"GKQ")
      76. erg$ = erg$ + "4"
      77. ElseIf (c$ = "C") and (InStr(Post$,"AHKLOQRUX")) and (&loop = 0)
      78. erg$ = erg$ + "4"
      79. ElseIf (c$ = "C") and (InStr(Post$,"AHKOQUX")) and not(InStr(Pre$,"SZ"))
      80. erg$ = erg$ + "4"
      81. ElseIf (c$ = "X") and not(InStr(Pre$,"CKQ"))
      82. erg$ = erg$ + "48"
      83. ElseIf (c$ = "L")
      84. erg$ = erg$ + "5"
      85. ElseIf InStr(c$,"MN")
      86. erg$ = erg$ + "6"
      87. ElseIf (c$ = "R")
      88. erg$ = erg$ + "7"
      89. ElseIf InStr(c$,"SZß")
      90. erg$ = erg$ + "8"
      91. ElseIf (c$ = "C") and (InStr(Pre$,"SZ"))
      92. erg$ = erg$ + "8"
      93. ElseIf (c$ = "C") and Not(InStr(Post$,"AHKLOQRUX")) and (&loop = 0)
      94. erg$ = erg$ + "8"
      95. ElseIf (c$ = "C") and Not(InStr(Post$,"AHKOQUX"))
      96. erg$ = erg$ + "8"
      97. ElseIf InStr(c$,"DT") and (InStr(Post$,"CSZ"))
      98. erg$ = erg$ + "8"
      99. ElseIf (c$ = "X") and (InStr(Pre$,"CKQ"))
      100. erg$ = erg$ + "8"
      101. Else
      102. 'Fehler
      103. EndIf
      104. EndWhile
      105. ' jetzt erg$ ausdünnen
      106. i& = Len(erg$)
      107. While i& > 1
      108. c$ = Mid$(erg$,i&,1)
      109. Case (c$ = Mid$(erg$,i& - 1,1)) or (c$ = "0") : erg$ = Del$(erg$,i&,1)
      110. Dec i&
      111. EndWhile
      112. EndIf
      113. Return erg$
      114. EndProc
      115. proc XP11
      116. parameters s$
      117. print s$,"=",tab(25);KPhon(s$),tab(40);"--",Soundex(s$)
      118. endproc
      119. Cls
      120. XP11("Wikipedia")
      121. XP11("Wikimedia")
      122. XP11("Wikipaedia")
      123. XP11("Wikipaedi")
      124. XP11("Wikibedia")
      125. XP11("Wikipetia")
      126. XP11("Breschnew")
      127. XP11("Müller-Lüdenscheidt")
      128. XP11("Meier")
      129. XP11("Maier")
      130. XP11("Mayer")
      131. XP11("Mayr")
      132. XP11("Haus")
      133. XP11("Maus")
      134. XP11("frisch")
      135. XP11("Fisch")
      136. XP11("Waage")
      137. XP11("wiegen")
      138. XP11("Britney")
      139. XP11("Spears")
      140. XP11("bewährten")
      141. XP11("Superzicke")
      142. waitkey
      143. end
      Alles anzeigen
      Win7-64HomPremSP1,XProfan11.2a,XPIA,JWasm,xpse,IntelCoreQuad2.5GHz/4GB/je1TB HD intern:esataBay:USB3