jclstrhashmap.pas

East make Tray Icon in delphi

{**************************************************************************************************}
{                                                                                                  }
{ Project JEDI Code Library (JCL)                                                                  }
{                                                                                                  }
{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); }
{ you may not use this file except in compliance with the License. You may obtain a copy of the    }
{ License at http://www.mozilla.org/MPL/                                                           }
{                                                                                                  }
{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF   }
{ ANY KIND, either express or implied. See the License for the specific language governing rights  }
{ and limitations under the License.                                                               }
{                                                                                                  }
{ The Original Code is JclStrHashMap.pas.                                                          }
{                                                                                                  }
{ The Initial Developer of the Original Code is Barry Kelly.                                       }
{ Portions created by Barry Kelly are Copyright (C) Barry Kelly. All rights reserved.              }
{                                                                                                  }
{ Contributors:                                                                                    }
{   Barry Kelly, Robert Rossmair, Matthias Thoma, Petr Vones                                       }
{                                                                                                  }
{**************************************************************************************************}
{                                                                                                  }
{ This unit contains a string-pointer associative map. It works by hashing the added strings using }
{ a passed-in traits object.                                                                       }
{                                                                                                  }
{**************************************************************************************************}

// Last modified: $Date: 2005/03/08 08:33:17 $
// For history see end of file

unit JclStrHashMap;

{$I jcl.inc}

interface

uses
  SysUtils,
  JclBase, JclResources;

type
  EJclStringHashMapError = class(EJclError);
  THashValue = Cardinal;

type
  TStringHashMapTraits = class(TObject)
  public
    function Hash(const S: string): Cardinal; virtual; abstract;
    function Compare(const L, R: string): Integer; virtual; abstract;
  end;

function CaseSensitiveTraits: TStringHashMapTraits;
function CaseInsensitiveTraits: TStringHashMapTraits;

type
  TIterateFunc = function(AUserData: Pointer; const AStr: string; var APtr: Pointer): Boolean;

  TIterateMethod = function(AUserData: Pointer; const AStr: string; var APtr: Pointer): Boolean of object;

  PPHashNode = ^PHashNode;
  PHashNode = ^THashNode;
  THashNode = record
    Str: string;
    Ptr: Pointer;
    Left: PHashNode;
    Right: PHashNode;
  end;

  { Internal iterate function pointer type used by the protected
    TStringHashMap.NodeIterate method. }
  TNodeIterateFunc = procedure(AUserData: Pointer; ANode: PPHashNode);

  PHashArray = ^THashArray;
  THashArray = array [0..MaxInt div SizeOf(PHashNode) - 1] of PHashNode;

  TStringHashMap = class(TObject)
  private
    FHashSize: Cardinal;
    FCount: Cardinal;
    FList: PHashArray;
    FLeftDelete: Boolean;
    FTraits: TStringHashMapTraits;
    function IterateNode(ANode: PHashNode; AUserData: Pointer; AIterateFunc: TIterateFunc): Boolean;
    function IterateMethodNode(ANode: PHashNode; AUserData: Pointer; AIterateMethod: TIterateMethod): Boolean;
    procedure NodeIterate(ANode: PPHashNode; AUserData: Pointer; AIterateFunc: TNodeIterateFunc);
    procedure SetHashSize(AHashSize: Cardinal);
    procedure DeleteNodes(var Q: PHashNode);
    procedure DeleteNode(var Q: PHashNode);
  protected
    function FindNode(const S: string): PPHashNode;
    function AllocNode: PHashNode; virtual;
    procedure FreeNode(ANode: PHashNode); virtual;
    function GetData(const S: string): Pointer;
    procedure SetData(const S: string; P: Pointer);
  public
    constructor Create(ATraits: TStringHashMapTraits; AHashSize: Cardinal);
    destructor Destroy; override;
    procedure Add(const S: string; const P);
    function Remove(const S: string): Pointer;
    procedure RemoveData(const P);
    procedure Iterate(AUserData: Pointer; AIterateFunc: TIterateFunc);
    procedure IterateMethod(AUserData: Pointer; AIterateMethod: TIterateMethod);
    function Has(const S: string): Boolean;
    function Find(const S: string; var P): Boolean;
    function FindData(const P; var S: string): Boolean;
    procedure Clear;
    property Count: Cardinal read FCount;
    property Data[const S: string]: Pointer read GetData write SetData; default;
    property Traits: TStringHashMapTraits read FTraits;
    property HashSize: Cardinal read FHashSize write SetHashSize;
  end;

{ Str=case sensitive, text=case insensitive }

function StrHash(const S: string): THashValue;
function TextHash(const S: string): THashValue;
function DataHash(var AValue; ASize: Cardinal): THashValue;
function Iterate_FreeObjects(AUserData: Pointer; const AStr: string; var AData: Pointer): Boolean;
function Iterate_Dispose(AUserData: Pointer; const AStr: string; var AData: Pointer): Boolean;
function Iterate_FreeMem(AUserData: Pointer; const AStr: string; var AData: Pointer): Boolean;

type
  TCaseSensitiveTraits = class(TStringHashMapTraits)
  public
    function Hash(const S: string): Cardinal; override;
    function Compare(const L, R: string): Integer; override;
  end;

  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
  GlobalCaseSensitiveTraits: TCaseSensitiveTraits;

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

var
  GlobalCaseInsensitiveTraits: TCaseInsensitiveTraits;

function CaseInsensitiveTraits: TStringHashMapTraits;
begin
  if GlobalCaseInsensitiveTraits = nil then
    GlobalCaseInsensitiveTraits := TCaseInsensitiveTraits.Create;
  Result := GlobalCaseInsensitiveTraits;
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;
const
  cLongBits = 32;
  cOneEight = 4;
  cThreeFourths = 24;
  cHighBits = $F0000000;
var
  I: Integer;
  P: PChar;
  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 cOneEight) + Ord(P^);
    Temp := Result and cHighBits;
    if Temp <> 0 then
      Result := (Result xor (Temp shr cThreeFourths)) and (not cHighBits);
    Dec(I);
    Inc(P);
  end;
end;

function TextHash(const S: string): Cardinal;
const
  cLongBits = 32;
  cOneEight = 4;
  cThreeFourths = 24;
  cHighBits = $F0000000;
var
  I: Integer;
  P: PChar;
  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 cOneEight) + Ord(UpCase(P^));
    Temp := Result and cHighBits;
    if Temp <> 0 then
      Result := (Result xor (Temp shr cThreeFourths)) and (not cHighBits);
    Dec(I);
    Inc(P);
  end;
end;

function DataHash(var AValue; ASize: Cardinal): THashValue;
const
  cLongBits = 32;
  cOneEight = 4;
  cThreeFourths = 24;
  cHighBits = $F0000000;
var
  P: PChar;
  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 cOneEight) + Ord(P^);
    Temp := Result and cHighBits;
    if Temp <> 0 then
      Result := (Result xor (Temp shr cThreeFourths)) and (not cHighBits);
    Dec(ASize);
    Inc(P);
  end;
end;

//=== { TStringHashMap } =====================================================

constructor TStringHashMap.Create(ATraits: TStringHashMapTraits; AHashSize: Cardinal);
begin
  inherited Create;
  Assert(ATraits <> nil, LoadResString(@RsStringHashMapNoTraits));
  SetHashSize(AHashSize);
  FTraits := ATraits;
end;

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

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
  CollectList: PCollectNodeNode;

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

  procedure InsertNodes;
  var
    PCnn, Tmp: PCollectNodeNode;
  begin
    PCnn := CollectList;
    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
  begin
    if AHashSize > 0 then
    begin
      GetMem(FList, AHashSize * SizeOf(FList^[0]));
      FillChar(FList^, AHashSize * SizeOf(FList^[0]), 0);
      FHashSize := AHashSize;
    end;
  end
  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 EJclStringHashMapError.CreateRes(@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;