Mega Code Archive
Metaphone FINAL
<![CDATA[
Title: Metaphone FINAL
Question: Phonetics algorithm
Answer:
function MetaPhone3(const Word:String; KeyLength: Integer = 10): String;
function Same(x: Char): Boolean;
begin
Result := x in ['F','J','L','M','N','R'];
end;
function Vowel(x: Char): Boolean;
begin
Result := x in ['A','E','I','O','U'];
end;
function Varson(x: Char): Boolean;
begin
Result := x in ['C','G','P','S','T'];
end;
function Noghf(x: Char): Boolean;
begin
Result := x in ['B', 'D', 'H'];
end;
function FrontV(x: Char): Boolean;
begin
Result := x in ['E', 'I', 'Y']
end;
var
i: Integer;
Tmp:String;
begin
Tmp := Trim(UpperCase(Word));
i := 1;
while (i 0) do
begin
if (Tmp[i] in ['G', 'K', 'P']) and (Tmp[i+1] = 'N')
or ((Tmp[i] = 'A') and (Tmp[i+1] = 'E'))
or ((Tmp[i] = 'W') and (Tmp[i+1] = 'R')) then Delete(Tmp, i, 1);
if (Tmp[i] = 'W') and (Tmp[i+1] = 'H') then
Delete(Tmp, 2, 1);
if (Tmp[i] = 'X') then Tmp[i] := 'S';
i := pos(' ', Tmp);
if (i 0) then Tmp[i] := #0;
end;
i := 0;
Tmp := Tmp + #0;
while (Length(Result) do
begin
inc(i);
if (Tmp[i] =#0) then Break;
if (Tmp[i] = Tmp[i-1]) and (Tmp[i] 'C') then
Continue;
if Same(Tmp[i]) or (Vowel(Tmp[i]) and (Tmp[i-1] = #0)) then
begin
Result := Result + Tmp[i];
Continue;
end;
case Tmp[i] of
'B': if ((i=2) and (Tmp[i-1] 'M')) or (i = 1) then Result := Result + Tmp[i];
'C':
begin
if FrontV(Tmp[i+1]) and (Tmp[i-1] 'S') then
begin
Result := Result + 'S';
inc(i);
end else if (Copy(Tmp, i, 2) = 'CH') or (Copy (Tmp, i ,3) = 'CIA') then
begin
Result := Result + 'X';
if (Copy(Tmp, i, 2) = 'CH') then inc(i);
if (Copy(Tmp, i, 3) = 'CIA')then inc(i, 2);
end else Result := Result + 'K';
end;
'D': if (Copy(Tmp, i, 2) = 'DG') and FrontV(Tmp[i+3]) then
begin
inc(i,3);
Result := Result + 'J';
end else
Result := Result + 'T';
'G': if ((Tmp[i+1] 'G') or Vowel(Tmp[i+1])) and
((Tmp[i+1]'N') or ((Tmp[i+1] = #0) and (Tmp[i+2]'E')
or (Tmp[i+3] 'D')) and ((Tmp[i+1] 'D') or not FrontV(Tmp[i+1]))) then
begin
if (FrontV(Tmp[i+1])) and (Tmp[i+2] 'G') then
Result := Result + 'J'
else
Result := Result + 'K';
end else if (Tmp[i+1] = 'H') and not noghf(Tmp[i -3]) and (Tmp[i -4] 'H') then
Result := Result + 'F';
'H': if not Varson(Tmp[i-1]) and (not Vowel(Tmp[i-1]) or Vowel(Tmp[i+1])) then
Result := Result + 'H';
'K': if (Tmp[i-1] 'C') then Result := Result + 'K';
'P': if (Tmp[i+1] = 'H') then
Result := Result + 'F'
else Result := Result + Tmp[i];
'Q': Result := Result + 'K';
'S': if (Tmp[i+1] = 'H') or ((Copy(Tmp, i, 2) = 'SI')
and (Tmp[i+3] in ['O','A'])) then
Result := Result + 'X'
else
Result := Result + 'S';
'T': if (Tmp[i+1] = 'I') and (Tmp[i+2] in ['O','A']) then
Result := Result + 'X'
else if (Tmp[i+1] = 'H') then Result := Result + '0' else
if (Tmp[i+1] 'C') or (Tmp[i+2] 'H') then Result := Result + 'T';
'V': Result := Result + 'F';
'W','Y': if Vowel(Tmp[i+1]) then Result := Result + Tmp[i];
'X': Result := Result + 'KS';
'Z': Result := Result + 'S';
end;
end;
end;
]]>