home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1991 / 01 / tricks / soundex.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1990-10-22  |  2.6 KB  |  95 lines
  1. (* ------------------------------------------------------ *)
  2. (*                    SOUNDEX.PAS                         *)
  3. (*          Phonetisches Suchen mit Turbo Pascal          *)
  4. (*             (c) 1990 Bodo Joest & TOOLBOX              *)
  5. (* ------------------------------------------------------ *)
  6. USES Crt;
  7.  
  8. TYPE
  9.   AdrType = RECORD
  10.     Name    : STRING;
  11.     Strasse : STRING;
  12.     Ort     : STRING;
  13.   END;
  14. VAR
  15.   Name    : STRING;
  16.   Adresse : AdrType;
  17.  
  18. FUNCTION UpString(Text : STRING): STRING;
  19. VAR
  20.   i: BYTE;
  21. BEGIN
  22.   FOR i := 1 TO Length(Text) DO
  23.     Text[i] := UpCase(Text[i]);
  24.   UpString := Text;
  25. END;
  26.  
  27. FUNCTION Soundex(Index : STRING): STRING;
  28.             { Umwandlung eines Strings in eine Phonemkette }
  29. CONST                                            { Phoneme }
  30.   BFPV     = ['B', 'F', 'P', 'V'];
  31.   CGJKQSXZ = ['C', 'G', 'J', 'K', 'Q', 'S', 'X', 'Z'];
  32.   DT       = ['D', 'T'];
  33.   L        = ['L'];
  34.   MN       = ['M', 'N'];
  35.   R        = ['R'];
  36. VAR
  37.   i       : BYTE;
  38.   Code    : STRING[5];
  39.   CodeLen : BYTE ABSOLUTE Code;
  40. BEGIN
  41.   Index := UpString(Index);
  42.   Code  := Index[1];
  43.   i     := 2;
  44.   WHILE (i <= Length(Index)) AND (CodeLen < 5) DO BEGIN
  45.     IF (Index[i] IN BFPV) AND
  46.        (Code[CodeLen] <> '1') THEN
  47.       Code := Code + '1'
  48.     ELSE
  49.       IF (Index[i] IN CGJKQSXZ) AND
  50.          (Code[CodeLen] <> '2') THEN
  51.         Code := Code + '2'
  52.       ELSE
  53.         IF (Index[i] IN DT) AND
  54.            (Code[CodeLen] <> '3') THEN
  55.           Code := Code + '3'
  56.         ELSE
  57.          IF (Index[i] IN L) AND
  58.             (Code[CodeLen] <> '4') THEN
  59.            Code := Code + '4'
  60.          ELSE
  61.            IF (Index[i] IN MN) AND
  62.               (Code[CodeLen] <> '5') THEN
  63.              Code := Code + '5'
  64.            ELSE
  65.            IF (Index[i] IN R) AND
  66.               (Code[CodeLen] <> '6') THEN
  67.              Code := Code + '6';
  68.     Inc(i);
  69.   END;
  70.   Code    := Code + '0000';
  71.   Soundex := Code;
  72. END;
  73.  
  74. BEGIN                                      { Hauptprogramm }
  75.   ClrScr;
  76.   Adresse.Name    := 'Meier';
  77.   Adresse.Strasse := 'Musterstr. 5';
  78.   Adresse.Ort     := '4711 Musterstadt';
  79.   REPEAT
  80.     Write('Name : ');
  81.     ReadLn(Name);
  82.     IF Soundex(Name) = Soundex(Adresse.Name) THEN BEGIN
  83.       WriteLn ('Name   : ', Adresse.Name);
  84.       WriteLn ('Straße : ', Adresse.Strasse);
  85.       WriteLn ('Ort    : ', Adresse.Ort);
  86.       WriteLn;
  87.     END ELSE BEGIN
  88.       WriteLn ('Name nicht gefunden.');
  89.       WriteLn;
  90.     END;
  91.   UNTIL Name = '';
  92. END.
  93. (* ------------------------------------------------------ *)
  94. (*                 Ende von SOUNDEX.PAS                   *)
  95.