12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556 |
- { **********************************************************************
- This file is part of the Free Component Library (FCL)
- Copyright (c) 2008 by Mattias Gaertner
-
- Average Level Tree implementation by Mattias Gaertner
- 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.
- **********************************************************************
- Author: Mattias Gaertner
- Abstract:
- TAVLTree is an Average Level binary Tree. This binary tree is always
- balanced, so that inserting, deleting and finding a node is performed in
- O(log(#Nodes)).
- }
- unit AVL_Tree;
- {$ifdef FPC}{$mode objfpc}{$endif}{$H+}
- interface
- {off $DEFINE MEM_CHECK}
- {off $DEFINE CheckAVLTreeNodeManager}
- uses
- {$IFDEF MEM_CHECK}MemCheck,{$ENDIF}
- Classes, SysUtils;
- type
- TAVLTree = class;
- TObjectSortCompare = function(Tree: TAVLTree; Data1, Data2: Pointer): integer of object;
- { TAVLTreeNode }
- TAVLTreeNode = class
- public
- Parent, Left, Right: TAVLTreeNode;
- Balance: integer; // = RightDepth-LeftDepth -2..+2, after balancing: -1,0,+1
- Data: Pointer;
- function Successor: TAVLTreeNode; // next right
- function Precessor: TAVLTreeNode; // next left
- procedure Clear;
- function TreeDepth: integer; // longest WAY down. e.g. only one node => 0 !
- procedure ConsistencyCheck(Tree: TAVLTree); virtual;
- function GetCount: SizeInt;
- end;
- TAVLTreeNodeClass = class of TAVLTreeNode;
- PAVLTreeNode = ^TAVLTreeNode;
- { TBaseAVLTreeNodeManager }
- TBaseAVLTreeNodeManager = class
- public
- procedure DisposeNode(ANode: TAVLTreeNode); virtual; abstract;
- function NewNode: TAVLTreeNode; virtual; abstract;
- end;
- { TAVLTreeNodeEnumerator }
- TAVLTreeNodeEnumerator = class
- protected
- FCurrent: TAVLTreeNode;
- FLowToHigh: boolean;
- FTree: TAVLTree;
- public
- constructor Create(Tree: TAVLTree; aLowToHigh: boolean = true);
- function GetEnumerator: TAVLTreeNodeEnumerator; inline;
- function MoveNext: Boolean;
- property Current: TAVLTreeNode read FCurrent;
- property LowToHigh: boolean read FLowToHigh;
- end;
- TAVLTree = class
- protected
- FCount: SizeInt;
- FNodeClass: TAVLTreeNodeClass;
- fNodeMgr: TBaseAVLTreeNodeManager;
- fNodeMgrAutoFree: boolean;
- FOnCompare: TListSortCompare;
- FOnObjectCompare: TObjectSortCompare;
- FRoot: TAVLTreeNode;
- procedure BalanceAfterInsert(ANode: TAVLTreeNode);
- procedure BalanceAfterDelete(ANode: TAVLTreeNode);
- procedure DeletingNode({%H-}aNode: TAVLTreeNode); virtual;
- function FindInsertPos(Data: Pointer): TAVLTreeNode;
- procedure Init; virtual;
- procedure NodeAdded({%H-}aNode: TAVLTreeNode); virtual;
- procedure RotateLeft(aNode: TAVLTreeNode); virtual;
- procedure RotateRight(aNode: TAVLTreeNode); virtual;
- procedure SwitchPositionWithSuccessor(aNode, aSuccessor: TAVLTreeNode); virtual;
- procedure SetOnCompare(const AValue: TListSortCompare);
- procedure SetOnObjectCompare(const AValue: TObjectSortCompare);
- procedure SetCompares(const NewCompare: TListSortCompare;
- const NewObjectCompare: TObjectSortCompare);
- procedure SetNodeClass(const AValue: TAVLTreeNodeClass);
- public
- constructor Create(const OnCompareMethod: TListSortCompare);
- constructor CreateObjectCompare(const OnCompareMethod: TObjectSortCompare);
- constructor Create;
- destructor Destroy; override;
- property OnCompare: TListSortCompare read FOnCompare write SetOnCompare;
- property OnObjectCompare: TObjectSortCompare read FOnObjectCompare write SetOnObjectCompare;
- property NodeClass: TAVLTreeNodeClass read FNodeClass write SetNodeClass; // used for new nodes
- procedure SetNodeManager(NewMgr: TBaseAVLTreeNodeManager;
- AutoFree: boolean = false);
- function NewNode: TAVLTreeNode; virtual; // create a node outside the tree
- procedure DisposeNode(ANode: TAVLTreeNode); virtual; // free the node outside the tree
- // add, delete, remove, move
- procedure Add(ANode: TAVLTreeNode);
- function Add(Data: Pointer): TAVLTreeNode;
- function AddAscendingSequence(Data: Pointer; LastAdded: TAVLTreeNode;
- var Successor: TAVLTreeNode): TAVLTreeNode;
- procedure Delete(ANode: TAVLTreeNode);
- function Remove(Data: Pointer): boolean;
- function RemovePointer(Data: Pointer): boolean;
- procedure MoveDataLeftMost(var ANode: TAVLTreeNode);
- procedure MoveDataRightMost(var ANode: TAVLTreeNode);
- procedure Clear;
- procedure FreeAndClear;
- procedure FreeAndDelete(ANode: TAVLTreeNode); virtual;
- function Equals(Obj: TObject): boolean; override; // same as IsEqual(aTree,false)
- function IsEqual(aTree: TAVLTree; CheckDataPointer: boolean): boolean; // checks only keys or Data (references), not the data itself, O(n)
- procedure Assign(aTree: TAVLTree); virtual; // clear and copy all Data (references), O(n)
- // search
- property Root: TAVLTreeNode read fRoot;
- property Count: SizeInt read FCount;
- function Compare(Data1, Data2: Pointer): integer;
- function Find(Data: Pointer): TAVLTreeNode; // O(log(n))
- function FindKey(Key: Pointer;
- const OnCompareKeyWithData: TListSortCompare): TAVLTreeNode; // O(log(n))
- function FindNearestKey(Key: Pointer;
- const OnCompareKeyWithData: TListSortCompare): TAVLTreeNode; // O(log(n))
- function FindSuccessor(ANode: TAVLTreeNode): TAVLTreeNode; inline;
- function FindPrecessor(ANode: TAVLTreeNode): TAVLTreeNode; inline;
- function FindLowest: TAVLTreeNode; // O(log(n))
- function FindHighest: TAVLTreeNode; // O(log(n))
- function FindNearest(Data: Pointer): TAVLTreeNode;
- // search in a tree with duplicates (duplicate means here: Compare function returns 0)
- function FindPointer(Data: Pointer): TAVLTreeNode;
- function FindLeftMost(Data: Pointer): TAVLTreeNode;
- function FindRightMost(Data: Pointer): TAVLTreeNode;
- function FindLeftMostKey(Key: Pointer;
- const OnCompareKeyWithData: TListSortCompare): TAVLTreeNode;
- function FindRightMostKey(Key: Pointer;
- const OnCompareKeyWithData: TListSortCompare): TAVLTreeNode;
- function FindLeftMostSameKey(ANode: TAVLTreeNode): TAVLTreeNode;
- function FindRightMostSameKey(ANode: TAVLTreeNode): TAVLTreeNode;
- // enumerators
- function GetEnumerator: TAVLTreeNodeEnumerator;
- function GetEnumeratorHighToLow: TAVLTreeNodeEnumerator;
- // consistency
- procedure ConsistencyCheck; virtual; // JuMa: changed to procedure and added "virtual".
- procedure WriteReportToStream(s: TStream);
- function NodeToReportStr(aNode: TAVLTreeNode): string; virtual;
- function ReportAsString: string;
- end;
- TAVLTreeClass = class of TAVLTree;
- { TAVLTreeNodeMemManager }
- TAVLTreeNodeMemManager = class(TBaseAVLTreeNodeManager)
- private
- FFirstFree: TAVLTreeNode;
- FFreeCount: SizeInt;
- FCount: SizeInt;
- FMinFree: SizeInt;
- FMaxFreeRatio: SizeInt;
- {$IFDEF CheckAVLTreeNodeManager}
- FThreadId: TThreadID;
- {$ENDIF}
- procedure SetMaxFreeRatio(NewValue: SizeInt);
- procedure SetMinFree(NewValue: SizeInt);
- procedure DisposeFirstFreeNode;
- public
- procedure DisposeNode(ANode: TAVLTreeNode); override;
- function NewNode: TAVLTreeNode; override;
- property MinimumFreeNode: SizeInt read FMinFree write SetMinFree;
- property MaximumFreeNodeRatio: SizeInt
- read FMaxFreeRatio write SetMaxFreeRatio; // in one eighth steps
- property Count: SizeInt read FCount;
- procedure Clear;
- constructor Create;
- destructor Destroy; override;
- end;
- var
- NodeMemManager: TAVLTreeNodeMemManager;
- implementation
- function ComparePointer(Data1, Data2: Pointer): integer;
- begin
- if Data1>Data2 then Result:=-1
- else if Data1<Data2 then Result:=1
- else Result:=0;
- end;
- { TAVLTreeNodeEnumerator }
- constructor TAVLTreeNodeEnumerator.Create(Tree: TAVLTree; aLowToHigh: boolean);
- begin
- FTree:=Tree;
- FLowToHigh:=aLowToHigh;
- end;
- function TAVLTreeNodeEnumerator.GetEnumerator: TAVLTreeNodeEnumerator;
- begin
- Result:=Self;
- end;
- function TAVLTreeNodeEnumerator.MoveNext: Boolean;
- begin
- if FLowToHigh then begin
- if FCurrent<>nil then
- FCurrent:=FCurrent.Successor
- else
- FCurrent:=FTree.FindLowest;
- end else begin
- if FCurrent<>nil then
- FCurrent:=FCurrent.Precessor
- else
- FCurrent:=FTree.FindHighest;
- end;
- Result:=FCurrent<>nil;
- end;
- { TAVLTree }
- function TAVLTree.Add(Data: Pointer): TAVLTreeNode;
- begin
- Result:=NewNode;
- Result.Data:=Data;
- Add(Result);
- end;
- function TAVLTree.AddAscendingSequence(Data: Pointer; LastAdded: TAVLTreeNode;
- var Successor: TAVLTreeNode): TAVLTreeNode;
- { This is an optimized version of "Add" for adding an ascending sequence of
- nodes.
- It uses the LastAdded and Successor to skip searching for an insert position.
- For nodes with same value the order of the sequence is kept.
- Usage:
- LastNode:=nil; // TAvlTreeNode
- Successor:=nil; // TAvlTreeNode
- for i:=1 to 1000 do
- LastNode:=Tree.AddAscendingSequence(TItem.Create(i),LastNode,Successor);
- }
- var
- InsertPos: TAVLTreeNode;
- begin
- Result:=NewNode;
- Result.Data:=Data;
- if (LastAdded<>nil) and (Compare(LastAdded.Data,Data)<=0)
- and ((Successor=nil) or (Compare(Data,Successor.Data)<=0)) then begin
- // Data is between LastAdded and Successor
- inc(FCount);
- if LastAdded.Right=nil then begin
- Result.Parent:=LastAdded;
- LastAdded.Right:=Result;
- end else begin
- InsertPos:=LastAdded.Right;
- while InsertPos.Left<>nil do
- InsertPos:=InsertPos.Left;
- Result.Parent:=InsertPos;
- InsertPos.Left:=Result;
- end;
- NodeAdded(Result);
- BalanceAfterInsert(Result);
- end else begin
- // normal Add
- Add(Result);
- Successor:=Result.Successor;
- end;
- end;
- function TAVLTree.NewNode: TAVLTreeNode;
- begin
- if fNodeMgr<>nil then
- Result:=fNodeMgr.NewNode
- else
- Result:=NodeClass.Create;
- end;
- procedure TAVLTree.DisposeNode(ANode: TAVLTreeNode);
- begin
- if fNodeMgr<>nil then
- fNodeMgr.DisposeNode(ANode)
- else
- ANode.Free;
- end;
- procedure TAVLTree.Add(ANode: TAVLTreeNode);
- // add a node. If there are already nodes with the same value it will be
- // inserted rightmost
- var InsertPos: TAVLTreeNode;
- InsertComp: integer;
- begin
- ANode.Left:=nil;
- ANode.Right:=nil;
- inc(FCount);
- if Root<>nil then begin
- InsertPos:=FindInsertPos(ANode.Data);
- InsertComp:=Compare(ANode.Data,InsertPos.Data);
- ANode.Parent:=InsertPos;
- if InsertComp<0 then begin
- // insert to the left
- InsertPos.Left:=ANode;
- end else begin
- // insert to the right
- InsertPos.Right:=ANode;
- end;
- NodeAdded(ANode);
- BalanceAfterInsert(ANode);
- end else begin
- fRoot:=ANode;
- ANode.Parent:=nil;
- NodeAdded(ANode);
- end;
- end;
- function TAVLTree.FindLowest: TAVLTreeNode;
- begin
- Result:=Root;
- if Result<>nil then
- while Result.Left<>nil do Result:=Result.Left;
- end;
- function TAVLTree.FindHighest: TAVLTreeNode;
- begin
- Result:=Root;
- if Result<>nil then
- while Result.Right<>nil do Result:=Result.Right;
- end;
- procedure TAVLTree.BalanceAfterDelete(ANode: TAVLTreeNode);
- var
- OldParent, OldRight, OldRightLeft, OldLeft, OldLeftRight: TAVLTreeNode;
- begin
- while ANode<>nil do begin
- if ((ANode.Balance=+1) or (ANode.Balance=-1)) then exit;
- OldParent:=ANode.Parent;
- if (ANode.Balance=0) then begin
- // Treeheight has decreased by one
- if (OldParent=nil) then
- exit;
- if(OldParent.Left=ANode) then
- Inc(OldParent.Balance)
- else
- Dec(OldParent.Balance);
- ANode:=OldParent;
- end else if (ANode.Balance=+2) then begin
- // Node is overweighted to the right
- OldRight:=ANode.Right;
- if (OldRight.Balance>=0) then begin
- // OldRight.Balance is 0 or -1
- // rotate ANode,OldRight left
- RotateLeft(ANode);
- ANode.Balance:=(1-OldRight.Balance); // toggle 0 and 1
- Dec(OldRight.Balance);
- ANode:=OldRight;
- end else begin
- // OldRight.Balance=-1
- { double rotate
- = rotate OldRightLeft,OldRight right
- and then rotate ANode,OldRightLeft left
- OldParent OldParent
- | |
- ANode OldRightLeft
- \ / \
- OldRight => ANode OldRight
- / \ /
- OldRightLeft OldRightLeftLeft OldRightLeftRight
- / \
- OldRightLeftLeft OldRightLeftRight
- }
- OldRightLeft:=OldRight.Left;
- RotateRight(OldRight);
- RotateLeft(ANode);
- if (OldRightLeft.Balance<=0) then
- ANode.Balance:=0
- else
- ANode.Balance:=-1;
- if (OldRightLeft.Balance>=0) then
- OldRight.Balance:=0
- else
- OldRight.Balance:=+1;
- OldRightLeft.Balance:=0;
- ANode:=OldRightLeft;
- end;
- end else begin
- // Node.Balance=-2
- // Node is overweighted to the left
- OldLeft:=ANode.Left;
- if (OldLeft.Balance<=0) then begin
- // rotate OldLeft,ANode right
- RotateRight(ANode);
- ANode.Balance:=(-1-OldLeft.Balance); // toggle 0 and -1
- Inc(OldLeft.Balance);
- ANode:=OldLeft;
- end else begin
- // OldLeft.Balance = 1
- { double rotate left right
- = rotate OldLeft,OldLeftRight left
- and then rotate OldLeft,ANode right
- OldParent OldParent
- | |
- ANode OldLeftRight
- / / \
- OldLeft => OldLeft ANode
- \ \ /
- OldLeftRight OldLeftRightLeft OldLeftRightRight
- / \
- OldLeftRightLeft OldLeftRightRight
- }
- OldLeftRight:=OldLeft.Right;
- RotateLeft(OldLeft);
- RotateRight(ANode);
- if (OldLeftRight.Balance>=0) then
- ANode.Balance:=0
- else
- ANode.Balance:=+1;
- if (OldLeftRight.Balance<=0) then
- OldLeft.Balance:=0
- else
- OldLeft.Balance:=-1;
- OldLeftRight.Balance:=0;
- ANode:=OldLeftRight;
- end;
- end;
- end;
- end;
- procedure TAVLTree.DeletingNode(aNode: TAVLTreeNode);
- // called by Delete
- // Node.Left=nil or Node.Right=nil
- begin
- // for descendants to override
- end;
- procedure TAVLTree.SetOnObjectCompare(const AValue: TObjectSortCompare);
- begin
- if AValue=nil then
- SetCompares(FOnCompare,nil)
- else
- SetCompares(nil,AValue);
- end;
- procedure TAVLTree.SetCompares(const NewCompare: TListSortCompare;
- const NewObjectCompare: TObjectSortCompare);
- var List: PPointer;
- ANode: TAVLTreeNode;
- i, OldCount: integer;
- begin
- if (FOnCompare=NewCompare) and (FOnObjectCompare=NewObjectCompare) then exit;
- if Count<=1 then begin
- FOnCompare:=NewCompare;
- FOnObjectCompare:=NewObjectCompare;
- exit;
- end;
- // sort the tree again
- OldCount:=Count;
- GetMem(List,SizeOf(Pointer)*OldCount);
- try
- // save the data in a list
- ANode:=FindLowest;
- i:=0;
- while ANode<>nil do begin
- List[i]:=ANode.Data;
- inc(i);
- ANode:=ANode.Successor;
- end;
- // clear the tree
- Clear;
- // set the new compare function
- FOnCompare:=NewCompare;
- FOnObjectCompare:=NewObjectCompare;
- // re-add all nodes
- for i:=0 to OldCount-1 do
- Add(List[i]);
- finally
- FreeMem(List);
- end;
- end;
- procedure TAVLTree.SetNodeClass(const AValue: TAVLTreeNodeClass);
- begin
- if FNodeClass=AValue then Exit;
- if Count>0 then
- raise Exception.Create(ClassName+'.SetNodeClass Count='+IntToStr(Count)
- +' Old='+fNodeMgr.ClassName+' New='+AValue.ClassName);
- FNodeClass:=AValue;
- if fNodeMgr=NodeMemManager then
- fNodeMgr:=nil;
- end;
- procedure TAVLTree.BalanceAfterInsert(ANode: TAVLTreeNode);
- var
- OldParent, OldRight, OldLeft: TAVLTreeNode;
- begin
- OldParent:=ANode.Parent;
- while (OldParent<>nil) do begin
- if (OldParent.Left=ANode) then begin
- // Node is left child
- dec(OldParent.Balance);
- if (OldParent.Balance=0) then exit;
- if (OldParent.Balance=-1) then begin
- ANode:=OldParent;
- OldParent:=ANode.Parent;
- continue;
- end;
- // OldParent.Balance=-2
- if (ANode.Balance=-1) then begin
- { rotate ANode,ANode.Parent right
- OldParentParent OldParentParent
- | |
- OldParent => ANode
- / \
- ANode OldParent
- \ /
- OldRight OldRight }
- RotateRight(OldParent);
- ANode.Balance:=0;
- OldParent.Balance:=0;
- end else begin
- // Node.Balance = +1
- { double rotate
- = rotate ANode,OldRight left and then rotate OldRight,OldParent right
- OldParentParent OldParentParent
- | |
- OldParent OldRight
- / => / \
- ANode ANode OldParent
- \ \ /
- OldRight OldRightLeft OldRightRight
- / \
- OldRightLeft OldRightRight
- }
- OldRight:=ANode.Right;
- RotateLeft(ANode);
- RotateRight(OldParent);
- if (OldRight.Balance<=0) then
- ANode.Balance:=0
- else
- ANode.Balance:=-1;
- if (OldRight.Balance=-1) then
- OldParent.Balance:=1
- else
- OldParent.Balance:=0;
- OldRight.Balance:=0;
- end;
- exit;
- end else begin
- // Node is right child
- Inc(OldParent.Balance);
- if (OldParent.Balance=0) then exit;
- if (OldParent.Balance=+1) then begin
- ANode:=OldParent;
- OldParent:=ANode.Parent;
- continue;
- end;
- // OldParent.Balance = +2
- if(ANode.Balance=+1) then begin
- { rotate OldParent,ANode left
- OldParentParent OldParentParent
- | |
- OldParent => ANode
- \ /
- ANode OldParent
- / \
- OldLeft OldLeft }
- RotateLeft(OldParent);
- ANode.Balance:=0;
- OldParent.Balance:=0;
- end else begin
- // Node.Balance = -1
- { double rotate
- = rotate OldLeft,ANode right and then rotate OldParent,OldLeft right
- OldParentParent OldParentParent
- | |
- OldParent OldLeft
- \ => / \
- ANode OldParent ANode
- / \ /
- OldLeft OldLeftLeft OldLeftRight
- / \
- OldLeftLeft OldLeftRight
- }
- OldLeft:=ANode.Left;
- RotateRight(ANode);
- RotateLeft(OldParent);
- if (OldLeft.Balance>=0) then
- ANode.Balance:=0
- else
- ANode.Balance:=+1;
- if (OldLeft.Balance=+1) then
- OldParent.Balance:=-1
- else
- OldParent.Balance:=0;
- OldLeft.Balance:=0;
- end;
- exit;
- end;
- end;
- end;
- procedure TAVLTree.Clear;
- procedure DeleteNode(ANode: TAVLTreeNode);
- begin
- if ANode<>nil then begin
- if ANode.Left<>nil then DeleteNode(ANode.Left);
- if ANode.Right<>nil then DeleteNode(ANode.Right);
- end;
- DisposeNode(ANode);
- end;
- // Clear
- begin
- DeleteNode(Root);
- fRoot:=nil;
- FCount:=0;
- end;
- constructor TAVLTree.Create(const OnCompareMethod: TListSortCompare);
- begin
- fNodeMgr:=NodeMemManager;
- FOnCompare:=OnCompareMethod;
- Init;
- end;
- constructor TAVLTree.CreateObjectCompare(
- const OnCompareMethod: TObjectSortCompare);
- begin
- fNodeMgr:=NodeMemManager;
- FOnObjectCompare:=OnCompareMethod;
- Init;
- end;
- constructor TAVLTree.Create;
- begin
- Create(@ComparePointer);
- end;
- procedure TAVLTree.Delete(ANode: TAVLTreeNode);
- var
- OldParent, Child: TAVLTreeNode;
- begin
- {$IFDEF CheckAVLTreeNodeManager}
- OldParent:=ANode;
- while OldParent.Parent<>nil do OldParent:=OldParent.Parent;
- if OldParent<>Root then
- raise Exception.Create('TAVLTree.Delete'); // not my node
- {$ENDIF}
- if (ANode.Left<>nil) and (ANode.Right<>nil) then begin
- // ANode has both: Left and Right
- // Switch ANode position with Successor
- // Because ANode.Right<>nil the Successor is a child of ANode
- SwitchPositionWithSuccessor(ANode,ANode.Successor);
- end;
- // left or right is nil
- DeletingNode(aNode);
- OldParent:=ANode.Parent;
- ANode.Parent:=nil;
- if ANode.Left<>nil then
- Child:=ANode.Left
- else
- Child:=ANode.Right;
- if Child<>nil then
- Child.Parent:=OldParent;
- if (OldParent<>nil) then begin
- // Node has parent
- if (OldParent.Left=ANode) then begin
- // Node is left child of OldParent
- OldParent.Left:=Child;
- Inc(OldParent.Balance);
- end else begin
- // Node is right child of OldParent
- OldParent.Right:=Child;
- Dec(OldParent.Balance);
- end;
- BalanceAfterDelete(OldParent);
- end else begin
- // Node was Root
- fRoot:=Child;
- end;
- dec(FCount);
- DisposeNode(ANode);
- end;
- function TAVLTree.Remove(Data: Pointer): boolean;
- var
- ANode: TAvlTreeNode;
- begin
- ANode:=Find(Data);
- if ANode<>nil then begin
- Delete(ANode);
- Result:=true;
- end else
- Result:=false;
- end;
- function TAVLTree.RemovePointer(Data: Pointer): boolean;
- var
- ANode: TAvlTreeNode;
- begin
- ANode:=FindPointer(Data);
- if ANode<>nil then begin
- Delete(ANode);
- Result:=true;
- end else
- Result:=false;
- end;
- destructor TAVLTree.Destroy;
- begin
- Clear;
- if fNodeMgrAutoFree then
- FreeAndNil(fNodeMgr);
- inherited Destroy;
- end;
- function TAVLTree.GetEnumerator: TAVLTreeNodeEnumerator;
- begin
- Result:=TAVLTreeNodeEnumerator.Create(Self,true);
- end;
- function TAVLTree.GetEnumeratorHighToLow: TAVLTreeNodeEnumerator;
- begin
- Result:=TAVLTreeNodeEnumerator.Create(Self,false);
- end;
- function TAVLTree.Find(Data: Pointer): TAVLTreeNode;
- var Comp: integer;
- begin
- Result:=Root;
- while (Result<>nil) do begin
- Comp:=Compare(Data,Result.Data);
- if Comp=0 then exit;
- if Comp<0 then begin
- Result:=Result.Left
- end else begin
- Result:=Result.Right
- end;
- end;
- end;
- function TAVLTree.FindKey(Key: Pointer; const OnCompareKeyWithData: TListSortCompare
- ): TAVLTreeNode;
- var Comp: integer;
- begin
- Result:=Root;
- while (Result<>nil) do begin
- Comp:=OnCompareKeyWithData(Key,Result.Data);
- if Comp=0 then exit;
- if Comp<0 then begin
- Result:=Result.Left
- end else begin
- Result:=Result.Right
- end;
- end;
- end;
- function TAVLTree.FindNearestKey(Key: Pointer;
- const OnCompareKeyWithData: TListSortCompare): TAVLTreeNode;
- var Comp: integer;
- begin
- Result:=fRoot;
- while (Result<>nil) do begin
- Comp:=OnCompareKeyWithData(Key,Result.Data);
- if Comp=0 then exit;
- if Comp<0 then begin
- if Result.Left<>nil then
- Result:=Result.Left
- else
- exit;
- end else begin
- if Result.Right<>nil then
- Result:=Result.Right
- else
- exit;
- end;
- end;
- end;
- function TAVLTree.FindLeftMostKey(Key: Pointer;
- const OnCompareKeyWithData: TListSortCompare): TAVLTreeNode;
- var
- LeftNode: TAVLTreeNode;
- begin
- Result:=FindKey(Key,OnCompareKeyWithData);
- if Result=nil then exit;
- repeat
- LeftNode:=Result.Precessor;
- if (LeftNode=nil) or (OnCompareKeyWithData(Key,LeftNode.Data)<>0) then exit;
- Result:=LeftNode;
- until false;
- end;
- function TAVLTree.FindRightMostKey(Key: Pointer;
- const OnCompareKeyWithData: TListSortCompare): TAVLTreeNode;
- var
- RightNode: TAVLTreeNode;
- begin
- Result:=FindKey(Key,OnCompareKeyWithData);
- if Result=nil then exit;
- repeat
- RightNode:=Result.Successor;
- if (RightNode=nil) or (OnCompareKeyWithData(Key,RightNode.Data)<>0) then exit;
- Result:=RightNode;
- until false;
- end;
- function TAVLTree.FindLeftMostSameKey(ANode: TAVLTreeNode): TAVLTreeNode;
- var
- LeftNode: TAVLTreeNode;
- Data: Pointer;
- begin
- if ANode<>nil then begin
- Data:=ANode.Data;
- Result:=ANode;
- repeat
- LeftNode:=Result.Precessor;
- if (LeftNode=nil) or (Compare(Data,LeftNode.Data)<>0) then break;
- Result:=LeftNode;
- until false;
- end else begin
- Result:=nil;
- end;
- end;
- function TAVLTree.FindRightMostSameKey(ANode: TAVLTreeNode): TAVLTreeNode;
- var
- RightNode: TAVLTreeNode;
- Data: Pointer;
- begin
- if ANode<>nil then begin
- Data:=ANode.Data;
- Result:=ANode;
- repeat
- RightNode:=Result.Successor;
- if (RightNode=nil) or (Compare(Data,RightNode.Data)<>0) then break;
- Result:=RightNode;
- until false;
- end else begin
- Result:=nil;
- end;
- end;
- function TAVLTree.FindNearest(Data: Pointer): TAVLTreeNode;
- var Comp: integer;
- begin
- Result:=Root;
- while (Result<>nil) do begin
- Comp:=Compare(Data,Result.Data);
- if Comp=0 then exit;
- if Comp<0 then begin
- if Result.Left<>nil then
- Result:=Result.Left
- else
- exit;
- end else begin
- if Result.Right<>nil then
- Result:=Result.Right
- else
- exit;
- end;
- end;
- end;
- function TAVLTree.FindPointer(Data: Pointer): TAVLTreeNode;
- // same as Find, but not comparing for key, but same Data too
- begin
- Result:=FindLeftMost(Data);
- while (Result<>nil) do begin
- if Result.Data=Data then break;
- Result:=Result.Successor;
- if Result=nil then exit;
- if Compare(Data,Result.Data)<>0 then exit(nil);
- end;
- end;
- function TAVLTree.FindLeftMost(Data: Pointer): TAVLTreeNode;
- var
- Left: TAVLTreeNode;
- begin
- Result:=Find(Data);
- while (Result<>nil) do begin
- Left:=Result.Precessor;
- if (Left=nil) or (Compare(Data,Left.Data)<>0) then break;
- Result:=Left;
- end;
- end;
- function TAVLTree.FindRightMost(Data: Pointer): TAVLTreeNode;
- var
- Right: TAVLTreeNode;
- begin
- Result:=Find(Data);
- while (Result<>nil) do begin
- Right:=Result.Successor;
- if (Right=nil) or (Compare(Data,Right.Data)<>0) then break;
- Result:=Right;
- end;
- end;
- function TAVLTree.FindInsertPos(Data: Pointer): TAVLTreeNode;
- var Comp: integer;
- begin
- Result:=Root;
- while (Result<>nil) do begin
- Comp:=Compare(Data,Result.Data);
- if Comp<0 then begin
- if Result.Left<>nil then
- Result:=Result.Left
- else
- exit;
- end else begin
- if Result.Right<>nil then
- Result:=Result.Right
- else
- exit;
- end;
- end;
- end;
- procedure TAVLTree.Init;
- begin
- FNodeClass:=TAVLTreeNode;
- end;
- procedure TAVLTree.NodeAdded(aNode: TAVLTreeNode);
- begin
- // for descendants to override
- end;
- procedure TAVLTree.RotateLeft(aNode: TAVLTreeNode);
- { Parent Parent
- | |
- Node => OldRight
- / \ /
- Left OldRight Node
- / / \
- OldRightLeft Left OldRightLeft }
- var
- AParent, OldRight, OldRightLeft: TAVLTreeNode;
- begin
- OldRight:=aNode.Right;
- OldRightLeft:=OldRight.Left;
- AParent:=aNode.Parent;
- if AParent<>nil then begin
- if AParent.Left=aNode then
- AParent.Left:=OldRight
- else
- AParent.Right:=OldRight;
- end else
- fRoot:=OldRight;
- OldRight.Parent:=AParent;
- aNode.Parent:=OldRight;
- aNode.Right:=OldRightLeft;
- if OldRightLeft<>nil then
- OldRightLeft.Parent:=aNode;
- OldRight.Left:=aNode;
- end;
- procedure TAVLTree.RotateRight(aNode: TAVLTreeNode);
- { Parent Parent
- | |
- Node => OldLeft
- / \ \
- OldLeft Right Node
- \ / \
- OldLeftRight OldLeftRight Right }
- var
- AParent, OldLeft, OldLeftRight: TAVLTreeNode;
- begin
- OldLeft:=aNode.Left;
- OldLeftRight:=OldLeft.Right;
- AParent:=aNode.Parent;
- if AParent<>nil then begin
- if AParent.Left=aNode then
- AParent.Left:=OldLeft
- else
- AParent.Right:=OldLeft;
- end else
- fRoot:=OldLeft;
- OldLeft.Parent:=AParent;
- aNode.Parent:=OldLeft;
- aNode.Left:=OldLeftRight;
- if OldLeftRight<>nil then
- OldLeftRight.Parent:=aNode;
- OldLeft.Right:=aNode;
- end;
- procedure TAVLTree.SwitchPositionWithSuccessor(aNode, aSuccessor: TAVLTreeNode);
- { called by delete, when aNode.Left<>nil and aNode.Right<>nil
- Switch ANode position with Successor
- Because ANode.Right<>nil the Successor is a child of ANode }
- var
- OldBalance: Integer;
- OldParent, OldLeft, OldRight,
- OldSuccParent, OldSuccLeft, OldSuccRight: TAVLTreeNode;
- begin
- OldBalance:=aNode.Balance;
- aNode.Balance:=aSuccessor.Balance;
- aSuccessor.Balance:=OldBalance;
- OldParent:=aNode.Parent;
- OldLeft:=aNode.Left;
- OldRight:=aNode.Right;
- OldSuccParent:=aSuccessor.Parent;
- OldSuccLeft:=aSuccessor.Left;
- OldSuccRight:=aSuccessor.Right;
- if OldParent<>nil then begin
- if OldParent.Left=aNode then
- OldParent.Left:=aSuccessor
- else
- OldParent.Right:=aSuccessor;
- end else
- fRoot:=aSuccessor;
- aSuccessor.Parent:=OldParent;
- if OldSuccParent<>aNode then begin
- if OldSuccParent.Left=aSuccessor then
- OldSuccParent.Left:=aNode
- else
- OldSuccParent.Right:=aNode;
- aSuccessor.Right:=OldRight;
- aNode.Parent:=OldSuccParent;
- if OldRight<>nil then
- OldRight.Parent:=aSuccessor;
- end else begin
- { aNode aSuccessor
- \ => \
- aSuccessor aNode }
- aSuccessor.Right:=aNode;
- aNode.Parent:=aSuccessor;
- end;
- aNode.Left:=OldSuccLeft;
- if OldSuccLeft<>nil then
- OldSuccLeft.Parent:=aNode;
- aNode.Right:=OldSuccRight;
- if OldSuccRight<>nil then
- OldSuccRight.Parent:=aNode;
- aSuccessor.Left:=OldLeft;
- if OldLeft<>nil then
- OldLeft.Parent:=aSuccessor;
- end;
- function TAVLTree.FindSuccessor(ANode: TAVLTreeNode): TAVLTreeNode;
- begin
- if ANode<>nil then
- Result:=ANode.Successor
- else
- Result:=nil;
- end;
- function TAVLTree.FindPrecessor(ANode: TAVLTreeNode): TAVLTreeNode;
- begin
- if ANode<>nil then
- Result:=ANode.Precessor
- else
- Result:=nil;
- end;
- procedure TAVLTree.MoveDataLeftMost(var ANode: TAVLTreeNode);
- var
- LeftMost, PreNode: TAVLTreeNode;
- Data: Pointer;
- begin
- if ANode=nil then exit;
- LeftMost:=ANode;
- repeat
- PreNode:=FindPrecessor(LeftMost);
- if (PreNode=nil) or (Compare(ANode,PreNode)<>0) then break;
- LeftMost:=PreNode;
- until false;
- if LeftMost=ANode then exit;
- Data:=LeftMost.Data;
- LeftMost.Data:=ANode.Data;
- ANode.Data:=Data;
- ANode:=LeftMost;
- end;
- procedure TAVLTree.MoveDataRightMost(var ANode: TAVLTreeNode);
- var
- RightMost, PostNode: TAVLTreeNode;
- Data: Pointer;
- begin
- if ANode=nil then exit;
- RightMost:=ANode;
- repeat
- PostNode:=FindSuccessor(RightMost);
- if (PostNode=nil) or (Compare(ANode,PostNode)<>0) then break;
- RightMost:=PostNode;
- until false;
- if RightMost=ANode then exit;
- Data:=RightMost.Data;
- RightMost.Data:=ANode.Data;
- ANode.Data:=Data;
- ANode:=RightMost;
- end;
- procedure TAVLTree.ConsistencyCheck;
- procedure E(Msg: string);
- begin
- raise Exception.Create('TAVLTree.ConsistencyCheck: '+Msg);
- end;
- var
- RealCount: SizeInt;
- begin
- RealCount:=0;
- if FRoot<>nil then begin
- FRoot.ConsistencyCheck(Self);
- RealCount:=FRoot.GetCount;
- end;
- if Count<>RealCount then
- E('Count<>RealCount');
- end;
- procedure TAVLTree.FreeAndClear;
- procedure FreeNodeData(ANode: TAVLTreeNode);
- begin
- if ANode=nil then exit;
- FreeNodeData(ANode.Left);
- FreeNodeData(ANode.Right);
- if ANode.Data<>nil then TObject(ANode.Data).Free;
- ANode.Data:=nil;
- end;
- // TAVLTree.FreeAndClear
- begin
- // free all data
- FreeNodeData(Root);
- // free all nodes
- Clear;
- end;
- procedure TAVLTree.FreeAndDelete(ANode: TAVLTreeNode);
- var OldData: TObject;
- begin
- OldData:=TObject(ANode.Data);
- Delete(ANode);
- OldData.Free;
- end;
- function TAVLTree.Equals(Obj: TObject): boolean;
- begin
- if Obj is TAVLTree then
- Result:=IsEqual(TAVLTree(Obj),false)
- else
- Result:=inherited Equals(Obj);
- end;
- function TAVLTree.IsEqual(aTree: TAVLTree; CheckDataPointer: boolean): boolean;
- var
- MyNode, OtherNode: TAVLTreeNode;
- begin
- if aTree=Self then exit(true);
- Result:=false;
- if aTree=nil then exit;
- if Count<>aTree.Count then exit;
- if OnCompare<>aTree.OnCompare then exit;
- if OnObjectCompare<>aTree.OnObjectCompare then exit;
- if NodeClass<>aTree.NodeClass then exit;
- MyNode:=FindLowest;
- OtherNode:=aTree.FindLowest;
- while MyNode<>nil do begin
- if OtherNode=nil then exit;
- if CheckDataPointer then begin
- if MyNode.Data<>OtherNode.Data then exit;
- end else begin
- if Compare(MyNode.Data,OtherNode.Data)<>0 then exit;
- end;
- MyNode:=MyNode.Successor;
- OtherNode:=OtherNode.Successor;
- end;
- if OtherNode<>nil then exit;
- Result:=true;
- end;
- procedure TAVLTree.Assign(aTree: TAVLTree);
- procedure AssignNode(var MyNode: TAVLTreeNode; OtherNode: TAVLTreeNode);
- begin
- MyNode:=NewNode;
- MyNode.Data:=OtherNode.Data;
- MyNode.Balance:=OtherNode.Balance;
- if OtherNode.Left<>nil then begin
- AssignNode(MyNode.Left,OtherNode.Left);
- MyNode.Left.Parent:=MyNode;
- end;
- if OtherNode.Right<>nil then begin
- AssignNode(MyNode.Right,OtherNode.Right);
- MyNode.Right.Parent:=MyNode;
- end;
- end;
- begin
- if aTree=nil then
- raise Exception.Create('TAVLTree.Assign aTree=nil');
- if IsEqual(aTree,true) then exit;
- Clear;
- SetCompares(aTree.OnCompare,aTree.OnObjectCompare);
- NodeClass:=aTree.NodeClass;
- if aTree.Root<>nil then
- AssignNode(fRoot,aTree.Root);
- FCount:=aTree.Count;
- end;
- function TAVLTree.Compare(Data1, Data2: Pointer): integer;
- begin
- if Assigned(FOnCompare) then
- Result:=FOnCompare(Data1,Data2)
- else
- Result:=FOnObjectCompare(Self,Data1,Data2);
- end;
- procedure TAVLTree.WriteReportToStream(s: TStream);
- procedure WriteStr(const Txt: string);
- begin
- if Txt='' then exit;
- s.Write(Txt[1],length(Txt));
- end;
- procedure WriteTreeNode(ANode: TAVLTreeNode);
- var
- b: String;
- IsLeft: boolean;
- AParent: TAVLTreeNode;
- WasLeft: Boolean;
- begin
- if ANode=nil then exit;
- WriteTreeNode(ANode.Right);
- AParent:=ANode;
- WasLeft:=false;
- b:='';
- while AParent<>nil do begin
- if AParent.Parent=nil then begin
- if AParent=ANode then
- b:='--'+b
- else
- b:=' '+b;
- break;
- end;
- IsLeft:=AParent.Parent.Left=AParent;
- if AParent=ANode then begin
- if IsLeft then
- b:='\-'
- else
- b:='/-';
- end else begin
- if WasLeft=IsLeft then
- b:=' '+b
- else
- b:='| '+b;
- end;
- WasLeft:=IsLeft;
- AParent:=AParent.Parent;
- end;
- b:=b+NodeToReportStr(ANode)+LineEnding;
- WriteStr(b);
- WriteTreeNode(ANode.Left);
- end;
- // TAVLTree.WriteReportToStream
- begin
- WriteStr('-Start-of-AVL-Tree-------------------'+LineEnding);
- WriteTreeNode(fRoot);
- WriteStr('-End-Of-AVL-Tree---------------------'+LineEnding);
- end;
- function TAVLTree.NodeToReportStr(aNode: TAVLTreeNode): string;
- begin
- Result:=Format('%p Self=%p Parent=%p Balance=%d',
- [aNode.Data, Pointer(aNode),Pointer(aNode.Parent), aNode.Balance]);
- end;
- function TAVLTree.ReportAsString: string;
- var ms: TMemoryStream;
- begin
- Result:='';
- ms:=TMemoryStream.Create;
- try
- WriteReportToStream(ms);
- ms.Position:=0;
- SetLength(Result,ms.Size);
- if Result<>'' then
- ms.Read(Result[1],length(Result));
- finally
- ms.Free;
- end;
- end;
- procedure TAVLTree.SetOnCompare(const AValue: TListSortCompare);
- begin
- if AValue=nil then
- SetCompares(nil,FOnObjectCompare)
- else
- SetCompares(AValue,nil);
- end;
- procedure TAVLTree.SetNodeManager(NewMgr: TBaseAVLTreeNodeManager;
- AutoFree: boolean);
- // only allowed just after create.
- begin
- if fNodeMgr=NewMgr then exit;
- if Count>0 then
- raise Exception.Create('TAVLTree.SetNodeManager');
- if fNodeMgrAutoFree then
- FreeAndNil(fNodeMgr);
- fNodeMgr:=NewMgr;
- fNodeMgrAutoFree:=AutoFree;
- end;
- { TAVLTreeNode }
- function TAVLTreeNode.TreeDepth: integer;
- // longest WAY down. e.g. only one node => 0 !
- var LeftDepth, RightDepth: integer;
- begin
- if Left<>nil then
- LeftDepth:=Left.TreeDepth+1
- else
- LeftDepth:=0;
- if Right<>nil then
- RightDepth:=Right.TreeDepth+1
- else
- RightDepth:=0;
- if LeftDepth>RightDepth then
- Result:=LeftDepth
- else
- Result:=RightDepth;
- end;
- procedure TAVLTreeNode.ConsistencyCheck(Tree: TAVLTree);
- procedure E(Msg: string);
- begin
- raise Exception.Create('TAVLTreeNode.ConsistencyCheck: '+Msg);
- end;
- var
- LeftDepth: SizeInt;
- RightDepth: SizeInt;
- begin
- // test left child
- if Left<>nil then begin
- if Left.Parent<>Self then
- E('Left.Parent<>Self');
- if Tree.Compare(Left.Data,Data)>0 then
- E('Compare(Left.Data,Data)>0');
- Left.ConsistencyCheck(Tree);
- end;
- // test right child
- if Right<>nil then begin
- if Right.Parent<>Self then
- E('Right.Parent<>Self');
- if Tree.Compare(Data,Right.Data)>0 then
- E('Compare(Data,Right.Data)>0');
- Right.ConsistencyCheck(Tree);
- end;
- // test balance
- if Left<>nil then
- LeftDepth:=Left.TreeDepth+1
- else
- LeftDepth:=0;
- if Right<>nil then
- RightDepth:=Right.TreeDepth+1
- else
- RightDepth:=0;
- if Balance<>(RightDepth-LeftDepth) then
- E('Balance['+IntToStr(Balance)+']<>(RightDepth['+IntToStr(RightDepth)+']-LeftDepth['+IntToStr(LeftDepth)+'])');
- end;
- function TAVLTreeNode.GetCount: SizeInt;
- begin
- Result:=1;
- if Left<>nil then inc(Result,Left.GetCount);
- if Right<>nil then inc(Result,Right.GetCount);
- end;
- function TAVLTreeNode.Successor: TAVLTreeNode;
- begin
- Result:=Right;
- if Result<>nil then begin
- while (Result.Left<>nil) do Result:=Result.Left;
- end else begin
- Result:=Self;
- while (Result.Parent<>nil) and (Result.Parent.Right=Result) do
- Result:=Result.Parent;
- Result:=Result.Parent;
- end;
- end;
- function TAVLTreeNode.Precessor: TAVLTreeNode;
- begin
- Result:=Left;
- if Result<>nil then begin
- while (Result.Right<>nil) do Result:=Result.Right;
- end else begin
- Result:=Self;
- while (Result.Parent<>nil) and (Result.Parent.Left=Result) do
- Result:=Result.Parent;
- Result:=Result.Parent;
- end;
- end;
- procedure TAVLTreeNode.Clear;
- begin
- Parent:=nil;
- Left:=nil;
- Right:=nil;
- Balance:=0;
- Data:=nil;
- end;
- { TAVLTreeNodeMemManager }
- constructor TAVLTreeNodeMemManager.Create;
- begin
- {$IFDEF CheckAVLTreeNodeManager}
- FThreadId:=GetCurrentThreadId;
- {$ENDIF}
- inherited Create;
- FFirstFree:=nil;
- FFreeCount:=0;
- FCount:=0;
- FMinFree:=100;
- FMaxFreeRatio:=8; // 1:1
- end;
- destructor TAVLTreeNodeMemManager.Destroy;
- begin
- Clear;
- inherited Destroy;
- end;
- procedure TAVLTreeNodeMemManager.DisposeNode(ANode: TAVLTreeNode);
- begin
- if ANode=nil then exit;
- {$IFDEF CheckAVLTreeNodeManager}
- if GetCurrentThreadId<>FThreadId then
- raise Exception.Create('not thread safe!');
- {$ENDIF}
- if FCount < 0 then
- raise Exception.CreateFmt(
- '%s.DisposeNode: FCount (%d) is negative. Should not happen.'
- +' FFreeCount=%d, FMinFree=%d, FMaxFreeRatio=%d.',
- [ClassName, FCount, FFreeCount, FMinFree, FMaxFreeRatio]);
- if (FFreeCount<FMinFree) or (FFreeCount<((FCount shr 3)*FMaxFreeRatio)) then
- begin
- // add ANode to Free list
- ANode.Clear;
- ANode.Right:=FFirstFree;
- FFirstFree:=ANode;
- inc(FFreeCount);
- if (FFreeCount>(((8+FMaxFreeRatio)*FCount) shr 3)) then begin
- DisposeFirstFreeNode;
- DisposeFirstFreeNode;
- end;
- end else begin
- // free list full -> free the ANode
- ANode.Free;
- end;
- dec(FCount);
- end;
- function TAVLTreeNodeMemManager.NewNode: TAVLTreeNode;
- begin
- {$IFDEF CheckAVLTreeNodeManager}
- if GetCurrentThreadId<>FThreadId then
- raise Exception.Create('not thread safe!');
- {$ENDIF}
- if FFirstFree<>nil then begin
- // take from free list
- Result:=FFirstFree;
- FFirstFree:=FFirstFree.Right;
- Result.Right:=nil;
- dec(FFreeCount);
- end else begin
- // free list empty -> create new node
- Result:=TAVLTreeNode.Create;
- end;
- inc(FCount);
- end;
- procedure TAVLTreeNodeMemManager.Clear;
- var ANode: TAVLTreeNode;
- begin
- {$IFDEF CheckAVLTreeNodeManager}
- if GetCurrentThreadId<>FThreadId then
- raise Exception.Create('not thread safe!');
- {$ENDIF}
- while FFirstFree<>nil do begin
- ANode:=FFirstFree;
- FFirstFree:=FFirstFree.Right;
- ANode.Right:=nil;
- ANode.Free;
- end;
- FFreeCount:=0;
- end;
- procedure TAVLTreeNodeMemManager.SetMaxFreeRatio(NewValue: SizeInt);
- begin
- if NewValue<0 then NewValue:=0;
- if NewValue=FMaxFreeRatio then exit;
- FMaxFreeRatio:=NewValue;
- end;
- procedure TAVLTreeNodeMemManager.SetMinFree(NewValue: SizeInt);
- begin
- if NewValue<0 then NewValue:=0;
- if NewValue=FMinFree then exit;
- FMinFree:=NewValue;
- end;
- procedure TAVLTreeNodeMemManager.DisposeFirstFreeNode;
- var OldNode: TAVLTreeNode;
- begin
- if FFirstFree=nil then exit;
- OldNode:=FFirstFree;
- FFirstFree:=FFirstFree.Right;
- dec(FFreeCount);
- OldNode.Right:=nil;
- OldNode.Free;
- end;
- initialization
- NodeMemManager:=TAVLTreeNodeMemManager.Create;
- finalization
- NodeMemManager.Free;
- NodeMemManager:=nil;
- end.
|