{---------------------------------------} { 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 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> *) 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 *) {} 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; {---------------------------------------}