summaryrefslogtreecommitdiff
path: root/dviware/ln03/rose/picmode.pli
diff options
context:
space:
mode:
Diffstat (limited to 'dviware/ln03/rose/picmode.pli')
-rw-r--r--dviware/ln03/rose/picmode.pli529
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;