(FILECREATED "16-Feb-86 13:15:38" {QV}<IDL>SOURCES>PRINT.;22 21835
changes to: (VARS PRINTCOMS)
previous date: "11-Feb-86 23:28:44" {QV}<IDL>SOURCES>PRINT.;21)
(* Copyright (c) 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT PRINTCOMS)
(RPAQQ PRINTCOMS [(* prettyprint fns for arrays)
(FNS PPA PRINTARRAYPROPS PRINTELT PRINTLABEL PRINTMATRIX PRINTTITLE SPACEP
TITLE.PRINT.ACTION)
(VARS (LABELPRINTFLAG 4)
(PRECISION (QUOTE (4 3)))
(ROWLABELWIDTH 8))
(ALISTS (PRETTYPRINTYPEMACROS ARRAYFRAME))
(FNS AFDEFPRINT)
(P (DEFPRINT (QUOTE ARRAYFRAME)
(QUOTE AFDEFPRINT)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS
(NLAMA)
(NLAML)
(LAMA TITLE.PRINT.ACTION])
(* prettyprint fns for arrays)
(DEFINEQ
(PPA
[ULAMBDA ((A ARRAY (USEDIN PRINTMATRIX))
(FILE))
(* jop: " 5-Sep-85 19:41")
[SETQ ROWLABELWIDTH (coerce ROWLABELWIDTH INTEGER (SATISFIES (IGREATERP ROWLABELWIDTH 0]
[SETQ LABELPRINTFLAG (coerce LABELPRINTFLAG INTEGER (SATISFIES (BETWEEN LABELPRINTFLAG 0 4]
(UERRORGUARD (PROGN (if (NLISTP (CDR (LISTP PRECISION)))
then (UERROR))
(change (CAR PRECISION)
(coerce DATUM INTEGER))
(change (CADR PRECISION)
(coerce DATUM INTEGER)))
"Illegal value for PRECISION: " .P2 PRECISION)
(DPROGN ((PRECISION (LISTP OF INTEGER))
(ROWLABELWIDTH INTEGER))
[RESETLST [if (NULL FILE)
elseif (OPENP FILE (QUOTE OUTPUT))
then (RESETSAVE (OUTPUT FILE))
else (RESETSAVE (OUTFILE FILE)
(QUOTE (PROGN (CLOSEF (OUTPUT OLDVALUE]
(if (VSCALARP A)
then (PRIN1 (GETAELT A (VSCALARPTR A)))
else (DPROG ((LABELPRINTFLAG [IMIN LABELPRINTFLAG
(PROG ((L (LABELLEVEL A)))
(RETURN (if (EQ L 2)
then 3
else L] INTEGER (USEDIN
PRINTMATRIX
PRINTELT))
(EMPTYFLAG NIL BOOL (USEDIN PRINTMATRIX)
(* T if A has an empty dimension))
(GSB (create GENSTATEBLOCK) GENSTATEBLOCK (USEDIN PRINTMATIX)
(* Prevents reallocation))
(SHAPE (fetch SHAPE of A) ROWINT)
(SYM (EQ (fetch FORMAT of A)
(QUOTE SYMMETRIC)) BOOL (USEDIN PRINTMATRIX))
(FIELDWIDTH (IPLUS (CAR PRECISION)
(CADR PRECISION)
2) INTEGER (USEDIN PRINTMATRIX PRINTELT
PRINTARRAYPROPS))
(CB NIL (ONEOF NIL CODEBOOK) (USEDIN PRINTMATRIX))
(VALDIM (GETVALDIM A) (USEDIN PRINTMATRIX))
(PAGEWIDTH (LINELENGTH) INTEGER)
THEN (NDIMS (fetch NELTS of SHAPE) INTEGER (USEDIN PRINTMATRIX))
(NUMFORMAT (NUMFORMATCODE (if (EQ (fetch AELTTYPE of A)
(QUOTE INTEGER))
then (LIST (QUOTE FIX)
FIELDWIDTH)
else (LIST (QUOTE FLOAT)
FIELDWIDTH
(CADR PRECISION)))
(CONSTANT (NUMFORMATCODE))) (USEDIN
PRINTELT))
THEN (XDIMS (IDIFFERENCE NDIMS 2) INTEGER
(* Number of excess dimensions))
(SHPND (if (ZEROP NDIMS)
then 0
else (GETRELT SHAPE NDIMS)) IJK)
(NCOLUMNS (IMAX 1 (IQUOTIENT (if (ILESSP LABELPRINTFLAG 3)
then PAGEWIDTH
else (IDIFFERENCE PAGEWIDTH
ROWLABELWIDTH))
(ADD1 FIELDWIDTH))) INTEGER (SATISFIES
(IGREATERP
NCOLUMNS
0))))
(DPROG ((LM (IQUOTIENT ROWLABELWIDTH 2) INTEGER
(* Left margin))
(RM (IMAX (if (IGREATERP SHPND NCOLUMNS)
then PAGEWIDTH
else (IPLUS (ITIMES SHPND (ADD1 FIELDWIDTH))
(if (IGREATERP LABELPRINTFLAG 2)
then ROWLABELWIDTH
else 0)))
35) INTEGER
(* Right margin)))
(PRINTTITLE (GETTITLE A)
LM RM T)
(PRINTARRAYPROPS A LM RM))
(if (OR (IGREATERP XDIMS 0)
(IGREATERP SHPND NCOLUMNS))
else (if (IGREATERP NDIMS 0)
then (PRINTMATRIX A 1)
(* Only one panel and not empty))
(RETURN))
[if (ILESSP LABELPRINTFLAG 3)
then (SETQ LABELPRINTFLAG 3)
(* Level label if slicing)
(SETQ NCOLUMNS (IMAX 1 (IQUOTIENT (IDIFFERENCE PAGEWIDTH
ROWLABELWIDTH)
(ADD1 FIELDWIDTH]
(* Leave space for the labels!)
[bind (XDSUB ←(AND (IGREATERP XDIMS 0)
(create ROWINT
NELTS ← XDIMS
INIT ← 1)))
[SLICE ←(FSELECT A
(for D
(S ←(create ROWPTR
NELTS ← NDIMS
INIT ←(QUOTE ALL)))
declare (S ROWPTR
(* Selector rowptr))
to XDIMS do (SETRELT S D 1)
finally (RETURN S]
declare (XDSUB (ONEOF NIL ROWINT)
(* Excess dimension subscript, if any)
)
(SLICE SELARRAY (* The object to be given to PRINTMATRIX, perhaps a
window))
do
(* * Now we have an at most two dimensional slice -
so we carve it into pagewidth slices)
[AND (IGREATERP LABELPRINTFLAG 1)
(for D L to XDIMS declare (L IJK)
do (printout NIL T (OR (GETDIMLAB A D)
D))
(if (IGREATERP LABELPRINTFLAG 2)
then (SETQ L (GETRELT (the ROWINT XDSUB)
D))
(PRIN1 " = ")
(* Watch out for an empty dimension)
(OR (IEQP 0 (GETRELT SHAPE D))
(PRIN1 (OR (GETLEVLAB A D L)
L)))
(AND (IGREATERP LABELPRINTFLAG 3)
(EQ D VALDIM)
(NOT EMPTYFLAG)
(SETQ CB (GETCODES A L]
(if (IGREATERP SHPND NCOLUMNS)
then (for LC from 1 to SHPND by NCOLUMNS as RC from NCOLUMNS
by NCOLUMNS
declare (LC IJK)
(RC IJK)
bind [HEIGHTSLTR
←(AND SYM (CONS NIL (IJKBOX
(GETRELT SHAPE (SUB1 NDIMS]
do (ADJUST.SELECTION SLICE NDIMS
(CONS LC (IMIN RC SHPND)))
(if SYM
then (FRPLACA HEIGHTSLTR LC)
(ADJUST.SELECTION SLICE (SUB1 NDIMS)
HEIGHTSLTR)
(* Lop off the empty top of symmetric arrays)
)
(PRINTMATRIX SLICE LC))
else (PRINTMATRIX SLICE 1))
(TERPRI) (* Put out the inter panel spacing)
repeatwhile (for D TEMP from XDIMS by -1 to 1 declare (TEMP IJK)
thereis (DPROGN ((XDSUB ROWINT))
(SETRELT XDSUB D
(SETQ TEMP
(if (ILESSP (GETRELT XDSUB D)
(GETRELT SHAPE D))
then (ADD1 (GETRELT XDSUB D))
else 1))))
(ADJUST.SELECTION SLICE D TEMP)
(NOT (IEQP 1 TEMP])]
(* Return the array with its KEEPs)
A)])
(PRINTARRAYPROPS
[DLAMBDA ((A ARRAY)
(LMARG INTEGER (* Left margin))
(RMARG INTEGER (* Right margin)))
(* bas: "17-AUG-79 17:29" posted: "23-NOV-77 17:12")
(* Prints the properties of A in a pretty format)
(DECL (NUMFORMAT (BOUNDIN PPA)))
(for P in A:SLOT5 when (AND P::1 P=(FASSOC P:1 A:SLOT5))
do
(* Print the first entry of each type on the array properties list. Only the first entry because property lists are
shared and new entries are pushed on the front rather than overwriting previous ones. -
The check for NIL has the same motivation. The NIL might be there to conceal earlier properties in the list.)
(printout NIL T .TAB0 LMARG)
(SELECTQ P:1
(PAIRN (PRIN1 "Observations missing"))
(HMEAN (printout NIL "Harmonic mean of cell N's:")
(PRINTNUM NUMFORMAT P::1))
[KEEPS (PRIN1 "Kept: ")
(for V in P::1 do (printout NIL , (OR (GETDIMLAB A V)
V]
(printout NIL P:1 ": " .PPV P::1))
(TERPRI))])
(PRINTELT
[DLAMBDA ((ELT SCALAR)
(CB (ONEOF NIL CODEBOOK)))
(* bas: "11-FEB-83 10:34")
(* Prints a scalar as an element of ARRAY)
(DECL (LABELPRINTFLAG INTEGER)
(FIELDWIDTH INTEGER (BOUNDIN PPA))
(NUMFORMAT (BOUNDIN PPA)))
(DPROG ((CODE NIL (ONEOF NIL LABEL)))
(if (AND (EQ LABELPRINTFLAG 4)
(SETQ CODE (perform CODEBOOK.FINDLAB CB ELT)))
then (PRINTLABEL FIELDWIDTH NIL CODE)
elseif (NULL ELT)
then (printout NIL .SP (IDIFFERENCE FIELDWIDTH 3)
NIL)
else (PRINTNUM NUMFORMAT ELT)))])
(PRINTLABEL
[DLAMBDA ((WIDTH INTEGER)
(DEFAULT (ONEOF INTEGER NIL) (* What to print if LABEL is NIL))
(LABEL (ONEOF NIL LABEL)))
(* jop: "30-Apr-85 14:44" posted: "24-SEP-77 23:21")
(* Prints LABEL truncated to WIDTH charactes, or
DEFAULT if LABEL is NIL. Output is flushed-right in a
field WIDTH wide.)
(printout NIL .FR (IMINUS WIDTH)
(OR (AND LABEL (if (GREATERP (NCHARS LABEL)
WIDTH)
then (SUBSTRING LABEL 1 WIDTH (CONSTANT (CONCAT)))
else LABEL))
DEFAULT))])
(PRINTMATRIX
[DLAMBDA ((ASLICE (ONEOF VECTOR MATRIX))
(LC INTEGER (SATISFIES (IGREATERP LC 0)) (* The left column of this slice)))
(* jop: " 7-Oct-85 23:24")
(* Prints a one or two dimensional slice generated by
PPA)
(DECL (A ARRAY (BOUNDIN PPA))
(NDIMS INTEGER (BOUNDIN PPA))
(VALDIM (ONEOF NIL INTEGER) (BOUNDIN PPA))
(CB (ONEOF NIL CODEBOOK) (BOUNDIN PPA))
(LABELPRINTFLAG INTEGER)
(ROWLABELWIDTH INTEGER)
(FIELDWIDTH INTEGER (BOUNDIN PPA))
(EMPTYFLAG BOOL (BOUNDIN PPA))
(SYM BOOL (BOUNDIN PPA))
(GSB GENSTATEBLOCK (BOUNDIN PPA) (* Free to prevent re-allocation)))
(DPROG ((SHAPE (fetch SHAPE of ASLICE) ROWINT)
(COLOFFSET (SUB1 LC) IJK (* Offset for colum labels)))
(SETQ GSB (SETUP ASLICE (QUOTE ROWMAJOR)
GSB))
(if (IEQP NDIMS 1)
then (* the original array was a vector)
(if (IGREATERP LABELPRINTFLAG 1)
then (printout NIL (OR (GETDIMLAB A NDIMS)
NDIMS)
T) (* Print the dimension label on its own line)
(if (IGREATERP LABELPRINTFLAG 2)
then (for I to (GETRELT SHAPE 1)
do (SPACES 1)
(PRINTLABEL FIELDWIDTH (IJKBOX (IPLUS COLOFFSET I))
(GETLEVLAB ASLICE 1 I)))
(TERPRI))) (* print rectangular cut of symmetric array right
against the triangular piece)
(for COL to (GETRELT SHAPE 1)
do (SPACES 1)
[PRINTELT (GETAELT ASLICE (NEXT GSB))
(OR CB (AND (EQ LABELPRINTFLAG 4)
(EQ NDIMS VALDIM)
(GETCODES A (IJKBOX (IPLUS COLOFFSET COL]
(* Row codebooks are extracted once higher up)
)
(TERPRI)
else (* the original array was a 2 or more dim array)
(if (IGREATERP LABELPRINTFLAG 1)
then (printout NIL T .SP ROWLABELWIDTH (OR (GETDIMLAB A NDIMS)
NDIMS)
T
(OR (GETDIMLAB A (SUB1 NDIMS))
(SUB1 NDIMS)))
[if (IGREATERP LABELPRINTFLAG 2)
then (printout NIL .TAB0 ROWLABELWIDTH)
(for I to (GETRELT SHAPE 2)
do (SPACES 1)
(PRINTLABEL FIELDWIDTH (IJKBOX (IPLUS COLOFFSET I))
(GETLEVLAB ASLICE 2 I]
(TERPRI)) (* Don't print column headers for rectangular cut of
symmetric matrix, so it will appear right against the
triangular piece)
(for ROW to (GETRELT SHAPE 1) as REALROW from (if SYM
then LC
else 1)
declare (REALROW IJK) bind [ROWCB ←(AND (EQ LABELPRINTFLAG 4)
(EQ VALDIM (SUB1 NDIMS]
do (if ROWCB
then (SETQ CB (GETCODES A REALROW)))
(if (IGREATERP LABELPRINTFLAG 2)
then (* The level labels for rows)
(PRINTLABEL ROWLABELWIDTH REALROW (GETLEVLAB ASLICE 1 ROW)))
[if (NOT EMPTYFLAG)
then (for COL to (GETRELT SHAPE 2)
do (SPACES 1)
[PRINTELT (GETAELT ASLICE (NEXT GSB))
(OR CB (AND (EQ LABELPRINTFLAG 4)
(EQ NDIMS VALDIM)
(GETCODES A (IJKBOX (IPLUS COLOFFSET COL]
(if (AND SYM (IEQP COL ROW))
then (SKIP GSB (IDIFFERENCE (GETRELT SHAPE 2)
COL))
(RETURN]
(TERPRI))))])
(PRINTTITLE
[DLAMBDA ((TIT TITLE)
(LM INTEGER (USEDIN TITLE.PRINT.ACTION) (* Left margin))
(RM INTEGER (USEDIN TITLE.PRINT.ACTION) (* Right margin))
(NONEWLINE BOOL (* Controls whether we start with TERPRI)))
(* rmk: "11-JAN-79 09:52" posted: "17-DEC-77 11:35")
(* Prints the TIT as a title between LM and RM columns. Arg is title instead of array so that HIST and PLOT can pass
in a manufactured title for printing without bothering to construct an array frame.)
(OR NONEWLINE (TERPRI))
(TAB LM 0 NIL)
(DPROG ((ACTION (FUNCTION TITLE.PRINT.ACTION) FUNCTION (USEDIN TRAVERSE.TITLE)))
(TRAVERSE.TITLE TIT)
(TERPRI))])
(SPACEP
[DLAMBDA ((S STRINGP)
(I INTEGER)
(RETURNS BOOL))
(* rmk: "22-FEB-82 16:54" posted: " 6-DEC-78 20:34")
(* Determines whether the Ith char of S is a space)
(CHARCODE SPACE)=(NTHCHARCODE S I)])
(TITLE.PRINT.ACTION
[LAMBDA NARGS (* bas: " 6-DEC-78 20:30" posted: " 4-DEC-77 22:13")
(* Action function for printing a title using
TRAVERSE.TITLE)
(DECLARE (USEDFREE LM RM))
(DPROG ((A 1 INTEGER (* Argument count))
(S NIL STRINGP (* What we have to print))
(NS NIL INTEGER))
NEXT(if A gt NARGS
then (RETURN))
(S←(MKSTRING (ARG NARGS A)))
(NS←(NCHARS S))
[if [OR (RM gt NS+(POSITION))
(AND RM=NS+(POSITION)
(OR A=NARGS (SPACEP S -1)
(SPACEP [OR (STRINGP (ARG NARGS A+1))
(SETARG NARGS A+1 (MKSTRING (ARG NARGS A+1]
1)
(PROGN S←(CONCAT S (ARG NARGS (add A 1)))
NS←(NCHARS S)
(* We can print something directly if it will either fit completely or if it fits exactly and the next thing to be
printed starts with a space. Otherwise, we glomb on the next arg and pass it thru the cutter so as to prevent being
left at the very end of the line with a non space to print as the first character of the next arg.)
NIL]
then (PRIN1 S) (* Except for first call we cannot be on the left
margin here, so no need for leading blank elimination)
else (DPROG ((I NIL INTEGER (SATISFIES (ILEQ I NS)))
(J 0 INTEGER (SATISFIES (ILEQ J NS))))
[while J lt NS
do (I←J+1) (* Start from after the last section)
(J←(OR (STRPOS " " S I+1)
NS+1)+ -1) (* End before next space or at end of string)
(if (ILEQ RM-(POSITION)
J-I)
then (OR (IEQP LM (POSITION))
(printout NIL T .TAB0 LM))
(* New line if not already)
(AND (SPACEP S I)
(if I=J
then (GO $$LP)
else (add I 1)))
(* If a new line was forced, dont print the possible
single leading space. If that was all forget this pass
thru the loop)
)
(PRIN1 (SUBSTRING S I J (CONSTANT (CONCAT])]
(add A 1)
(GO NEXT))])
)
(RPAQQ LABELPRINTFLAG 4)
(RPAQQ PRECISION (4 3))
(RPAQQ ROWLABELWIDTH 8)
(ADDTOVAR PRETTYPRINTYPEMACROS (ARRAYFRAME . PPA))
(DEFINEQ
(AFDEFPRINT
[DLAMBDA ((AF ARRAYFRAME))
(* jop: " 5-Sep-85 18:02" posted: " 3-DEC-77 14:10")
(* The DEFPRINT function for array-frames)
[RPLACA (CONSTANT (CONS NIL (PACK)))
(APPLY (FUNCTION CONCAT)
(PROG (LST)
(if (VSCALARP AF)
then (SETQ LST (NCONC1 LST "[Scalar "))
(SETQ LST (NCONC1 LST (SERIALNUMBER AF)))
(SETQ LST (NCONC1 LST ": "))
[SETQ LST (NCONC1 LST (GETAELT AF (VSCALARPTR AF]
(SETQ LST (NCONC1 LST "]"))
else (SETQ LST (NCONC1 LST "[Array "))
(SETQ LST (NCONC1 LST (SERIALNUMBER AF)))
(SETQ LST (NCONC1 LST ":"))
[for I LAB (SH ←(fetch SHAPE of AF)) to (fetch NDIMS of AF)
do (SETQ LST (NCONC1 LST " "))
(SETQ LST (NCONC1 LST (OR (GETDIMLAB AF I)
I)))
(SETQ LST (NCONC1 LST "="))
(SETQ LST (NCONC1 LST (GETRELT SH I]
[if (fetch KEEPS of AF)
then (SETQ LST (NCONC1 LST "; kept"))
(for I in (fetch KEEPS of AF)
do (SETQ LST (NCONC1 LST " "))
(SETQ LST (NCONC1 LST (OR (GETDIMLAB AF I)
I]
(SETQ LST (NCONC1 LST "]")))
(RETURN LST]])
)
(DEFPRINT (QUOTE ARRAYFRAME)
(QUOTE AFDEFPRINT))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA TITLE.PRINT.ACTION)
)
(PUTPROPS PRINT COPYRIGHT ("Xerox Corporation" 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (849 19848 (PPA 859 . 8981) (PRINTARRAYPROPS 8983 . 10298) (PRINTELT 10300 . 11055) (
PRINTLABEL 11057 . 11824) (PRINTMATRIX 11826 . 15934) (PRINTTITLE 15936 . 16800) (SPACEP 16802 . 17173
) (TITLE.PRINT.ACTION 17175 . 19846)) (19993 21542 (AFDEFPRINT 20003 . 21540)))))
STOP