Something that has been floating around in my "to-do" list for quite some time is to write a class for phonetic keyword matching in a fox database.
The idea is for it to be a step down from PhDbase (link) without losing the functionality I personally find most useful, phonetic matching.
At the core of this class is a VFP version of the Double Metaphone algorithm (link) originally written by Lawrence Philips in C/C++.
This isn't the tidiest piece of code floating around the internet, but it is still pretty clever, and I hope to someday soon find the time to wrap it in a class with some support for boolean logic and a good word boundary algorithm for indexing.
Code
function double_metaphone(cStr as String)local cP, cS, nCur, nLen, cOrig, isSlavo, cRest
cP= ''
cS= ''
nCur= 1
nLen= len(m.cStr)
cOrig= upper(m.cStr) + space(5)
isSlavo= Slavo_Germanic(m.cOrig)
cRest= m.cOrig
* skip this at beginning of word
if inlist(m.cOrig, 'GN','KN','PN','WR','PS')
nCur = m.nCur + 1
endif
* Initial 'X' is pronounced 'Z' e.g. 'Xavier'
if (m.cOrig = 'X')
cP= m.cP + "S"
cS= m.cS + "S"
nCur = nCur + 1
endif
* Main Loop
do while (len(m.cP) < 4 or len(m.cS) < 4) and m.nCur <= m.nLen
local cLet
cLet= substr(m.cOrig, m.nCur, 1)
cRest= substr(m.cOrig, m.nCur)
do case
case m.cLet $ 'AEIOU'
* do nothing
nCur= m.nCur + 1
case m.cLet = 'Y'
if m.nCur = 1
cP= m.cP + 'A'
cS= m.cS + 'A'
endif
nCur = nCur + 1
case m.cLet = 'B'
* '-mb', e.g. "dumb", already skipped over ...
cP= m.cP + 'P'
cS= m.cS + 'P'
if m.cRest = 'BB'
nCur = nCur + 2
else
nCur = nCur + 1
endif
case m.cLet = chr(199) &&
cP= m.cP + 'S'
cS= m.cS + 'S'
nCur = nCur + 1
case m.cLet = 'C'
* Various germanic
if m.nCur > 2 and !is_vowel(m.cOrig, m.nCur - 2) ;
and substr(m.cOrig, m.nCur - 1, 3) = "ACH" ;
and (substr(m.cOrig, m.nCur + 2, 1) # 'I' ;
and (substr(m.cOrig, m.nCur + 2, 1) # 'E' ;
or inlist(substr(m.cOrig, m.nCur - 2, 6), "BACHER", "MACHER")))
cP= m.cP + 'K'
cS= m.cS + 'K'
nCur = m.nCur + 2
loop
endif
* special case 'caesar'
if m.nCur = 1 and m.cOrig = "CAESAR"
cP = cP + 'S'
cS = cS + 'S'
nCur= m.nCur + 2
loop
endif
* italian 'chianti'
if m.cRest = "CHIA"
cP = cP + 'K'
cS = cS + 'K'
nCur= m.nCur + 2
loop
endif
if m.cRest = "CH"
* Find michael
if m.nCur > 1 and m.cRest = "CHAE"
cP= m.cP + "K"
cS= m.cS + "X"
nCur = nCur + 2
loop
endif
* greek roots e.g. 'chemistry', 'chorus'
if (m.nCur = 1 and ;
inlist(m.cRest, "CHARAC", "CHARIS", "CHOR", "CHYM", "CHIA", "CHEM") ;
and m.cOrig != "CHORE")
cP= m.cP + 'K'
cS= m.cS + 'K'
nCur = nCur + 2
loop
endif
if inlist(m.cOrig, "VAN ", "VON ", "SCH") ;
or inlist(substr(m.cOrig, m.nCur - 2, 6), "ORCHES", "ARCHIT", "ORCHID") ;
or substr(m.cOrig, m.nCur + 2, 1) $ "TS" ;
or (substr(m.cOrig, m.nCur - 1, 1) $ "AOUE" or m.nCur = 1)
cP= m.cP + 'K'
cS= m.cS + 'K'
else
if m.nCur > 1
if m.cOrig = "MC"
cP= m.cP + 'K'
cS= m.cS + 'K'
else
cP= m.cP + 'X'
cS= m.cS + 'K'
endif
else
m.cP = m.cP + 'X'
m.cS = m.cS + 'X'
endif
endif
nCur = nCur + 2
loop
endif
* e.g. 'czerny'
if m.cRest = "CZ" ;
and substr(m.cOrig, m.nCur - 2, 4) # "WICZ"
cP= m.cP + "S"
cS= m.cS + "X"
nCur= m.nCur + 2
loop
endif
* eg focaccia
if m.cRest = "CCIA"
cP= m.cP + 'X'
cS= m.cS + 'X'
nCur= m.nCur + 3
loop
endif
* double 'C', but not McClellan'
if m.cRest = "CC" and !(m.nCur = 2 and m.cOrig = "M")
* 'bellocchio' but not 'bacchus'
if substr(m.cOrig, m.nCur + 2, 1) $ 'IEH' ;
and substr(m.cOrig, m.nCur + 2, 2) # 'HU'
*'accident', 'accede', 'succeed'
if (m.nCur != 2 and substr(m.cOrig, m.nCur -1, 1) = "A") ;
or inlist(m.cOrig, "UCCEE", "UCCES")
cP= m.cP + "KS"
cS= m.cS + "KS"
else
cP= m.cP + "X"
cS= m.cS + "X"
endif
nCur= m.nCur + 3
loop
else
* Pierce's rule
cP= m.cP + 'K'
cS= m.cS + 'K'
nCur= m.nCur + 2
loop
endif
endif
if inlist(m.cRest, "CK", "CG", "CQ")
cP= m.cP + 'K'
cS= m.cS + 'K'
nCur= m.nCur + 2
loop
endif
if inlist(m.cRest, "CI", "CE", "CY")
if inlist(m.cRest, "CIO", "CIE", "CIA")
cP= m.cP + "S"
cS= m.cS + "X"
else
cP= m.cP + "S"
cS= m.cS + "S"
endif
nCur= m.nCur + 2
loop
endif
* else case
cP= m.cP + 'K'
cS= m.cS + 'K'
if inlist(m.cRest, "C C", "C Q", "C G")
nCur= m.nCur + 3
else
if inlist(m.cRest, "CC", "CK", "CQ")
nCur= m.nCur + 2
else
nCur= m.nCur + 1
endif
endif
case m.cLet = 'D'
if m.cRest = "DG"
if inlist(m.cRest, "DGI", "DGE", "DGY")
cP = cP + 'J'
cS = cS + 'J'
nCur = nCur + 2
loop
else
cP = cP + 'TK'
cS = cS + 'TK'
nCur= m.nCur + 2
loop
endif
endif
if inlist(m.cRest, "DT", "DD")
cP = cP + "T"
cS = cS + "T"
nCur = nCur + 2
loop
endif
cP = cP + "T"
cS = cS + "T"
nCur = nCur + 1
case m.cLet = 'F'
if m.cRest = "FF"
nCur= m.nCur + 2
else
nCur= m.nCur + 1
endif
cP= m.cP + "F"
cS= m.cS + "F"
case m.cLet = 'G'
if m.cRest = "GH"
if m.nCur > 1 and !is_vowel(m.cOrig, m.nCur - 1)
cP= m.cP + "K"
cS= m.cS + "K"
nCur= m.nCur + 2
loop
endif
* 'ghislane', 'ghiradelli'
if m.nCur = 1
if m.cRest = "GHI"
cP= m.cP + "J"
cS= m.cS + "J"
else
cP=m.cP + "K"
cS= m.cS + "K"
endif
nCur= m.nCur + 2
loop
endif
if (m.nCur > 2 and substr(m.cOrig, m.nCur - 2, 1) $ "BHD") ;
or (m.nCur > 3 and substr(m.cOrig, m.nCur - 3, 1) $ 'BHD') ;
or (m.nCur > 4 and substr(m.cOrig, m.nCur - 4, 1) $ 'BH')
nCur= m.nCur + 2
loop
else
if m.nCur > 3 and substr(m.cOrig, m.nCur - 1, 1) = "U" ;
and substr(m.cOrig, m.nCur - 3, 1) $ 'CGLRT'
cP= m.cP + 'F'
cS= m.cS + 'F'
else
if (m.nCur > 1) and substr(m.cOrig, m.nCur - 1, 1) # 'I'
cP= m.cP + 'K'
cS= m.cS + 'K'
endif
endif
m.nCur = m.nCur + 2
loop
endif
endif
if m.cRest = "GN"
if m.nCur = 2 and is_vowel(m.cOrig, 1) and !m.isSlavo
cP= m.cP + "KN"
cS= m.cS + "N"
else
if m.cRest != "GNEY" and !m.isSlavo
cP= m.cP + "N"
cS= m.cS + "KN"
else
cP= m.cP + "KN"
cS= m.cS + "KN"
endif
endif
nCur= m.nCur + 2
loop
endif
* tagliaro
if m.cRest= "GLI" and !m.isSlavo
cP= m.cP + "KL"
cS= m.cS + "L"
nCur= m.nCur + 2
loop
endif
* ges-, gep-, gel- at beginning
if inlist(m.cOrig, "GES","GEP","GEB","GEL","GEY","GIB","GIL","GIN","GIE","GEI","GER","GY")
cP= m.cP + "K"
cS= m.cS + "J"
nCur= m.nCur + 2
loop
endif
* -ger-, -gy-
if (m.cRest = "GER" or m.cRest = "GY") ;
and !inlist(m.cOrig, "DANGER","RANGER", "MANGER") ;
and !substr(m.cOrig, m.nCur - 1, 1) $ "EI" ;
and !inlist(substr(m.cOrig, m.nCur - 1, 3), "RGY", "OGY")
cP= m.cP + "K"
cS= m.cS + "J"
nCur= m.nCur + 2
loop
endif
* italian e.g. 'biaggi'
if inlist(m.cRest, "GE", "GI", "GY") ;
or inlist(substr(m.cOrig, m.nCur - 1, 4), "AGGI", "OGGI")
if inlist(m.cOrig, "VAN ", "VON ", "SCH") or m.cRest = "GET"
cP= m.cP + "K"
cS= m.cS + "K"
else
if m.cRest = "GIER "
cP= m.cP + "J"
cS= m.cS + "J"
else
cP= m.cP + "J"
cS= m.cS + "K"
endif
endif
nCur= m.nCur + 2
loop
endif
if m.cRest = "GG"
nCur= m.nCur + 2
else
nCur= m.nCur + 1
endif
cP= m.cP + "K"
cS= m.cS + "K"
case m.cLet = "H"
if (m.nCur = 1 or is_vowel(m.cOrig, m.nCur - 1)) and is_vowel(m.cOrig, m.nCur + 1)
cP= m.cP + "H"
cS= m.cS + "H"
nCur= m.nCur + 2
else
nCur= m.nCur + 1
endif
case m.cLet = "J"
* obvious spanish, 'jose', 'san jacinto'
if m.cRest = "JOSE" ;
or m.cOrig = "SAN "
if (m.nCur = 1 and substr(m.cOrig, m.nCur + 4, 1) = " ") ;
or m.cOrig = "SAN "
cP= m.cP + "H"
cS= m.cS + "H"
else
cP= m.cP + "J"
cS= m.cS + "H"
endif
nCur= m.nCur + 1
loop
endif
if m.nCur = 1 and m.cRest # "JOSE"
cP= m.cP + "J"
cS= m.cS + "A"
else
* spanish pron. of .e.g. 'bajador'
if is_vowel(m.cOrig, m.nCur - 1) ;
and !m.isSlavo ;
and (m.cRest = "JA" ;
or m.cRest = "JO")
cP= m.cP + "J"
cS= m.cS + "H"
else
if m.nCur = m.nLen
cP= m.cP + "J"
cS= m.cS + ""
else
if !inlist(m.cRest, "JL","JT","JK","JS","JN","JM","JB","JZ") ;
and !substr(m.cOrig, m.nCur - 1, 1) $ "SKL"
cP= m.cP + "J"
cS= m.cS + "J"
endif
endif
endif
endif
if m.cRest = "JJ"
nCur= m.nCur + 2
else
nCur = m.nCur + 1
endif
case m.cLet = "K"
if m.cRest = "KK"
nCur= m.nCur + 2
else
nCur= m.nCur + 1
endif
cP= m.cP + "K"
cS= m.cS + "K"
case m.cLet = "L"
if m.cRest = "LL"
&& spanish e.g. 'cabrillo', 'gallegos'
if (m.nCur = m.nLen - 3 ;
and inlist(substr(m.cOrig, m.nCur - 1, 4), "ILLO", "ILLA", "ALLE")) ;
or ((inlist(right(m.cOrig, 2), "AS", "OS") ;
or right(m.cOrig, 1) $ "AO") ;
and substr(m.cOrig, m.nCur - 1, 4) = "ALLE")
cP= m.cP + "L"
cS= m.cS + ""
nCur= m.nCur + 2
loop
endif
nCur= m.nCur + 2
else
nCur= m.nCur + 1
endif
cP= m.cP + "L"
cS= m.cS + "L"
case m.cLet = "M"
if (substr(m.cOrig, m.nCur - 1, 3) = "UMB" ;
and m.nCur + 1 = m.nLen) ;
or substr(m.cOrig, m.nCur + 2, 2) = "ER" ;
or m.cRest = "MM"
*'dumb', 'thumb'
nCur= m.nCur + 2
else
nCur= m.nCur + 1
endif
cP= m.cP + "M"
cS= m.cS + "M"
case m.cLet= "N"
if m.cRest = "NN"
nCur= m.nCur + 2
else
nCur= m.nCur + 1
endif
cP= m.cP + "N"
cS= m.cS + "N"
case m.cLet = chr(209) &&
nCur= m.nCur + 1
cP= m.cP + "N"
cS= m.cS + "N"
case m.cLet = "P"
if m.cRest = "PH"
nCur= m.nCur + 2
cP= m.cP + "F"
cS= m.cS + "F"
loop
endif
* also account for "campbell" and "raspberry"
if inlist(m.cRest, "PP", "PB")
nCur= m.nCur + 2
else
nCur= m.nCur + 1
endif
cP= m.cP + "P"
cS= m.cS + "P"
case m.cLet = "Q"
if m.cRest = "QQ"
nCur= m.nCur + 2
else
nCur = m.nCur + 1
endif
cP= m.cP + "K"
cS= m.cS + "K"
case m.cLet = "R"
* french e.g. 'rogier', but exclude 'hochmeier'
if m.nCur = m.nLen and !m.isSlavo ;
and substr(m.cOrig, m.nCur - 2, 2) = "IE" ;
and !inlist(substr(m.cOrig, m.nCur - 4, 2), "ME", "MA")
cP= m.cP + ""
cS= m.cS + "R"
else
cP= m.cP + "R"
cS= m.cS + "R"
endif
if m.cRest = "RR"
nCur= m.nCur + 2
else
nCur= m.nCur + 1
endif
case m.cLet = "S"
* special cases 'island', 'isle', 'carlisle', 'carlysle'
if inlist(substr(m.cOrig, m.nCur - 1, 3), "ISL", "YSL")
nCur= m.nCur + 1
loop
endif
* special case 'sugar-'
if m.nCur = 1 and m.cOrig = "SUGAR"
cP= m.cP + "X"
cS= m.cS + "S"
nCur= m.nCur + 1
loop
endif
if m.cRest = "SH"
* germanic
if inlist(m.cRest, "SHEIM","SHOEK","SHOLM","SHOLZ")
cP= m.cP + "S"
cS= m.cS + "S"
else
cP= m.cP + "X"
cS= m.cS + "X"
endif
nCur= m.nCur + 2
loop
endif
* italian & armenian
if inlist(m.cRest, "SIO", "SIA")
if !m.isSlavo
cP= m.cP + "S"
cS= m.cS + "X"
else
cP= m.cP + "S"
cS= m.cS + "S"
endif
nCur= m.nCur + 3
loop
endif
* german & anglicisations, e.g. 'smith' match 'schmidt', 'snider' match 'schneider'
* also, -sz- in slavic language altho in hungarian it is pronounced 's'
if (m.nCur = 1 and inlist(m.cRest, "SM","SN","SL","SW")) ;
or m.cRest = "SZ"
cP= m.cP + "S"
cS= m.cS + "X"
if m.cRest = "SZ"
nCur= m.nCur + 2
else
nCur= m.nCur + 1
endif
loop
endif
if m.cRest = "SC"
* Schlesinger's rule
if m.cRest = "SCH"
* dutch origin, e.g. 'school', 'schooner'
if inlist(m.cRest, "SCHOO","SCHER","SCHEN","SCHUY","SCHED","SCHEM")
* 'schermerhorn', 'schenker'
if inlist(m.cRest, "SCHER", "SCHEN")
cP= m.cP + "X"
cS= m.cS + "SK"
else
cP= m.cP + "SK"
cS= m.cS + "SK"
endif
nCur= m.nCur + 3
loop
else
if m.nCur = 1 ;
and !is_vowel(m.cOrig, 3) ;
and m.cRest # "SCHW"
cP= m.cP + "X"
cS= m.cS + "S"
else
cP= m.cP + "X"
cS= m.cS + "X"
endif
nCur= m.nCur + 3
loop
endif
endif && H
if inlist(m.cRest, "SCI", "SCE", "SCY")
cP= m.cP + "S"
cS= m.cS + "S"
nCur= m.nCur + 3
loop
endif
cP= m.cP + "SK"
cS= m.cS + "SK"
nCur= m.nCur + 3
loop
endif && "SC"
* french e.g. 'resnais', 'artois'
if m.nCur = m.nLen and inlist(right(m.cOrig, 2), "AI", "OI")
cP= m.cP + ""
cS= m.cS + "S"
else
cP= m.cP + "S"
cS= m.cS + "S"
endif
if inlist(m.cRest, "SS", "SZ")
nCur= m.nCur + 2
else
nCur= m.nCur + 1
endif
case m.cLet = "T"
if inlist(m.cRest, "TION", "TIA", "TCH")
cP= m.cP + "X"
cS= m.cS + "X"
nCur= m.nCur + 3
loop
endif
if m.cRest = "TH" or m.cRest = "TTH"
* special case 'thomas', 'thames' or germanic
if inlist(m.cRest, "THOM", "THAM") ;
or inlist(m.cOrig, "VAN ", "VON ", "SCH")
cP= m.cP + "T"
cS= m.cS + "T"
else
cS= m.cS + "O"
cS= m.cS + "T"
endif
nCur= m.nCur + 2
loop
endif
if inlist(m.cRest, "TT", "TD")
nCur= m.nCur + 2
else
nCur= m.nCur + 1
endif
cP= m.cP + "T"
cS= m.cS + "T"
case m.cLet = "V"
if m.cRest = "VV"
nCur= m.nCur + 2
else
nCur= m.nCur + 1
endif
cP= m.cP + "F"
cS= m.cS + "F"
case m.cLet = "W"
* can also be in middle of word
if m.cRest = "WR"
cP= m.cP + "R"
cS= m.cS + "R"
nCur= m.nCur + 2
loop
endif
if m.nCur = 1 ;
and (is_vowel(m.cOrig, m.nCur + 1) ;
or m.cRest = "WH")
* Wasserman should match Vasserman
if is_vowel(m.cOrig, m.nCur + 1)
cP= m.cP + "A"
cS= m.cS + "F"
else
cP= m.cP + "A"
cS= m.cS + "A"
endif
nCur= m.nCur + 2
loop
endif
&& Arnow should match Arnoff
if (m.nCur = m.nLen and is_vowel(m.cOrig, m.nCur - 1)) ;
or inlist(substr(m.cOrig, m.nCur - 1, 5), "EWSKI","EWSKY","OWSKI","OWSKY") ;
or m.cOrig = "SCH"
cP= m.cP + ""
cS= m.cS + "F"
nCur= m.nCur + 1
loop
endif
if inlist(m.cRest, "WICZ","WITZ")
cP= m.cP + "TS"
cS= m.cS + "FX"
nCur= m.nCur + 4
loop
endif
nCur= m.nCur + 1
case m.cLet = "X"
* french e.g. breaux
if !(m.nCur = m.nLen ;
and (inlist(substr(m.cOrig, m.nCur - 3, 3), "IAU", "EAU") ;
or inlist(substr(m.cOrig, m.nCur - 2, 2), "AU", "OU")))
cP= m.cP + "KS"
cS= m.cS + "KS"
endif
if inlist(m.cRest, "XX", "XC")
nCur= m.nCur + 2
else
nCur= m.nCur + 1
endif
case m.cLet = "Z"
* chinese pinyin e.g. 'zhao'
if m.cRest = "ZH"
cP= m.cP + "J"
cS= m.cS + "J"
nCur= m.nCur + 2
loop
else
if inlist(m.cRest, "ZO", "ZA", "ZI") ;
or (m.isSlavo ;
and (m.nCur > 1 and substr(m.cOrig, m.nCur - 1, 1) # "T"))
cP= m.cP + "S"
cS= m.cS + "TS"
else
cP= m.cP + "S"
cS= m.cS + "S"
endif
endif
if m.cRest = "ZZ"
nCur= m.nCur + 2
else
nCur= m.nCur + 1
endif
otherwise
nCur= m.nCur + 1
endcase
enddo
cP= padr(m.cP, 4)
cS= padr(m.cS, 4)
return m.cP
endfunc
function is_vowel(cStr, nPos)
return substr(m.cStr, m.nPos, 1) $ 'AEIOUY'
endfunc
function Slavo_Germanic(cStr)
return occurs("W", m.cStr) > 0 ;
or occurs("K", m.cStr) > 0 ;
or occurs("CZ", m.cStr) > 0 ;
or occurs("WITZ", m.cStr) > 0
endfunc
Example
set procedure to Phonetics.prgclear
?double_metaphone("foxpro") && FKSP
?double_metaphone("phoxpro") && FKSP
?double_metaphone("phocksprow") && FKSP
