Data commit

Task/Soundex/Pascal/soundex.pas

@@ -0,0 +1,108 @@
+program Soundex;
+
+{$mode objfpc}{$H+}
+
+uses
+  {$IFDEF UNIX}{$IFDEF UseCThreads}
+  cthreads,
+  {$ENDIF}{$ENDIF}
+   SysUtils;
+
+type
+  TLang=(en,fr,de);
+
+const
+   Examples : array[1..16, 1..2] of string =
+     (('Ashcraft', 'A261')
+     ,('Ashcroft', 'A261')
+     ,('Gauss', 'G200')
+     ,('Ghosh', 'G200')
+     ,('Hilbert', 'H416')
+     ,('Heilbronn', 'H416')
+     ,('Lee', 'L000')
+     ,('Lloyd', 'L300')
+     ,('Moses', 'M220')
+     ,('Pfister', 'P236')
+     ,('Robert', 'R163')
+     ,('Rupert', 'R163')
+     ,('Rubin', 'R150')
+     ,('Tymczak', 'T522')
+     ,('Soundex', 'S532')
+     ,('Example', 'E251')
+     );
+
+// For Ansi Str
+function Soundex(Value: String; Lang: TLang) : String;
+const
+  // Thx to WP.
+  Map: array[TLang, 0..2] of String =(
+    // Deals with accented, to improve
+    ('abcdefghijklmnopqrstuvwxyz'
+    ,'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
+    ,' 123 12- 22455 12623 1-2 2'),
+    ('aàâäbcçdeéèêëfghiîjklmnoöôpqrstuùûüvwxyz' // all chars with accented
+    ,'AAAABCCDEEEEEFGHIIJKLMNOOOPQRSTUUUUVWXYZ' // uppercased
+    ,' 123 97- 72455 12683 9-8 8'),             // coding
+    ('abcdefghijklmnopqrstuvwxyz'
+    ,'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
+    ,' 123 12- 22455 12623 1-2 2')
+    );
+var
+  i: Integer;
+  c, cOld: Char;
+
+  function Normalize(const s: string): string;
+  var
+    c: Char;
+    p: Integer;
+  begin
+    result := '';
+    for c in LowerCase(s) do
+    begin
+      p := Pos(c, Map[Lang,0]);
+      // unmapped chars are ignored
+      if p > 0 then
+        Result := Result + Map[Lang, 1][p];
+    end;
+  End;
+
+  function GetCode(c: Char): Char;
+  begin
+    Result := Map[Lang, 2][Ord(c)-Ord('A')+1];
+  End;
+
+begin
+  Value := Trim(Value);
+  if Value = '' then
+  begin
+    Result := '0000';
+    exit;
+  end;
+  Value := Normalize(Value);
+  Result := Value[1];
+  cOld := GetCode(Value[1]);
+  for i := 2 to length(Value) do
+  begin
+    c := GetCode(Value[i]);
+    if (c <> ' ') and (c <> '-') and (c <> cOld) then
+      Result := Result + c;
+    if c <> '-' then
+      cOld := c;
+  end;
+  Result := Copy(Result+'0000', 1, 4);
+End;
+
+const
+  Status : array[boolean] of string = ('KO', 'OK');
+var
+  Found: String;
+  tab: array[1..2] of String;
+begin
+  WriteLn('Word                : Code   Found   Status');
+  for tab in Examples do
+  begin
+    Found := Soundex(tab[1], en);
+    WriteLn(Format('%-20s: %s   %s    %s',[tab[1], tab[2], Found, Status[Found = tab[2]]]))
+  end;
+  ReadLn;
+End.