home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS - Coast to Coast / simteldosarchivecoasttocoast.iso / pcmag / vol8n16.zip / SOUNDEX.PAS < prev    next >
Pascal/Delphi Source File  |  1989-08-11  |  2KB  |  72 lines
  1. SOUNDEX.PAS
  2.  
  3.  
  4.  
  5. PROGRAM TestSoundex;
  6.  
  7. USES Crt; (*comment out for TP3*)
  8. TYPE
  9.   SString = STRING[255];
  10. VAR
  11.   IPString : SString;
  12.   Row : Byte;
  13.  
  14.   FUNCTION Soundex(TextString : SString) : SString;
  15.   CONST SoundexTable : ARRAY[1..26] OF Char =
  16.      '.123.12..22455.12623.1.2.2';
  17.   (*  ABCDEFGHIJKLMNOPQRSTUVWXYZ  *)
  18.   VAR
  19.     SoundString : SString;
  20.     FirstChar : Char;
  21.     I1, I2 : Integer;
  22.   BEGIN
  23.     (* Provide for trailing zero fill  *)
  24.     FillChar(SoundString[1], 255, '0');
  25.     SoundString[0] := #255;
  26.     (* First character is always alpha *)
  27.     FirstChar := Upcase(TextString[1]);
  28.     (*  First step - ASCII to soundex *)
  29.     FOR I1 := 1 TO Length(TextString)-1 DO
  30.       BEGIN
  31.         I2 := Ord(Upcase(TextString[I1+1]))-64;
  32.         (* Range check for good letters *)
  33.         IF (I2 < 1) OR (I2 > 26) THEN I2 := 1;
  34.         SoundString[I1] := SoundexTable[I2];
  35.       END;
  36.     I1 := 1; (* Initialize for second pass      *)
  37.     (* Eliminate non-soundex characters and side by side duplicates  *)
  38.     REPEAT
  39.       WHILE SoundString[I1] = '.' DO Delete(SoundString, I1, 1);
  40.       IF SoundString[I1] = SoundString[I1+1] THEN
  41.         Delete(SoundString, I1, 1);
  42.       I1 := I1 + 1;
  43.     UNTIL SoundString[I1] = '0';
  44.     Soundex := FirstChar+Copy(SoundString, 1, 3);
  45.   END;                            (* End of Soundex FUNCTION         *)
  46.  
  47. BEGIN
  48.   Row := 24;
  49.   REPEAT
  50.     IF Row = 24 THEN
  51.       BEGIN
  52.         Row := 1;
  53.         ClrScr;
  54.       END;
  55.     GoToXY(10, 24);
  56.     Write('Enter a name to be encoded:  ');
  57.     ReadLn(IPString);
  58.     IF IPString <> '' THEN
  59.       BEGIN
  60.         GoToXY(10, 24);
  61.         ClrEol;
  62.         GoToXY(10, Row);
  63.         Write(IPString);
  64.         GoToXY(32, Row);
  65.         WriteLn('->  ', Soundex(IPString));
  66.         Row := Row+1;
  67.       END;
  68.   UNTIL IPString = '';
  69. END.
  70.  
  71.  
  72.