tpsystools_4.04/source/StTree.pas

// Upgraded to Delphi 2009: Sebastian Zierer

(* ***** BEGIN LICENSE BLOCK *****
 * Version: MPL 1.1
 *
 * The contents of this file are subject to the Mozilla Public License Version
 * 1.1 (the "License"); you may not use this file except in compliance with
 * the License. You may obtain a copy of the License at
 * http://www.mozilla.org/MPL/
 *
 * Software distributed under the License is distributed on an "AS IS" basis,
 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
 * for the specific language governing rights and limitations under the
 * License.
 *
 * The Original Code is TurboPower SysTools
 *
 * The Initial Developer of the Original Code is
 * TurboPower Software
 *
 * Portions created by the Initial Developer are Copyright (C) 1996-2002
 * the Initial Developer. All Rights Reserved.
 *
 * Contributor(s):
 *
 * ***** END LICENSE BLOCK ***** *)

{*********************************************************}
{* SysTools: StTree.pas 4.04                             *}
{*********************************************************}
{* SysTools: AVL Tree class                              *}
{*********************************************************}

{$I StDefine.inc}

{Notes:
  - These binary trees are self-balancing in the AVL sense (the depth
    of any left branch differs by no more than one from the depth of the
    right branch).

  - Duplicate data is not allowed in a tree.

  - Nodes can be of type TStTreeNode or any descendant.

  - The Compare property of the TStContainer ancestor must be set to
    specify the sort order of the tree. The Compare function operates
    on Data pointers. The Data pointer could be typecast to a number
    (any integer type), to a string pointer, to a record pointer, or to
    an instance of a class.

  - Next and Prev should not be used to iterate through an entire tree.
    This is much slower than calling the Iterate method.
}

unit StTree;

interface

uses
  Windows,
  SysUtils, Classes, StConst, StBase;

type
  TStTreeNode = class(TStNode)
  {.Z+}
    protected
      tnPos  : array[Boolean] of TStTreeNode; {Child nodes}
      tnBal  : Integer;         {Used during balancing}

  {.Z-}
    public
      constructor Create(AData : Pointer); override;
        {-Initialize node}
  end;

  TStTree = class(TStContainer)
  {.Z+}
    protected
      trRoot : TStTreeNode;       {Root of tree}
      trIgnoreDups : Boolean;     {Ignore duplicates during Join?}

      procedure ForEachPointer(Action : TIteratePointerFunc; OtherData : pointer);
        override;
      function StoresPointers : boolean;
        override;
      procedure trInsertNode(N : TStTreeNode);

   {.Z-}
    public
      constructor Create(NodeClass : TStNodeClass); virtual;
        {-Initialize an empty tree}

      procedure LoadFromStream(S : TStream); override;
        {-Create a list and its data from a stream}
      procedure StoreToStream(S : TStream); override;
        {-Write a list and its data to a stream}

      procedure Clear; override;
        {-Remove all nodes from container but leave it instantiated}

      function Insert(Data : Pointer) : TStTreeNode;
        {-Add a new node}
      procedure Delete(Data : Pointer);
        {-Delete a node}
      function Find(Data : Pointer) : TStTreeNode;
        {-Return node that matches Data}

      procedure Assign(Source: TPersistent); override;
        {-Assign another container's contents to this one}
      procedure Join(T: TStTree; IgnoreDups : Boolean);
        {-Add tree T into this one and dispose T}
      function Split(Data : Pointer) : TStTree;
        {-Split tree, putting all nodes above and including Data into new tree}

      function Iterate(Action : TIterateFunc; Up : Boolean;
                       OtherData : Pointer) : TStTreeNode;
        {-Call Action for all the nodes, returning the last node visited}

      function First : TStTreeNode;
        {-Return the smallest-value node in the tree}
      function Last : TStTreeNode;
        {-Return the largest-value node in the tree}
      function Next(N : TStTreeNode) : TStTreeNode;
        {-Return the next node whose value is larger than N's}
      function Prev(N : TStTreeNode) : TStTreeNode;
        {-Return the largest node whose value is smaller than N's}
  end;

{.Z+}
  TStTreeClass = class of TStTree;
{.Z-}

{======================================================================}

implementation

{$IFDEF ThreadSafe}
var
  ClassCritSect : TRTLCriticalSection;
{$ENDIF}

procedure EnterClassCS;
begin
{$IFDEF ThreadSafe}
  EnterCriticalSection(ClassCritSect);
{$ENDIF}
end;

procedure LeaveClassCS;
begin
{$IFDEF ThreadSafe}
  LeaveCriticalSection(ClassCritSect);
{$ENDIF}
end;

const
  Left = False;
  Right = True;

{Following stack declarations are used to avoid recursion in all tree
 routines. Because the tree is AVL-balanced, a stack size of 40
 allows at least 2**32 elements in the tree without overflowing the
 stack.}

const
  StackSize = 40;

type
  StackNode =
    record
      Node : TStTreeNode;
      Comparison : Integer;
    end;
  StackArray = array[1..StackSize] of StackNode;

constructor TStTreeNode.Create(AData : Pointer);
begin
  inherited Create(AData);
end;

{----------------------------------------------------------------------}

function Sign(I : Integer) : Integer;
begin
  if I < 0 then
    Sign := -1
  else if I > 0 then
    Sign := +1
  else
    Sign := 0;
end;

procedure DelBalance(var P : TStTreeNode; var SubTreeDec : Boolean; CmpRes : Integer);
var
  P1, P2 : TStTreeNode;
  B1, B2 : Integer;
  LR : Boolean;
begin
  CmpRes := Sign(CmpRes);
  if P.tnBal = CmpRes then
    P.tnBal := 0
  else if P.tnBal = 0 then begin
    P.tnBal := -CmpRes;
    SubTreeDec := False;
  end else begin
    LR := (CmpRes < 0);
    P1 := P.tnPos[LR];
    B1 := P1.tnBal;
    if (B1 = 0) or (B1 = -CmpRes) then begin
      {Single RR or LL rotation}
      P.tnPos[LR] := P1.tnPos[not LR];
      P1.tnPos[not LR] := P;
      if B1 = 0 then begin
        P.tnBal := -CmpRes;
        P1.tnBal := CmpRes;
        SubTreeDec := False;
      end else begin
        P.tnBal := 0;
        P1.tnBal := 0;
      end;
      P := P1;
    end else begin
      {Double RL or LR rotation}
      P2 := P1.tnPos[not LR];
      B2 := P2.tnBal;
      P1.tnPos[not LR] := P2.tnPos[LR];
      P2.tnPos[LR] := P1;
      P.tnPos[LR] := P2.tnPos[not LR];
      P2.tnPos[not LR] := P;
      if B2 = -CmpRes then
        P.tnBal := CmpRes
      else
        P.tnBal := 0;
      if B2 = CmpRes then
        P1.tnBal := -CmpRes
      else
        P1.tnBal := 0;
      P := P2;
      P2.tnBal := 0;
    end;
  end;
end;

procedure InsBalance(var P : TStTreeNode; var SubTreeInc : Boolean;
                     CmpRes : Integer);
var
  P1 : TStTreeNode;
  P2 : TStTreeNode;
  LR : Boolean;
begin
  CmpRes := Sign(CmpRes);
  if P.tnBal = -CmpRes then begin
    P.tnBal := 0;
    SubTreeInc := False;
  end else if P.tnBal = 0 then
    P.tnBal := CmpRes
  else begin
    LR := (CmpRes > 0);
    P1 := P.tnPos[LR];
    if P1.tnBal = CmpRes then begin
      P.tnPos[LR] := P1.tnPos[not LR];
      P1.tnPos[not LR] := P;
      P.tnBal := 0;
      P := P1;
    end else begin
      P2 := P1.tnPos[not LR];
      P1.tnPos[not LR] := P2.tnPos[LR];
      P2.tnPos[LR] := P1;
      P.tnPos[LR] := P2.tnPos[not LR];
      P2.tnPos[not LR] := P;
      if P2.tnBal = CmpRes then
        P.tnBal := -CmpRes
      else
        P.tnBal := 0;
      if P2.tnBal = -CmpRes then
        P1.tnBal := CmpRes
      else
        P1.tnBal := 0;
      P := P2;
    end;
    P.tnBal := 0;
    SubTreeInc := False;
  end;
end;

function JoinNode(Container : TStContainer; Node : TStNode;
                  OtherData : Pointer) : Boolean; far;
var
  N : TStTreeNode;
begin
  Result := True;
  N := TStTree(OtherData).Find(Node.Data);
  if Assigned(N) then
    if TStTree(OtherData).trIgnoreDups then begin
      Node.Free;
      Exit;
    end else
      RaiseContainerError(stscDupNode);

  with TStTreeNode(Node) do begin
    tnPos[Left] := nil;
    tnPos[Right] := nil;
    tnBal := 0;
  end;
  TStTree(OtherData).trInsertNode(TStTreeNode(Node));
end;

type
  SplitRec =
  record
    SData : Pointer;
    STree : TStTree;
  end;

function SplitTree(Container : TStContainer; Node : TStNode;
                   OtherData : Pointer) : Boolean; far;
var
  D : Pointer;
begin
  Result := True;
  if Container.DoCompare(Node.Data, SplitRec(OtherData^).SData) >= 0 then begin
    D := Node.Data;
    TStTree(Container).Delete(D);
    SplitRec(OtherData^).STree.Insert(D);
  end;
end;

type
  TStoreInfo = record
    Wtr : TWriter;
    SDP : TStoreDataProc;
  end;

function StoreNode(Container : TStContainer; Node : TStNode;
                   OtherData : Pointer) : Boolean; far;
  begin
    Result := True;
    with TStoreInfo(OtherData^) do
      SDP(Wtr, Node.Data);
  end;

function AssignData(Container : TStContainer;
                    Data, OtherData : Pointer) : Boolean; far;
  var
    OurTree : TStTree absolute OtherData;
  begin
    OurTree.Insert(Data);
    Result := true;
  end;

{----------------------------------------------------------------------}
procedure TStTree.Assign(Source: TPersistent);
  begin
    {$IFDEF ThreadSafe}
    EnterCS;
    try
    {$ENDIF}
      {The only containers that we allow to be assigned to a tree are
         - a SysTools linked list (TStList)
         - another SysTools binary search tree (TStTree)
         - a SysTools collection (TStCollection, TStSortedCollection)}
      if not AssignPointers(Source, AssignData) then
        inherited Assign(Source);
    {$IFDEF ThreadSafe}
    finally
      LeaveCS;
    end;{try..finally}
    {$ENDIF}
  end;

procedure TStTree.Clear;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    if conNodeProt = 0 then
      Iterate(DestroyNode, True, nil);
    trRoot := nil;
    FCount := 0;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStTree.ForEachPointer(Action : TIteratePointerFunc;
                                 OtherData : pointer);
var
  P : TStTreeNode;
  Q : TStTreeNode;
  StackP : Integer;
  Stack : StackArray;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    StackP := 0;
    P := trRoot;
    repeat
      while Assigned(P) do begin
        Inc(StackP);
        Stack[StackP].Node := P;
        P := P.tnPos[false];
      end;
      if StackP = 0 then begin
        Exit;
      end;

      P := Stack[StackP].Node;
      Dec(StackP);
      Q := P;
      P := P.tnPos[true];
      if not Action(Self, Q.Data, OtherData) then begin
        Exit;
      end;
    until False;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

function TStTree.StoresPointers : boolean;
begin
  Result := true;
end;

constructor TStTree.Create(NodeClass : TStNodeClass);
begin
  CreateContainer(NodeClass, 0);
end;

procedure TStTree.Delete(Data : Pointer);
var
  P : TStTreeNode;
  Q : TStTreeNode;
  TmpData : Pointer;
  CmpRes : Integer;
  Found : Boolean;
  SubTreeDec : Boolean;
  StackP : Integer;
  Stack : StackArray;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    P := trRoot;
    if not Assigned(P) then
      Exit;

    {Find node to delete and stack the nodes to reach it}
    Found := False;
    StackP := 0;
    while not Found do begin
      CmpRes := DoCompare(Data, P.Data);
      Inc(StackP);
      if CmpRes = 0 then begin
        {Found node to delete}
        with Stack[StackP] do begin
          Node := P;
          Comparison := -1;
        end;
        Found := True;
      end else begin
        with Stack[StackP] do begin
          Node := P;
          Comparison := CmpRes;
        end;
        P := P.tnPos[CmpRes > 0];
        if not Assigned(P) then
          {Node to delete not found}
          Exit;
      end;
    end;

    {Delete the node found}
    Q := P;
    if (not Assigned(Q.tnPos[Right])) or (not Assigned(Q.tnPos[Left])) then begin
      {Node has at most one branch}
      Dec(StackP);
      P := Q.tnPos[Assigned(Q.tnPos[Right])];
      if StackP = 0 then
        trRoot := P
      else with Stack[StackP] do
        Node.tnPos[Comparison > 0] := P;
    end else begin
      {Node has two branches; stack nodes to reach one with no right child}
      P := Q.tnPos[Left];
      while Assigned(P.tnPos[Right]) do begin
        Inc(StackP);
        with Stack[StackP] do begin
          Node := P;
          Comparison := 1;
        end;
        P := P.tnPos[Right];
      end;

      {Swap the node to delete with the terminal node}
      TmpData := Q.Data;
      Q.Data := P.Data;
      Q := P;
      with Stack[StackP] do begin
        Node.tnPos[Comparison > 0].Data := TmpData;
        Node.tnPos[Comparison > 0] := P.tnPos[Left];
      end;
    end;

    {Dispose of the deleted node}
    DisposeNodeData(Q);
    Q.Free;
    Dec(FCount);

    {Unwind the stack and rebalance}
    SubTreeDec := True;
    while (StackP > 0) and SubTreeDec do begin
      if StackP = 1 then
        DelBalance(trRoot, SubTreeDec, Stack[1].Comparison)
      else with Stack[StackP-1] do
        DelBalance(Node.tnPos[Comparison > 0], SubTreeDec, Stack[StackP].Comparison);
      dec(StackP);
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

function TStTree.Find(Data : Pointer) : TStTreeNode;
var
  P : TStTreeNode;
  CmpRes : Integer;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    P := trRoot;
    while Assigned(P) do begin
      CmpRes := DoCompare(Data, P.Data);
      if CmpRes = 0 then begin
        Result := P;
        Exit;
      end else
        P := P.tnPos[CmpRes > 0];
    end;

    Result := nil;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

function TStTree.First : TStTreeNode;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    if Count = 0 then
      Result := nil
    else begin
      Result := trRoot;
      while Assigned(Result.tnPos[Left]) do
        Result := Result.tnPos[Left];
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

function TStTree.Insert(Data : Pointer) : TStTreeNode;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    {Create the node}
    Result := TStTreeNode(conNodeClass.Create(Data));
    trInsertNode(Result);
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

function TStTree.Iterate(Action : TIterateFunc; Up : Boolean;
                         OtherData : Pointer) : TStTreeNode;
var
  P : TStTreeNode;
  Q : TStTreeNode;
  StackP : Integer;
  Stack : StackArray;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    StackP := 0;
    P := trRoot;
    repeat
      while Assigned(P) do begin
        Inc(StackP);
        Stack[StackP].Node := P;
        P := P.tnPos[not Up];
      end;
      if StackP = 0 then begin
        Result := nil;
        Exit;
      end;

      P := Stack[StackP].Node;
      Dec(StackP);
      Q := P;
      P := P.tnPos[Up];
      if not Action(Self, Q, OtherData) then begin
        Result := Q;
        Exit;
      end;
    until False;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStTree.Join(T: TStTree; IgnoreDups : Boolean);
begin
{$IFDEF ThreadSafe}
  EnterClassCS;
  EnterCS;
  T.EnterCS;
  try
{$ENDIF}
    trIgnoreDups := IgnoreDups;
    T.Iterate(JoinNode, True, Self);
    T.IncNodeProtection;
    T.Free;
{$IFDEF ThreadSafe}
  finally
    T.LeaveCS;
    LeaveCS;
    LeaveClassCS;
  end;
{$ENDIF}
end;

function TStTree.Last : TStTreeNode;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    if Count = 0 then
      Result := nil
    else begin
      Result := trRoot;
      while Assigned(Result.tnPos[Right]) do
        Result := Result.tnPos[Right];
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

function TStTree.Next(N : TStTreeNode) : TStTreeNode;
var
  Found : Word;
  P : TStTreeNode;
  StackP : Integer;
  Stack : StackArray;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    Result := nil;
    Found := 0;
    StackP := 0;
    P := trRoot;
    repeat
      while Assigned(P) do begin
        Inc(StackP);
        Stack[StackP].Node := P;
        P := P.tnPos[Left];
      end;
      if StackP = 0 then
        Exit;

      P := Stack[StackP].Node;
      Dec(StackP);
      if Found = 1 then begin
        Result := P;
        Exit;
      end;
      if P = N then
        Inc(Found);
      P := P.tnPos[Right];
    until False;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

function TStTree.Prev(N : TStTreeNode) : TStTreeNode;
var
  Found : Word;
  P : TStTreeNode;
  StackP : Integer;
  Stack : StackArray;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    Result := nil;
    Found := 0;
    StackP := 0;
    P := trRoot;
    repeat
      while Assigned(P) do begin
        Inc(StackP);
        Stack[StackP].Node := P;
        P := P.tnPos[Right];
      end;
      if StackP = 0 then
        Exit;

      P := Stack[StackP].Node;
      Dec(StackP);
      if Found = 1 then begin
        Result := P;
        Exit;
      end;
      if P = N then
        Inc(Found);
      P := P.tnPos[Left];
    until False;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

function TStTree.Split(Data : Pointer) : TStTree;
var
  SR : SplitRec;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    {Create and initialize the new tree}
    Result := TStTreeClass(ClassType).Create(conNodeClass);
    Result.Compare := Compare;
    Result.OnCompare := OnCompare;
    Result.DisposeData := DisposeData;
    Result.OnDisposeData := OnDisposeData;

    {Scan all elements to transfer some to new tree}
    SR.SData := Data;
    SR.STree := Result;
    {Prevent SplitTree from disposing of node data it moves from old tree to new}
    DisposeData := nil;
    OnDisposeData := nil;
    Iterate(SplitTree, True, @SR);
    {Restore DisposeData property}
    DisposeData := Result.DisposeData;
    OnDisposeData := Result.OnDisposeData;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStTree.trInsertNode(N : TStTreeNode);
var
  P : TStTreeNode;
  CmpRes : Integer;
  StackP : Integer;
  Stack : StackArray;
  SubTreeInc : Boolean;
begin
  if not Assigned(N) then
    Exit;

  {Handle first node}
  P := trRoot;
  if not Assigned(P) then begin
    trRoot := N;
    Inc(FCount);
    Exit;
  end;

  {Find where new node should fit in tree}
  StackP := 0;
  CmpRes := 0; {prevent D32 from generating a warning}
  while Assigned(P) do begin
    CmpRes := DoCompare(N.Data, P.Data);
    if CmpRes = 0 then begin
      {New node matches a node already in the tree, free it}
      N.Free;
      RaiseContainerError(stscDupNode);
    end;
    Inc(StackP);
    with Stack[StackP] do begin
      Node := P;
      Comparison := CmpRes;
    end;
    P := P.tnPos[CmpRes > 0];
  end;

  {Insert new node}
  Stack[StackP].Node.tnPos[CmpRes > 0] := N;
  Inc(FCount);

  {Unwind the stack and rebalance}
  SubTreeInc := True;
  while (StackP > 0) and SubTreeInc do begin
    if StackP = 1 then
      InsBalance(trRoot, SubTreeInc, Stack[1].Comparison)
    else with Stack[StackP-1] do
      InsBalance(Node.tnPos[Comparison > 0], SubTreeInc, Stack[StackP].Comparison);
    dec(StackP);
  end;
end;

procedure TStTree.LoadFromStream(S : TStream);
var
  Data : pointer;
  Reader : TReader;
  StreamedClass : TPersistentClass;
  StreamedNodeClass : TPersistentClass;
  StreamedClassName : string;
  StreamedNodeClassName : string;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    Clear;
    Reader := TReader.Create(S, 1024);
    try
      with Reader do
        begin
          StreamedClassName := ReadString;
          StreamedClass := GetClass(StreamedClassName);
          if (StreamedClass = nil) then
            RaiseContainerErrorFmt(stscUnknownClass, [StreamedClassName]);
          if (not IsOrInheritsFrom(StreamedClass, Self.ClassType)) or
              (not IsOrInheritsFrom(TStTree, StreamedClass)) then
            RaiseContainerError(stscWrongClass);
          StreamedNodeClassName := ReadString;
          StreamedNodeClass := GetClass(StreamedNodeClassName);
          if (StreamedNodeClass = nil) then
            RaiseContainerErrorFmt(stscUnknownNodeClass, [StreamedNodeClassName]);
          if (not IsOrInheritsFrom(StreamedNodeClass, conNodeClass)) or
              (not IsOrInheritsFrom(TStTreeNode, StreamedNodeClass)) then
            RaiseContainerError(stscWrongNodeClass);
          ReadListBegin;
          while not EndOfList do
            begin
              Data := DoLoadData(Reader);
              Insert(Data);
            end;
          ReadListEnd;
        end;
    finally
      Reader.Free;
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStTree.StoreToStream(S : TStream);
var
  Writer : TWriter;
  StoreInfo : TStoreInfo;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    Writer := TWriter.Create(S, 1024);
    try
      with Writer do begin
        WriteString(Self.ClassName);
        WriteString(conNodeClass.ClassName);
        WriteListBegin;
        StoreInfo.Wtr := Writer;
        StoreInfo.SDP := StoreData;
        Iterate(StoreNode, false, @StoreInfo);
        WriteListEnd;
      end;
    finally
      Writer.Free;
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

{$IFDEF ThreadSafe}
initialization
  Windows.InitializeCriticalSection(ClassCritSect);
finalization
  Windows.DeleteCriticalSection(ClassCritSect);
{$ENDIF}
end.
1	torben	2671	// Upgraded to Delphi 2009: Sebastian Zierer
2
3			(* *** BEGIN LICENSE BLOCK ***
4			* Version: MPL 1.1
5			*
6			* The contents of this file are subject to the Mozilla Public License Version
7			* 1.1 (the "License"); you may not use this file except in compliance with
8			* the License. You may obtain a copy of the License at
9			* http://www.mozilla.org/MPL/
10			*
11			* Software distributed under the License is distributed on an "AS IS" basis,
12			* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
13			* for the specific language governing rights and limitations under the
14			* License.
15			*
16			* The Original Code is TurboPower SysTools
17			*
18			* The Initial Developer of the Original Code is
19			* TurboPower Software
20			*
21			* Portions created by the Initial Developer are Copyright (C) 1996-2002
22			* the Initial Developer. All Rights Reserved.
23			*
24			* Contributor(s):
25			*
26			* *** END LICENSE BLOCK *** *)
27
28			{*********************************************************}
29			{* SysTools: StTree.pas 4.04 *}
30			{*********************************************************}
31			{* SysTools: AVL Tree class *}
32			{*********************************************************}
33
34			{$I StDefine.inc}
35
36			{Notes:
37			- These binary trees are self-balancing in the AVL sense (the depth
38			of any left branch differs by no more than one from the depth of the
39			right branch).
40
41			- Duplicate data is not allowed in a tree.
42
43			- Nodes can be of type TStTreeNode or any descendant.
44
45			- The Compare property of the TStContainer ancestor must be set to
46			specify the sort order of the tree. The Compare function operates
47			on Data pointers. The Data pointer could be typecast to a number
48			(any integer type), to a string pointer, to a record pointer, or to
49			an instance of a class.
50
51			- Next and Prev should not be used to iterate through an entire tree.
52			This is much slower than calling the Iterate method.
53			}
54
55			unit StTree;
56
57			interface
58
59			uses
60			Windows,
61			SysUtils, Classes, StConst, StBase;
62
63			type
64			TStTreeNode = class(TStNode)
65			{.Z+}
66			protected
67			tnPos : array[Boolean] of TStTreeNode; {Child nodes}
68			tnBal : Integer; {Used during balancing}
69
70			{.Z-}
71			public
72			constructor Create(AData : Pointer); override;
73			{-Initialize node}
74			end;
75
76			TStTree = class(TStContainer)
77			{.Z+}
78			protected
79			trRoot : TStTreeNode; {Root of tree}
80			trIgnoreDups : Boolean; {Ignore duplicates during Join?}
81
82			procedure ForEachPointer(Action : TIteratePointerFunc; OtherData : pointer);
83			override;
84			function StoresPointers : boolean;
85			override;
86			procedure trInsertNode(N : TStTreeNode);
87
88			{.Z-}
89			public
90			constructor Create(NodeClass : TStNodeClass); virtual;
91			{-Initialize an empty tree}
92
93			procedure LoadFromStream(S : TStream); override;
94			{-Create a list and its data from a stream}
95			procedure StoreToStream(S : TStream); override;
96			{-Write a list and its data to a stream}
97
98			procedure Clear; override;
99			{-Remove all nodes from container but leave it instantiated}
100
101			function Insert(Data : Pointer) : TStTreeNode;
102			{-Add a new node}
103			procedure Delete(Data : Pointer);
104			{-Delete a node}
105			function Find(Data : Pointer) : TStTreeNode;
106			{-Return node that matches Data}
107
108			procedure Assign(Source: TPersistent); override;
109			{-Assign another container's contents to this one}
110			procedure Join(T: TStTree; IgnoreDups : Boolean);
111			{-Add tree T into this one and dispose T}
112			function Split(Data : Pointer) : TStTree;
113			{-Split tree, putting all nodes above and including Data into new tree}
114
115			function Iterate(Action : TIterateFunc; Up : Boolean;
116			OtherData : Pointer) : TStTreeNode;
117			{-Call Action for all the nodes, returning the last node visited}
118
119			function First : TStTreeNode;
120			{-Return the smallest-value node in the tree}
121			function Last : TStTreeNode;
122			{-Return the largest-value node in the tree}
123			function Next(N : TStTreeNode) : TStTreeNode;
124			{-Return the next node whose value is larger than N's}
125			function Prev(N : TStTreeNode) : TStTreeNode;
126			{-Return the largest node whose value is smaller than N's}
127			end;
128
129			{.Z+}
130			TStTreeClass = class of TStTree;
131			{.Z-}
132
133			{======================================================================}
134
135			implementation
136
137			{$IFDEF ThreadSafe}
138			var
139			ClassCritSect : TRTLCriticalSection;
140			{$ENDIF}
141
142			procedure EnterClassCS;
143			begin
144			{$IFDEF ThreadSafe}
145			EnterCriticalSection(ClassCritSect);
146			{$ENDIF}
147			end;
148
149			procedure LeaveClassCS;
150			begin
151			{$IFDEF ThreadSafe}
152			LeaveCriticalSection(ClassCritSect);
153			{$ENDIF}
154			end;
155
156			const
157			Left = False;
158			Right = True;
159
160			{Following stack declarations are used to avoid recursion in all tree
161			routines. Because the tree is AVL-balanced, a stack size of 40
162			allows at least 2**32 elements in the tree without overflowing the
163			stack.}
164
165			const
166			StackSize = 40;
167
168			type
169			StackNode =
170			record
171			Node : TStTreeNode;
172			Comparison : Integer;
173			end;
174			StackArray = array[1..StackSize] of StackNode;
175
176			constructor TStTreeNode.Create(AData : Pointer);
177			begin
178			inherited Create(AData);
179			end;
180
181			{----------------------------------------------------------------------}
182
183			function Sign(I : Integer) : Integer;
184			begin
185			if I < 0 then
186			Sign := -1
187			else if I > 0 then
188			Sign := +1
189			else
190			Sign := 0;
191			end;
192
193			procedure DelBalance(var P : TStTreeNode; var SubTreeDec : Boolean; CmpRes : Integer);
194			var
195			P1, P2 : TStTreeNode;
196			B1, B2 : Integer;
197			LR : Boolean;
198			begin
199			CmpRes := Sign(CmpRes);
200			if P.tnBal = CmpRes then
201			P.tnBal := 0
202			else if P.tnBal = 0 then begin
203			P.tnBal := -CmpRes;
204			SubTreeDec := False;
205			end else begin
206			LR := (CmpRes < 0);
207			P1 := P.tnPos[LR];
208			B1 := P1.tnBal;
209			if (B1 = 0) or (B1 = -CmpRes) then begin
210			{Single RR or LL rotation}
211			P.tnPos[LR] := P1.tnPos[not LR];
212			P1.tnPos[not LR] := P;
213			if B1 = 0 then begin
214			P.tnBal := -CmpRes;
215			P1.tnBal := CmpRes;
216			SubTreeDec := False;
217			end else begin
218			P.tnBal := 0;
219			P1.tnBal := 0;
220			end;
221			P := P1;
222			end else begin
223			{Double RL or LR rotation}
224			P2 := P1.tnPos[not LR];
225			B2 := P2.tnBal;
226			P1.tnPos[not LR] := P2.tnPos[LR];
227			P2.tnPos[LR] := P1;
228			P.tnPos[LR] := P2.tnPos[not LR];
229			P2.tnPos[not LR] := P;
230			if B2 = -CmpRes then
231			P.tnBal := CmpRes
232			else
233			P.tnBal := 0;
234			if B2 = CmpRes then
235			P1.tnBal := -CmpRes
236			else
237			P1.tnBal := 0;
238			P := P2;
239			P2.tnBal := 0;
240			end;
241			end;
242			end;
243
244			procedure InsBalance(var P : TStTreeNode; var SubTreeInc : Boolean;
245			CmpRes : Integer);
246			var
247			P1 : TStTreeNode;
248			P2 : TStTreeNode;
249			LR : Boolean;
250			begin
251			CmpRes := Sign(CmpRes);
252			if P.tnBal = -CmpRes then begin
253			P.tnBal := 0;
254			SubTreeInc := False;
255			end else if P.tnBal = 0 then
256			P.tnBal := CmpRes
257			else begin
258			LR := (CmpRes > 0);
259			P1 := P.tnPos[LR];
260			if P1.tnBal = CmpRes then begin
261			P.tnPos[LR] := P1.tnPos[not LR];
262			P1.tnPos[not LR] := P;
263			P.tnBal := 0;
264			P := P1;
265			end else begin
266			P2 := P1.tnPos[not LR];
267			P1.tnPos[not LR] := P2.tnPos[LR];
268			P2.tnPos[LR] := P1;
269			P.tnPos[LR] := P2.tnPos[not LR];
270			P2.tnPos[not LR] := P;
271			if P2.tnBal = CmpRes then
272			P.tnBal := -CmpRes
273			else
274			P.tnBal := 0;
275			if P2.tnBal = -CmpRes then
276			P1.tnBal := CmpRes
277			else
278			P1.tnBal := 0;
279			P := P2;
280			end;
281			P.tnBal := 0;
282			SubTreeInc := False;
283			end;
284			end;
285
286			function JoinNode(Container : TStContainer; Node : TStNode;
287			OtherData : Pointer) : Boolean; far;
288			var
289			N : TStTreeNode;
290			begin
291			Result := True;
292			N := TStTree(OtherData).Find(Node.Data);
293			if Assigned(N) then
294			if TStTree(OtherData).trIgnoreDups then begin
295			Node.Free;
296			Exit;
297			end else
298			RaiseContainerError(stscDupNode);
299
300			with TStTreeNode(Node) do begin
301			tnPos[Left] := nil;
302			tnPos[Right] := nil;
303			tnBal := 0;
304			end;
305			TStTree(OtherData).trInsertNode(TStTreeNode(Node));
306			end;
307
308			type
309			SplitRec =
310			record
311			SData : Pointer;
312			STree : TStTree;
313			end;
314
315			function SplitTree(Container : TStContainer; Node : TStNode;
316			OtherData : Pointer) : Boolean; far;
317			var
318			D : Pointer;
319			begin
320			Result := True;
321			if Container.DoCompare(Node.Data, SplitRec(OtherData^).SData) >= 0 then begin
322			D := Node.Data;
323			TStTree(Container).Delete(D);
324			SplitRec(OtherData^).STree.Insert(D);
325			end;
326			end;
327
328			type
329			TStoreInfo = record
330			Wtr : TWriter;
331			SDP : TStoreDataProc;
332			end;
333
334			function StoreNode(Container : TStContainer; Node : TStNode;
335			OtherData : Pointer) : Boolean; far;
336			begin
337			Result := True;
338			with TStoreInfo(OtherData^) do
339			SDP(Wtr, Node.Data);
340			end;
341
342			function AssignData(Container : TStContainer;
343			Data, OtherData : Pointer) : Boolean; far;
344			var
345			OurTree : TStTree absolute OtherData;
346			begin
347			OurTree.Insert(Data);
348			Result := true;
349			end;
350
351			{----------------------------------------------------------------------}
352			procedure TStTree.Assign(Source: TPersistent);
353			begin
354			{$IFDEF ThreadSafe}
355			EnterCS;
356			try
357			{$ENDIF}
358			{The only containers that we allow to be assigned to a tree are
359			- a SysTools linked list (TStList)
360			- another SysTools binary search tree (TStTree)
361			- a SysTools collection (TStCollection, TStSortedCollection)}
362			if not AssignPointers(Source, AssignData) then
363			inherited Assign(Source);
364			{$IFDEF ThreadSafe}
365			finally
366			LeaveCS;
367			end;{try..finally}
368			{$ENDIF}
369			end;
370
371			procedure TStTree.Clear;
372			begin
373			{$IFDEF ThreadSafe}
374			EnterCS;
375			try
376			{$ENDIF}
377			if conNodeProt = 0 then
378			Iterate(DestroyNode, True, nil);
379			trRoot := nil;
380			FCount := 0;
381			{$IFDEF ThreadSafe}
382			finally
383			LeaveCS;
384			end;
385			{$ENDIF}
386			end;
387
388			procedure TStTree.ForEachPointer(Action : TIteratePointerFunc;
389			OtherData : pointer);
390			var
391			P : TStTreeNode;
392			Q : TStTreeNode;
393			StackP : Integer;
394			Stack : StackArray;
395			begin
396			{$IFDEF ThreadSafe}
397			EnterCS;
398			try
399			{$ENDIF}
400			StackP := 0;
401			P := trRoot;
402			repeat
403			while Assigned(P) do begin
404			Inc(StackP);
405			Stack[StackP].Node := P;
406			P := P.tnPos[false];
407			end;
408			if StackP = 0 then begin
409			Exit;
410			end;
411
412			P := Stack[StackP].Node;
413			Dec(StackP);
414			Q := P;
415			P := P.tnPos[true];
416			if not Action(Self, Q.Data, OtherData) then begin
417			Exit;
418			end;
419			until False;
420			{$IFDEF ThreadSafe}
421			finally
422			LeaveCS;
423			end;
424			{$ENDIF}
425			end;
426
427			function TStTree.StoresPointers : boolean;
428			begin
429			Result := true;
430			end;
431
432			constructor TStTree.Create(NodeClass : TStNodeClass);
433			begin
434			CreateContainer(NodeClass, 0);
435			end;
436
437			procedure TStTree.Delete(Data : Pointer);
438			var
439			P : TStTreeNode;
440			Q : TStTreeNode;
441			TmpData : Pointer;
442			CmpRes : Integer;
443			Found : Boolean;
444			SubTreeDec : Boolean;
445			StackP : Integer;
446			Stack : StackArray;
447			begin
448			{$IFDEF ThreadSafe}
449			EnterCS;
450			try
451			{$ENDIF}
452			P := trRoot;
453			if not Assigned(P) then
454			Exit;
455
456			{Find node to delete and stack the nodes to reach it}
457			Found := False;
458			StackP := 0;
459			while not Found do begin
460			CmpRes := DoCompare(Data, P.Data);
461			Inc(StackP);
462			if CmpRes = 0 then begin
463			{Found node to delete}
464			with Stack[StackP] do begin
465			Node := P;
466			Comparison := -1;
467			end;
468			Found := True;
469			end else begin
470			with Stack[StackP] do begin
471			Node := P;
472			Comparison := CmpRes;
473			end;
474			P := P.tnPos[CmpRes > 0];
475			if not Assigned(P) then
476			{Node to delete not found}
477			Exit;
478			end;
479			end;
480
481			{Delete the node found}
482			Q := P;
483			if (not Assigned(Q.tnPos[Right])) or (not Assigned(Q.tnPos[Left])) then begin
484			{Node has at most one branch}
485			Dec(StackP);
486			P := Q.tnPos[Assigned(Q.tnPos[Right])];
487			if StackP = 0 then
488			trRoot := P
489			else with Stack[StackP] do
490			Node.tnPos[Comparison > 0] := P;
491			end else begin
492			{Node has two branches; stack nodes to reach one with no right child}
493			P := Q.tnPos[Left];
494			while Assigned(P.tnPos[Right]) do begin
495			Inc(StackP);
496			with Stack[StackP] do begin
497			Node := P;
498			Comparison := 1;
499			end;
500			P := P.tnPos[Right];
501			end;
502
503			{Swap the node to delete with the terminal node}
504			TmpData := Q.Data;
505			Q.Data := P.Data;
506			Q := P;
507			with Stack[StackP] do begin
508			Node.tnPos[Comparison > 0].Data := TmpData;
509			Node.tnPos[Comparison > 0] := P.tnPos[Left];
510			end;
511			end;
512
513			{Dispose of the deleted node}
514			DisposeNodeData(Q);
515			Q.Free;
516			Dec(FCount);
517
518			{Unwind the stack and rebalance}
519			SubTreeDec := True;
520			while (StackP > 0) and SubTreeDec do begin
521			if StackP = 1 then
522			DelBalance(trRoot, SubTreeDec, Stack[1].Comparison)
523			else with Stack[StackP-1] do
524			DelBalance(Node.tnPos[Comparison > 0], SubTreeDec, Stack[StackP].Comparison);
525			dec(StackP);
526			end;
527			{$IFDEF ThreadSafe}
528			finally
529			LeaveCS;
530			end;
531			{$ENDIF}
532			end;
533
534			function TStTree.Find(Data : Pointer) : TStTreeNode;
535			var
536			P : TStTreeNode;
537			CmpRes : Integer;
538			begin
539			{$IFDEF ThreadSafe}
540			EnterCS;
541			try
542			{$ENDIF}
543			P := trRoot;
544			while Assigned(P) do begin
545			CmpRes := DoCompare(Data, P.Data);
546			if CmpRes = 0 then begin
547			Result := P;
548			Exit;
549			end else
550			P := P.tnPos[CmpRes > 0];
551			end;
552
553			Result := nil;
554			{$IFDEF ThreadSafe}
555			finally
556			LeaveCS;
557			end;
558			{$ENDIF}
559			end;
560
561			function TStTree.First : TStTreeNode;
562			begin
563			{$IFDEF ThreadSafe}
564			EnterCS;
565			try
566			{$ENDIF}
567			if Count = 0 then
568			Result := nil
569			else begin
570			Result := trRoot;
571			while Assigned(Result.tnPos[Left]) do
572			Result := Result.tnPos[Left];
573			end;
574			{$IFDEF ThreadSafe}
575			finally
576			LeaveCS;
577			end;
578			{$ENDIF}
579			end;
580
581			function TStTree.Insert(Data : Pointer) : TStTreeNode;
582			begin
583			{$IFDEF ThreadSafe}
584			EnterCS;
585			try
586			{$ENDIF}
587			{Create the node}
588			Result := TStTreeNode(conNodeClass.Create(Data));
589			trInsertNode(Result);
590			{$IFDEF ThreadSafe}
591			finally
592			LeaveCS;
593			end;
594			{$ENDIF}
595			end;
596
597			function TStTree.Iterate(Action : TIterateFunc; Up : Boolean;
598			OtherData : Pointer) : TStTreeNode;
599			var
600			P : TStTreeNode;
601			Q : TStTreeNode;
602			StackP : Integer;
603			Stack : StackArray;
604			begin
605			{$IFDEF ThreadSafe}
606			EnterCS;
607			try
608			{$ENDIF}
609			StackP := 0;
610			P := trRoot;
611			repeat
612			while Assigned(P) do begin
613			Inc(StackP);
614			Stack[StackP].Node := P;
615			P := P.tnPos[not Up];
616			end;
617			if StackP = 0 then begin
618			Result := nil;
619			Exit;
620			end;
621
622			P := Stack[StackP].Node;
623			Dec(StackP);
624			Q := P;
625			P := P.tnPos[Up];
626			if not Action(Self, Q, OtherData) then begin
627			Result := Q;
628			Exit;
629			end;
630			until False;
631			{$IFDEF ThreadSafe}
632			finally
633			LeaveCS;
634			end;
635			{$ENDIF}
636			end;
637
638			procedure TStTree.Join(T: TStTree; IgnoreDups : Boolean);
639			begin
640			{$IFDEF ThreadSafe}
641			EnterClassCS;
642			EnterCS;
643			T.EnterCS;
644			try
645			{$ENDIF}
646			trIgnoreDups := IgnoreDups;
647			T.Iterate(JoinNode, True, Self);
648			T.IncNodeProtection;
649			T.Free;
650			{$IFDEF ThreadSafe}
651			finally
652			T.LeaveCS;
653			LeaveCS;
654			LeaveClassCS;
655			end;
656			{$ENDIF}
657			end;
658
659			function TStTree.Last : TStTreeNode;
660			begin
661			{$IFDEF ThreadSafe}
662			EnterCS;
663			try
664			{$ENDIF}
665			if Count = 0 then
666			Result := nil
667			else begin
668			Result := trRoot;
669			while Assigned(Result.tnPos[Right]) do
670			Result := Result.tnPos[Right];
671			end;
672			{$IFDEF ThreadSafe}
673			finally
674			LeaveCS;
675			end;
676			{$ENDIF}
677			end;
678
679			function TStTree.Next(N : TStTreeNode) : TStTreeNode;
680			var
681			Found : Word;
682			P : TStTreeNode;
683			StackP : Integer;
684			Stack : StackArray;
685			begin
686			{$IFDEF ThreadSafe}
687			EnterCS;
688			try
689			{$ENDIF}
690			Result := nil;
691			Found := 0;
692			StackP := 0;
693			P := trRoot;
694			repeat
695			while Assigned(P) do begin
696			Inc(StackP);
697			Stack[StackP].Node := P;
698			P := P.tnPos[Left];
699			end;
700			if StackP = 0 then
701			Exit;
702
703			P := Stack[StackP].Node;
704			Dec(StackP);
705			if Found = 1 then begin
706			Result := P;
707			Exit;
708			end;
709			if P = N then
710			Inc(Found);
711			P := P.tnPos[Right];
712			until False;
713			{$IFDEF ThreadSafe}
714			finally
715			LeaveCS;
716			end;
717			{$ENDIF}
718			end;
719
720			function TStTree.Prev(N : TStTreeNode) : TStTreeNode;
721			var
722			Found : Word;
723			P : TStTreeNode;
724			StackP : Integer;
725			Stack : StackArray;
726			begin
727			{$IFDEF ThreadSafe}
728			EnterCS;
729			try
730			{$ENDIF}
731			Result := nil;
732			Found := 0;
733			StackP := 0;
734			P := trRoot;
735			repeat
736			while Assigned(P) do begin
737			Inc(StackP);
738			Stack[StackP].Node := P;
739			P := P.tnPos[Right];
740			end;
741			if StackP = 0 then
742			Exit;
743
744			P := Stack[StackP].Node;
745			Dec(StackP);
746			if Found = 1 then begin
747			Result := P;
748			Exit;
749			end;
750			if P = N then
751			Inc(Found);
752			P := P.tnPos[Left];
753			until False;
754			{$IFDEF ThreadSafe}
755			finally
756			LeaveCS;
757			end;
758			{$ENDIF}
759			end;
760
761			function TStTree.Split(Data : Pointer) : TStTree;
762			var
763			SR : SplitRec;
764			begin
765			{$IFDEF ThreadSafe}
766			EnterCS;
767			try
768			{$ENDIF}
769			{Create and initialize the new tree}
770			Result := TStTreeClass(ClassType).Create(conNodeClass);
771			Result.Compare := Compare;
772			Result.OnCompare := OnCompare;
773			Result.DisposeData := DisposeData;
774			Result.OnDisposeData := OnDisposeData;
775
776			{Scan all elements to transfer some to new tree}
777			SR.SData := Data;
778			SR.STree := Result;
779			{Prevent SplitTree from disposing of node data it moves from old tree to new}
780			DisposeData := nil;
781			OnDisposeData := nil;
782			Iterate(SplitTree, True, @SR);
783			{Restore DisposeData property}
784			DisposeData := Result.DisposeData;
785			OnDisposeData := Result.OnDisposeData;
786			{$IFDEF ThreadSafe}
787			finally
788			LeaveCS;
789			end;
790			{$ENDIF}
791			end;
792
793			procedure TStTree.trInsertNode(N : TStTreeNode);
794			var
795			P : TStTreeNode;
796			CmpRes : Integer;
797			StackP : Integer;
798			Stack : StackArray;
799			SubTreeInc : Boolean;
800			begin
801			if not Assigned(N) then
802			Exit;
803
804			{Handle first node}
805			P := trRoot;
806			if not Assigned(P) then begin
807			trRoot := N;
808			Inc(FCount);
809			Exit;
810			end;
811
812			{Find where new node should fit in tree}
813			StackP := 0;
814			CmpRes := 0; {prevent D32 from generating a warning}
815			while Assigned(P) do begin
816			CmpRes := DoCompare(N.Data, P.Data);
817			if CmpRes = 0 then begin
818			{New node matches a node already in the tree, free it}
819			N.Free;
820			RaiseContainerError(stscDupNode);
821			end;
822			Inc(StackP);
823			with Stack[StackP] do begin
824			Node := P;
825			Comparison := CmpRes;
826			end;
827			P := P.tnPos[CmpRes > 0];
828			end;
829
830			{Insert new node}
831			Stack[StackP].Node.tnPos[CmpRes > 0] := N;
832			Inc(FCount);
833
834			{Unwind the stack and rebalance}
835			SubTreeInc := True;
836			while (StackP > 0) and SubTreeInc do begin
837			if StackP = 1 then
838			InsBalance(trRoot, SubTreeInc, Stack[1].Comparison)
839			else with Stack[StackP-1] do
840			InsBalance(Node.tnPos[Comparison > 0], SubTreeInc, Stack[StackP].Comparison);
841			dec(StackP);
842			end;
843			end;
844
845			procedure TStTree.LoadFromStream(S : TStream);
846			var
847			Data : pointer;
848			Reader : TReader;
849			StreamedClass : TPersistentClass;
850			StreamedNodeClass : TPersistentClass;
851			StreamedClassName : string;
852			StreamedNodeClassName : string;
853			begin
854			{$IFDEF ThreadSafe}
855			EnterCS;
856			try
857			{$ENDIF}
858			Clear;
859			Reader := TReader.Create(S, 1024);
860			try
861			with Reader do
862			begin
863			StreamedClassName := ReadString;
864			StreamedClass := GetClass(StreamedClassName);
865			if (StreamedClass = nil) then
866			RaiseContainerErrorFmt(stscUnknownClass, [StreamedClassName]);
867			if (not IsOrInheritsFrom(StreamedClass, Self.ClassType)) or
868			(not IsOrInheritsFrom(TStTree, StreamedClass)) then
869			RaiseContainerError(stscWrongClass);
870			StreamedNodeClassName := ReadString;
871			StreamedNodeClass := GetClass(StreamedNodeClassName);
872			if (StreamedNodeClass = nil) then
873			RaiseContainerErrorFmt(stscUnknownNodeClass, [StreamedNodeClassName]);
874			if (not IsOrInheritsFrom(StreamedNodeClass, conNodeClass)) or
875			(not IsOrInheritsFrom(TStTreeNode, StreamedNodeClass)) then
876			RaiseContainerError(stscWrongNodeClass);
877			ReadListBegin;
878			while not EndOfList do
879			begin
880			Data := DoLoadData(Reader);
881			Insert(Data);
882			end;
883			ReadListEnd;
884			end;
885			finally
886			Reader.Free;
887			end;
888			{$IFDEF ThreadSafe}
889			finally
890			LeaveCS;
891			end;
892			{$ENDIF}
893			end;
894
895			procedure TStTree.StoreToStream(S : TStream);
896			var
897			Writer : TWriter;
898			StoreInfo : TStoreInfo;
899			begin
900			{$IFDEF ThreadSafe}
901			EnterCS;
902			try
903			{$ENDIF}
904			Writer := TWriter.Create(S, 1024);
905			try
906			with Writer do begin
907			WriteString(Self.ClassName);
908			WriteString(conNodeClass.ClassName);
909			WriteListBegin;
910			StoreInfo.Wtr := Writer;
911			StoreInfo.SDP := StoreData;
912			Iterate(StoreNode, false, @StoreInfo);
913			WriteListEnd;
914			end;
915			finally
916			Writer.Free;
917			end;
918			{$IFDEF ThreadSafe}
919			finally
920			LeaveCS;
921			end;
922			{$ENDIF}
923			end;
924
925			{$IFDEF ThreadSafe}
926			initialization
927			Windows.InitializeCriticalSection(ClassCritSect);
928			finalization
929			Windows.DeleteCriticalSection(ClassCritSect);
930			{$ENDIF}
931			end.