PROGRAM newrite7(input,output); (*============================================== This is the latest version of an earlier program titled, WRITEGEN.COM. It was updated 6/16/86. NEWRITE7.COM will now accept your TOUR20 created file from the command_line. It will create either a disk file or hardcopy or simply display it on your console. It has a directory display if not invoked from the command_tail. It will create a default-- unless requested otherwise-- of your original. So FYLNAME.EXT will become FYLNAME.OTL. It is released to the Public Domain for O-1 users, but cannot be offered for resale or any non- authorized use. For comments or for questions, please call: Dr. William P. Honeywell (603) 889-1909 or write Post Office Box 7437; Nashua, NH 03060 (c) William P. Honeywell: 16 June 1987 ================================================*) {$I CTVSTUFF.INC} {$I CRTSTUFF.INC} {$I KBDSTUFF.INC} (*$V- *) { LINE 105 } const adjust=6; page='Page: '; var getline,bareline,flagline,index:longstr; index_1,index_2,index_3,index_4,index_5:longstr; loop,tab,flag,bflag,pagenum:integer; PROCEDURE initialize; begin tab:=6; pagenum:=1; index_1:=''; inpstr:=''; fnameout:=''; end; (* initialize *) FUNCTION stripwhite(var target:midstr): midstr; const whitespace:set of char=[#8,#10,#12,#13,' ']; begin while (length(target)>0) and (target[1] in whitespace) do delete(target,1,1); stripwhite:=target end; PROCEDURE parsetail(ramtail:midstr;var s:midstr); var marker:integer; tail:midstr; begin tail:=ramtail; tail:=stripwhite(tail); if length(tail)>0 then repeat marker:=pos(' ',tail)-1; if marker<=0 then marker:=length(tail); s:=copy(tail,1,marker); delete(tail,1,marker); tail:=stripwhite(tail) until (length(tail)=0); end; (* parsetail *) PROCEDURE gettail(var inpstr:midstr); VAR ramtail:midstr absolute $80; begin parsetail(ramtail,inpstr); end; (* gettail *) PROCEDURE translit(var fnameout:midstr); const EXT='.OTL'; var slen, marker : integer; BEGIN slen:=length(fnameout); marker:=0; marker:=pos('.',fnameout); if marker>0 then delete(fnameout,marker,(slen-marker)+1); fnameout:=concat(fnameout,EXT); END; (* translit *) PROCEDURE todisk(fnameout:midstr); BEGIN assign(textout,fnameout); rewrite(textout); END; (* todisk *) PROCEDURE directory; const Search_First : Integer = $11; Search_Next : Integer = $12; Set_DMA : Integer = $1A; var Error, Loop, Start : Integer; FCB : array[0..25] of Byte absolute $005C; DMA : array[0..255] of Byte; begin Error := BDos(Set_DMA,Addr(DMA)); FCB[0] := 0; for Loop := 1 to 11 do FCB[Loop] := ord('?'); Error := BDos(Search_First,Addr(FCB)); if Error <> 255 then begin Start := Error * 32; for Loop:= Start to start+8 do Write(Char(Mem[Addr(DMA)+Loop])); Write(' '); for Loop:= Start+9 to Start+11 do Write(Char(Mem[Addr(DMA)+Loop])); WriteLn end; repeat Error := BDos(search_Next); Start := Error * 32; if Error <> 255 then begin for Loop:= Start to start+8 do Write(Char(Mem[Addr(DMA)+Loop])); Write(' '); for Loop:= Start+9 to Start+11 do Write(Char(Mem[Addr(DMA)+Loop])); WriteLn end until Error=255 end; (*directory*) PROCEDURE getfile(var inpstr:midstr; var fnameout:midstr); var slen:integer; IOerr:boolean; rr:real; ii,jj,nn:integer; ee:boolean; begin IOerr:=FALSE; fnamein:=inpstr; slen:=length(fnamein); clrscr; if slen>0 then slen:=1; case slen of 0 : begin directory; remark('Enter your file..',20,10,FAST); remark('Use and .....',20,12,FAST); getstring(25,14,fnamein,14,CAPS,ANUM,AFRACS,rr,nn,ii,jj,ee); end; (* 0 *) 1 : begin remark('Your file is....',20,10,FAST); remark(fnamein,25,14,FAST); end; (* 1 *) end; (* case *) repeat assign(textin,fnamein); {$I-} reset(textin); {$I+} IOerr:=(IOresult<>0); if IOerr then begin crt(BEEP); gotoxy(25,14); crt(ERASEOL); center('That not found...',20); gotoxy(1,1); directory; fnamein:=''; remark('Enter File...',20,12,SLOW); getstring(25,14,fnamein,14,CAPS,ANUM,AFRACS,r,n,i,j,e); end (* if *) until not IOerr; fnameout:=fnamein; translit(fnameout); remark('Default for ALL output...',20,16,SLOW); remark('You can change it by ...',20,17,SLOW); getstring(25,19,fnameout,14,CAPS,ANUM,AFRACS,r,n,i,j,e); end; (* getfile *) PROCEDURE select; var choice:char; okset:charset; BEGIN clrscr; bstr:=''; okset:=['P','S','D']; remark('Enter One of the Following......',10,10,SLOW); remark('For Sending to Printer

', 12,12,FAST); remark('For Sending to Screen ', 12,13,FAST); remark('For Sending to Disk ', 12,14,FAST); getstring(20,16,bstr,1,CAPS,ANUM,AFRACS,r,n,i,j,e); choice:=copy(bstr,1,1); case choice of 'P' : begin assign(textout,'LST:'); reset(textout); end; (* P *) 'S' : begin assign(textout,'CON:'); reset(textout); end; (* S *) 'D' : todisk(fnameout); else begin crt(BEEP); select; end; end; (* case *) end; (* select *) PROCEDURE lineheaders; BEGIN CASE tab OF 6: BEGIN writeln(textout); row:=row+1; index_2:=' '; index_5:=' '; if index_1='XX. ' then index:='XXI. ' else if index_1='XIX. ' then index:='XX. ' else if index_1='XVIII. ' then index:='XIX. ' else if index_1='XVII. ' then index:='XVIII. ' else if index_1='XVI. ' then index:='XVII. ' else if index_1='XV. ' then index:='XVI. ' else if index_1='XIV. ' then index:='XV. ' else if index_1='XIII. ' then index:='XIV. ' else if index_1='XII. ' then index:='XIII. ' else if index_1='XI. ' then index:='XII. ' else if index_1='X. ' then index:='XI. ' else if index_1='IX. ' then index:='X. ' else if index_1='VIII. ' then index:='IX. ' else if index_1='VII. ' then index:='VIII. ' else if index_1='VI. ' then index:='VII. ' else if index_1='V. ' then index:='VI. ' else if index_1='IV. ' then index:='V. ' else if index_1='III. ' then index:='IV. ' else if index_1='II. ' then index:='III. ' else if index_1='I. ' then index:='II. ' else index:='I. '; index_1:=index; END; 12: BEGIN index_3:=' '; if index_2='U. ' then index:='V. ' else if index_2='T. ' then index:='U. ' else if index_2='S. ' then index:='T. ' else if index_2='R. ' then index:='S. ' else if index_2='Q. ' then index:='R. ' else if index_2='P. ' then index:='Q. ' else if index_2='O. ' then index:='P. ' else if index_2='N. ' then index:='O. ' else if index_2='M. ' then index:='N. ' else if index_2='L. ' then index:='M. ' else if index_2='K. ' then index:='L. ' else if index_2='J. ' then index:='K. ' else if index_2='I. ' then index:='J. ' else if index_2='H. ' then index:='I. ' else if index_2='G. ' then index:='H. ' else if index_2='F. ' then index:='G. ' else if index_2='E. ' then index:='F. ' else if index_2='D. ' then index:='E. ' else if index_2='C. ' then index:='D. ' else if index_2='B. ' then index:='C. ' else if index_2='A. ' then index:='B. ' else index:='A. '; index_2:=index; END; 18: BEGIN index_4:=' '; if index_3='19. ' then index:='20. ' else if index_3='18. ' then index:='19. ' else if index_3='17. ' then index:='18. ' else if index_3='16. ' then index:='17. ' else if index_3='15. ' then index:='16. ' else if index_3='14. ' then index:='15. ' else if index_3='13. ' then index:='14. ' else if index_3='12. ' then index:='13. ' else if index_3='11. ' then index:='12. ' else if index_3='10. ' then index:='11. ' else if index_3='9. ' then index:='10. ' else if index_3='8. ' then index:='9. ' else if index_3='7. ' then index:='8. ' else if index_3='6. ' then index:='7. ' else if index_3='5. ' then index:='6. ' else if index_3='4. ' then index:='5. ' else if index_3='3. ' then index:='4. ' else if index_3='2. ' then index:='3. ' else if index_3='1. ' then index:='2. ' else index:='1. '; index_3:=index; END; 24: BEGIN index_5:=' '; if index_4='m. ' then index:='n. ' else if index_4='l. ' then index:='m. ' else if index_4='k. ' then index:='l. ' else if index_4='j. ' then index:='k. ' else if index_4='i. ' then index:='j. ' else if index_4='h. ' then index:='i. ' else if index_4='g. ' then index:='h. ' else if index_4='f. ' then index:='g. ' else if index_4='e. ' then index:='f. ' else if index_4='d. ' then index:='e. ' else if index_4='c. ' then index:='d. ' else if index_4='b. ' then index:='c. ' else if index_4='a. ' then index:='b. ' else index:='a. '; index_4:=index; END; 30: BEGIN if index_5='xvi. ' then index:='xvii. ' else if index_5='xv. ' then index:='xvi. ' else if index_5='xiv. ' then index:='xv. ' else if index_5='xiii. ' then index:='xiv. ' else if index_5='xii. ' then index:='xiii. ' else if index_5='xi. ' then index:='xii. ' else if index_5='x. ' then index:='xi. ' else if index_5='ix. ' then index:='x. ' else if index_5='viii. ' then index:='ix. ' else if index_5='vii. ' then index:='viii. ' else if index_5='vi. ' then index:='vii. ' else if index_5='v. ' then index:='vi. ' else if index_5='iv. ' then index:='v. ' else if index_5='iii. ' then index:='iv. ' else if index_5='ii. ' then index:='iii. ' else if index_5='i. ' then index:='ii. ' else index:='i. '; index_5:=index; END; END; (*tab*) END; (*lineheaders*) PROCEDURE newpage; BEGIN row:=1; pagenum:=pagenum+1; for loop:=1 to 5 do writeln(textout); writeln(textout,fnameout:15,page:30,pagenum:4); writeln(textout);writeln(textout); END; (*newpage*) PROCEDURE parse; BEGIN CASE flag OF 1 : BEGIN lineheaders; writeln(textout,index:tab,bareline); row:=row+1; if row>58 then newpage; END; 2 : CASE bflag OF 1 : tab:=tab+adjust; 2 : tab:=tab-adjust; END (*bflag*) END; (*flag*) END; (*parse*) PROCEDURE execute; begin writeln(textout); writeln(textout,fnameout:15,page:30,pagenum:4); writeln(textout);writeln(textout); row:=1; while not eof(textin) do begin readln(textin,getline); maxlen:=length(getline)-1; flagline:=copy(getline,1,3); if flagline='.hl' then flag:=1 else flag:=2; bareline:=copy(getline,5,maxlen); if bareline='+1' then bflag:=1 else bflag:=2; parse; end; (* enddo *) close(textin); close(textout); end; PROCEDURE driver; BEGIN crt(CLEAR); initialize; gettail(inpstr); getfile(inpstr,fnameout); select; execute; END; (* driver *) BEGIN driver END.