// Doj's yet another HashMap
{$MODE FPC}
{$MODESWITCH ADVANCEDRECORDS}
{$MODESWITCH DEFAULTPARAMETERS}
{$MODESWITCH OUT}
{$MODESWITCH RESULT}
unit dya_hashmap_impl;

interface

type
THashMapValueDestructor = procedure (Value: Pointer; ValueLen: SizeUInt) of object;
THashMapGetMem = procedure (out P: Pointer; Size: PtrUInt; Allocator: Pointer);
THashMapFreeMem = procedure (P: Pointer; Size: PtrUInt; Allocator: Pointer);
THashMapReAllocMem = function (var P: Pointer; Size: PtrUInt; Allocator: Pointer): Pointer;

THashMapAllocator = packed record
  Allocator: Pointer;
  GetMem: THashMapGetMem;
  FreeMem: THashMapFreeMem;
  ReAllocMem: THashMapReAllocMem;
end;

THashMap = packed record
  Buckets: Pointer;
  Count: SizeUInt;
  ValueDestructor: THashMapValueDestructor;
  Allocator: Pointer;
  GetMem: THashMapGetMem;
  FreeMem: THashMapFreeMem;
  ReAllocMem: THashMapReAllocMem;
end;

THashMapHash = SizeUInt;

THashMapKey = packed record
  Data: PAnsiChar;
  Len: SizeUInt;
  Hash: THashMapHash;
end;

THashMapValue = packed record
  Data: Pointer;
  Len: SizeUInt;
end;

THashMapIterator = packed record
  Bucket: Pointer;
  BucketEnd: Pointer;
  Pair: Pointer;
  Key: THashMapKey;
  Value: THashMapValue;
end;

THashMapStats = packed record
  Buckets: SizeUInt;
  Pairs: SizeUInt;
  Collisions: SizeUInt;
  // Total allocated memory in bytes
  Allocated: SizeUInt;
  // Non contiguous regions of memory
  Noncontiguous: SizeUInt;
end;

//
//  HashMapInit
//  HashMapDone
//
//      Constructor and destructor.
//
procedure HashMapInit(out HashMap: THashMap;
                      ValueDestructor: THashMapValueDestructor = nil;
                      Allocator: Pointer = nil;
                      GetMem: THashMapGetMem = nil;
                      FreeMem: THashMapFreeMem = nil;
                      ReAllocMem: THashMapReAllocMem = nil);
procedure HashMapDone(var HashMap: THashMap);

//
//  HashMapClear
//
//    Removes all data inside hashmap
//
procedure HashMapClear(var HashMap: THashMap);

//
//  HashMapIsEmpty
//
//      Checks whenever the HashMap is empty.
//
function HashMapIsEmpty(var HashMap: THashMap): Boolean;

//
//  HashMapAdd
//
//      Adds new element and copies new data to it.
//
procedure HashMapAdd(var HashMap: THashMap;
                     constref Key: THashMapKey;
                     Value: Pointer; ValueLen: SizeUInt);

//
//  HashMapEmplace
//
//      Adds new element and returns uninitialized data for it.
//
function HashMapEmplace(var HashMap: THashMap;
                        constref Key: THashMapKey;
                        ValueLen: SizeUInt): Pointer;

//
//  HashMapDelete
//
//      Removes all elements with specified key.
//
procedure HashMapDelete(var HashMap: THashMap;
                        constref Key: THashMapKey);

//
//  HashMapFind
//
//      Searches for one element with specified key.
//
function HashMapFind(constref HashMap: THashMap;
                     constref Key: THashMapKey;
                     out Value: THashMapValue): Boolean;

procedure HashMapGetStats(constref HashMap: THashMap;
                          out Stats: THashMapStats);

procedure HashMapIteratorInit(constref HashMap: THashMap;
                              constref K: THashMapKey;
                              out It: THashMapIterator); overload;
procedure HashMapIteratorInit(constref HashMap: THashMap;
                              out It: THashMapIterator); overload;
procedure HashMapIteratorDone(var It: THashMapIterator);
function HashMapIteratorNext(var It: THashMapIterator): Boolean;

implementation

const
  HASHMAP_INITIAL_BUCKETS = 32;

type
PHashMapPair = ^THashMapPair;
THashMapPair = packed record
  Key: THashMapKey;
  Value: THashMapValue;
  Next: PHashMapPair;
end;

PHashMapBucket = ^THashMapBucket;
THashMapBucket = packed record
  First: PHashMapPair;
end;

TDummy = object
  procedure DefaultValueDestructor(Value: Pointer; ValueLen: SizeUInt);
end;

var
  Dummy: TDummy;

procedure TDummy.DefaultValueDestructor(Value: Pointer; ValueLen: SizeUInt);
begin
  // do nothing
end;

procedure DefaultValueDestructor(Value: Pointer; ValueLen: SizeUInt);
begin
  // do nothing
end;

procedure DefaultGetMem(out P: Pointer; Size: PtrUInt; Allocator: Pointer);
begin
  System.GetMem(P, Size);
end;

procedure DefaultFreeMem(P: Pointer; Size: PtrUInt; Allocator: Pointer);
begin
  System.FreeMem(P, Size);
end;

function DefaultReAllocMem(var P: Pointer; Size: PtrUInt; Allocator: Pointer): Pointer;
begin
  Result := System.ReAllocMem(P, Size);
end;

procedure HashMapInit(out HashMap: THashMap;
                      ValueDestructor: THashMapValueDestructor = nil;
                      Allocator: Pointer = nil;
                      GetMem: THashMapGetMem = nil;
                      FreeMem: THashMapFreeMem = nil;
                      ReAllocMem: THashMapReAllocMem = nil);
begin
  HashMap.Buckets := nil;
  HashMap.Count := 1;
  if ValueDestructor <> nil then begin
    HashMap.ValueDestructor := ValueDestructor;
  end else
    HashMap.ValueDestructor := @Dummy.DefaultValueDestructor;
  HashMap.Allocator := Allocator;
  if GetMem <> nil then begin
    HashMap.GetMem := GetMem;
  end else
    HashMap.GetMem := @DefaultGetMem;
  if FreeMem <> nil then begin
    HashMap.FreeMem := FreeMem;
  end else
    HashMap.FreeMem := @DefaultFreeMem;
  if ReAllocMem <> nil then begin
    HashMap.ReAllocMem := ReAllocMem
  end else
    HashMap.ReAllocMem := @DefaultReAllocMem;
end;

procedure HashMapDone(var HashMap: THashMap);
begin
  HashMapClear(HashMap);
end;

procedure HashMapClear(var HashMap: THashMap);
var
  Bucket, BucketEnd: PHashMapBucket;
  Pair, Next: PHashMapPair;
begin
  if HashMap.Buckets = nil then
    Exit;
  Bucket := HashMap.Buckets;
  BucketEnd := PHashMapBucket(HashMap.Buckets) + HashMap.Count;
  while Bucket < BucketEnd do begin
    Pair := Bucket^.First;
    while Pair <> nil do begin
      Next := Pair^.Next;
      HashMap.ValueDestructor(Pair^.Value.Data, Pair^.Value.Len);
      HashMap.FreeMem(Pair^.Key.Data, Pair^.Key.Len, HashMap.Allocator);
      HashMap.FreeMem(Pair^.Value.Data, Pair^.Value.Len, HashMap.Allocator);
      HashMap.FreeMem(Pair, SizeOf(THashMapPair), HashMap.Allocator);
      Pair := Next;
    end;
    Inc(Bucket);
  end;
  HashMap.FreeMem(HashMap.Buckets, HashMap.Count * SizeOf(THashMapPair), HashMap.Allocator);
  HashMap.Buckets := nil;
  HashMap.Count := 1;
end;

function HashMapIsEmpty(var HashMap: THashMap): Boolean;
begin
  Result := HashMap.Buckets = nil;
end;

procedure HashMapClearBuckets(Bucket, BucketEnd: PHashMapBucket);
begin
  while Bucket < BucketEnd do begin
    Bucket^.First := nil;
    Inc(Bucket);
  end;
end;

procedure HashMapMove(Prev, Item: PHashMapPair;
                      var List: PHashMapPair);
begin
  if Prev <> nil then
    Prev^.Next := Item^.Next;
  Item^.Next := List;
  List := Item;
end;

procedure HashMapGrowBuckets(var HashMap: THashMap; NewCount: SizeUInt);
var
  OldCount: SizeUInt;
  Bucket, BucketEnd: PHashMapBucket;
  Prev, Pair, Next: PHashMapPair;
  H: SizeUInt;
begin
  // 1. Allocate new memory
  if HashMap.Buckets = nil then begin
    OldCount := 0;
    HashMap.GetMem(Pointer(HashMap.Buckets), NewCount * SizeOf(THashMapBucket), HashMap.Allocator);
  end else begin
    OldCount := HashMap.Count;
    HashMap.Buckets := HashMap.ReAllocMem(Pointer(HashMap.Buckets), NewCount * SizeOf(THashMapBucket), HashMap.Allocator);
  end;
  // 2. Clear new data
  Bucket := PHashMapBucket(HashMap.Buckets) + OldCount;
  BucketEnd := PHashMapBucket(HashMap.Buckets) + NewCount;
  HashMapClearBuckets(Bucket, BucketEnd);
  // 3. Move elements from old buckets to new
  Bucket := HashMap.Buckets;
  BucketEnd := PHashMapBucket(HashMap.Buckets) + OldCount;
  while Bucket < BucketEnd do begin
    Prev := nil;
    Pair := Bucket^.First;
    while Pair <> nil do begin
      Next := Pair^.Next;
      H := Pair^.Key.Hash mod NewCount;
      if H >= OldCount then begin
        if Prev = nil then
          Bucket^.First := Next;
        HashMapMove(Prev, Pair, PHashMapBucket(HashMap.Buckets)[H].First);
        Pair := Next;
      end else begin
        Prev := Pair;
        Pair := Next;
      end;
    end;
  end;
  // 4. Sync data
  HashMap.Count := NewCount;
end;

procedure HashMapGrowStrategy(var HashMap: THashMap);
begin
end;

procedure HashMapAdd(var HashMap: THashMap;
                     constref Key: THashMapKey;
                     Value: Pointer; ValueLen: SizeUInt);
begin
  Move(Value^, HashMapEmplace(HashMap, Key, ValueLen)^, ValueLen);
end;

function HashMapEmplace(var HashMap: THashMap;
                        constref Key: THashMapKey;
                        ValueLen: SizeUInt): Pointer;
var
  H: SizeUInt;
  Pair: PHashMapPair;
begin
  if HashMap.Buckets = nil then begin
    HashMapGrowBuckets(HashMap, HASHMAP_INITIAL_BUCKETS);
  end;
  H := Key.Hash mod HashMap.Count;
  HashMap.GetMem(Pair, SizeOf(THashMapPair), HashMap.Allocator);
  HashMap.GetMem(Pointer(Pair^.Key.Data), Key.Len, HashMap.Allocator);
  HashMap.GetMem(Pointer(Pair^.Value.Data), ValueLen, HashMap.Allocator);
  Move(Key.Data^, Pair^.Key.Data^, Key.Len);
  Pair^.Key.Len := Key.Len;
  Pair^.Key.Hash := Key.Hash;
  Pair^.Value.Len := ValueLen;
  Pair^.Next := PHashMapBucket(HashMap.Buckets)[H].First;
  PHashMapBucket(HashMap.Buckets)[H].First := Pair;
  Result := Pair^.Value.Data;
end;

procedure HashMapDelete(var HashMap: THashMap;
                        constref Key: THashMapKey);
begin
end;

function HashMapFindPair(Pair: PHashMapPair;
                         constref Key: THashMapKey;
                         out Value: THashMapValue): Boolean;
begin
  while Pair <> nil do begin
    if (Key.Hash = Pair^.Key.Hash) and (Key.Len = Pair^.Key.Len) and (CompareByte(Key.Data^, Pair^.Key.Data^, Key.Len) = 0) then begin
      Value := Pair^.Value;
      Exit(True);
    end;
    Pair := Pair^.Next;
  end;
  Exit(False);
end;

function HashMapFind(constref HashMap: THashMap;
                     constref Key: THashMapKey;
                     out Value: THashMapValue): Boolean;
var
  H: THashMapHash;
begin
  if HashMap.Buckets = nil then
    Exit(False);
  H := Key.Hash mod HashMap.Count;
  Result := HashMapFindPair(PHashMapBucket(HashMap.Buckets)[H].First, Key, Value);
end;

procedure HashMapGetStats(constref HashMap: THashMap;
                          out Stats: THashMapStats);
var
  Bucket, BucketEnd: PHashMapBucket;
  Pair: PHashMapPair;
begin
  Stats.Buckets := HashMap.Count;
  Stats.Pairs := 0;
  Stats.Collisions := 0;
  Stats.Allocated := 0;
  Stats.Noncontiguous := 0;
  Stats.Allocated := SizeOf(THashMap);
  Bucket := HashMap.Buckets;
  if Bucket <> nil then begin
    Stats.Noncontiguous := 1;
    Inc(Stats.Allocated, HashMap.Count * SizeOf(THashMapBucket));
    BucketEnd := PHashMapBucket(HashMap.Buckets) + HashMap.Count;
    while Bucket < BucketEnd do begin
      Pair := Bucket^.First;
      if Pair <> nil then
        Dec(Stats.Collisions);
      while Pair <> nil do begin
        Inc(Stats.Pairs);
        Inc(Stats.Collisions);
        Inc(Stats.Allocated, SizeOf(THashMapPair) + Pair^.Key.Len + Pair^.Value.Len);
        Inc(Stats.Noncontiguous, 3);
        Pair := Pair^.Next;
      end;
      Inc(Bucket);
    end;
  end;
end;

procedure HashMapIteratorInit(constref HashMap: THashMap;
                              constref K: THashMapKey;
                              out It: THashMapIterator);
begin
end;

procedure HashMapIteratorInit(constref HashMap: THashMap;
                              out It: THashMapIterator);
begin
end;

procedure HashMapIteratorDone(var It: THashMapIterator);
begin
end;

function HashMapIteratorNext(var It: THashMapIterator): Boolean;
begin
  Result := False;
end;

end.
