{ This file is part of the Free Component Library (FCL) Copyright (c) 2002 by Florian Klaempfl See the file COPYING.FPC, included in this distribution, for details about the copyright. This program 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. **********************************************************************} {$mode objfpc} unit contnrs; interface uses SysUtils, Classes; Type TObjectListCallback = Reference to Procedure(data:TObject;arg:JSValue); TFPObjectList = class(TObject) private FFreeObjects : Boolean; FList: TFPList; Function GetCount: integer; Procedure SetCount(const AValue: integer); protected Function GetItem(Index: Integer): TObject; Procedure SetItem(Index: Integer; AObject: TObject); Procedure SetCapacity(NewCapacity: Integer); Function GetCapacity: integer; public constructor Create; reintroduce; constructor Create(FreeObjects : Boolean); destructor Destroy; override; Procedure Clear; Function Add(AObject: TObject): Integer; Procedure Delete(Index: Integer); Procedure Exchange(Index1, Index2: Integer); Function Expand: TFPObjectList; Function Extract(Item: TObject): TObject; Function Remove(AObject: TObject): Integer; Function IndexOf(AObject: TObject): Integer; Function FindInstanceOf(AClass: TClass; AExact: Boolean; AStartAt: Integer): Integer; Procedure Insert(Index: Integer; AObject: TObject); Function First: TObject; Function Last: TObject; Procedure Move(CurIndex, NewIndex: Integer); Procedure Assign(Obj:TFPObjectList); Procedure Pack; Procedure Sort(Compare: TListSortCompare); Procedure ForEachCall(proc2call:TObjectListCallback;arg:JSValue); property Capacity: Integer read GetCapacity write SetCapacity; property Count: Integer read GetCount write SetCount; property OwnsObjects: Boolean read FFreeObjects write FFreeObjects; property Items[Index: Integer]: TObject read GetItem write SetItem; default; property List: TFPList read FList; end; { TObjectList } TObjectList = class(TList) private FFreeObjects : Boolean; Protected Procedure Notify(Ptr: JSValue; Action: TListNotification); override; Function GetItem(Index: Integer): TObject; Procedure SetItem(Index: Integer; AObject: TObject); public constructor Create; reintroduce; constructor Create(FreeObjects : boolean); Function Add(AObject: TObject): Integer; reintroduce; Function Extract(Item: TObject): TObject; reintroduce; Function Remove(AObject: TObject): Integer; reintroduce; Function IndexOf(AObject: TObject): Integer; reintroduce; Function FindInstanceOf(AClass: TClass; AExact: Boolean; AStartAt: Integer): Integer; Procedure Insert(Index: Integer; AObject: TObject); reintroduce; Function First: TObject; reintroduce; Function Last: TObject; reintroduce; property OwnsObjects: Boolean read FFreeObjects write FFreeObjects; property Items[Index: Integer]: TObject read GetItem write SetItem; default; end; TComponentList = class(TObjectList) Private FNotifier : TComponent; Protected Procedure Notify(Ptr: JSValue; Action: TListNotification); override; Function GetItems(Index: Integer): TComponent; Procedure SetItems(Index: Integer; AComponent: TComponent); Procedure HandleFreeNotify(Sender: TObject; AComponent: TComponent); public destructor Destroy; override; Function Add(AComponent: TComponent): Integer; reintroduce; Function Extract(Item: TComponent): TComponent; reintroduce; Function Remove(AComponent: TComponent): Integer; reintroduce; Function IndexOf(AComponent: TComponent): Integer; reintroduce; Function First: TComponent; reintroduce; Function Last: TComponent; reintroduce; Procedure Insert(Index: Integer; AComponent: TComponent); reintroduce; property Items[Index: Integer]: TComponent read GetItems write SetItems; default; end; TClassList = class(TList) protected Function GetItems(Index: Integer): TClass; Procedure SetItems(Index: Integer; AClass: TClass); public Function Add(AClass: TClass): Integer; reintroduce; Function Extract(Item: TClass): TClass; reintroduce; Function Remove(AClass: TClass): Integer; reintroduce; Function IndexOf(AClass: TClass): Integer; reintroduce; Function First: TClass; reintroduce; Function Last: TClass; reintroduce; Procedure Insert(Index: Integer; AClass: TClass); reintroduce; property Items[Index: Integer]: TClass read GetItems write SetItems; default; end; TOrderedList = class(TObject) private FList: TList; protected Procedure PushItem(AItem: JSValue); virtual; abstract; Function PopItem: JSValue; virtual; Function PeekItem: JSValue; virtual; property List: TList read FList; public constructor Create; reintroduce; destructor Destroy; override; Function Count: Integer; Function AtLeast(ACount: Integer): Boolean; Function Push(AItem: JSValue): JSValue; Function Pop: JSValue; Function Peek: JSValue; end; { TStack class } TStack = class(TOrderedList) protected Procedure PushItem(AItem: JSValue); override; end; { TObjectStack class } TObjectStack = class(TStack) public Function Push(AObject: TObject): TObject; reintroduce; Function Pop: TObject; reintroduce; Function Peek: TObject; reintroduce; end; { TQueue class } TQueue = class(TOrderedList) protected Procedure PushItem(AItem: JSValue); override; end; { TObjectQueue class } TObjectQueue = class(TQueue) public Function Push(AObject: TObject): TObject; reintroduce; Function Pop: TObject; reintroduce; Function Peek: TObject; reintroduce; end; { --------------------------------------------------------------------- Hash support, implemented by Dean Zobec ---------------------------------------------------------------------} { Must return a Longword value in the range 0..TableSize, usually via a mod operator; } THashFunction = Function(const S: string; const TableSize: Longword): Longword; { THTNode } THTCustomNode = class(TObject) private FKey: string; public constructor CreateWith(const AString: String); Function HasKey(const AKey: string): boolean; property Key: string read FKey; end; THTCustomNodeClass = Class of THTCustomNode; { TFPCustomHashTable } TFPCustomHashTable = class(TObject) private FHashTable: TFPObjectList; FHashFunction: THashFunction; FCount: Longword; Function GetDensity: Longword; Function GetNumberOfCollisions: Longword; Procedure SetHashTableSize(const Value: Longword); Procedure InitializeHashTable; Function GetVoidSlots: Longword; Function GetLoadFactor: double; Function GetAVGChainLen: double; Function GetMaxChainLength: Longword; protected FHashTableSize: Longword; Function Chain(const index: Longword):TFPObjectList; Function CreateNewNode(const aKey : string) : THTCustomNode; virtual; abstract; Procedure AddNode(ANode : THTCustomNode); virtual; abstract; Function ChainLength(const ChainIndex: Longword): Longword; virtual; Function FindOrCreateNew(const aKey: string): THTCustomNode; virtual; Procedure SetHashFunction(AHashFunction: THashFunction); virtual; Function FindChainForAdd(Const aKey : String) : TFPObjectList; public constructor Create; reintroduce; constructor CreateWith(AHashTableSize: Longword; aHashFunc: THashFunction); destructor Destroy; override; Procedure ChangeTableSize(const ANewSize: Longword); virtual; Procedure Clear; virtual; Procedure Delete(const aKey: string); virtual; Function Find(const aKey: string): THTCustomNode; Function IsEmpty: boolean; property HashFunction: THashFunction read FHashFunction write SetHashFunction; property Count: Longword read FCount; property HashTableSize: Longword read FHashTableSize write SetHashTableSize; property HashTable: TFPObjectList read FHashTable; property VoidSlots: Longword read GetVoidSlots; property LoadFactor: double read GetLoadFactor; property AVGChainLen: double read GetAVGChainLen; property MaxChainLength: Longword read GetMaxChainLength; property NumberOfCollisions: Longword read GetNumberOfCollisions; property Density: Longword read GetDensity; end; { TFPDataHashTable : Hash table with simple data JSValues } THTDataNode = Class(THTCustomNode) Private FData: JSValue; public property Data: JSValue read FData write FData; end; // For compatibility THTNode = THTDataNode; TDataIteratorMethod = Procedure(Item: JSValue; const Key: string; var Continue: Boolean) of object; TDataIteratorCallBack = Procedure(Item: JSValue; const Key: string; var Continue: Boolean); // For compatibility TIteratorMethod = TDataIteratorMethod; TFPDataHashTable = Class(TFPCustomHashTable) Private FIteratorCallBack: TDataIteratorCallBack; Procedure CallbackIterator(Item: JSValue; const Key: string; var Continue: Boolean); Protected Function CreateNewNode(const aKey : String) : THTCustomNode; override; Procedure AddNode(ANode : THTCustomNode); override; Procedure SetData(const index: string; const AValue: JSValue); virtual; Function GetData(const index: string):JSValue; virtual; Function ForEachCall(aMethod: TDataIteratorMethod): THTDataNode; virtual; Public Function Iterate(aMethod: TDataIteratorMethod): JSValue; virtual; Function Iterate(aMethod: TDataIteratorCallBack): JSValue; virtual; Procedure Add(const aKey: string; AItem: JSValue); virtual; property Items[const index: string]: JSValue read GetData write SetData; default; end; { TFPStringHashTable : Hash table with simple strings as data } THTStringNode = Class(THTCustomNode) Private FData : String; public property Data: String read FData write FData; end; TStringIteratorMethod = Procedure(Item: String; const Key: string; var Continue: Boolean) of object; TStringIteratorCallback = Procedure(Item: String; const Key: string; var Continue: Boolean); TFPStringHashTable = Class(TFPCustomHashTable) Private FIteratorCallBack: TStringIteratorCallback; Procedure CallbackIterator(Item: String; const Key: string; var Continue: Boolean); Protected Function CreateNewNode(const aKey : String) : THTCustomNode; override; Procedure AddNode(ANode : THTCustomNode); override; Procedure SetData(const Index, AValue: string); virtual; Function GetData(const index: string): String; virtual; Function ForEachCall(aMethod: TStringIteratorMethod): THTStringNode; virtual; Public Function Iterate(aMethod: TStringIteratorMethod): String; virtual; Function Iterate(aMethod: TStringIteratorCallback): String; virtual; Procedure Add(const aKey,aItem: string); virtual; property Items[const index: string]: String read GetData write SetData; default; end; { TFPStringHashTable : Hash table with simple strings as data } THTObjectNode = Class(THTCustomNode) Private FData : TObject; public property Data: TObject read FData write FData; end; THTOwnedObjectNode = Class(THTObjectNode) public destructor Destroy; override; end; TObjectIteratorMethod = Procedure(Item: TObject; const Key: string; var Continue: Boolean) of object; TObjectIteratorCallback = Procedure(Item: TObject; const Key: string; var Continue: Boolean); TFPObjectHashTable = Class(TFPCustomHashTable) Private FOwnsObjects : Boolean; FIteratorCallBack: TObjectIteratorCallback; procedure CallbackIterator(Item: TObject; const Key: string; var Continue: Boolean); Protected Function CreateNewNode(const aKey : String) : THTCustomNode; override; Procedure AddNode(ANode : THTCustomNode); override; Procedure SetData(const Index: string; AObject : TObject); virtual; Function GetData(const index: string): TObject; virtual; Function ForEachCall(aMethod: TObjectIteratorMethod): THTObjectNode; virtual; Public constructor Create(AOwnsObjects : Boolean = True); reintroduce; constructor CreateWith(AHashTableSize: Longword; aHashFunc: THashFunction; AOwnsObjects : Boolean = True); reintroduce; Function Iterate(aMethod: TObjectIteratorMethod): TObject; virtual; Function Iterate(aMethod: TObjectIteratorCallback): TObject; virtual; Procedure Add(const aKey: string; AItem : TObject); virtual; property Items[const index: string]: TObject read GetData write SetData; default; Property OwnsObjects : Boolean Read FOwnsObjects; end; EDuplicate = class(Exception); EKeyNotFound = class(Exception); Function RSHash(const S: string; const TableSize: Longword): Longword; { --------------------------------------------------------------------- Bucket lists as in Delphi ---------------------------------------------------------------------} Type TBucketItem = record Item, Data: JSValue; end; TBucketItemArray = array of TBucketItem; TBucket = record Count : Integer; Items : TBucketItemArray; end; TBucketArray = array of TBucket; TBucketProc = Reference to Procedure(AInfo, AItem, AData: JSValue; out AContinue: Boolean); { --------------------------------------------------------------------- TCustomBucketList ---------------------------------------------------------------------} { TCustomBucketList } TCustomBucketList = class(TObject) private FBuckets: TBucketArray; Function GetBucketCount: Integer; Function GetData(AItem: JSValue): JSValue; Procedure SetData(AItem: JSValue; const AData: JSValue); Procedure SetBucketCount(const Value: Integer); protected Procedure GetBucketItem(AItem: JSValue; out ABucket, AIndex: Integer); Function AddItem(ABucket: Integer; AItem, AData: JSValue): JSValue; virtual; Function BucketFor(AItem: JSValue): Integer; virtual; abstract; Function DeleteItem(ABucket: Integer; AIndex: Integer): JSValue; virtual; Procedure Error(Msg : String; Args : Array of Const); Function FindItem(AItem: JSValue; out ABucket, AIndex: Integer): Boolean; virtual; property Buckets: TBucketArray read FBuckets; property BucketCount: Integer read GetBucketCount write SetBucketCount; public destructor Destroy; override; Procedure Clear; Function Add(AItem, AData: JSValue): JSValue; Procedure Assign(AList: TCustomBucketList); Function Exists(AItem: JSValue): Boolean; Function Find(AItem: JSValue; out AData: JSValue): Boolean; Function ForEach(AProc: TBucketProc; AInfo: JSValue): Boolean; Function ForEach(AProc: TBucketProc): Boolean; Function Remove(AItem: JSValue): JSValue; property Data[AItem: JSValue]: JSValue read GetData write SetData; default; end; { --------------------------------------------------------------------- TBucketList ---------------------------------------------------------------------} TBucketListSizes = (bl2, bl4, bl8, bl16, bl32, bl64, bl128, bl256); { TBucketList } TBucketList = class(TCustomBucketList) private FBucketMask: Byte; protected Function BucketFor(AItem: JSValue): Integer; override; public constructor Create(ABuckets: TBucketListSizes = bl16); reintroduce; end; { --------------------------------------------------------------------- TObjectBucketList ---------------------------------------------------------------------} { TObjectBucketList } TObjectBucketList = class(TBucketList) protected Function GetData(AItem: TObject): TObject; reintroduce; Procedure SetData(AItem: TObject; const AData: TObject); reintroduce; public Function Add(AItem, AData: TObject): TObject; reintroduce; Function Remove(AItem: TObject): TObject; reintroduce; property Data[AItem: TObject]: TObject read GetData write SetData; default; end; implementation uses js; ResourceString DuplicateMsg = 'An item with key %0:s already exists'; //KeyNotFoundMsg = 'Method: %0:s key [''%1:s''] not found in container'; NotEmptyMsg = 'Hash table not empty.'; SErrNoSuchItem = 'No item in list for %p'; SDuplicateItem = 'Item already exists in list: %p'; const NPRIMES = 28; PRIMELIST: array[0 .. NPRIMES-1] of Longword = ( 53, 97, 193, 389, 769, 1543, 3079, 6151, 12289, 24593, 49157, 98317, 196613, 393241, 786433, 1572869, 3145739, 6291469, 12582917, 25165843, 50331653, 100663319, 201326611, 402653189, 805306457, 1610612741, 3221225473, 4294967291 ); constructor TFPObjectList.Create(FreeObjects : boolean); begin Create; FFreeObjects:=Freeobjects; end; destructor TFPObjectList.Destroy; begin if (FList <> nil) then begin Clear; FList.Destroy; end; inherited Destroy; end; Procedure TFPObjectList.Clear; var i: integer; O : TObject; begin if FFreeObjects then for i:=FList.Count-1 downto 0 do begin O:=TObject(FList[i]); FList[i]:=Nil; O.Free; end; FList.Clear; end; constructor TFPObjectList.Create; begin inherited Create; FList:=TFPList.Create; FFreeObjects:=True; end; Function TFPObjectList.GetCount: integer; begin Result:=FList.Count; end; Procedure TFPObjectList.SetCount(const AValue: integer); begin if FList.Count <> AValue then FList.Count:=AValue; end; Function TFPObjectList.GetItem(Index: Integer): TObject; begin Result:=TObject(FList[Index]); end; Procedure TFPObjectList.SetItem(Index: Integer; AObject: TObject); Var O : TObject; begin if OwnsObjects then begin O:=TObject(FList[Index]); FList[Index]:=AObject; O.Free; end else FList[index]:=AObject; end; Procedure TFPObjectList.SetCapacity(NewCapacity: Integer); begin FList.Capacity:=NewCapacity; end; Function TFPObjectList.GetCapacity: integer; begin Result:=FList.Capacity; end; Function TFPObjectList.Add(AObject: TObject): Integer; begin Result:=FList.Add(AObject); end; Procedure TFPObjectList.Delete(Index: Integer); Var O : TObject; begin if OwnsObjects then begin O:=TObject(FList[Index]); FList[Index]:=Nil; O.Free; end; FList.Delete(Index); end; Procedure TFPObjectList.Exchange(Index1, Index2: Integer); begin FList.Exchange(Index1, Index2); end; Function TFPObjectList.Expand: TFPObjectList; begin FList.Expand; Result:=Self; end; Function TFPObjectList.Extract(Item: TObject): TObject; begin Result:=TObject(FList.Extract(Item)); end; Function TFPObjectList.Remove(AObject: TObject): Integer; Var O : TObject; begin Result:=IndexOf(AObject); if (Result <> -1) then begin if OwnsObjects then begin O:=TObject(FList[Result]); FList[Result]:=Nil; O.Free; end; FList.Delete(Result); end; end; Function TFPObjectList.IndexOf(AObject: TObject): Integer; begin Result:=FList.IndexOf(JSValue(AObject)); end; Function TFPObjectList.FindInstanceOf(AClass: TClass; AExact: Boolean; AStartAt : Integer): Integer; var I : Integer; begin I:=AStartAt; Result:=-1; if AExact then while (I=Acount) end; Function TOrderedList.Count: Integer; begin Result:=FList.Count; end; constructor TOrderedList.Create; begin FList:=Tlist.Create; end; destructor TOrderedList.Destroy; begin FList.Free; end; Function TOrderedList.Peek: JSValue; begin if AtLeast(1) then Result:=PeekItem else Result:=nil; end; Function TOrderedList.PeekItem: JSValue; begin with Flist do Result:=Items[Count-1] end; Function TOrderedList.Pop: JSValue; begin If Atleast(1) then Result:=PopItem else Result:=nil; end; Function TOrderedList.PopItem: JSValue; begin with FList do if Count>0 then begin Result:=Items[Count-1]; Delete(Count-1); end else Result:=nil; end; Function TOrderedList.Push(AItem: JSValue): JSValue; begin PushItem(AItem); Result:=AItem; end; { TStack } Procedure TStack.PushItem(AItem: JSValue); begin FList.Add(AItem); end; { TObjectStack } Function TObjectStack.Peek: TObject; begin Result:=TObject(inherited Peek); end; Function TObjectStack.Pop: TObject; begin Result:=TObject(Inherited Pop); end; Function TObjectStack.Push(AObject: TObject): TObject; begin Result:=TObject(inherited Push(JSValue(AObject))); end; { TQueue } Procedure TQueue.PushItem(AItem: JSValue); begin with FList Do Insert(0,AItem); end; { TObjectQueue } Function TObjectQueue.Peek: TObject; begin Result:=TObject(inherited Peek); end; Function TObjectQueue.Pop: TObject; begin Result:=TObject(inherited Pop); end; Function TObjectQueue.Push(AObject: TObject): TObject; begin Result:=TObject(inherited Push(JSValue(AObject))); end; {***************************************************************************** TFPHashList *****************************************************************************} (* Function FPHash(const s:shortstring):LongWord; var p,pmax : PChar; begin {$push} {$Q-} Result:=0; p:=@s[1]; pmax:=@s[length(s)+1]; while (p0 then for i:=1 to Length(S) do begin Result:=Result * a + Ord(S[i]); a:=a * b; end; Result:=(Result and $7FFFFFFF) mod TableSize; end; { THTNode } constructor THTCustomNode.CreateWith(const AString: string); begin inherited Create; FKey:=AString; end; Function THTCustomNode.HasKey(const AKey: string): boolean; begin Result:=(AKey=FKey); end; { TFPCustomHashTable } constructor TFPCustomHashTable.Create; begin CreateWith(196613,@RSHash); end; constructor TFPCustomHashTable.CreateWith(AHashTableSize: Longword; aHashFunc: THashFunction); begin inherited Create; FHashTable:=TFPObjectList.Create(True); HashTableSize:=AHashTableSize; FHashFunction:=aHashFunc; end; destructor TFPCustomHashTable.Destroy; begin FHashTable.Free; inherited Destroy; end; Function TFPCustomHashTable.GetDensity: Longword; begin Result:=FHashTableSize - VoidSlots end; Function TFPCustomHashTable.GetNumberOfCollisions: Longword; begin Result:=FCount -(FHashTableSize - VoidSlots) end; Procedure TFPCustomHashTable.SetHashTableSize(const Value: Longword); var i: Longword; newSize: Longword; begin if Value <> FHashTableSize then begin i:=0; while (PRIMELIST[i] < Value) and (i < 27) do Inc(i); newSize:=PRIMELIST[i]; if Count = 0 then begin FHashTableSize:=newSize; InitializeHashTable; end else ChangeTableSize(newSize); end; end; Procedure TFPCustomHashTable.InitializeHashTable; var i: LongWord; begin if FHashTableSize>0 Then for i:=0 to FHashTableSize-1 do FHashTable.Add(nil); FCount:=0; end; Procedure TFPCustomHashTable.ChangeTableSize(const ANewSize: Longword); var SavedTable, List: TFPObjectList; SavedTableSize: Longword; i, j: Longword; temp: THTCustomNode; begin SavedTable:=FHashTable; SavedTableSize:=FHashTableSize; FHashTableSize:=ANewSize; FHashTable:=TFPObjectList.Create(True); InitializeHashTable; if SavedTableSize>0 Then for i:=0 to SavedTableSize-1 do begin List:=TFPObjectList(SavedTable[i]); if Assigned(List) then for j:=0 to List.Count -1 do begin temp:=THTCustomNode(List[j]); AddNode(temp); end; end; SavedTable.Free; end; Procedure TFPCustomHashTable.SetHashFunction(AHashFunction: THashFunction); begin if IsEmpty then FHashFunction:=AHashFunction else raise Exception.Create(NotEmptyMsg); end; Function TFPCustomHashTable.Find(const aKey: string): THTCustomNode; var hashCode: Longword; chn: TFPObjectList; i: Longword; begin hashCode:=FHashFunction(aKey, FHashTableSize); chn:=Chain(hashCode); if Assigned(chn) then if chn.count>0 then for i:=0 to chn.Count - 1 do if THTCustomNode(chn[i]).Key=aKey then Exit(THTCustomNode(chn[i])); Result:=nil; end; Function TFPCustomHashTable.FindChainForAdd(Const aKey : String) : TFPObjectList; var hashCode: Longword; i: Longword; begin hashCode:=FHashFunction(aKey, FHashTableSize); Result:=Chain(hashCode); if Assigned(Result) then begin if Result.count>0 then for i:=0 to Result.Count - 1 do if (THTCustomNode(Result[i]).Key=aKey) then raise EDuplicate.CreateFmt(DuplicateMsg, [aKey]); end else begin FHashTable[hashcode]:=TFPObjectList.Create(True); Result:=Chain(hashCode); end; Inc(FCount); end; Procedure TFPCustomHashTable.Delete(const aKey: string); var hashCode: Longword; chn: TFPObjectList; i: Longword; begin hashCode:=FHashFunction(aKey, FHashTableSize); chn:=Chain(hashCode); if Assigned(chn) then if chn.count>0 then for i:=0 to chn.Count - 1 do if THTCustomNode(chn[i]).Key=aKey then begin chn.Delete(i); dec(FCount); Exit; end; end; Function TFPCustomHashTable.IsEmpty: boolean; begin Result:=(FCount = 0); end; Function TFPCustomHashTable.Chain(const index: Longword): TFPObjectList; begin Result:=TFPObjectList(FHashTable[index]); end; Function TFPCustomHashTable.GetVoidSlots: Longword; var i: Longword; num: Longword; begin num:=0; if FHashTableSize>0 then for i:= 0 to FHashTableSize-1 do if not Assigned(Chain(i)) then Inc(num); Result:=num; end; Function TFPCustomHashTable.GetLoadFactor: double; begin Result:=Count / FHashTableSize; end; Function TFPCustomHashTable.GetAVGChainLen: double; begin Result:=Count / (FHashTableSize - VoidSlots); end; Function TFPCustomHashTable.GetMaxChainLength: Longword; var i: Longword; begin Result:=0; if FHashTableSize>0 Then for i:=0 to FHashTableSize-1 do if ChainLength(i) > Result then Result:=ChainLength(i); end; Function TFPCustomHashTable.FindOrCreateNew(const aKey: string): THTCustomNode; var hashCode: Longword; chn: TFPObjectList; i: Longword; begin hashCode:=FHashFunction(aKey, FHashTableSize); chn:=Chain(hashCode); if Assigned(chn) then begin if chn.count>0 then for i:=0 to chn.Count - 1 do if (THTCustomNode(chn[i]).Key=aKey) then Exit(THTNode(chn[i])); end else begin FHashTable[hashcode]:=TFPObjectList.Create(true); chn:=Chain(hashcode); end; Inc(FCount); Result:=CreateNewNode(aKey); chn.Add(Result); end; Function TFPCustomHashTable.ChainLength(const ChainIndex: Longword): Longword; begin if Assigned(Chain(ChainIndex)) then Result:=Chain(ChainIndex).Count else Result:=0; end; Procedure TFPCustomHashTable.Clear; var i: Longword; begin if FHashTableSize>0 then for i:=0 to FHashTableSize - 1 do if Assigned(Chain(i)) then Chain(i).Clear; FCount:=0; end; { TFPDataHashTable } Procedure TFPDataHashTable.Add(const aKey: string; aItem: JSValue); var chn: TFPObjectList; NewNode: THtDataNode; begin chn:=FindChainForAdd(akey); NewNode:=THtDataNode(CreateNewNode(aKey)); NewNode.Data:=aItem; chn.Add(NewNode); end; Function TFPDataHashTable.GetData(const Index: string): JSValue; var node: THTDataNode; begin node:=THTDataNode(Find(Index)); if Assigned(node) then Result:=node.Data else Result:=nil; end; Procedure TFPDataHashTable.SetData(const index: string; const AValue: JSValue); begin THTDataNode(FindOrCreateNew(index)).Data:=AValue; end; Function TFPDataHashTable.CreateNewNode(const aKey : string) : THTCustomNode; begin Result:=THTDataNode.CreateWith(aKey); end; Function TFPDataHashTable.Iterate(aMethod: TDataIteratorMethod): JSValue; var N : THTDataNode; begin N:=ForEachCall(AMethod); if Assigned(N) then Result:=N.Data else Result:=nil; end; Procedure TFPDataHashTable.CallbackIterator(Item: JSValue; const Key: string; var Continue: Boolean); begin FIteratorCallBack(Item, Key, Continue); end; Function TFPDataHashTable.Iterate(aMethod: TDataIteratorCallBack): JSValue; begin FIteratorCallBack := aMethod; Result := Iterate(@CallbackIterator); end; Function TFPDataHashTable.ForEachCall(aMethod: TDataIteratorMethod): THTDataNode; var i, j: Longword; continue: Boolean; begin Result:=nil; continue:=true; if FHashTableSize>0 then for i:=0 to FHashTableSize-1 do if Assigned(Chain(i)) then if chain(i).count>0 then for j:=0 to Chain(i).Count-1 do begin aMethod(THTDataNode(Chain(i)[j]).Data, THTDataNode(Chain(i)[j]).Key, continue); if not continue then begin Result:=THTDataNode(Chain(i)[j]); Exit; end; end; end; Procedure TFPDataHashTable.AddNode(ANode : THTCustomNode); begin with THTDataNode(ANode) do Add(Key,Data); end; { TFPStringHashTable } Procedure TFPStringHashTable.AddNode(ANode : THTCustomNode); begin with THTStringNode(ANode) do Add(Key,Data); end; Function TFPStringHashTable.GetData(const Index: string): String; var node: THTStringNode; begin node:=THTStringNode(Find(Index)); if Assigned(node) then Result:=node.Data else Result:=''; end; Procedure TFPStringHashTable.SetData(const index, AValue: string); begin THTStringNode(FindOrCreateNew(index)).Data:=AValue; end; Procedure TFPStringHashTable.Add(const aKey, aItem: string); var chn: TFPObjectList; NewNode: THtStringNode; begin chn:=FindChainForAdd(akey); NewNode:=THtStringNode(CreateNewNode(aKey)); NewNode.Data:=aItem; chn.Add(NewNode); end; Function TFPStringHashTable.CreateNewNode(const aKey : string) : THTCustomNode; begin Result:=THTStringNode.CreateWith(aKey); end; Function TFPStringHashTable.Iterate(aMethod: TStringIteratorMethod): String; var N : THTStringNode; begin N:=ForEachCall(AMethod); if Assigned(N) then Result:=N.Data else Result:=''; end; Procedure TFPStringHashTable.CallbackIterator(Item: String; const Key: string; var Continue: Boolean); begin FIteratorCallBack(Item, Key, Continue); end; Function TFPStringHashTable.Iterate(aMethod: TStringIteratorCallback): String; begin FIteratorCallBack := aMethod; Result := Iterate(@CallbackIterator); end; Function TFPStringHashTable.ForEachCall(aMethod: TStringIteratorMethod): THTStringNode; var i, j: Longword; continue: boolean; begin Result:=nil; continue:=True; if FHashTableSize>0 then for i:=0 to FHashTableSize-1 do if Assigned(Chain(i)) then if chain(i).Count>0 then for j:=0 to Chain(i).Count-1 do begin aMethod(THTStringNode(Chain(i)[j]).Data, THTStringNode(Chain(i)[j]).Key, continue); if not continue then begin Result:=THTStringNode(Chain(i)[j]); Exit; end; end; end; { TFPObjectHashTable } Procedure TFPObjectHashTable.AddNode(ANode : THTCustomNode); begin With THTObjectNode(ANode) do Add(Key,Data); end; Function TFPObjectHashTable.GetData(const Index: string): TObject; var node: THTObjectNode; begin node:=THTObjectNode(Find(Index)); if Assigned(node) then Result:=node.Data else Result:=nil; end; Procedure TFPObjectHashTable.SetData(const index : string; AObject : TObject); begin THTObjectNode(FindOrCreateNew(index)).Data:=AObject; end; Procedure TFPObjectHashTable.Add(const aKey: string; AItem : TObject); var chn: TFPObjectList; NewNode: THTObjectNode; begin chn:=FindChainForAdd(akey); NewNode:=THTObjectNode(CreateNewNode(aKey)); NewNode.Data:=aItem; chn.Add(NewNode); end; Function TFPObjectHashTable.CreateNewNode(const aKey : string) : THTCustomNode; begin if OwnsObjects then Result:=THTOwnedObjectNode.CreateWith(aKey) else Result:=THTObjectNode.CreateWith(aKey); end; Function TFPObjectHashTable.Iterate(aMethod: TObjectIteratorMethod): TObject; var N : THTObjectNode; begin N:=ForEachCall(AMethod); if Assigned(N) then Result:=N.Data else Result:=nil; end; Procedure TFPObjectHashTable.CallbackIterator(Item: TObject; const Key: string; var Continue: Boolean); begin FIteratorCallBack(Item, Key, Continue); end; Function TFPObjectHashTable.Iterate(aMethod: TObjectIteratorCallback): TObject; begin FIteratorCallBack := aMethod; Result := Iterate(@CallbackIterator); end; Function TFPObjectHashTable.ForEachCall(aMethod: TObjectIteratorMethod): THTObjectNode; var i, j: Longword; continue: boolean; begin Result:=nil; continue:=true; if FHashTableSize>0 then for i:=0 to FHashTableSize-1 do if Assigned(Chain(i)) then if Chain(i).Count>0 then for j:=0 to Chain(i).Count-1 do begin aMethod(THTObjectNode(Chain(i)[j]).Data, THTObjectNode(Chain(i)[j]).Key, continue); if not continue then begin Result:=THTObjectNode(Chain(i)[j]); Exit; end; end; end; constructor TFPObjectHashTable.Create(AOwnsObjects : Boolean = True); begin inherited Create; FOwnsObjects:=AOwnsObjects; end; constructor TFPObjectHashTable.CreateWith(AHashTableSize: Longword; aHashFunc: THashFunction; AOwnsObjects : Boolean = True); begin inherited CreateWith(AHashTableSize,AHashFunc); FOwnsObjects:=AOwnsObjects; end; destructor THTOwnedObjectNode.Destroy; begin FreeAndNil(FData); inherited; end; { TCustomBucketList } Function TCustomBucketList.GetData(AItem: JSValue): JSValue; var B,I : Integer; begin GetBucketItem(AItem,B,I); Result:=FBuckets[B].Items[I].Data; end; Function TCustomBucketList.GetBucketCount: Integer; begin Result:=Length(FBuckets); end; Procedure TCustomBucketList.SetData(AItem: JSValue; const AData: JSValue); var B,I : Integer; begin GetBucketItem(AItem,B,I); FBuckets[B].Items[I].Data:=AData; end; Procedure TCustomBucketList.SetBucketCount(const Value: Integer); begin if (Value<>GetBucketCount) then SetLength(FBuckets,Value); end; Procedure TCustomBucketList.GetBucketItem(AItem: JSValue; out ABucket, AIndex: Integer); begin if not FindItem(AItem,ABucket,AIndex) then Error(SErrNoSuchItem,[AItem]); end; Function TCustomBucketList.AddItem(ABucket: Integer; AItem, AData: JSValue ): JSValue; var L : Integer; begin L:=Length(FBuckets[ABucket].Items); if (FBuckets[ABucket].Count=L) then begin if L<8 then L:=8 else L:=L+L div 2; SetLength(FBuckets[ABucket].Items,L); end; with FBuckets[ABucket] do begin Items[Count].Item:=AItem; Items[Count].Data:=AData; Result:=AData; Inc(Count); end; end; Function TCustomBucketList.DeleteItem(ABucket: Integer; AIndex: Integer): JSValue; var I,L : Integer; begin Result:=FBuckets[ABucket].Items[AIndex].Data; if FBuckets[ABucket].Count=1 then SetLength(FBuckets[ABucket].Items,0) else begin L:=(FBuckets[ABucket].Count-AIndex-1);// No point in moving if last one... For I:=0 to L-1 do FBuckets[ABucket].Items[AIndex+I]:=FBuckets[ABucket].Items[AIndex+I+1]; end; Dec(FBuckets[ABucket].Count); end; Procedure TCustomBucketList.Error(Msg: String; Args: array of Const); begin raise ElistError.CreateFmt(Msg,Args); end; Function TCustomBucketList.FindItem(AItem: JSValue; out ABucket, AIndex: Integer ): Boolean; var I : Integer; B : TBucket; begin ABucket:=BucketFor(AItem); B:=FBuckets[ABucket]; I:=B.Count-1; while (I>=0) and (B.Items[I].Item<>AItem) do Dec(I); Result:=I>=0; if Result then AIndex:=I; end; destructor TCustomBucketList.Destroy; begin Clear; inherited Destroy; end; Procedure TCustomBucketList.Clear; var B : TBucket; I,J : Integer; begin for I:=0 to Length(FBuckets)-1 do begin B:=FBuckets[I]; for J:=B.Count-1 downto 0 do DeleteItem(I,J); end; SetLength(FBuckets,0); end; Function TCustomBucketList.Add(AItem, AData: JSValue): JSValue; var B,I : Integer; begin if FindItem(AItem,B,I) then Error(SDuplicateItem,[AItem]); Result:=AddItem(B,AItem,AData); end; Procedure TCustomBucketList.Assign(AList: TCustomBucketList); var I,J : Integer; begin Clear; SetLength(FBuckets,Length(Alist.FBuckets)); for I:=0 to BucketCount-1 do begin SetLength(FBuckets[i].Items,Length(AList.Fbuckets[I].Items)); for J:=0 to AList.Fbuckets[I].Count-1 do with AList.Fbuckets[I].Items[J] do AddItem(I,Item,Data); end; end; Function TCustomBucketList.Exists(AItem: JSValue): Boolean; var B,I : Integer; begin Result:=FindItem(AItem,B,I); end; Function TCustomBucketList.Find(AItem: JSValue; out AData: JSValue): Boolean; var B,I : integer; begin Result:=FindItem(AItem,B,I); if Result then AData:=FBuckets[B].Items[I].Data; end; Function TCustomBucketList.ForEach(AProc: TBucketProc): Boolean; begin Result:=Foreach(aProc,Null); end; Function TCustomBucketList.ForEach(AProc: TBucketProc; AInfo: JSValue): Boolean; var I,J,S : Integer; Bu : TBucket; begin I:=0; Result:=True; S:=GetBucketCount; while Result and (I