program HashTest;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  Winapi.Windows,
  System.SysUtils,
  System.Classes,
  System.Generics.Collections,
  System.Generics.Defaults;

type
  TStringEqualComparer = class(TInterfacedObject)
    function Equals(const Left, Right: string): Boolean; reintroduce;
    // важно! если сделать виртуальный метод - то скорость падает ~3 раза
    // function GetHashCode(const Value: string): Integer; reintroduce; virtual; abstract;
  end;

  TSedgwicComparer = class(TStringEqualComparer, IEqualityComparer<string>)
    function GetHashCode(const Value: string): Integer; reintroduce;
  end;

  TSimpleComparer = class(TStringEqualComparer, IEqualityComparer<string>)
    function GetHashCode(const Value: string): Integer; reintroduce;
  end;

  TShiftComparer = class(TStringEqualComparer, IEqualityComparer<string>)
    function GetHashCode(const Value: string): Integer; reintroduce;
  end;

  TFastComparer = class(TStringEqualComparer, IEqualityComparer<string>)
    function GetHashCode(const Value: string): Integer; reintroduce;
  end;

  TMurmur3Comparer = class(TStringEqualComparer, IEqualityComparer<string>)
    function GetHashCode(const Value: string): Integer; reintroduce;
  end;

{ TStringEqualComparer }

function TStringEqualComparer.Equals(const Left, Right: string): Boolean;
label
  cmp_ptrs;
var
  i, Count: NativeInt;
  S1, S2: PNativeUInt;
begin
  S1 := Pointer(Left);
  S2 := Pointer(Right);
  if (S1 <> S2) and (S1 <> nil) and (S2 <> nil) then
  begin
    Dec(NativeUInt(S1), SizeOf(Integer));
    Dec(NativeUInt(S2), SizeOf(Integer));
    Count := PInteger(S1)^;
    if (Integer(Count) <> PInteger(S2)^) then goto cmp_ptrs;
    Inc(NativeUInt(S1), SizeOf(Integer));
    Inc(NativeUInt(S2), SizeOf(Integer));

    for i := 1 to Count shr {$ifdef CPUX64}2{$else}1{$endif} do
    begin
      if (S1^ <> S2^) then goto cmp_ptrs;
      Inc(S1);
      Inc(S2);
    end;

    {$ifdef CPUX64}
    if (Count and 2 <> 0) then
    begin
      if (PCardinal(S1)^ <> PCardinal(S2)^) then goto cmp_ptrs;
      Inc(NativeUInt(S1), SizeOf(Cardinal));
      Inc(NativeUInt(S2), SizeOf(Cardinal));
    end;
    {$endif}

    if (PWord(S1)^ <> PWord(S2)^) then goto cmp_ptrs;
    Result := True;
    Exit;
  end else
  begin
  cmp_ptrs:
    Result := (S1 = S2);
  end;
end;

{ TSedgwicComparer }

function TSedgwicComparer.GetHashCode(const Value: string): Integer;
var
  a, i: Integer;
begin
  Result := 0;
  a := 63689;
  for i := 1 to Length(Value) - 1 do
  begin
    Result := Result * a + PWordArray(Value)[i];
    a := a * 378551;
  end;
end;

{ TSimpleComparer }

function TSimpleComparer.GetHashCode(const Value: string): Integer;
var
  i: NativeInt;
  S: PChar;
begin
  S := Pointer(Value);
  Result := 0;
  if (S <> nil) then
  begin
    Result := PInteger(NativeInt(Value) - 4)^;

    for i := 0 to NativeInt(Result) - 1 do
    begin
      Result := Result + Ord(S[i]);
    end;
  end;
end;

{ TShiftComparer }

function TShiftComparer.GetHashCode(const Value: string): Integer;
var
  i: NativeInt;
  S: PChar;
begin
  S := Pointer(Value);
  Result := 0;
  if (S <> nil) then
  begin
    Result := PInteger(NativeInt(Value) - 4)^;

    for i := 0 to NativeInt(Result) - 1 do
    begin
      Result := Result xor (Result shr (i and 7 + 1)) + Ord(S[i]);
    end;
  end;
end;

{ TFastComparer }

function TFastComparer.GetHashCode(const Value: string): Integer;
var
  i, X, Count: Integer;
  S: PByte;
begin
  S := Pointer(Value);
  Result := 0;
  if (S <> nil) then
  begin
    Count := PInteger(NativeInt(Value) - 4)^;

    Result := Count;
    for i := 1 to (Count shr (SizeOf(Char) xor 3)) do
    begin
      X := Result xor PInteger(S)^;
      Result := Result * i;
      Inc(Result, X shr 19);
      Inc(S, SizeOf(Integer));
      Inc(Result, X);
    end;

    for i := 1 to (Count and ((SizeOf(Char) xor 2) or 1)) do
    begin
      Result := Result * i;
      Inc(Result, Ord(PChar(S)^));
      Inc(S, SizeOf(Char));
    end;
  end;
end;

{ TMurmur3Comparer }

type
  uint32_t = cardinal;
{$IFNDEF fpc}
function RolDWord(x:uint32_t;r:integer):uint32_t;
{$IF Defined(CPUX86)}
asm
  MOV  CL, DL
  ROL  EAX, CL
end;
{$ELSEIF Defined(CPUX64)}
asm
  MOV  EAX, ECX
  MOV  CL, DL
  ROL  EAX, CL
end;
{$ELSE}
begin
  Result:=(x shl r) or (x shr (32 - r));
end;
{$IFEND}
{$ENDIF}

function MurmurHash3_x86_32 ( const Akey; len:uint32_t): cardinal;
type
  Puint32_t=^uint32_t;

var data:Puint32_t;
  nblocks,tail_len,i:uint32_t;
  h1,k1:uint32_t;
const
   c1:uint32_t = $cc9e2d51;
   c2:uint32_t = $1b873593;
type
 TTailRec=packed record
  case Integer of
   1:(b:byte);
   2:(w:word);
   3:(uint24_d:uint32_t);
 end;
var
 tail:^TTailRec;
begin
  data := @Akey;
  nblocks := len div 4;

  h1 := 0;
  //----------
  // body
  for i:=1 to nblocks do begin
    k1 := data^;

    k1 := k1 * c1;
    k1 := RolDWord(k1,15);
    k1 := k1*c2;

    h1 := h1 xor k1;
    h1 := RolDWord(h1,13);
    h1 := h1*5+$e6546b64;

    inc(data);
  end;

  //----------
  // tail

  tail :=pointer(data);

  k1 := 0;
  tail_len:=len and 3;
  if tail_len>0 then begin
    case tail_len of
    3: k1 :=k1 xor (tail^.uint24_d and $FFFFFF);
    2: k1 :=k1 xor tail^.w;
    1: k1 :=k1 xor tail^.b;
    end;

    k1 :=k1* c1;
    k1 := RolDWord(k1,15);
    k1 :=k1 * c2;
    h1 :=h1 xor k1;
  end;
  //----------
  // finalization

  h1 :=h1 xor len;

  //h1 := fmix32(h1);  Result := h1;

  h1 :=h1 xor (h1 shr 16);
  h1 :=h1* $85ebca6b;
  h1 :=h1 xor (h1 shr 13);
  h1 :=h1 * $c2b2ae35;

  Result:=h1 xor (h1 shr 16);
end;
function TMurmur3Comparer.GetHashCode(const Value: string): Integer;
begin
  Result := Integer(MurmurHash3_x86_32(PChar(Value)^, Length(Value) * SizeOf(Char)));
end;



procedure TestDict(Title: string; L: TStringList; C: IEqualityComparer<string> = nil);
var
  t1, t2: Cardinal;
  D: TDictionary<string, Integer>;
  i: Integer;
begin
  Write(Title);
  //
  D := TDictionary<string, Integer>.Create(L.Count, C);
  try
   t1 := GetTickCount();
    for i := L.Count - 1 downto 0 do
      D.AddOrSetValue(L[i], i);

    t2 := GetTickCount();
    Writeln(t2 - t1);
  finally
    D.Free;
  end;
  //
end;

function GenStr(): string;
var
  l: Integer;
begin
  l := Random(1024);
  SetLength(Result, l);
  for l := l downto 1 do
  begin
    Result[l] := Char(Random(256));
  end;
end;

procedure GenList(L: TStringList);
var
  i: Integer;
begin
  RandSeed := 0;
  for i := 1 to 1000000 do
    L.Add(GenStr)
end;

var
  L: TStringList;

begin
  try
    L:= TStringList.Create;
    try
      GenList(L);
      TestDict( 'std: ', L);

      TestDict( 'TSedgwicComparer: ', L, TSedgwicComparer.Create);
      TestDict( 'TMurmur3Comparer: ', L, TMurmur3Comparer.Create);
      TestDict( 'TFastComparer: ', L, TFastComparer.Create);
      TestDict( 'TShiftComparer: ', L, TShiftComparer.Create);
      TestDict( 'TSimpleComparer: ', L, TSimpleComparer.Create);
    finally
      L.Free;
    end;
    { TODO -oUser -cConsole Main : Insert code here }
  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
end.