path: root/dviware/ln03/rose/picmode.pli

%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;