home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / SOUNDX.ZIP / SOUNDX.INC
Encoding:
Text File  |  1988-03-09  |  2.9 KB  |  100 lines
  1. { SOUNDEX.INC }
  2. { A Turbo Pascal implementation of the Soundex algorithm }
  3. { The basic Soundex algorithm may be found in Vol. 3 of  }
  4. { Don Knuth's Algorithms.  As described, an input string }
  5. { is converted to a string of the form  XYYY, where:     }
  6. {    X    = the first letter                             }
  7. {    YYY  = the Soundex values the next several non-     }
  8. {           vowels; doubled values of Y are ignored.     }
  9. { This implementation will return the Soundex code as    }
  10. { defined by Knuth.  In addition, it will return two     }
  11. { variations: first character replaced by its Soundex    }
  12. { value, and retain all vowels.                          }
  13.  
  14.  
  15. type
  16.   bigstr =string [255];
  17.  
  18. const
  19.   code_table : array [0..25] of char =
  20.      ('0', '1', '2', '3', '0', '1', '2', '0',
  21.      { A    B    C    D    E    F    G    H  }
  22.       '0', '2', '2', '4', '5', '5', '0', '1',
  23.      { I    J    K    L    M    N    O    P  }
  24.       '2', '6', '2', '3', '0', '1', '0', '2',
  25.      { Q   R    S     T    U    V    W    X  }
  26.       '0', '2' );
  27.      { Y    Z  }
  28.  
  29. procedure soundex (var name , sx : bigstr; first, vowels : boolean;
  30.                    size : integer);
  31.  
  32. { name   = string to be converted
  33.   sx     = output Soundex string
  34.   first  = true to include first character, false to include
  35.            first character's Soundex code
  36.   vowels = true to retain all vowels
  37.   size   = Maximum length of the SX string; 0 implies no limt
  38.  
  39.   Using first = false, vowels = false, size = 4 will produce Knuth's
  40.   result.
  41. }
  42.  
  43. var
  44.   ch : char;              { Holds characters from the input string }
  45.   tv : char;              { Holds Soundex value of current character }
  46.   pv : char;              { Holds Soundex value of previous character }
  47.   i  : integer;           { Used to index through the input string }
  48.   j  : integer;           { Index into the output string, sx }
  49.  
  50. begin
  51.   if size = 0
  52.   then size := length (name);
  53.  
  54.   ch := ' ';
  55.   i := 0;
  56.  
  57.   while ((i <= length (name)) and not (ch in ['A'..'Z'])) do
  58.   begin
  59.     i  := i + 1;
  60.     ch := upcase (name [i]);
  61.   end;
  62.  
  63.   pv := code_table [ord (ch) - ord ('A')];
  64.  
  65.   if first
  66.   then sx [1] := ch
  67.   else sx [1] := pv;
  68.  
  69.  
  70.   if i <= length (name)
  71.   then j := 1
  72.   else j := 0;
  73.  
  74.   for i := i + 1 to length (name) do
  75.   begin
  76.     ch := upcase (name [i]);
  77.  
  78.     if ch in ['A'..'Z']
  79.     then begin
  80.       if vowels or not (ch in ['A', 'E', 'I', 'O', 'U', 'W', 'Y'])
  81.       then begin
  82.         tv := code_table [ord (ch) - ord ('A')];
  83.  
  84.         if tv <> pv
  85.         then begin
  86.           j := j + 1;
  87.           sx [j] := tv;
  88.           pv := tv;
  89.         end;
  90.       end;
  91.     end;
  92.   end;
  93.  
  94.   if j > size                           { Limit length of result }
  95.   then j := size;
  96.  
  97.   sx [0] := chr (j);                     { Store length of output string }
  98. end;   { soundex () }
  99.  
  100.