diff options
Diffstat (limited to 'dviware/ln03/rose/picmode.pli')
-rw-r--r-- | dviware/ln03/rose/picmode.pli | 529 |
1 files changed, 529 insertions, 0 deletions
diff --git a/dviware/ln03/rose/picmode.pli b/dviware/ln03/rose/picmode.pli new file mode 100644 index 0000000000..4169256a7c --- /dev/null +++ b/dviware/ln03/rose/picmode.pli @@ -0,0 +1,529 @@ +%REPLACE false BY '0'B; +%REPLACE true BY '1'B; + +/* + +The purpose of this program is to provide a standalone version of LNF's +PICmode, outputting a TeX file which can be \input into a TeX document. +Copyright (c) 1984 by Digital Equipment Corporation. Author: Flavio +Rose. UNDER DEVELOPMENT. + +*/ + +picmode: PROCEDURE OPTIONS(MAIN); + + DCL (strip,frontstrip) EXTERNAL ENTRY (CHAR (*)) + RETURNS (CHAR (*)), + cvis EXTERNAL ENTRY (FIXED) RETURNS (CHAR (*)); + DCL upcase EXTERNAL ENTRY (CHAR (*)) RETURNS (CHAR (*)); + DCL read_wln_file EXTERNAL ENTRY(FIXED,CHAR(*),FILE) RETURNS(BIT); + + /* Debugging info */ + DCL debug FILE; + DCL debugwid FIXED; + DCL debugflag BIT; + debugflag = false; + debugwid = 0; + + /* input file, output file, wln file, include file */ + DCL (outf,inf) FILE; + DCL (infnam,outfnam) CHAR(150) VARYING; + + ON UNDEFINEDFILE (inf) BEGIN; + PUT SKIP LIST('No such file: ' || infnam); + GOTO terminal_eof; + END; + + ON UNDEFINEDFILE (outf) BEGIN; + PUT SKIP LIST('Couldn''t open: ' || outfnam); + GOTO terminal_eof; + END; + + /* Define <esc> <tab> as constants. In general this source file should + not contain any ascii control characters; instead we use byte(). */ + DCL (esc,tab) CHAR(1); + esc = byte(27); + tab = byte(9); + + /* Heading */ + PUT SKIP LIST ('PICmode 1.0'); + /* Hack command line */ + %REPLACE obufsize BY 512; + %REPLACE inbufsize BY 512; + DCL ob CHAR(obufsize); + DCL inline CHAR(inbufsize) VARYING; + DCL tch CHAR(1); + DCL (illen,obp,ilp,i,istart,zch) FIXED; + + %INCLUDE $stsdef; + DCL lib$get_foreign ENTRY (CHAR(*) VARYING, CHAR(*) VARYING, + FIXED(15),FIXED) OPTIONS(VARIABLE) RETURNS(FIXED); + DCL rms$_eof FIXED GLOBALREF VALUE; + DCL defdir CHAR(150) VARYING; + DCL (jj,jdir,jext) FIXED; + + sts$value = lib$get_foreign(inline,,,0); + + IF ^sts$success THEN DO; + PUT SKIP EDIT ('Usage: picmode <filename>') (A); + GOTO terminal_eof; + END; + + inline = inline || ' '; + illen = length(inline); + ilp = 1; + CALL skipb; + IF ilp > illen THEN DO; + PUT SKIP EDIT ('Usage: picmode <filename>') (A); + GOTO terminal_eof; + END; + istart = ilp; + CALL skipnb2; + infnam = substr(inline,istart,ilp-istart); + OPEN FILE(inf) TITLE(infnam) + ENVIRONMENT(Default_file_name('FOO.PMD')); + + jdir = istart; + DO jj = ilp-1 TO istart BY -1; + IF substr(inline,jj,1) = ':' | + substr(inline,jj,1) = ']' | + substr(inline,jj,1) = '>' + THEN DO; + jdir = jj+1; + GOTO found_jdir; + END; + END; + +found_jdir: + defdir = substr(inline,istart,jdir-istart); + jext = ilp; + DO jj = jdir TO ilp-1; + IF substr(inline,jj,1) = '.' | + substr(inline,jj,1) = ';' + THEN DO; + jext = jj; + GOTO found_jext; + END; + END; + +found_jext: + outfnam = substr(inline,jdir,jext-jdir) || '.TEX'; + + OPEN FILE(outf) OUTPUT TITLE(outfnam) + ENVIRONMENT(Default_file_name('FOO.TEX')); + +/* Globals: + + font information + picmode uses just one font + but we use these for compatibility with LNFWLN */ + + DCL curf FIXED; + DCL (firstch(0:9),lastch(0:9),fht(0:9)) FIXED GLOBALDEF; + DCL chw(0:9,0:255) FIXED GLOBALDEF; + DCL fname(0:9) CHAR(20) GLOBALDEF; + DCL font_present(0:9) BIT GLOBALDEF; + + curf = 0; + chw = 0; + font_present = false; + + /* character classification for PIC mode */ + DCL ztyp(0:255) FIXED(7); + ztyp = 0; + ztyp(rank('+')) = 1; + ztyp(rank('-')) = 2; + ztyp(rank('|')) = 3; + ztyp(rank('v')) = 4; + ztyp(rank('<')) = 5; + ztyp(rank('>')) = 6; + ztyp(rank('^')) = 7; + ztyp(rank('/')) = 8; + ztyp(rank('\')) = 9; + ztyp(rank('#')) = 10; + ztyp(rank('X')) = 11; + + DCL horp(0:11) BIT ALIGNED INIT(false,true,true,false, + true,false,false,true,true,true,true,false); + DCL verp(0:11) BIT ALIGNED INIT(false,true,false,true, + false,true,true,false,true,true,true,false); + DCL arrowp(0:11) BIT ALIGNED INIT(false,false,false,false, + true,true,true,true,false,false,false,false); + DCL slant(0:11) BIT ALIGNED INIT(false,false,false,false, + false,true,true,false,true,true,false,true); + PUT EDIT ('\vbox{\font\amgr=AMGR at 10truept\baselineskip0.1466667truein' || + '\lineskiplimit-\maxdimen') (A) FILE(outf); + PUT SKIP EDIT ('\catcode`\-=\active\catcode`\~=\active' || + '\def~{{\char32}}\def-{{\char1}}%') (A) FILE(outf); + CALL process_pic; + PUT EDIT ('}') (A) FILE(outf); + +abort_job: + CLOSE FILE(inf); + + +terminal_eof: + RETURN; + + process_pic: PROCEDURE; + DCL ils(3) CHAR(inbufsize) VARYING; + DCL (temp,prev,curr,next,quo,rem) FIXED; + DCL last_line BIT; + + ils(1) = ''; + last_line = false; + prev = 1; + curr = 2; + next = 3; + IF ^read_line_for_pic(2) THEN RETURN; /* pic is empty */ + IF ^read_line_for_pic(3) THEN last_line = true; + DO WHILE (true); + CALL output_pic_line; + IF last_line THEN DO; + obp = 0; + RETURN; + END; + temp = prev; + prev = curr; + curr = next; + next = temp; + IF ^read_line_for_pic(next) THEN last_line = true; + END; + + read_line_for_pic: PROCEDURE (which) RETURNS (BIT); + DCL (which,true_ilp) FIXED; + + ON ENDFILE (inf) GOTO end_of_inf; + + ils(which) = ''; + GET EDIT (inline) (A(511)) FILE(inf); + + inline = inline || ' '; + illen = length(inline); + /* For PICs, we attempt to untabify input lines */ + true_ilp = 1; + DO ilp = 1 TO illen-1; + IF substr(inline,ilp,1) ^= tab + THEN DO; + ils(which) = ils(which) || substr(inline,ilp,1); + true_ilp = true_ilp+1; + END; + ELSE DO; + quo = DIVIDE(true_ilp-1,8,31); + rem = true_ilp-1-quo*8; + ils(which) = ils(which) || copy(' ',8-rem); + true_ilp = true_ilp+8-rem; + END; + END; + RETURN(true); + + end_of_inf: + CLOSE FILE(inf); + RETURN(false); + + END read_line_for_pic; + + output_pic_line: PROCEDURE; + DCL (iz,prevl,currl,nextl,icnt,nbors(8)) FIXED; + DCL (zch,tch) CHAR; + DCL cnt_to_char_plus(0:15) FIXED STATIC INIT( + 43,161,160,164,161,161,165,177, + 160,163,161,176,162,178,175,174); + DCL cnt_to_char_sharp(0:15) FIXED STATIC INIT( + 35,161,160,186,161,161,187,177, + 160,185,161,176,184,178,175,174); + DCL (xtra1,xtra2) CHAR(inbufsize) VARYING; + DCL (xtra1used,xtra2used,present(8)) BIT ALIGNED; + + xtra1used = false; + xtra2used = false; + xtra1 = ''; + xtra2 = ''; + obp = 0; + prevl = length(ils(prev)); + currl = length(ils(curr)); + nextl = length(ils(next)); + DO iz = 1 TO currl; + zch = substr(ils(curr),iz); + IF ztyp(rank(zch)) ^= 0 THEN CALL det_nbors; + IF ztyp(rank(zch)) = 0 THEN tch = zch; + ELSE IF zch = '-' THEN DO; + IF ztyp(nbors(1)) ^= 0 | ztyp(nbors(3)) ^= 0 + THEN tch = byte(161); + ELSE tch = '-'; + END; ELSE IF zch = '|' THEN DO; + IF ztyp(nbors(2)) ^= 0 | ztyp(nbors(4)) ^= 0 + THEN tch = byte(160); + ELSE tch = '|'; + END; ELSE IF zch = '+' THEN DO; + icnt = 0; + IF horp(ztyp(nbors(1))) THEN icnt = icnt+1; + IF verp(ztyp(nbors(2))) THEN icnt = icnt+2; + IF horp(ztyp(nbors(3))) THEN icnt = icnt+4; + IF verp(ztyp(nbors(4))) THEN icnt = icnt+8; + IF nbors(1) = rank('<') THEN DO; + IF verp(ztyp(nbors(5))) | verp(ztyp(nbors(8))) + THEN icnt = icnt+1; + END; + IF nbors(2) = rank('^') THEN DO; + IF horp(ztyp(nbors(5))) | horp(ztyp(nbors(6))) + THEN icnt = icnt+2; + END; + IF nbors(3) = rank('>') THEN DO; + IF verp(ztyp(nbors(6))) | verp(ztyp(nbors(7))) + THEN icnt = icnt+4; + END; + IF nbors(4) = rank('v') THEN DO; + IF horp(ztyp(nbors(7))) | horp(ztyp(nbors(8))) + THEN icnt = icnt+8; + END; + tch = byte(cnt_to_char_plus(icnt)); + END; ELSE IF zch = 'v' | zch = '^' THEN DO; + IF (horp(ztyp(nbors(1))) & + ^arrowp(ztyp(nbors(1)))) + | (horp(ztyp(nbors(3))) & + ^arrowp(ztyp(nbors(3)))) + THEN DO; + IF zch = 'v' THEN tch = byte(181); + ELSE tch = byte(182); + END; ELSE tch = zch; + END; ELSE IF zch = '<' THEN DO; + IF (verp(ztyp(nbors(2))) & + ^arrowp(ztyp(nbors(2)))) + | (verp(ztyp(nbors(4))) & + ^arrowp(ztyp(nbors(4)))) + THEN tch = byte(179); + ELSE IF (nbors(6) = rank('/') + | nbors(6) = rank('>') | nbors(7) = rank('\') + | nbors(7) = rank('>')) + THEN DO; + tch = byte(173); + CALL superpose(byte(172)); + IF horp(ztyp(nbors(1))) THEN + CALL superpose(byte(167)); + END; ELSE tch = zch; + END; ELSE IF zch = '>' THEN DO; + IF (verp(ztyp(nbors(2))) & + ^arrowp(ztyp(nbors(2)))) + | (verp(ztyp(nbors(4))) & + ^arrowp(ztyp(nbors(4)))) + THEN tch = byte(180); + ELSE IF (nbors(8) = rank('/') + | nbors(5) = rank('<') | nbors(5) = rank('\') + | nbors(8) = rank('<')) + THEN DO; + tch = byte(170); + CALL superpose(byte(171)); + IF horp(ztyp(nbors(3))) THEN + CALL superpose(byte(169)); + END; ELSE tch = zch; + END; ELSE IF zch = '/' THEN DO; + present = false; + IF nbors(6) = rank('/') | nbors(6) = rank('>') + | nbors(6) = rank('X') | nbors(3) = rank('\') + THEN present(6) = true; + IF nbors(8) = rank('/') | nbors(8) = rank('<') + | nbors(8) = rank('X') | nbors(1) = rank('\') + THEN present(8) = true; + IF ^(present(6) | present(8)) THEN DO; + tch = zch; + GOTO break; + END; + IF present(6) & present(8) THEN tch = byte(188); + ELSE IF present(6) THEN tch = byte(172); + ELSE IF present(8) THEN tch = byte(170); + IF horp(ztyp(nbors(1))) & ^slant(ztyp(nbors(1))) + THEN present(1) = true; + IF horp(ztyp(nbors(3))) & ^slant(ztyp(nbors(3))) + THEN present(3) = true; + IF present(1) & present(3) THEN CALL superpose( + byte(161)); + ELSE IF present(1) THEN CALL superpose(byte(167)); + ELSE IF present(3) THEN CALL superpose(byte(169)); + END; ELSE IF zch = '\' THEN DO; + present = false; + IF nbors(5) = rank('\') | nbors(5) = rank('<') + | nbors(5) = rank('X') | nbors(3) = rank('/') + THEN present(5) = true; + IF nbors(7) = rank('\') | nbors(7) = rank('>') + | nbors(7) = rank('X') | nbors(1) = rank('/') + THEN present(7) = true; + IF ^(present(5) | present(7)) THEN DO; + tch = zch; + GOTO break; + END; + IF horp(ztyp(nbors(1))) & ^slant(ztyp(nbors(1))) + THEN present(1) = true; + IF horp(ztyp(nbors(3))) & ^slant(ztyp(nbors(3))) + THEN present(3) = true; + IF present(5) & present(7) THEN tch = byte(189); + ELSE IF present(5) THEN tch = byte(171); + ELSE IF present(7) THEN tch = byte(173); + IF present(1) & present(3) THEN CALL superpose( + byte(161)); + ELSE IF present(1) THEN CALL superpose(byte(167)); + ELSE IF present(3) THEN CALL superpose(byte(169)); + END; ELSE IF zch = '#' THEN DO; + icnt = 0; + IF horp(ztyp(nbors(1))) THEN icnt = icnt+1; + IF verp(ztyp(nbors(2))) THEN icnt = icnt+2; + IF horp(ztyp(nbors(3))) THEN icnt = icnt+4; + IF verp(ztyp(nbors(4))) THEN icnt = icnt+8; + IF nbors(1) = rank('<') THEN DO; + IF verp(ztyp(nbors(5))) | verp(ztyp(nbors(8))) + THEN icnt = icnt+1; + END; + IF nbors(2) = rank('^') THEN DO; + IF horp(ztyp(nbors(5))) | horp(ztyp(nbors(6))) + THEN icnt = icnt+2; + END; + IF nbors(3) = rank('>') THEN DO; + IF verp(ztyp(nbors(6))) | verp(ztyp(nbors(7))) + THEN icnt = icnt+4; + END; + IF nbors(4) = rank('v') THEN DO; + IF horp(ztyp(nbors(7))) | horp(ztyp(nbors(8))) + THEN icnt = icnt+8; + END; + tch = byte(cnt_to_char_sharp(icnt)); + END; ELSE IF zch = 'X' THEN DO; + IF nbors(5) = rank('\') & nbors(6) = rank('/') & + nbors(7) = rank('\') & nbors(8) = rank('/') + THEN DO; + tch = byte(188); + CALL superpose(byte(189)); + END; ELSE tch = zch; + END; ELSE tch = zch; + break: + obp = obp+1; + substr(ob,obp,1) = tch; + END; + + IF xtra1used THEN PUT SKIP EDIT ('\hbox{\rlap{%') (A) FILE(outf); + CALL really_output(substr(ob,1,obp)); + IF xtra1used THEN DO; + PUT EDIT ('}%') (A) FILE(outf); + IF xtra2used THEN PUT SKIP EDIT ('\rlap{%') (A) FILE(outf); + CALL really_output(xtra1); + IF xtra2used THEN DO; + PUT EDIT ('}%') (A) FILE(outf); + CALL really_output(xtra2); + END; + PUT EDIT ('}') (A) FILE(outf); + END; + + det_nbors: PROCEDURE; + DCL space_rank FIXED; + + space_rank = rank(' '); + IF iz = 1 THEN nbors(1) = space_rank; + ELSE nbors(1) = rank(substr(ils(curr),iz-1,1)); + IF iz = 1 | iz-1 > prevl THEN nbors(5) = space_rank; + ELSE nbors(5) = rank(substr(ils(prev),iz-1,1)); + IF iz > prevl THEN nbors(2) = space_rank; + ELSE nbors(2) = rank(substr(ils(prev),iz,1)); + IF iz+1 > prevl THEN nbors(6) = space_rank; + ELSE nbors(6) = rank(substr(ils(prev),iz+1,1)); + IF iz = currl THEN nbors(3) = space_rank; + ELSE nbors(3) = rank(substr(ils(curr),iz+1,1)); + IF iz = 1 | iz-1 > nextl THEN nbors(8) = space_rank; + ELSE nbors(8) = rank(substr(ils(next),iz-1,1)); + IF iz > nextl THEN nbors(4) = space_rank; + ELSE nbors(4) = rank(substr(ils(next),iz,1)); + IF iz+1 > nextl THEN nbors(7) = space_rank; + ELSE nbors(7) = rank(substr(ils(next),iz+1,1)); + + END det_nbors; + + superpose: PROCEDURE (x); + DCL x CHAR; + + IF ^xtra1used THEN DO; + xtra1 = copy(' ',obp+1); + substr(xtra1,obp+1,1) = x; + xtra1used = true; + END; ELSE IF length(xtra1) < obp+1 + THEN xtra1 = xtra1 || copy(' ',obp-length(xtra1)) || x; + ELSE IF substr(xtra1,obp+1,1) = ' ' + THEN substr(xtra1,obp+1,1) = x; + ELSE IF ^xtra2used THEN DO; + xtra2 = copy(' ',obp+1); + substr(xtra2,obp+1,1) = x; + xtra2used = true; + END; ELSE IF length(xtra2) < obp+1 + THEN xtra2 = xtra2 || copy(' ',obp-length(xtra2)) || x; + ELSE substr(xtra2,obp+1,1) = x; + + END superpose; + + really_output: PROCEDURE (who); + + DCL who CHAR(*) VARYING; + DCL (i,j,k) FIXED; + DCL (tch,tcat) CHAR(1); + DCL cats(32:126) CHAR(1) STATIC INIT + ('e',(2)('o'),(4)('e'),(6)('o'),'e',(46)('o'), + 'e','o',(2)('e'),(27)('o'),'e','o',(2)('e')); + + j = length(who); + + PUT SKIP EDIT ('\hbox{\amgr ') (A) FILE(outf); + k = 0; + DO i = 1 to j; + tch = substr(who,i,1); + IF rank(tch) < 32 | (rank(tch) > 126 & + rank(tch) < 160) + THEN tch = ' '; + k = k+1; + IF tch = ' ' THEN PUT EDIT ('~') (A) FILE(outf); + ELSE IF tch = byte(161) THEN PUT EDIT ('-') (A) FILE(outf); + ELSE IF rank(tch) >= 160 THEN DO; + PUT EDIT ('{\char' || cvis(rank(tch)-160) || '}') + (A) FILE(outf); + k = k+7; + END; ELSE DO; + tcat = cats(rank(tch)); + IF tcat = 'o' THEN PUT EDIT (tch) (A) FILE(outf); + ELSE DO; + PUT EDIT ('{\char' || cvis(rank(tch)) || '}') + (A) FILE(outf); + k = k+7; + END; + END; + IF k > 100 THEN DO; + PUT EDIT ('%') (A) FILE(outf); + PUT SKIP FILE(outf); + k = 0; + END; + + END; + PUT EDIT ('}') (A) FILE(outf); + + END really_output; + + END output_pic_line; + + END process_pic; + + /* skip over blanks in infile */ + skipb: PROCEDURE; + + DO WHILE (ilp <= illen); + IF substr(inline,ilp,1) ^= ' ' THEN RETURN; + ilp = ilp+1; + END; + + END skipb; + + /* skip over characters other than ' ' and '}'. */ + skipnb2: PROCEDURE; + + DO WHILE (ilp <= illen); + IF substr(inline,ilp,1) = ' ' + | substr(inline,ilp,1) = '}' THEN RETURN; + ilp = ilp+1; + END; + + END skipnb2; + +END picmode; |