Category : Pascal Source Code
Archive   : TURBOIO.ZIP
Filename : IO20DEMO.PAS

program IO20DEMO ;
{ This program demonstrates Turbo Pascal I/O routines
developed by Wm Meacham.
Revised 4/18/86 }

{ For CP/M, compile to COM file with End address of $7000. }

{$c-,v-}
{$i io20.inc }
{$i date20.inc }

var
choice : integer ; { to get menu choice }
quitnow : boolean ; { to get user Y/N input }

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

procedure title_screen ;
begin
clrscr;
write_str ('-------------------',30,6) ;
write_str (' ',30,7) ;
write_str (' Demonstration ',30,8) ;
write_str (' of ',30,9) ;
write_str (' Turbo Pascal ',30,10) ;
write_str (' I/O routines ',30,11) ;
write_str (' ',30,12) ;
write_str ('-------------------',30,13) ;
write_str (' Reliance Software Services',23,18) ;
write_str ('1004 Elm Street, Austin, Tx 78703',23,19) ;
write_str (' Public Domain - No Copyright',23,21) ;
fld := 0 ;
hard_pause ;
if fld = maxint then halt
end ; { proc title_screen }

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

procedure display_menu ;
begin
clrscr ;
write_str('I/O DEMONSTRATION',32,3) ;
write_str('MAIN MENU',36,4) ;
write_str('Please select:',26,6) ;
write_str('1 Display instructions',26,8) ;
write_str('2 Data entry and display demo for',26,10) ;
write_str('Strings, Integers, Reals and Booleans',31,11) ;
write_str('3 Data entry and display demo for Dates',26,13) ;
write_str('ESC Exit the program',26,15) ;
write_str('==>',26,17)
end ; { proc display_menu }

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

procedure display_instructions ;
begin
clrscr;
write_str(' COMMAND Labelled Arrow Ctrl Function',7,1) ;
write_str(' key key key key (IBM)',7,2) ;
write_str(' ------ -------- ----- ---- ---------',7,3) ;
write_str('* DELETE character Del, left S F1',7,4) ;
write_str(' to left Backspace',7,5) ;
write_str('* DELETE entire Y F2',7,6) ;
write_str(' entry',7,7) ;
write_str('* MOVE DOWN Return, down X F4',7,8) ;
write_str(' a line Enter',7,9) ;
write_str('* MOVE UP up E F3',7,10) ;
write_str(' a line',7,11) ;
write_str('* PAGE FORWARD PgDn C F8',7,12) ;
write_str(' to next screen (IBM)',7,13) ;
write_str('* PAGE BACKWARD PgUp R F7',7,14) ;
write_str(' to prev. screen (IBM)',7,15) ;
write_str('* CANCEL data entry Esc',7,16) ;
write_str('* TO ENTER DATA: Type the data & press Enter or another',7,18) ;
write_str('cursor movement key.',28,19) ;
write_str('* TO ENTER YES/NO: Type "Y" or "N;" don''t press Enter.',7,20) ;
write_str('* TO ENTER A DATE: Type the month & press Enter, type the day',7,21) ;
write_str('& press Enter, type the year & press Enter.',28,22) ;
hard_pause ;
fld := 1 { reset FLD for calling proc }
end ; { proc display_instructions }

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

procedure io_demo ;
{ demonstrate I/O of strings, integers, reals and booleans }

var
first, last, addr1, addr2, city,
state, zip : str_type ; { for string demo }
i1, i2, i3, itot : integer ; { for integer demo }
r1, r2, r3, rtot : real ; { for real demo }
b1, b2, b3, b4 : boolean ; { for boolean demo }

{ ==================== }

procedure init_io_vars ;
{ Initializes global variables }
begin
first := '' ;
last := '' ;
addr1 := '' ;
addr2 := '' ;
city := '' ;
state := '' ;
zip := '' ;
i1 := 0 ;
i2 := 0 ;
i3 := 0 ;
itot := 0 ;
r1 := 0 ;
r2 := 0 ;
r3 := 0 ;
rtot := 0 ;
b1 := false ;
b2 := false ;
b3 := false ;
b4 := false
end ; { proc init_io_vars }

{ ==================== }

procedure strings ;
{ This procedure demonstrates reading and writing strings. }

var
i : integer ; { For loop control }
ok : boolean ; { Whether zip code is numeric }

begin
clrscr ;
write ('SCREEN ', scrn, ' -- STRINGS') ;
write_str ('First name:',9,8) ;
write_str (first,21,8 ) ;
write_str ('Last name:',9,9) ;
write_str (last,21,9) ;
write_str ('Address 1:',9,10) ;
write_str (addr1,21,10) ;
write_str ('Address 2:',9,11) ;
write_str (addr2,21,11) ;
write_str ('City:',9,12) ;
write_str (city,21,12) ;
write_str ('State:',9,13) ;
write_str (state,21,13) ;
write_str ('Zip:',9,14) ;
write_str (zip,21,14) ;
fld := 1 ;
repeat
case fld of
1: read_str (first, 15, 21, 8) ;
2: read_str (last, 10, 21, 9) ;
3: read_str (addr1, 15, 21, 10) ;
4: read_str (addr2, 15, 21, 11) ;
5: read_str (city, 15, 21, 12) ;
6: read_str (state, 2, 21, 13) ;
7: begin
repeat
read_str (zip, 5, 21, 14) ;
ok := true ;
if not (zip = '') then
begin
if length (zip) < 5 then
ok := false
else
for i:= 1 to 5 do
if (zip[i] <'0')
or (zip[i] >'9') then
ok := false
end ;
if not ok then
begin
show_msg ('MUST BE NUMERIC OR NOT ENTERED') ;
zip := '' ;
fld := 7
end
until ok ;
end ; { 7: }
end ; { case }
until (fld < 1) or (fld > 7) ;
do_scrn_ctl
end ; { proc strings }

{ ==================== }

procedure integers ;
{ This procedure demonstrates reading & writing integers. }

procedure sum_int ;
begin
itot := i1 + i2 + i3 ;
write_int (itot, 5, 13, 12)
end ;

begin { integers }
clrscr ;
write ('SCREEN ', scrn, ' -- INTEGERS') ;
write_str ('==>', 9, 8) ;
write_int (i1,4,14,8) ;
write_str ('==>', 9, 9) ;
write_int (i2,4,14,9) ;
write_str ('==>', 9, 10) ;
write_int (i3,4,14,10) ;
write_str ('TOTAL', 7, 12) ;
write_int (itot,5,13,12) ;
fld := 1 ;
repeat
case fld of
1: begin
read_int (i1, 4, 14, 8) ;
sum_int ;
end ;
2: begin
read_int (i2, 4, 14, 9) ;
sum_int ;
end ;
3: begin
read_int (i3, 4, 14, 10) ;
sum_int ;
end ;
4: pause ;
end ; { case }
until (fld < 1) or (fld > 4 ) ;
do_scrn_ctl
end ; { proc integers }

{ ==================== }

procedure reals ;
{ This procedure demonstrates reading & writing reals. }

const
tot = 11 ;
frac = 3 ;

procedure sum_real ;
begin
rtot := r1 + r2 + r3 ;
write_real (rtot, tot+1, frac, 13, 12)
end ;

begin { proc reals }
clrscr ;
write ('SCREEN ', scrn, ' -- REALS') ;
write_str ('==>', 9, 8) ;
write_real (r1,tot,frac,14,8) ;
write_str ('==>', 9, 9) ;
write_real (r2,tot,frac,14,9) ;
write_str ('==>', 9, 10) ;
write_real (r3,tot,frac,14,10) ;
write_str ('TOTAL', 7, 12) ;
write_real (rtot,12,3,13,12) ;
fld := 1 ;
repeat
case fld of
1: begin
read_real (r1, tot,frac, 14, 8) ;
sum_real ;
end ;
2: begin
read_real (r2, tot,frac, 14, 9) ;
sum_real ;
end ;
3: begin

read_real (r3, tot,frac, 14, 10) ;
sum_real ;
end ;
4: pause ;
end ; { CASE }
until (fld < 1) or (fld > 4 ) ;
do_scrn_ctl
end ; { proc reals }

{ ==================== }

procedure booleans ;
{ This procedure demonstrates reading & writing booleans }
begin
clrscr;
write ('SCREEN ', scrn, ' -- BOOLEANS') ;
write_str ('TYPE OF CO-BORROWER. Type "Y" for all that apply.',3,8) ;
write_str ('"No" will be assumed if you just press .',3,9) ;
write_str ('1 - Another person will be jointly obligated with borrower',5,10) ;
write_str ('2 - Borrower is relying on income of another person',5,11) ;
write_str ('3 - Married, living in a community property state',5,12) ;
write_bool (b1, 71, 10) ;
write_bool (b2, 71, 11) ;
write_bool (b3, 71, 12) ;
write_str ('Epimenides the Cretan says, "All Cretans are liars!" Is he lying?',3,14) ;
write_bool (b4, 71, 14) ;
fld := 1 ;
repeat
case fld of
1: read_bool (b1, 71, 10) ;
2: read_bool (b2, 71, 11) ;
3: read_bool (b3, 71, 12) ;
4: read_bool (b4, 71, 14) ;
5: pause ;
end ; { case }
until (fld <1) or (fld > 5) ;
do_scrn_ctl
end ; { booleans }

{ ==================== }

procedure final_screen ;
{ The final screen -- demonstrates proc Read_YN }
var
more : boolean ;
begin
clrscr ;
write_str ('End of demonstration.',20, 10) ;
write_str ('Do it again?',20, 12) ;
read_yn (more, 34, 12) ;
if more then
scrn := 1
else
scrn := succ(scrn)
end ; { proc final_screen }

{ ==================== }

begin { ----- proc io_demo ----- }
scrn := 1 ;
init_io_vars ;
repeat
case scrn of
1 : strings ;
2 : integers ;
3 : reals ;
4 : booleans ;
5 : final_screen
end ; { case }
if scrn < 1 then
scrn := 1 { no going backward from first screen }
else if scrn > 6 then
scrn := 5 { trap ESC }
until scrn > 5 ;
fld := 1 ; { reset FLD for calling proc }
end ; { proc io_demo }

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

procedure date_demo ;
{ demonstrates the things you can do with dates }

const
null_jul : juldate = (yr:0 ; day:0) ;
blanks : string[10] = ' ' ;

var
date1,
date2,
temp1,
temp2 : date ;
workjul : juldate ;
juldtst : juldatestring ;
dtst : datestring ;
diff : string[7] ;
n : integer ;
prevfld : integer ;

{ ==================== }

procedure display_diff ;
begin
if equal_date (date1,null_date)
or equal_date (date2,null_date) then
for n := 18 to 21 do
clrline (16,n)
else if equal_date(date1,date2) then
begin
write_str ('The dates are equal',16,18) ;
write ('':20) ;
for n := 20 to 21 do
clrline (16,n)
end
else
begin
write_date (date1,16,18) ;
if greater_date(date1,date2) = 1 then
begin
write (' is later than ') ;
temp1 := date2 ;
temp2 := date1
end
else
begin
write (' is earlier than ') ;
temp1 := date1 ;
temp2 := date2
end ;
dtst := mk_dt_st(date2) ;
write (dtst) ;
write ('':20) ;
write_str ('There are ',16,20) ;
str(date_diff(temp1,temp2):7:0,diff) ;
diff := purgech(diff,' ') ;
write (diff,' days (about ') ;
write (month_diff(temp1,temp2)) ;
write (' months) between') ;
write ('':20) ;
write_str ('the two dates.',16,21)
end
end ;

{ ==================== }

begin { proc date_demo }
clrscr ;
write_str('Enter two dates, press ESC to quit.',16,1) ;
write_str('DATE 1 DATE 2',32,3) ;
write_str('------ ------',32,4) ;
write_str('==> ==>',26,6) ;
write_str('Julian date:',17,8) ;
write_str('Next day:',20,10) ;
write_str('Previous day:',16,12) ;
write_str('Leap year?',19,14) ;
write_str('=============================================',16,16) ;
date1 := null_date ;
date2 := null_date ;
fld := 1 ;
repeat
case fld of
1: begin
prevfld := 1 ;
read_date (date1,30,6) ;
if not (equal_date(date1,null_date)) then
begin
greg_to_jul (date1,workjul) ;
juldtst := mk_jul_dt_st (workjul) ;
write_str (juldtst,32,8) ;

temp1 := date1 ;
next_day (temp1) ;
write_date (temp1,30,10) ;
temp1 := date1 ;
prev_day (temp1) ;
write_date (temp1,30,12) ;
write_bool (leapyear(date1.yr),32,14) ;
end
else
for n := 8 to 14 do
write_str (blanks,30,n) ;
display_diff
end ; { 1 }
2: begin
prevfld := 2 ;
read_date (date2,51,6) ;
if not (equal_date(date2,null_date)) then
begin
greg_to_jul (date2,workjul) ;
juldtst := mk_jul_dt_st (workjul) ;
write_str (juldtst,53,8) ;
temp1 := date2 ;
next_day (temp1) ;
write_date (temp1,51,10) ;
temp1 := date2 ;
prev_day (temp1) ;
write_date (temp1,51,12) ;
write_bool (leapyear(date2.yr),53,14) ;
end
else
for n := 8 to 14 do
write_str (blanks,51,n) ;
display_diff
end ; { 2 }
3: begin
prevfld := 3 ;
pause
end
end ; { case }
if fld < 1 then { can't go back from 1 }
fld := 1
else if (fld > 3) and (fld < maxint) then
begin
if prevfld = 3 then
fld := 1 { back to beginning from 3 }
else
fld := 3 { trap next_page }
end
until fld = maxint ;
fld := 1 { reset FLD for calling proc }
end ; { proc date_demo }

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

begin { --- program IO20DEMO --- }
title_screen ;
repeat
display_menu ;
repeat
fld := 1 ;
choice := 0 ;
read_int (choice,1, 31,17) ;
if fld < 1 then choice := 0 ;
if fld = maxint then
begin
write_str (' ',31,17) ;
write_str ('QUIT NOW? (Y/N)',26,19) ;
read_yn (quitnow,42,19) ;
if not quitnow then
begin
fld := 1 ;
choice := 0 ;
clrline (26,19)
end
end ;
until (choice in [1 .. 3]) or (fld = maxint) ;
if not (fld = maxint) then
case choice of
1: display_instructions ;
2: io_demo ;
3: date_demo ;
else
beep
end { case }
until fld = maxint ;
clrscr ;
write_str ('Thank you for trying the Reliance I/O Demonstration',12,5) ;
write_str ('Program. Please send me your comments and suggestions.',12,6) ;
write_str ('Bill Meacham',30,10) ;
write_str ('Reliance Software Services',24,11) ;
write_str ('1004 Elm Street',29,12) ;
write_str ('Austin, Tx 78703',28,13) ;
writeln ; writeln
end.