;------------------------------------------------------------------------------------------------------------------------------------------ #DefineFunction udfStrMetaphone (strString, intCodeLength) If strString == "" Then Return "" ; Make all characters uppercase. strString = StrUpper (strString) ; Remove all occurrences of non alpha chars. strString = StrClean (strString, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", "", @TRUE, 2) If strString == "" Then Return "" ; Set minimal default code length to 4 Byte. intCodeLength = Max (4, intCodeLength) ; Define vowels. strVowels = "AEIOU" Switch @TRUE Case StrSub (strString, 1, 2) == 'KN' strString = StrSub (strString, 2, -1) Break Case StrSub (strString, 1, 2) == 'GN' strString = StrSub (strString, 2, -1) Break Case StrSub (strString, 1, 2) == 'PN' strString = StrSub (strString, 2, -1) Break Case StrSub (strString, 1, 2) == 'AE' strString = StrSub (strString, 2, -1) Break Case StrSub (strString, 1, 2) == 'WR' strString = StrSub (strString, 2, -1) Break Case StrSub (strString, 1, 1) == 'X' strString = 'S' : StrSub (strString, 2, -1) Break Case StrSub (strString, 1, 2) == 'WH' strString = 'W' : StrSub (strString, 3, -1) Break EndSwitch intLen = StrLen (strString) strMetaphone = '' For intS = 1 To intLen If StrLen (strMetaphone) >= intCodeLength Then Break strChar = StrSub (strString, intS, 1) If strChar == StrSub (strString, intS + 1, 1) Then If strChar != 'C' Then Continue Switch @TRUE Case strChar == 'A' If intS == 1 Then strMetaphone = 'A' Break Case strChar == 'B' If !((intS == intLen) && (StrSub (strString, intS - 1, 1) == 'M')) Then strMetaphone = strMetaphone : 'B' Break Case strChar == 'C' If intS > 1 If StrSub (strString, intS - 1, 3) == 'SCI' Then Continue If StrSub (strString, intS - 1, 3) == 'SCE' Then Continue If StrSub (strString, intS - 1, 3) == 'SCY' Then Continue If StrSub (strString, intS - 1, 3) == 'SCH' strMetaphone = strMetaphone : 'K' intS = intS + 1 Continue EndIf EndIf Switch @TRUE Case StrSub (strString, intS + 1, 2) == 'IA' strMetaphone = strMetaphone : 'X' intS = intS + 2 Break Case StrSub (strString, intS + 1, 1) == 'I' strMetaphone = strMetaphone : 'S' intS = intS + 1 Break Case StrSub (strString, intS + 1, 1) == 'E' strMetaphone = strMetaphone : 'S' intS = intS + 1 Break Case StrSub (strString, intS + 1, 1) == 'Y' strMetaphone = strMetaphone : 'S' intS = intS + 1 Break Case StrSub (strString, intS + 1, 1) == 'H' If !StrIndex (strVowels, StrSub (strString, intS + 2, 1), 1, @FWDSCAN) ; Added for 'K' in 'Ch'ristus ; DD.20020727. strMetaphone = strMetaphone : 'K' ; Added for 'K' in 'Ch'ristus ; DD.20020727. Else strMetaphone = strMetaphone : 'X' EndIf intS = intS + 1 Break Case @TRUE strMetaphone = strMetaphone : 'K' Break EndSwitch Break Case strChar == 'D' Switch @TRUE Case StrSub (strString, intS + 1, 2) == 'GE' strMetaphone = strMetaphone : 'J' intS = intS + 2 Break Case StrSub (strString, intS + 1, 2) == 'GY' strMetaphone = strMetaphone : 'J' intS = intS + 2 Break Case StrSub (strString, intS + 1, 2) == 'GI' strMetaphone = strMetaphone : 'J' intS = intS + 2 Break Case @TRUE strMetaphone = strMetaphone : 'T' Break EndSwitch Break Case strChar == 'E' If intS == 1 Then strMetaphone = 'E' Break Case strChar == 'F' strMetaphone = strMetaphone : 'F' Break Case strChar == 'G' Switch @TRUE Case StrSub (strString, intS + 1, 1) == 'H' If (intS + 1) == intLen Then strMetaphone = strMetaphone : 'K' strCharSub = StrSub (strString, intS + 2, 1) If (strCharSub != '') && !!StrIndex (strVowels, strCharSub, 1, @FWDSCAN) Then strMetaphone = strMetaphone : 'K' intS = intS + 1 Break Case StrSub (strString, intS + 1, 1) == 'N' intS = intS + 1 Break Case StrSub (strString, intS + 1, 3) == 'NED' intS = intS + 3 Break Case StrSub (strString, intS + 1, 1) == 'I' If (intS > 1) && (StrSub (strString, intS - 1, 1) == 'G') strMetaphone = strMetaphone : 'K' Else strMetaphone = strMetaphone : 'J' EndIf intS = intS + 1 Break Case StrSub (strString, intS + 1, 1) == 'E' If (intS > 1) && (StrSub (strString, intS - 1, 1) == 'G') strMetaphone = strMetaphone : 'K' Else strMetaphone = strMetaphone : 'J' EndIf intS = intS + 1 Break Case StrSub (strString, intS + 1, 1) == 'Y' If (intS > 1) && (StrSub (strString, intS - 1, 1) == 'G') strMetaphone = strMetaphone : 'K' Else strMetaphone = strMetaphone : 'J' EndIf intS = intS + 1 Break Case 1 strMetaphone = strMetaphone : 'K' Break EndSwitch Break Case strChar == 'H' OK = 1 If intS > 1 strCharSub = StrSub (strString, intS - 1, 1) If (strCharSub != '') && !!StrIndex (strVowels, strCharSub, 1, @FWDSCAN) strCharSub = StrSub (strString, intS + 1, 1) If (strCharSub != '') && !StrIndex (strVowels, strCharSub, 1, @FWDSCAN) Then OK = 0 EndIf Else strCharSub = StrSub (strString, intS + 1, 1) If (strCharSub != '') && !StrIndex (strVowels, strCharSub, 1, @FWDSCAN) Then OK = 0 EndIf If OK Then strMetaphone = strMetaphone : 'H' Break Case strChar == 'I' If intS == 1 Then strMetaphone = 'I' Break Case strChar == 'J' strMetaphone = strMetaphone : 'J' Break Case strChar == 'K' OK = 1 If intS > 1 Then If StrSub (strString, intS - 1, 1) == 'C' Then OK = 0 If OK Then strMetaphone = strMetaphone : 'K' Break Case strChar == 'L' strMetaphone = strMetaphone : 'L' Break Case strChar == 'M' strMetaphone = strMetaphone : 'M' Break Case strChar == 'N' strMetaphone = strMetaphone : 'N' Break Case strChar == 'O' If intS == 1 Then strMetaphone = 'O' Break Case strChar == 'P' If StrSub (strString, intS + 1, 1) == 'H' strMetaphone = strMetaphone : 'F' intS = intS + 1 Else strMetaphone = strMetaphone : 'P' EndIf Break Case strChar == 'Q' strMetaphone = strMetaphone : 'K' Break Case strChar == 'R' strMetaphone = strMetaphone : 'R' Break Case strChar == 'S' Switch @TRUE Case StrSub (strString, intS + 1, 1) == 'H' strMetaphone = strMetaphone : 'X' intS = intS + 1 Break Case StrSub (strString, intS + 1, 2) == 'IO' strMetaphone = strMetaphone : 'X' intS = intS + 2 Break Case StrSub (strString, intS + 1, 2) == 'IA' strMetaphone = strMetaphone : 'X' intS = intS + 2 Break Case @TRUE strMetaphone = strMetaphone : 'S' Break EndSwitch Break Case strChar == 'T' Switch @TRUE Case StrSub (strString, intS + 1, 2) == 'IA' strMetaphone = strMetaphone : 'X' intS = intS + 2 Break Case StrSub (strString, intS + 1, 2) == 'IO' strMetaphone = strMetaphone : 'X' intS = intS + 2 Break Case StrSub (strString, intS + 1, 2) == 'CH' strMetaphone = strMetaphone : 'X' ; Added because "TCH" is not silent. ; DD.20100206. intS = intS + 2 Break Case StrSub (strString, intS + 1, 1) == 'H' If StrSub (strString, intS, 4) == 'THOM' Then strMetaphone = strMetaphone : 'T' ; Added because "THOMAS" sounds better with "T" than "0" ; DD.20100206. Else strMetaphone = strMetaphone : '0' ; "TH" = "0" = zero. intS = intS + 1 Break Case @TRUE strMetaphone = strMetaphone : 'T' Break EndSwitch Break Case strChar == 'U' If intS == 1 Then strMetaphone = 'U' Break Case strChar == 'V' strMetaphone = strMetaphone : 'F' Break Case strChar == 'W' strCharSub = StrSub (strString, intS + 1, 1) If (strCharSub != '') && !!StrIndex (strVowels, strCharSub, 1, @FWDSCAN) Then strMetaphone = strMetaphone : 'W' Break Case strChar == 'X' strMetaphone = strMetaphone : 'KS' Break Case strChar == 'Y' strCharSub = StrSub (strString, intS + 1, 1) If (strCharSub != '') && !!StrIndex (strVowels, strCharSub, 1, @FWDSCAN) Then strMetaphone = strMetaphone : 'Y' Break Case strChar == 'Z' strMetaphone = strMetaphone : 'S' Break EndSwitch Next Return strMetaphone ;.......................................................................................................................................... ; This UDF "udfStrMetaphone" returns a string with a typical length of 1..4 Byte, ; which represents the phonetic sound of the given input string, ; based on simple phonetic rules for typical spoken English. ; The Metaphone algorithm does group names together that are more closely related than Soundex does. ; ; The Metaphone Algorithm was first published by Lawrence Philips in article ; "Hanging on the Metaphone", Computer Language v7 n12, December 1990, pp39-43. ; Lawrence Philips has written his Metaphone routine in Pick/BASIC. ; ; In the meantime the code has been ported to numerous other programming language platforms, ; merely bug fixed and often tweaked to fit to the needs of the world. ; A good source for further information is this group at Sourceforge: http://aspell.sourceforge.net/metaphone/ ; ; This WinBatch implementation is a port of a D3BASIC script, which relies on the originally 1990 algorithm description ; but provides a more structured and better readable code design than the first published BASIC code. ; The D3BASIC code is provided by "bryanb@webbtide.com", referenced by http://svc423.bne034u.server-web.com/bjb/metaphone.bas. ; The Author's webpage is http://svc423.bne034u.server-web.com/bjbhtml/metaphone.html. ; ; I think that the WinBatch code does what it should do. So use it. ; ; Detlev Dalitz.20020727.20100206. ;.......................................................................................................................................... #EndFunction ;------------------------------------------------------------------------------------------------------------------------------------------ ; Test. strList = "This is WinBatch code." ;1 This is WinBatch code. 0SSWNBXKT ; "0" is "th". strList = strList : @LF : "Detlev Dalitz" ;2 Detlev Dalitz TTLFTLTS strList = strList : @LF : "Angelika" ;3 Angelika ANJLK strList = strList : @LF : "Christopher" ;4 Christopher KRSTFR strList = strList : @LF : "Sabine" ;5 Sabine SBN strList = strList : @LF : "Daniel" ;6 Daniel TNL strList = strList : @LF : "Margot" ;7 Margot MRKT strList = strList : @LF : "Otto" ;8 Otto OT strList = strList : @LF : "McComb" ;9 McComb MKKM strList = strList : @LF : "Susan" ;10 Susan SSN strList = strList : @LF : "Souzanna" ;11 Souzanna SSN strList = strList : @LF : "Schubert" ;12 Schubert SKBRT ; German: Should be pre-processed from "SCH" to "SH". strList = strList : @LF : "Shubert" ;13 Shubert XBRT strList = strList : @LF : "technical" ;14 technical TKNKL strList = strList : @LF : "chemical" ;15 chemical XMKL strList = strList : @LF : "Lee" ;16 Lee L strList = strList : @LF : "Bonner" ;17 Bonner BNR strList = strList : @LF : "Baymore" ;18 Baymore BMR strList = strList : @LF : "Saneed" ;19 Saneed SNT strList = strList : @LF : "Van Hoesen" ;20 Van Hoesen FNHSN strList = strList : @LF : "Vincenco" ;21 Vincenco FNSNK ; Italian: Should be more like "FNSNS". strList = strList : @LF : "Jürgen von Manger" ;22 Jürgen von Manger JRJNFNMNJR strList = strList : @LF : "Edgar Wallace" ;23 Edgar Wallace ETKRWLS strList = strList : @LF : "Stuart Granger" ;24 Stuart Granger STRTKRNJR strList = strList : @LF : "Roger Daltry" ;25 Roger Daltry RJRTLTR strList = strList : @LF : "Lukasiewicz" ;26 Lukasiewicz LKSWKS strList = strList : @LF : "Van Houten" ;27 Van Houten FNHTN strList = strList : @LF : "Kuczewski" ;28 Kuczewski KKSSK strList = strList : @LF : "Bordeaux" ;29 Bordeaux BRTKS strList = strList : @LF : "Breaux" ;30 Breaux BRKS strList = strList : @LF : "Zhao" ;31 Zhao SH strList = strList : @LF : "Womo" ;32 Womo WM strList = strList : @LF : "Uomo" ;33 Uomo UM strList = strList : @LF : "Arnoff" ;34 Arnoff ARNF strList = strList : @LF : "Arnow" ;35 Arnow ARN strList = strList : @LF : "Filipovicz" ;36 Filipovicz FLPFKS strList = strList : @LF : "Vasserman" ;37 Vasserman FSRMN strList = strList : @LF : "Wassermann" ;38 Wassermann WSRMN strList = strList : @LF : "Thames" ;39 Thames 0MS ; "0" is "th". strList = strList : @LF : "Thomas" ;40 Thomas TMS ; Special case "THOM" gives "T". strList = strList : @LF : "school" ;41 school SKL strList = strList : @LF : "schooner" ;42 schooner SKNR strList = strList : @LF : "schenker" ;43 schenker SKNKR strList = strList : @LF : "snider" ;44 snider SNTR strList = strList : @LF : "schneider" ;45 schneider SKNTR strList = strList : @LF : "schmidt" ;46 schmidt SKMTT strList = strList : @LF : "smith" ;47 smith SM0 ; "0" is "th". strList = strList : @LF : "Carlysle" ;48 Carlysle KRLSL strList = strList : @LF : "Carlisle" ;49 Carlisle KRLSL strList = strList : @LF : "Eisel" ;50 Eisel ESL strList = strList : @LF : "Isle" ;51 Isle ISL strList = strList : @LF : "Island" ;52 Island ISLNT strList = strList : @LF : "Rogier" ;53 Rogier RJR strList = strList : @LF : "Hochmeier" ;54 Hochmeier HKMR strList = strList : @LF : "Raspberry" ;55 Raspberry RSPBR strList = strList : @LF : "Campbell" ;56 Campbell KMPBL strList = strList : @LF : "Gallegos" ;57 Gallegos KLKS strList = strList : @LF : "Cabrillo" ;58 Cabrillo KBRL strList = strList : @LF : "Señor" ;59 Señor SR strList = strList : @LF : "Jablunowski" ;60 Jablunowski JBLNSK strList = strList : @LF : "Yankelovich" ;61 Yankelovich YNKLFX strList = strList : @LF : "Jankelowicz" ;62 Jankelowicz JNKLWKS strList = strList : @LF : "bajador" ;63 bajador BJTR strList = strList : @LF : "San Jacinto" ;64 San Jacinto SNJSNT strList = strList : @LF : "Jose" ;65 Jose JS strList = strList : @LF : "Cagney" ;66 Cagney K strList = strList : @LF : "Biaggi" ;67 Biaggi BK strList = strList : @LF : "tagliaro" ;68 tagliaro TKLR strList = strList : @LF : "McLaughlin" ;69 McLaughlin MKLLN strList = strList : @LF : "broughton" ;70 broughton BRTN strList = strList : @LF : "bough" ;71 bough BK strList = strList : @LF : "hugh" ;72 hugh HK strList = strList : @LF : "ghislane" ;73 ghislane KSLN strList = strList : @LF : "ghiradelli" ;74 ghiradelli KRTL strList = strList : @LF : "Toto" ;75 Toto TT strList = strList : @LF : "Edgar" ;76 Edgar ETKR strList = strList : @LF : "mac gregor" ;77 mac gregor MKKRKR strList = strList : @LF : "mac caffrey" ;78 mac caffrey MKKFR strList = strList : @LF : "McHugh" ;79 McHugh MXK strList = strList : @LF : "Bacchus" ;80 Bacchus BKXS strList = strList : @LF : "Bellocchio" ;81 Bellocchio BLKX strList = strList : @LF : "Bertucci" ;82 Bertucci BRTKS strList = strList : @LF : "Bacci" ;83 Bacci BKS strList = strList : @LF : "Broccoli" ;84 Broccoli BRKKL strList = strList : @LF : "Focaccia" ;85 Focaccia FKKX strList = strList : @LF : "Czerny" ;86 Czerny KSRN strList = strList : @LF : "Tucker" ;87 Tucker TKR strList = strList : @LF : "Tuchner" ;88 Tuchner TKNR strList = strList : @LF : "Tischler" ;89 Tischler TSKLR strList = strList : @LF : "Wechsler" ;90 Wechsler WKSLR strList = strList : @LF : "Wachtler" ;91 Wachtler WKTLR strList = strList : @LF : "Orchester" ;92 Orchester ORXSTR strList = strList : @LF : "Architekt" ;93 Architekt ARXTKT strList = strList : @LF : "chorus" ;94 chorus XRS strList = strList : @LF : "chemistry" ;95 chemistry XMSTR strList = strList : @LF : "Michaelis" ;96 Michaelis MXLS strList = strList : @LF : "Kant" ;97 Kant KNT strList = strList : @LF : "Chianti" ;98 Chianti XNT strList = strList : @LF : "Caesar" ;99 Caesar KSR strList = strList : @LF : "Aschenbecher" ;100 Aschenbecher ASKNBXR strList = strList : @LF : "Achenbacher" ;101 Achenbacher AXNBXR strList = strList : @LF : "Garçon" ;102 Garçon KRN strList = strList : @LF : "dumb" ;103 dumb TM strList = strList : @LF : "Xavier" ;104 Xavier SFR strList = strList : @LF : "Thrash" ;105 Thrash 0RX ; "0" is "th". strList = strList : @LF : "Matthew" ;106 Matthew M0 ; "0" is "th". strList = strList : @LF : "Matthies" ;107 Matthies M0S ; "0" is "th". ; German: Should be "MTS"; Should be pre-processed from "TTH" to "T". strList = strList : @LF : "Christus" ;108 Christus KRSTS strFileOut = ShortCutDir ("Local Settings") : "\Temp\" : StrInsert (StrReplace (TimeYmdHms (), ":", ""), ".", "", 9, 1) : ".FileOut.txt" strOut = "" intItem = 0 intCodeLen = 10 BoxOpen ("Demo udfStrMetaphone (strString, intCodeLength)", "") BoxDataTag (1, 1) ForEach strItem In ObjectType ("ARRAY", Arrayize (strList, @LF)) strResult = udfStrMetaphone (strItem, intCodeLen) intItem = intItem + 1 strOut = strOut : @CRLF : StrFix (intItem, " ", 5) : StrFix (strItem, " ", 30) : @TAB : StrFix (strResult, " ", intCodeLen) strMsgText = "Item : " : intItem : @LF : "Name : " : strItem : @LF : "Code : " : strResult BoxTextFont (1, "", 100, 40, 1 | 64) BoxText (strMsgText) BoxDataClear (1, 1) Next BoxShut () FilePut (strFileOut, StrSub (strOut, 3, -1)) Run (strFileOut, "") Exit ;-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------