unit dgeneric_hashmap_ptr;

{$MODE FPC}
{$MODESWITCH ADVANCEDRECORDS}
{$MODESWITCH DEFAULTPARAMETERS}
{$MODESWITCH OUT}
{$MODESWITCH RESULT}

interface

type
generic TGenericHashMapToPtr<
  TKey,         // one of "string"-like types
  TKeyManager,  // see d*_manager modules
      //  constructor TKeyManager.Init;
      //  destructor  TKeyManager.Done;
      //  procedure   TKeyManager.Initialize(var Key: TKey);
      //  procedure   TKeyManager.Finalize(var Key: TKey);
      //  function    TKeyManager.Compare(const A, B: TKey): PtrInt;
      //  function    TKeyManager.Assign(out Dst: TKey; const Src: TKey): Boolean;
  TValue,       // must be one of plain pointer types
  THashFunc,    // see d*_generic moudules
      //  constructor THashFunc.Init;
      //  destructor  THashFunc.Done;
      //  function    THashFunc.Get(P: Pointer; S: SizeUInt): PtrUInt;
  TAllocator    // see dallocator_* modules
      //  constructor TAllocator.Init;
      //  destructor  TAllocator.Done;
      //  function    TAllocator.GetMem(Size: SizeUInt): Pointer;
      //  procedure   TAllocator.FreeMem(P: Pointer);
> = object

public type
  TPtr = ^TGenericHashMapToPtr;
  PKey = ^TKey;
  PValue = ^TValue;

  PItem = ^TItem;
  TItem = record
    public  Hash: PtrUInt;
    public  Key: TKey;
    public  Value: TValue;
    private Next: PItem;
  end;

private type
  PBucketOrTable = ^TBucketOrTable;
  TBucketOrTable = record
    IsBucket: Boolean;
    Count: SizeUInt;
    Capacity: SizeUInt;
    Shift: SizeUInt;
    P: Pointer;
  end;

private
  FAllocator: TAllocator;
  FHashFunc: THashFunc;
  FKeyManager: TKeyManager;
  FBucketOrTable: TBucketOrTable;

  function _Find(H: PtrUInt; B: PBucketOrTable; const Key: TKey; out Value: TValue): Boolean;
  function _FindItem(H: PtrUInt; B: PBucketOrTable; const Key: TKey; out Item: PItem): Boolean;
  function _NewItem(H: PtrUInt; const Key: TKey; const Value: TValue; Next: PItem): PItem;
  procedure _DisposeItem(Item: PItem);
  procedure _RelocateToTable(List: PItem; Table: PBucketOrTable);
  function _ResizeTable(Table: PBucketOrTable; NewCount: SizeUInt): Boolean;
      // All elements of the Table must be buckets.
  function _BucketToTable(Bucket: PBucketOrTable; Count: SizeUInt): Boolean;
  function _Put(H: PtrUInt; B: PBucketOrTable; const Key: TKey; const Value: TValue): Boolean;
  function _Remove(H: PtrUInt; B: PBucketOrTable; const Key: TKey): Boolean;
  procedure _Clear(B: PBucketOrTable);

public
  procedure Init;
  procedure Done;
  function IsEmpty: Boolean;
  procedure Clear;
  function Has(const Key: TKey): Boolean;

  function Find(const Key: TKey; out Value: TValue): Boolean;
      //
      //  Searches for element with the Key. Returns True and the Value if
      //  found. Returns False and leave Value unmodified otherwise.
      //

  function Put(const Key: TKey; Value: TValue): Boolean;
      //
      //  Sets values of the Key to the Value. Returns True on success.
      //  Returns False on out of memory error (if allocator did not raise
      //  an exception).
      //

  function Remove(const Key: TKey): Boolean;
      //
      //  Remove all pairs with the Key key.
      //

  function GetOrNil(const Key: TKey): TValue;
      //
      //  Searches for element with the Key. Returns the value of the element
      //  or nil if an element not found.
      //

  function FindOrPut(const Key: TKey;
                     out Found: TValue;
                     Value: TValue): Boolean;

public type
  TIterator = record
      //
      //  Iterates each pair with specified Key.
      //
      //  HashMap and Key must be alive and unmodified all the TIterator's
      //  lifetime.
      //
      //  Example:
      //
      //      var
      //        Iterator: TSpecializedHashMap.TIterator;
      //
      //        Iterator.Init(HashMap, Key);
      //        while Iterator.Next do begin
      //          // ..
      //        end;
      //        Iterator.Done;
      //
  private
    FItem: PItem;
    FKey: PKey;
    FHashMap: TPtr;
    FFakeItem: TItem; // is used for storing Hash and faking previous state on
                      // first iteration
  public
    procedure Init(HashMap: TPtr; const Key: TKey);
    procedure Done;
    function Next: Boolean;
    property Item: PItem read FItem;
  end;

  TIteratorAll = record
      //
      //  Iterates each pair in the hash table.
      //
      //  Example:
      //
      //      var
      //        Iterator: TSpecializedHashMap.TIteratorAll;
      //
      //        Iterator.Init(HashMap);
      //        while Iterator.Next do begin
      //          // ..
      //        end;
      //        Iterator.Done;
      //
  private type
    TStackEntry = record
      Table: PBucketOrTable;
      Index: PtrInt;
    end;
  private
    FItem: PItem;
    FTop: SizeInt;
    FStack: array of TStackEntry;
    FHashMap: TPtr;
  public
    procedure Init(HashMap: TPtr);
    procedure Done;
    function Next: Boolean;
    property Item: PItem read FItem;
  end;
end;

implementation

function TGenericHashMapToPtr._Find(H: PtrUInt; B: PBucketOrTable; const Key: TKey; out Value: TValue): Boolean;
var
  P: PItem;
begin
  if B^.IsBucket then begin
    P := B^.P;
    while P <> nil do begin
      if (H = P^.Hash) and (FKeyManager.Compare(Key, P^.Key) = 0) then begin
        Value := P^.Value;
        Exit(True);
      end;
      P := P^.Next;
    end;
  end else begin
    Exit(_Find(H, @PBucketOrTable(B^.P)[(H shr B^.Shift) mod B^.Count], Key, Value));
  end;
end;

function TGenericHashMapToPtr._FindItem(H: PtrUInt; B: PBucketOrTable; const Key: TKey; out Item: PItem): Boolean;
var
  P: PItem;
begin
  if B^.IsBucket then begin
    P := B^.P;
    while P <> nil do begin
      if (H = P^.Hash) and (FKeyManager.Compare(Key, P^.Key) = 0) then begin
        Item := P;
        Exit(True);
      end;
      P := P^.Next;
    end;
  end else begin
    Exit(_FindItem(H, @PBucketOrTable(B^.P)[(H shr B^.Shift) mod B^.Count], Key, Item));
  end;
end;

function TGenericHashMapToPtr._NewItem(H: PtrUInt; const Key: TKey; const Value: TValue; Next: PItem): PItem;
begin
  Result := FAllocator.GetMem(SizeOf(TItem));
  if Result <> nil then begin
    Result^.Hash := H;
    FKeyManager.Initialize(Pointer(Result^.Key));
    if not FKeyManager.Assign(Result^.Key, Key) then begin
      FKeyManager.Finalize(Result^.Key);
      FAllocator.FreeMem(Result);
      Exit(nil);
    end;
    Result^.Value := Value;
    Result^.Next := Next;
  end;
end;

procedure TGenericHashMapToPtr._DisposeItem(Item: PItem);
begin
  FKeyManager.Finalize(Item^.Key);
  FAllocator.FreeMem(Item);
end;

procedure TGenericHashMapToPtr._RelocateToTable(List: PItem; Table: PBucketOrTable);
var
  Next: PItem;
  I: PtrUInt;
begin
  while List <> nil do begin
    Next := List^.Next;
    I := (List^.Hash shr Table^.Shift) mod Table^.Count;
    List^.Next := PBucketOrTable(Table^.P)[I].P;
    PBucketOrTable(Table^.P)[I].P := List;
    List := Next;
  end;
end;

function TGenericHashMapToPtr._ResizeTable(Table: PBucketOrTable; NewCount: SizeUInt): Boolean;
var
  OldTable: TBucketOrTable;
  NewTable: PBucketOrTable;
  I: SizeInt;
begin
  OldTable := Table^;
  NewTable := FAllocator.GetMem(NewCount * SizeOf(TBucketOrTable));
  if NewTable = nil then
    Exit(False);
  Table^.Count := NewCount;
  Table^.Capacity := NewCount;
  Table^.P := NewTable;
  for I := 0 to NewCount - 1 do begin
    PBucketOrTable(Table^.P)[I].IsBucket := True;
    PBucketOrTable(Table^.P)[I].Count := 0;
    PBucketOrTable(Table^.P)[I].Capacity := 0;
    PBucketOrTable(Table^.P)[I].Shift := 0;
    PBucketOrTable(Table^.P)[I].P := nil;
  end;
  for I := 0 to OldTable.Count - 1 do begin
    _RelocateToTable(PBucketOrTable(OldTable.P)[I].P, Table);
  end;
  FAllocator.FreeMem(OldTable.P);
  Exit(True);
end;

function TGenericHashMapToPtr._BucketToTable(Bucket: PBucketOrTable; Count: SizeUInt): Boolean;
var
  OldBucket: TBucketOrTable;
  NewP: Pointer;
begin
  OldBucket := Bucket^;
  NewP := FAllocator.GetMem(Count * SizeOf(TBucketOrTable));
  if NewP = nil then
    Exit(False);
  Bucket^.IsBucket := False;
  Bucket^.Count := Count;
  Bucket^.Capacity := Count;
  Bucket^.Shift := 5;
  Bucket^.P := NewP;
  _RelocateToTable(OldBucket.P, Bucket);
  Exit(True);
end;

function TGenericHashMapToPtr._Put(H: PtrUInt; B: PBucketOrTable; const Key: TKey; const Value: TValue): Boolean;
var
  Item: PItem;
begin
  if B^.IsBucket then begin
    if B^.Count >= 4 then begin
      if not _BucketToTable(B, 32) then
        Exit(False);
      Exit(_Put(H, B, Key, Value));
    end;
    Item := _NewItem(H, Key, Value, B^.P);
    if Item = nil then
      Exit(False);
    B^.P := Item;
    Exit(True);
  end else begin
    Exit(_Put(H, @PBucketOrTable(B^.P)[(H shr B^.Shift) mod B^.Count], Key, Value));
  end;
end;

function TGenericHashMapToPtr._Remove(H: PtrUInt; B: PBucketOrTable; const Key: TKey): Boolean;
var
  FixPos, NextFixPos: Pointer;
  Item, Next: PItem;
begin
  if B^.IsBucket then begin
    FixPos := @B^.P;
    Item := B^.P;
    while Item <> nil do begin
      Next := Item^.Next;
      NextFixPos := @Item^.Next;
      if (H = Item^.Hash) and (FKeyManager.Compare(Key, Item^.Key) = 0) then begin
        PItem(FixPos^) := Next;
        _DisposeItem(Item);
      end else
        FixPos := NextFixPos;
      Item := Next;
    end;
  end else begin
    Exit(_Remove(H, @PBucketOrTable(B^.P)[(H shr B^.Shift) mod B^.Count], Key));
  end;
end;

procedure TGenericHashMapToPtr._Clear(B: PBucketOrTable);
var
  Item, Next: PItem;
  I: PtrInt;
begin
  if B^.IsBucket then begin
    Item := B^.P;
    while Item <> nil do begin
      Next := Item^.Next;
      FKeyManager.Finalize(Item^.Key);
      FAllocator.FreeMem(Item);
      Item := Next;
    end;
  end else begin
    for I := 0 to B^.Count - 1 do
      _Clear(@PBucketOrTable(B^.P)[I]);
    FAllocator.FreeMem(B^.P);
  end;
end;

procedure TGenericHashMapToPtr.Init;
begin
  FAllocator.Init;
  FHashFunc.Init;
  FKeyManager.Init;
  FBucketOrTable.IsBucket := True;
  FBucketOrTable.Count := 0;
  FBucketOrTable.Capacity := 0;
  FBucketOrTable.Shift := 0;
  FBucketOrTable.P := nil;
end;

procedure TGenericHashMapToPtr.Done;
begin
  Clear;
  FKeyManager.Done;
  FHashFunc.Done;
  FAllocator.Done;
end;

function TGenericHashMapToPtr.IsEmpty: Boolean;
begin
  Exit(True); // TODO
end;

procedure TGenericHashMapToPtr.Clear;
begin
  _Clear(@FBucketOrTable);
  FBucketOrTable.IsBucket := True;
  FBucketOrTable.Count := 0;
  FBucketOrTable.Capacity := 0;
  FBucketOrTable.Shift := 0;
  FBucketOrTable.P := nil;
end;

function TGenericHashMapToPtr.Has(const Key: TKey): Boolean;
var
  Value: TValue;
begin
  Exit(Find(Key, Value));
end;

function TGenericHashMapToPtr.Find(const Key: TKey; out Value: TValue): Boolean;
var
  H: PtrUInt;
begin
  H := FHashFunc.Get(FKeyManager.FirstOf(Key), FKeyManager.LengthOf(Key));
  Exit(_Find(H, @FBucketOrTable, Key, Value));
end;

function TGenericHashMapToPtr.Put(const Key: TKey; Value: TValue): Boolean;
var
  H: PtrUInt;
begin
  H := FHashFunc.Get(FKeyManager.FirstOf(Key), FKeyManager.LengthOf(Key));
  Exit(_Put(H, @FBucketOrTable, Key, Value));
end;

function TGenericHashMapToPtr.Remove(const Key: TKey): Boolean;
var
  H: PtrUInt;
begin
  H := FHashFunc.Get(FKeyManager.FirstOf(Key), FKeyManager.LengthOf(Key));
  Exit(_Remove(H, @FBucketOrTable, Key));
end;

function TGenericHashMapToPtr.GetOrNil(const Key: TKey): TValue;
begin
  if not Find(Key, Result) then
    Exit(nil);
end;

function TGenericHashMapToPtr.FindOrPut(const Key: TKey;
                                        out Found: TValue;
                                        Value: TValue): Boolean;
begin
  if not Find(Key, Found) then begin
    Exit(Put(Key, Value));
  end else
    Exit(False);
end;

procedure TGenericHashMapToPtr.TIterator.Init(HashMap: TPtr; const Key: TKey);
begin
  FHashMap := HashMap;
  FFakeItem.Hash := HashMap^.FHashFunc.Get(HashMap^.FKeyManager.FirstOf(Key), HashMap^.FKeyManager.LengthOf(Key));
  if HashMap^._FindItem(FFakeItem.Hash, @FHashMap^.FBucketOrTable, Key, FFakeItem.Next) then begin
    FItem := @FFakeItem;
  end else
    FItem := nil;
end;

procedure TGenericHashMapToPtr.TIterator.Done;
begin
end;

function TGenericHashMapToPtr.TIterator.Next: Boolean;
begin
  if FItem = nil then
    Exit(False);
  FItem := FItem^.Next;
  while FItem <> nil do begin
    if (FFakeItem.Hash = Item^.Hash) and (FHashMap^.FKeyManager.Compare(FKey^, FItem^.Key) = 0) then
      Exit(True);
    FItem := FItem^.Next;
  end;
  Exit(False);
end;

procedure TGenericHashMapToPtr.TIteratorAll.Init(HashMap: TPtr);
begin
  FHashMap := HashMap;
  SetLength(FStack, 16);
  FStack[0].Index := -1;
  FStack[0].Table := @FHashMap^.FBucketOrTable;
  FItem := nil;
  FTop := 0;
end;

procedure TGenericHashMapToPtr.TIteratorAll.Done;
begin
  SetLength(FStack, 0);
end;

function TGenericHashMapToPtr.TIteratorAll.Next: Boolean;
begin
  if FItem <> nil then begin
    FItem := FItem^.Next;
    if FItem <> nil then
      Exit(True);
  end;
  if FTop < 0 then
    Exit(False);
  while FTop >= 0 do begin
    if FStack[FTop].Table^.IsBucket then begin
      FItem := FStack[FTop].Table^.P;
      Dec(FTop);
      if FItem <> nil then
        Exit(True);
      continue;
    end;
    Inc(FStack[FTop].Index);
    if FStack[FTop].Index >= FStack[FTop].Table^.Count then begin
      Dec(FTop);
      continue;
    end;
    FStack[FTop + 1].Index := -1;
    FStack[FTop + 1].Table := @PBucketOrTable(FStack[FTop].Table^.P)[FStack[FTop].Index];
    Inc(FTop);
  end;
  Exit(False);
end;

end.
