CP/M/CPM_CDROM.iso/simtel/sigm/vols000/vol022/strlib.lib

Text File | 1984-04-29 | 12.8 KB | 576 lines

    {---------------------------------------}
    {        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.

}

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



    {-------------------------------}
    {    DEFINE LIBRARY        }
    {-------------------------------}

(***   Some commonly used values  ***)
const
  default    = 80 ;
  dflt_str_len    = default;    { default length for a string }
  fid_length    = 14;        {max file name length}
  line_len    = default;
  space        = ' ';
  screen_lines    = 24; {# of viewing lines on consle device }
  StrMax    = 255;

type
  dfltstr = STRING dflt_str_len;
  fid      = STRING FID_LENGTH;
  str0      = STRING 0 ;
  str1      = STRING 1;
  str255  = STRING Strmax ;
  Mstring = STRING Strmax;

var
  bell        : char;
  cix        : char;
  error        : boolean;
  LINE        : dfltstr;
  in_file    : fid;

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

Function length(x: str255): integer; external;
Function index(x,y: str255): integer; external;
Procedure setlength(var x: str0; y: integer); external;

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

Procedure KEYIN(VAR cix: char); external;
(*---Direct Keyboard onput of a single char---*)

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

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 : dfltstr;
        {   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      default = default line length;
      dfltstr = STRING default;
      StrMax = 255;
      MSTRING = STRING StrMax;        }
LABEL    9;
VAR    ix   : 1..StrMax;
begin
  SETLENGTH(dest,0);  {length returned string=0}
  If (len + posn) > default then{EXIT}goto 9;
  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]);
9: {Any error returns dest with a length of ZERO.}
End{of COPY};


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


PROCEDURE CONCAT({New_String} VAR C : dfltstr ;
         {Arg1_str  }     A : Mstring ;
         {Arg2_str  }     B : Mstring );
{  CONCAT(New_string, Arg1, Arg2);   }
{ An error returns length of new_string=0 }
{
GLOBAL      default = default line length;
      dfltstr = STRING default;
      StrMax = 255;
      Mstring = STRING StrMax;        }
var    ix : 1..StrMax;
begin
  SETLENGTH(C,0);
  If (LENGTH(A) + LENGTH(B)) <= default then
    begin
    APPEND(C,A);
        APPEND(C,B);
    end;
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 GETID( MESSAGE : dfltstr; VAR ID: FID );
{
GLOBAL    FID_LENGTH = 14;
    dfltstr    = STRING dflt_str_len;
    fid      = STRING FID_LENGTH;        }
const    space = ' ';
begin
  setlength(ID,0);
  writeln;
  write(message);
  READLN(ID);
  while length(ID)<FID_LENGTH do APPEND(ID,space);
End{---of GETID---};



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;

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