(*----------------------------------------------------------------------------*)
(* TJPHashTable ... a class for hashtables.                                   *)
(* Author: Joachim Pimiskern, 9. Aug. 2002                                    *)
(* Freeware. Use and/or modify it at your own risk.                           *)
(* Version 1.1                                                                *)
(*                                                                            *)
(* Change: Clear stringlist in values() and keys(). Sept 20, 2004             *)
(* Change: AsIntegerS(), AsStringI() Feb 12 2005                              *)
(* Change: Removed bug in Delete(). Thanks to Holger Lembke. Mar 17 2005      *)
(*----------------------------------------------------------------------------*)
unit jphash;

interface
uses
   classes;

const
   cJPHashTableStartSize = 20;

type
   pJPHashTableEntry = ^TJPHashTableEntry;
   TJPHashTableEntry = packed record
     Key  : string;
     Value: string;
   end;

   pJPHashTableEntryArray = ^TJPHashTableEntryArray;
   TJPHashTableEntryArray = array[0..maxint div sizeof(TJPHashTableEntry) -1] of pJPHashTableEntry;

   TJPHashTable = class
     protected
       Anchor      : pJPHashTableEntryArray;
       FCurrentSize: integer;
       procedure   Init; virtual;
       function    h(key: string; size: integer): integer; virtual;
       function    FindPosition(key: string): integer;
       function    GetFreePlace(key: string): integer; virtual;
       procedure   AddRecord(p: pJPHashTableEntry);
       function    SuccMod(i: integer): integer;
       function    PredMod(i: integer): integer;
       procedure   CollectForward(lis: TList; pos: integer);
       procedure   CollectBackward(lis: TList; pos: integer);
     public
       constructor Create; virtual;
       constructor CreateWithSize(size: integer); virtual;
       destructor  Destroy; override;
       procedure   Add(key,value: string);
       function    Get(key: string): string;
       function    Find(key: string; var value: string): boolean;
       function    Exists(key: string): boolean;
       procedure   Delete(key: string);
       function    KeyCount: integer;
       procedure   Keys(sl: TStrings);
       procedure   Values(sl: TStrings);
       procedure   Clear;
   end;

function AsPointerS(s: string): pointer;
function AsStringP(p: pointer): string;
function AsStringI(i: integer): string;
function AsIntegerS(s: string): integer;

implementation
uses
   sysutils;

var
   instances: integer;

function AsPointerS(s: string): pointer;
begin
  move(s[1],result,sizeof(pointer));
end;

function AsStringP(p: pointer): string;
begin
  setLength(result,sizeof(pointer));
  move(p,result[1],sizeof(pointer));
end;

function AsStringI(i: integer): string;
begin
  setLength(result,sizeof(integer));
  move(i,result[1],sizeof(integer));
end;

function AsIntegerS(s: string): integer;
begin
  move(s[1],result,sizeof(integer));
end;


(*----------------------------------------------------------------------------*)
(* Konstruktor mit Default-Tabellengroesse                                    *)
(*----------------------------------------------------------------------------*)
constructor TJPHashTable.Create;
begin
  CreateWithSize(cJPHashTableStartSize);
end;


(*----------------------------------------------------------------------------*)
(* Alternativer Konstruktor mit waehlbarer Tabellengroesse.                   *)
(* Im allgemeinen arbeitet TJPHashTable schneller, wenn mehr Platz da ist.    *)
(* Anchor ist der Zeiger auf die interne Tabelle, FCurrentSize die Groesse.   *)
(*----------------------------------------------------------------------------*)
constructor TJPHashTable.CreateWithSize(size: integer);
begin
  inherited Create;
  FCurrentSize := size;
  GetMem(Anchor,FCurrentSize * sizeof(pJPHashTableEntry));
  Init;
  inc(instances);
end;


(*----------------------------------------------------------------------------*)
(* Destruktor: Zuerst alle Eintraege der internen Tabelle (dynamisch          *)
(* allozierte Records) freigeben, dann die interne Tabelle selber.            *)
(*----------------------------------------------------------------------------*)
destructor TJPHashTable.Destroy;
var i: integer;
begin
  dec(instances);
  for i := 0 to FCurrentSize - 1 do
      if (Anchor^[i] <> nil) then
         Dispose(Anchor^[i]);
  FreeMem(Anchor,FCurrentSize * sizeof(pJPHashTableEntry));
  inherited Destroy;
end;


(*----------------------------------------------------------------------------*)
(* Interne Tabelle initialisieren.                                            *)
(*----------------------------------------------------------------------------*)
procedure TJPHashTable.Init;
var i: integer;
begin
  for i := 0 to FCurrentSize - 1 do
      Anchor^[i] := nil;
end;


function TJPHashTable.SuccMod(i: integer): integer;
begin
  result := succ(i) mod FCurrentSize;
end;


function TJPHashTable.PredMod(i: integer): integer;
begin
  if (i = 0) then
     result := FCurrentSize - 1
  else
     result := pred(i);
end;


(*----------------------------------------------------------------------------*)
(* Das ist die eigentliche Hash-Funktion. Aus einem String wird eine Pseudo-  *)
(* Zufallszahl berechnet. Die Funktion ist virtual, man kann sie ableiten.    *)
(*----------------------------------------------------------------------------*)
function TJPHashTable.h(key: string; size: integer): integer;
var i,len,len1: integer;
begin
  result := 0;
  len    := length(key);
  len1   := len+1;
  for i := 1 to len do
      result := (result shl 8) xor ord(key[len1-i]);

  if (result < 0) then
     result := -result;

  result := result mod size;
end;


(*----------------------------------------------------------------------------*)
(* Liefert die Anzahl der Eintraege.                                          *)
(*----------------------------------------------------------------------------*)
function TJPHashTable.KeyCount: integer;
var i: integer;
begin
  result := 0;
  for i := 0 to FCurrentSize - 1 do
      if (Anchor^[i] <> nil) then
         inc(result);
end;


(*----------------------------------------------------------------------------*)
(* Eintrag vorhanden? Dann Wert ersetzen. Ansonsten einfuegen.                *)
(*----------------------------------------------------------------------------*)
procedure TJPHashTable.Add(key,value: string);
var pos: integer;
    p: pJPHashTableEntry;
begin
  pos := FindPosition(key);
  if (pos >= 0) then
     begin
       p := Anchor^[pos];
       p^.Value := value;
       exit;
     end;

  pos := GetFreePlace(key);
  new(p);
  p^.Key       := key;
  p^.Value     := value;
  Anchor^[pos] := p;
end;


(*----------------------------------------------------------------------------*)
(* Ein Record eintragen, das ein Schluessel/Wert-Paar enthaelt.               *)
(*----------------------------------------------------------------------------*)
procedure TJPHashTable.AddRecord(p: pJPHashTableEntry);
var pos: integer;
begin
  pos := GetFreePlace(p^.key);
  Anchor^[pos] := p;
end;


(*----------------------------------------------------------------------------*)
(* Alle Eintraege ab pos+1 sammeln und aus Hashtabelle austragen              *)
(*----------------------------------------------------------------------------*)
procedure TJPHashTable.CollectForward(lis: TList; pos: integer);
var i: integer;
begin
  i := SuccMod(pos);
  while ((Anchor^[i] <> nil) and
         (i <> pos)
        ) do
  begin
    lis.Add(Anchor^[i]);
    Anchor^[i] := nil;
    i := SuccMod(i);
  end;
end;


(*----------------------------------------------------------------------------*)
(* Alle Eintraege ab pos-1 zurueck sammeln und aus Hashtabelle austragen      *)
(*----------------------------------------------------------------------------*)
procedure TJPHashTable.CollectBackward(lis: TList; pos: integer);
var i: integer;
begin
  i := PredMod(pos);
  while ((Anchor^[i] <> nil) and
         (i <> pos)
        ) do
  begin
    lis.Add(Anchor^[i]);
    Anchor^[i] := nil;
    i := PredMod(i);
  end;
end;


(*----------------------------------------------------------------------------*)
(* Fuer einen Schluessel einen freien Platz (fuer einen Eintrag) suchen.      *)
(* Es wird auf jeden Fall ein Platz gefunden; ggf. wird die Groesse der       *)
(* Tabelle vergroessert; in diesem Falle verdoppelt.                          *)
(*----------------------------------------------------------------------------*)
function TJPHashTable.GetFreePlace(key: string): integer;
var pos,i,StartPosition: integer;
    OldCurrentSize: integer;
    OldAnchor     : pJPHashTableEntryArray;
    p: pJPHashTableEntry;
begin
  (*--- Tabellenplatz aus key berechnen, Pseudozufallszahl ---*)
  pos := h(key,FCurrentSize);

  (*--- Falls Platz leer, ist die Aufgabe schon erledigt ---*)
  if (Anchor^[pos] = nil) then
     begin
       result := pos;
       exit;
     end;

  (*--- Ab der aktuellen Position 'einmal im Kreis' leeren Platz suchen ---*)
  StartPosition := pos;
  pos := SuccMod(pos);
  while (
         (Anchor^[pos] <> nil) and
         (pos <> StartPosition)
        ) do
        pos := SuccMod(pos);


  (*--- Falls leerer Platz das Abbruchkriterium fuer Schleife war, fertig ---*)
  if (Anchor^[pos] = nil) then
     begin
       result := pos;
       exit;
     end
  else
     (*--- Kein freier Platz mehr in der Tabelle. -> Tabelle vergroessern ---*)
     begin
       (*--- Zeiger auf alte Tabelle merken und deren Groesse ---*)
       OldAnchor      := Anchor;
       OldCurrentSize := FCurrentSize;

       (*--- Neue Tabelle mit doppelter Groesse anlegen und initialisieren ---*)
       FCurrentSize   := FCurrentSize * 2;
       GetMem(Anchor,FCurrentSize * sizeof(pJPHashTableEntry));
       Init;

       (*--- Alle alten Records in neuer, groesserer Tabelle eintragen ---*)
       for i := 0 to OldCurrentSize - 1 do
           begin
             p := OldAnchor^[i];
             if (p <> nil) then
                AddRecord(p);
           end;

       (*--- Speicher von alter Tabelle freigeben ---*)
       FreeMem(OldAnchor,OldCurrentSize * sizeof(pJPHashTableEntry));

       (*--- Rekursion: Urspruenglichen Auftrag ausfuehren ---*)
       result := GetFreePlace(Key);
     end;
end;


(*----------------------------------------------------------------------------*)
(* Die Position eines Schluesselwerts innerhalb der Tabelle suchen. Falls der *)
(* Wert in der Tabelle vorhanden ist, wird der Index geliefert, sonst -1.     *)
(*----------------------------------------------------------------------------*)
function TJPHashTable.FindPosition(key: string): integer;
var pos, StartPosition: integer;
    p: pJPHashTableEntry;
begin
  (*--- Einen Tabellenplatz berechnen (Pseudozufallszahl) ---*)
  pos := h(key,FCurrentSize);

  (*--- Schluessel schon gefunden? ---*)
  p := Anchor^[pos];
  if (
      (p <> nil) and
      (p^.Key = key)
     ) then
     begin
       result := pos;
       exit;
     end;

  (*--- Schleife durch alle Tabellenplaetze, die ab hier belegt sind ---*)
  StartPosition := pos;
  pos := SuccMod(pos);
  while ((Anchor^[pos] <> nil) and
         (pos <> StartPosition)
        ) do
  begin
    p := Anchor^[pos];
    if (p^.Key = key) then
       begin
         result := pos;
         exit;
       end;
    pos := SuccMod(pos);
  end;

  result := -1;
end;


(*----------------------------------------------------------------------------*)
(* Liefert den Eintrag fuer einen Schluessel. Wenn der Wert nicht gefunden    *)
(* wird, wird eine Exception ausgeloest.                                      *)
(*----------------------------------------------------------------------------*)
function TJPHashTable.Get(key: string): string;
begin
  if (not Find(key,result)) then
     raise Exception.Create('Key not found');
end;


(*----------------------------------------------------------------------------*)
(* Zu einem Schluessel den Wert suchen und in value ablegen. Wenn der Wert    *)
(* nicht gefunden wird, wird value nicht geaendert. Als Ergebnis wird an-     *)
(* gezeigt, ob die Suche Erfolgreich war.                                     *)
(*----------------------------------------------------------------------------*)
function TJPHashTable.Find(key: string; var value: string): boolean;
var pos: integer;
    p: pJPHashTableEntry;
begin
  pos := FindPosition(key);
  if (pos >= 0) then
     begin
       p := Anchor^[pos];
       value  := p^.Value;
       result := true;
     end
  else
     result := false;
end;


(*----------------------------------------------------------------------------*)
(* Testen, ob fuer einen Schluessel ein Eintrag existiert.                    *)
(*----------------------------------------------------------------------------*)
function TJPHashTable.Exists(key: string): boolean;
var pos: integer;
begin
  pos := FindPosition(key);
  if (pos >= 0) then
     result := true
  else
     result := false;
end;


(*----------------------------------------------------------------------------*)
(* Einen Eintrag loeschen. Wenn fuer den Schluessel kein Wert vorhanden ist,  *)
(* wird nichts gemacht.                                                       *)
(*----------------------------------------------------------------------------*)
procedure TJPHashTable.Delete(key: string);
var pos: integer;
    p  : pJPHashTableEntry;
    lis: TList;
    i  : integer;
begin
  lis := TList.Create;
  try
    pos := FindPosition(key);
    if (pos >= 0) then
       begin
         // Cluster belegter Eintraege sammeln
         CollectForward(lis,pos);
         CollectBackward(lis,pos);

         // Den eigentlichen Eintrag entfernen
         p := Anchor^[pos];
         Anchor^[pos] := nil;
         Dispose(p);

         // Nun die Eintraege der Liste neu hinzufuegen
         for i := 0 to lis.Count - 1 do
             AddRecord(lis[i]);
       end;
  finally
    lis.Free;
  end;
end;





(*----------------------------------------------------------------------------*)
(* Liefert alle Schluessel der Hashtabelle in einer Stringliste. Die          *)
(* Reihenfolge ist zufaellig.                                                 *)
(*----------------------------------------------------------------------------*)
procedure TJPHashTable.Keys(sl: TStrings);
var i: integer;
    p: pJPHashTableEntry;
begin
  sl.Clear;
  for i := 0 to FCurrentSize - 1 do
      begin
        p := Anchor^[i];
        if (p <> nil) then
           sl.Add(p^.Key);
      end;
end;


(*----------------------------------------------------------------------------*)
(* Liefert alle Eintraege der Hashtabelle in einer Stringliste. Die           *)
(* Reihenfolge ist zufaellig.                                                 *)
(*----------------------------------------------------------------------------*)
procedure TJPHashTable.Values(sl: TStrings);
var i: integer;
    p: pJPHashTableEntry;
begin
  sl.Clear;
  for i := 0 to FCurrentSize - 1 do
      begin
        p := Anchor^[i];
        if (p <> nil) then
           sl.Add(p^.Value);
      end;
end;


(*----------------------------------------------------------------------------*)
(* Eine Hashtabelle leeren. Die leere Tabelle behaelt ihre Groesse.           *)
(*----------------------------------------------------------------------------*)
procedure TJPHashTable.Clear;
var i: integer;
    p: pJPHashTableEntry;
begin
  for i := 0 to FCurrentSize - 1 do
      begin
        p := Anchor^[i];
        if (p <> nil) then
           begin
             Dispose(p);
             Anchor^[i] := nil;
           end;
      end;
end;


initialization
   instances := 0;
finalization
   assert(instances = 0,'TJPHashTable instances not balanced');
end.