1{ 2 ***************************************************************************** 3 This file is part of LazUtils. 4 5 See the file COPYING.modifiedLGPL.txt, included in this distribution, 6 for details about the license. 7 ***************************************************************************** 8 9 Author: Mattias Gaertner 10 11 Abstract: 12 This unit defines TDynHashArray, which is very similar to a TList, since 13 it also stores pointer/objects. 14 It supports Add, Remove, Contains, First, Count and Clear. 15 Because of the hashing nature the operations adding, removing and finding is 16 done in constant time on average. 17 18 Inner structure: 19 There are three parts: 20 1. The array itself (FItems). Every entry is a pointer to the first 21 TDynHashArrayItem of a list with the same hash index. The first item 22 of every same index list is the list beginning and its IsOverflow 23 flag is set to false. All other items are overflow items. 24 To get all items with the same hash index, do a FindHashItem. Then 25 search through all "Next" items until Next is nil or its IsOverflow 26 flag is set to false. 27 2. The items beginning with FFirstItem is a 2-way-connected list of 28 TDynHashArrayItem. This list contains all used items. 29 3. To reduce GetMem/FreeMem calls, free items are cached. 30 31 Issues: 32 The maximum capacity is the PrimeNumber. You can store more items, but the 33 performance decreases. The best idea is to provide your own hash function. 34 35 Important: Items in the TDynHashArray must not change their key. 36 When changing the key of an item, remove it and add it after the change. 37 38} 39unit DynHashArray; 40 41{$Mode ObjFPC}{$H+} 42 43interface 44 45uses 46 Classes, SysUtils, 47 // LazUtils 48 LazLoggerBase; 49 50type 51 TDynHashArray = class; 52 53 THashFunction = function(Sender: TDynHashArray; Item: Pointer): integer; 54 TOwnerHashFunction = function(Item: Pointer): integer of object; 55 TOnGetKeyForHashItem = function(Item: pointer): pointer; 56 TOnEachHashItem = function(Sender: TDynHashArray; Item: Pointer): boolean; 57 58 PDynHashArrayItem = ^TDynHashArrayItem; 59 TDynHashArrayItem = record 60 Item: Pointer; 61 Next, Prior: PDynHashArrayItem; 62 IsOverflow: boolean; 63 end; 64 65 TDynHashArrayOption = (dhaoCachingEnabled, dhaoCacheContains); 66 TDynHashArrayOptions = set of TDynHashArrayOption; 67 68 { TDynHashArray } 69 70 TDynHashArray = class 71 private 72 FItems: ^PDynHashArrayItem; 73 FCount: integer; 74 FCapacity: integer; 75 FMinCapacity: integer; 76 FMaxCapacity: integer; 77 FFirstItem: PDynHashArrayItem; 78 FHashCacheItem: Pointer; 79 FHashCacheIndex: integer; 80 FLowWaterMark: integer; 81 FHighWaterMark: integer; 82 FCustomHashFunction: THashFunction; 83 FOnGetKeyForHashItem: TOnGetKeyForHashItem; 84 FOptions: TDynHashArrayOptions; 85 FOwnerHashFunction: TOwnerHashFunction; 86 FContainsCache: TObject; 87 function NewHashItem: PDynHashArrayItem; 88 procedure DisposeHashItem(ADynHashArrayItem: PDynHashArrayItem); 89 procedure ComputeWaterMarks; 90 procedure SetCapacity(NewCapacity: integer); 91 procedure SetCustomHashFunction(const AValue: THashFunction); 92 procedure SetOnGetKeyForHashItem(const AValue: TOnGetKeyForHashItem); 93 procedure SetOptions(const AValue: TDynHashArrayOptions); 94 procedure SetOwnerHashFunction(const AValue: TOwnerHashFunction); 95 protected 96 procedure RebuildItems; 97 procedure SaveCacheItem(Item: Pointer; Index: integer); 98 public 99 constructor Create; 100 constructor Create(InitialMinCapacity: integer); 101 destructor Destroy; override; 102 procedure Add(Item: Pointer); 103 function Contains(Item: Pointer): boolean; 104 function ContainsKey(Key: Pointer): boolean; 105 procedure Remove(Item: Pointer); 106 procedure Clear; 107 procedure ClearCache; 108 function First: Pointer; 109 property Count: integer read fCount; 110 function IndexOf(AnItem: Pointer): integer; 111 function IndexOfKey(Key: Pointer): integer; 112 function FindHashItem(Item: Pointer): PDynHashArrayItem; 113 function FindHashItemWithKey(Key: Pointer): PDynHashArrayItem; 114 function FindItemWithKey(Key: Pointer): Pointer; 115 function GetHashItem(HashIndex: integer): PDynHashArrayItem; 116 procedure Delete(ADynHashArrayItem: PDynHashArrayItem); 117 procedure AssignTo(List: TList); 118 procedure AssignTo(List: TFPList); 119 procedure ForEach(const Func: TOnEachHashItem); 120 121 function SlowAlternativeHashMethod(Sender: TDynHashArray; 122 Item: Pointer): integer; 123 function ConsistencyCheck: integer; 124 procedure WriteDebugReport; 125 126 property FirstHashItem: PDynHashArrayItem read FFirstItem; 127 property MinCapacity: integer read FMinCapacity write FMinCapacity; 128 property MaxCapacity: integer read FMaxCapacity write FMaxCapacity; 129 property Capacity: integer read FCapacity; 130 property CustomHashFunction: THashFunction 131 read FCustomHashFunction write SetCustomHashFunction; 132 property OwnerHashFunction: TOwnerHashFunction 133 read FOwnerHashFunction write SetOwnerHashFunction; 134 property OnGetKeyForHashItem: TOnGetKeyForHashItem 135 read FOnGetKeyForHashItem write SetOnGetKeyForHashItem; 136 property Options: TDynHashArrayOptions read FOptions write SetOptions; 137 end; 138 139 TDynHashArrayItemMemManager = class 140 private 141 FFirstFree: PDynHashArrayItem; 142 FFreeCount: integer; 143 FCount: integer; 144 FMinFree: integer; 145 FMaxFreeRatio: integer; 146 procedure SetMaxFreeRatio(NewValue: integer); 147 procedure SetMinFree(NewValue: integer); 148 procedure DisposeFirstFreeItem; 149 public 150 procedure DisposeItem(ADynHashArrayItem: PDynHashArrayItem); 151 function NewItem: PDynHashArrayItem; 152 property MinimumFreeCount: integer read FMinFree write SetMinFree; 153 property MaximumFreeRatio: integer 154 read FMaxFreeRatio write SetMaxFreeRatio; // in one eighth steps 155 property Count: integer read FCount; 156 procedure Clear; 157 constructor Create; 158 destructor Destroy; override; 159 function ConsistencyCheck: integer; 160 procedure WriteDebugReport; 161 end; 162 163 EDynHashArrayException = class(Exception); 164 165const 166 ItemMemManager: TDynHashArrayItemMemManager = nil; 167 168implementation 169 170function GetItemMemManager: TDynHashArrayItemMemManager; 171begin 172 if ItemMemManager=nil then 173 ItemMemManager:=TDynHashArrayItemMemManager.Create; 174 Result:=ItemMemManager; 175end; 176 177const 178 PrimeNumber: integer = 5364329; 179 180 181type 182 TRecentList = class 183 private 184 FCapacity: integer; 185 FCount: integer; 186 FItems: PPointer; 187 procedure FreeItems; 188 procedure SetCapacity(NewCapacity: integer); 189 public 190 constructor Create(TheCapacity: integer); 191 destructor Destroy; override; 192 function Contains(Item: Pointer): boolean; 193 procedure Add(Item: Pointer); 194 procedure Remove(Item: Pointer); 195 function IndexOf(Item: Pointer): integer; 196 procedure Clear; 197 function ConsistencyCheck: integer; 198 property Cacpacity: integer read FCapacity; 199 property Count: integer read FCount; 200 end; 201 202{ TRecentList } 203 204procedure TRecentList.FreeItems; 205begin 206 if FItems<>nil then begin 207 FreeMem(FItems); 208 FItems:=nil; 209 end; 210end; 211 212procedure TRecentList.SetCapacity(NewCapacity: integer); 213begin 214 if NewCapacity=FCapacity then exit; 215 if NewCapacity>0 then 216 ReAllocMem(FItems,NewCapacity*SizeOf(Pointer)) 217 else 218 FreeItems; 219 FCapacity:=NewCapacity; 220 if FCount>FCapacity then FCount:=FCapacity; 221end; 222 223constructor TRecentList.Create(TheCapacity: integer); 224begin 225 inherited Create; 226 if TheCapacity<1 then FCapacity:=1; 227 SetCapacity(TheCapacity); 228end; 229 230destructor TRecentList.Destroy; 231begin 232 FreeItems; 233 inherited Destroy; 234end; 235 236function TRecentList.Contains(Item: Pointer): boolean; 237begin 238 Result:=IndexOf(Item)>=0; 239end; 240 241procedure TRecentList.Add(Item: Pointer); 242begin 243 if FCount=FCapacity then begin 244 if FCount>1 then 245 Move(FItems[1],FItems[0],SizeOf(PPointer)*(FCount-1)); 246 end else begin 247 inc(FCount); 248 end; 249 FItems[FCount-1]:=Item; 250end; 251 252procedure TRecentList.Remove(Item: Pointer); 253var i: integer; 254begin 255 i:=IndexOf(Item); 256 if i<0 then exit; 257 if i<FCount-1 then 258 Move(FItems[i+1],FItems[i],SizeOf(PPointer)*(FCount-i-1)); 259 dec(FCount); 260end; 261 262function TRecentList.IndexOf(Item: Pointer): integer; 263begin 264 Result:=FCount-1; 265 while (Result>=0) and (FItems[Result]<>Item) do dec(Result); 266end; 267 268procedure TRecentList.Clear; 269begin 270 FCount:=0; 271end; 272 273function TRecentList.ConsistencyCheck: integer; 274begin 275 if FCount>FCapacity then exit(-1); 276 if FCapacity=0 then exit(-2); 277 if FItems=nil then exit(-3); 278 Result:=0; 279end; 280 281{ TDynHashArray } 282 283procedure TDynHashArray.WriteDebugReport; 284var i, RealHashIndex: integer; 285 HashItem: PDynHashArrayItem; 286begin 287 DebugLn('TDynHashArray.WriteDebugReport: Consistency=',dbgs(ConsistencyCheck)); 288 DebugLn(' Count=',dbgs(FCount),' Capacity=',dbgs(FCapacity)); 289 for i:=0 to FCapacity-1 do begin 290 HashItem:=FItems[i]; 291 if HashItem<>nil then begin 292 DbgOut(' Index=',IntToStr(i)); 293 while HashItem<>nil do begin 294 DbgOut(' ',Dbgs(HashItem^.Item)); 295 RealHashIndex:=IndexOf(HashItem^.Item); 296 if RealHashIndex<>i then 297 DbgOut('(H='+dbgs(RealHashIndex)+')'); 298 HashItem:=HashItem^.Next; 299 if (HashItem<>nil) and (HashItem^.IsOverflow=false) then break; 300 end; 301 DebugLn; 302 end; 303 end; 304 HashItem:=FFirstItem; 305 while HashItem<>nil do begin 306 DebugLn(' ',Dbgs(HashItem^.Prior),'<-' 307 ,Dbgs(HashItem) 308 ,'(',Dbgs(HashItem^.Item),')' 309 ,'->',Dbgs(HashItem^.Next)); 310 HashItem:=HashItem^.Next; 311 end; 312end; 313 314constructor TDynHashArray.Create(InitialMinCapacity: integer); 315var Size: integer; 316begin 317 inherited Create; 318 FMinCapacity:=InitialMinCapacity; 319 FMaxCapacity:=PrimeNumber; 320 if FMinCapacity<5 then FMinCapacity:=137; 321 FCapacity:=FMinCapacity; 322 Size:=FCapacity * SizeOf(TDynHashArrayItem); 323 GetMem(FItems,Size); 324 FillChar(FItems^,Size,0); 325 FCount:=0; 326 FFirstItem:=nil; 327 ComputeWaterMarks; 328 FHashCacheIndex:=-1; 329end; 330 331destructor TDynHashArray.Destroy; 332begin 333 Clear; 334 FreeMem(FItems); 335 FContainsCache.Free; 336 inherited Destroy; 337end; 338 339function TDynHashArray.ConsistencyCheck: integer; 340var RealCount, i: integer; 341 HashItem, HashItem2: PDynHashArrayItem; 342 OldCacheItem: pointer; 343 OldCacheIndex: integer; 344begin 345 RealCount:=0; 346 // check first item 347 if (FFirstItem<>nil) and (FFirstItem^.IsOverflow) then 348 exit(-1); 349 if (FItems=nil) and (FFirstItem<>nil) then 350 exit(-2); 351 // check for doubles and circles 352 HashItem:=FFirstItem; 353 while HashItem<>nil do begin 354 HashItem2:=HashItem^.Prior; 355 while HashItem2<>nil do begin 356 if HashItem=HashItem2 then 357 exit(-3); // circle 358 if HashItem^.Item=HashItem2^.Item then 359 exit(-4); // double item 360 HashItem2:=HashItem2^.Prior; 361 end; 362 HashItem:=HashItem^.Next; 363 end; 364 // check chain 365 HashItem:=FFirstItem; 366 while HashItem<>nil do begin 367 inc(RealCount); 368 if (HashItem^.Next<>nil) and (HashItem^.Next^.Prior<>HashItem) then 369 exit(-6); 370 if (HashItem^.Prior<>nil) and (HashItem^.Prior^.Next<>HashItem) then 371 exit(-7); 372 if (HashItem^.IsOverflow=false) 373 and (FItems[IndexOf(HashItem^.Item)]<>HashItem) then 374 exit(-8); 375 HashItem:=HashItem^.Next; 376 end; 377 // check count 378 if RealCount<>FCount then exit(-9); 379 // check FItems 380 RealCount:=0; 381 for i:=0 to FCapacity-1 do begin 382 HashItem:=FItems[i]; 383 while HashItem<>nil do begin 384 inc(RealCount); 385 if IndexOf(HashItem^.Item)<>i then exit(-14); 386 HashItem:=HashItem^.Next; 387 if (HashItem<>nil) and (HashItem^.IsOverflow=false) then break; 388 end; 389 end; 390 if RealCount<>FCount then exit(-15); 391 // check cache 392 if FHashCacheIndex>=0 then begin 393 OldCacheItem:=FHashCacheItem; 394 OldCacheIndex:=FHashCacheIndex; 395 ClearCache; 396 FHashCacheIndex:=IndexOfKey(OldCacheItem); 397 if FHashCacheIndex<>OldCacheIndex then exit(-16); 398 FHashCacheItem:=OldCacheItem; 399 end; 400 // check ContainsCache 401 if (FContainsCache<>nil) xor (dhaoCacheContains in Options) then exit(-17); 402 if (FContainsCache<>nil) then begin 403 Result:=TRecentList(FContainsCache).ConsistencyCheck; 404 if Result<>0 then begin 405 dec(Result,100); 406 exit; 407 end; 408 end; 409 Result:=0; 410end; 411 412procedure TDynHashArray.ComputeWaterMarks; 413begin 414 FLowWaterMark:=FCapacity div 4; 415 FHighWaterMark:=(FCapacity*3) div 4; 416end; 417 418function TDynHashArray.IndexOf(AnItem: Pointer): integer; 419begin 420 if (AnItem<>nil) and (FItems<>nil) then begin 421 if Assigned(OnGetKeyForHashItem) then begin 422 AnItem:=OnGetKeyForHashItem(AnItem); 423 end; 424 Result:=IndexOfKey(AnItem); 425 end else 426 Result:=-1; 427end; 428 429function TDynHashArray.IndexOfKey(Key: Pointer): integer; 430begin 431 if (FItems<>nil) 432 and ((Key<>nil) or Assigned(OnGetKeyForHashItem)) then begin 433 434 if (dhaoCachingEnabled in Options) 435 and (Key=FHashCacheItem) and (FHashCacheIndex>=0) then 436 exit(FHashCacheIndex); 437 if not Assigned(FCustomHashFunction) then begin 438 if not Assigned(FOwnerHashFunction) then begin 439 Result:=Integer(({%H-}PtrUInt(Key)+({%H-}PtrUint(Key) mod 17)) mod Cardinal(FCapacity)); 440 end else 441 Result:=FOwnerHashFunction(Key); 442 end else 443 Result:=FCustomHashFunction(Self,Key); 444 {if (Key=FHashCacheItem) and (FHashCacheIndex>=0) 445 and (Result<>FHashCacheIndex) then begin 446 DebugLn(' DAMN: ',HexStr(PtrInt(Key),8),' ',FHashCacheIndex,'<>',Result); 447 raise Exception.Create('GROSSER MIST'); 448 end;} 449 // Check if the owner or custon function has returned something valid 450 if (Result < 0) 451 or (Result >= FCapacity) 452 then raise EDynHashArrayException.CreateFmt('Invalid index %d for key %p', [Result, Key]); 453 end else 454 Result:=-1; 455end; 456 457procedure TDynHashArray.Clear; 458begin 459 ClearCache; 460 while FFirstItem<>nil do Delete(FFirstItem); 461end; 462 463procedure TDynHashArray.ClearCache; 464begin 465 FHashCacheIndex:=-1; 466 if FContainsCache<>nil then TRecentList(FContainsCache).Clear; 467end; 468 469procedure TDynHashArray.Add(Item: Pointer); 470var Index: integer; 471 HashItem: PDynHashArrayItem; 472begin 473 if Item=nil then exit; 474 if FCount>=FHighWaterMark then begin 475 SetCapacity(FCapacity*2-1); 476 end; 477 Index:=IndexOf(Item); 478 if Index < 0 then Exit; 479 HashItem:=NewHashItem; 480 HashItem^.Item:=Item; 481 if FItems[Index]=nil then begin 482 HashItem^.Next:=FFirstItem; 483 end else begin 484 HashItem^.Next:=FItems[Index]; 485 HashItem^.Prior:=HashItem^.Next^.Prior; 486 HashItem^.Next^.IsOverflow:=true; 487 end; 488 if (HashItem^.Next=FFirstItem) then 489 FFirstItem:=HashItem; 490 FItems[Index]:=HashItem; 491 if HashItem^.Next<>nil then begin 492 HashItem^.Next^.Prior:=HashItem; 493 if HashItem^.Prior<>nil then 494 HashItem^.Prior^.Next:=HashItem; 495 end; 496 inc(FCount); 497 SaveCacheItem(Item,Index); 498 if FContainsCache<>nil then TRecentList(FContainsCache).Clear; 499end; 500 501function TDynHashArray.SlowAlternativeHashMethod(Sender: TDynHashArray; 502 Item: Pointer): integer; 503begin 504 Result:=integer(({%H-}PtrUInt(Item) mod Cardinal(PrimeNumber)) 505 +({%H-}PtrUInt(Item) mod 17)+({%H-}PtrUInt(Item) mod 173) 506 +({%H-}PtrUInt(Item) mod 521) 507 ) mod FCapacity; 508end; 509 510procedure TDynHashArray.Remove(Item: Pointer); 511begin 512 Delete(FindHashItem(Item)); 513end; 514 515procedure TDynHashArray.Delete(ADynHashArrayItem: PDynHashArrayItem); 516var Index: integer; 517 OldNext: PDynHashArrayItem; 518begin 519 if ADynHashArrayItem=nil then exit; 520 // delete from cache 521 if (FHashCacheIndex>=0) 522 and ((ADynHashArrayItem^.Item=FHashCacheItem) 523 or (Assigned(OnGetKeyForHashItem) 524 and (OnGetKeyForHashItem(ADynHashArrayItem^.Item)=FHashCacheItem))) 525 then 526 // if the user removes an item, changes the key and readds it, the hash 527 // of the item can change 528 // => the cache must be cleared 529 ClearCache; 530 // delete from FItems 531 if not ADynHashArrayItem^.IsOverflow then begin 532 // Item is first item with hash 533 Index:=IndexOf(ADynHashArrayItem^.Item); 534 if Index < 0 then Exit; // should not happen 535 OldNext:=ADynHashArrayItem^.Next; 536 if (OldNext=nil) or (not (OldNext^.IsOverflow)) then 537 FItems[Index]:=nil 538 else begin 539 FItems[Index]:=OldNext; 540 OldNext^.IsOverflow:=false; 541 end; 542 end; 543 // adjust FFirstItem 544 if FFirstItem=ADynHashArrayItem then 545 FFirstItem:=FFirstItem^.Next; 546 // free storage item 547 DisposeHashItem(ADynHashArrayItem); 548 // adjust count and capacity 549 dec(FCount); 550 if FCount<FLowWaterMark then begin 551 // resize 552 SetCapacity((FCapacity+1) div 2); 553 end; 554end; 555 556procedure TDynHashArray.AssignTo(List: TList); 557var 558 i: integer; 559 HashItem: PDynHashArrayItem; 560begin 561 List.Count:=Count; 562 HashItem:=FirstHashItem; 563 i:=0; 564 while HashItem<>nil do begin 565 List[i]:=HashItem^.Item; 566 inc(i); 567 HashItem:=HashItem^.Next; 568 end; 569end; 570 571procedure TDynHashArray.AssignTo(List: TFPList); 572var 573 i: integer; 574 HashItem: PDynHashArrayItem; 575begin 576 List.Count:=Count; 577 HashItem:=FirstHashItem; 578 i:=0; 579 while HashItem<>nil do begin 580 List[i]:=HashItem^.Item; 581 inc(i); 582 HashItem:=HashItem^.Next; 583 end; 584end; 585 586procedure TDynHashArray.ForEach(const Func: TOnEachHashItem); 587var 588 HashItem: PDynHashArrayItem; 589begin 590 HashItem:=FFirstItem; 591 while HashItem<>nil do begin 592 if not Func(Self,HashItem^.Item) then break; 593 HashItem:=HashItem^.Next; 594 end; 595end; 596 597function TDynHashArray.First: Pointer; 598begin 599 if FFirstItem<>nil then 600 Result:=FFirstItem^.Item 601 else 602 Result:=nil; 603end; 604 605function TDynHashArray.NewHashItem: PDynHashArrayItem; 606begin 607 Result:=GetItemMemManager.NewItem; 608end; 609 610procedure TDynHashArray.DisposeHashItem(ADynHashArrayItem: PDynHashArrayItem); 611begin 612 GetItemMemManager.DisposeItem(ADynHashArrayItem); 613end; 614 615function TDynHashArray.Contains(Item: Pointer): boolean; 616begin 617 if (FContainsCache=nil) or (not TRecentList(FContainsCache).Contains(Item)) 618 then begin 619 Result:=FindHashItem(Item)<>nil; 620 if Result and (FContainsCache<>nil) then 621 TRecentList(FContainsCache).Add(Item); 622 end else 623 Result:=true; 624end; 625 626function TDynHashArray.ContainsKey(Key: Pointer): boolean; 627begin 628 Result:=FindHashItemWithKey(Key)<>nil; 629end; 630 631function TDynHashArray.FindHashItem(Item: Pointer): PDynHashArrayItem; 632var Index: integer; 633begin 634 if (Item<>nil) and (FItems<>nil) then begin 635 Index:=IndexOf(Item); 636 if Index>=0 then begin 637 Result:=FItems[Index]; 638 if (Result<>nil) then begin 639 while (Result^.Item<>Item) do begin 640 Result:=Result^.Next; 641 if Result=nil then exit; 642 if Result^.IsOverflow=false then begin 643 Result:=nil; 644 exit; 645 end; 646 end; 647 SaveCacheItem(Item,Index); 648 end; 649 end else 650 Result:=nil; 651 end else 652 Result:=nil; 653end; 654 655function TDynHashArray.FindHashItemWithKey(Key: Pointer): PDynHashArrayItem; 656var Index: integer; 657begin 658 if FItems<>nil then begin 659 Index:=IndexOfKey(Key); 660 if Index>=0 then begin 661 Result:=FItems[Index]; 662 if (Result<>nil) then begin 663 if Assigned(OnGetKeyForHashItem) then begin 664 if OnGetKeyForHashItem(Result^.Item)=Key then exit; 665 // search in overflow hash items 666 Result:=Result^.Next; 667 while (Result<>nil) and (Result^.IsOverflow) do begin 668 if OnGetKeyForHashItem(Result^.Item)=Key then begin 669 FHashCacheIndex:=Index; 670 FHashCacheItem:=Key; 671 exit; 672 end; 673 Result:=Result^.Next; 674 end; 675 Result:=nil; 676 end; 677 end; 678 end else 679 Result:=nil; 680 end else 681 Result:=nil; 682end; 683 684function TDynHashArray.FindItemWithKey(Key: Pointer): Pointer; 685var 686 Index: integer; 687 HashItem: PDynHashArrayItem; 688begin 689 Result:=nil; 690 if FItems<>nil then begin 691 Index:=IndexOfKey(Key); 692 if Index < 0 then Exit; // should not happen 693 HashItem:=FItems[Index]; 694 if (HashItem<>nil) 695 and Assigned(OnGetKeyForHashItem) then begin 696 if OnGetKeyForHashItem(HashItem^.Item)=Key then exit; 697 // search in overflow hash items 698 HashItem:=HashItem^.Next; 699 while (HashItem<>nil) and (HashItem^.IsOverflow) do begin 700 if OnGetKeyForHashItem(HashItem^.Item)=Key then begin 701 FHashCacheIndex:=Index; 702 FHashCacheItem:=Key; 703 Result:=HashItem^.Item; 704 exit; 705 end; 706 HashItem:=HashItem^.Next; 707 end; 708 end; 709 end; 710end; 711 712function TDynHashArray.GetHashItem(HashIndex: integer): PDynHashArrayItem; 713begin 714 Result:=FItems[HashIndex]; 715end; 716 717procedure TDynHashArray.SetCapacity(NewCapacity: integer); 718var Size: integer; 719begin 720 if NewCapacity<FMinCapacity then NewCapacity:=FMinCapacity; 721 if NewCapacity>FMaxCapacity then NewCapacity:=FMaxCapacity; 722 if NewCapacity=FCapacity then exit; 723 // resize FItems 724 FreeMem(FItems); 725 FCapacity:=NewCapacity; 726 Size:=FCapacity * SizeOf(PDynHashArrayItem); 727 GetMem(FItems,Size); 728 ComputeWaterMarks; 729 // rebuild 730 RebuildItems; 731end; 732 733procedure TDynHashArray.SetCustomHashFunction(const AValue: THashFunction); 734begin 735 if FCustomHashFunction=AValue then exit; 736 FCustomHashFunction:=AValue; 737 FOwnerHashFunction:=nil; 738 RebuildItems; 739end; 740 741procedure TDynHashArray.SetOwnerHashFunction(const AValue: TOwnerHashFunction); 742begin 743 if FOwnerHashFunction=AValue then exit; 744 FCustomHashFunction:=nil; 745 FOwnerHashFunction:=AValue; 746 RebuildItems; 747end; 748 749procedure TDynHashArray.RebuildItems; 750var Index: integer; 751 CurHashItem, NextHashItem: PDynHashArrayItem; 752begin 753 FillChar(FItems^,FCapacity * SizeOf(PDynHashArrayItem),0); 754 ClearCache; 755 CurHashItem:=FFirstItem; 756 FFirstItem:=nil; 757 while CurHashItem<>nil do begin 758 NextHashItem:=CurHashItem^.Next; 759 Index:=IndexOf(CurHashItem^.Item); 760 if Index < 0 761 then begin 762 // ??? something bad happenend 763 // should we dispose current item ? 764 // Anyhow, skip it. 765 CurHashItem := NextHashItem; 766 Continue; 767 end; 768 CurHashItem^.IsOverFlow:=false; 769 CurHashItem^.Prior:=nil; 770 if FItems[Index]=nil then begin 771 CurHashItem^.Next:=FFirstItem; 772 end else begin 773 CurHashItem^.Next:=FItems[Index]; 774 CurHashItem^.Prior:=CurHashItem^.Next^.Prior; 775 CurHashItem^.Next^.IsOverflow:=true; 776 end; 777 if (CurHashItem^.Next=FFirstItem) then 778 FFirstItem:=CurHashItem; 779 FItems[Index]:=CurHashItem; 780 if CurHashItem^.Next<>nil then begin 781 CurHashItem^.Next^.Prior:=CurHashItem; 782 if CurHashItem^.Prior<>nil then 783 CurHashItem^.Prior^.Next:=CurHashItem; 784 end; 785 CurHashItem:=NextHashItem; 786 end; 787end; 788 789procedure TDynHashArray.SaveCacheItem(Item: Pointer; Index: integer); 790// Important: 791// !!! Only call this method for items, that exists in the list or for items 792// that can't change their key 793begin 794 if Assigned(OnGetKeyForHashItem) then Item:=OnGetKeyForHashItem(Item); 795 FHashCacheItem:=Item; 796 FHashCacheIndex:=Index; 797end; 798 799constructor TDynHashArray.Create; 800begin 801 Create(10); 802end; 803 804procedure TDynHashArray.SetOnGetKeyForHashItem( 805 const AValue: TOnGetKeyForHashItem); 806begin 807 if FOnGetKeyForHashItem=AValue then exit; 808 FOnGetKeyForHashItem:=AValue; 809 RebuildItems; 810end; 811 812procedure TDynHashArray.SetOptions(const AValue: TDynHashArrayOptions); 813begin 814 if FOptions=AValue then exit; 815 FOptions:=AValue; 816 if (FContainsCache<>nil) xor (dhaoCacheContains in Options) then begin 817 if FContainsCache=nil then begin 818 FContainsCache:=TRecentList.Create(5); 819 end else begin 820 FContainsCache.Free; 821 FContainsCache:=nil; 822 end; 823 end; 824end; 825 826{ TDynHashArrayItemMemManager } 827 828procedure TDynHashArrayItemMemManager.SetMaxFreeRatio(NewValue: integer); 829begin 830 if NewValue<0 then NewValue:=0; 831 if NewValue=FMaxFreeRatio then exit; 832 FMaxFreeRatio:=NewValue; 833end; 834 835procedure TDynHashArrayItemMemManager.SetMinFree(NewValue: integer); 836begin 837 if NewValue<0 then NewValue:=0; 838 if NewValue=FMinFree then exit; 839 FMinFree:=NewValue; 840end; 841 842procedure TDynHashArrayItemMemManager.DisposeFirstFreeItem; 843var OldItem: PDynHashArrayItem; 844begin 845 if FFirstFree=nil then exit; 846 OldItem:=FFirstFree; 847 FFirstFree:=OldItem^.Next; 848 if FFirstFree<>nil then 849 FFirstFree^.Prior:=nil; 850 Dispose(OldItem); 851 dec(FFreeCount); 852end; 853 854procedure TDynHashArrayItemMemManager.DisposeItem( 855 ADynHashArrayItem: PDynHashArrayItem); 856begin 857 if ADynHashArrayItem=nil then exit; 858 // unbind item 859 if ADynHashArrayItem^.Next<>nil then 860 ADynHashArrayItem^.Next^.Prior:=ADynHashArrayItem^.Prior; 861 if ADynHashArrayItem^.Prior<>nil then 862 ADynHashArrayItem^.Prior^.Next:=ADynHashArrayItem^.Next; 863 // add to free list 864 ADynHashArrayItem^.Next:=FFirstFree; 865 FFirstFree:=ADynHashArrayItem; 866 if ADynHashArrayItem^.Next<>nil then 867 ADynHashArrayItem^.Next^.Prior:=ADynHashArrayItem; 868 ADynHashArrayItem^.Prior:=nil; 869 inc(FFreeCount); 870 // reduce free list 871 if (FFreeCount>(((8+FMaxFreeRatio)*FCount) shr 3)) and (FFreeCount>10) then 872 begin 873 DisposeFirstFreeItem; 874 DisposeFirstFreeItem; 875 end; 876end; 877 878function TDynHashArrayItemMemManager.NewItem: PDynHashArrayItem; 879begin 880 if FFirstFree<>nil then begin 881 Result:=FFirstFree; 882 FFirstFree:=FFirstFree^.Next; 883 if FFirstFree<>nil then 884 FFirstFree^.Prior:=nil; 885 dec(FFreeCount); 886 end else begin 887 New(Result); 888 end; 889 with Result^ do begin 890 Item:=nil; 891 Next:=nil; 892 Prior:=nil; 893 IsOverflow:=false; 894 end; 895end; 896 897procedure TDynHashArrayItemMemManager.Clear; 898begin 899 while FFreeCount>0 do DisposeFirstFreeItem; 900end; 901 902constructor TDynHashArrayItemMemManager.Create; 903begin 904 inherited Create; 905 FFirstFree:=nil; 906 FFreeCount:=0; 907 FCount:=0; 908 FMinFree:=100; 909 FMaxFreeRatio:=8; // 1:1 910end; 911 912destructor TDynHashArrayItemMemManager.Destroy; 913begin 914 Clear; 915 inherited Destroy; 916end; 917 918function TDynHashArrayItemMemManager.ConsistencyCheck: integer; 919var RealFreeCount: integer; 920 HashItem: PDynHashArrayItem; 921begin 922 RealFreeCount:=0; 923 HashItem:=FFirstFree; 924 while HashItem<>nil do begin 925 inc(RealFreeCount); 926 if (HashItem^.Next<>nil) and (HashItem^.Next^.Prior<>HashItem) then 927 exit(-1); 928 if (HashItem^.Prior<>nil) and (HashItem^.Prior^.Next<>HashItem) then 929 exit(-2); 930 HashItem:=HashItem^.Next; 931 end; 932 if RealFreeCount<>FFreeCount then exit(-3); 933 Result:=0; 934end; 935 936procedure TDynHashArrayItemMemManager.WriteDebugReport; 937begin 938 DebugLn('TDynHashArrayItemMemManager.WriteDebugReport:' 939 ,' Consistency=',dbgs(ConsistencyCheck),', FreeCount=',dbgs(FFreeCount)); 940end; 941 942//============================================================================== 943 944finalization 945 FreeAndNil(ItemMemManager); 946 947end. 948