{$define debug}
unit HashTrie;

{
  Delphi implementation of HashTrie dynamic hashing method
  Full description available on www.softlab.od.ua

  Delphi 2,3,4,5
  Freware with source. 

  Copyright (c) 2000-2001, SoftLab MIL-TEC Ltd
  Web:   http://www.softcomplete.com
  Email: support@softcomplete.com

  THIS SOFTWARE AND THE ACCOMPANYING FILES ARE DISTRIBUTED 
  "AS IS" AND WITHOUT WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR 
  ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED.
  NO WARRANTY OF FITNESS FOR A PARTICULAR PURPOSE IS OFFERED.
  THE USER MUST ASSUME THE ENTIRE RISK OF USING THE ACCOMPANYING CODE.

  Permission is granted to anyone to use this software for any purpose,
  including commercial applications, and to alter it and redistribute it
  freely, subject to the following restrictions: 

  1. The origin of this software must not be misrepresented, you must 
     not claim that you wrote the original software. If you use this software 
     in a product, an acknowledgment in the product documentation 
     would be appreciated but is not required. 
  2. Altered source versions must be plainly marked as such, and must not be 
     misrepresented as being the original software.
  3. Original copyright may not be removed or altered from any source 
     distribution.
  4. All copyright of HashTrie dynamic hashing method belongs to Andre N Belokon, 
     SoftLab MIL-TEC Ltd.
}


interface

uses Windows, SysUtils;

const
  // DON'T CHANGE LeafSize VALUE !!! MUST BE EQ 256
  // because some code optimization used
  LeafSize = 256;
  // determines max length of the list
  // very big|small values decrease performance
  // optimum value in range 4..16
  BucketSize = 8;

type
  TLinkedItem = class
  private
    Value: DWORD;
    Data: DWORD;
    Next: TLinkedItem;
    constructor Create(FValue,FData: DWORD; FNext: TLinkedItem);
    destructor Destroy; override;
  end;

  THashTrie = class; // forward
  TTraverseProc = procedure (UserData,UserProc: Pointer;
    Value,Data: DWORD; var Done: Boolean) of object;

  TTreeItem = class
  private
    Owner: THashTrie;
    Level: integer;
    Filled: integer;
    Items: array[0..LeafSize-1] of TObject;
    constructor Create(AOwner: THashTrie);
    destructor Destroy; override;
    function ROR(Value: DWORD): DWORD;
    function RORN(Value: DWORD; Level: integer): DWORD;
    procedure AddDown(Value,Data,Hash: DWORD);
    procedure Delete(Value,Hash: DWORD);
    function Find(Value,Hash: DWORD; var Data: DWORD): Boolean;
    function Traverse(UserData,UserProc: Pointer; TraverseProc: TTraverseProc): Boolean;
  end;

  THashTrie = class
  private
    Root: TTreeItem;
  protected
    function HashValue(Value: DWORD): DWORD; virtual; abstract;
    procedure DestroyItem(var Value,Data: DWORD); virtual; abstract;
    function CompareValue(Value1,Value2: DWORD): Boolean; virtual; abstract;
    procedure AddDown(Value,Data,Hash: DWORD);
    procedure Delete(Value,Hash: DWORD);
    function Find(Value,Hash: DWORD; var Data: DWORD): Boolean;
    procedure Traverse(UserData,UserProc: Pointer; TraverseProc: TTraverseProc);
  public
    constructor Create; virtual;
    destructor Destroy; override;
  end;

  TStrHashTraverseProc = procedure (UserData: Pointer; const Value: string;
    Data: TObject; var Done: Boolean);
  TStrHashTraverseMeth = procedure (UserData: Pointer; const Value: string;
    Data: TObject; var Done: Boolean) of object;

  TStringHashTrie = class(THashTrie)
  private
    FCaseSensitive: Boolean;
    FAutoFreeObjects: Boolean;
  protected
    function HashValue(Value: DWORD): DWORD; override;
    procedure DestroyItem(var Value,Data: DWORD); override;
    function CompareValue(Value1,Value2: DWORD): Boolean; override;
    function HashStr(const S: string): DWORD;
    procedure TraverseProc(UserData,UserProc: Pointer;
      Value,Data: DWORD; var Done: Boolean);
    procedure TraverseMeth(UserData,UserProc: Pointer;
      Value,Data: DWORD; var Done: Boolean);
  public
    constructor Create; override;
    procedure Add(const S: string; Data: TObject);
    procedure Delete(const S: string);
    function Find(const S: string; var Data: TObject): Boolean;
    procedure Traverse(UserData: Pointer; UserProc: TStrHashTraverseProc); overload;
    procedure Traverse(UserData: Pointer; UserProc: TStrHashTraverseMeth); overload;
    property CaseSensitive: Boolean read FCaseSensitive write FCaseSensitive default False;
    property AutoFreeObjects: Boolean read FAutoFreeObjects write FAutoFreeObjects default False;
  end;

function CalcStrCRC32(const S: string): DWORD;
  
{$ifdef debug}
type
  TLenStat = array[1..BucketSize] of integer;

procedure Stat(ht: THashTrie; var MaxLevel, PeakCnt, FillCnt, EmptyCnt: integer;
  var LenStat: TLenStat);
{$endif}

implementation

{$ifdef debug}
procedure Stat(ht: THashTrie; var MaxLevel, PeakCnt, FillCnt, EmptyCnt: integer;
  var LenStat: TLenStat);

  procedure TreeStat(ht: TTreeItem);
  var j,i: integer;
      LinkedItem: TLinkedItem;
  begin
    Inc(PeakCnt);
    if ht.Level+1 > MaxLevel then
      MaxLevel:=ht.Level+1;
    for j:=0 to LeafSize-1 do
      if ht.Items[j] <> nil then begin
        Inc(FillCnt);
        if ht.Items[j] is TTreeItem then begin
          TreeStat(TTreeItem(ht.Items[j]));
        end else begin
          i:=0;
          LinkedItem:=TLinkedItem(ht.Items[j]);
          while LinkedItem <> nil do begin
            Inc(i);
            LinkedItem:=LinkedItem.Next;
          end;
          LenStat[i]:=LenStat[i]+1;
        end;
      end else
        Inc(EmptyCnt);
  end;
begin
  if ht.Root <> nil then
    TreeStat(ht.Root);
end;
{$endif}

{ TTreeItem }

procedure TTreeItem.AddDown(Value, Data, Hash: DWORD);
var i,j: integer;
    TreeItem: TTreeItem;
    LinkedItem: TLinkedItem;
begin
  i:=Hash and $FF;
  if Items[i] = nil then begin
    Items[i]:=TLinkedItem.Create(Value,Data,nil);
    Inc(Filled);
  end else if Items[i] is TTreeItem then begin
    TTreeItem(Items[i]).AddDown(Value,Data,ROR(Hash));
  end else begin
    j:=0;
    LinkedItem:=TLinkedItem(Items[i]);
    while LinkedItem <> nil do begin
      if Owner.CompareValue(LinkedItem.Value,Value) then begin
        // found
        LinkedItem.Data:=Data;
        Exit;
      end;
      LinkedItem:=LinkedItem.Next;
      Inc(j)
    end;
    if j >= BucketSize then begin
      // full
      TreeItem:=TTreeItem.Create(Owner);
      TreeItem.Level:=Level+1;
      LinkedItem:=TLinkedItem(Items[i]);
      while LinkedItem <> nil do begin
        TreeItem.AddDown(LinkedItem.Value, LinkedItem.Data,
                         RORN(Owner.HashValue(LinkedItem.Value), Level+1));
        LinkedItem:=LinkedItem.Next;
      end;
      TreeItem.AddDown(Value,Data,ROR(Hash));
      TLinkedItem(Items[i]).Free;
      Items[i]:=TreeItem;
    end else
      Items[i]:=TLinkedItem.Create(Value,Data,TLinkedItem(Items[i]));
  end;
end;

constructor TTreeItem.Create(AOwner: THashTrie);
var j: integer;
begin
  Owner:=AOwner;
  Level:=0;
  Filled:=0;
  for j:=0 to LeafSize-1 do Items[j]:=nil;
end;

procedure TTreeItem.Delete(Value, Hash: DWORD);
var i: integer;
    TreeItem: TTreeItem;
    PrevLinkedItem,LinkedItem: TLinkedItem;
begin
  i:=Hash and $FF;
  if Items[i] = nil then begin
    Exit;
  end else if Items[i] is TTreeItem then begin
    TTreeItem(Items[i]).Delete(Value,ROR(Hash));
    if TTreeItem(Items[i]).Filled = 0 then begin
      TTreeItem(Items[i]).Free;
      Items[i]:=nil;
    end;
  end else begin
    PrevLinkedItem:=nil;
    LinkedItem:=TLinkedItem(Items[i]);
    while LinkedItem <> nil do begin
      if Owner.CompareValue(LinkedItem.Value,Value) then begin
        // found
        if PrevLinkedItem = nil then begin
          Items[i]:=LinkedItem.Next;
          if Items[i] = nil then
            Dec(Filled);
        end else
          PrevLinkedItem.Next:=LinkedItem.Next;
        LinkedItem.Next:=nil;
        Owner.DestroyItem(LinkedItem.Value,LinkedItem.Data);
        LinkedItem.Free;
        Exit;
      end;
      PrevLinkedItem:=LinkedItem;
      LinkedItem:=LinkedItem.Next;
    end;
  end;
end;

destructor TTreeItem.Destroy;
var j: integer;
    LinkedItem: TLinkedItem;
begin
  for j:=0 to LeafSize-1 do
    if Items[j] <> nil then
      if Items[j] is TTreeItem then
        TTreeItem(Items[j]).Free
      else begin
        LinkedItem:=TLinkedItem(Items[j]);
        while LinkedItem <> nil do begin
          Owner.DestroyItem(LinkedItem.Value,LinkedItem.Data);
          LinkedItem:=LinkedItem.Next;
        end;
        TLinkedItem(Items[j]).Free;
      end;
  inherited;
end;

function TTreeItem.Find(Value, Hash: DWORD; var Data: DWORD): Boolean;
var i: integer;
    TreeItem: TTreeItem;
    LinkedItem: TLinkedItem;
begin
  Result:=False;
  i:=Hash and $FF;
  if Items[i] = nil then begin
    Exit;
  end else if Items[i] is TTreeItem then begin
    Result:=TTreeItem(Items[i]).Find(Value,ROR(Hash),Data);
  end else begin
    LinkedItem:=TLinkedItem(Items[i]);
    while LinkedItem <> nil do begin
      if Owner.CompareValue(LinkedItem.Value,Value) then begin
        // found
        Data:=LinkedItem.Data;
        Result:=True;