{ Brief: A utility iterating function that calls TObject.Free for all
  data items in a map.
  Example:
    This frees all objects in the map and clears the map.
    <code>
    var
      myMap: TStringHashMap;
      // ...
      myMap.Iterate(nil, Iterate_FreeObjects);
      myMap.Clear;
    </code> }
function Iterate_FreeObjects(AUserData: Pointer; const AStr: string;
  var AData: Pointer): Boolean;
{ Brief: A utility iterating function that calls Dispose for all data
  items in a map.
  See Also: Iterate_FreeObjects }
function Iterate_Dispose(AUserData: Pointer; const AStr: string;
  var AData: Pointer): Boolean;
{ Brief: A utility iterating function that calls FreeMem for all data
  items in a map.
  See Also: Iterate_FreeMem }
function Iterate_FreeMem(AUserData: Pointer; const AStr: string;
  var AData: Pointer): Boolean;

type
  { Brief: A useful concrete descendant of TStringHashMapTraits which
    implements case sensitive traits, with order based on ordinal value.
    See Also: TCaseInsensitiveTraits }
  TCaseSensitiveTraits = class(TStringHashMapTraits)
  public
    function Hash(const s: string): Cardinal; override;
    function Compare(const l, r: string): Integer; override;
  end;

type
  { Brief: A useful concrete descendant of TStringHashMapTraits which
    implements case insensitive traits, with order based on ordinal value.
    See Also: TCaseSensitiveTraits }
  TCaseInsensitiveTraits = class(TStringHashMapTraits)
  public
    function Hash(const s: string): Cardinal; override;
    function Compare(const l, r: string): Integer; override;
  end;

implementation

{
  ======================================================================
  Case Sensitive & Insensitive Traits
  ======================================================================
}

function TCaseSensitiveTraits.Compare(const l, r: string): Integer;
begin
  Result := CompareStr(l, r);
end;

function TCaseSensitiveTraits.Hash(const s: string): Cardinal;
begin
  Result := StrHash(s);
end;

function TCaseInsensitiveTraits.Compare(const l, r: string): Integer;
begin
  Result := CompareText(l, r);
end;

function TCaseInsensitiveTraits.Hash(const s: string): Cardinal;
begin
  Result := TextHash(s);
end;

var
  _CaseSensitiveTraits: TCaseSensitiveTraits;

function CaseSensitiveTraits: TStringHashMapTraits;
begin
  if _CaseSensitiveTraits = nil then
    _CaseSensitiveTraits := TCaseSensitiveTraits.Create;
  Result := _CaseSensitiveTraits;
end;

var
  _CaseInsensitiveTraits: TCaseInsensitiveTraits;

function CaseInsensitiveTraits: TStringHashMapTraits;
begin
  if _CaseInsensitiveTraits = nil then
    _CaseInsensitiveTraits := TCaseInsensitiveTraits.Create;
  Result := _CaseInsensitiveTraits;
end;

function Iterate_FreeObjects(AUserData: Pointer; const AStr: string;
  var AData: Pointer): Boolean;
begin
  TObject(AData).Free;
  AData := nil;
  Result := True;
end;

function Iterate_Dispose(AUserData: Pointer; const AStr: string;
  var AData: Pointer): Boolean;
begin
  Dispose(AData);
  AData := nil;
  Result := True;
end;

function Iterate_FreeMem(AUserData: Pointer; const AStr: string;
  var AData: Pointer): Boolean;
begin
  FreeMem(AData);
  AData := nil;
  Result := True;
end;

function StrHash(const s: string): Cardinal;
var
  i: Integer;
  p: PChar;
const
  C_LongBits = 32;
  C_OneEight = 4;
  C_ThreeFourths = 24;
  C_HighBits = $F0000000;
var
  temp: Cardinal;
begin
  {TODO I should really be processing 4 bytes at once... }
  Result := 0;
  p := PChar(s);

  i := Length(s);
  while i > 0 do
  begin
    Result := (Result shl C_OneEight) + Ord(p^);
    temp := Result and C_HighBits;
    if temp <> 0 then
      Result := (Result xor (temp shr C_ThreeFourths)) and (not C_HighBits);
    Dec(i);
    Inc(p);
  end;
end;

function TextHash(const s: string): Cardinal;
var
  i: Integer;
  p: PChar;
const
  C_LongBits = 32;
  C_OneEight = 4;
  C_ThreeFourths = 24;
  C_HighBits = $F0000000;
var
  temp: Cardinal;
begin
  {TODO I should really be processing 4 bytes at once... }
  Result := 0;
  p := PChar(s);

  i := Length(s);
  while i > 0 do
  begin
    Result := (Result shl C_OneEight) + Ord(UpCase(p^));
    temp := Result and C_HighBits;
    if temp <> 0 then
      Result := (Result xor (temp shr C_ThreeFourths)) and (not C_HighBits);
    Dec(i);
    Inc(p);
  end;
end;

function DataHash(var AValue; ASize: Cardinal): THashValue;
var
  p: PChar;
const
  C_LongBits = 32;
  C_OneEight = 4;
  C_ThreeFourths = 24;
  C_HighBits = $F0000000;
var
  temp: Cardinal;
begin
  {TODO I should really be processing 4 bytes at once... }
  Result := 0;
  p := @AValue;

  while ASize > 0 do
  begin
    Result := (Result shl C_OneEight) + Ord(p^);
    temp := Result and C_HighBits;
    if temp <> 0 then
      Result := (Result xor (temp shr C_ThreeFourths)) and (not C_HighBits);
    Dec(ASize);
    Inc(p);
  end;
end;

{
  ======================================================================
  TStringHashMap
  ======================================================================
}
constructor TStringHashMap.Create(ATraits: TStringHashMapTraits; AHashSize: Cardinal);
begin
  Assert(ATraits <> nil, 'HashList must have traits');
  SetHashSize(AHashSize);
  FTraits := ATraits;
end;

destructor TStringHashMap.Destroy;
begin
  Clear;
  SetHashSize(0);
  inherited Destroy;
end;

{
  protected methods
}
type
  PPCollectNodeNode = ^PCollectNodeNode;
  PCollectNodeNode = ^TCollectNodeNode;
  TCollectNodeNode = record
    next: PCollectNodeNode;
    str: string;
    ptr: Pointer;
  end;

procedure NodeIterate_CollectNodes(AUserData: Pointer; ANode: PPHashNode);
var
  ppcnn: PPCollectNodeNode;
  pcnn: PCollectNodeNode;
begin
  ppcnn := PPCollectNodeNode(AUserData);
  New(pcnn);
  pcnn^.next := ppcnn^;
  ppcnn^ := pcnn;

  pcnn^.str := ANode^^.Str;
  pcnn^.ptr := ANode^^.Ptr;
end;

procedure TStringHashMap.SetHashSize(AHashSize: Cardinal);
var
  collect_list: PCollectNodeNode;

  procedure CollectNodes;
  var
    i: Integer;
  begin
    collect_list := nil;
    for i := 0 to FHashSize - 1 do
      NodeIterate(@FList^[i], @collect_list, NodeIterate_CollectNodes);
  end;

  procedure InsertNodes;
  var
    pcnn, tmp: PCollectNodeNode;
  begin
    pcnn := collect_list;
    while pcnn <> nil do
    begin
      tmp := pcnn^.next;
      Add(pcnn^.str, pcnn^.ptr);
      Dispose(pcnn);
      pcnn := tmp;
    end;
  end;
begin
  { 4 cases:
    we are empty, and AHashSize = 0 --> nothing to do
    we are full, and AHashSize = 0 --> straight empty
    we are empty, and AHashSize > 0 --> straight allocation
    we are full, and AHashSize > 0 --> rehash }

  if FHashSize = 0 then
    if AHashSize > 0 then
    begin
      GetMem(FList, AHashSize * SizeOf(FList^[0]));
      FillChar(FList^, AHashSize * SizeOf(FList^[0]), 0);
      FHashSize := AHashSize;
    end
    else
      { nothing to do }
  else
  begin
    if AHashSize > 0 then
    begin
      { must rehash table }
      CollectNodes;
      Clear;
      ReallocMem(FList, AHashSize * SizeOf(FList^[0]));
      FillChar(FList^, AHashSize * SizeOf(FList^[0]), 0);
      FHashSize := AHashSize;
      InsertNodes;
    end
    else
    begin
      { we are clearing the table - need hash to be empty }
      if FCount > 0 then
        raise EhwStringHashMapError.CreateResRec(@RsStringHashMapMustBeEmpty);
      FreeMem(FList);
      FList := nil;
      FHashSize := 0;
    end;
  end;
end;

function TStringHashMap.FindNode(const s: string): PPHashNode;
var
  i: Cardinal;
  r: Integer;
  ppn: PPHashNode;
begin
  { we start at the node offset by s in the hash list }
  i := FTraits.Hash(s) mod FHashSize;

  ppn := @FList^[i];

  if ppn^ <> nil then
    while True do
    begin
      r := FTraits.Compare(s, ppn^^.Str);

      { left, then right, then match }
      if r < 0 then
        ppn := @ppn^^.Left
      else if r > 0 then
        ppn := @ppn^^.Right
      else
        Break;

      { check for empty position after drilling left or right }
      if ppn^ = nil then
        Break;
    end;

  Result := ppn;
end;

function TStringHashMap.IterateNode(ANode: PHashNode; AUserData: Pointer;
  AIterateFunc: TIterateFunc): Boolean;
begin
  if ANode <> nil then
  begin
    Result := AIterateFunc(AUserData, ANode^.Str, ANode^.Ptr);
    if not Result then
      Exit;

    Result := IterateNode(ANode^.Left, AUserData, AIterateFunc);
    if not Result then
      Exit;

    Result := IterateNode(ANode^.Right, AUserData, AIterateFunc);
    if not Result then
      Exit;
  end else
    Result := True;
end;

function TStringHashMap.IterateMethodNode(ANode: PHashNode; AUserData: Pointer;
  AIterateMethod: TIterateMethod): Boolean;
begin
  if ANode <> nil then
  begin
    Result := AIterateMethod(AUserData, ANode^.Str, ANode^.Ptr);
    if not Result then
      Exit;

    Result := IterateMethodNode(ANode^.Left, AUserData, AIterateMethod);