{ -----------------------------------------------------------------------
Tcl Scripting Language Components (Tslc)
Copyright (C) 1996-2002 William Byrne

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

WilliamB@ByrneLitho.com
------------------------------------------------------------------------}
unit TslcHash;

///////////////////////////////////////////////////////////////////////////////
//
//  TclDbTbl.pas
//	Copyright(c) 1996-1997 William Byrne
//		WilliamB@ByrneLitho.com
//		76262.13@CompuServe.com
//
//	All rights reserved.
//  	William Byrne makes no representations about the suitability of this
//    	software for any purpose.  It is provided "as is" without express or
//    	implied warranty.
//
//	Usage
//      I hereby grant to the legal purchasors of the source code contained
//      herein a non-exclusive license for the use of said source code in
//      developing compiled, executable software, and for the distribution of
//      said source code as part of said developed, compiled, executable software.
//
//  Purpose:
//		This file provides for Bde Table Manipulation using the
//		Tcl Scripting Language Components.
//
//	Editor:
//		Tab stops = 4
//		Page width = 132 characters
//		Font = Courier New, 8pt
//
//  Misc:
//      ??? = Note to self


interface
uses SysUtils;

type
	THashRecord = record
    	pHash: ^Integer;
        pValue: pChar;
    end;

    pHashArray = ^THashArray;
    THashArray = array[0..1027] of THashRecord;



function Hash(p: pChar): integer;
function HashCount(HashArray: pHashArray): integer;
function HashIndex(HashArray: pHashArray; index: integer): integer;
function HashValueIndex(HashArray: pHashArray; index: integer): pChar;
function IndexOfHash(HashArray: pHashArray; hash: integer): integer;
procedure InitializeHashValues(var HashArray: pHashArray; const values: pHashArray; list: boolean);
procedure CheckHashCollisions(HashArray: pHashArray); // Checks for collision within an HashArray
procedure CheckHashCollisions2(HashArray1, HashArray2: pHashArray); // Checks for collisions between two HashArrays
procedure CheckHashCollisionsList; // Checks modVar HashList (HashArrays passed to InitializeHashValues.) Calls CheckHashCollisions2
procedure CheckHashCollisionsAll; // Comprehensive Check on all HashArrays in HashList

implementation


function PJWStrHash(p: pChar): integer; cdecl; far; external;
{$L strhash.obj}

function Hash(p: pChar): integer;
begin
	result := PJWStrHash(p);
end;

function HashCount(HashArray: pHashArray): integer;
begin
	dec(pChar(HashArray), sizeof(THashRecord));
    result := HashArray^[0].pHash^;
end;

function IndexOfHash(HashArray: pHashArray; hash: integer): integer;
var
	x: integer;
begin
	for x:= 0 to HashCount(HashArray) -1 do
		if HashArray^[x].pHash^ = hash then
        begin
        	result := x;
            exit;
        end;
    result := -1;
end;

function HashValueIndex(HashArray: pHashArray; index: integer): pChar;
begin
	if (index < 0) or (index >= HashCount(HashArray)) then
		ERangeError.Create('Hash value index out of range');
	result := HashArray^[index].pValue;
end;

function HashIndex(HashArray: pHashArray; index: integer): integer;
begin
	if (index < 0) or (index >= HashCount(HashArray)) then
		ERangeError.Create('Hash index out of range');
	result := HashArray^[index].pHash^;
end;

{$DEFINE HASH_REDUNDANCY_OK}
procedure CheckHashCollisions(HashArray: pHashArray);
var
	x, y, c: integer;
begin
	c := HashCount(HashArray);
	for x := 0 to c - 2 do
		for y := x + 1 to c - 1 do
        	if (HashArray^[y].pHash^ = HashArray^[x].pHash^) then
{$IFDEF HASH_REDUNDANCY_OK} // spelling error would ?benefit? from this. hashSKI = 'SKI'  hashSKIP = 'SKI'
//            	if (StrComp(HashArray1^[x].pValue, HashArray2^[y].pValue) <> 0) then
{$ENDIF}
            	raise Exception.CreateFmt('Hash Collision: HashArray^[%d] (%s) : HashArray^[%d] (%s)',
                	[x, HashArray^[x].pValue, y, HashArray^[y].pValue]);
end;

procedure CheckHashCollisions2(HashArray1, HashArray2: pHashArray);
var
	x, y: integer;
begin
	for x:= 0 to HashCount(HashArray1) - 1 do
    	for y:= 0 to HashCount(HashArray2) - 1 do
        	if (HashArray1^[x].pHash^ = HashArray2^[y].pHash^) then
{$IFDEF HASH_REDUNDANCY_OK}
            	if (StrComp(HashArray1^[x].pValue, HashArray2^[y].pValue) <> 0) then // can set breakpoint this way
{$ENDIF}
            	raise Exception.CreateFmt('Hash Collision: HashArray1^[%d] (%s) : HashArray2^[%d] (%s)',
                	[x, HashArray1^[x].pValue, y, HashArray2^[y].pValue]);
end;



const
	MAX_HASH_LIST = 16;
    HashListPos: integer = -1;
var
	HashList: array[0..MAX_HASH_LIST - 1] of pHashArray;

procedure InitializeHashValues(var HashArray: pHashArray; const values: pHashArray; list: boolean);
var
	x: integer;
begin
    HashArray := @values^[1];

	for x:= 0 to HashCount(HashArray) - 1 do
    with HashArray^[x] do
		pHash^ := Hash(pValue);

    if list then
    begin
		inc(HashListPos);
    	if HashListPos >= MAX_HASH_LIST then
        	raise Exception.CreateFmt('Hash List Overflow(%d/%d) - increase size of buffer',[HashListPos, MAX_HASH_LIST]);
		HashList[HashListPos] := HashArray;
    end;
end;

procedure CheckHashCollisionsList;
var
	x, y: integer;
begin
	for x:= 0 to HashListPos - 1 do
		for y := x + 1 to hashListPos do
	    	CheckHashCollisions2(HashList[x], HashList[y]);
end;

procedure CheckHashCollisionsAll;
var
	x: integer;
begin
	for x:= 0 to HashListPos do
    	CheckHashCollisions(HashList[x]);
    CheckHashCollisionsList;
end;

end.
