Donated to the PASCAL/Z USERS GROUP, July 1980
  by Ray Penley

	{---------------------------------------}
	{	    STRLIB LIBRARY		}
	{---------------------------------------}


{
	Functions in this library


	Concat		-Concatenate two strings.
	Copy		-Copy to a substring from a source string
	Delay		-Pause for a requested number of seconds.
	Draw		-Draws/Prints a pattern string.
	GetLine		-Input a string into users buffer.
	Quiry		-True/False plus literal message.
	Print		-Prints a string to the console.
	RDR		-Alphanumeric to real number.
	Replace		-Replace a substring within a source string.
	Skip		-Skips X lines.
	STR		-Integer to alphanumeric.
	Ucase		-Translates lowercase letter to uppercase.
	VAL		-Single character to integer value.

}

  (*********************************************)



PROCEDURE PRINT( A : MString);
VAR
  I : 1..StrMax;
begin
  If (LENGTH(A) > 0) and (LENGTH(A) <= StrMax) then
    For I:= 1 to LENGTH(A) do
	write(A[ I ])
  Else
    Write(space)
end;

  (*********************************************)


PROCEDURE COPY( {    TO     } VAR dest : string80 ;
		{   FROM    } THIS : MSTRING ;
		{STARTING AT} POSN : INTEGER ;
		{# OF CHARS } LEN  : INTEGER ) ;
{  COPY(NEW_NAME, NBUF, NAME_ADDR, NAME_LEN);	}
{  COPY(A_STRING, A_STRING, 5, 5);		}
{GLOBAL
  StrMax = 255;
  MSTRING = STRING StrMax;			}
LABEL	99;
CONST	line_length = 80 ;
VAR	ix   : 1..StrMax;
begin
  SETLENGTH(dest,0);  {length returned string=0}
  If (len + posn) > line_length then{exit}goto 99;
  IF ((len+posn-1) <= LENGTH(this)) and
     (len > 0) and (posn > 0) then
     FOR ix:=1 to len do
         APPEND(dest, this[posn+ix-1]);
99: {Any error returns dest with a length of ZERO.}
End{of COPY};

  (*********************************************)


PROCEDURE CONCAT({New_String} VAR C : string80 ;
		 {Arg1_str  }     A : Mstring ;
		 {Arg2_str  }     B : Mstring );
CONST
  line_length = 80;
VAR
  ix : 1..StrMax;
begin
  SETLENGTH(C,0);
  If (LENGTH(A) + LENGTH(B)) <= line_length then
    begin
	APPEND(C,A);
        APPEND(C,B);
    end;
  {If error then returns length of new_string=0}
End{of CONCAT};

  (*********************************************)


PROCEDURE REPLACE(VAR source	: string80;
		  VAR dest	: string80;
		      K1	: Integer);
(*
 *	REPLACE(Source, Destination, Index);
 *)
CONST	line_length = 80;
VAR	temp1,temp2 : Mstring;
	pos, k      : 1..StrMax;
begin
  If (K1 > 0) and (K1 <= LENGTH(dest)) and (K1 <= line_length) then
    begin (* Position 'K1' is within STRING 'dest'	*)
	  (* but not longer than line_length		*)
      SETLENGTH(temp1,0);
      SETLENGTH(temp2,0);
      COPY(temp1,dest,1,K1-1);
      APPEND(temp1,source);(* concatenate temp1 and A *)
      k := K1 + LENGTH(source);(* extract remaining chars from dest *)
      COPY(temp2,dest,k,(LENGTH(dest)-k+1));
      CONCAT(dest,temp1,temp2)
    end(*If*)
  Else(* Issue error message and do nothing *)
    Writeln('Index out of range')
end(* of REPLACE *);

  (*********************************************)



Function VAL(ch: char): integer;
{ Returns the integer value of
  the single char passed }
const	z = 48; {  ORD('0')  }
begin
  VAL := ORD(ch) - z
end;

  (*********************************************)



Function RDR(var f: Dstring  ): real;
{ read real numbers in free format.
  author: Niklaus Wirth
  book:   Pascal User Manual & Report
	  pg 122-123
  ENTER WITH:
	f = a string containing ONLY the alphanumeric number
	    to be converted to a real number.
  RETURNS:
	A real number.
	Any error returns RDR := 0.0
*}
label	9;{ error exit }
const
	t48 = 281474976710656.0 ;
	limit = 56294995342131.0 ;
	lim1 = 322;		{ maximum exponent }
	lim2 = -292;		{ minimum exponent }
	space = ' ';
	emsg1 = '**digit expected';
	emsg2 = '**number too large';
type
	posint = 0..323;
var
  ch	: char;
  y	: real;
  posn,
  a,i,e	: integer;
  fatal,
  s,ss	: boolean; { signs }

procedure Getc(var ch: char);
begin
  posn := posn + 1;
  ch := f[posn];
end;

function TEN(e: posint): real; {  = 10**e,  0<e<322  }
var	i: integer;
	t: real;
begin
  i := 0;
  t := 1.0;
  repeat
    If ODD(e) then
      case i of
	0: t := t * 1.0E1;
	1: t := t * 1.0E2;
	2: t := t * 1.0E4;
	3: t := t * 1.0E8;
	4: t := t * 1.0E16;
	5: t := t * 1.0E32	{ that's all! }
	6,7,8:
	   begin
	   writeln('**Floating point overflow');
	   fatal := true;
	   e := 2;{ sets e to zero on next division }
	   end;
	{*===================*
	--- can not use ---
	 6: t := t * 1.0E64;
	 7: t := t * 1.0E128;
	 8: t := t * 1.0E256
	 *===================*}
      end{ case };
    e := e DIV 2;
    i := i + 1;
  until e=0;
  TEN := t;
end{of TEN};

begin
  fatal := false;
  posn := length(f);
  setlength(f,posn+1);
  f[posn+1] := space;
  posn := 0;
  getc(ch);
  { skip leading blanks }
  While ch=space do getc(ch);
  If ch='-' then
    begin
    s := true;
    getc(ch)
    end
  Else
    begin
    s := false;
    If ch='+' then getc(ch)
    end;
  If not(ch IN ['0'..'9']) then
    begin
    writeln(emsg1);
    {HALT} fatal := true; goto 9;
    end;
  a := 0;
  e := 0;
  repeat
    If a<limit then
      a := 10 * a + VAL(ch)
    Else
      e := e+1;
    getc(ch);
  until not(ch IN ['0'..'9']);
  If ch='.' then
    begin { read fraction }
    getc(ch);
    while ch IN ['0'..'9'] do
      begin
      If a<limit then
	begin
	a := 10 * a + VAL(ch);
	e := e - 1
	end;
      getc(ch);
      end{ while };
    end{ read fraction };
  If (ch='E') or (CH='e') then
    begin { read scale factor }
      getc(ch);
      i := 0;
      If ch='-' then
        begin ss := true; getc(ch) end
      Else
        begin
        ss := false;
        If ch='+' then getc(ch)
        end;
      If ch IN ['0'..'9'] then
        begin
        i := VAL(ch);
        getc(ch);
        while ch IN ['0'..'9'] do
	  begin
	  If i<limit then i := 10 * i + VAL(ch);
	  getc(ch)
	  end{ while}
        end{ If }
      Else
        begin
        writeln(emsg1);
        {HALT} fatal := true; goto 9;
        end;
      If ss
	 then e := e - i
	 Else e := e + i;
    end{ read scale factor };
  If e < lim2 then
    begin
    a := 0;
    e := 0;
    end
  Else
    If e > lim1 then
      begin
      writeln(emsg2);
      {HALT} fatal := true; goto 9;
      end;
  {  0 < a < 2**49  }
  If a >= t48 then
    y := ((a+1) DIV 2) * 2.0
  Else
    y := a;
  If s then y := -y;
  If e < 0 then
    RDR := y/TEN(-e)
  Else
    If e<>0 then
      RDR := y*TEN(e)
    Else
      RDR := y;
9: If fatal then RDR := 0.0;
End{of RDR};

  (*********************************************)



Procedure STR( var S: Dstring;
		tval: integer );
{ ENTER WITH:
	tval = INTEGER to be converted to an alphanumeric
	       string.
  RETURNS:
	An alphanumeric equal of tval in S.
}
const
	size = 15; { number of digits in the number }
var
	cix : char;
	digits : packed array[1..10] of char;
	i,		{ length of number }
	d,t,j: integer;
begin
  digits := '0123456789';
  t := ABS(tval);
  setlength(S,0);	{ null string }
  i := 0;
  repeat { generate digits }
    i := i + 1;
    d := t MOD 10;
    append(S,digits[d+1]);
    t := t DIV 10
  until (t=0) OR (i>=size);
  If (tval<0) AND (i<size) then
    begin { sign }
    i := i + 1;
    append(S,'-')
    end;
  j := 1;
  while j<i do
    begin{ reverse }
    cix := S[i]; S[i] := S[j]; S[j] := cix;
    i := i - 1;
    j := j + 1
    end{ revese }
End{of STR};

  (*********************************************)



Procedure GetLine( VAR Agr_string : string80 ;
			    count : integer );
(*----------------------------------------------*)
(* version: 31 MAY 80 by R.E.Penley		*)
(* Valid Alphanumeric chars are:		*)
(* from the ASCII space - CHR(32) to the	*)
(*	    ASCII tilde - CHR(126)		*)
(* In order to get this to work with		*)
(* Pascal/Z v 3.0 I have defined a line		*)
(* as a string[80]				*)
(*----------------------------------------------*)
(*
GLOBAL	StrMax = 255;
	Mstring = STRING 255;
	error  : boolean; <<to be returned to caller>>
*)
CONST	SPACE = ' ';
	a_error = 'Alphanumerics only - ';
	line_length = 80;
VAR	InChar : char;
	CHAR_COUNT : INTEGER;
	ix : 1..StrMax;
begin
  error := false;
  SETLENGTH( Agr_string, 0 );
  CHAR_COUNT := 0;
  REPEAT
  If (count <= line_length) AND (CHAR_COUNT < count) then
    begin{start accepting chars}
    READ( InChar );
    If InChar IN [' ' .. '~'] then{valid char}
      begin{increment CHAR_COUNT and store InChar}
	CHAR_COUNT := char_count + 1 ;
	APPEND( Agr_string, InChar );
      end(* If *)
    Else (* we have a non-acceptable character *)
      begin
	WRITELN(a_error);
	error:=TRUE
      end(* else *)
    end(* If *)
  Else	(*   ERROR   *)
    begin (* RESET EndOfLine <EOLN> *)
{}    READLN( Agr_string[ CHAR_COUNT ] );
      WRITELN('Maximum of', count:4, ' characters please!');
      error:=TRUE
    end(* else *)
  UNTIL EOLN(INPUT) or error;
  If error then{return a length of zero}
    SETLENGTH( Agr_string, 0 );
End{of GetLine};


	{---------------------------------------}
	{	    UTILITY ROUTINES		}
	{---------------------------------------}



Function UCase(ch : char) : char;
(*---Returns an uppercase ASCII character---*)
begin
  If ch IN ['a'..'z'] then
    UCase := CHR(ORD(ch) -32)
  Else
    UCase := ch
end;


Procedure DRAW(picture : Mstring ; count : integer);
VAR	ix : integer;
begin
  For ix:=1 to count do
    WRITE(picture);
end;

Procedure DELAY(timer:integer);
{  DELAY(10);	will give about 1 second delay }
{  DELAY(5);	will give about 0.5 second delay }
{  DELAY(30);	will give about 3 second delay }
CONST	factor = 172;
var	ix,jx : integer;
begin
  for ix:=1 to factor do
    for jx:=1 to timer do {dummy};
end;

Function QUIRY(message : string80) : boolean ;
{	Try to write a general purpose		}
{	routine that gets a 'YES' or 'NO'	}
{	response from the user.			}
VAR	ans : string 2;
	valid : boolean;
begin
  Repeat
    valid := false;
    Write(message);
    readln(ans);
    If ans='OK' then
      begin valid := true; QUIRY := true end
    Else
	If ans[1] IN ['Y','y','N','n'] then
	  begin
	    valid := true;
	    QUIRY := ( (ans='Y') or (ans='y') )
	  end
  Until valid{response}
end{of Quiry};

Procedure CLEAR;
var	ix :1..25;
begin
  for ix:=1 to 25 do writeln
end;

Procedure SKIP(n : integer);
var	ix : 0..255;
begin
  for ix:=1 to n do writeln
end;

Procedure PAUSE;
CONST	sign = 'Enter return to continue ';
var	ch : char;
begin
  write(sign);
  readln(CH)
end;

Procedure HEADER( title : string80 );
CONST	left_margin  = 11;
	right_margin = 51;
	center	     = 31;
	dashes	     = '{---------------------------------------}';
VAR	F1,	{filler left side}
	F2,	{filler right side}
	CL,	{center line of title}
	len	{length of title}
		 : integer;
begin
  len := LENGTH(title);
  CL := len DIV 2;
  {If length of title is odd then increase CL by one}
  If ODD(len) then CL := CL +1;
  F1 := (center - CL) - left_margin;
  {If length of title is even then reduce F1 by 1   }
  If not ODD(len) then F1 := F1 - 1;
  F2 := right_margin - (center + CL);
  writeln(' ':left_margin,dashes);
  writeln(' ':left_margin,'{',' ':F1,title,' ':F2,'}');
  writeln(' ':left_margin,dashes);
end;

	{---------------------------------------}