{$MODE OBJFPC}
{$MODESWITCH AUTODEREF}
unit dhashmap;

interface

uses
  dtypes,
  dobjects;

type
THash32 = LongInt;
THashValue = THash32;

generic THashMap<TKey, TValue, THashFunc> = object
public const
  MAX_HASH = 256;
public type
  PHashMap = ^THashMap;
  PValue = ^TValue;
  PPNode = ^PNode;
  PNode = ^TNode;
  TNode = record
    Key: TKey;
    Value: TValue;
    Next: PNode;
  end;
  TEnumerator = object
  public
    Map: PHashMap;
    H: THashValue;
    Node: PNode;
    function MoveNext: Boolean;
    property Current: PNode read Node;
  end;
private
  FHash: THashFunc;
  FItems: array[0 .. MAX_HASH - 1] of PNode;
public
  constructor Init;
  destructor Done;
  function GetEnumerator: TEnumerator;
  procedure Clear;
  function Hash(const Key: TKey): THashValue; inline;
  function Add(const Key: TKey; const Value: TValue): PValue;
  function Find(const Key: TKey; out Value: TValue): Boolean; overload;
  function FindPlace(const Key: TKey; out Value: PValue): Boolean; overload;
  function Get(const Key: TKey; out Value: PValue): Boolean;
  procedure Remove(const Key: TKey);
end;

TStringHash = object
  procedure Init; inline;
  procedure Done; inline;
  function Get(const S: TString): THashValue;
end;

generic THashMapBase<TKey, TValue, THashFunc> = object(TObject)
public type
  TPtr = ^THashMapBase;
  PValue = ^TValue;
  THash = Cardinal;
  PPair = ^TPair;
  TPair = packed record
    Key: TKey;
    Value: TValue;
  end;
private
  FPages: LongInt;
  // TODO
  // Использовать второй массив некорректно, потому что при изменении его
  // размера будут биться указатели на объекты, что приведёт к ошибкам,
  // если в клиентском коде указатель на объект был где-то сохранён
  // Очень важно это исправить
  FTable: array of array of TPair;
  function GetPage(const Key: TKey): LongInt;
  function FindIndex(const Key: TKey; Page: LongInt; out Index: LongInt): Boolean;
public
  constructor Init(Pages: LongInt = 128);
  destructor Done; virtual;
  function Has(const Key: TKey): Boolean;
  function Get(const Key: TKey; Def: PValue): PValue;
  procedure Del(const Key: TKey);
  procedure Clear;
  function Find(const Key: TKey; var P: PValue): Boolean;
  function FindOrAlloc(const Key: TKey; var P: PValue): Boolean;
  // Utils
  function GetCount: LongInt;
  function GetAllCollisions: LongInt;
  function GetMaxCollisions: LongInt;
public type
  // leads to Internal error in fpc3.0.0rc1
  TIterator = object
    HashMap: TPtr;
    Page: LongInt;
    Index: LongInt;
    Pair: PPair;
    procedure Init(aHashMap: TPtr); inline;
    procedure Done; inline;
    function Next: Boolean;
  end;
end;

// Hash map contains objects. TObj should have default Init constructor
// and Done destructor.
generic THashMapToObject<TKey, TObj, THashFunc> = object(TObject)
public type
  TPtr = ^THashMapToObject;
  PObj = ^TObj;
private type
  THashMap = specialize THashMapBase<TKey, TObj, THashFunc>;
private
  FMap: THashMap;
public
  constructor Init(Pages: LongInt = 128);
  destructor Done; virtual;
  function Has(const Key: TKey): Boolean; inline;
  // may call destructor if an object for Key exists
  // you should initialize returned object
  function Alloc(const Key: TKey): PObj; inline;
  function Get(const Key: TKey; Def: PObj): PObj; inline;
  procedure Del(const Key: TKey; CallDtor: Boolean); inline;
  function Find(const Key: TKey; var P: PObj): Boolean; inline;
  procedure Clear(CallDtor: Boolean);
  // may call basic constructor
  function GetOrInit(const Key: TKey): PObj; inline;
  // you should initialize returned object
  function GetOrAlloc(const Key: TKey): PObj; inline;
  property _Values[Index: TKey]: PObj read GetOrInit; default;
public type
  TIterator = object
  private
    FIt: THashMap.TIterator;
  public
    procedure Init(aHashMap: TPtr);
    procedure Done; inline;
    function Next: Boolean; inline;
    function Key: TKey; inline;
    function Value: PObj; inline;
  end;
end;

generic THashMapToPointerBase<TKey, THashFunc> = object(specialize THashMapBase<TKey, Pointer, THashFunc>) end;

generic THashMapToPointer<TKey, TPointer, THashFunc> = object(TObject)
public type
  TPtr = ^THashMapToPointer;
private type
  THashMap = specialize THashMapToPointerBase<TKey, THashFunc>;
private
  FMap: THashMap;
public
  constructor Init(Pages: LongInt = 128);
  destructor Done; virtual;
  function Has(const Key: TKey): Boolean; inline;
  function Alloc(const Key: TKey): TPointer; inline;
  procedure Add(const Key: TKey; Value: TPointer);
  function Get(const Key: TKey; Def: TPointer): TPointer; inline;
  procedure Del(const Key: TKey); inline;
  function Find(const Key: TKey; var P: TPointer): Boolean; inline;
  property _Values[Index: TKey]: TPointer read Alloc write Add; default;
public type
  TIterator = object
  private
    FIt: THashMap.TIterator;
  public
    procedure Init(aHashMap: TPtr); inline;
    procedure Done; inline;
    function Next: Boolean; inline;
    function Key: TKey; inline;
    function Value: TPointer; inline;
  end;
end;

implementation

function THashMap.TEnumerator.MoveNext: Boolean;
begin
  if Node <> nil then
    Node := Node^.Next;
  if Node = nil then
    repeat
      Inc(H);
      if H >= MAX_HASH then
        Exit(False);
      Node := Map^.FItems[H];
    until Node <> nil;
  Exit(True);
end;

constructor THashMap.Init;
var
  I: THashValue;
begin
  FHash.Init;
  for I := 0 to MAX_HASH - 1 do
    FItems[I] := nil;
end;

destructor THashMap.Done;
begin
  Clear;
  FHash.Done;
end;

function THashMap.GetEnumerator: TEnumerator;
begin
  Result.Map := @Self;
  Result.H := -1;
  Result.Node := nil;
end;

procedure THashMap.Clear;
var
  H: THashValue;
  N, Next: PNode;
begin
  for H := 0 to MAX_HASH - 1 do begin
    N := FItems[H];
    while N <> nil do begin
      Next := N^.Next;
      Dispose(N);
      N := Next;
    end;
    FItems[H] := nil;
  end;
end;

function THashMap.Hash(const Key: TKey): THashValue;
begin
  Result := FHash.Get(Key) mod MAX_HASH;
end;

function THashMap.Add(const Key: TKey; const Value: TValue): PValue;
var
  N: PNode;
  P: PPNode;
begin
  P := @FItems[Hash(Key)];
  N := P^;
  New(P^);
  P^.Key := Key;
  P^.Value := Value;
  P^.Next := N;
  Result := @P^.Value;
end;

function THashMap.Find(const Key: TKey; out Value: TValue): Boolean;
var
  N: PNode;
begin
  N := FItems[Hash(Key)];
  while N <> nil do begin
    if Key = N^.Key then begin
      Value := N^.Value;
      Exit(True);
    end;
    N := N^.Next;
  end;
  Exit(False);
end;

function THashMap.FindPlace(const Key: TKey; out Value: PValue): Boolean;
var
  N: PNode;
begin
  N := FItems[Hash(Key)];
  while N <> nil do begin
    if Key = N^.Key then begin
      Value := @N^.Value;
      Exit(True);
    end;
    N := N^.Next;
  end;
  Exit(False);
end;

function THashMap.Get(const Key: TKey; out Value: PValue): Boolean;
begin
  Result := FindPlace(Key, Value);
  if not Result then
    Value := Add(Key, Default(TValue));
end;

procedure THashMap.Remove(const Key: TKey);
var
  P: PPNode;
  N: PNode;
begin
  P := @FItems[Hash(Key)];
  N := P^;
  while N <> nil do
    if N^.Key = Key then begin
      P^ := N^.Next;
      Dispose(N);
      N := P^;
    end else begin
      P := @N^.Next;
      N := P^;
    end;
end;

procedure TStringHash.Init;
begin
end;

procedure TStringHash.Done;
begin
end;

function TStringHash.Get(const S: TString): THashValue;
var
  I: LongInt;
begin
  Result := 0;
  for I := 1 to 4 do
    if I <= Length(S) then
      Result := (Result shl 1) xor Ord(S[I])
    else
      Exit;
  Result := Result xor Length(S);
  if Length(S) > 8 then
    for I := Length(S) - 3 to Length(S) do
      Result := (Result shl 1) xor Ord(S[I]);
end;

function THashMapBase.GetPage(const Key: TKey): LongInt;
begin
  Result := THashFunc.GetHash(Key) mod FPages;
end;

function THashMapBase.FindIndex(const Key: TKey; Page: LongInt; out Index: LongInt): Boolean;
begin
  Index := 0;
  while Index < Length(FTable[Page]) do begin
    if Key = FTable[Page][Index].Key then
      Exit(True);
    Inc(Index);
  end;
  Exit(False);
end;

constructor THashMapBase.Init(Pages: LongInt = 128);
begin
  FPages := Pages;
  SetLength(FTable, FPages, 0);
end;

destructor THashMapBase.Done;
begin
  SetLength(FTable, 0, 0);
end;

function THashMapBase.Has(const Key: TKey): Boolean;
var
  Temp: PValue;
begin
  Result := Find(Key, Temp);
end;

function THashMapBase.Get(const Key: TKey; Def: PValue): PValue;
begin
  if not Find(Key, Result) then
    Result := Def;
end;

procedure THashMapBase.Del(const Key: TKey);
var
  Page, I, J: LongInt;
begin
  Page := GetPage(Key);
  I := 0;
  while I < Length(FTable[Page]) do begin
    if Key = FTable[Page][I].Key then begin
      for J := I to High(FTable[Page]) do
        FTable[Page][J] := FTable[Page][J + 1];
      SetLength(FTable[Page], Length(FTable[Page]) - 1);
    end;
    Inc(I);
  end;
end;

procedure THashMapBase.Clear;
begin
  SetLength(FTable, FPages, 0);
end;

function THashMapBase.Find(const Key: TKey; var P: PValue): Boolean;
var
  Page, I: LongInt;
begin
  Page := GetPage(Key);
  for I := 0 to High(FTable[Page]) do
    if Key = FTable[Page][I].Key then begin
      P := @FTable[Page][I].Value;
      Exit(True);
    end;
  Exit(False);
end;

function THashMapBase.FindOrAlloc(const Key: TKey; var P: PValue): Boolean;
var
  Page, I: LongInt;
begin
  Page := GetPage(Key);
  for I := 0 to High(FTable[Page]) do
    if Key = FTable[Page][I].Key then begin
      P := @FTable[Page][I].Value;
      Exit(True);
    end;
  SetLength(FTable[Page], Length(FTable[Page]) + 1);
  FTable[Page][High(FTable[Page])].Key := Key;
  P := @FTable[Page][High(FTable[Page])].Value;
  Exit(False);
end;

function THashMapBase.GetCount: LongInt;
var
  Page: LongInt;
begin
  Result := 0;
  for Page := 0 to High(FTable) do
    Result := Result + Length(FTable[Page]);
end;

function THashMapBase.GetAllCollisions: LongInt;
var
  Page: LongInt;
begin
  Result := 0;
  for Page := 0 to High(FTable) do
    if Length(FTable[Page]) <> 0 then
      Result := Result + Length(FTable[Page]) - 1;
end;

function THashMapBase.GetMaxCollisions: LongInt;
var
  Page: LongInt;
begin
  Result := 0;
  for Page := 0 to High(FTable) do
    if Result < High(FTable[Page]) then
      Result := High(FTable[Page]);
end;

procedure THashMapBase.TIterator.Init(aHashMap: TPtr);
begin
  HashMap := aHashMap;
  Page := 0;
  Index := -1;
  Pair := nil;
end;

procedure THashMapBase.TIterator.Done;
begin
end;

function THashMapBase.TIterator.Next: Boolean;
begin
  Inc(Index);
  while Index > High(HashMap.FTable[Page]) do begin
    Inc(Page);
    if Page > High(HashMap.FTable) then
      Exit(False);
    Index := 0;
  end;
  Pair := @HashMap.FTable[Page][Index];
  Exit(True);
end;

constructor THashMapToObject.Init(Pages: LongInt = 128);
begin
  FMap.Init(Pages);
end;

destructor THashMapToObject.Done;
begin
  Clear(True);
end;

function THashMapToObject.Has(const Key: TKey): Boolean;
begin
  Result := FMap.Has(Key);
end;

function THashMapToObject.Alloc(const Key: TKey): PObj;
begin
  if FMap.FindOrAlloc(Key, Result) then
    Result^.Done;
end;

function THashMapToObject.Get(const Key: TKey; Def: PObj): PObj;
begin
  Result := FMap.Get(Key, Def);
end;

procedure THashMapToObject.Del(const Key: TKey; CallDtor: Boolean);
var
  P: PObj;
begin
  if CallDtor and Find(Key, P) then
    P^.Done;
  FMap.Del(Key);
end;

procedure THashMapToObject.Clear(CallDtor: Boolean);
var
  Page, Index: LongInt;
begin
  for Page := 0 to High(FMap.FTable) do
    for Index := 0 to High(FMap.FTable[Page]) do
      FMap.FTable[Page][Index].Value.Done;
  FMap.Clear;
end;

function THashMapToObject.Find(const Key: TKey; var P: PObj): Boolean;
begin
  Result := FMap.Find(Key, P);
end;

function THashMapToObject.GetOrInit(const Key: TKey): PObj;
begin
  if not FMap.FindOrAlloc(Key, Result) then
    Result.Init;
end;

function THashMapToObject.GetOrAlloc(const Key: TKey): PObj;
begin
  if FMap.FindOrAlloc(Key, Result) then
    Result^.Done;
end;

procedure THashMapToObject.TIterator.Init(aHashMap: TPtr);
begin
  FIt.Init(@aHashMap^.FMap);
end;

procedure THashMapToObject.TIterator.Done;
begin
  FIt.Done;
end;

function THashMapToObject.TIterator.Next: Boolean;
begin
  Result := FIt.Next;
end;

function THashMapToObject.TIterator.Key: TKey;
begin
  Result := FIt.Pair.Key;
end;

function THashMapToObject.TIterator.Value: PObj;
begin
  Result := @FIt.Pair.Value;
end;

constructor THashMapToPointer.Init(Pages: LongInt = 128);
begin
  FMap.Init(Pages);
end;

destructor THashMapToPointer.Done;
begin
  FMap.Done;
end;

function THashMapToPointer.Has(const Key: TKey): Boolean;
begin
  Result := FMap.Has(Key);
end;

function THashMapToPointer.Alloc(const Key: TKey): TPointer;
begin
  FMap.FindOrAlloc(Key, Pointer(Result));
  Result := TPointer(PPointer(Result)^);
end;

procedure THashMapToPointer.Add(const Key: TKey; Value: TPointer);
var
  P: PPointer;
begin
  FMap.FindOrAlloc(Key, P);
  TPointer(P^) := Value;
end;

function THashMapToPointer.Get(const Key: TKey; Def: TPointer): TPointer;
var
  Temp: PPointer;
begin
  if FMap.Find(Key, Temp) then begin
    Result := TPointer(PPointer(Temp)^);
  end else
    Result := Def;
end;

procedure THashMapToPointer.Del(const Key: TKey);
begin
  FMap.Del(Key);
end;

function THashMapToPointer.Find(const Key: TKey; var P: TPointer): Boolean;
begin
  Result := FMap.Find(Key, Pointer(P));
  if Result then
    P := TPointer(PPointer(P)^);
end;

procedure THashMapToPointer.TIterator.Init(aHashMap: TPtr);
begin
  FIt.Init(@aHashMap^.FMap);
end;

procedure THashMapToPointer.TIterator.Done;
begin
  FIt.Done;
end;

function THashMapToPointer.TIterator.Next: Boolean;
begin
  Result := FIt.Next;
end;

function THashMapToPointer.TIterator.Key: TKey;
begin
  Result := FIt.Pair.Key;
end;

function THashMapToPointer.TIterator.Value: TPointer;
begin
  Result := FIt.Pair.Value;
end;

end.
