tssetlib.pas

企业进销存管理系统

begin
    inherited CreatePtr(@NodeValue);
    FNodeValue := NodeValue;
end;

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

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

function TtsRealSet.NewNode(NodeValue : Pointer) : TtsSetNode;
begin
    NewNode := TtsRealSetNode.Create(Double(NodeValue^));
end;

function TtsRealSet.Add(NodeValue : Double) : Pointer;
var
    Node : TtsSetNode;
begin
    Node := AddNode(@NodeValue);
    Result := @TtsRealSetNode(Node).FNodeValue;
end;

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

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

//End implementation of class TtsRealSet
//******************************************************************************


//******************************************************************************
//Implementation of TtsObjectSet

function TtsSetElement.Compare(NodeSet: TtsCustomSet; Value : TtsSetElement) : TtsSetOrder;
{The compare method should compare Value to the object itself. The method must
 be overridden.

 Return value:
    ordLarger if Value is larger
    ordSmaller if Value is smaller
    ordEqual if Value is equal
}
begin
    Result := ordEqual;
end;

function TtsSetElement.CompareKey(NodeSet: TtsCustomSet; const KeyValue : array of const) : TtsSetOrder;
{The CompareKey method should compare the KeyValue to the key value of the
 object itself. The method must be overridden. KeyValue is an array of const, so
 it can consist of any number of elements.

 Parameters:
    KeyValue : contains the elements of the key, from KeyValue[0] to
               KeyValue[N-1].
 Return value:
    ordLarger if KeyValue is larger than the key of self
    ordSmaller if KeyValue is smaller then the key of self
    ordEqual if both are equal
}
begin
    Result := ordEqual;
end;

function TtsSetElement.Release(DestroyingSet : Boolean) : TtsSetElement;
{The Release method frees the TtsSetElement object when the element is removed
 from the set. The Release method can be overridden.

 Parameters:
    DestroyingSet : true if the object is being released as a result freeing
                    the entire set, otherwise false
 Return value :
    nil of the object is freed, otherwise a reference to the object.
}
begin
    Free;
    Result := nil;
end;

function TtsSetElement.Copy : TtsSetElement;
{A virtual method that returns a reference to the object that should be stored
 in the set. In the default implementation below, a reference to self is
 returned, which is the object that was passed to the Add method. Copy can be
 overridden to return a duplicate of this object rather than the object itself.
 In that case the set will contain duplicates and not the objects themselves.

 Return value:
    Reference to the object that will be stored in the set.
}
begin
    Result := Self;
end;

function TtsSetElement.AssignCopy: TtsSetElement;
{A virtual method that returns a reference to the object that should be stored
 in the set when it is being assigned to another set. In the default
 implementation below, a reference to self is returned, which is the object
 that was passed to the Add method. Copy can be overridden to return a duplicate
 of this object rather than the object itself. In that case the set will contain
 duplicates and not the objects themselves.

 Return value:
    Reference to the object that will be stored in the set.
}
begin
    Result := Self;
end;

function TtsSetElement.StringValue : string;
begin
    Result := '';
end;

constructor TtsObjectSetNode.Create(NodeValue : TtsSetElement);
begin
    inherited CreatePtr(NodeValue);
    FNodeValue := NodeValue.Copy;
end;

function TtsObjectSetNode.Compare(NodeSet: TtsCustomSet; NodeValue : Pointer) : TtsSetOrder;
begin
    Result := FNodeValue.Compare(NodeSet, TtsSetElement(NodeValue));
end;

function TtsObjectSetNode.CompareKey(NodeSet: TtsCustomSet; KeyValue : Pointer) : TtsSetOrder;
begin
    Result := FNodeValue.CompareKey(NodeSet, TtsVarRecArray(KeyValue^));
end;

function TtsObjectSetNode.Release(DestroyingSet : Boolean) : Pointer;
begin
    Result := FNodeValue.Release(DestroyingSet);
    inherited Release(DestroyingSet);
end;

function TtsObjectSetNode.Value : Pointer;
begin
    Result := FNodeValue;
end;

function TtsObjectSet.NewNode(NodeValue : Pointer) : TtsSetNode;
begin
    NewNode := TtsObjectSetNode.Create(TtsSetElement(NodeValue));
end;

function TtsObjectSet.Add(NodeValue : TtsSetElement) : Pointer;
var
    Node : TtsSetNode;
begin
    Node := AddNode(NodeValue);

    if TtsObjectSetNode(Node).FNodeValue <> NodeValue then
    begin
        Result := TtsObjectSetNode(Node).FNodeValue.Release(false);
        TtsObjectSetNode(Node).FNodeValue := NodeValue.Copy;
    end
    else
    begin
        Result := nil;
    end;
end;

function TtsObjectSet.Get(KeyValue : array of const) : Pointer;
var
    Node : TtsSetNode;
begin
    Result := nil;
    Node := GetNode(FTopNode, @KeyValue);
    if Node <> nil then Result := TtsObjectSetNode(Node).FNodeValue;
end;

function TtsObjectSet.Remove(KeyValue : array of const) : Pointer;
var
    Node : TtsSetNode;
begin
    Node := RemoveNode(@KeyValue);
    if Node <> nil then Result := Node.Release(false)
                   else Result := nil;
end;

//End implementation of TtsObjectSet
//******************************************************************************


//******************************************************************************
//Implementation of TtsIntegerList

procedure TtsIntegerList.AddItem(Item: Integer);
begin
    Add(Pointer(Item));
end;

function TtsIntegerList.GetItem(Index: Integer): Integer;
begin
    Result := Integer(Items[Index]);
end;

procedure TtsIntegerList.SetItem(Index: Integer; Value: Integer);
begin
    Items[Index] := Pointer(Value);
end;

function TtsIntegerList.Remove(Value: Integer): Integer;
begin
    Result := inherited Remove(Pointer(Value));
end;

function IntCompare(Int1, Int2: Pointer): Integer;
begin
    Result := Integer(Int1) - Integer(Int2);
end;

//End implementation of TtsIntegerList
//******************************************************************************


//******************************************************************************
//Implementation of TtsIntegerSetList

destructor TtsIntegerSetList.Destroy;
begin
    FreeItems;
    inherited;
end;

procedure TtsIntegerSetList.FreeItems;
var
    I: Integer;
begin
    for I := 0 to Count - 1 do
    begin
        Item[I].Free;
        Item[I] := nil;
    end;
end;

procedure TtsIntegerSetList.Assign(Source: TtsIntegerSetList);
var
    I: Integer;
    MaxCount: Integer;
begin
    FreeItems;
    MaxCount := Count;
    if MaxCount > Source.Count then MaxCount := Source.Count;
    for I := 0 to MaxCount - 1 do
    begin
        if Assigned(Source.Item[I]) then
        begin
            Item[I] := TtsIntegerSet.Create;
            Item[I].Assign(Source.Item[I]);
        end;
    end;
end;

procedure TtsIntegerSetList.AddItem(Item: TtsIntegerSet);
begin
    Add(Pointer(Item));
end;

function TtsIntegerSetList.GetItem(Index: Integer): TtsIntegerSet;
begin
    Result := TtsIntegerSet(Items[Index]);
end;

procedure TtsIntegerSetList.SetItem(Index: Integer; Value: TtsIntegerSet);
begin
    Items[Index] := Pointer(Value);
end;

function TtsIntegerSetList.Remove(Value: TtsIntegerSet): Integer;
begin
    Result := inherited Remove(Pointer(Value));
end;

//Implementation of TtsIntegerSetList
//******************************************************************************


//******************************************************************************
//Implementation of TtsSortIntList

constructor TtsSortIntList.Create;
begin
    FItems := nil;
    FCount := 0;
    FCapacity := 0;
end;

destructor TtsSortIntList.Destroy;
begin
    ReallocMem(FItems, 0);
end;

procedure TtsSortIntList.Assign(Source: TtsSortIntList);
begin
    if (Source.FItems = nil) or (Source.FCount = 0) then
    begin
        ReAllocMem(FItems, 0);
        FCount := 0;
        FCapacity := 0;
    end
    else
    begin
        CheckCapacity(Source.FCount);
        CopyMemory(FItems, Source.FItems, (Source.Count + 1) * SizeOf(Longint));
        FCount := Source.FCount;
    end;
end;

procedure TtsSortIntList.CheckCapacity(NewSize: Longint);
begin
    if NewSize > Capacity then
        Capacity := NewSize + 100
    else if (NewSize < Capacity - 100) then
        Capacity := NewSize;
end;

procedure TtsSortIntList.SetCapacity(Value: Longint);
begin
    if FCapacity <> Value then
    begin
        FCapacity := Value;
        ReallocMem(FItems, (Value + 1) * SizeOf(Longint));
    end;
end;

function TtsSortIntList.GetItem(Index: Longint): Longint;
begin
    Result := 0;
    if (Index > 0) and (Index <= Count) then Result := FItems[Index];
end;

procedure TtsSortIntList.SetItem(Index: Longint; Value: Longint);
begin
    if (Index > 0) and (Index <= Count) then FItems[Index] := Value;
end;

procedure TtsSortIntList.Insert(Pos: Longint; Value: Longint);
begin
    CheckCapacity(Count + 1);
    if Pos = 0 then Inc(Pos);

    if Pos <= Count then
    begin
        MoveMemory(@FItems[Pos + 1], @FItems[Pos],
                   (Count - Pos + 1) * SizeOf(Longint));
    end;

    FItems[Pos] := Value;
    Inc(FCount);
end;

procedure TtsSortIntList.Delete(Pos: Longint);
begin
    if (Pos < 1) or (Pos > Count) then Exit;

    if Pos < Count then
    begin
        MoveMemory(@FItems[Pos], @FItems[Pos + 1],
                   (Count - Pos) * SizeOf(Longint));
    end;

    CheckCapacity(Count - 1);
    Dec(FCount);
end;

procedure TtsSortIntList.Add(Value: Longint);
var
    Pos: Longint;
    Found: Boolean;
begin
    Pos := Locate(Value, Found);
    if not Found then Insert(Pos, Value);
end;

procedure TtsSortIntList.Remove(Value: Longint);
var
    Pos: Longint;
    Found: Boolean;
begin
    Pos := Locate(Value, Found);
    if Found then Delete(Pos);
end;

procedure TtsSortIntList.FindPosition(Top, Bottom: Longint; CmpValue: Longint;
                                      var Pos: Longint; var Found: Boolean);
var
    Val: Longint;
begin
    if Top <= Bottom then
    begin
        Val := Item[(Top + Bottom) div 2];

        if Val > CmpValue then
            FindPosition(Top, ((Top + Bottom) div 2) - 1, CmpValue, Pos, Found)
        else if Val < CmpValue then
            FindPosition(((Top + Bottom) div 2) + 1, Bottom, CmpValue, Pos, Found)
        else
        begin
            Pos := (Top + Bottom) div 2;
            Found := True;
        end;
    end
    else if not Found then
        Pos := Top;
end;

function TtsSortIntList.Locate(Value: Longint; var Found: Boolean): Longint;
begin
    Result := 0;
    Found := False;
    FindPosition(1, Count, Value, Result, Found);
end;

//End implementation of TtsSortIntList
//******************************************************************************

end.