home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Overload
/
ShartewareOverload.cdr
/
database
/
mailit.zip
/
IO20.INC
< prev
next >
Wrap
Text File
|
1986-03-12
|
22KB
|
660 lines
{ IO20.INC -- Global I/O procedures to include in programs generally
Version 2.0 includes prev_page and next_page, changes where pause text
is displayed -- WPM -- 2/26/86 }
{ ------------------------------------------------------------ }
const
prev_fld = $0b ; { ^K -- up_arrow on Kaypro II '83 }
next_fld = $0a ; { ^J -- linefeed, down_arrow }
backspace = $08 ; { ^H -- Backspace key }
del_fld = $19 ; { ^Y }
prev_page = $12 ; { ^R }
next_page = $03 ; { ^C }
escape = $1b ;
carr_rtn = $0d ;
del = $7f ;
filler = $2e ; { . }
type
str_type = string[80] ;
intset = set of $00 .. $ff ;
const { Turbo typed constants -- initialized variables }
terminating : intset = [carr_rtn, next_fld, prev_fld, next_page,
prev_page, escape] ;
adjusting : intset = [backspace, del_fld, del] ;
var
fld, scrn : integer ; {For field & screen cursor control}
{ ------------------------------------------------------------ }
{ procedure gotoxy (col,row) ; -- Built-in proc in Turbo to place
cursor on screen. Upper left is (1,1) not (0,0)! }
{ procedure clrscr ; -- Built-in proc in Turbo to clear screen. }
{ procedure clreol ; -- built-in proc in Turbo to clear to end of line }
{ ------------------------------------------------------------ }
procedure clrline (col,row : integer) ;
begin
gotoxy (col,row) ;
clreol
end ;
{ ------------------------------------------------------------ }
procedure clreos ;
begin
write (chr($17)) {Clear to end of screen on Kaypro & ADM-3A}
end ;
{ ------------------------------------------------------------ }
procedure beep ;
begin
write (chr(7))
end ;
{ ------------------------------------------------------------ }
procedure do_fld_ctl (key : integer) ;
{ Adjusts global FLD based on value of key, the ordinal value of last key pressed }
{ global
fld : integer -- for field cursor control }
begin
case key of
carr_rtn, next_fld : fld := fld + 1 ;
prev_fld : fld := fld - 1 ;
next_page : fld := 999 ;
prev_page : fld := -999 ;
escape : fld := maxint ; { NOTE -- different from MT+ }
end { case }
end ; { proc do_fld_ctl }
{ ------------------------------------------------------------ }
procedure do_scrn_ctl ;
{ Checks value of FLD and adjusts value of SCRN accordingly }
{ Global
fld, scrn : integer -- For field and screen cursor control }
begin
if fld < 1 then
scrn := scrn - 1
else if fld = maxint then
scrn := maxint
else
scrn := scrn + 1
end ;
{ ------------------------------------------------------------ }
procedure write_str (st:str_type ; col,row:integer) ;
begin
gotoxy (col,row) ;
write (st)
end ;
{ ------------------------------------------------------------ }
procedure write_int (int:integer ; width,col,row:integer) ;
begin
gotoxy (col,row) ;
write (int:width)
end ;
{ ------------------------------------------------------------ }
procedure write_bool (bool:boolean ; col, row:integer) ;
begin
gotoxy (col,row) ;
if bool then write ('YES') else write ('NO ')
end ;
{ ------------------------------------------------------------ }
procedure write_real (r:real ; width,frac,col,row:integer) ;
begin
gotoxy (col,row) ;
write (r:width:frac)
end ;
{ ------------------------------------------------------------ }
{ This is for Kaypro CP/M -- comment it out to use IBM }
(*
procedure keyin (var ch:char) ;
{ Reads a single character from keyboard without echoing it back.
Modified to trap WordStar commands, 4/29/85 }
begin
read (kbd, ch) ;
if ch = ^S then
ch := chr(backspace)
else if ch = ^E then
ch := chr(prev_fld)
else if ch = ^X then
ch := chr(next_fld)
END ;
*)
{ ------------------------------------------------------------ }
{ This is for IBM PC-DOS -- comment it out for CP/M }
procedure keyin (var ch:char) ;
{ Reads a single character from keyboard without echoing it back.
Maps function key scan codes to single keyboard keys.
Modified for IBM -- from Turbo 3.0 manual, page 360 -- 5/29/85
Modified for IO20 -- 2/26/86 }
var
func : boolean ; { Whether function key or not }
c : char ; { Character read }
key : integer ; { ORD of character returned }
begin
func := false ;
read (kbd,c) ; { Get first char }
if (ord(c) = escape) { If there is }
and keypressed then { a second ... }
begin
read (kbd,c) ; { Get 2nd char }
func := true
end ;
key := ord(c) ;
if func then { Translate func. keys }
case key of
61,72 : key := prev_fld ; { F3, up-arrow }
62,80 : key := next_fld ; { F4, down-arrow }
65,73 : key := prev_page ; { F7, PgUp }
66,81 : key := next_page ; { F8, PgDn }
59,83,75 : key := backspace ; { F1, DEL, left-arrow }
60 : key := del_fld ; { F2 }
else key := 00 ;
end { case }
else { not a function key }
case key of
$13 : key := backspace ; { ^S -- Like WordStar }
$05 : key := prev_fld ; { ^E }
$18 : key := next_fld ; { ^X }
end ; { case }
ch := chr(key) { finally, return the character }
end ;
{ ------------------------------------------------------------ }
function purgech (instr : str_type ; inchar : char) : str_type ;
{Purges all instances of the character from the string}
var
n : integer ; {Loop counter}
outstr : str_type ; {Result string}
begin
outstr := '' ;
for n := 1 to length (instr) do
if not (instr[n] = inchar) then
outstr := concat (outstr, instr[n]) ;
purgech := outstr
end ;
{ ------------------------------------------------------------ }
function stripch (instr:str_type ; inchar:char) : str_type ;
{Strips leading instances of the character from the string}
begin
while not (length(instr) = 0)
and (instr[1] = inchar) do
delete (instr, 1, 1) ;
stripch := instr
end ;
{ ------------------------------------------------------------ }
function chopch (instr:str_type ; inchar:char) : str_type ;
{Chops trailing instances of the character from the string}
begin
while not (length(instr) = 0)
and (instr[length(instr)] = inchar) do
delete (instr, length(instr), 1) ;
chopch := instr
end ;
{ ------------------------------------------------------------ }
procedure adjust_str (var st : str_type ; key, maxlen, col, row : integer ) ;
{ deletes a character or the whole entry }
var
i : integer ;
begin
case key of
del_fld : begin
st := '' ;
gotoxy (col, row) ;
for i := 1 to maxlen do
write (chr(filler)) ;
gotoxy (col, row)
end ;
backspace,
del : if length(st) = 0 then
beep
else
begin
write (chr(backspace), chr(filler), chr(backspace)) ;
delete (st, length(st), 1)
end
end { case }
end ; { proc adjust_str }
{ ------------------------------------------------------------ }
procedure read_str (var st:str_type ; maxlen, col, row:integer) ;
{ Read String. This procedure gets input from the keyboard one
character at a time and edits on the fly, rejecting invalid
characters. COL and ROW tell where to begin the data input
field, and MAXLEN is the maximum length of the string to be
returned. }
var
ch : char ;
i,key : integer ;
procedure add_to_str ;
begin
if length(st) = maxlen then
beep
else
begin
st := concat(st, ch) ; {concatenate char. onto str.}
write (ch)
end
end ; {--- of ADD_TO_STR---}
begin {--- READ_STR ---}
write_str (st, col, row) ;
for i := (length(st)+1) to maxlen do
write (chr(filler)) ;
gotoxy ((col + length(st)), row) ;
repeat
keyin (ch) ;
key := ord(ch) ;
if key in [$20 .. $7e] then
add_to_str
else if key in adjusting then
adjust_str (st,key,maxlen,col,row)
else if key in terminating then
do_fld_ctl (key)
else
beep ;
until key in terminating ;
write ('':maxlen - length(st))
end ; {--- of READ_STR ---}
{ ------------------------------------------------------------ }
procedure read_int (var int:integer ; maxlen, col, row:integer) ;
{ Read Integer. This procedure gets input from the keyboard
one character at a time and edits on the fly, rejecting
invalid characters. COL and ROW tell where to begin the data
input field, and MAXLEN is the maximum length of the integer
to be returned. }
var
ch : char ;
i,key : integer ;
st : string[5] ;
maxst : string[5] ;
code : integer ;
procedure add_to_str ;
begin
if length(st) = maxlen then
beep
else
begin
st := concat(st, ch) ; {concatenate char. onto str.}
write (ch)
end
end ; {--- of ADD_TO_STR---}
begin {--- READ_INT ---}
str (maxint:5, maxst) ; {Make integer into string}
str (int:maxlen, st) ;
st := purgech (st, ' ') ;
st := stripch (st, '0') ;
write_str (st, col, row) ;
for i := (length(st)+1) to maxlen do
write (chr(filler)) ;
gotoxy ((col + length(st)), row) ;
repeat
keyin (ch) ;
key := ord(ch) ;
if key = $2d then { minus sign }
begin
if length(st) = 0 then
add_to_str
end
else if key in [$30 .. $39] then {digits 0 - 9}
begin
add_to_str ;
if (length(st) = 5)
and (st > maxst) then
adjust_str (st,del,maxlen,col,row)
end
else if key in adjusting then
adjust_str (st,key,maxlen,col,row)
else if key in terminating then
do_fld_ctl (key)
else
beep ;
until key in terminating ;
if st = '' then
begin
int := 0 ;
code := 0
end
else
val (st, int, code) ; {Make string into integer}
gotoxy (col, row) ;
if code = 0 then {Conversion worked OK}
write (int:maxlen)
else
begin
write ('** CONVERSION ERROR ', code) ;
halt
end
end ; {--- of READ_INT ---}
{ ------------------------------------------------------------ }
function equal (r1,r2 : real) : boolean ;
{ tests functional equality of two real numbers -- 4/30/85 }
begin
equal := abs(r1 - r2) < 1.0e-5
end ; { function equal }
{ ------------------------------------------------------------ }
function greater (r1,r2 : real) : boolean ;
{ tests functional inequality of two real numbers -- 5/1/85 }
begin
greater := (r1 - r2) > 1.0e-5
end ; { function greater }
{ ------------------------------------------------------------ }
procedure read_real (var r:real ; maxlen,frac,col,row:integer) ;
{ Read Real. This procedure gets input from the keyboard
one character at a time and edits on the fly, rejecting
invalid characters. COL and ROW tell where to begin the data
input field; MAXLEN is the maximum length of the string
representation of the real number, including sign and decimal
point; FRAC is the fractional part, the number of digits to
right of the decimal point.
Note -- In TURBO the maximum number of significant digits in
decimal (not scientific) representation is 11. It is the
programmer's responsibility to limit input and computed output
to 11 significant digits. }
var
ch : char ; {Input character}
i,key : integer ; {Loop control ; ORD of CH}
st : string[13] ; {String representation of real number}
code : integer ; {Result of VAL conversion}
rlen : integer ; {Current length of ST to right of dec. pt.}
llen : integer ; {Current length to left, including dec. pt.}
maxl : integer ; {Max allowable to left, including dec. pt.}
procedure compute_length ;
begin
if pos ('.', st) = 0 then { If no dec. pt. ... }
begin
llen := length(st) ; {the whole string is Left}
rlen := 0 {and none is Right}
end
else {There is a decimal point ...}
begin
llen := pos ('.', st) ; {Left is all up to dec. pt.}
rlen := length(st) - llen {Right is the rest}
end
end ; { proc compute_length }
procedure add_to_str ;
procedure add_it ;
begin
st := concat(st, ch) ;
write (ch)
end ;
begin {ADD_TO_STR}
if ch = '.' then { Decimal point: if not one already, add it }
begin
if pos('.', st) = 0 then
add_it
else
beep
end
{ else it's not a decimal point }
else if pos('.',st) = 0 then
{ There's no dec pt in string, so digit goes on left. }
begin
if llen = (maxl - 1) then
beep { Only a dec pt is allowed in pos MAXL }
else
add_it
end
else { There is a dec pt in string, so digit goes on right }
begin
if rlen = frac then
beep
else
add_it
end
end ; {--- of ADD_TO_STR---}
begin {--- READ_REAL ---}
{Initialize}
maxl := maxlen - frac ;
{Set up string representation of real and }
{determine length of left & right portions}
str(r:maxlen:frac,st) ; {Make real into string}
st := purgech (st, ' ') ; {Purge all blanks}
st := stripch (st, '0') ; {Strip leading zeroes}
if not (pos('.', st) = 0) then {If there is a dec. pt ... }
begin
st := chopch (st, '0') ; {Chop trailing zeroes}
st := chopch (st, '.') {and trailing dec. pt.}
end ;
{Write string on console}
write_str (st, col, row) ;
for i := (length(st)+1) to maxlen do
write (chr(filler)) ;
gotoxy ((col + length(st)), row) ;
{Get input a character at a time & edit it}
repeat
compute_length ;
keyin (ch) ;
key := ord(ch) ;
if ch = '-' then
begin
if length(st) = 0 then
add_to_str
else
beep
end
else if (ch = '.')
or (ch in ['0' .. '9']) then
add_to_str
else if key in adjusting then
adjust_str (st,key,maxlen,col,row)
else if key in terminating then
do_fld_ctl (key)
else
beep
until key in terminating ;
{Done getting input, now convert back to real}
if (st = '') {If null string ... }
or (st = '.')
or (st = '-')
or (st = '-.') then
begin
r := 0.0 ; {Make real zero}
code := 0
end
else {Not a null string}
val (st, r, code) ; {Make string into real}
gotoxy (col, row) ;
if code = 0 then {Conversion worked OK}
write (r:maxlen:frac) {Write the real on screen}
else
begin
write ('** CONVERSION ERROR ', code) ;
halt
end
end ; {--- of READ_REAL ---}
{ ------------------------------------------------------------ }
procedure read_yn (var bool:boolean; col,row:integer) ;
{ Inputs "Y" OR "N" to boolean at column and row specified,
prints "YES" or "NO."
Note -- use this when the screen control will not return
to the question and the boolean IS NOT defined before the
user answers the question. }
var ch:char ;
begin
gotoxy (col,row) ;
write (' ') ;
gotoxy (col,row) ;
repeat
keyin (ch)
until (ch in ['Y', 'y', 'N', 'n']) ;
if (ch = 'Y') or (ch = 'y') then
begin
write ('YES') ;
bool := true
end
else
begin
write ('NO ') ;
bool := false
end
end ; {--- of READ_YN ---}
{ ------------------------------------------------------------ }
procedure read_bool (var bool:boolean; col,row:integer) ;
{ Displays boolean at column and row specified, inputs "Y"
or "N" to set new value of boolean, prints "YES" or "NO."
Note -- use this when the screen control may return to the
question and the boolean IS defined before the user answers
the question. }
var
ch : char ;
key : integer ;
begin
write_bool (bool, col, row) ;
gotoxy (col, row) ;
repeat
keyin (ch) ;
key := ord(ch) ;
if key in [$59, $79] then { 'Y', 'y' }
begin
bool := true ;
key := next_fld ;
do_fld_ctl(key)
end
else if key in [$4e, $6e] then { 'N', 'n' }
begin
bool := false ;
key := next_fld ;
do_fld_ctl(key)
end
else if key in terminating then
do_fld_ctl(key)
else
beep ;
until key in terminating ;
write_bool (bool, col, row)
end ; {--- of READ_BOOL ---}
{ ------------------------------------------------------------ }
procedure pause ;
{Prints message on bottom line, waits for user response}
var
ch : char ;
key : integer ;
begin
clrline (1,24) ;
write_str ('PRESS SPACE BAR TO CONTINUE OR UP-ARROW TO GO BACK',14,24) ;
repeat
keyin (ch) ;
key := ord(ch) ;
case key of
$20 : fld := fld + 1 ;
prev_fld : fld := fld - 1 ;
prev_page : fld := -999 ;
escape : fld := maxint ;
end ;
until key in [$20, prev_fld, prev_page, escape] ;
clrline (1,24)
end ; {--- of PAUSE ---}
{ ------------------------------------------------------------ }
procedure hard_pause ;
{ Like Pause, but only accepts space bar or Escape and only goes forward }
var
ch : char ;
key : integer ;
begin
clrline (1,24) ;
write_str ('PRESS SPACE BAR TO CONTINUE',26,24) ;
repeat
keyin (ch) ;
key := ord(ch) ;
case key of
$20 : fld := fld + 1 ;
escape : fld := maxint ;
end ;
until key in [$20, escape] ;
clrline (1,24)
end ; {--- of hard_pause ---}
{ ------------------------------------------------------------ }
procedure show_msg (msg : str_type) ;
{ Beeps, displays message centered on line 23, pauses }
var
savefld : integer ;
begin
savefld := fld ;
beep ;
clrline (1,23) ;
write_str (msg,((80-length(msg)) div 2),23) ;
hard_pause ;
clrline (1,23) ;
fld := savefld ;
end ; { --- of SHOW_MSG --- }
{ ----- EOF IO20.INC ----------------------------------------- }