/*------------------------------------------------------------------------------ Module: metaphone.p Written by: Mark S. Domalewski, on 07/23/94 Description: Convert a series of characters into a string representing the approx- imate sound of the string. Based on a PICK BASIC program written by Lawrence Philips from in the December 1990 issue of "Computer Language". Parameters: Input: source, char - string to convert to metaphone meta_len, int - maximum length of metaphone string (usually 4) Output: metaphone, char - metaphone for source Example: run metaphone.p (input mt-source,4,output mt-phonetic). ------------------------------------------------------------------------------*/ /** PASSED PARAMETERS **/ def input param source as char. def input param meta-len as int. def output param metaphone as char. /** "CONSTANTS" VAR'S **/ def var vowels as char no-undo init "A,E,I,O,U". def var initdip as char no-undo init "KN,GN,PN,AE,WR". def var frontv as char no-undo init "E,I,Y". /* vowels which alter sound */ /* of preceeding consonants */ def var varson as char no-undo init "C,S,T,P,G". /* consonants whose sound */ /* changes following "h" */ /** VAR'S USED IN EXAMINIG THE CHAR'S TO CONVERT TO METAPHONE **/ def var c as char no-undo. /* current char being examined */ def var n as char no-undo. /* next char after current */ def var p as char no-undo. /* char immediately before current */ def var meta-str as char no-undo. def var temp as char no-undo init "". def var i as int no-undo. def var m-idx as int no-undo init 1. def var mt-len as int no-undo. def var hard as log no-undo. def var mt-new as log no-undo. /******************************************************************************/ /** REMOVE NON-ALPHABETIC CHARACTERS FROM STRING. ** ** 7/29/94 - ADDED A CHECK FOR SPACES AND THE FOLLOWING CHAR'S: -/., ** ** BEFORE, IF A SPACE WAS ENCOUNTERD IT WOULD LEAVE THE DO ** ** LOOP. NOW IT WON'T. **/ do i = 1 to length(source): if index("-/.,",substr(source,i,1)) = 0 and substr(source,i,1) <> "" and (substr(source,i,1) < "A" or substr(source,i,1) > "Z") then leave. temp = temp + caps(substr(source,i,1)). end. if length(temp) = 0 then return. /** ADJUST INITIAL DIPTHONG EXCEPTIONS **/ temp = if can-do(initdip,substr(temp,1,2)) then substr(temp,2,length(temp) - 1) else if substr(temp,1,2) = "WH" then "W" + substr(temp,3,length(temp) - 2) else if substr(temp,1,2) = "X" then "X" + substr(temp,2,length(temp) - 1) else temp. /** CONVERT TO METAPHONE **/ assign i = 0 m-idx = 1 mt-len = length(temp). META-BLK: do while i <= mt-len and length(meta-str) < meta-len: /** GET THE CURRENT, PREVIOUS AND THE NEXT CHARACTERS **/ assign i = i + 1 c = substr(temp,i,1) n = if i < mt-len then substr(temp,i + 1,1) else ? p = if i > 1 then substr(temp,i - 1,1) else ?. /** ELIMINATE DOUBLE CONSONANTS, EXCEPT FOR DOUBLE "C"'S **/ mt-new = if c <> "C" and i > 1 and c = p then NO else YES. if mt-new then do: if can-do(vowels,c) and i > 1 then next META-BLK. else if c = "B" and i = mt-len and p = "M" then next META-BLK. else if c = "C" then do: if NOT (i > 1 and p = "S" and i + 1 <= mt-len and can-do(frontv,n)) then if i + 2 <= mt-len and substr(temp,i + 1,2) = "IA" then c = "X". else if i < mt-len and can-do(frontv,n) then c = "S". else if i > 1 and i < mt-len and substr(temp,i - 1,3) = "SCH" then c = "K". else if i < mt-len and n = "H" then if i = 1 and i + 2 < mt-len and NOT can-do(vowels,substr(temp,i + 2,1)) then c = "K". else c = "X". else c = "K". else next META-BLK. end. else if c = "D" then if i + 2 <= mt-len and n = "G" and can-do(frontv,substr(temp,i + 2,1)) then c = "J". else c = "T". else if c = "G" then do: if (i < mt-len and n = "H" and NOT can-do(vowels,substr(temp,i + 2,1))) or (i > 1 and ((i + 1 = mt-len and n = "N") or (i + 3 = mt-len and substr(temp,i + 1,3) = "NED"))) or (i > 1 and i + 1 <= mt-len and p = "D" and can-do(frontv,n)) then next META-BLK. else if i < mt-len and can-do(frontv,n) and i > 1 and p = "G" then c = "J". else c = "K". end. else if c = "H" then do: if i > 1 and can-do(varson,p) then next META-BLK. else if i > 1 and can-do(vowels,p) and (i = mt-len or (i < mt-len and NOT can-do(vowels,n))) then next META-BLK. end. else if c = "K" and i > 1 and p = "C" then next META-BLK. else if c = "P" and i < mt-len and n = "H" then c = "F". else if c = "Q" then c = "K". else if c = "S" then do: if i > 1 and i + 2 <= mt-len and can-do("IA,IO",substr(temp,i + 1,2)) then c = "X". else if i < mt-len and n = "H" then c = "X". end. else if c = "T" then do: if i > 1 and i + 2 <= mt-len and can-do("IA,IO",substr(temp,i + 1,2)) then c = "X". else if i < mt-len and n = "H" then if NOT (i > 1 and p = "T") then c = "0". else if substr(temp,i + 1,2) = "CH" then next META-BLK. end. else if c = "V" then c = "F". else if index("WY",c) > 0 and i < mt-len and NOT can-do(vowels,n) then next META-BLK. else if c = "X" then c = "KS". else if c = "Z" then c = "S". /** ADD NEW META CHARACTER(S) TO METAPHONE **/ assign substr(meta-str, m-idx) = c m-idx = m-idx + length(c). end. /** END OF IF MT-NEW THEN DO **/ end. /**** END OF DO WHILE I <= MT-LEN... -- META-BLK **/ /** PUT SOUND OF PASSED STRING INTO OUTPUT PARAM METAPHONE **/ if (length(meta-str) > 0) then metaphone = substr(meta-str,1,meta-len).