tssetlib.pas

企业进销存管理系统

{*******************************************************}
{                                                       }
{       Top Support Delphi Library                      }
{       Storage classes for lists and binary trees      } 
{                                                       }
{       Copyright (c) 1997 - 1999, Top Support          }
{                                                       }
{*******************************************************}

unit TSSetLib;

interface

uses
    Windows, Classes, SysUtils;

    {TtsCustomSet

     TtsCustomSet is an abstract base class that can be used to provide general
     purpose sets for fast storage and retrieval of elements. The elements in a
     set are stored as a binary tree. The type of elements to be stored are
     defined in TtsCustomSet's derived classes. Ready made set classes are
     provided for strings, integers and objects (in TtsStringSet, TtsIntegerSet and
     TtsObjectSet respectively). The base class handles adding, searching and
     deletion of the tree nodes. The derived classes define the Add, Get
     and Remove methods for the handling of their specific datatypes.

     The elements of a set are stored in TtsSetNode objects. TtsSetNode itself
     provides no actual storage location for the elements, but only provides the
     basic handling of the nodes. A set class should define its own nodes
     as a derived class of TtsSetNode and provide for the actual storage.
     See the classes TtsStringSet, TtsIntegerSet and TtsObjectSet for an example.

     TtsSetNode provides a virtual method 'compare' for comparing the elements in
     a set so they can be stored according to their relative order. Subclasses
     should override this method for the specific elements to be stored.

     TtsSetNode:
        Count
            Reference count. The number of times the element has been added to the
            set.
        Left
            Subtree containing the smaller elements in the set.
        Right
            Subtree containing the larger elements in the set.
        Release
            Frees the node. Can be overridden to provide special release
            handling for the data in the node. See TtsObjectSetNode for an example
        Compare
            Compares one node element to another and stores the elements
            accordingly. Must be overridden.
        CompareKey
            Compares the keyvalue of a node element to another keyvalue. In the
            default implementation it simply calls Compare. Can be overridden.
        Value
            Returns a pointer to the value in the node. This method is used
            by TtsCustomSet.List to create a list of pointers to set elements.
            Must be overridden.

     TtsCustomSet:
        Count
            The number of set elements (= the number of nodes)
        NewNode
            Virtual function for creating a new set node. Must be overridden in
            the subclass.
        AddNode
            Adds a new element to the set. If an element with the same compare
            value already exists, the element's node reference count is
            increased.
        GetNode
            Searches for an element in the sets.
        RemoveNode
            Removes the element from the set.
        List
            Returns a TtsSetList, which is a sorted list of the elements in the
            set. The list can be used to iterate through the elements in the
            set.

     TtsSetList:
        Count
            The number of elements in the list
        Items
            An array[1..Count] of items in the list.
     }


    {TtsStringSet, TtsIntegerSet, TtsRealSet and TtsObjectSet

     TtsStringSet, TtsIntegerSet and TtsRealSet provide implementations for sets of
     strings, integers and reals. The interface to the sets is provided by the
     methods Add, Get and Remove. These methods do little more than
     call AddNode, GetNode and RemoveNode in the TtsCustomSet base class.

     TtsObjectSet provides the implementation for a set of objects. It has
     basically the same interface as TtsStringSet and TtsIntegerSet, but provides
     an extra base class, TtsSetElement. Objects which are to be stored in the a
     TtsObjectSet must be derived from this class. When an object is added to the
     set, a reference to the object is stored in a node. If the new object has
     the same compare value as an already existing object, the new object
     replaces the old one and the old one is freed. You can change this behaviour by
     overriding the Release and Copy methods of TtsSetElement.

     TtsStringSet, TtsIntegerSet, TtsRealSet and TtsObjectSet:
        Add
            Adds an element to the set.
        Get
            Searches an element in the set.
        Remove
            Removes an element from the set.

     TtsSetElement (base class for objects in TtsObjectSet):
        Compare
            Compare one object to another. Must be overridden.
            In most cases this method can be simply implemented as a call to
            CompareKey below, passing the keyvalue elements of the object being
            compared as the parameter.
        CompareKey
            Compares the keyvalues of one object to another. Must be overridden.
            The keyvalue of the other object is passed as an array of const.
        Release
            Frees the object. It is called when the node is freed or when the
            node object is replaced by another object (which occurs when a new
            object is added with the same compare value as an already present
            object). It can be overridden to prevent objects from actually being
            freed when they are removed from the set.
        Copy
            When an object is added to a set a reference to that object is
            is stored in its node. If you want to store a copy of the object
            rather than the object itself, you should override the Copy method.
            In its default implementation it simply returns a reference to the
            object that was passed with the add method. You can override it to
            duplicate the object and return a reference to the duplicate.
    }


    {TtsIntegerList

     TtsIntegerList provides an implementation for a dynamic array of integers
     based on the TList class.}



type
    TtsSetOrder = (ordSmaller, ordEqual, ordLarger);

    PtsSetListArray = ^TtsSetListArray;
    TtsSetListArray = array[1..MaxListSize] of Pointer;

    PtsVarRecArray = ^TtsVarRecArray;
    TtsVarRecArray = array[0..MaxListSize] of TVarRec;

    PtsLongintArray = ^TtsLongintArray;
    TtsLongintArray = array[0..MaxListSize] of Longint;

type
    TtsCustomSet = class;

    TtsSetNode = class(TObject)
    protected
        FLeft : TtsSetNode;
        FRight : TtsSetNode;
        FBalance: Shortint;

        procedure Initialize;
        procedure Assign(Source: TtsSetNode); virtual;
        property  Balance: Shortint read FBalance write FBalance;

    public
        constructor CreatePtr(NodeValue : Pointer); virtual;
        destructor  Destroy; override;

        function Release(DestroyingSet : Boolean) : Pointer; virtual;
        function Compare(NodeSet: TtsCustomSet; NodeValue : Pointer) : TtsSetOrder; virtual;
        function CompareKey(NodeSet: TtsCustomSet; KeyValue : Pointer) : TtsSetOrder; virtual;
        function Value : Pointer; virtual;

        property Left : TtsSetNode read FLeft write FLeft;
        property Right : TtsSetNode read FRight write FRight;
    end; //class TtsSetNode

    TtsSetList = class(TObject)
    protected
        FCount : Longint;
        FItems : PtsSetListArray;

        procedure Initialize;
        procedure SetItems(Index : Longint; Value : Pointer);
        function  GetItems(Index : Longint) : Pointer;

    public
        constructor CreateCnt(NrOfElements : Longint);
        destructor  Destroy; override;

        property Count : Longint read FCount;
        property Items[Index : Longint] : Pointer read GetItems write SetItems;
    end; //class TtsSetList

    TtsNodeStackElement = record
        Node: TtsSetNode;
        Direction: Shortint;
    end;

    PtsNodeStackArray = ^TtsNodeStackArray;
    TtsNodeStackArray = array[1..MaxListSize] of TtsNodeStackElement;

    TtsNodeStack = class(TObject)
    protected
        FBuffer: PtsNodeStackArray;
        FBufSize: Integer;
        FCount: Integer;

        function  Push(Node: TtsSetNode; Direction: Shortint): Integer;
        function  Pop: TtsNodeStackElement;
        procedure Replace(Index: Integer; Node: TtsSetNode; Direction: Shortint);
        procedure Reset;
        function  GetItem(Index: Integer): TtsNodeStackElement;

        property  Count: Integer read FCount;
        property  Item[Index: Integer]: TtsNodeStackElement read GetItem; default;
    public
        constructor Create;
        destructor  Destroy; override;
    end;

    TtsCustomSet = class(TObject)
    protected
        FCount : Longint;
        FTopNode : TtsSetNode;
        FStack: TtsNodeStack;
        FAssigning: Integer;

        procedure Initialize;
        procedure DestroyNodes(Tree : TtsSetNode);
        procedure PlaceTreeInList(Node : TtsSetNode; SetList : TtsSetList; var ListPos : Longint);
        function  GetNewNode(NodeValue: Pointer): TtsSetNode;
        procedure SearchNode(NodeValue: Pointer; var ParentNode,
                             BalanceNode, NewNode: TtsSetNode; var Found: Boolean);
        procedure InsertSetBalance(NodeValue: Pointer; FromNode, ToNode: TtsSetNode);
        procedure RotateSingle(Direction: Shortint; var SubTopNode: TtsSetNode; BalanceNode, BalanceChildNode: TtsSetNode);
        procedure RotateDouble(Direction: Shortint; var SubTopNode: TtsSetNode; BalanceNode, BalanceChildNode: TtsSetNode);
        procedure InsertRebalance(Direction: Shortint; ParentNode, BalanceNode, BalanceChildNode: TtsSetNode);

        function  AddNode(NodeValue : Pointer) : TtsSetNode;
        function  GetNode(Tree : TtsSetNode; NodeValue : Pointer) : TtsSetNode;
        function  TraceElement(Value: Pointer): TtsSetNode;
        function  NextSmallestElement(Node: TtsSetNode): TtsSetNode;
        procedure DeleteNode(Node: TtsSetNode);
        procedure RotateRebalance(var SubTopNode: TtsSetNode; var Done: Boolean);
        procedure RemoveRebalance;
        procedure ReplaceNode(ParentNode, Node, RplNode: TtsSetNode; StackPos: Integer);
        function  RemoveNode(Value: Pointer): TtsSetNode;
        function  NewNode(NodeValue : Pointer) : TtsSetNode; virtual;
        function  CopyNodes(Node: TtsSetNode): TtsSetNode; virtual;
        function  GetAssigning: Boolean;

        property  Stack: TtsNodeStack read FStack;

    public
        constructor Create; virtual;
        destructor  Destroy; override;

        procedure Assign(Source: TtsCustomSet); virtual;
        procedure Clear; virtual;
        function  List : TtsSetList;
        function  TreeHeight(Node: TtsSetNode): Integer;
        function  IsBalanced(Node: TtsSetNode): Boolean;
        function  CheckBalance: Boolean;
        function  CheckHeight: Integer;

        property Assigning: Boolean read GetAssigning;
        property Count : Longint read FCount;
        property TopNode: TtsSetNode read FTopNode;
    end; //class TtsCustomSet


    TtsStringSetNode = class(TtsSetNode)
    protected
        FNodeValue : string;

        procedure Assign(Source: TtsSetNode); override;
    public
        constructor Create(NodeValue : string);

        function Compare(NodeSet: TtsCustomSet; NodeValue : Pointer) : TtsSetOrder; override;
        function Value : Pointer; override;
    end; //class TtsStringSetNode

    TtsStringSet = class(TtsCustomSet)
    protected
        function NewNode(NodeValue : Pointer) : TtsSetNode; override;

    public
        function Add(NodeValue : string) : Pointer; virtual;
        function Get(NodeValue : string) : Pointer; virtual;
        function Remove(NodeValue : string) : Pointer; virtual;
    end; //class TtsStringSet

    TtsVariantSetNode = class(TtsSetNode)
    protected
        FNodeValue : Variant;
    public
        constructor Create(NodeValue : Variant);

        function Compare(NodeSet: TtsCustomSet; NodeValue : Pointer) : TtsSetOrder; override;
        function Value : Pointer; override;
    end; //class TtsVariantSetNode

    TtsVariantSet = class(TtsCustomSet)
    protected
        function NewNode(NodeValue : Pointer) : TtsSetNode; override;

    public
        function Add(NodeValue : Variant) : Pointer; virtual;
        function Get(NodeValue : Variant) : Pointer; virtual;
        function Remove(NodeValue : Variant) : Pointer; virtual;
    end; //class TtsVariantSet

    TtsIntegerSetNode = class(TtsSetNode)
    protected
        FNodeValue : Longint;
    public
        constructor Create(NodeValue : Longint);

        function  Compare(NodeSet: TtsCustomSet; NodeValue : Pointer) : TtsSetOrder; override;
        function  Value : Pointer; override;
    end; //class TtsIntegerSetNode

    TtsIntegerSet = class(TtsCustomSet)
    protected
        function NewNode(NodeValue : Pointer) : TtsSetNode; override;

    public
        function Add(NodeValue : Longint) : Pointer; virtual;
        function Get(NodeValue : Longint) : Pointer; virtual;
        function Remove(NodeValue : Longint) : Pointer; virtual;
    end; //class TtsIntegerSet

    TtsRealSetNode = class(TtsSetNode)
    protected
        FNodeValue : Double;
    public
        constructor Create(NodeValue : Double);

        function Compare(NodeSet: TtsCustomSet; NodeValue : Pointer) : TtsSetOrder; override;
        function Value : Pointer; override;
    end; //class TtsRealSetNode

    TtsRealSet = class(TtsCustomSet)
    protected
        function NewNode(NodeValue : Pointer) : TtsSetNode; override;

    public
        function Add(NodeValue : Double) : Pointer; virtual;
        function Get(NodeValue : Double) : Pointer; virtual;
        function Remove(NodeValue : Double) : Pointer; virtual;
    end; //class TtsRealSet

    TtsSetElement = class(TObject)
    public
        function Release(DestroyingSet : Boolean) : TtsSetElement; virtual;
        function Compare(NodeSet: TtsCustomSet; Value : TtsSetElement) : TtsSetOrder; virtual;
        function CompareKey(NodeSet: TtsCustomSet; const KeyValue : array of const) : TtsSetOrder; virtual;
        function Copy: TtsSetElement;
        function AssignCopy: TtsSetElement;
        function StringValue : string; virtual;
    end;

    TtsObjectSetNode = class(TtsSetNode)
    protected
        FNodeValue : TtsSetElement;
    public
        constructor Create(NodeValue : TtsSetElement);

        function  CompareKey(NodeSet: TtsCustomSet; KeyValue : Pointer) : TtsSetOrder; override;
        function  Compare(NodeSet: TtsCustomSet; NodeValue : Pointer) : TtsSetOrder; override;
        function  Release(DestroyingSet : Boolean) : Pointer; override;
        function  Value : Pointer; override;

        property NodeValue: TtsSetElement read FNodeValue;
    end;

    TtsObjectSet = class(TtsCustomSet)
    protected
        function NewNode(NodeValue : Pointer) : TtsSetNode; override;

    public
        function Add(NodeValue : TtsSetElement) : Pointer; virtual;
        function Get(KeyValue : array of const) : Pointer; virtual;
        function Remove(KeyValue : array of const) : Pointer; virtual;
    end;


    TtsIntegerList = class(TList)
    public
        procedure AddItem(Item: Integer);

        function  GetItem(Index: Integer): Integer;
        procedure SetItem(Index: Integer; Value: Integer);
        function  Remove(Value: Integer): Integer;

        property Item[Index : Integer] : Integer read GetItem write SetItem; default;
    end; //TtsIntegerList

    {TtsSortIntList}
    {Sorted list of Longints. Index ranges from 1 to Count}

    TtsSortIntList = class(TObject)
    protected
        FItems: PtsLongintArray;
        FCount: Longint;
        FCapacity: Longint;

        procedure Assign(Source: TtsSortIntList); virtual;
        procedure CheckCapacity(NewSize: Longint); virtual;
        function  GetItem(Index: Longint): Longint; virtual;
        procedure SetItem(Index: Longint; Value: Longint);
        procedure Insert(Pos: Longint; Value: Longint); virtual;
        procedure Delete(Pos: Longint); virtual;
        procedure SetCapacity(Value: Longint); virtual;
        procedure FindPosition(Top, Bottom: Longint; CmpValue: Longint; var Pos: Longint; var Found: Boolean);

    public
        constructor Create;
        destructor Destroy; override;

        procedure Add(Value: Longint); virtual;
        function  Locate(Value: Longint; var Found: Boolean): Longint; virtual;
        procedure Remove(Value: Longint); virtual;

        property Item[Index: Longint]: Longint read GetItem write SetItem; default;
        property Count: Longint read FCount;
        property Capacity: Longint read FCapacity write SetCapacity;
    end;

    TtsIntegerSetList = class(TList)
    public
        destructor Destroy; override;

        procedure Assign(Source: TtsIntegerSetList); virtual;
        procedure AddItem(Item: TtsIntegerSet);
        procedure FreeItems;
        function  GetItem(Index: Integer): TtsIntegerSet;
        function  Remove(Value: TtsIntegerSet): Integer;
        procedure SetItem(Index: Integer; Value: TtsIntegerSet);

        property Item[Index : Integer] : TtsIntegerSet read GetItem write SetItem; default;