Author: Raghunath Dhungel
Did you ever want to find a string - But were not sure of it's spelling? A typical
case would be names (Micael/Maical/Michael/Maichael) all sound same but differ in
spelling!
Answer:
Most of you may already be familiar with the magical "Soundex" function which is
present in many Db environments ranging from FoxPro to Oracle/SQL Server. Few of
you may wonder how it works! Well, here is the implementation of the Soundex
function in Pascal based on an algorithm that I found in a computer magazine long
time back. The original program worked in Turbo Pascal, but I have modified it for
Delphi (The only change being use of ShortString instead of String!)
The function seems to return the same values as does SQL Server for the little
tests that I conducted. However, as you will have already guessed, I provide you no
gurantee that it will provide same values for all strings.
Please save the code below in a file called Soundx.pas. You will need to include
the file in your source (Uses Soundx) and then you will have access to the
Soundex() function.
For the example given in the Question/Problem/Abstract, Soundex returns the same
value (M240) for each of Micael/Maical/Michael/Maichael
Wishing you all a "Sound" search (Ha!)
1
2 {******************************************************}
3 {* Description: Implementation of Soundex function *}
4 {******************************************************}
5 {* Last Modified : 12-Nov-2000 *}
6 {* Author : Paramjeet Singh Reen *}
7 {* eMail : Paramjeet.Reen@EudoraMail.com *}
8 {******************************************************}
9 {* This program is based on the algorithm that I had *}
10 {* found in a magazine. I do not gurantee the fitness *}
11 {* of this program. Please use it at your own risk. *}
12 {******************************************************}
13 {* Category :Freeware. *}
14 {******************************************************}
15
16 unit Soundx;
17
18 interface
19
20 type
21 SoundexStr = string[4];
22
23 //Returns the Soundex code for the specified string.
24 function Soundex(const InpStr: ShortString): SoundexStr;
25
26 implementation
27
28 const
29 Alphs: array['A'..'Z'] of Char = ('0', '1', '2', '3', '0', '1', '2', '0', '0',
30 '2',
31 '2',
32 '4', '5', '5', '0', '1', '2', '6', '2', '3', '0', '1',
33 '0', '2', '0', '2');
34
35 function Soundex(const InpStr: ShortString): SoundexStr;
36 var
37 vStr: ShortString;
38 vCh1: Char;
39 i: Word;
40
41 begin
42 //Store the given InpStr in local variable in uppercase
43 vStr := '';
44 for i := 1 to Length(InpStr) do
45 vStr := vStr + UpCase(InpStr[i]);
46
47 //Replace all occurances of "PH" with "F"
48 i := Pos('PH', vStr);
49 while (i > 0) do
50 begin
51 Delete(vStr, i, 2);
52 Insert('F', vStr, i);
53 i := Pos('PH', vStr);
54 end;
55
56 //Replace all occurances of "CHR" with "CR"
57 i := Pos('CHR', vStr);
58 while (i > 0) do
59 begin
60 Delete(vStr, i, 3);
61 Insert('CR', vStr, i);
62 i := Pos('CHR', vStr);
63 end;
64
65 //Replace all occurances of "Z" with "S"
66 for i := 1 to Length(vStr) do
67 if (vStr[i] = 'Z') then
68 vStr[i] := 'S';
69
70 //Replace all occurances of "X" with "KS"
71 i := Pos('X', vStr);
72 while (i > 0) do
73 begin
74 Delete(vStr, i, 1);
75 Insert('KS', vStr, i);
76 i := Pos('X', vStr);
77 end;
78
79 //Remove all adjacent duplicates
80 i := 2;
81 while (i <= Length(vStr)) do
82 if (vStr[i] = vStr[i - 1]) then
83 Delete(vStr, i, 1)
84 else
85 Inc(i);
86
87 //Starting from 2nd char, remove all chars mapped to '0' in Alphs table
88 i := 2;
89 while (i <= Length(vStr)) do
90 if (Alphs[vStr[i]] = '0') then
91 Delete(vStr, i, 1)
92 else
93 Inc(i);
94
95 //Assemble Soundex string from Alphs table
96 vCh1 := vStr[1];
97 for i := 1 to Length(vStr) do
98 vStr[i] := Alphs[vStr[i]];
99
100 //Remove all adjacent duplicates from assembled Soundex string
101 i := 2;
102 while (i <= Length(vStr)) do
103 if (vStr[i] = vStr[i - 1]) then
104 Delete(vStr, i, 1)
105 else
106 Inc(i);
107
108 //Final assembly of Soundex string
109 vStr := vCh1 + Copy(vStr, 2, 255);
110 for i := Length(vStr) to 3 do
111 vStr := vStr + '0';
112 Soundex := vStr;
113 end;
114
115 end.
|
