{*********************************************************************}
{
#
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}

program stringDemo(output);

label 999;

Const
   Chunksize = 8;

   Blank = ' ';


Type
   Natural = 0..Maxint;
   Cardinal = 1..Maxint;
   Relation = (BeFore,BeForeOrEqualto,Equalto,
               AfterOrEqualto,After,NotEqualto);

   Fract = packed array [1..Chunksize] of char;
   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 : (NotReady,Reading,Writing)
        End;



(***   use these functions ....

Procedure CreateS(Var S : Strng);
Procedure DisposeS(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 AssignS(Var S1 : Strng; S2 : Strng);
Procedure InsertS(Var Sst : Strng; Src : Strng; After : Natural);
Procedure DeleteS(Var Sst : Strng; From : Cardinal; Count : Natural);
Procedure AppendS(Var S1 : Strng; S2 : Strng);
Procedure ExtractS(Src : Strng; From : Cardinal;
                     Count : Natural; Var Object : Strng);
Procedure PStrtoStrng(ps : packed array[one..len :integer ] of Char;
                      Var S : Strng);
Procedure ChartoStrng(Ch : Char; Var S : Strng);

Function LengthS(S : Strng) : Natural;
Function CompareS(S1 : Strng; R : Relation; S2 : Strng) : Boolean;
Function FindS(S1,S2 : Strng) : Natural;

 other functions are for internal use only

**)


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


  Function ReadKey : char;  { Replacement for CRT.ReadKey }
                            { Just like ReadKey in CRT unit}
{@@ #include <termios.h> @@}
  var chrout: char;
    Begin

      {Char input w/o echo}
/***
      If CheckBreak and (chrout = chr(3)) then  {If it's a ^C and CheckBreak}
        Begin                             {then execute Ctrl_Brk}
        end;
***/

{@@ {}
   int            ch;
   struct termios old;
   struct termios tmp;

   tcgetattr(STDIN_FILENO, &old);
   tmp = old;
   tmp.c_lflag &= ~ICANON & ~ECHO;
   tcsetattr(STDIN_FILENO, TCSANOW, (const struct termios*) &tmp);
   ch = getchar();
   tcsetattr(STDIN_FILENO, TCSANOW, (const struct termios*) &old);

  return ch;
@@}

       ReadKey := ' ';      {unused code}
    end;


Procedure CreateS(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 := NotReady
   End;
   S := Temp
End;

Procedure StringError(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( chr(7) ); {BEEP}
   goto 999;
End;


{ prepare string to accept input }
Procedure ReWriteS(Var S : Strng);
Var
   Fail : Boolean;
Begin
   With S do  Begin
      If Head = Nil Then Begin
         New(Head);
         If Head = nil Then
            StringError(7); { INSUFFICIENT MEMORY }
         Head^.Next := Nil
      End;
      Current := Head;
      Position := 0;  {was 1, but 1 is not occupied yet}
      Chunkno := 0;
      Length := 0;
      Status := Writing
   End
End;


{ prepare string to be read from }
Procedure ResetS(Var S: Strng);
Var
   P : Pntr;
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(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; { ResetS }


{ how many characters in string ? }
Function LengthS(S : Strng) : Natural;
Begin
   ResetS(S);
   LengthS := S.Length
End;

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


{ just like a file put
  accept the present input and prepare to accept the next }
Procedure PutS(Var S : Strng);
Var
   Fail : Boolean;
Begin
   With S do Begin
      If Status = Reading Then
         StringError(1);
      If Position = Chunksize Then Begin { GO TO NEXT CHUNK }
         If Current^.Next = Nil Then Begin { IF NO NEXT CHUNK THEN }
            New(Current^.Next); { ALLOCATE NEW CHUNK }
            If Current^.Next = nil Then
               StringError(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[Position] := W; { FRACT := FRACT + WINDOW }
      W := Blank; { RESET WINDOW }
   End
End;


{ just like file get see putd comments }
Procedure GetS(Var S : Strng);
Begin
   With S do Begin
      If Status = Writing Then
         StringError(2);
      If EofS(S) Then
         StringError(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 DisposeS(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(Head);
         Head := Current
      End
End;


{ loads string from keyboard }
Procedure ReadString(Var S : Strng);
Begin
   ReWriteS(S);
   S.W := ReadKey;
   While S.W <> chr(10) {cr} do Begin  {terminate on whatever character}
                                       {suits your application}
      Write(S.W); {echo the character}
      PutS(S);
      S.W := ReadKey;
   End;
End;


{ load entire file into a string }
Procedure ReadFile(Var From : text; Var S : Strng);
Var
   I : Integer;
   NumRead : integer;
   Buffer : Array [1..2048] of Char;

Begin
   ReWriteS(S);
   Reset(From);
   while not eof(From) do Begin
      if eoln(From) then begin
         readln(From);
         s.w := chr(10);   {new line}
      end
      else
         read(From, S.W);
      PutS(S)
   End
End;

Procedure WriteFile(Var Onto : Text; S : Strng);
var
   n : integer;
Begin
   ResetS(S);       { WRITES STRING TO A TEXT FILE i.e LST }
   With S do Begin  { WRITE WHOLE CHUNK FOR SPEED }
      n := length;
      while n > chunksize do begin
         Write(Onto, Current^.Line);
         Current := Current^.Next;
         n := n - chunksize;
      end; {while}
      Write(Onto, Current^.Line:n); {partial chunk}
   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 GETS }
   If S.Chunkno >= Chunkpos Then Begin
      ResetS(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
      GetS(S); { NEVER MORE THAN CHUNKSIZE CALLS TO GETS }
End;


Procedure AssignS(Var S1 : Strng; S2 : Strng);
Begin
   ReWriteS(S1);
   ResetS(S2);
   While not EofS(S2) do Begin
      S1.W := S2.W;
      PutS(S1);
      GetS(S2)
   End
End;

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

Begin
   L1 := LengthS(S1);
   L2 := LengthS(S2);
   ResetS(S1);
   ResetS(S2);
   Equal := L1 = L2;
   Less := False;
   While (Equal and not Less) and not EofS (S1) and not EofS (S2) do
   Begin
      Equal := S1.W = S2.W;
      Less := S1.W < S2.W;
      GetS(S1);
      GetS(S2)
   End;
   Case R of
     Before :            CompareS := Less;
     BeforeOrEqualto : CompareS := Less or Equal;
     Equalto :           CompareS := Equal;
     AfterOrEqualto :  CompareS := not Less or Equal;
     After :             CompareS := not Less;
     NotEqualto :       CompareS := not Equal
   End
End;

Procedure ChartoStrng(Ch : Char; Var S : Strng);
Begin
   ReWriteS(S);
   S.W := Ch;
   PutS(S)
End;

{copy s2 to current position of s1}
Procedure CopyS(Var S1 : Strng; S2 : Strng);
Begin
   ResetS(S2);
   While not EofS(S2) do Begin
      S1.W := S2.W;
      PutS(S1);
      GetS(S2)
   End
End;


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

Begin
   CreateS(St);
   ReWriteS(St);
   CopyS(St,S1);
   CopyS(St,S2);
   ReWriteS(S1);
   CopyS(S1,St);
   disposes(st);
End;


{ Create substring Object from
  Src[from .. from+Count] }
Procedure ExtractS(Src : Strng; From : Cardinal;
                   Count : Natural; Var Object : Strng);
Var
   I : Cardinal;
   St : Strng;
Begin
   CreateS(St);
   If (LengthS (Src) < (From + Count - 1)) Then
      StringError(5);
   ResetS(Src);
   ReWriteS(St);
   Fastget(Src,From-1);
   For I := 1 to Count do Begin
      St.W := Src.W;
      PutS(St);
      GetS(Src)
   End;
   AssignS(Object,St);  // was CopyS
   disposes(st);
End;


{ Insert Substring Src into Sst after Sst[After] }
Procedure InsertS(Var Sst : Strng; Src : Strng; After : Natural);
Var
   I : Cardinal;
   St : Strng;
Begin
   CreateS(St);
   If (LengthS(Sst) < After) Then
      StringError(6);
   ResetS(Sst);
   ReWriteS(St);
   For I := 1 to After do Begin
      St.W := Sst.W;
      PutS(St);
      GetS(Sst)
   End;
   CopyS(St,Src);
   While not EofS(Sst) do Begin
      St.W := Sst.W;
      PutS(St);
      GetS(Sst)
   End;
   ReWriteS(Sst);
   CopyS(Sst,St);
   disposes(st);
End;


{ Delete Count characters from Sst[From .. From+Count-1] }
Procedure DeleteS(Var Sst : Strng; From : Cardinal; Count : Natural);
Var
   I : Cardinal;
   St : Strng;
Begin
   CreateS(St);
   If (LengthS (Sst) < (From + Count - 1))
      Then
      StringError(4);
   ResetS(Sst);
   ReWriteS(St);
   For I := 1 to (From - 1) do
   Begin
      St.W := Sst.W;
      PutS(St);
      GetS(Sst)
   End;
   For I := 1 to Count do
      GetS(Sst);
   While not EofS(Sst) do
   Begin
      St.W := Sst.W;
      PutS(St);
      GetS(Sst)
   End;
   ReWriteS(Sst);
   CopyS(Sst,St);
   disposes(st);
End;

{find position of s2 inside s1,
 return 0 if not found}
Function FindS(S1,S2 : Strng) : Natural;
Var
   M,N : Natural;
   I : Cardinal;
   Object : Strng;
   State : (scanning,found,notfound);

Begin
   CreateS(Object);
   M := LengthS(S1);
   N := LengthS(S2);
   If (N = 0) or (M < N) Then Begin
      FindS := 0
   End
   Else Begin
      I := 1;
      State := scanning;
      While (State = scanning) do Begin
         ExtractS(S1,I,N,Object);
         If (CompareS(Object,Equalto,S2)) Then Begin
            State := found;
            FindS := I
         End
         Else Begin
            I := I + 1;
            If ((M - I + 1) < N) Then Begin
               State := notfound;
               FindS := 0
            End;
         End
      End
   End;
   disposes(object);
End; { FindS }


{ assign pascal string to strng S }
Procedure PStrtoStrng(ps : packed array[one..len :integer ] of Char;
                      Var S : Strng);
var
   i : integer;
Begin
   ReWriteS(S);
   for i := one to len do begin
      S.W := ps[i];
      PutS(S)
   end; {for}
End;


procedure testS;
var
   s1, s2 : strng;
   f      : text;
   i, j   : integer;
begin
   creates(s1);
   creates(s2);
   write('enter string 1 -->');
   readstring(s2);
   assigns(s1, s2);

   i := lengths(s1);
   writeln('<-- this string is ', i:1, ' characters long');
   write('enter string 2 -->');
   readstring(s2);
   j := lengths(s2);
   writeln('<-- this string is ', j:1, ' characters long');

   if CompareS(s1, BeFore, s2) then
      writeln('s1 is BeFore s2');
   if CompareS(s1, BeForeOrEqualto, s2) then
      writeln('s1 is BeForeOrEqualto s2');
   if CompareS(s1, Equalto, s2) then
      writeln('s1 is Equalto s2');
   if CompareS(s1, AfterOrEqualto, s2) then
      writeln('s1 is AfterOrEqualto s2');
   if CompareS(s1, After, s2) then
      writeln('s1 is After s2');
   if CompareS(s1, NotEqualto, s2) then
      writeln('s1 is NotEqualto s2');

   appends(s1, s2);
   chartostrng(' ', s2);
   inserts(s1, s2, i); {at end of original s1}
   rewrite(f);
   writefile(f, s1);
   reset(f);
   readfile(f, s1);
   deletes(s1, lengths(s1), 1); {remove trailing eoln}

   if i+j+1 <> lengths(s1) then begin
      write('PROBLEM: s1 + s2 is -->');
      writeString(s1);
      writeln('<-- this string is ', lengths(s1):1, ' characters long');
   end;

   for i := 1 to lengths(s1) do begin
      for j := 1 to lengths(s1) - i + 1 do begin
         extracts(s1, i, j, s2);
         if lengths(s2) <> j then begin
            write('PROBLEM: ');
            writeString(s2);
            writeln('<-- this string is ', lengths(s2):1, ' characters long');
         end;
         if finds(s1, s2) <> i then begin
            write('PROBLEM: ');
            writeString(s2);
            writeln(' is at position ', finds(s1, s2):1, ' in s1+s2');
         end;
      end;
   end;

   pstrtostrng('!!', s2);
   if lengths(s2) <> 2 then begin
      write('PROBLEM: ');
      writeString(s2);
      writeln('<-- this string is ', lengths(s2):1, ' characters long');
   end;

   i := lengths(s1);
   inserts(s1, s2, lengths(s1));
   if lengths(s1) <> i+2 then begin
      write('PROBLEM: ');
      writeString(s1);
      writeln('<-- this string is ', lengths(s1):1, ' characters long');
   end;

   deletes(s1, lengths(s1), 1);
   if lengths(s1) <> i+1 then begin
      write('PROBLEM: ');
      writeString(s1);
      writeln('<-- this string is ', lengths(s1):1, ' characters long');
   end;

   disposes(s1);
   disposes(s2);

end; { testS }


Begin
   testS;
999:
End. {Unit String Pack}

{%%%%%%%%%%%%%%%%%%%%%%%%%%%%% end of dynstr.pas %%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
