Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/DYNSTR.ZIP/DYNSTRNG.PAS

Pascal/Delphi Source File | 1988-03-19 | 17.0 KB | 638 lines

{*********************************************************************}
{
     This module implements a dynamic String data type and the
     Procedures and Functions needed to work with such Strings.

     This package owes most of its existence to two articles
     found in the Journal: Software - Practice and Experience

     Vol. 9 pages 779 - 788  "Implementing Strings In Pascal"
                             by Judy M. Bishop

     Vol. 9 pages 671 - 683  "Strings and the Sequence
                              Abstraction in Pascal"
                             by A.H.J. Sale

                ++++++++++++++++++++++++++++++++++++++++

     This software is Public Domain, and the author makes no
     guarantees as to its suitability for any application whatsoever.
     It is provided AS IS!

    Author:   Eric C. Wentz     (Compuserve 70741,517)

     NOTES:
        1)  By playing around with chunksize, you can achieve
            almost startling efficiency.  With a Chunksize of
            40, I have stored 136315 byte file into 151245 bytes RAM.
            (This Included program OverHead!)

        2)  Practical uses of such huge strings elude me, but I am
            told they exist.  I have not really analyzed it much, but
            it seems that for strings in excess of 1000 bytes, reasonable
            efficiency can be obtained using Dynamic Strings.  If you
            store the Carriage Return/Line Feed characters in the String
            and proceed onward with the same String, you are never wasting
            more than Chunksize+4 bytes of RAM.

        3)  If you modify this Code, or add to it, I insist that the
            credits to Dr.'s Bishop and Sale be left Intact. I also
            request copies of significant changes (in case somebody
            develops something of more than merely academic interest).

        4)  If you are one of those gifted (warped?) people who can
            make wonderful things come out of Assembly Language, please
            examine this package with an eye towards quick-running
            assembled code.  Some of the features are S-L-O-W (of necessity).
            If you develop such assembly routines, Please pass them
            on to me.

        5)  These routines have been moderately well tested, but in
            Standard Pascal.  Testing in TP 4.0 has been only sparse.
            If any bugs creep in, please squash them and please let me
            know, or if you can't squash them, let me know anyway --
            No Promises, I'm not in the business of software support,
            but I will TRY to help if you find a bug.

}
{*********************************************************************}
{DYNAMIC STRING PACKAGE}
Unit StrngPak;

Interface
  Uses Crt;

  Const
    Chunksize = 8;

  Type
    Natural  = 0..Maxint;
    Cardinal = 1..Maxint;
    Relation = (BeFore,BeFore_Or_Equalto,Equalto,
                After_Or_Equalto,After,Not_Equalto);

    Fract    = String [Chunksize];
    Pntr      = ^Chunk;

    Chunk     = Record
                  Next : Pntr;
                  Line : Fract;
                End;

    Strng    = Record
                 W        : char;
                 Length   : Natural;
                 Position : 0..Chunksize;
                 Head     : Pntr;
                 Current  : Pntr;
                 Chunkno  : Natural;
                 Status   : (Reading,Writing,Not_Ready)
               End;


  Procedure Create_S (Var S : Strng);
  Procedure Dispose_S (Var S : Strng);

  Procedure ReadString (Var S : Strng);
  Procedure ReadFile (Var From : File; Var S : Strng);
  Procedure WriteFile (Var Onto : Text; S : Strng);
  Procedure WriteString (S : Strng);

  Procedure Assign_S (Var S1 : Strng; S2 : Strng);
  Procedure Copy_S (Var S1 : Strng; S2 : Strng);
  Procedure Insert_S (Var Sst : Strng; Src : Strng; After : Natural);
  Procedure Delete_S (Var Sst : Strng; From : Cardinal; Count : Natural);
  Procedure Concat_S (Var S1 : Strng; S2 : Strng);
  Procedure Extract_S (Src : Strng; From : Cardinal;
                                   Count : Natural; Var Object : Strng);

  Procedure AddChar (Var S : Strng; Ch : Char);
  Procedure Char_to_Strng (Ch : Char; Var S : Strng);

  Function Length_S (S : Strng) : Natural;
  Function Eof_S (S : Strng) : Boolean;
  Function Compare_S (S1 : Strng; R : Relation; S2 : Strng) : Boolean;
  Function Find_S (S1,S2 : Strng) : Natural;

Implementation


Const
  Blank     = ' ';
  Empty     = '';
  ChunkMEM  = 27;  { ((Chunksize+1 bytes)+4 bytes)*2 +1 }
                   { Allows for (2 * Needed) + 1 }

Var
  Avail_S    : Pntr;


{*********************************************************************}
{END OF GLOBAL DECLARATIONS -- LIBRARY PROCEDURES FOLLOW}
{*********************************************************************}

Procedure Create_S (Var S : Strng);   { INITIALIZES A DYNAMIC STRING }
Var
  Temp : Strng;

Begin
  With Temp do
    Begin
      W := Blank;
      Length := 0;
      Position := 0;
      Head := Nil;
      Current := Nil;
      Chunkno := 0;
      Status := Not_Ready
    End;
  S := Temp
End;

Procedure String_Error (N : Natural);
Begin
  GoToXY (28,12);
  HighVideo;
  Write (' **** EXECUTION ERROR IN STRING LIBRARY  ****');
  GoToXY (28,14);
  Write (' ****');
  Case N of
       1 : Write (' PUT ATTEMPTED IN READ STATE ');
       2 : Write (' GET ATTEMPTED IN WRITE STATE ');
       3 : Write (' GET ATTEMPTED BEYOND END OF STRING ');
       4 : Write (' DELETE PORTION BIGGER THAN STRING ');
       5 : Write (' EXTRACT PORTION BIGGER THAN STRING ');
       6 : Write (' INSERTING BEYOND END OF STRING ');
       7 : Write (' INSUFFICIENT MEMORY REMAINING ');
  End;
  Write ('****');
  Write (#7);  {BEEP}
  HALT
End;

Procedure New_S (Var P : Pntr; Var Fail : Boolean);
Var
  I : 1..Chunksize;              { MAKES A NEW CHUNK -- DOES NOT }
                                 { ACTUALLY ADD IT TO STRING }
Begin
  Fail := False;
  If Avail_S = Nil     { IS THERE AN OLD CHUNK FLOATING AROUND? }
    Then
      Begin
        If MemAvail >= ChunkMEM     { IF ENOUGH MEMORY LEFT }
          Then
            Begin
              New (P);
              With P^ do
                Line := Empty;
            End
          Else
            Fail := True  { NOT ENOUGH MEMORY }
      End
    Else
      Begin   { USING OLD CHUNK RATHER THAN MAKING A NEW ONE }
        P := Avail_S;
        Avail_S := Avail_S^.Next
      End
End;

Procedure Dispose_C (p : Pntr);
Begin
  P^.Next := Avail_S;    { PUT UNNEEDED CHUNK WHERE NEW_S CAN RECYCLE IT }
  Avail_S := P
End;

Procedure Re_Write_S (Var S : Strng);
Var
  Fail : Boolean;                  { PREPARE STRING TO ACCEPT INPUT }
Begin
  With S do
    Begin
      If Head = Nil
        Then
          Begin
            New_S (Head,Fail);
            If Fail
              Then
                String_Error (7);  { INSUFFICIENT MEMORY }
            Head^.Next := Nil
          End;
        Current := Head;
        Position := 1;
        Chunkno := 0;
        Length := 0;
        Status := Writing
    End
End;

Procedure Reset_S (Var S: Strng);
Var
  P : Pntr;                      { PREPARE STRING TO BE READ FROM }
Begin
  With S do
    Begin
      If Status = Writing
        Then
          Begin
            Length := Length + Position;
            P := Current^.Next;
            Current^.Next := Nil;
            While P <> Nil do
              Begin
                Current := P^.Next;
                Dispose_C (P);
                P := Current
              End
          End;
      Current := Head;
      Position := 1;
      Chunkno := 0;
      Status := Reading;
      If Current <> Nil
        Then
          W := Current^.Line[1]
        Else
          W := Blank
    End
End;

Function Length_S (S : Strng) : Natural;   { HOW MANY CHARACTERS IN STRING ? }
Begin
  Reset_S (S);
  Length_S := S.Length
End;

Function Eof_S (S : Strng) : Boolean;      { IS NEXT CHARACTER THE LAST ? }
Begin
  With S do
    Eof_S := (Length + 1) = Chunkno * Chunksize + Position
End;

Procedure Put_S (Var S : Strng);
Var
  Fail : Boolean;                   { JUST LIKE A FILE PUT }
Begin                             { ACCEPT THE PRESENT INPUT }
  With S do                    { AND PREPARE TO ACCEPT THE NEXT }
    Begin
      If Status = Reading
        Then
          String_Error(1);
      If Position = Chunksize     { GO TO NEXT CHUNK }
        Then
          Begin
            If Current^.Next = Nil   { IF NO NEXT CHUNK THEN }
              Then
                Begin
                  New_S (Current^.Next,Fail);  { ALLOCATE NEW CHUNK }
                  If Fail
                    Then
                      String_Error (7);  { INSUFFICIENT MEMORY }
                  Current^.Next^.Next := Nil
                End;
            Current := Current^.Next;       { SET RECORD TO REFLECT }
            Chunkno := Chunkno + 1;           { NEW CHUNK POSITION }
            Length := Length + Chunksize;
            Position := 1
          End
        Else
          Position := Position + 1;         { NO NEW CHUNK NEEDED }
      Current^.Line := Current^.Line + W;   { FRACT := FRACT + WINDOW }
      W := Blank;      { RESET WINDOW }
    End
End;

Procedure Get_S (Var S : Strng);
Begin
  With S do                          { JUST LIKE FILE GET }
    Begin                             { SEE PUTD COMMENTS }
      If Status = Writing
        Then
          String_Error(2);
      If Eof_S (S)
        Then
          String_Error(3);
      If Position = Chunksize
        Then
          Begin
            Current := Current^.Next;
            Chunkno := Chunkno + 1;
            Position := 1
          End
        Else
          Position := Position + 1;
      If Current <> Nil
        Then
          W := Current^.Line[Position]  { WINDOW = CURRENT POSITION }
        Else
          W := Blank;
    End
End;

Procedure Dispose_S (Var S : Strng);
Begin
  With S do                     { DE - ALLOCATE ALL CHUNKS IN STRING }
    While Head <> Nil do       { IF NOT SAVED TO DISK, IT IS HISTORY! }
      Begin
        Current := Head^.Next;
        Dispose_C (Head);
        Head := Current
      End
End;

Procedure ReadString (Var S : Strng);
Begin                                  { LOADS STRING FROM KEYBOARD }
  Re_Write_S (S);
  S.W := ReadKey;
  Write (S.W);    {echo the character}
  While S.W <> #26 do  {ctrl-Z}        {terminate on whatever character}
    Begin                                  {suits your application}
      Put_S (S);
      S.W := ReadKey;
    End;
  Reset (Input)    {reset Standard Text File Input}
End;

Procedure ReadFile (Var From : File; Var S : Strng);
Var
  I       : Integer;
  NumRead : Word;
  Buffer  : Array [1..2048] of Char;

Begin
  Re_Write_S (S);                      { LOAD ENTIRE FILE INTO A STRING }
  Reset (From, 1);
  Repeat
    BlockRead (From,Buffer,2048,NumRead);
    If NumRead <> 0
      Then
        Begin
          For I := 1 to NumRead do
            Begin
              S.W := Buffer[I];
              If S.W <> #26     {EOF Marker}
                Then
                  Put_S (S)
            End;
        End
  Until NumRead = 0;
  Close (From)
End;

Procedure WriteFile (Var Onto : Text; S : Strng);
Begin
  Reset_S (S);              { WRITES STRING TO A TEXT FILE i.e LST }
  With S do                     { WRITE WHOLE CHUNK FOR SPEED }
    Begin
      While Current <> Nil do
        Begin
          Write (Current^.Line);
          Current := Current^.Next
        End   {While}
    End       {With}
End;

Procedure WriteString (S : Strng);
Begin                                 { WRITES TO SCREEN }
  WriteFile (Output,S)
End;


Procedure Fastget (Var S : Strng; Pos : Natural);
Var
  Chunkpos, I : Integer;                { LOCATES A CHARACTER IN A STRING BY }
Begin                                      { CHUNK SKIPPING WHERE POSSIBLE }
  Chunkpos := Pos div Chunksize;            { FASTER THAN CALLS TO GET_S }
  If S.Chunkno >= Chunkpos
    Then
      Begin
        Reset_S (S);
        While S.Chunkno < Chunkpos do
          Begin
            S.Current := S.Current^.Next;
            S.Chunkno := S.Chunkno + 1
          End
      End;
  S.Position := Pos mod Chunksize;
  While (S.Position + (S.Chunkno * Chunksize)) <= Pos do
    Get_S (S);    { NEVER MORE THAN CHUNKSIZE CALLS TO GET_S }
End;

Procedure Assign_S (Var S1 : Strng; S2 : Strng);
Begin
  Re_Write_S (S1);
  Reset_S (S2);
  While not Eof_S (S2) do
    Begin
      S1.W := S2.W;
      Put_S (S1);
      Get_S (S2)
    End
End;

Function Compare_S (S1 : Strng; R : Relation; S2 : Strng) : Boolean;
Var
  Less,Equal : Boolean;
  L1,L2 : Natural;

Begin
  L1 := Length_S (S1);
  L2 := Length_S (S2);
  Reset_S (S1);
  Reset_S (S2);
  Equal := L1 = L2;
  Less := False;
  While (Equal and not Less) and not Eof_S (S1) and not Eof_S (S2) do
    Begin
      Equal := S1.W = S2.W;
      Less := S1.W < S2.W;
      Get_S (S1);
      Get_S (S2)
    End;
  Case R of
       Before            : Compare_S := Less;
       Before_Or_Equalto : Compare_S := Less or Equal;
       Equalto           : Compare_S := Equal;
       After_Or_Equalto  : Compare_S := not Less or Equal;
       After             : Compare_S := not Less;
       Not_Equalto       : Compare_S := not Equal
  End
End;

Procedure Char_to_Strng (Ch : Char; Var S : Strng);
Begin
  Re_Write_S (S);
  S.W := Ch;
  Put_S (S)
End;

Procedure Copy_S (Var S1 : Strng; S2 : Strng);
Begin
  Reset_S (S2);
  While not Eof_S (S2) do
    Begin
      S1.W := S2.W;
      Put_S (S1);
      Get_S (S2)
    End
End;

Procedure Append_S (Var S1 : Strng; S2 : Strng);
Var
  St : Strng;

Begin
  Create_S (St);
  Re_Write_S (St);
  Copy_S (St,S1);
  Copy_S (St,S2);
  Re_Write_S (S1);
  Copy_S (S1,St)
End;

Procedure Extract_S (Src : Strng; From : Cardinal;
                    Count : Natural; Var Object : Strng);
Var
  I  : Cardinal;
  St : Strng;
                             { Create substring Object from
                               Src[from] to Src[from+Count] }
Begin
  Create_S (St);
  If (Length_S (Src) < (From + Count - 1))
    Then
      String_Error (5);
  Reset_S (Src);
  Re_Write_S (St);
  Fastget (Src,From-1);
  For I := 1 to Count do
    Begin
      St.W := Src.W;
      Put_S (St);
      Get_S (Src)
    End;
  Copy_S (Object,St)
End;

Procedure Insert_S (Var Sst : Strng; Src : Strng; After : Natural);
Var
  I : Cardinal;
  St : Strng;
                          { Insert Substring Src into Sst after
                            Sst[After] }
Begin
  Create_S (St);
  If (Length_S (Sst) < After)
    Then
      String_Error (6);
  Reset_S (Sst);
  Re_Write_S (St);
  For I := 1 to After do
    Begin
      St.W := Sst.W;
      Put_S (St);
      Get_S (Sst)
    End;
  Copy_S (St,Src);
  While not Eof_S (Sst) do
    Begin
      St.W := Sst.W;
      Put_S (St);
      Get_S (Sst)
    End;
  Re_Write_S (Sst);
  Copy_S (Sst,St)
End;

Procedure Delete_S (Var Sst : Strng; From : Cardinal; Count : Natural);
Var
  I  : Cardinal;
  St : Strng;
                             { Delete Count characters from
                               Sst[From] to Sst[From+Count] }
Begin
  Create_S (St);
  If (Length_S (Sst) < (From + Count - 1))
    Then
      String_Error (4);
  Reset_S (Sst);
  Re_Write_S (St);
  For I := 1 to (From - 1) do
    Begin
      St.W := Sst.W;
      Put_S (St);
      Get_S (Sst)
    End;
  For I := 1 to Count do
    Get_S (Sst);
  While not Eof_S (Sst) do
    Begin
      St.W := Sst.W;
      Put_S (St);
      Get_S (Sst)
    End;
  Re_Write_S (Sst);
  Copy_S (Sst,St)
End;

Function Find_S (S1,S2 : Strng) : Natural;
Var
  M,N    : Natural;
  I      : Cardinal;
  Object : Strng;
  State  : (scanning,found,notfound);

Begin
  Create_S (Object);
  M := Length_S (S1);
  N := Length_S (S2);
  If (N = 0) or (M < N)
    Then
      Begin
        Find_S := 0
      End
    Else
      Begin
        I := 1;
        State := scanning;
        While (State = scanning) do
          Begin
            Extract_S (S1,I,N,Object);
            If (Compare_S (Object,Equalto,S2))
              Then
                Begin
                  State := found;
                  Find_S := I
                End
              Else
                Begin
                  I := I + 1;
                  If ((M - I + 1) < N)
                    Then
                      Begin
                        State := notfound;
                        Find_S := 0
                      End;
                End
          End
      End
End;

Procedure Concat_S (Var S1 : Strng; S2 : Strng);
Begin
  Append_S (S1,S2)
End;

Procedure AddChar (Var S : Strng; Ch : Char);
Begin
  S.W := Ch;
  Put_S (S)
End;

Procedure Init_String_Pack;
Begin
  Avail_S := Nil;
End;

Begin
  Init_String_Pack;
End. {Unit String Pack}