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	// 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.