Delphi Programming Unleashed/Delphi_Programming_Unleashed_SAMS_Publishing_1995.iso/units/dblist.pas

Pascal/Delphi Source File | 1995-03-21 | 7.0 KB | 333 lines

unit DBList;
{
  A doubly linked list
  Right now this puppy works with any normal record.
  If you want to work with strings, then use TStringList,
  which is shown below.
}

interface
{$ifndef Windows}
uses
  Objects;
{$EndIf}
const
  ALLOCATE_ERROR = 'Dynamic allocation error';

type
  PString = ^String;

  DListPtr = ^DListRec;
  DListRec = record
    ListData : Pointer;
    PrevPtr,
    NextPtr : DListPtr
  end;

  PDbList = ^TDbList;
  {$IfDef Windows}
  TDBList = class
  {$Else}
  TDbList = Object(TObject)
  {$EndIf}
      NodePtr, Head, Tail: DListPtr;
      ErrorMessage: String;
      ListSize: Integer;
    {$IfDef Windows}
    constructor Create;
    destructor Destroy;
    {$Else}
    constructor Init;
    destructor Done; virtual;
    {$EndIf}
    function DeleteNode(X : Pointer; Occur : Word) : Boolean;
    function InsertNode(X : Pointer ) : Boolean; virtual;
    function GoToHead: Boolean;
    function Search(var ThisPtr: DListPtr; X: Pointer) : Boolean;
    function First: Boolean; virtual;
    function GotoPrevious(var X : Pointer) : Boolean; virtual;
    function GotoNextNode(var X : Pointer) : Boolean; virtual;
    function GotoLast(var X : Pointer) : Boolean; virtual;
    function At(i: LongInt): Pointer;
    procedure DisposeElement(P: Pointer); virtual;
    procedure Clear; virtual;
    function CompFunc(X, Y: Pointer): Boolean; virtual;
  end;

  PStringList = ^TStringList;
  {$IfDef Windows}
  TStringList = class(TDbList)
  {$Else}
  TStringList = Object(TDbList)
  {$EndIf}
    function AddString(S: String): Boolean;
    function GetStringAt(i: Integer): String;
    procedure DisposeElement(P: Pointer); virtual;
  end;

implementation

function NewString(const S: String): PString;
var
  P: PString;
begin
  if S = '' then P := nil else
  begin
    GetMem(P, Length(S) + 1);
    P^ := S;
  end;
  NewString := P;
end;

procedure DisposeString(P: PString);
begin
  if P <> nil then FreeMem(P, Length(P^) + 1);
end;

{$IfDef Windows}
constructor TDbList.Create;
begin
  inherited Create;
  ListSize := 0;
  NodePtr := nil;
  Head := nil;
  Tail := nil;
end;

destructor TDBList.Destroy;
begin
  Clear;
  NodePtr := nil;
  Head := nil;
  Tail := nil;
  ListSize := 0;
  ErrorMessage := '';
  inherited Destroy;
end;
{$Else}
constructor TDbList.Init;
begin
  inherited Init;
  ListSize := 0;
  NodePtr := nil;
  Head := nil;
  Tail := nil;
end;

destructor TDBList.Done;
begin
  Clear;
  NodePtr := nil;
  Head := nil;
  Tail := nil;
  ListSize := 0;
  ErrorMessage := '';
  inherited Done;
end;
{$EndIf}

function TDBList.GoToHead;
begin
  NodePtr := Head;
end;

function TDBList.DeleteNode(X : Pointer; Occur : Word) : Boolean;
var
  ThisPtr, p : DListPtr;
  match : Boolean;

begin
  ErrorMessage := '';
  if Head = nil then begin
    DeleteNode := False;
    Exit;
  end;

  { search for item to delete }
  match := Search(ThisPtr, X);

  if match then begin           { found item in list }
    if ListSize = 1 then begin
      DisposeElement(ThisPtr^.ListData);
      Dispose(Head);
      Head := nil;
      Tail := nil
    end
    else if ThisPtr^.NextPtr = nil then begin
      { delete the last list member }
      p := ThisPtr^.PrevPtr;
      p^.NextPtr := nil;
      DisposeElement(Tail^.ListData);
      Dispose(Tail);
      Tail := p;                { link tail pointer with new last element }
    end
    else if ThisPtr^.PrevPtr = nil then begin
      { delete the list head }
      p := ThisPtr^.NextPtr;
      p^.PrevPtr := nil;
      DisposeElement(Head^.ListData);
      Dispose(Head);
      Head := p;                { link head with new first element }
    end
    else begin
      ThisPtr^.PrevPtr^.NextPtr := ThisPtr^.NextPtr;
      ThisPtr^.NextPtr^.PrevPtr := ThisPtr^.PrevPtr;
      DisposeElement(ThisPtr^.ListData);
      Dispose(ThisPtr)
    end;                        { IF }
    Dec(ListSize);
  end;                          { IF }
  DeleteNode := match           { return function value }
end;

function TDBList.InsertNode(X : Pointer) : Boolean;
var
  ThisPtr : DListPtr;

begin
  New(ThisPtr);
  if ThisPtr = nil then begin
    ErrorMessage := ALLOCATE_ERROR;
    InsertNode := False;
    Exit
  end;
  ThisPtr^.NextPtr := nil;
  ThisPtr^.PrevPtr := Tail;
  { assign key and other fields }
  ThisPtr^.ListData := X;
  if (Head = nil) then begin
    Head := ThisPtr;
    Tail := Head;
  end
  else begin
    Tail^.NextPtr := ThisPtr;
    Tail := ThisPtr;            { reassign pointer to new tail }
  end;
  Inc(ListSize);
  InsertNode := True
end;

function TDBlist.At(i: LongInt): Pointer;
var
  P: Pointer;
  j: LongInt;
begin
  First;
  P := Head^.ListData;
  for j := 1 to i do
    GotoNextNode(P);
  At := P;
end;

function TDbList.First: Boolean;
var
  X: Pointer;
begin
  if Head <> nil then begin
    X := Head^.ListData;
    NodePtr := Head^.NextPtr;
    First := True
  end else
    First := False
end;

function TDbList.CompFunc(X, Y: Pointer): Boolean;
begin
  if X = Y then
    CompFunc := True
  else
    CompFunc := False;
end;

function TDbList.Search(var ThisPtr : DListPtr; X : Pointer) : Boolean;
var
  OutCome: Boolean;

begin
  ErrorMessage := '';

  ThisPtr := Head;
  if Head = nil then begin
    Search := False;
    Exit;
  end;

  OutCome := CompFunc(X, ThisPtr^.ListData);
  while (ThisPtr <> nil) and (not OutCome) do begin
    ThisPtr := ThisPtr^.NextPtr;
    OutCome := CompFunc(X, ThisPtr^.ListData);
  end;
  Search := OutCome;
end;

function TDbList.GotoLast(var X : Pointer) : Boolean;
begin
  if Tail <> nil then begin
    X := Tail^.ListData;
    NodePtr := Tail^.PrevPtr;
    GotoLast := True
  end
  else
    GotoLast := False
end;

function TDbList.GotoNextNode(var X : Pointer) : Boolean;
begin
  GotonextNode := False;
  if NodePtr <> nil then begin
    X := NodePtr^.ListData;
    if NodePtr^.NextPtr <> nil then begin
      NodePtr := NodePtr^.NextPtr;
      GotoNextNode := True
    end;
  end
end;

function TDbList.GotoPrevious(var X : Pointer) : Boolean;
begin
  if NodePtr <> nil then begin
    X := NodePtr^.ListData;
    if NodePtr^.PrevPtr <> nil then
      NodePtr := NodePtr^.PrevPtr;
    GotoPrevious := True
  end
  else
    GotoPrevious := False
end;

procedure TDbList.DisposeElement(P: Pointer);
begin
  if P <> nil then Dispose(P);
end;

procedure TDbList.Clear;
var
  p : DListPtr;
begin
  while Head <> nil do begin
    p := Head;
    Head := Head^.NextPtr;
    DisposeElement(p^.ListData);
    Dispose(p);
    Dec(ListSize);
  end;                          { WHILE }
  Tail := nil;
  ErrorMessage := ''
end;

procedure TStringList.DisposeElement(P: Pointer);
begin
  DisposeString(P);
end;

function TStringList.AddString(S: String): Boolean;
begin
  InsertNode(NewString(S));
end;

function TStringList.GetStringAt(i: Integer): String;
begin
  GetStringAt := PString(At(i))^;
end;

end.