COMMENT ⊗   VALID 00011 PAGES 
RECORD PAGE   DESCRIPTION
 00001 00001
 00002 00002	BEGIN	"cram"
 00003 00003	! variables
 00004 00004	! setup, dcmd, qmcmd
 00007 00005	! icmd, tcmd, hcmd, tcmd, ccmd, pcmd
 00009 00006	λ OCMD
 00010 00007	 λ PUTLIN (str LIN)
 00012 00008	λ PGSOUT
 00013 00009	! the code for ocmd
 00014 00010	! qcmd, xcmd, fcmd, wcmd
 00015 00011	! MAIN PROGRAM -- initialize and dispatch
 00017 ENDMK
⊗;
BEGIN	"cram"

COMMENT cram 4 pages onto an XGP page.
;
REQUIRE 4000 STRING_SPACE;

DEFINE	INT="integer",STR = "string", REA = "real",
	BOOL = "boolean", ARR = "array",

	cr = "'15", lf = "'12", bl = "'40",
	crlf = "cr & lf", ff = "'14",

	TT = "true", F = "false",

	! = "comment", β = "begin", ∂ = "datum",
	λ = "procedure",

	CHOP = "fudge ← LOP", SAY = "outstr",

	TIL = "step 1 until", TH = " FOR 1";

INT fudge, flg, brk;

DEFINE	ichn = "1", ochn = "2";

DEFINE	linbrk = "1"; ! break table;

INT i, j, k, l, m, n; STR s, t, u, v; REA w, x, y, z;
! variables;

STR ifile, iline, ofile;

INT iflg, ieof, ibrk, oflg, oeof, obrk;

STR title, header;

INT page, line, col;		! indices for output array;

INT pagn, pages, lines, cols, width;

INT cmd;


! XGP parameters;

DEFINE linlen = "1536"; 	! length of xgp scanline;
DEFINE margin = "150";		! right margin;
INT chrwid;			! character width;
STR xfnt;			! font;

DEFINE xpgwid = "(linlen-margin)%chrwid"; ! page width;
DEFINE xpglen = "75";		! lines/page;
! setup, dcmd, qmcmd;

λ SETUP;
 β "setup" ! set up variables and so forth;
 say("type ? for help" &crlf);
 title ← ifile ← NULL;
 header ←
"-------- $ ------ # -----------";
 ofile ← "XXCRAM.RPG";
 pages ← 2; cols ← 2;
 xfnt ← "FIX13"; chrwid ← 9;
 width ← (xpgwid)%cols-1;
 lines ← (xpglen)%pages;
 SETBREAK(linbrk,ff&lf,NULL,"ias");
 END "setup";

λ DCMD;
 β "dcmd" ! type parameters;
 say(" I"&ifile&crlf & " O"&ofile&crlf &
     " t"&title&crlf & " H"&header&crlf & " C"&cvs(cols)&crlf &
     " P"&cvs(pages)&crlf & " F"&xfnt&crlf & " W"&cvs(chrwid)&crlf &
     " column width="&cvs(width)&crlf &
     " page length="&cvs(lines-1)&crlf);
 cmd ← 0;
 END "dcmd";

λ QMCMD;
 β "qmcmd" ! type command list;
 cmd ← 0;
 say("commands are a command character followed by argument
 followed by [cr].
COMMANDS ARE: (* means not working yet)
 ?		print this list
 Cn		columns/xgpage, default 2
 D		display current parameter values
 F<font>	set font, default FIX13 (width 9). must be 13 high.
 H<str>		header, $ filename, # page number, *[ ∂ date ]
 I<file>	set input file
 O<file>	output to file, default is XXCRAM.RPG
 Pn		pages/column, default 2.  0 means as many as will fit.
 Q		quit to monitor
*T<str>		title, $ replaced by input file name, ∂ by date
 W<width>	set char. width, default 9
 X		exit to COPY and put out the last file written
 X<file>	same as I<file>, O, X.
");
 END "qmcmd";

! icmd, tcmd, hcmd, tcmd, ccmd, pcmd;

λ ICMD;
 β "icmd" ! set input file;
 cmd ← 0;
 ifile ← iline;
 OPEN(ichn,"DSK",0,11,0,256,ibrk,ieof);
 LOOKUP(ichn,ifile,iflg);
 IF iflg THEN say("sorry, lookup failed" & crlf);
 END "icmd";

λ TCMD;
 β "tcmd" ! set title line;
 cmd ← 0;
 title ← iline;
 END "tcmd";

λ HCMD;
 β "hcmd" ! set header line;
 cmd ← 0;
 header ← iline;
 END "hcmd";
 
λ PCMD;
 β "pcmd" ! set pages/column;
 cmd ← 0;
 pages ← INTSCAN(iline,ibrk);
 lines ← IF pages THEN xpglen % pages ELSE xpglen;
 END "pcmd";
 
λ CCMD;
 β "ccmd" ! set columns/page;
 cmd ← 0;
 cols ← INTSCAN(iline,ibrk);
 width ← (xpgwid)%cols-1; ! allow 1 chr. between columns;
 END "ccmd";
λ OCMD;
 β "ocmd" ! get output file name and do the transfer;
 STR ARR outpg[0:xpglen];
 STR colskp;

 STR λ XGPSKIP (int COLS, COL);
  β "xgpskip" ! column skip escape to column COL of COLS;
  STR colskp;
  n ← (linlen-margin)%cols*col+margin;
  colskp ← '177 & '1 & '40 & (n%'200) & (n MOD '200);
  RETURN(colskp)
  END "xgpskip";

 λ PUTOUT;
  β "putout" ! put out the page;
    FOR j ← 0 TIL xpglen-1 DO
     β "putline"
      OUT(ochn,outpg[j]);
      OUT(ochn,crlf);
     END "putline";
   col ← page ← line ← 0;
   OUT(ochn,ff);
  END "putout";

 λ PUTLIN (str LIN);
  β "putlin" ! put a line into the outpg array;
  STR nlin; ! line with tabs converted;
  INT l; ! its length;

  IF line ≥ xpglen THEN
   β "newcol"
   line ← 0;
   IF (col←col+1)= cols THEN
    PUTOUT; ! we have finished an xgp page;
   colskp ← xgpskip(cols,col);
   END "newcol";

  nlin ← NULL; l ← 0;
  WHILE lin ∧ l < width DO 
   β "cvtabs" ! convert tabs and clip line to column length;
   IF lin = '11 THEN β "istab"
		     nlin ← nlin & " ";
		     l ← l + 1;
		     WHILE l MOD 8 DO β "xtab"
				      nlin ← nlin & " ";
				      l ← l + 1;
				      END "xtab";
		     CHOP(lin);
		     END "istab"
		ELSE IF lin = cr ∧ LENGTH(lin) > 1 THEN β "iscr"
		     ! naked carriage return;
		     nlin ← nlin & colskp;
		     l ← 0;
		     CHOP(lin);
		     END "iscr"
		ELSE β "ordinary"
		     l ← l + 1;
		     nlin ← nlin & LOP(lin);
		     END "ordinary";
   END "cvtabs";
  outpg[line] ← IF col THEN outpg[line] & colskp & nlin
			    ELSE colskp & nlin;
  line ← line + 1; ! step line #;
  END "putlin";
λ PGSOUT;
 WHILE ¬ieof DO 
  β "outloop" 
  IF ibrk ≠ ff THEN putlin(iline)
  ELSE
    β "dohdr" ! do spc. character replacement on header;
    STR hdr; INT i;

    IF pages THEN WHILE line MOD lines DO putlin(NULL);
    hdr ← NULL;
    FOR i ← 1 TIL LENGTH(header) DO
     hdr ← hdr & (IF header[i TH] = "$" THEN ifile
		  ELSE IF header[i TH] = "#" THEN cvs(pagn)
		  ELSE header[i TH]);
    putlin(hdr);
    pagn ← pagn + 1;
    END "dohdr";
  iline ← INPUT(ichn,linbrk);
  END "outloop";
! the code for ocmd;

 cmd ← 0;
 IF iline THEN ofile ← iline;
 OPEN(ochn,"DSK",0,0,11,0,obrk,oeof);
 ENTER(ochn,ofile,oflg);
 IF oflg THEN β say("sorry, enter failed" & crlf); RETURN END;
 line ← page ← col ← 0;

 iline ← NULL;
 ibrk ← ff; ! fake first page;
 colskp ← xgpskip(cols,col);
 pagn ← 1; ! page number;

 PGSOUT; ! put out pages;

! clean up at eof;
 WHILE line < xpglen DO
  putlin(null);
 PUTOUT;
 CLOSE(ochn);CLOSE(ichn);
 END "ocmd";

! qcmd, xcmd, fcmd, wcmd;

λ QCMD;
 β "qcmd" ! quit to monitor;
 cmd ← 0;
 fudge ← CALL(0,"EXIT");
 END "qcmd";

λ XCMD;
 β "xcmd" ! exit to copy;
 cmd ← 0;
 IF iline THEN
  β "more" ! if argument, input and output the file;
  icmd;
  iline ← NULL; ! default file for output;
  ocmd;
  END "more";
 PTOSTR(0,"XG /FONT=" & xfnt & " " & ofile & crlf);
 qcmd
 END "xcmd";

λ FCMD;
 β "fcmd" ! set font name;
 cmd ← 0;
 xfnt ← iline;
 say ("WIDTH= ");		! ask for width;
 chrwid ← cvd(INCHWL);
 END "fcmd";

λ WCMD;
 β "wcmd" ! set font width;
 cmd ← 0;
 chrwid ← cvd(iline);
 END "wcmd";

! MAIN PROGRAM -- initialize and dispatch;

setup;

WHILE TT DO
 β "dispatch"
 say("*");
 iline ← INCHWL;
 cmd ← LOP(iline); ! get a character;
 IF cmd = "C" ∨ cmd = "c" THEN ccmd;
 IF cmd = "D" ∨ cmd = "d" THEN dcmd;
 IF cmd = "F" ∨ cmd = "f" THEN fcmd;
 IF cmd = "H" ∨ cmd = "h" THEN hcmd;
 IF cmd = "I" ∨ cmd = "i" THEN icmd;
 IF cmd = "O" ∨ cmd = "o" THEN ocmd;
 IF cmd = "P" ∨ cmd = "p" THEN pcmd;
 IF cmd = "Q" ∨ cmd = "q" THEN qcmd;
 IF cmd = "T" ∨ cmd = "t" THEN tcmd;
 IF cmd = "W" ∨ cmd = "w" THEN wcmd;
 IF cmd = "X" ∨ cmd = "x" THEN xcmd;
 IF cmd = "?" THEN qmcmd;
 IF cmd THEN say("?? type ? for help")
 END "dispatch";

END "cram"