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 }
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};
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;
