(* KoelnerPhonetics

   Copyright (C) 2011 - 2023 Michael Fuchs, https://www.ypa-software.de

   This library is free software; you can redistribute it and/or modify it under the terms of the
   GNU Library General Public License as published by the Free Software Foundation; either version
   2 of the License, or (at your option) any later version with the following modification:

   As a special exception, the copyright holders of this library give you permission to link this
   library with independent modules to produce an executable, regardless of the license terms of
   these independent modules,and to copy and distribute the resulting executable under terms of
   your choice, provided that you also meet, for each linked independent module, the terms and
   conditions of the license of that module. An independent module is a module which is not derived
   from or based on this library. If you modify this library, you may extend this exception to your
   version of the library, but you are not obligated to do so. If you do not wish to do so, delete
   this exception statement from your version.

   This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
   without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See
   the GNU Library General Public License for more details.

   You should have received a copy of the GNU Library General Public License along with this
   library; if not, write to the Free Software Foundation, Inc., 51 Franklin Street - Fifth Floor,
   Boston, MA 02110-1335, USA. *)

unit KoelnerPhonetics;
{$MODE ObjFpc}
{$H+}

interface

uses
  Classes, SysUtils, StrUtils;

type
  TVocalRemoving = (vrStandard = 0, //:< Removes all zeros from result, except if on the first position.
                    vrNoRemoving = 1, //:< No removing of zeros from result.
                    vrNoTailRemoving = 2); //:< Removes all zeros from result, except if on first or last position.

  TKoelnerPhonetics = class
    private
      FVocalRemoving: TVocalRemoving;
    private
      function ReplaceChars(AString: String): String;
      function RemoveMultipleChars(AString: String): String;
      function RemoveNotLeadingZeros(AString: String): String;
      function RemoveInnerZeros(AString: String): String;
    public
      constructor Create;
    public
      (*: Indicates how the zeros are removed from result string. *)
      property VocalRemoving: TVocalRemoving read FVocalRemoving write FVocalRemoving;
    public
      (*: Calculates the koelner phonetic value of a given string. *)
      function KoelnerPhonetic(AText: String): String;
      (*: Compares the koelner phonetic value of two given strings, returns TRUE if both values are same, otherwise FALSE. *)
      function ComparePhonetics(FirstText, SecondText: String): Boolean;
  end;


implementation

function TKoelnerPhonetics.ReplaceChars(AString: String): String;
begin
  Result := StringsReplace(AString,
                           ['ä', 'Ä', 'ö', 'Ö', 'ü', 'Ü', 'ph', 'ß' ],
                           ['a', 'a', 'o', 'o', 'u', 'u', 'f' , 'ss'],
                           [rfReplaceAll]);
end;

function TKoelnerPhonetics.RemoveMultipleChars(AString: String): String;
var
  i, StringLength: Integer;
begin
  Result := EmptyStr;
  StringLength := Length(AString);
  if StringLength > 0 then begin
    for i := 1 to StringLength do begin
      if i < StringLength then begin
        if not(AString[i] = AString[i+1]) then
          Result := Result + AString[i];
      end else
        Result := Result + AString[i];
    end;
  end;
end;

(* removes all zeros from string (except when on first position) *)
function TKoelnerPhonetics.RemoveNotLeadingZeros(AString: String): String;
var
  LeadingZero: Boolean;
begin
  Result := EmptyStr;
  if Length(AString) > 0 then begin
    LeadingZero := (AString[1] = '0');
    Result := AnsiReplaceStr(AString, '0', EmptyStr);
    if LeadingZero then
      Result := '0' + Result;
  end;
end;

function TKoelnerPhonetics.RemoveInnerZeros(AString: String): String;
var
  TailingZero: Boolean;
begin
  Result := EmptyStr;
  if Length(AString) > 0 then begin
    TailingZero := RightStr(AString, 1) = '0';
    Result := RemoveNotLeadingZeros(AString);
    if TailingZero then
      Result := Result + '0';
  end;
end;

constructor TKoelnerPhonetics.Create;
begin
  FVocalRemoving := vrStandard;
end;

function TKoelnerPhonetics.KoelnerPhonetic(AText: String): String;
var
  i, TextLength: Integer;
  TempString: String;

  function OneMoreChar: Boolean;
  begin
    Result := i < TextLength;
  end;

  function CodeX: String;
  begin
    Result := '48';
    if i > 1 then begin
      if TempString[i-1] in ['c', 'k', 'q'] then
        Result := '8';
    end;
  end;

  function CodeDT: String;
  begin
    Result := '2';
    if OneMoreChar then begin
      if TempString[i+1] in ['c', 's', 'z'] then
        Result := '8';
    end;
  end;

  function CodeC: String;
  begin
    if i = 1 then begin
      if TempString[2] in ['a', 'h', 'k', 'l' ,'o', 'q', 'r', 'u', 'x'] then
        Result := '4'
      else
        Result := '8';
    end else begin
      if TempString[i-1] in ['s', 'z'] then
        Result := '8'
      else begin
        if OneMoreChar then begin
          if TempString[i+1] in  ['a', 'h', 'k', 'o', 'q', 'u', 'x'] then
            Result := '4'
          else
            Result := '8';
        end else
          Result := '8';
      end;
    end;
  end;

begin
  Result := EmptyStr;
  TempString := ReplaceChars(LowerCase(AText));
  TextLength := Length(TempString);
  if TextLength > 0 then begin
    for i := 1 to TextLength do begin
      case TempString[i] of
        'a', 'e', 'i', 'j', 'o', 'u', 'y': Result := Result + '0';
        'b', 'p'                         : Result := Result + '1';
        'd', 't'                         : Result := Result + CodeDT;
        'f', 'v', 'w'                    : Result := Result + '3';
        'g', 'k', 'q'                    : Result := Result + '4';
        'l'                              : Result := Result + '5';
        'm', 'n'                         : Result := Result + '6';
        'r'                              : Result := Result + '7';
        's', 'z'                         : Result := Result + '8';
        'c'                              : Result := Result + CodeC;
        'x'                              : Result := Result + CodeX;
      end;
    end;
  end;
  Result := RemoveMultipleChars(Result);
  case FVocalRemoving of
    vrStandard: Result := RemoveNotLeadingZeros(Result);
    vrNoTailRemoving: Result := RemoveInnerZeros(Result);
  end;
end;

function TKoelnerPhonetics.ComparePhonetics(FirstText, SecondText: String): Boolean;
begin
  Result := KoelnerPhonetic(FirstText) = KoelnerPhonetic(SecondText);
end;

end.