Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/SHDK_2.ZIP/SHLIST.PAS

Pascal/Delphi Source File | 1992-04-30 | 21.2 KB | 670 lines

{$I SHDEFINE.INC}

{$I SHUNITSW.INC}

{$D-,L-}
{$A-,V-}
unit ShList;
{
                                 ShList

                         A List Processing Unit

                                   by

                              Bill Madison

                   W. G. Madison and Associates, Ltd.
                          13819 Shavano Downs
                            P.O. Box 780956
                       San Antonio, TX 78278-0956
                             [phone]
                             CIS 73240,342

                  Copyright 1991 Madison & Associates
                          All Rights Reserved

        This file may  be used and distributed  only in accord-
        ance with the provisions described on the title page of
                  the accompanying documentation file
                              SKYHAWK.DOC
}

interface

uses
  TpString,
  TpInline,
  TpMemChk;

type
  slNodePtr = ^slNode;
  slNode    = record
                Data  : pointer;
                Next  : slNodePtr;
                end;
  dlNodePtr = ^dlNode;
  dlNode    = record
                Data  : pointer;
                Next,
                Prev  : dlNodePtr;
                end;
  slList    = record
                DataRecSize : word;
                Count       : LongInt;
                Head,
                Tail,
                Current     : slNodePtr;
                end;
  dlList    = record
                DataRecSize : word;
                Count       : LongInt;
                Head,
                Tail,
                Current     : dlNodePtr;
                end;
  dlLessFunc= function(var DataRec1, DataRec2)  : boolean;

{******************INITIALIZATION ROUTINES************************}

procedure slListInit(var L  : slList; RecSize : word);
{Initializes a singly linked list.}

procedure dlListInit(var L : dlList; RecSize : word);
{Initializes a doubly linked list.}

{******************STORAGE ROUTINES************************}

function slPush(var L : slList; var DataRec) : boolean;
function dlPush(var L : dlList; var DataRec) : boolean;
{Pushes a data record onto the top of the list.}

function slAppend(var L : slList; var DataRec) : boolean;
function dlAppend(var L : dlList; var DataRec) : boolean;
{Appends a data record to the tail of the list.}

function slPut(var L : slList; var DataRec) : boolean;
function dlPut(var L : dlList; var DataRec) : boolean;
{Inserts a data record following the current node; returns with current
 pointer directed to the new node.}

function dlPutPrev(var L : dlList; var DataRec) : boolean;
{Inserts a data record ahead of the current node; returns with current
 pointer directed to the new node.}

function dlPutSorted(var L : dlList;
                        var DataRec; Less : dlLessFunc) : boolean;
{Inserts a data record into the list in sorted order, as determined by
 the user-defined boolean function LESS.}

procedure slFree(var L : slList);
procedure dlFree(var L : dlList);
{Releases the heap space allocated for a list and re-initializes the
 list.}

{******************RETRIEVAL ROUTINES************************}

function slGetCurrent(var L : slList; var DataRec) : boolean;
{Returns the data record at the current node and does not move the node
 pointer. Returns a function value of false if the list is empty or the
 current node pointer is nil.}

function dlGetCurrent(var L : dlList; var DataRec) : boolean;
{Returns the data record at the current node and does not move the node
 pointer. Returns a function value of false if the list is empty or the
 current node pointer is nil.}

function slGetFirst(var L : slList; var DataRec) : boolean;
{Returns the data record at the head of the list. Sets the current node
 pointer to the head of the list. Returns a function value of false if
 the list is empty.}

function dlGetFirst(var L : dlList; var DataRec) : boolean;
{Returns the data record at the head of the list. Sets the current node
 pointer to the head of the list. Returns a function value of false if
 the list is empty.}

function slGetLast(var L : slList; var DataRec) : boolean;
{Returns the data record at the tail of the list. Sets the current node
 pointer to the tail of the list. Returns a function value of false if
 the list is empty.}

function dlGetLast(var L : dlList; var DataRec) : boolean;
{Returns the data record at the tail of the list. Sets the current node
 pointer to the tail of the list. Returns a function value of false if
 the list is empty.}

function slGetNext(var L : slList; var DataRec) : boolean;
{Returns the next data record in the list. Sets the current node pointer
 to the record retrieved. Returns a function value of false if the list is
 empty or if the last record successfully retrieved was at the list tail.
 In this case, calling slGetNext again will retrieve the head of the list.}

function dlGetNext(var L : dlList; var DataRec) : boolean;
{Returns the next data record in the list. Sets the current node pointer
 to the record retrieved. Returns a function value of false if the list is
 empty or if the last record successfully retrieved was at the list tail.
 In this case, calling dlGetNext again will retrieve the head of the list.}

function dlGetPrev(var L : dlList; var DataRec) : boolean;
{Same as dlGetNext, but in the opposite direction.}

function slPop(var L : slList; var DataRec) : boolean;
{Returns the data record at the head of the list, then deallocates the
 space associated with the data record and node. Returns a function value
 of false if the list is empty.}

function dlPop(var L : dlList; var DataRec) : boolean;
{Returns the data record at the head of the list, then deallocates the
 space associated with the data record and node. Returns a function value
 of false if the list is empty.}

{******************GENERAL UTILITY ROUTINES************************}

function slCount(L : slList) : LongInt;
{Returns the number of records currently in the list.}

function dlCount(L : dlList) : LongInt;
{Returns the number of records currently in the list.}

function slSpaceUsed(L : slList) : LongInt;
{Returns the total amount of heap space currently allocated to the list.}

function dlSpaceUsed(L : dlList) : LongInt;
{Returns the total amount of heap space currently allocated to the list.}

function Ptr2Str(P : pointer) : string;
{This function is included primarily for debugging.}
{Returns a string of the form ssss:oooo being the hex representation of
 the pointer P following normalization, in segment:offset form.}

{*******************************************************************}
{*******************************************************************}
implementation
{*******************************************************************}
{*******************************************************************}

{******************INTERNAL UTILITY ROUTINES************************}

function Ptr2Str(P:pointer) : string; {For debugging only!}
  begin
    Ptr2Str := HexPtr(Normalized(P));
    end;

function slGrabMemory(var L : slList;
                      var P : slNodePtr;
                      var DataRec)        : boolean;
{Gets the heap space needed for the node and its data record.}
  begin
    if GetMemCheck(P, SizeOf(slNode)) then begin
      if GetMemCheck(P^.Data, L.DataRecSize) then begin
        slGrabMemory := true;
        Move(DataRec, P^.Data^, L.DataRecSize);
        exit;
        end
      else {room for the node but not the data}
        FreeMemCheck(P, SizeOf(slNode));
      end;
    {If we get to here, there has been a space allocation problem.}
    slGrabMemory := false;
    end;  {slGrabMemory}

function dlGrabMemory(var L : dlList;
                      var P : dlNodePtr;
                      var DataRec)        : boolean;
{Gets the heap space needed for the node and its data record.}
  begin
    if GetMemCheck(P, SizeOf(dlNode)) then begin
      if GetMemCheck(P^.Data, L.DataRecSize) then begin
        dlGrabMemory := true;
        Move(DataRec, P^.Data^, L.DataRecSize);
        exit;
        end
      else {room for the node but not the data}
        FreeMemCheck(P, SizeOf(dlNode));
      end;
    {If we get to here, there has been a space allocation problem.}
    dlGrabMemory := false;
    end;  {dlGrabMemory}

function slFirstNode(var L : slList; var P : slNodePtr) : boolean;
{If list L is empty and the first node has been allocated, sets up the
 pointers. Assumes that the node has been allocated with slGrabMemory.
 Returns a function value of false if the list is not empty.}
  begin
    L.Current := P;
    if L.Count = 0 then begin
      slFirstNode := true;
      P^.Next := nil;
      L.Head := P;
      L.Tail := P;
      end
    else
      slFirstNode := false;
    end; {slFirstNode}

function dlFirstNode(var L : dlList; var P : dlNodePtr) : boolean;
{If list L is empty and the first node has been allocated, sets up the
 pointers. Assumes that the node has been allocated with dlGrabMemory.
 Returns a function value of false if the list is not empty.}
  var
    B1  : boolean;
  begin
    B1 := slFirstNode(slList(L), slNodePtr(P));
    if B1 then
      P^.Prev := nil;
    dlFirstNode := B1;
    end; {dlFirstNode}

{******************INITIALIZATION ROUTINES************************}

procedure slListInit(var L  : slList; RecSize : word);
{Initializes a singly linked list.}
  begin
    with L do begin
      DataRecSize := RecSize;
      Count := 0;
      Head := nil;
      Tail := nil;
      Current := nil;
      end; {with}
    end; {slListInit}

procedure dlListInit(var L : dlList; RecSize : word);
{Initializes a doubly linked list.}
  begin
    slListInit(slList(L), RecSize);
    end; {dlListInit}

{******************STORAGE ROUTINES************************}

function slPush(var L : slList; var DataRec) : boolean;
{Pushes a data record onto the top of the list.}
  var
    P : slNodePtr;
  begin
    if not slGrabMemory(L, P, DataRec) then begin
      slPush := false;
      exit;
      end;
    slPush := true;
    if not slFirstNode(L, P) then begin
      P^.Next := L.Head;
      L.Head := P;
      end;
    inc(L.Count);
    end; {slPush}

function dlPush(var L : dlList; var DataRec) : boolean;
{Pushes a data record onto the top of the list.}
  var
    P : dlNodePtr;
  begin
    if not dlGrabMemory(L, P, DataRec) then begin
      dlPush := false;
      exit;
      end;
    dlPush := true;
    if not dlFirstNode(L, P) then begin
      P^.Next := L.Head;
      L.Head^.Prev := P;
      L.Head := P;
      L.Head^.Prev := nil;
      end;
    inc(L.Count);
    end; {dlPush}

function slAppend(var L : slList; var DataRec) : boolean;
{Appends a data record to the tail of the list.}
  var
    P : slNodePtr;
  begin
    if not slGrabMemory(L, P, DataRec) then begin
      slAppend := false;
      exit;
      end;
    slAppend := true;
    if not slFirstNode(L, P) then begin
      L.Tail^.Next := P;
      L.Tail := P;
      L.Tail^.Next := nil;
      end;
    inc(L.Count);
    end; {slAppend}

function dlAppend(var L : dlList; var DataRec) : boolean;
{Appends a data record to the tail of the list.}
  var
    P : dlNodePtr;
  begin
    if not dlGrabMemory(L, P, DataRec) then begin
      dlAppend := false;
      exit;
      end;
    dlAppend := true;
    if not dlFirstNode(L, P) then begin
      L.Tail^.Next := P;
      P^.Prev := L.Tail;
      L.Tail := P;
      L.Tail^.Next := nil;
      end;
    inc(L.Count);
    end; {dlAppend}

function slPut(var L : slList; var DataRec) : boolean;
{Inserts a data record following the current node; returns with current
 pointer directed to the new node.}
  var
    P,
    C : slNodePtr;
  begin
    if not slGrabMemory(L, P, DataRec) then begin
      slPut := false;
      exit;
      end;
    slPut := true;
    C := L.Current;
    if not slFirstNode(L, P) then begin
      L.Current^.Next := C^.Next;
      C^.Next := L.Current;
      end;
    if L.Current^.Next = nil then
      L.Tail := L.Current;
    inc(L.Count);
    end; {slPut}

function dlPut(var L : dlList; var DataRec) : boolean;
{Inserts a data record following the current node; returns with current
 pointer directed to the new node.}
  var
    P,
    C : dlNodePtr;
  begin
    if not dlGrabMemory(L, P, DataRec) then begin
      dlPut := false;
      exit;
      end;
    dlPut := true;
    C := L.Current;
    if not dlFirstNode(L, P) then begin
      L.Current^.Next := C^.Next;
      C^.Next := L.Current;
      L.Current^.Prev := C;
      L.Current^.Next^.Prev := L.Current;
      end;
    if L.Current^.Next = nil then
      L.Tail := L.Current;
    inc(L.Count);
    end; {dlPut}

function dlPutPrev(var L : dlList; var DataRec) : boolean;
{Inserts a data record ahead of the current node; returns with current
 pointer directed to the new node.}
  var
    P,
    C : dlNodePtr;
  begin
    if not dlGrabMemory(L, P, DataRec) then begin
      dlPutPrev := false;
      exit;
      end;
    dlPutPrev := true;
    C := L.Current;
    if not dlFirstNode(L, P) then begin
      L.Current^.Prev := C^.Prev;
      C^.Prev := L.Current;
      L.Current^.Next := C;
      L.Current^.Prev^.Next := L.Current;
      end;
    if L.Current^.Prev = nil then
      L.Head := L.Current;
    inc(L.Count);
    end; {dlPutPrev}

function dlPutSorted(var L : dlList;
                        var DataRec; Less : dlLessFunc) : boolean;
{Inserts a data record into the list in sorted order, as determined by
 the user-defined boolean function LESS.}
  var
    DataRec0  : pointer;
  begin
    if L.Count = 0 then begin                 {Empty list}
      dlPutSorted := dlPut(L, DataRec);
      exit;
      end;
    if not GetMemCheck(DataRec0, L.DataRecSize) then begin
      dlPutSorted := false;
      exit;
      end;
    if not dlGetCurrent(L, DataRec0^) then begin
      if dlGetLast(L, DataRec0^) then ;
      if Less(DataRec0^, DataRec) then begin
        dlPutSorted := dlAppend(L, DataRec);
        FreeMemCheck(DataRec0, L.DataRecSize);
        exit;
        end;
      if dlGetFirst(L, DataRec0^) then ;
      if not Less(DataRec0^, DataRec) then begin
        dlPutSorted := dlPush(L, DataRec);
        FreeMemCheck(DataRec0, L.DataRecSize);
        exit;
        end;
      end; {if not dlGetCurrent}
    if Less(DataRec0^, DataRec) then begin
      while dlGetNext(L, DataRec0^) and Less(DataRec0^, DataRec) do ;
      if not Less(DataRec0^, DataRec) then begin
        dlPutSorted := dlPutPrev(L, DataRec);
        end
      else begin
        dlPutSorted := dlAppend(L, DataRec);
        end
      end {if Less}
    else begin
      while dlGetPrev(L, DataRec0^) and not Less(DataRec0^, DataRec) do ;
      if Less(DataRec0^, DataRec) then
        dlPutSorted := dlPut(L, DataRec)
      else
        dlPutSorted := dlPush(L, DataRec);
      end; {else}
    FreeMemCheck(DataRec0, L.DataRecSize);
    end; {dlPutSorted}

procedure slFree(var L : slList);
{Releases the heap space allocated for a list and re-initializes the
 list.}
  var
    T1  : LongInt;
    P   : slNodePtr;
  begin
    for T1 := 1 to L.Count do begin
      P := L.Head;
      L.Head := P^.Next;
      FreeMemCheck(P^.Data, L.DataRecSize);
      FreeMemCheck(P, SizeOf(slNode));
      end;
    slListInit(L, L.DataRecSize);
    end; {slFree}

procedure dlFree(var L : dlList);
{Releases the heap space allocated for a list and re-initializes the
 list.}
  var
    T1  : LongInt;
    P   : dlNodePtr;
  begin
    for T1 := 1 to L.Count do begin
      P := L.Head;
      L.Head := P^.Next;
      FreeMemCheck(P^.Data, L.DataRecSize);
      FreeMemCheck(P, SizeOf(dlNode));
      end;
    dlListInit(L, L.DataRecSize);
    end; {dlFree}

{******************RETRIEVAL ROUTINES************************}

function slGetCurrent(var L : slList; var DataRec) : boolean;
{Returns the data record at the current node and does not move the node
 pointer. Returns a function value of false if the list is empty or the
 current node pointer is nil.}
  begin
    if L.Current = nil then begin
      slGetCurrent := false;
      exit;
      end;
    slGetCurrent := true;
    Move(L.Current^.Data^, DataRec, L.DataRecSize);
    end; {slGetCurrent}

function dlGetCurrent(var L : dlList; var DataRec) : boolean;
{Returns the data record at the current node and does not move the node
 pointer. Returns a function value of false if the list is empty or the
 current node pointer is nil.}
  var
    S : slList absolute L;
  begin
    dlGetCurrent := slGetCurrent(S, DataRec);
    end; {dlGetCurrent}

function slGetFirst(var L : slList; var DataRec) : boolean;
{Returns the data record at the head of the list. Sets the current node
 pointer to the head of the list. Returns a function value of false if
 the list is empty.}
  begin
    L.Current := L.Head;
    slGetFirst := slGetCurrent(L, DataRec);
    end; {slGetFirst}

function dlGetFirst(var L : dlList; var DataRec) : boolean;
{Returns the data record at the head of the list. Sets the current node
 pointer to the head of the list. Returns a function value of false if
 the list is empty.}
  var
    S : slList absolute L;
  begin
    dlGetFirst := slGetFirst(S, DataRec);
    end; {dlGetFirst}

function slGetLast(var L : slList; var DataRec) : boolean;
{Returns the data record at the tail of the list. Sets the current node
 pointer to the tail of the list. Returns a function value of false if
 the list is empty.}
  begin
    L.Current := L.Tail;
    slGetLast := slGetCurrent(L, DataRec);
    end; {slGetLast}

function dlGetLast(var L : dlList; var DataRec) : boolean;
{Returns the data record at the tail of the list. Sets the current node
 pointer to the tail of the list. Returns a function value of false if
 the list is empty.}
  var
    S : slList absolute L;
  begin
    dlGetLast := slGetLast(S, DataRec);
    end; {dlGetLast}

function slGetNext(var L :slList; var DataRec) : boolean;
{Returns the next data record in the list. Sets the current node pointer
 to the record retrieved. Returns a function value of false if the list is
 empty or if the last record successfully retrieved was at the list tail.
 In this case, calling slGetNext again will retrieve the head of the list.}
  begin
    if not (L.Count = 0) then begin
      if L.Current = nil then
        L.Current := L.Head
      else
        L.Current := L.Current^.Next;
      end; {if not L.Count}
    slGetNext := slGetCurrent(L, DataRec);
    end; {slGetNext}

function dlGetNext(var L : dlList; var DataRec) : boolean;
{Returns the next data record in the list. Sets the current node pointer
 to the record retrieved. Returns a function value of false if the list is
 empty or if the last record successfully retrieved was at the list tail.
 In this case, calling dlGetNext again will retrieve the head of the list.}
  var
    S : slList absolute L;
  begin
    dlGetNext := slGetNext(S, DataRec);
    end; {dlGetNext}

function dlGetPrev(var L : dlList; var DataRec) : boolean;
{Same as dlGetNext, but in the opposite direction.}
  begin
    if not (L.Count = 0) then begin
      if L.Current = nil then
        L.Current := L.Tail
      else
        L.Current := L.Current^.Prev;
      end; {if not L.Count}
    dlGetPrev := dlGetCurrent(L, DataRec);
    end; {dlGetPrev}

function slPop(var L : slList; var DataRec) : boolean;
{Returns the data record at the head of the list, then deallocates the
 space associated with the data record and node. Returns a function value
 of false if the list is empty.}
  var
    P : slNodePtr;
    B : boolean;
  begin
    B := slGetFirst(L, DataRec);
    slPop := B;
    if not B then exit;
    P := L.Head;
    L.Head := P^.Next;
    L.Current := L.Head;
    FreeMemCheck(P^.Data, L.DataRecSize);
    FreeMemCheck(P, SizeOf(slNode));
    dec(L.Count);
    end; {slPop}

function dlPop(var L : dlList; var DataRec) : boolean;
{Returns the data record at the head of the list, then deallocates the
 space associated with the data record and node. Returns a function value
 of false if the list is empty.}
  var
    P : dlNodePtr;
    B : boolean;
  begin
    B := dlGetFirst(L, DataRec);
    dlPop := B;
    if not B then exit;
    P := L.Head;
    L.Head := P^.Next;
    L.Head^.Prev := nil;
    L.Current := L.Head;
    FreeMemCheck(P^.Data, L.DataRecSize);
    FreeMemCheck(P, SizeOf(dlNode));
    dec(L.Count);
    end; {dlPop}

{******************GENERAL UTILITY ROUTINES************************}

function slCount(L : slList) : LongInt;
{Returns the number of records currently in the list.}
  begin
    slCount := L.Count;
    end; {slCount}

function dlCount(L : dlList) : LongInt;
{Returns the number of records currently in the list.}
  begin
    dlCount := L.Count;
    end; {dlCount}

function slSpaceUsed(L : slList) : LongInt;
{Returns the total amount of heap space currently allocated to the list.}
  begin
    slSpaceUsed := L.Count * (L.DataRecSize + SizeOf(slNode));
    end; {slSpaceUsed}

function dlSpaceUsed(L : dlList) : LongInt;
{Returns the total amount of heap space currently allocated to the list.}
  begin
    dlSpaceUsed := L.Count * (L.DataRecSize + SizeOf(dlNode));
    end; {dlSpaceUsed}
  end.