avl_tree.pp 41 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556
  1. { **********************************************************************
  2. This file is part of the Free Component Library (FCL)
  3. Copyright (c) 2008 by Mattias Gaertner
  4. Average Level Tree implementation by Mattias Gaertner
  5. See the file COPYING.FPC, included in this distribution,
  6. for details about the copyright.
  7. This program is distributed in the hope that it will be useful,
  8. but WITHOUT ANY WARRANTY; without even the implied warranty of
  9. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  10. **********************************************************************
  11. Author: Mattias Gaertner
  12. Abstract:
  13. TAVLTree is an Average Level binary Tree. This binary tree is always
  14. balanced, so that inserting, deleting and finding a node is performed in
  15. O(log(#Nodes)).
  16. }
  17. unit AVL_Tree;
  18. {$ifdef FPC}{$mode objfpc}{$endif}{$H+}
  19. interface
  20. {off $DEFINE MEM_CHECK}
  21. {off $DEFINE CheckAVLTreeNodeManager}
  22. uses
  23. {$IFDEF MEM_CHECK}MemCheck,{$ENDIF}
  24. Classes, SysUtils;
  25. type
  26. TAVLTree = class;
  27. TObjectSortCompare = function(Tree: TAVLTree; Data1, Data2: Pointer): integer of object;
  28. { TAVLTreeNode }
  29. TAVLTreeNode = class
  30. public
  31. Parent, Left, Right: TAVLTreeNode;
  32. Balance: integer; // = RightDepth-LeftDepth -2..+2, after balancing: -1,0,+1
  33. Data: Pointer;
  34. function Successor: TAVLTreeNode; // next right
  35. function Precessor: TAVLTreeNode; // next left
  36. procedure Clear;
  37. function TreeDepth: integer; // longest WAY down. e.g. only one node => 0 !
  38. procedure ConsistencyCheck(Tree: TAVLTree); virtual;
  39. function GetCount: SizeInt;
  40. end;
  41. TAVLTreeNodeClass = class of TAVLTreeNode;
  42. PAVLTreeNode = ^TAVLTreeNode;
  43. { TBaseAVLTreeNodeManager }
  44. TBaseAVLTreeNodeManager = class
  45. public
  46. procedure DisposeNode(ANode: TAVLTreeNode); virtual; abstract;
  47. function NewNode: TAVLTreeNode; virtual; abstract;
  48. end;
  49. { TAVLTreeNodeEnumerator }
  50. TAVLTreeNodeEnumerator = class
  51. protected
  52. FCurrent: TAVLTreeNode;
  53. FLowToHigh: boolean;
  54. FTree: TAVLTree;
  55. public
  56. constructor Create(Tree: TAVLTree; aLowToHigh: boolean = true);
  57. function GetEnumerator: TAVLTreeNodeEnumerator; inline;
  58. function MoveNext: Boolean;
  59. property Current: TAVLTreeNode read FCurrent;
  60. property LowToHigh: boolean read FLowToHigh;
  61. end;
  62. TAVLTree = class
  63. protected
  64. FCount: SizeInt;
  65. FNodeClass: TAVLTreeNodeClass;
  66. fNodeMgr: TBaseAVLTreeNodeManager;
  67. fNodeMgrAutoFree: boolean;
  68. FOnCompare: TListSortCompare;
  69. FOnObjectCompare: TObjectSortCompare;
  70. FRoot: TAVLTreeNode;
  71. procedure BalanceAfterInsert(ANode: TAVLTreeNode);
  72. procedure BalanceAfterDelete(ANode: TAVLTreeNode);
  73. procedure DeletingNode({%H-}aNode: TAVLTreeNode); virtual;
  74. function FindInsertPos(Data: Pointer): TAVLTreeNode;
  75. procedure Init; virtual;
  76. procedure NodeAdded({%H-}aNode: TAVLTreeNode); virtual;
  77. procedure RotateLeft(aNode: TAVLTreeNode); virtual;
  78. procedure RotateRight(aNode: TAVLTreeNode); virtual;
  79. procedure SwitchPositionWithSuccessor(aNode, aSuccessor: TAVLTreeNode); virtual;
  80. procedure SetOnCompare(const AValue: TListSortCompare);
  81. procedure SetOnObjectCompare(const AValue: TObjectSortCompare);
  82. procedure SetCompares(const NewCompare: TListSortCompare;
  83. const NewObjectCompare: TObjectSortCompare);
  84. procedure SetNodeClass(const AValue: TAVLTreeNodeClass);
  85. public
  86. constructor Create(const OnCompareMethod: TListSortCompare);
  87. constructor CreateObjectCompare(const OnCompareMethod: TObjectSortCompare);
  88. constructor Create;
  89. destructor Destroy; override;
  90. property OnCompare: TListSortCompare read FOnCompare write SetOnCompare;
  91. property OnObjectCompare: TObjectSortCompare read FOnObjectCompare write SetOnObjectCompare;
  92. property NodeClass: TAVLTreeNodeClass read FNodeClass write SetNodeClass; // used for new nodes
  93. procedure SetNodeManager(NewMgr: TBaseAVLTreeNodeManager;
  94. AutoFree: boolean = false);
  95. function NewNode: TAVLTreeNode; virtual; // create a node outside the tree
  96. procedure DisposeNode(ANode: TAVLTreeNode); virtual; // free the node outside the tree
  97. // add, delete, remove, move
  98. procedure Add(ANode: TAVLTreeNode);
  99. function Add(Data: Pointer): TAVLTreeNode;
  100. function AddAscendingSequence(Data: Pointer; LastAdded: TAVLTreeNode;
  101. var Successor: TAVLTreeNode): TAVLTreeNode;
  102. procedure Delete(ANode: TAVLTreeNode);
  103. function Remove(Data: Pointer): boolean;
  104. function RemovePointer(Data: Pointer): boolean;
  105. procedure MoveDataLeftMost(var ANode: TAVLTreeNode);
  106. procedure MoveDataRightMost(var ANode: TAVLTreeNode);
  107. procedure Clear;
  108. procedure FreeAndClear;
  109. procedure FreeAndDelete(ANode: TAVLTreeNode); virtual;
  110. function Equals(Obj: TObject): boolean; override; // same as IsEqual(aTree,false)
  111. function IsEqual(aTree: TAVLTree; CheckDataPointer: boolean): boolean; // checks only keys or Data (references), not the data itself, O(n)
  112. procedure Assign(aTree: TAVLTree); virtual; // clear and copy all Data (references), O(n)
  113. // search
  114. property Root: TAVLTreeNode read fRoot;
  115. property Count: SizeInt read FCount;
  116. function Compare(Data1, Data2: Pointer): integer;
  117. function Find(Data: Pointer): TAVLTreeNode; // O(log(n))
  118. function FindKey(Key: Pointer;
  119. const OnCompareKeyWithData: TListSortCompare): TAVLTreeNode; // O(log(n))
  120. function FindNearestKey(Key: Pointer;
  121. const OnCompareKeyWithData: TListSortCompare): TAVLTreeNode; // O(log(n))
  122. function FindSuccessor(ANode: TAVLTreeNode): TAVLTreeNode; inline;
  123. function FindPrecessor(ANode: TAVLTreeNode): TAVLTreeNode; inline;
  124. function FindLowest: TAVLTreeNode; // O(log(n))
  125. function FindHighest: TAVLTreeNode; // O(log(n))
  126. function FindNearest(Data: Pointer): TAVLTreeNode;
  127. // search in a tree with duplicates (duplicate means here: Compare function returns 0)
  128. function FindPointer(Data: Pointer): TAVLTreeNode;
  129. function FindLeftMost(Data: Pointer): TAVLTreeNode;
  130. function FindRightMost(Data: Pointer): TAVLTreeNode;
  131. function FindLeftMostKey(Key: Pointer;
  132. const OnCompareKeyWithData: TListSortCompare): TAVLTreeNode;
  133. function FindRightMostKey(Key: Pointer;
  134. const OnCompareKeyWithData: TListSortCompare): TAVLTreeNode;
  135. function FindLeftMostSameKey(ANode: TAVLTreeNode): TAVLTreeNode;
  136. function FindRightMostSameKey(ANode: TAVLTreeNode): TAVLTreeNode;
  137. // enumerators
  138. function GetEnumerator: TAVLTreeNodeEnumerator;
  139. function GetEnumeratorHighToLow: TAVLTreeNodeEnumerator;
  140. // consistency
  141. procedure ConsistencyCheck; virtual; // JuMa: changed to procedure and added "virtual".
  142. procedure WriteReportToStream(s: TStream);
  143. function NodeToReportStr(aNode: TAVLTreeNode): string; virtual;
  144. function ReportAsString: string;
  145. end;
  146. TAVLTreeClass = class of TAVLTree;
  147. { TAVLTreeNodeMemManager }
  148. TAVLTreeNodeMemManager = class(TBaseAVLTreeNodeManager)
  149. private
  150. FFirstFree: TAVLTreeNode;
  151. FFreeCount: SizeInt;
  152. FCount: SizeInt;
  153. FMinFree: SizeInt;
  154. FMaxFreeRatio: SizeInt;
  155. {$IFDEF CheckAVLTreeNodeManager}
  156. FThreadId: TThreadID;
  157. {$ENDIF}
  158. procedure SetMaxFreeRatio(NewValue: SizeInt);
  159. procedure SetMinFree(NewValue: SizeInt);
  160. procedure DisposeFirstFreeNode;
  161. public
  162. procedure DisposeNode(ANode: TAVLTreeNode); override;
  163. function NewNode: TAVLTreeNode; override;
  164. property MinimumFreeNode: SizeInt read FMinFree write SetMinFree;
  165. property MaximumFreeNodeRatio: SizeInt
  166. read FMaxFreeRatio write SetMaxFreeRatio; // in one eighth steps
  167. property Count: SizeInt read FCount;
  168. procedure Clear;
  169. constructor Create;
  170. destructor Destroy; override;
  171. end;
  172. var
  173. NodeMemManager: TAVLTreeNodeMemManager;
  174. implementation
  175. function ComparePointer(Data1, Data2: Pointer): integer;
  176. begin
  177. if Data1>Data2 then Result:=-1
  178. else if Data1<Data2 then Result:=1
  179. else Result:=0;
  180. end;
  181. { TAVLTreeNodeEnumerator }
  182. constructor TAVLTreeNodeEnumerator.Create(Tree: TAVLTree; aLowToHigh: boolean);
  183. begin
  184. FTree:=Tree;
  185. FLowToHigh:=aLowToHigh;
  186. end;
  187. function TAVLTreeNodeEnumerator.GetEnumerator: TAVLTreeNodeEnumerator;
  188. begin
  189. Result:=Self;
  190. end;
  191. function TAVLTreeNodeEnumerator.MoveNext: Boolean;
  192. begin
  193. if FLowToHigh then begin
  194. if FCurrent<>nil then
  195. FCurrent:=FCurrent.Successor
  196. else
  197. FCurrent:=FTree.FindLowest;
  198. end else begin
  199. if FCurrent<>nil then
  200. FCurrent:=FCurrent.Precessor
  201. else
  202. FCurrent:=FTree.FindHighest;
  203. end;
  204. Result:=FCurrent<>nil;
  205. end;
  206. { TAVLTree }
  207. function TAVLTree.Add(Data: Pointer): TAVLTreeNode;
  208. begin
  209. Result:=NewNode;
  210. Result.Data:=Data;
  211. Add(Result);
  212. end;
  213. function TAVLTree.AddAscendingSequence(Data: Pointer; LastAdded: TAVLTreeNode;
  214. var Successor: TAVLTreeNode): TAVLTreeNode;
  215. { This is an optimized version of "Add" for adding an ascending sequence of
  216. nodes.
  217. It uses the LastAdded and Successor to skip searching for an insert position.
  218. For nodes with same value the order of the sequence is kept.
  219. Usage:
  220. LastNode:=nil; // TAvlTreeNode
  221. Successor:=nil; // TAvlTreeNode
  222. for i:=1 to 1000 do
  223. LastNode:=Tree.AddAscendingSequence(TItem.Create(i),LastNode,Successor);
  224. }
  225. var
  226. InsertPos: TAVLTreeNode;
  227. begin
  228. Result:=NewNode;
  229. Result.Data:=Data;
  230. if (LastAdded<>nil) and (Compare(LastAdded.Data,Data)<=0)
  231. and ((Successor=nil) or (Compare(Data,Successor.Data)<=0)) then begin
  232. // Data is between LastAdded and Successor
  233. inc(FCount);
  234. if LastAdded.Right=nil then begin
  235. Result.Parent:=LastAdded;
  236. LastAdded.Right:=Result;
  237. end else begin
  238. InsertPos:=LastAdded.Right;
  239. while InsertPos.Left<>nil do
  240. InsertPos:=InsertPos.Left;
  241. Result.Parent:=InsertPos;
  242. InsertPos.Left:=Result;
  243. end;
  244. NodeAdded(Result);
  245. BalanceAfterInsert(Result);
  246. end else begin
  247. // normal Add
  248. Add(Result);
  249. Successor:=Result.Successor;
  250. end;
  251. end;
  252. function TAVLTree.NewNode: TAVLTreeNode;
  253. begin
  254. if fNodeMgr<>nil then
  255. Result:=fNodeMgr.NewNode
  256. else
  257. Result:=NodeClass.Create;
  258. end;
  259. procedure TAVLTree.DisposeNode(ANode: TAVLTreeNode);
  260. begin
  261. if fNodeMgr<>nil then
  262. fNodeMgr.DisposeNode(ANode)
  263. else
  264. ANode.Free;
  265. end;
  266. procedure TAVLTree.Add(ANode: TAVLTreeNode);
  267. // add a node. If there are already nodes with the same value it will be
  268. // inserted rightmost
  269. var InsertPos: TAVLTreeNode;
  270. InsertComp: integer;
  271. begin
  272. ANode.Left:=nil;
  273. ANode.Right:=nil;
  274. inc(FCount);
  275. if Root<>nil then begin
  276. InsertPos:=FindInsertPos(ANode.Data);
  277. InsertComp:=Compare(ANode.Data,InsertPos.Data);
  278. ANode.Parent:=InsertPos;
  279. if InsertComp<0 then begin
  280. // insert to the left
  281. InsertPos.Left:=ANode;
  282. end else begin
  283. // insert to the right
  284. InsertPos.Right:=ANode;
  285. end;
  286. NodeAdded(ANode);
  287. BalanceAfterInsert(ANode);
  288. end else begin
  289. fRoot:=ANode;
  290. ANode.Parent:=nil;
  291. NodeAdded(ANode);
  292. end;
  293. end;
  294. function TAVLTree.FindLowest: TAVLTreeNode;
  295. begin
  296. Result:=Root;
  297. if Result<>nil then
  298. while Result.Left<>nil do Result:=Result.Left;
  299. end;
  300. function TAVLTree.FindHighest: TAVLTreeNode;
  301. begin
  302. Result:=Root;
  303. if Result<>nil then
  304. while Result.Right<>nil do Result:=Result.Right;
  305. end;
  306. procedure TAVLTree.BalanceAfterDelete(ANode: TAVLTreeNode);
  307. var
  308. OldParent, OldRight, OldRightLeft, OldLeft, OldLeftRight: TAVLTreeNode;
  309. begin
  310. while ANode<>nil do begin
  311. if ((ANode.Balance=+1) or (ANode.Balance=-1)) then exit;
  312. OldParent:=ANode.Parent;
  313. if (ANode.Balance=0) then begin
  314. // Treeheight has decreased by one
  315. if (OldParent=nil) then
  316. exit;
  317. if(OldParent.Left=ANode) then
  318. Inc(OldParent.Balance)
  319. else
  320. Dec(OldParent.Balance);
  321. ANode:=OldParent;
  322. end else if (ANode.Balance=+2) then begin
  323. // Node is overweighted to the right
  324. OldRight:=ANode.Right;
  325. if (OldRight.Balance>=0) then begin
  326. // OldRight.Balance is 0 or -1
  327. // rotate ANode,OldRight left
  328. RotateLeft(ANode);
  329. ANode.Balance:=(1-OldRight.Balance); // toggle 0 and 1
  330. Dec(OldRight.Balance);
  331. ANode:=OldRight;
  332. end else begin
  333. // OldRight.Balance=-1
  334. { double rotate
  335. = rotate OldRightLeft,OldRight right
  336. and then rotate ANode,OldRightLeft left
  337. OldParent OldParent
  338. | |
  339. ANode OldRightLeft
  340. \ / \
  341. OldRight => ANode OldRight
  342. / \ /
  343. OldRightLeft OldRightLeftLeft OldRightLeftRight
  344. / \
  345. OldRightLeftLeft OldRightLeftRight
  346. }
  347. OldRightLeft:=OldRight.Left;
  348. RotateRight(OldRight);
  349. RotateLeft(ANode);
  350. if (OldRightLeft.Balance<=0) then
  351. ANode.Balance:=0
  352. else
  353. ANode.Balance:=-1;
  354. if (OldRightLeft.Balance>=0) then
  355. OldRight.Balance:=0
  356. else
  357. OldRight.Balance:=+1;
  358. OldRightLeft.Balance:=0;
  359. ANode:=OldRightLeft;
  360. end;
  361. end else begin
  362. // Node.Balance=-2
  363. // Node is overweighted to the left
  364. OldLeft:=ANode.Left;
  365. if (OldLeft.Balance<=0) then begin
  366. // rotate OldLeft,ANode right
  367. RotateRight(ANode);
  368. ANode.Balance:=(-1-OldLeft.Balance); // toggle 0 and -1
  369. Inc(OldLeft.Balance);
  370. ANode:=OldLeft;
  371. end else begin
  372. // OldLeft.Balance = 1
  373. { double rotate left right
  374. = rotate OldLeft,OldLeftRight left
  375. and then rotate OldLeft,ANode right
  376. OldParent OldParent
  377. | |
  378. ANode OldLeftRight
  379. / / \
  380. OldLeft => OldLeft ANode
  381. \ \ /
  382. OldLeftRight OldLeftRightLeft OldLeftRightRight
  383. / \
  384. OldLeftRightLeft OldLeftRightRight
  385. }
  386. OldLeftRight:=OldLeft.Right;
  387. RotateLeft(OldLeft);
  388. RotateRight(ANode);
  389. if (OldLeftRight.Balance>=0) then
  390. ANode.Balance:=0
  391. else
  392. ANode.Balance:=+1;
  393. if (OldLeftRight.Balance<=0) then
  394. OldLeft.Balance:=0
  395. else
  396. OldLeft.Balance:=-1;
  397. OldLeftRight.Balance:=0;
  398. ANode:=OldLeftRight;
  399. end;
  400. end;
  401. end;
  402. end;
  403. procedure TAVLTree.DeletingNode(aNode: TAVLTreeNode);
  404. // called by Delete
  405. // Node.Left=nil or Node.Right=nil
  406. begin
  407. // for descendants to override
  408. end;
  409. procedure TAVLTree.SetOnObjectCompare(const AValue: TObjectSortCompare);
  410. begin
  411. if AValue=nil then
  412. SetCompares(FOnCompare,nil)
  413. else
  414. SetCompares(nil,AValue);
  415. end;
  416. procedure TAVLTree.SetCompares(const NewCompare: TListSortCompare;
  417. const NewObjectCompare: TObjectSortCompare);
  418. var List: PPointer;
  419. ANode: TAVLTreeNode;
  420. i, OldCount: integer;
  421. begin
  422. if (FOnCompare=NewCompare) and (FOnObjectCompare=NewObjectCompare) then exit;
  423. if Count<=1 then begin
  424. FOnCompare:=NewCompare;
  425. FOnObjectCompare:=NewObjectCompare;
  426. exit;
  427. end;
  428. // sort the tree again
  429. OldCount:=Count;
  430. GetMem(List,SizeOf(Pointer)*OldCount);
  431. try
  432. // save the data in a list
  433. ANode:=FindLowest;
  434. i:=0;
  435. while ANode<>nil do begin
  436. List[i]:=ANode.Data;
  437. inc(i);
  438. ANode:=ANode.Successor;
  439. end;
  440. // clear the tree
  441. Clear;
  442. // set the new compare function
  443. FOnCompare:=NewCompare;
  444. FOnObjectCompare:=NewObjectCompare;
  445. // re-add all nodes
  446. for i:=0 to OldCount-1 do
  447. Add(List[i]);
  448. finally
  449. FreeMem(List);
  450. end;
  451. end;
  452. procedure TAVLTree.SetNodeClass(const AValue: TAVLTreeNodeClass);
  453. begin
  454. if FNodeClass=AValue then Exit;
  455. if Count>0 then
  456. raise Exception.Create(ClassName+'.SetNodeClass Count='+IntToStr(Count)
  457. +' Old='+fNodeMgr.ClassName+' New='+AValue.ClassName);
  458. FNodeClass:=AValue;
  459. if fNodeMgr=NodeMemManager then
  460. fNodeMgr:=nil;
  461. end;
  462. procedure TAVLTree.BalanceAfterInsert(ANode: TAVLTreeNode);
  463. var
  464. OldParent, OldRight, OldLeft: TAVLTreeNode;
  465. begin
  466. OldParent:=ANode.Parent;
  467. while (OldParent<>nil) do begin
  468. if (OldParent.Left=ANode) then begin
  469. // Node is left child
  470. dec(OldParent.Balance);
  471. if (OldParent.Balance=0) then exit;
  472. if (OldParent.Balance=-1) then begin
  473. ANode:=OldParent;
  474. OldParent:=ANode.Parent;
  475. continue;
  476. end;
  477. // OldParent.Balance=-2
  478. if (ANode.Balance=-1) then begin
  479. { rotate ANode,ANode.Parent right
  480. OldParentParent OldParentParent
  481. | |
  482. OldParent => ANode
  483. / \
  484. ANode OldParent
  485. \ /
  486. OldRight OldRight }
  487. RotateRight(OldParent);
  488. ANode.Balance:=0;
  489. OldParent.Balance:=0;
  490. end else begin
  491. // Node.Balance = +1
  492. { double rotate
  493. = rotate ANode,OldRight left and then rotate OldRight,OldParent right
  494. OldParentParent OldParentParent
  495. | |
  496. OldParent OldRight
  497. / => / \
  498. ANode ANode OldParent
  499. \ \ /
  500. OldRight OldRightLeft OldRightRight
  501. / \
  502. OldRightLeft OldRightRight
  503. }
  504. OldRight:=ANode.Right;
  505. RotateLeft(ANode);
  506. RotateRight(OldParent);
  507. if (OldRight.Balance<=0) then
  508. ANode.Balance:=0
  509. else
  510. ANode.Balance:=-1;
  511. if (OldRight.Balance=-1) then
  512. OldParent.Balance:=1
  513. else
  514. OldParent.Balance:=0;
  515. OldRight.Balance:=0;
  516. end;
  517. exit;
  518. end else begin
  519. // Node is right child
  520. Inc(OldParent.Balance);
  521. if (OldParent.Balance=0) then exit;
  522. if (OldParent.Balance=+1) then begin
  523. ANode:=OldParent;
  524. OldParent:=ANode.Parent;
  525. continue;
  526. end;
  527. // OldParent.Balance = +2
  528. if(ANode.Balance=+1) then begin
  529. { rotate OldParent,ANode left
  530. OldParentParent OldParentParent
  531. | |
  532. OldParent => ANode
  533. \ /
  534. ANode OldParent
  535. / \
  536. OldLeft OldLeft }
  537. RotateLeft(OldParent);
  538. ANode.Balance:=0;
  539. OldParent.Balance:=0;
  540. end else begin
  541. // Node.Balance = -1
  542. { double rotate
  543. = rotate OldLeft,ANode right and then rotate OldParent,OldLeft right
  544. OldParentParent OldParentParent
  545. | |
  546. OldParent OldLeft
  547. \ => / \
  548. ANode OldParent ANode
  549. / \ /
  550. OldLeft OldLeftLeft OldLeftRight
  551. / \
  552. OldLeftLeft OldLeftRight
  553. }
  554. OldLeft:=ANode.Left;
  555. RotateRight(ANode);
  556. RotateLeft(OldParent);
  557. if (OldLeft.Balance>=0) then
  558. ANode.Balance:=0
  559. else
  560. ANode.Balance:=+1;
  561. if (OldLeft.Balance=+1) then
  562. OldParent.Balance:=-1
  563. else
  564. OldParent.Balance:=0;
  565. OldLeft.Balance:=0;
  566. end;
  567. exit;
  568. end;
  569. end;
  570. end;
  571. procedure TAVLTree.Clear;
  572. procedure DeleteNode(ANode: TAVLTreeNode);
  573. begin
  574. if ANode<>nil then begin
  575. if ANode.Left<>nil then DeleteNode(ANode.Left);
  576. if ANode.Right<>nil then DeleteNode(ANode.Right);
  577. end;
  578. DisposeNode(ANode);
  579. end;
  580. // Clear
  581. begin
  582. DeleteNode(Root);
  583. fRoot:=nil;
  584. FCount:=0;
  585. end;
  586. constructor TAVLTree.Create(const OnCompareMethod: TListSortCompare);
  587. begin
  588. fNodeMgr:=NodeMemManager;
  589. FOnCompare:=OnCompareMethod;
  590. Init;
  591. end;
  592. constructor TAVLTree.CreateObjectCompare(
  593. const OnCompareMethod: TObjectSortCompare);
  594. begin
  595. fNodeMgr:=NodeMemManager;
  596. FOnObjectCompare:=OnCompareMethod;
  597. Init;
  598. end;
  599. constructor TAVLTree.Create;
  600. begin
  601. Create(@ComparePointer);
  602. end;
  603. procedure TAVLTree.Delete(ANode: TAVLTreeNode);
  604. var
  605. OldParent, Child: TAVLTreeNode;
  606. begin
  607. {$IFDEF CheckAVLTreeNodeManager}
  608. OldParent:=ANode;
  609. while OldParent.Parent<>nil do OldParent:=OldParent.Parent;
  610. if OldParent<>Root then
  611. raise Exception.Create('TAVLTree.Delete'); // not my node
  612. {$ENDIF}
  613. if (ANode.Left<>nil) and (ANode.Right<>nil) then begin
  614. // ANode has both: Left and Right
  615. // Switch ANode position with Successor
  616. // Because ANode.Right<>nil the Successor is a child of ANode
  617. SwitchPositionWithSuccessor(ANode,ANode.Successor);
  618. end;
  619. // left or right is nil
  620. DeletingNode(aNode);
  621. OldParent:=ANode.Parent;
  622. ANode.Parent:=nil;
  623. if ANode.Left<>nil then
  624. Child:=ANode.Left
  625. else
  626. Child:=ANode.Right;
  627. if Child<>nil then
  628. Child.Parent:=OldParent;
  629. if (OldParent<>nil) then begin
  630. // Node has parent
  631. if (OldParent.Left=ANode) then begin
  632. // Node is left child of OldParent
  633. OldParent.Left:=Child;
  634. Inc(OldParent.Balance);
  635. end else begin
  636. // Node is right child of OldParent
  637. OldParent.Right:=Child;
  638. Dec(OldParent.Balance);
  639. end;
  640. BalanceAfterDelete(OldParent);
  641. end else begin
  642. // Node was Root
  643. fRoot:=Child;
  644. end;
  645. dec(FCount);
  646. DisposeNode(ANode);
  647. end;
  648. function TAVLTree.Remove(Data: Pointer): boolean;
  649. var
  650. ANode: TAvlTreeNode;
  651. begin
  652. ANode:=Find(Data);
  653. if ANode<>nil then begin
  654. Delete(ANode);
  655. Result:=true;
  656. end else
  657. Result:=false;
  658. end;
  659. function TAVLTree.RemovePointer(Data: Pointer): boolean;
  660. var
  661. ANode: TAvlTreeNode;
  662. begin
  663. ANode:=FindPointer(Data);
  664. if ANode<>nil then begin
  665. Delete(ANode);
  666. Result:=true;
  667. end else
  668. Result:=false;
  669. end;
  670. destructor TAVLTree.Destroy;
  671. begin
  672. Clear;
  673. if fNodeMgrAutoFree then
  674. FreeAndNil(fNodeMgr);
  675. inherited Destroy;
  676. end;
  677. function TAVLTree.GetEnumerator: TAVLTreeNodeEnumerator;
  678. begin
  679. Result:=TAVLTreeNodeEnumerator.Create(Self,true);
  680. end;
  681. function TAVLTree.GetEnumeratorHighToLow: TAVLTreeNodeEnumerator;
  682. begin
  683. Result:=TAVLTreeNodeEnumerator.Create(Self,false);
  684. end;
  685. function TAVLTree.Find(Data: Pointer): TAVLTreeNode;
  686. var Comp: integer;
  687. begin
  688. Result:=Root;
  689. while (Result<>nil) do begin
  690. Comp:=Compare(Data,Result.Data);
  691. if Comp=0 then exit;
  692. if Comp<0 then begin
  693. Result:=Result.Left
  694. end else begin
  695. Result:=Result.Right
  696. end;
  697. end;
  698. end;
  699. function TAVLTree.FindKey(Key: Pointer; const OnCompareKeyWithData: TListSortCompare
  700. ): TAVLTreeNode;
  701. var Comp: integer;
  702. begin
  703. Result:=Root;
  704. while (Result<>nil) do begin
  705. Comp:=OnCompareKeyWithData(Key,Result.Data);
  706. if Comp=0 then exit;
  707. if Comp<0 then begin
  708. Result:=Result.Left
  709. end else begin
  710. Result:=Result.Right
  711. end;
  712. end;
  713. end;
  714. function TAVLTree.FindNearestKey(Key: Pointer;
  715. const OnCompareKeyWithData: TListSortCompare): TAVLTreeNode;
  716. var Comp: integer;
  717. begin
  718. Result:=fRoot;
  719. while (Result<>nil) do begin
  720. Comp:=OnCompareKeyWithData(Key,Result.Data);
  721. if Comp=0 then exit;
  722. if Comp<0 then begin
  723. if Result.Left<>nil then
  724. Result:=Result.Left
  725. else
  726. exit;
  727. end else begin
  728. if Result.Right<>nil then
  729. Result:=Result.Right
  730. else
  731. exit;
  732. end;
  733. end;
  734. end;
  735. function TAVLTree.FindLeftMostKey(Key: Pointer;
  736. const OnCompareKeyWithData: TListSortCompare): TAVLTreeNode;
  737. var
  738. LeftNode: TAVLTreeNode;
  739. begin
  740. Result:=FindKey(Key,OnCompareKeyWithData);
  741. if Result=nil then exit;
  742. repeat
  743. LeftNode:=Result.Precessor;
  744. if (LeftNode=nil) or (OnCompareKeyWithData(Key,LeftNode.Data)<>0) then exit;
  745. Result:=LeftNode;
  746. until false;
  747. end;
  748. function TAVLTree.FindRightMostKey(Key: Pointer;
  749. const OnCompareKeyWithData: TListSortCompare): TAVLTreeNode;
  750. var
  751. RightNode: TAVLTreeNode;
  752. begin
  753. Result:=FindKey(Key,OnCompareKeyWithData);
  754. if Result=nil then exit;
  755. repeat
  756. RightNode:=Result.Successor;
  757. if (RightNode=nil) or (OnCompareKeyWithData(Key,RightNode.Data)<>0) then exit;
  758. Result:=RightNode;
  759. until false;
  760. end;
  761. function TAVLTree.FindLeftMostSameKey(ANode: TAVLTreeNode): TAVLTreeNode;
  762. var
  763. LeftNode: TAVLTreeNode;
  764. Data: Pointer;
  765. begin
  766. if ANode<>nil then begin
  767. Data:=ANode.Data;
  768. Result:=ANode;
  769. repeat
  770. LeftNode:=Result.Precessor;
  771. if (LeftNode=nil) or (Compare(Data,LeftNode.Data)<>0) then break;
  772. Result:=LeftNode;
  773. until false;
  774. end else begin
  775. Result:=nil;
  776. end;
  777. end;
  778. function TAVLTree.FindRightMostSameKey(ANode: TAVLTreeNode): TAVLTreeNode;
  779. var
  780. RightNode: TAVLTreeNode;
  781. Data: Pointer;
  782. begin
  783. if ANode<>nil then begin
  784. Data:=ANode.Data;
  785. Result:=ANode;
  786. repeat
  787. RightNode:=Result.Successor;
  788. if (RightNode=nil) or (Compare(Data,RightNode.Data)<>0) then break;
  789. Result:=RightNode;
  790. until false;
  791. end else begin
  792. Result:=nil;
  793. end;
  794. end;
  795. function TAVLTree.FindNearest(Data: Pointer): TAVLTreeNode;
  796. var Comp: integer;
  797. begin
  798. Result:=Root;
  799. while (Result<>nil) do begin
  800. Comp:=Compare(Data,Result.Data);
  801. if Comp=0 then exit;
  802. if Comp<0 then begin
  803. if Result.Left<>nil then
  804. Result:=Result.Left
  805. else
  806. exit;
  807. end else begin
  808. if Result.Right<>nil then
  809. Result:=Result.Right
  810. else
  811. exit;
  812. end;
  813. end;
  814. end;
  815. function TAVLTree.FindPointer(Data: Pointer): TAVLTreeNode;
  816. // same as Find, but not comparing for key, but same Data too
  817. begin
  818. Result:=FindLeftMost(Data);
  819. while (Result<>nil) do begin
  820. if Result.Data=Data then break;
  821. Result:=Result.Successor;
  822. if Result=nil then exit;
  823. if Compare(Data,Result.Data)<>0 then exit(nil);
  824. end;
  825. end;
  826. function TAVLTree.FindLeftMost(Data: Pointer): TAVLTreeNode;
  827. var
  828. Left: TAVLTreeNode;
  829. begin
  830. Result:=Find(Data);
  831. while (Result<>nil) do begin
  832. Left:=Result.Precessor;
  833. if (Left=nil) or (Compare(Data,Left.Data)<>0) then break;
  834. Result:=Left;
  835. end;
  836. end;
  837. function TAVLTree.FindRightMost(Data: Pointer): TAVLTreeNode;
  838. var
  839. Right: TAVLTreeNode;
  840. begin
  841. Result:=Find(Data);
  842. while (Result<>nil) do begin
  843. Right:=Result.Successor;
  844. if (Right=nil) or (Compare(Data,Right.Data)<>0) then break;
  845. Result:=Right;
  846. end;
  847. end;
  848. function TAVLTree.FindInsertPos(Data: Pointer): TAVLTreeNode;
  849. var Comp: integer;
  850. begin
  851. Result:=Root;
  852. while (Result<>nil) do begin
  853. Comp:=Compare(Data,Result.Data);
  854. if Comp<0 then begin
  855. if Result.Left<>nil then
  856. Result:=Result.Left
  857. else
  858. exit;
  859. end else begin
  860. if Result.Right<>nil then
  861. Result:=Result.Right
  862. else
  863. exit;
  864. end;
  865. end;
  866. end;
  867. procedure TAVLTree.Init;
  868. begin
  869. FNodeClass:=TAVLTreeNode;
  870. end;
  871. procedure TAVLTree.NodeAdded(aNode: TAVLTreeNode);
  872. begin
  873. // for descendants to override
  874. end;
  875. procedure TAVLTree.RotateLeft(aNode: TAVLTreeNode);
  876. { Parent Parent
  877. | |
  878. Node => OldRight
  879. / \ /
  880. Left OldRight Node
  881. / / \
  882. OldRightLeft Left OldRightLeft }
  883. var
  884. AParent, OldRight, OldRightLeft: TAVLTreeNode;
  885. begin
  886. OldRight:=aNode.Right;
  887. OldRightLeft:=OldRight.Left;
  888. AParent:=aNode.Parent;
  889. if AParent<>nil then begin
  890. if AParent.Left=aNode then
  891. AParent.Left:=OldRight
  892. else
  893. AParent.Right:=OldRight;
  894. end else
  895. fRoot:=OldRight;
  896. OldRight.Parent:=AParent;
  897. aNode.Parent:=OldRight;
  898. aNode.Right:=OldRightLeft;
  899. if OldRightLeft<>nil then
  900. OldRightLeft.Parent:=aNode;
  901. OldRight.Left:=aNode;
  902. end;
  903. procedure TAVLTree.RotateRight(aNode: TAVLTreeNode);
  904. { Parent Parent
  905. | |
  906. Node => OldLeft
  907. / \ \
  908. OldLeft Right Node
  909. \ / \
  910. OldLeftRight OldLeftRight Right }
  911. var
  912. AParent, OldLeft, OldLeftRight: TAVLTreeNode;
  913. begin
  914. OldLeft:=aNode.Left;
  915. OldLeftRight:=OldLeft.Right;
  916. AParent:=aNode.Parent;
  917. if AParent<>nil then begin
  918. if AParent.Left=aNode then
  919. AParent.Left:=OldLeft
  920. else
  921. AParent.Right:=OldLeft;
  922. end else
  923. fRoot:=OldLeft;
  924. OldLeft.Parent:=AParent;
  925. aNode.Parent:=OldLeft;
  926. aNode.Left:=OldLeftRight;
  927. if OldLeftRight<>nil then
  928. OldLeftRight.Parent:=aNode;
  929. OldLeft.Right:=aNode;
  930. end;
  931. procedure TAVLTree.SwitchPositionWithSuccessor(aNode, aSuccessor: TAVLTreeNode);
  932. { called by delete, when aNode.Left<>nil and aNode.Right<>nil
  933. Switch ANode position with Successor
  934. Because ANode.Right<>nil the Successor is a child of ANode }
  935. var
  936. OldBalance: Integer;
  937. OldParent, OldLeft, OldRight,
  938. OldSuccParent, OldSuccLeft, OldSuccRight: TAVLTreeNode;
  939. begin
  940. OldBalance:=aNode.Balance;
  941. aNode.Balance:=aSuccessor.Balance;
  942. aSuccessor.Balance:=OldBalance;
  943. OldParent:=aNode.Parent;
  944. OldLeft:=aNode.Left;
  945. OldRight:=aNode.Right;
  946. OldSuccParent:=aSuccessor.Parent;
  947. OldSuccLeft:=aSuccessor.Left;
  948. OldSuccRight:=aSuccessor.Right;
  949. if OldParent<>nil then begin
  950. if OldParent.Left=aNode then
  951. OldParent.Left:=aSuccessor
  952. else
  953. OldParent.Right:=aSuccessor;
  954. end else
  955. fRoot:=aSuccessor;
  956. aSuccessor.Parent:=OldParent;
  957. if OldSuccParent<>aNode then begin
  958. if OldSuccParent.Left=aSuccessor then
  959. OldSuccParent.Left:=aNode
  960. else
  961. OldSuccParent.Right:=aNode;
  962. aSuccessor.Right:=OldRight;
  963. aNode.Parent:=OldSuccParent;
  964. if OldRight<>nil then
  965. OldRight.Parent:=aSuccessor;
  966. end else begin
  967. { aNode aSuccessor
  968. \ => \
  969. aSuccessor aNode }
  970. aSuccessor.Right:=aNode;
  971. aNode.Parent:=aSuccessor;
  972. end;
  973. aNode.Left:=OldSuccLeft;
  974. if OldSuccLeft<>nil then
  975. OldSuccLeft.Parent:=aNode;
  976. aNode.Right:=OldSuccRight;
  977. if OldSuccRight<>nil then
  978. OldSuccRight.Parent:=aNode;
  979. aSuccessor.Left:=OldLeft;
  980. if OldLeft<>nil then
  981. OldLeft.Parent:=aSuccessor;
  982. end;
  983. function TAVLTree.FindSuccessor(ANode: TAVLTreeNode): TAVLTreeNode;
  984. begin
  985. if ANode<>nil then
  986. Result:=ANode.Successor
  987. else
  988. Result:=nil;
  989. end;
  990. function TAVLTree.FindPrecessor(ANode: TAVLTreeNode): TAVLTreeNode;
  991. begin
  992. if ANode<>nil then
  993. Result:=ANode.Precessor
  994. else
  995. Result:=nil;
  996. end;
  997. procedure TAVLTree.MoveDataLeftMost(var ANode: TAVLTreeNode);
  998. var
  999. LeftMost, PreNode: TAVLTreeNode;
  1000. Data: Pointer;
  1001. begin
  1002. if ANode=nil then exit;
  1003. LeftMost:=ANode;
  1004. repeat
  1005. PreNode:=FindPrecessor(LeftMost);
  1006. if (PreNode=nil) or (Compare(ANode,PreNode)<>0) then break;
  1007. LeftMost:=PreNode;
  1008. until false;
  1009. if LeftMost=ANode then exit;
  1010. Data:=LeftMost.Data;
  1011. LeftMost.Data:=ANode.Data;
  1012. ANode.Data:=Data;
  1013. ANode:=LeftMost;
  1014. end;
  1015. procedure TAVLTree.MoveDataRightMost(var ANode: TAVLTreeNode);
  1016. var
  1017. RightMost, PostNode: TAVLTreeNode;
  1018. Data: Pointer;
  1019. begin
  1020. if ANode=nil then exit;
  1021. RightMost:=ANode;
  1022. repeat
  1023. PostNode:=FindSuccessor(RightMost);
  1024. if (PostNode=nil) or (Compare(ANode,PostNode)<>0) then break;
  1025. RightMost:=PostNode;
  1026. until false;
  1027. if RightMost=ANode then exit;
  1028. Data:=RightMost.Data;
  1029. RightMost.Data:=ANode.Data;
  1030. ANode.Data:=Data;
  1031. ANode:=RightMost;
  1032. end;
  1033. procedure TAVLTree.ConsistencyCheck;
  1034. procedure E(Msg: string);
  1035. begin
  1036. raise Exception.Create('TAVLTree.ConsistencyCheck: '+Msg);
  1037. end;
  1038. var
  1039. RealCount: SizeInt;
  1040. begin
  1041. RealCount:=0;
  1042. if FRoot<>nil then begin
  1043. FRoot.ConsistencyCheck(Self);
  1044. RealCount:=FRoot.GetCount;
  1045. end;
  1046. if Count<>RealCount then
  1047. E('Count<>RealCount');
  1048. end;
  1049. procedure TAVLTree.FreeAndClear;
  1050. procedure FreeNodeData(ANode: TAVLTreeNode);
  1051. begin
  1052. if ANode=nil then exit;
  1053. FreeNodeData(ANode.Left);
  1054. FreeNodeData(ANode.Right);
  1055. if ANode.Data<>nil then TObject(ANode.Data).Free;
  1056. ANode.Data:=nil;
  1057. end;
  1058. // TAVLTree.FreeAndClear
  1059. begin
  1060. // free all data
  1061. FreeNodeData(Root);
  1062. // free all nodes
  1063. Clear;
  1064. end;
  1065. procedure TAVLTree.FreeAndDelete(ANode: TAVLTreeNode);
  1066. var OldData: TObject;
  1067. begin
  1068. OldData:=TObject(ANode.Data);
  1069. Delete(ANode);
  1070. OldData.Free;
  1071. end;
  1072. function TAVLTree.Equals(Obj: TObject): boolean;
  1073. begin
  1074. if Obj is TAVLTree then
  1075. Result:=IsEqual(TAVLTree(Obj),false)
  1076. else
  1077. Result:=inherited Equals(Obj);
  1078. end;
  1079. function TAVLTree.IsEqual(aTree: TAVLTree; CheckDataPointer: boolean): boolean;
  1080. var
  1081. MyNode, OtherNode: TAVLTreeNode;
  1082. begin
  1083. if aTree=Self then exit(true);
  1084. Result:=false;
  1085. if aTree=nil then exit;
  1086. if Count<>aTree.Count then exit;
  1087. if OnCompare<>aTree.OnCompare then exit;
  1088. if OnObjectCompare<>aTree.OnObjectCompare then exit;
  1089. if NodeClass<>aTree.NodeClass then exit;
  1090. MyNode:=FindLowest;
  1091. OtherNode:=aTree.FindLowest;
  1092. while MyNode<>nil do begin
  1093. if OtherNode=nil then exit;
  1094. if CheckDataPointer then begin
  1095. if MyNode.Data<>OtherNode.Data then exit;
  1096. end else begin
  1097. if Compare(MyNode.Data,OtherNode.Data)<>0 then exit;
  1098. end;
  1099. MyNode:=MyNode.Successor;
  1100. OtherNode:=OtherNode.Successor;
  1101. end;
  1102. if OtherNode<>nil then exit;
  1103. Result:=true;
  1104. end;
  1105. procedure TAVLTree.Assign(aTree: TAVLTree);
  1106. procedure AssignNode(var MyNode: TAVLTreeNode; OtherNode: TAVLTreeNode);
  1107. begin
  1108. MyNode:=NewNode;
  1109. MyNode.Data:=OtherNode.Data;
  1110. MyNode.Balance:=OtherNode.Balance;
  1111. if OtherNode.Left<>nil then begin
  1112. AssignNode(MyNode.Left,OtherNode.Left);
  1113. MyNode.Left.Parent:=MyNode;
  1114. end;
  1115. if OtherNode.Right<>nil then begin
  1116. AssignNode(MyNode.Right,OtherNode.Right);
  1117. MyNode.Right.Parent:=MyNode;
  1118. end;
  1119. end;
  1120. begin
  1121. if aTree=nil then
  1122. raise Exception.Create('TAVLTree.Assign aTree=nil');
  1123. if IsEqual(aTree,true) then exit;
  1124. Clear;
  1125. SetCompares(aTree.OnCompare,aTree.OnObjectCompare);
  1126. NodeClass:=aTree.NodeClass;
  1127. if aTree.Root<>nil then
  1128. AssignNode(fRoot,aTree.Root);
  1129. FCount:=aTree.Count;
  1130. end;
  1131. function TAVLTree.Compare(Data1, Data2: Pointer): integer;
  1132. begin
  1133. if Assigned(FOnCompare) then
  1134. Result:=FOnCompare(Data1,Data2)
  1135. else
  1136. Result:=FOnObjectCompare(Self,Data1,Data2);
  1137. end;
  1138. procedure TAVLTree.WriteReportToStream(s: TStream);
  1139. procedure WriteStr(const Txt: string);
  1140. begin
  1141. if Txt='' then exit;
  1142. s.Write(Txt[1],length(Txt));
  1143. end;
  1144. procedure WriteTreeNode(ANode: TAVLTreeNode);
  1145. var
  1146. b: String;
  1147. IsLeft: boolean;
  1148. AParent: TAVLTreeNode;
  1149. WasLeft: Boolean;
  1150. begin
  1151. if ANode=nil then exit;
  1152. WriteTreeNode(ANode.Right);
  1153. AParent:=ANode;
  1154. WasLeft:=false;
  1155. b:='';
  1156. while AParent<>nil do begin
  1157. if AParent.Parent=nil then begin
  1158. if AParent=ANode then
  1159. b:='--'+b
  1160. else
  1161. b:=' '+b;
  1162. break;
  1163. end;
  1164. IsLeft:=AParent.Parent.Left=AParent;
  1165. if AParent=ANode then begin
  1166. if IsLeft then
  1167. b:='\-'
  1168. else
  1169. b:='/-';
  1170. end else begin
  1171. if WasLeft=IsLeft then
  1172. b:=' '+b
  1173. else
  1174. b:='| '+b;
  1175. end;
  1176. WasLeft:=IsLeft;
  1177. AParent:=AParent.Parent;
  1178. end;
  1179. b:=b+NodeToReportStr(ANode)+LineEnding;
  1180. WriteStr(b);
  1181. WriteTreeNode(ANode.Left);
  1182. end;
  1183. // TAVLTree.WriteReportToStream
  1184. begin
  1185. WriteStr('-Start-of-AVL-Tree-------------------'+LineEnding);
  1186. WriteTreeNode(fRoot);
  1187. WriteStr('-End-Of-AVL-Tree---------------------'+LineEnding);
  1188. end;
  1189. function TAVLTree.NodeToReportStr(aNode: TAVLTreeNode): string;
  1190. begin
  1191. Result:=Format('%p Self=%p Parent=%p Balance=%d',
  1192. [aNode.Data, Pointer(aNode),Pointer(aNode.Parent), aNode.Balance]);
  1193. end;
  1194. function TAVLTree.ReportAsString: string;
  1195. var ms: TMemoryStream;
  1196. begin
  1197. Result:='';
  1198. ms:=TMemoryStream.Create;
  1199. try
  1200. WriteReportToStream(ms);
  1201. ms.Position:=0;
  1202. SetLength(Result,ms.Size);
  1203. if Result<>'' then
  1204. ms.Read(Result[1],length(Result));
  1205. finally
  1206. ms.Free;
  1207. end;
  1208. end;
  1209. procedure TAVLTree.SetOnCompare(const AValue: TListSortCompare);
  1210. begin
  1211. if AValue=nil then
  1212. SetCompares(nil,FOnObjectCompare)
  1213. else
  1214. SetCompares(AValue,nil);
  1215. end;
  1216. procedure TAVLTree.SetNodeManager(NewMgr: TBaseAVLTreeNodeManager;
  1217. AutoFree: boolean);
  1218. // only allowed just after create.
  1219. begin
  1220. if fNodeMgr=NewMgr then exit;
  1221. if Count>0 then
  1222. raise Exception.Create('TAVLTree.SetNodeManager');
  1223. if fNodeMgrAutoFree then
  1224. FreeAndNil(fNodeMgr);
  1225. fNodeMgr:=NewMgr;
  1226. fNodeMgrAutoFree:=AutoFree;
  1227. end;
  1228. { TAVLTreeNode }
  1229. function TAVLTreeNode.TreeDepth: integer;
  1230. // longest WAY down. e.g. only one node => 0 !
  1231. var LeftDepth, RightDepth: integer;
  1232. begin
  1233. if Left<>nil then
  1234. LeftDepth:=Left.TreeDepth+1
  1235. else
  1236. LeftDepth:=0;
  1237. if Right<>nil then
  1238. RightDepth:=Right.TreeDepth+1
  1239. else
  1240. RightDepth:=0;
  1241. if LeftDepth>RightDepth then
  1242. Result:=LeftDepth
  1243. else
  1244. Result:=RightDepth;
  1245. end;
  1246. procedure TAVLTreeNode.ConsistencyCheck(Tree: TAVLTree);
  1247. procedure E(Msg: string);
  1248. begin
  1249. raise Exception.Create('TAVLTreeNode.ConsistencyCheck: '+Msg);
  1250. end;
  1251. var
  1252. LeftDepth: SizeInt;
  1253. RightDepth: SizeInt;
  1254. begin
  1255. // test left child
  1256. if Left<>nil then begin
  1257. if Left.Parent<>Self then
  1258. E('Left.Parent<>Self');
  1259. if Tree.Compare(Left.Data,Data)>0 then
  1260. E('Compare(Left.Data,Data)>0');
  1261. Left.ConsistencyCheck(Tree);
  1262. end;
  1263. // test right child
  1264. if Right<>nil then begin
  1265. if Right.Parent<>Self then
  1266. E('Right.Parent<>Self');
  1267. if Tree.Compare(Data,Right.Data)>0 then
  1268. E('Compare(Data,Right.Data)>0');
  1269. Right.ConsistencyCheck(Tree);
  1270. end;
  1271. // test balance
  1272. if Left<>nil then
  1273. LeftDepth:=Left.TreeDepth+1
  1274. else
  1275. LeftDepth:=0;
  1276. if Right<>nil then
  1277. RightDepth:=Right.TreeDepth+1
  1278. else
  1279. RightDepth:=0;
  1280. if Balance<>(RightDepth-LeftDepth) then
  1281. E('Balance['+IntToStr(Balance)+']<>(RightDepth['+IntToStr(RightDepth)+']-LeftDepth['+IntToStr(LeftDepth)+'])');
  1282. end;
  1283. function TAVLTreeNode.GetCount: SizeInt;
  1284. begin
  1285. Result:=1;
  1286. if Left<>nil then inc(Result,Left.GetCount);
  1287. if Right<>nil then inc(Result,Right.GetCount);
  1288. end;
  1289. function TAVLTreeNode.Successor: TAVLTreeNode;
  1290. begin
  1291. Result:=Right;
  1292. if Result<>nil then begin
  1293. while (Result.Left<>nil) do Result:=Result.Left;
  1294. end else begin
  1295. Result:=Self;
  1296. while (Result.Parent<>nil) and (Result.Parent.Right=Result) do
  1297. Result:=Result.Parent;
  1298. Result:=Result.Parent;
  1299. end;
  1300. end;
  1301. function TAVLTreeNode.Precessor: TAVLTreeNode;
  1302. begin
  1303. Result:=Left;
  1304. if Result<>nil then begin
  1305. while (Result.Right<>nil) do Result:=Result.Right;
  1306. end else begin
  1307. Result:=Self;
  1308. while (Result.Parent<>nil) and (Result.Parent.Left=Result) do
  1309. Result:=Result.Parent;
  1310. Result:=Result.Parent;
  1311. end;
  1312. end;
  1313. procedure TAVLTreeNode.Clear;
  1314. begin
  1315. Parent:=nil;
  1316. Left:=nil;
  1317. Right:=nil;
  1318. Balance:=0;
  1319. Data:=nil;
  1320. end;
  1321. { TAVLTreeNodeMemManager }
  1322. constructor TAVLTreeNodeMemManager.Create;
  1323. begin
  1324. {$IFDEF CheckAVLTreeNodeManager}
  1325. FThreadId:=GetCurrentThreadId;
  1326. {$ENDIF}
  1327. inherited Create;
  1328. FFirstFree:=nil;
  1329. FFreeCount:=0;
  1330. FCount:=0;
  1331. FMinFree:=100;
  1332. FMaxFreeRatio:=8; // 1:1
  1333. end;
  1334. destructor TAVLTreeNodeMemManager.Destroy;
  1335. begin
  1336. Clear;
  1337. inherited Destroy;
  1338. end;
  1339. procedure TAVLTreeNodeMemManager.DisposeNode(ANode: TAVLTreeNode);
  1340. begin
  1341. if ANode=nil then exit;
  1342. {$IFDEF CheckAVLTreeNodeManager}
  1343. if GetCurrentThreadId<>FThreadId then
  1344. raise Exception.Create('not thread safe!');
  1345. {$ENDIF}
  1346. if FCount < 0 then
  1347. raise Exception.CreateFmt(
  1348. '%s.DisposeNode: FCount (%d) is negative. Should not happen.'
  1349. +' FFreeCount=%d, FMinFree=%d, FMaxFreeRatio=%d.',
  1350. [ClassName, FCount, FFreeCount, FMinFree, FMaxFreeRatio]);
  1351. if (FFreeCount<FMinFree) or (FFreeCount<((FCount shr 3)*FMaxFreeRatio)) then
  1352. begin
  1353. // add ANode to Free list
  1354. ANode.Clear;
  1355. ANode.Right:=FFirstFree;
  1356. FFirstFree:=ANode;
  1357. inc(FFreeCount);
  1358. if (FFreeCount>(((8+FMaxFreeRatio)*FCount) shr 3)) then begin
  1359. DisposeFirstFreeNode;
  1360. DisposeFirstFreeNode;
  1361. end;
  1362. end else begin
  1363. // free list full -> free the ANode
  1364. ANode.Free;
  1365. end;
  1366. dec(FCount);
  1367. end;
  1368. function TAVLTreeNodeMemManager.NewNode: TAVLTreeNode;
  1369. begin
  1370. {$IFDEF CheckAVLTreeNodeManager}
  1371. if GetCurrentThreadId<>FThreadId then
  1372. raise Exception.Create('not thread safe!');
  1373. {$ENDIF}
  1374. if FFirstFree<>nil then begin
  1375. // take from free list
  1376. Result:=FFirstFree;
  1377. FFirstFree:=FFirstFree.Right;
  1378. Result.Right:=nil;
  1379. dec(FFreeCount);
  1380. end else begin
  1381. // free list empty -> create new node
  1382. Result:=TAVLTreeNode.Create;
  1383. end;
  1384. inc(FCount);
  1385. end;
  1386. procedure TAVLTreeNodeMemManager.Clear;
  1387. var ANode: TAVLTreeNode;
  1388. begin
  1389. {$IFDEF CheckAVLTreeNodeManager}
  1390. if GetCurrentThreadId<>FThreadId then
  1391. raise Exception.Create('not thread safe!');
  1392. {$ENDIF}
  1393. while FFirstFree<>nil do begin
  1394. ANode:=FFirstFree;
  1395. FFirstFree:=FFirstFree.Right;
  1396. ANode.Right:=nil;
  1397. ANode.Free;
  1398. end;
  1399. FFreeCount:=0;
  1400. end;
  1401. procedure TAVLTreeNodeMemManager.SetMaxFreeRatio(NewValue: SizeInt);
  1402. begin
  1403. if NewValue<0 then NewValue:=0;
  1404. if NewValue=FMaxFreeRatio then exit;
  1405. FMaxFreeRatio:=NewValue;
  1406. end;
  1407. procedure TAVLTreeNodeMemManager.SetMinFree(NewValue: SizeInt);
  1408. begin
  1409. if NewValue<0 then NewValue:=0;
  1410. if NewValue=FMinFree then exit;
  1411. FMinFree:=NewValue;
  1412. end;
  1413. procedure TAVLTreeNodeMemManager.DisposeFirstFreeNode;
  1414. var OldNode: TAVLTreeNode;
  1415. begin
  1416. if FFirstFree=nil then exit;
  1417. OldNode:=FFirstFree;
  1418. FFirstFree:=FFirstFree.Right;
  1419. dec(FFreeCount);
  1420. OldNode.Right:=nil;
  1421. OldNode.Free;
  1422. end;
  1423. initialization
  1424. NodeMemManager:=TAVLTreeNodeMemManager.Create;
  1425. finalization
  1426. NodeMemManager.Free;
  1427. NodeMemManager:=nil;
  1428. end.