tssetlib.pas

企业进销存管理系统

    if Compare = ordSmaller then
    begin
        Direction := -1;
        BalanceChildNode := BalanceNode.Left
    end
    else
    begin
        Direction := 1;
        BalanceChildNode := BalanceNode.Right;
    end;

    InsertSetBalance(NodeValue, BalanceChildNode, NewNode);
    InsertRebalance(Direction, ParentNode, BalanceNode, BalanceChildNode);
end;

function TtsCustomSet.GetNode(Tree : TtsSetNode; NodeValue : Pointer) : TtsSetNode;
begin
    Result := nil;
    if Tree = nil then Exit;

    case Tree.CompareKey(Self, NodeValue) of
        ordEqual    : Result := Tree;
        ordSmaller  : Result := GetNode(Tree.Left, NodeValue);
        ordLarger   : Result := GetNode(Tree.Right, NodeValue);
    end;
end;

function TtsCustomSet.TraceElement(Value: Pointer): TtsSetNode;
var
    CurNode: TtsSetNode;
begin
    CurNode := FTopNode;
    while CurNode <> nil do
    begin
        case CurNode.CompareKey(Self, Value) of
            ordEqual: Break;
            ordSmaller: begin Stack.Push(CurNode, -1); CurNode := CurNode.Left; end;
            ordLarger: begin Stack.Push(CurNode, 1); CurNode := CurNode.Right; end;
        end;
    end;

    Result := CurNode;
end;

function TtsCustomSet.NextSmallestElement(Node: TtsSetNode): TtsSetNode;
var
    CurNode: TtsSetNode;
begin
    Stack.Push(Node, 1);
    CurNode := Node.Right;
    while CurNode.Left <> nil do
    begin
        Stack.Push(CurNode, -1);
        CurNode := CurNode.Left;
    end;

    Result := CurNode;
end;

procedure TtsCustomSet.DeleteNode(Node: TtsSetNode);
var
    NewNode: TtsSetNode;
begin
    if Node.Left = nil
        then NewNode := Node.Right
        else NewNode := Node.Left;

    if Stack.Count >= 1 then
    begin
        if Stack[Stack.Count].Direction = -1
            then Stack[Stack.Count].Node.Left := NewNode
            else Stack[Stack.Count].Node.Right := NewNode;
    end
    else
        FTopNode := NewNode;

    FCount := FCount - 1;
end;

procedure TtsCustomSet.RotateRebalance(var SubTopNode: TtsSetNode; var Done: Boolean);
var
    Direction: Shortint;
    BalanceNode, BalanceChildNode: TtsSetNode;
begin
    Done := False;
    with Stack do
    begin
        BalanceNode := Stack[Count].Node;
        if Stack[Count].Direction = -1 then
        begin
            BalanceChildNode := BalanceNode.Right;
            Direction := 1;
        end
        else
        begin
            BalanceChildNode := BalanceNode.Left;
            Direction := -1;
        end;
    end;

    if (BalanceChildNode.Balance = Direction) or (BalanceChildNode.Balance = 0) then
    begin
        Done := (BalanceChildNode.Balance = 0);
        RotateSingle(Direction, SubTopNode, BalanceNode, BalanceChildNode)
    end
    else
        RotateDouble(Direction, SubTopNode, BalanceNode, BalanceChildNode);
end;

procedure TtsCustomSet.RemoveRebalance;
var
    Done: Boolean;
    SubTopNode: TtsSetNode;
begin
    Done := False;
    with Stack do
    begin
        while (not Done) and (Count > 0) do
        begin
            if Stack[Count].Node.Balance = 0 then
            begin
                Stack[Count].Node.Balance := -Stack[Count].Direction;
                Break;
            end;

            if Stack[Count].Node.Balance = Stack[Count].Direction then
                Stack[Count].Node.Balance := 0
            else
            begin
                RotateRebalance(SubTopNode, Done);
                if Count = 1 then
                    FTopNode := SubTopNode
                else
                begin
                    if Stack[Count].Node = Stack[Count-1].Node.Right
                        then Stack[Count-1].Node.Right := SubTopNode
                        else Stack[Count-1].Node.Left := SubTopNode;
                end;
            end;

            Pop;
        end;
    end;
end;

procedure TtsCustomSet.ReplaceNode(ParentNode, Node, RplNode: TtsSetNode; StackPos: Integer);
begin
    if ParentNode = nil then
        FTopNode := RplNode
    else if ParentNode.Right = Node then
        ParentNode.Right := RplNode
    else
        ParentNode.Left := RplNode;

    RplNode.Left := Node.Left;
    RplNode.Right := Node.Right;
    RplNode.Balance := Node.Balance;

    if StackPos > 0 then
        Stack.Replace(StackPos, RplNode, Stack[StackPos].Direction);
end;

function TtsCustomSet.RemoveNode(Value: Pointer): TtsSetNode;
var
    ParentNode: TtsSetNode;
    Node, DelNode: TtsSetNode;
    NodeStackPos: Integer;
begin
    Stack.Reset;
    Node := TraceElement(Value);
    Result := Node;
    if Node = nil then Exit;

    ParentNode := nil;
    if Stack.Count >= 1 then ParentNode := Stack[Stack.Count].Node;

    NodeStackPos := 0;
    if (Node.Left <> nil) and (Node.Right <> nil) then
    begin
        NodeStackPos := Stack.Count + 1;
        DelNode := NextSmallestElement(Node);
    end
    else
        DelNode := Node;

    DeleteNode(DelNode);
    if Node <> DelNode then
        ReplaceNode(ParentNode, Node, DelNode, NodeStackPos);
    RemoveRebalance;
end;

function TtsCustomSet.TreeHeight(Node: TtsSetNode): Integer;
var
    LeftHeight, RightHeight: Integer;
begin
    Result := 0;
    if Node = nil then Exit;

    LeftHeight := TreeHeight(Node.Left);
    RightHeight := TreeHeight(Node.Right);
    if LeftHeight > RightHeight
        then Result := 1 + LeftHeight
        else Result := 1 + RightHeight;
end;

function TtsCustomSet.IsBalanced(Node: TtsSetNode): Boolean;
begin
    Result := True;
    if Node = nil then Exit;

    Result := IsBalanced(Node.Right) and
              IsBalanced(Node.Left) and
              (Abs(TreeHeight(Node.Left) - TreeHeight(Node.Right)) <= 1);
end;

function TtsCustomSet.CheckBalance: Boolean;
begin
    Result := IsBalanced(FTopNode);
end;

function TtsCustomSet.CheckHeight: Integer;
begin
    Result := TreeHeight(FTopNode);
end;

function TtsCustomSet.List : TtsSetList;
var
    ListPos : Longint;
    SetList : TtsSetList;
begin
    ListPos := 0;
    SetList := TtsSetList.CreateCnt(FCount);

    try
        PlaceTreeInList(FTopNode, SetList, ListPos)
    except
        on Exception do begin SetList.Free; raise end;
    end;

    Result := SetList;
end;

procedure TtsCustomSet.PlaceTreeInList(Node : TtsSetNode; SetList : TtsSetList; var ListPos : Longint);
begin
    if Node <> nil then
    begin
        PlaceTreeInList(Node.Left, SetList, ListPos);

        ListPos := ListPos + 1;
        SetList.Items[ListPos] := Node.Value;

        PlaceTreeInList(Node.Right, SetList, ListPos);
    end;
end;

//End implementation of class TtsCustomSet
//******************************************************************************


//******************************************************************************
//Implementation of class TtsStringSet

constructor TtsStringSetNode.Create(NodeValue : string);
begin
    inherited CreatePtr(@NodeValue);
    FNodeValue := NodeValue;
end;

function TtsStringSetNode.Compare(NodeSet: TtsCustomSet; NodeValue : Pointer) : TtsSetOrder;
begin
    if FNodeValue = string(NodeValue^) then
        Result := ordEqual
    else if string(NodeValue^) < FNodeValue then
        Result := ordSmaller
    else
        Result := ordLarger
end;

function TtsStringSetNode.Value : Pointer;
begin
    Result := @FNodeValue;
end;

procedure TtsStringSetNode.Assign(Source: TtsSetNode);
begin
    if Source is TtsStringSetNode then
        FNodeValue := TtsStringSetNode(Source).FNodeValue;
end;

function TtsStringSet.NewNode(NodeValue : Pointer) : TtsSetNode;
begin
    NewNode := TtsStringSetNode.Create(string(NodeValue^));
end;

function TtsStringSet.Add(NodeValue : string) : Pointer;
var
    Node : TtsSetNode;
begin
    Node := AddNode(@NodeValue);
    Result := @TtsStringSetNode(Node).FNodeValue;
end;

function TtsStringSet.Get(NodeValue : string) : Pointer;
var
    Node : TtsSetNode;
begin
    Result := nil;
    Node := GetNode(FTopNode, @NodeValue);
    if Node <> nil then Result := @TtsStringSetNode(Node).FNodeValue;
end;

function TtsStringSet.Remove(NodeValue : string) : Pointer;
var
    Node : TtsSetNode;
begin
    Node := RemoveNode(@NodeValue);
    Node.Free;
    Result := nil;
end;

//End implementation of class TtsStringSet
//******************************************************************************


//******************************************************************************
//Implementation of class TtsVariantSet

constructor TtsVariantSetNode.Create(NodeValue : Variant);
begin
    inherited CreatePtr(@NodeValue);
    FNodeValue := NodeValue;
end;

function TtsVariantSetNode.Compare(NodeSet: TtsCustomSet; NodeValue : Pointer) : TtsSetOrder;
begin
    if FNodeValue = Variant(NodeValue^) then
        Result := ordEqual
    else if Variant(NodeValue^) < FNodeValue then
        Result := ordSmaller
    else
        Result := ordLarger
end;

function TtsVariantSetNode.Value : Pointer;
begin
    Result := @FNodeValue;
end;

function TtsVariantSet.NewNode(NodeValue : Pointer) : TtsSetNode;
begin
    NewNode := TtsVariantSetNode.Create(Variant(NodeValue^));
end;

function TtsVariantSet.Add(NodeValue : Variant) : Pointer;
var
    Node : TtsSetNode;
begin
    Node := AddNode(@NodeValue);
    Result := @TtsVariantSetNode(Node).FNodeValue;
end;

function TtsVariantSet.Get(NodeValue : Variant) : Pointer;
var
    Node : TtsSetNode;
begin
    Result := nil;
    Node := GetNode(FTopNode, @NodeValue);
    if Node <> nil then Result := @TtsVariantSetNode(Node).FNodeValue;
end;

function TtsVariantSet.Remove(NodeValue : Variant) : Pointer;
var
    Node : TtsSetNode;
begin
    Node := RemoveNode(@NodeValue);
    Node.Free;
    Result := nil;
end;

//End implementation of class TtsVariantSet
//******************************************************************************


//******************************************************************************
//Implementation of class TtsIntegerSet

constructor TtsIntegerSetNode.Create(NodeValue : Longint);
begin
    inherited CreatePtr(@NodeValue);
    FNodeValue := NodeValue;
end;

function TtsIntegerSetNode.Compare(NodeSet: TtsCustomSet; NodeValue : Pointer) : TtsSetOrder;
begin
    if FNodeValue = Longint(NodeValue^) then
        Result := ordEqual
    else if Longint(NodeValue^) < FNodeValue then
        Result := ordSmaller
    else
        Result := ordLarger
end;

function TtsIntegerSetNode.Value : Pointer;
begin
    Result := @FNodeValue;
end;

function TtsIntegerSet.NewNode(NodeValue : Pointer) : TtsSetNode;
begin
    NewNode := TtsIntegerSetNode.Create(Longint(NodeValue^));
end;

function TtsIntegerSet.Add(NodeValue : Longint) : Pointer;
var
    Node : TtsSetNode;
begin
    Node := AddNode(@NodeValue);
    Result := @TtsIntegerSetNode(Node).FNodeValue;
end;

function TtsIntegerSet.Get(NodeValue : Longint) : Pointer;
var
    Node : TtsSetNode;
begin
    Result := nil;
    Node := GetNode(FTopNode, @NodeValue);
    if Node <> nil then Result := @TtsIntegerSetNode(Node).FNodeValue;
end;

function TtsIntegerSet.Remove(NodeValue : Longint) : Pointer;
var
    Node : TtsSetNode;
begin
    Node := RemoveNode(@NodeValue);
    Node.Free;
    Result := nil;
end;

//End implementation of class TtsIntegerSet
//******************************************************************************


//******************************************************************************
//Implementation of class TtsRealSet

constructor TtsRealSetNode.Create(NodeValue : Double);