stlist.pas

条码控件： 一维条码控件 二维条码控件 PDF417Barcode MaxiCodeBarcode

(* ***** 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: StList.pas 4.03                             *}
{*********************************************************}
{* SysTools: Linked list class                           *}
{*********************************************************}

{$I StDefine.inc}

{Notes:
  Nodes stored in the list can be of type TStListNode or of a derived type.
  Pass the node class to the list constructor.

  TStList is a doubly-linked list that can be scanned backward just as
  efficiently as forward.

  The list retains the index and node of the last node found by Nth (or by
  the indexed array property). This makes For loops that scan a list much
  faster and speeds up random calls to Nth by about a factor of two.
}

unit StList;

interface

uses
  Windows, SysUtils, Classes,
  StConst, StBase;

type
  TStListNode = class(TStNode)
  {.Z+}
    protected
      FNext : TStListNode;     {Next node}
      FPrev : TStListNode;     {Previous node}

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

  TStList = class(TStContainer)
  {.Z+}
  protected
    {property instance variables}
    FHead : TStListNode;     {Start of list}
    FTail : TStListNode;     {End of list}

    {private instance variables}
    lsLastI : LongInt;        {Last index requested from Nth}
    lsLastP : TStListNode;    {Last node returned by Nth}

    {protected undocumented methods}
    procedure ForEachPointer(Action : TIteratePointerFunc;
                             OtherData : pointer);
      override;
  function StoresPointers : boolean;
    override;
  {.Z-}
  public
    constructor Create(NodeClass : TStNodeClass); virtual;
      {-Initialize an empty list}

    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 Append(Data : Pointer) : TStListNode;
      {-Add a new node to the end of a list}
    function Insert(Data : Pointer) : TStListNode;
      {-Insert a new node at the start of a list}
    function Place(Data : Pointer; P : TStListNode) : TStListNode;
      {-Place a new node into a list after an existing node P}
    function PlaceBefore(Data : Pointer; P : TStListNode) : TStListNode;
      {-Place a new node into a list before an existing node P}
    function InsertSorted(Data : Pointer) : TStListNode;
      {-Insert a new node in sorted order}
    procedure MoveToHead(P : TStListNode);
      {-Move P to the head of the list}

    procedure Assign(Source: TPersistent); override;
      {-Assign another container's contents to this one}
    procedure Join(P : TStListNode; L : TStList);
      {-Join list L after P in the current list. L is freed}
    function Split(P : TStListNode) : TStList;
      {-Split list, creating a new list that starts with P}

    procedure Sort;
      {-Put the list into sorted order}

    procedure Delete(P : TStListNode);
      {-Remove an element and dispose of its contents}

    function Next(P : TStListNode) : TStListNode;
      {-Return the node after P, nil if none}
    function Prev(P : TStListNode) : TStListNode;
      {-Return the node before P, nil if none}
    function Nth(Index : LongInt) : TStListNode;
      {-Return the Index'th node in the list, Index >= 0 (cached)}
    function NthFrom(P : TStListNode; Index : LongInt) : TStListNode;
      {-Return the Index'th node from P, either direction}
    function Posn(P : TStListNode) : LongInt;
      {-Return the ordinal position of an element in the list}
    function Distance(P1, P2 : TStListNode) : LongInt;
      {-Return the number of nodes separating P1 and P2 (signed)}
    function Find(Data : Pointer) : TStListNode;
      {-Return the first node whose data equals Data}
    function Iterate(Action : TIterateFunc; Up : Boolean;
                     OtherData : Pointer) : TStListNode;
      {-Call Action for all the nodes, returning the last node visited}

    property Head : TStListNode
      {-Return the head node}
      read FHead;
    property Tail : TStListNode
      {-Return the tail node}
      read FTail;
    property Items[Index : LongInt] : TStListNode
      {-Return the Index'th node, 0-based}
      read Nth;
      default;
  end;

  {.Z+}
  TStListClass = class of TStList;
  {.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;

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

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

function FindNode(Container : TStContainer;
                  Node : TStNode;
                  OtherData : Pointer) : Boolean; far;
begin
  Result := (Node.Data <> OtherData);
end;

function AssignData(Container : TStContainer;
                    Data, OtherData : Pointer) : Boolean; far;
  var
    OurList : TStList absolute OtherData;
  begin
    OurList.Append(Data);
    Result := true;
  end;

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

function TStList.Append(Data : Pointer) : TStListNode;
var
  N : TStListNode;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    N := TStListNode(conNodeClass.Create(Data));
    N.FPrev := FTail;
    if not Assigned(FHead) then begin
      {Special case for first node}
      FHead := N;
      FTail := N;
    end else begin
      {Add at end of existing list}
      FTail.FNext := N;
      FTail := N;
    end;
    Inc(FCount);
    Result := N;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStList.Assign(Source: TPersistent);
  begin
    {$IFDEF ThreadSafe}
    EnterCS;
    try
    {$ENDIF}
      {The only containers that we allow to be assigned to a linked list are
         - another SysTools linked list (TStList)
         - a 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 TStList.Clear;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    if Count > 0 then begin
      Iterate(DestroyNode, True, nil);
      FCount := 0;
    end;
    FHead := nil;
    FTail := nil;
    lsLastI := -1;
    lsLastP := nil;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

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

procedure TStList.Delete(P : TStListNode);
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    if (not Assigned(P)) or (Count <= 0) then
      Exit;
    if not (P is conNodeClass) then
      RaiseContainerError(stscBadType);

    with P do begin
      {Fix pointers of surrounding nodes}
      if Assigned(FNext) then
        FNext.FPrev := FPrev;
      if Assigned(FPrev) then
        FPrev.FNext := FNext;
    end;

    {Fix head and tail of list}
    if FTail = P then
      FTail := FTail.FPrev;
    if FHead = P then
      FHead := FHead.FNext;

    {Dispose of the node}
    DisposeNodeData(P);
    P.Free;
    Dec(FCount);
    lsLastI := -1;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

function TStList.Distance(P1, P2 : TStListNode) : LongInt;
var
  I : LongInt;
  N : TStListNode;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    {Count forward}
    I := 0;
    N := P1;
    while Assigned(N) and (N <> P2) do begin
      Inc(I);
      N := N.FNext;
    end;
    if N = P2 then begin
      Result := I;
      Exit;
    end;

    {Count backward}
    I := 0;
    N := P1;
    while Assigned(N) and (N <> P2) do begin
      Dec(I);
      N := N.FPrev;
    end;
    if N = P2 then begin
      Result := I;
      Exit;
    end;

    {Not on same list}
    Result := MaxLongInt;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

function TStList.Find(Data : Pointer) : TStListNode;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    Result := Iterate(FindNode, True, Data);
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStList.ForEachPointer(Action : TIteratePointerFunc;
                                 OtherData : pointer);
var
  N : TStListNode;
  P : TStListNode;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    N := FHead;
    while Assigned(N) do begin
      P := N.FNext;
      if Action(Self, N.Data, OtherData) then
        N := P
      else
        Exit;
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

function TStList.Insert(Data : Pointer) : TStListNode;
var
  N : TStListNode;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    N := TStListNode(conNodeClass.Create(Data));
    {N.FPrev := nil;}
    N.FNext := FHead;
    if not Assigned(FHead) then
      {Special case for first node}
      FTail := N
    else
      {Add at start of existing list}
      FHead.FPrev := N;
    FHead := N;
    Inc(FCount);
    lsLastI := -1;
    Result := N;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

function TStList.InsertSorted(Data : Pointer) : TStListNode;
var
  N : TStListNode;
  P : TStListNode;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    N := TStListNode(conNodeClass.Create(Data));
    Result := N;
    Inc(FCount);
    lsLastI := -1;

    if not Assigned(FHead) then begin
      {First element added to list}
      FHead := N;
      FTail := N;
    end else begin
      P := FHead;
      while Assigned(P) do begin
        if DoCompare(N.Data, P.Data) < 0 then begin
          if not Assigned(P.FPrev) then begin
            {New head}
            FHead := N;
          end else begin
            P.FPrev.FNext := N;
            N.FPrev := P.FPrev;
          end;
          P.FPrev := N;
          N.FNext := P;
          Exit;
        end;
        P := P.FNext;
      end;
      {New tail}
      FTail.FNext := N;
      N.FPrev := FTail;
      FTail := N;
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

function TStList.Iterate(Action : TIterateFunc; Up : Boolean;
                         OtherData : Pointer) : TStListNode;
var
  N : TStListNode;
  P : TStListNode;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    if Up then begin
      N := FHead;
      while Assigned(N) do begin
        P := N.FNext;
        if Action(Self, N, OtherData) then
          N := P
        else begin
          Result := N;
          Exit;
        end;
      end;
    end else begin
      N := FTail;
      while Assigned(N) do begin
        P := N.FPrev;
        if Action(Self, N, OtherData) then
          N := P
        else begin
          Result := N;
          Exit;
        end;
      end;
    end;
    Result := nil;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStList.Join(P : TStListNode; L : TStList);
var
  N : TStListNode;
  Q : TStListNode;
begin
{$IFDEF ThreadSafe}
  EnterClassCS;
  EnterCS;
  L.EnterCS;