Simtel MSDOS - Coast to Coast/simteldosarchivecoasttocoast2.iso/turbopas/pslst102.zip/LISTCON.PAS

Pascal/Delphi Source File | 1994-01-10 | 7KB | 332 lines

{

List Control

Rev. 1.02

(c) Copyright 1994, Michael Gallias

Target: Real, Protected, Windows

}

{$V-} {$B-}

{$IFOPT I+} {$DEFINE IOCHECK} {$ENDIF}

Unit ListCon;

Interface

Type
  {$I LISTCON.TYP}   {User Defined Data Type}

  SorterType  = Function(FirstItem,SecondItem:ListData):Boolean;

  PListArray  = ^TListArray;
  TListArray  = Array [1..(65530 Div SizeOf(ListData))-1] of ListData;
                          {Name Changes Here}
  PList       = ^TList;   {In Ver 1.00: ListArrayPtr}
  TList       = Object    {In Ver 1.00: ListObject}
                  Data      :PListArray;
                  CurPtr    :Word;
                  MaxItems  :Word;
                  TotalItems:Word;

                  Procedure Init     (Const Resv:Word);
                  Procedure Load     (Const FileName:String; Var Error:Word); {Don't call Init First!}
                  Procedure Get      (Var   Item:ListData);
                  Procedure Put      (Const Item:ListData);
                  Procedure Insert   (Const Item:ListData);
                  Procedure Delete;
                  Procedure ShiftUp;
                  Procedure GotoNext;
                  Procedure GotoPrev;
                  Procedure GotoBegin;
                  Procedure GotoLast;
                  Procedure GotoEnd;
                  Procedure GotoItem (Const Here:Word);
                  Procedure Hop      (Const By  :LongInt);
                  Procedure SwapWith (Const This:Word);
                  Procedure ShellSort;
                  Procedure Save     (Const FileName:String; Var Error:Word);
                  Function  CurPoint :Word;
                  Function  CurSize  :Word;
                  Function  AtBegin  :Boolean;
                  Function  AtLast   :Boolean;
                  Function  AtEnd    :Boolean;
                  Function  Empty    :Boolean;
                  Function  Full     :Boolean;
                  Procedure Done;

                End;

Var
  UserSort : SorterType;

Implementation

Procedure TList.Init(Const Resv:Word);
Begin
  GetMem(Data,Resv*SizeOf(ListData));
  FillChar(Data^,Resv*SizeOf(ListData),0);
  MaxItems   :=Resv;
  TotalItems :=0;
  CurPtr     :=1;
End;

Procedure TList.Load(Const FileName:String; Var Error:Word);

Var
  F     :File;
  X     :Word;

Begin
  {$I-}
  Assign(F,FileName);
  Reset(F,1);
  Error:=IOResult;
  If Error>0 Then Begin Inc(Error,1000); Exit; End;  {No Init Done}
  If FileSize(F)=0 Then
  Begin
    Close(F);
    Assign(F,FileName);
    Erase(F);
    Error:=1002;
    Exit;
  End;
  BlockRead(F,X,SizeOf(X));
  Init(X);
  BlockRead(F,Data^,MaxItems*SizeOf(ListData));
  BlockRead(F,CurPtr,SizeOf(CurPtr));
  BlockRead(F,TotalItems,SizeOf(TotalItems));
  Error:=IOResult;
  If Error>0 Then Exit;
  Close(F);
  Error:=IOResult;
  {$IFDEF IOCHECK} {$I+} {$ENDIF}
End;

Procedure TList.Get(Var Item:ListData);
Begin
  If CurPtr=0 Then RunError(250);
  Item:=Data^[CurPtr];
End;

Procedure TList.Put(Const Item:ListData);
Begin
  If CurPtr=0 Then RunError(250);
  Data^[CurPtr]:=Item;
  If TotalItems<CurPtr Then TotalItems:=CurPtr;
End;

Procedure TList.Insert(Const Item:ListData);
Begin
  If TotalItems=0 Then
    CurPtr:=1
  Else
    ShiftUp;
  Put(Item);
End;

Procedure TList.Delete;

Var
  X:Word;

Begin
  Dec(TotalItems);
  For X:=CurPtr to TotalItems do
    Data^[X]:=Data^[X+1];
  If CurPtr>TotalItems Then CurPtr:=TotalItems;
  If CurPtr=0 Then CurPtr:=1;
End;

Procedure TList.ShiftUp;

Var
  X:Word;

Begin
  If CurPtr=0 Then CurPtr:=1;
  If TotalItems>0 Then
    For X:=TotalItems DownTo CurPtr do
      Data^[X+1]:=Data^[X];
  Inc(TotalItems);
End;

Procedure TList.GotoNext;
Begin
  Inc(CurPtr);
End;

Procedure TList.GotoPrev;
Begin
  Dec(CurPtr);
End;

Procedure TList.GotoBegin;
Begin
  CurPtr:=1;
End;

Procedure TList.GotoLast;
Begin
  If TotalItems=0 Then
    CurPtr:=1
  Else
    CurPtr:=TotalItems;
End;

Procedure TList.GotoEnd;
Begin
  CurPtr:=TotalItems+1;
End;

Procedure TList.GotoItem(Const Here:Word);
Begin
  CurPtr:=Here;
End;

Procedure TList.Hop(Const By:LongInt);
Begin
  Inc(CurPtr,By);
End;

Procedure TList.SwapWith(Const This:Word);

Var
  Temp2,
  Temp1   :ListData;
  OldP    :Word;

Begin
  OldP:=CurPoint;
  Get(Temp1);
  GotoItem(This);
  Get(Temp2);
  Put(Temp1);
  GotoItem(OldP);
  Put(Temp2);
End;

Procedure TList.ShellSort;

Var
  OldPoint    :Word;
  i,j,k       :LongInt;
  DataB,
  DataA       :ListData;

Begin
  OldPoint:=CurPoint;
  k:=TotalItems Div 2;
  While k>0 do
  Begin
    For i:=k+1 to TotalItems do
    Begin
      j:=i-k;
      While j>0 do
      Begin
        GotoItem(j);
        Get(DataA);
        GotoItem(j+k);
        Get(DataB);
        If UserSort(DataA,DataB) Then
        Begin
          Put(DataA);
          GotoItem(j);
          Put(DataB);
          Dec(j,k);
        End
        Else
          j:=0;
      End;
    End;
    k:=k Div 2;
  End;
  GotoItem(OldPoint);
End;

Procedure TList.Save(Const FileName:String; Var Error:Word);

Var
  F     :File;

Begin
  {$I-}
  Assign(F,FileName);
  Rewrite(F,1);
  Error:=IOResult;
  If Error>0 Then Exit;
  BlockWrite(F,MaxItems,SizeOf(MaxItems));
  BlockWrite(F,Data^,MaxItems*SizeOf(ListData));
  BlockWrite(F,CurPtr,SizeOf(CurPtr));
  BlockWrite(F,TotalItems,SizeOf(TotalItems));
  Error:=IOResult;
  If Error>0 Then Exit;
  Close(F);
  Error:=IOResult;
  {$IFDEF IOCHECK} {$I+} {$ENDIF}
End;

Function TList.CurPoint:Word;
Begin
  CurPoint:=CurPtr;
End;

Function TList.CurSize:Word;
Begin
  CurSize:=TotalItems;
End;

Function TList.AtBegin:Boolean;
Begin
  If CurPtr=1 Then
    AtBegin:=True
  Else
    AtBegin:=False;
End;

Function TList.AtLast:Boolean;
Begin
  If CurPtr=TotalItems Then
    AtLast:=True
  Else
    AtLast:=False;
End;

Function TList.AtEnd:Boolean;
Begin
  If CurPtr>TotalItems Then
    AtEnd:=True
  Else
    AtEnd:=False;
End;

Function TList.Empty:Boolean;
Begin
  If TotalItems=0 Then
    Empty:=True
  Else
    Empty:=False;
End;

Function TList.Full:Boolean;
Begin
  If TotalItems=MaxItems Then
    Full:=True
  Else
    Full:=False;
End;

Procedure TList.Done;
Begin
  FreeMem(Data,MaxItems*SizeOf(ListData));
  MaxItems    :=0;
  TotalItems  :=0;
  CurPtr      :=0;
End;

End.