(FILECREATED "16-Feb-86 13:13:49" {QV}<IDL>SOURCES>LABELS.;14 38566
changes to: (VARS LABELSCOMS)
previous date: "27-Nov-85 17:48:49" {QV}<IDL>SOURCES>LABELS.;13)
(* Copyright (c) 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT LABELSCOMS)
(RPAQQ LABELSCOMS [(* IDL label functions)
(FNS COPYCODEBOOKS COPYDIMBLOCK COPYLEVBLOCK GETCODELAB GETCODENUM GETCODES GETDIMLAB
GETDIMNUM GETELTCODELAB GETLEVLAB GETLEVNUM GETTITLE GETTITLE.HACK GETTITLE.SELECTION
GETVALDIM IGNOR.SCF LAB.COPYALL LAB.COPYDIM LAB.COPYDIMS LABELLEVEL LABELP MAKETITLE
MAKETITLE.SUBSTARRAY MAKEUSERTITLE PLURAL SETCODELAB SETCODES SETDIMLAB SETLEVLAB
SETTITLE SETVALDIM SHOWSBASELABELS TRAVERSE.TITLE)
(VARS (LABPROPFLAG T))
(IF: TESTSYS (RECORDS CODEBOOK CODEPAIR LABELBLOCK))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA MAKETITLE])
(* IDL label functions)
(DEFINEQ
(COPYCODEBOOKS
[DLAMBDA ((AOLD ARRAY)
(ANEW ARRAY)
(OLDDIM INTEGER (SATISFIES (DIMENSIONP AOLD OLDDIM)))
(NEWDIM INTEGER (SATISFIES (DIMENSIONP ANEW NEWDIM)
(AOLD:SHAPE$OLDDIM LEQ ANEW:SHAPE$NEWDIM))))
(* jd: " 4-AUG-77 14:08" posted: " 4-AUG-77 14:19")
(* copys codebooks from aold to anew if oldim equals
the valdim of aold, newdim will become the valdim of
anew)
(DPROG ((VD (GETVALDIM AOLD) (ONEOF NIL INTEGER)))
[if (AND VD VD=OLDDIM)
then (SETVALDIM ANEW NEWDIM)
(for LEV to AOLD:SHAPE$VD do (SETCODES ANEW LEV (GETCODES AOLD LEV])])
(COPYDIMBLOCK
[DLAMBDA ((A SIMARRAY)
(INSERT ANY)
(RETURNS (ONEOF NIL ROWPTR)))
(* rmk: " 7-JUL-77 11:45" posted: " 7-JUL-77 11:48")
(* Returns a DIMLABELBLOCK that may be legally smashed. Assumes that the LABELBLOCK is never shared.
If INSERT=NIL, then the caller does not need to smash in if the structures don't yet exist, so don't build them and
return NIL.)
(DPROG ((LB A:LABELBLOCK (ONEOF NIL LABELBLOCK))
(DL NIL (ONEOF NIL ROWPTR)))
(if LB=NIL
then (if INSERT=NIL
then (RETURN))
LB←(A:LABELBLOCK←(create LABELBLOCK)))
(if DL←LB:DIMLABELBLOCK=NIL
then (if INSERT=NIL
then (RETURN))
DL←(LB:DIMLABELBLOCK←(create ROWPTR
NELTS ← A:NDIMS))
DL:REFCOUNT←1
elseif DL:REFCOUNT GT 1
then (add DL:REFCOUNT -1)
LB:DIMLABELBLOCK←DL←(COPYROW DL)
DL:REFCOUNT←1
(for I LL to DL:NELTS when LL←(GETRELTD DL I) do (add LL:REFCOUNT 1)))
(RETURN DL))])
(COPYLEVBLOCK
[DLAMBDA ((A SIMARRAY)
(DIM INTEGER (SATISFIES (DIMENSIONP A DIM)))
(INSERT ANY)
(RETURNS (ONEOF NIL ROWPTR)))
(* rmk: " 7-JUL-77 15:00" posted: " 6-JUL-77 23:56")
(* Returns a level block that may be legally smashed. Copies dimlabelblock and lev-labelblock if necessary, but
assumes that the LABELBLOCK is never shared. If INSERT=NIL, then the caller does not need to smash in if the
structures don't yet exist, so don't build them and return NIL.)
(DPROG ((DL (COPYDIMBLOCK A INSERT) (ONEOF NIL ROWPTR))
(LL NIL (ONEOF NIL ROWPTR)))
(if DL=NIL
then (RETURN))
(if LL←(GETRELTD DL DIM)=NIL
then (if INSERT=NIL
then (RETURN))
LL←((GETRELTD DL DIM)←(create ROWPTR
NELTS ← A:SHAPE$DIM))
LL:REFCOUNT←1
elseif LL:REFCOUNT GT 1
then (add LL:REFCOUNT -1)
((GETRELTD DL DIM)←LL←(COPYROW LL))
LL:REFCOUNT←1)
(RETURN LL))])
(GETCODELAB
[DLAMBDA ((A ARRAY (SATISFIES (GETVALDIM A)))
(LEV INTEGER (SATISFIES (LEVELP A (GETVALDIM A)
LEV)))
(CODE ARITH)
(RETURNS LABEL))
(* rmk: " 7-JUL-77 11:56" posted: " 2-JUN-77 18:07")
(* Gets code label for given array, level, and code.)
(perform CODEBOOK.FINDLAB (GETCODES A LEV)
CODE)])
(GETCODENUM
[DLAMBDA ((CODEBOOK (ONEOF NIL CODEBOOK))
(CODELAB LABEL)
(RETURNS SCALAR))
(CLISP:(ARRAYRECORD SPARRAY (FN))) (* rmk: "11-MAY-79 11:29" posted: "30-MAR-78 22:50")
(* Gets code number for given codebook and code label.
Corrects spelling if necessary)
[OR (perform CODEBOOK.FINDCODE CODEBOOK CODELAB)
(DPROG ((CB CODEBOOK (ONEOF NIL CODEBOOK) (USEDIN SPELLINGCORRECTOR))
(SPA (CONSTANT (create SPARRAY)) (* Bound and then smashed so that the function is
compiled)))
(SPA:FN←(FUNCTION [LAMBDA (ARRAY)
(pop CB):CODELAB]))
(if CODELAB←(FIXSPELL CODELAB 70 SPA)
then (RETURN (perform CODEBOOK.FINDCODE CODEBOOK CODELAB))))]])
(GETCODES
[DLAMBDA ((A ARRAY (SATISFIES (GETVALDIM A)))
(LEV INTEGER (SATISFIES (LEVELP A (GETVALDIM A)
LEV)))
(RETURNS (ONEOF NIL CODEBOOK)))
(* rmk: " 6-JUN-77 17:12")
(if (type? SELARRAY A)
then LEV←(TTGETELT A:TTAB$((A←A:BASEARRAY):LABELBLOCK:VALDIM)
LEV))
(DPROG ((TEMP A:LABELBLOCK:DIMLABELBLOCK))
(DECL (A SIMARRAY))
(RETURN (AND TEMP TEMP←(GETRELTD TEMP A:LABELBLOCK:VALDIM)
(GETRELTD TEMP LEV))))])
(GETDIMLAB
[DLAMBDA ((A ARRAY)
(DIM INTEGER (SATISFIES (DIMENSIONP A DIM)))
(RETURNS LABEL))
(* bas: "30-AUG-78 22:53")
(* gets dimension label from A)
(if (type? SELARRAY A)
then (DPROG ((BDIM (BASEDIM A DIM) INTEGER)
THEN (TT (GETRELT (fetch TTAB of A)
BDIM) TTELT))
(if (SHOWSBASELABELS TT)
then (SETQ A (fetch BASEARRAY of A))
(SETQ DIM BDIM)
else (SETQ DIM (TTABDIM (PROG1 A (SETQ A TT))
DIM)))) (* This is tricky as DIM and A must be rebound in the
right order to prevent the declarations from
complaining))
(DPROG ((DL (fetch DIMLABELBLOCK of (fetch LABELBLOCK of A)) (ONEOF NIL ROWPTR)))
(RETURN (AND DL (GETRELT DL DIM))))])
(GETDIMNUM
[DLAMBDA ((A ARRAY (USEDIN SPELLINGCORRECTION))
(DIMLAB LABEL)
(RETURNS [ONEOF NIL (INTEGER (SATISFIES (DIMENSIONP A VALUE]))
(* DECLARATIONS: (ARRAYRECORD SPARRAY
(FN)))
(* jop: "27-Nov-85 17:31" posted: "30-MAR-78 22:52")
(* gets dimension number for a given label both for
sim and selarrays, correcting spelling if necessary)
(DPROG ((NDIMS (fetch NDIMS of A) INTEGER (USEDIN SPELLINGCORRECTION))
(SPA (CONSTANT (create SPARRAY)) (* FN done later so it gets compiled)))
(RETURN
(SELECTQ
(fetch (ARRAYFRAME TYPE) of A)
[SELECTION (for DIM to NDIMS declare (SPECVARS DIM)
when (EQ DIMLAB (GETDIMLAB A DIM)) do (RETURN DIM)
finally (SETQ DIM 0)
[replace FN of SPA
with (FUNCTION (LAMBDA (ARRAY)
(PROG NIL
(* LP so don't return NIL's)
LP (RETURN (if (GEQ NDIMS
(add DIM 1))
then (OR (GETDIMLAB
A DIM)
(GO LP]
(AND (SETQ DIMLAB (FIXSPELL DIMLAB 70 SPA))
(RETURN (GETDIMNUM A DIMLAB]
[SIMPLE (DPROG ((DL (fetch DIMLABELBLOCK of (fetch LABELBLOCK of A)) (ONEOF
NIL
ROWPTR) (
USEDIN SPELLINGCORRECTION) ))
(DECL (A SIMARRAY))
[RETURN
(AND DL (for DIM to NDIMS declare (SPECVARS DIM)
when (EQ DIMLAB (GETRELT DL DIM)) do (RETURN
DIM)
finally
(SETQ DIM 0)
[replace FN of SPA
with (FUNCTION (LAMBDA (ARRAY)
(PROG NIL
(* LP so don't return NIL's)
LP (RETURN (if (GEQ NDIMS
(add DIM 1))
then
(OR (GETRELT
DL DIM)
(GO LP]
(AND (SETQ DIMLAB (FIXSPELL DIMLAB 70 SPA))
(RETURN (GETDIMNUM A DIMLAB])]
(SHOULDNT))))])
(GETELTCODELAB
[DLAMBDA ((A ARRAY)
(ELT AELTPTR)
(CB (ONEOF NIL CODEBOOK))
(RETURNS LABEL))
(* rmk: " 2-JUN-77 21:29" posted: " 6-MAY-77 15:50")
(* does a sassoc when given an array, an aeltptr, and a
codebook; returns nil or a label)
(perform CODEBOOK.FINDLAB CB (GETAELT A ELT))])
(GETLEVLAB
[DLAMBDA ((A ARRAY)
(DIM INTEGER (SATISFIES (DIMENSIONP A DIM)))
(LEV INTEGER (SATISFIES (LEVELP A DIM LEV)))
(RETURNS LABEL))
(* bas: "30-AUG-78 22:56")
(* gets level label both for sim and selarrays)
[if (type? SELARRAY A)
then (DPROG ((BDIM (BASEDIM A DIM) INTEGER)
THEN (TT (GETRELT (fetch TTAB of A)
BDIM) TTELT))
(if (SHOWSBASELABELS TT)
then (SETQ A (fetch BASEARRAY of A))
(SETQ DIM BDIM)
(SETQ LEV (TTGETELT TT LEV))
else (SETQ DIM (TTABDIM (PROG1 A (SETQ A TT))
DIM))))]
(DPROG ((DL (fetch DIMLABELBLOCK of (fetch LABELBLOCK of A)))
LL)
(RETURN (AND DL (SETQ LL (GETRELTD DL DIM))
(GETRELT LL LEV))))])
(GETLEVNUM
[DLAMBDA ((A ARRAY (USEDIN SPELLINGCORRECTION))
(DIM INTEGER (SATISFIES (DIMENSIONP A DIM)) (USEDIN SPELLINGCORRECTION))
(LEVLAB LABEL)
(RETURNS [ONEOF NIL (INTEGER (SATISFIES (LEVELP A DIM VALUE]))
(* DECLARATIONS: (ARRAYRECORD SPARRAY
(FN)))
(* jop: "27-Nov-85 17:32" posted: "30-MAR-78 22:47")
(* gets level number for a given label both for sim
and selarrays, correcting spelling if necessary)
(DPROG ((NLEVS (GETRELT (fetch SHAPE of A)
DIM) INTEGER (USEDIN SPELLINGCORRECTION))
(SPA (CONSTANT (create SPARRAY)) (* FN done later so it gets compiled)))
(RETURN
(SELECTQ
(fetch (ARRAYFRAME TYPE) of A)
[SELECTION (for LEV to NLEVS declare (SPECVARS LEV)
when (EQ LEVLAB (GETLEVLAB A DIM LEV)) do (RETURN LEV)
finally (SETQ LEV 0)
[replace FN of SPA
with (FUNCTION (LAMBDA (ARRAY)
(PROG NIL
(* LP so don't return NIL's)
LP (RETURN (if (GEQ NLEVS
(add LEV 1))
then (OR (GETLEVLAB
A DIM LEV)
(GO LP]
(AND (SETQ LEVLAB (FIXSPELL LEVLAB 70 SPA))
(RETURN (GETLEVNUM A DIM LEVLAB]
[SIMPLE (DPROG ((DL (fetch DIMLABELBLOCK of (fetch LABELBLOCK of A)) (ONEOF
NIL
ROWPTR))
(LL NIL (ONEOF NIL ROWPTR) (USEDIN SPELLINGCORRECTION)))
(DECL (A SIMARRAY))
[RETURN
(AND DL (SETQ LL (GETRELTD DL DIM))
(for LEV to NLEVS declare (SPECVARS LEV)
when (EQ LEVLAB (GETRELT LL LEV)) do (RETURN LEV)
finally (SETQ LEV 0)
[replace FN of SPA
with
(FUNCTION (LAMBDA (ARRAY)
(PROG NIL
(* LP so don't return NIL's)
LP (RETURN (if (GEQ NLEVS
(add LEV 1))
then
(OR (GETRELT
LL LEV)
(GO LP]
(AND (SETQ LEVLAB (FIXSPELL LEVLAB 70 SPA))
(RETURN (GETLEVNUM A DIM LEVLAB])]
(SHOULDNT))))])
(GETTITLE
[DLAMBDA ((A ARRAY)
(TESTFLAG BOOL (* Dont title if not already titled))
(RETURNS (ONEOF NIL TITLE)))
(* jop: "27-Nov-85 17:38" posted: "18-NOV-77 13:41")
(* If TESTFLAG, then returns NIL if no title and the title of the basearray for selections.
Otherwise, returns a possibly concocted title for simarrays, the data value for virtual scalars, and a SELECTION
indication in front of the base title for selarrays)
[OR (fetch TITLEF of (fetch (ARRAYFRAME ID) of A))
(AND (NOT TESTFLAG)
(SETTITLE A (SELECTQ (fetch (ARRAYFRAME TYPE) of A)
(SIMPLE (CONCAT "Array " (SERIALNUMBER A)))
[SELECTION (if (VSCALARP A)
then
(* Convert the value into a string to get passed the
RETURNS TITLE.)
(CONCAT (GETAELT A (VSCALARPTR
A)))
else (GETTITLE.HACK
(GETTITLE.SELECTION A)
(GETTITLE (fetch (SELARRAY
BASEARRAY)
of A]
(SHOULDNT]])
(GETTITLE.HACK
[DLAMBDA ((PRE (ONEOF LITATOM LISTP))
(POST (ONEOF STRINGP LISTP))
(RETURNS LISTP))
(* bas: "25-JUL-79 19:10" posted: " 6-DEC-78 19:12")
(* As the name suggests, this fn is the repository of all sleazy title processing. At the present time the only hack
that resides here is the MOMENTS titling)
(if (AND (LISTP POST):1='MOMENTS (FASSOC 'Moment (LISTP PRE)))
then (if PRE::1
then <(CDR (FASSOC 'Moment PRE))
<(for I in PRE when (LISTP I):1~='Moment collect I)
< " from " POST:2>>>
else <PRE:1::1 POST:2>)
else <PRE < " from " POST>>)])
(GETTITLE.SELECTION
[DLAMBDA ((A SELARRAY)
(RETURNS (ONEOF LITATOM LISTP)))
(* bas: " 6-DEC-78 20:00" posted: " 2-DEC-77 11:19")
(* Returns the "function" for a selection title. If all non-ALL selections are integers then it is an alist of the
integer level values else a list of the dimensions on which selection took place)
(DPROG ((AB (A:BASEARRAY) SIMARRAY)
(TT (A:TTAB) ROWPTR)
THEN (SEL (for I LEV to TT:NELTS declare (LEV TTELT)
collect (LEV←TT$I)
(SELECTQ (TTELTTYPE LEV)
(INTEGER < (OR (GETDIMLAB AB I)
(SELECTQ I
(1 'Row)
(2 'Column)
I))
!
(OR (GETLEVLAB AB I LEV)
LEV)
>)
(ARRAY (OR (GETDIMLAB AB I)
(SELECTQ I
(1 'Row)
(2 'Column)
I)))
(GO $$ITERATE))) LST))
(RETURN (if ~SEL
then 'Complete% Selection
elseif TT:NELTS=(LENGTH SEL)
then 'Selection
else SEL)))])
(GETVALDIM
[DLAMBDA ((A ARRAY)
(RETURNS [ONEOF NIL (INTEGER (SATISFIES (DIMENSIONP A VALUE]))
(* bas: "27-AUG-78 14:55")
[if (type? SIMARRAY A)
then (fetch VALDIM of (fetch LABELBLOCK of A))
else (DPROG ((BASEVALDIM (fetch VALDIM of (fetch LABELBLOCK of (fetch BASEARRAY of A))) (ONEOF
NIL
INTEGER))
(TTAB (fetch TTAB of A) ROWPTR))
[RETURN (AND BASEVALDIM (SHOWSBASELABELS (GETRELT TTAB BASEVALDIM))
(for I to BASEVALDIM sum (TTELTDIMS (GETRELT TTAB I])]])
(IGNOR.SCF
[DLAMBDA ((A ANY)
(RETURNS ANY))
(* bas: "28-JUN-78 16:28" posted: "28-JUN-78 12:28")
(* Used in TRAVERSE.TITLE. If A has a string car of
form, the real argument is the CADR of that form)
(if (STRINGP (LISTP A):1)
then A:2
else A)])
(LAB.COPYALL
[DLAMBDA ((AOLD ARRAY)
(ANEW SIMARRAY (SATISFIES (EQUALROW AOLD:SHAPE ANEW:SHAPE))))
(* bas: " 5-DEC-78 12:26" posted: "29-NOV-77 18:41")
(* Copies (perhaps by bumping refcounts) all labels and codes from one array to a second array which has to have the
same shape. Will not destroy old labels if there are none to be added.)
(* Ron has speculated for over a year that ANEW is always simple. The declaration was changed to enforce that on
5-DEC-78. If no assertion faults occurr, the code should be changed also -- bas)
(if ~LABPROPFLAG
elseif (AND (type? SIMARRAY AOLD)
AOLD:LABELBLOCK=NIL)
elseif (AND (type? SIMARRAY AOLD)
(type? SIMARRAY ANEW))
then (DPROG ((DL (fetch DIMLABELBLOCK of (ANEW:LABELBLOCK←(create LABELBLOCK using
AOLD:LABELBLOCK))) (
ONEOF NIL ROWPTR) ))
(if DL
then (BUMPREFCNT DL)))
else [for DIM (SHAPE ← ANEW:SHAPE) to ANEW:NDIMS
do (SETDIMLAB ANEW DIM (GETDIMLAB AOLD DIM))
(for LEV to SHAPE$DIM do (SETLEVLAB ANEW DIM LEV (GETLEVLAB AOLD DIM LEV]
(DPROG ((VD (GETVALDIM AOLD) (ONEOF NIL INTEGER)))
[if VD
then (SETVALDIM ANEW VD)
(for LEV from 1 to AOLD:SHAPE$VD do (SETCODES ANEW LEV (GETCODES AOLD LEV])
(SETTITLE ANEW (GETTITLE AOLD T)))])
(LAB.COPYDIM
[DLAMBDA ((AOLD ARRAY)
(ANEW ARRAY)
(OLDDIM INTEGER (SATISFIES (DIMENSIONP AOLD OLDDIM)))
(NEWDIM INTEGER (SATISFIES (DIMENSIONP ANEW NEWDIM)
(AOLD:SHAPE$OLDDIM LEQ ANEW:SHAPE$NEWDIM)))
(CODEFLAG BOOL))
(* bas: "24-MAR-78 21:54")
(if ~LABPROPFLAG
elseif (AND (type? SIMARRAY AOLD)
(type? SIMARRAY ANEW)
AOLD:SHAPE$OLDDIM=ANEW:SHAPE$NEWDIM)
then (DPROG (NDL
(NEWLEVS NIL (ONEOF NIL ROWPTR))
(ODL AOLD:LABELBLOCK:DIMLABELBLOCK (ONEOF NIL ROWPTR))
(OLDDIMLAB NIL LABEL)
(OLDLEVS NIL (ONEOF NIL ROWPTR)))
(if ODL
then (OLDDIMLAB←ODL$OLDDIM)
(OLDLEVS←(GETRELTD ODL OLDDIM)))
(if NDL←(COPYDIMBLOCK ANEW (OR OLDDIMLAB OLDLEVS))
then (NDL$NEWDIM←OLDDIMLAB)
(if NEWLEVS←(GETRELTD NDL NEWDIM)
then (add NEWLEVS:REFCOUNT -1))
((GETRELTD NDL NEWDIM)←OLDLEVS)
(if OLDLEVS
then (BUMPREFCNT OLDLEVS))))
(AND CODEFLAG (COPYCODEBOOKS AOLD ANEW OLDDIM NEWDIM))
else (SETDIMLAB ANEW NEWDIM (GETDIMLAB AOLD OLDDIM))
(for LEV to AOLD:SHAPE$OLDDIM do (SETLEVLAB ANEW NEWDIM LEV (GETLEVLAB AOLD OLDDIM LEV)))
(AND CODEFLAG (COPYCODEBOOKS AOLD ANEW OLDDIM NEWDIM)))])
(LAB.COPYDIMS
[DLAMBDA ((AOLD ARRAY)
(ANEW SIMARRAY (SATISFIES (EQUALROW AOLD:SHAPE ANEW:SHAPE))))
(* bas: "24-MAR-78 21:52" posted: "29-NOV-77 18:41")
(* Copies (perhaps by bumping refcounts) all dimension and level labels from one array to a second array which has
to have the same shape. Will not destroy old labels if there are none to be added.)
(* Question: Is ANEW always simple? --rmk)
[if ~LABPROPFLAG
elseif (type? SIMARRAY AOLD)
then (DPROG ((VD NIL (ONEOF NIL INTEGER))
(ODL AOLD:LABELBLOCK:DIMLABELBLOCK (ONEOF NIL ROWPTR)))
(if ODL
then (BUMPREFCNT ODL)
[ANEW:LABELBLOCK←(create LABELBLOCK
DIMLABELBLOCK ← ODL
VALDIM ←(VD←(GETVALDIM AOLD]
(if VD
then (SETVALDIM ANEW NIL))) (* Only need to mention VALDIM to eliminate codes.)
)
else (for DIM (SHAPE ← ANEW:SHAPE) to ANEW:NDIMS
do (SETDIMLAB ANEW DIM (GETDIMLAB AOLD DIM))
(for LEV to SHAPE$DIM do (SETLEVLAB ANEW DIM LEV (GETLEVLAB AOLD DIM LEV]])
(LABELLEVEL
[DLAMBDA ((A ARRAY)
(RETURNS INTEGER (SATISFIES (BETWEEN VALUE 1 4))))
(* jop: " 7-Oct-85 23:23" posted: "11-OCT-77 00:25")
(* Returns the degree of labelling of the array A)
(OR (AND (GETVALDIM A)
4)
(for I L (SHAPE ←(fetch SHAPE of A)) to (fetch NDIMS of A) declare (SHAPE ROWINT)
do (AND (NOT L)
(GETDIMLAB A I)
(SETQ L 2))
(AND (for J from 1 to (GETRELT SHAPE I) thereis (GETLEVLAB A I J))
(RETURN 3))
finally (RETURN L))
1)])
(LABELP
[DLAMBDA ((A ARRAY)
(N (MEMQ NIL 2 3 4))
(RETURNS BOOL))
(* rmk: " 2-DEC-77 11:09" posted: "25-MAY-77 11:42")
(AND (SELECTQ N
(NIL (if (type? SIMARRAY A)
then A:LABELBLOCK
else (LABELLEVEL A)
~=1))
(2 (for I to A:NDIMS thereis (GETDIMLAB A I)))
[3 (for I (SHAPE ← A:SHAPE) to A:NDIMS thereis (for J to SHAPE$I
thereis (GETLEVLAB A I J]
(4 (GETVALDIM A))
NIL)
T)])
(MAKETITLE
[DLAMBDA NARGS
(* bas: "15-FEB-83 15:26")
(* MAKETITLE is the universal title constructor. It substitutes the UERRORNAME for a NIL first arg, removes other
NILs to allow easy format for caller for missing arguments, and then calls SUBSTARRAY to substitute for any arrays
that it might have been given.)
(DECLARE (USEDFREE UERRORNAME))
(CONS (OR (ARG NARGS 1)
UERRORNAME)
(MAKETITLE.SUBSTARRAY (for I X from 2 to NARGS when (SETQ X (ARG NARGS I)) collect X)))])
(MAKETITLE.SUBSTARRAY
[DLAMBDA ((L LST)
(RETURNS LST))
(* rmk: " 5-JUN-78 21:20" posted: "29-MAR-78 18:24")
(* SUBSTitutes for any ARRAYs found in L)
(* We substitute the title for now and the ID later. The input can be smashed because it is all pure structure if it
has embedded arrays)
(for I J on L
do (J←I:1)
(if (type? ARRAY J)
then (FRPLACA I J:TITLE)
elseif (LISTP J)
then (MAKETITLE.SUBSTARRAY J)))
L])
(MAKEUSERTITLE
[DLAMBDA ((A ARRAY)
(RETURNS USERTITLE))
(* bas: " 6-DEC-78 19:27" posted: " 4-DEC-77 19:46")
(* Turns the internal title into a string)
(DPROG ((ACTION [FUNCTION (LAMBDA NARGS
(for I to NARGS do (push RSLT (ARG NARGS I] FUNCTION (USEDIN TRAVERSE.TITLE))
(RSLT NIL LISTP (USEDIN ACTION)))
(TRAVERSE.TITLE (GETTITLE A))
(RETURN (APPLY (FUNCTION CONCAT)
(DREVERSE RSLT))))])
(PLURAL
[DLAMBDA ((W (ONEOF LITATOM STRINGP))
(LCFLG BOOL)
(RETURNS STRINGP))
(* rmk: "22-FEB-82 17:17" posted: " 2-DEC-78 18:58")
(* Computes the plural inflection for W)
(DPROG ((CC (NTHCHARCODE W -1) INTEGER))
(RETURN (if (OR CC=(CHARCODE S)
CC=(CHARCODE s))
then ""
elseif (AND ~LCFLG (BETWEEN CC (CHARCODE A)
(CHARCODE Z)))
then "S"
else "s")))])
(SETCODELAB
[DLAMBDA ((A ARRAY (SATISFIES (GETVALDIM A)))
(LEV INTEGER (SATISFIES (LEVELP A (GETVALDIM A)
LEV)))
(CODE ARITH)
(CODELAB LABEL))
(* rmk: "11-JAN-79 12:05")
(* Sets code label for given array, dim , level, and
code value; dim and level may be either labels or
integers)
(if (type? SELARRAY A)
then LEV←(TTGETELT A:TTAB$((A←A:BASEARRAY):LABELBLOCK:VALDIM)
LEV))
(DPROG ((CB NIL (ONEOF NIL CODEBOOK))
(DUP NIL)
(LL (COPYLEVBLOCK A A:LABELBLOCK:VALDIM CODELAB) (ONEOF NIL ROWPTR))
(CVAL NIL ARITH))
(if LL
then (CVAL←(if A:AELTTYPE='FLOATING
then (FLOAT CODE)
else (FIXR CODE)))
(CB←(GETRELTD LL LEV))
(if DUP←(SASSOC CVAL CB)
then (for P on CB until P:1=DUP collect (create CODEPAIR using P:1)
finally ((GETRELTD LL LEV)←
<!! $$VAL
!!(if CODELAB
then <(create CODEPAIR
CODE ← CVAL
CODELAB ← CODELAB)
>)
! P::1>))
elseif CODELAB
then ((GETRELTD LL LEV)← <(create CODEPAIR
CODE ← CVAL
CODELAB ← CODELAB)
! CB>))))])
(SETCODES
[DLAMBDA ((A ARRAY (SATISFIES (GETVALDIM A)))
(LEV INTEGER (SATISFIES (LEVELP A (GETVALDIM A)
LEV)))
(CODEBOOK (ONEOF NIL CODEBOOK)))
(* rmk: " 6-JUL-77 23:58")
(* Sets codebook for array, creating, copying, or sharing structure as needed. We should probably force the codes in
CODEBOOK to have the same type as A, but that might only be appropriate to the user entry.)
(if (type? SELARRAY A)
then LEV←(TTGETELT A:TTAB$((A←A:BASEARRAY):LABELBLOCK:VALDIM)
LEV))
(DPROG ((LL (COPYLEVBLOCK A A:LABELBLOCK:VALDIM CODEBOOK) (ONEOF NIL ROWPTR)))
(AND LL (GETRELTD LL LEV)←CODEBOOK))])
(SETDIMLAB
[DLAMBDA ((A ARRAY)
(DIM INTEGER (SATISFIES (DIMENSIONP A DIM)))
(LAB LABEL))
(* bas: "30-AUG-78 22:59")
(* Sets dimension label both for sim and selarrays. Copies DIMLABELBLOCK if necessary, but assumes that the
LABELBLOCK can be smashed, since those are never shared.)
[if (type? SELARRAY A)
then (DPROG ((BDIM (BASEDIM A DIM) INTEGER)
THEN (TT (A:TTAB$BDIM) TTELT))
(if (SHOWSBASELABELS TT)
then (A←A:BASEARRAY)
(DIM←BDIM)
else DIM←(TTABDIM (PROG1 A A←TT)
DIM)))]
(DPROG ((DL (COPYDIMBLOCK A LAB) (ONEOF NIL ROWPTR)))
(if DL
then ((DL$DIM)←LAB)))])
(SETLEVLAB
[DLAMBDA ((A ARRAY)
(DIM INTEGER (SATISFIES (DIMENSIONP A DIM)))
(LEV INTEGER (SATISFIES (LEVELP A DIM LEV)))
(LAB LABEL))
(* bas: "30-AUG-78 23:00")
(* Sets level label both for sim and selarrays.
Copies DIMLABELBLOCK and lev-labelblock if necessary,
but assumes that the LABELBLOCK can be smashed.)
[if (type? SELARRAY A)
then (DPROG ((BDIM (BASEDIM A DIM) INTEGER)
THEN (TT (A:TTAB$BDIM) TTELT))
(if (SHOWSBASELABELS TT)
then (A←A:BASEARRAY)
(DIM←BDIM)
(LEV←(TTGETELT TT LEV))
else DIM←(TTABDIM (PROG1 A A←TT)
DIM)))]
(DPROG ((LL (COPYLEVBLOCK A DIM LAB) (ONEOF NIL ROWPTR)))
(if LL
then (LL$LEV←LAB)))])
(SETTITLE
[DLAMBDA ((A ARRAY)
(TITLE (ONEOF NIL TITLE))
(RETURNS (ONEOF NIL TITLE)))
(* jop: "27-Nov-85 17:39" posted: "19-MAY-77 18:42")
(* Sets the title of an array.)
(OR (fetch (ARRAYFRAME ID) of A)
(SERIALNUMBER A)) (* Set up an ID block if not there)
(replace TITLEF of (fetch (ARRAYFRAME ID) of A) with TITLE)])
(SETVALDIM
[DLAMBDA ((A ARRAY)
(DIM [ONEOF NIL (INTEGER (SATISFIES (DIMENSIONP A DIM]))
(* bas: "30-AUG-78 23:02")
(if (type? SELARRAY A)
then (ASSERT (SHOWSBASELABELS A:TTAB$(BASEDIM A DIM)))
(DIM←(BASEDIM (PROG1 A A←A:BASEARRAY)
DIM)))
(DPROG ((VD (A:LABELBLOCK:VALDIM) (ONEOF NIL INTEGER)))
(if (AND VD DIM~=VD)
then (for I to A:SHAPE$VD do (SETCODES A I NIL))))
(replace VALDIM of (OR A:LABELBLOCK A:LABELBLOCK←(create LABELBLOCK)) with DIM)])
(SHOWSBASELABELS
[DLAMBDA ((TTELT (ONEOF SIMARRAY INTEGER (MEMQ ALL)))
(RETURNS BOOL))
(* rmk: " 2-JUN-77 17:58" posted: " 2-JUN-77 18:17")
(* True if TTELT in a translation table would permit
the corresponding base labels to shine through)
(OR TTELT='ALL (AND (type? VECTOR TTELT)
TTELT:LABELBLOCK:DIMLABELBLOCK=NIL))])
(TRAVERSE.TITLE
[DLAMBDA ((TTL ANY (* Both titles and fragments thereof))
(NOCAR BOOL (* CAR is to be gapped out))
(NOCDR BOOL (* CDR is to be gapped out))
(FIRST BOOL (* 1st arg in higher title?))
(LAST BOOL (* Last arg in higher title?)))
(* bas: "25-JUL-79 19:00" posted: " 4-DEC-77 22:11")
(* Walks over the title building or printing a string)
(DECLARE (USEDFREE ACTION))
[if (AND NOCAR NOCDR (NOT FIRST))
then (APPLY* ACTION " itself")
elseif (NLISTP TTL)
then (APPLY* ACTION TTL)
elseif (EQ (CAR TTL)
(QUOTE LIST))
then (for I on (CDR TTL)
do (TRAVERSE.TITLE (CAR I))
(AND (CDR I)
(APPLY* ACTION " ")))
elseif (EQ (CAR TTL)
(QUOTE KEEP))
then (TRAVERSE.TITLE (CADR TTL))
(for I on (CDDR TTL) do (APPLY* ACTION (if (EQ I (CDDR TTL))
then " keeping "
elseif (CDR I)
then ", "
else " and ")
(CAR I)))
else [if (OR FIRST (NOT NOCAR))
then (if (NLISTP (CAR TTL))
then (APPLY* ACTION (L-CASE (CAR TTL)
T))
(AND NOCAR FIRST (NOT NOCDR)
(APPLY* ACTION (PLURAL (CAR TTL)
T)))
else (for I J on (CAR TTL)
do (SETQ J (CAR I))
(APPLY* ACTION (if (EQ I (CAR TTL))
then (if (for K in I thereis (NLISTP K))
then "Selected "
else "")
elseif (CDR I)
then ", "
else " and "))
(if (LISTP J)
then (if (LITATOM (CAR J))
then (APPLY* ACTION (CAR J)
" "
(CDR J))
else (APPLY* ACTION "Level " (CDR J)
" on Dimension "
(CAR J)))
elseif (FIXP J)
then (APPLY* ACTION "levels on Dimension " J)
else (APPLY* ACTION J (PLURAL J]
(if (OR (NOT NOCDR)
(if NOCAR
then FIRST
else LAST))
then (* Set the gapping flags for the tail)
(for ELT (SAME ← T) in (CDDR TTL) when (NEQ ELT (CADR TTL))
do (if (if SAME
then (SETQ SAME NIL)
(SETQ NOCAR (NEQ (CAR ELT)
(QUOTE KEEP)))
(SETQ NOCDR T)
(AND (LISTP (CADR TTL))
(LISTP ELT))
else (LISTP ELT))
then [SETQ NOCAR (AND NOCAR (EQ (CAR ELT)
(CAADR TTL]
[SETQ NOCDR (AND NOCDR (EQUAL (CDR ELT)
(CDADR TTL]
else (SETQ NOCAR (SETQ NOCDR NIL)))
(OR NOCAR NOCDR (RETURN))
finally (if SAME
then [SETQ NOCAR (SETQ NOCDR (NOT (NULL (CDDR TTL]
(* Suppress only if there were multiple args)
elseif NOCAR
then (SETQ NOCDR NIL) (* If the forms are EQUAL but not EQ then suppress only
CDRs)))
(for I on (CDR TTL)
do [APPLY* ACTION (SUBSTRING (OR [STRINGP (CAR (LISTP (CAR I]
(if (EQ I (CDR TTL))
then " of "
elseif (CDR I)
then ", "
else " and "))
1
(AND NOCAR (NEQ I (CDR TTL))
-2)
(CONSTANT (CONCAT]
(* Punctuation; eliminate trailing space if we are to
suppress the function name as its trailing space will
do)
(TRAVERSE.TITLE (IGNOR.SCF (CAR I))
NOCAR NOCDR (EQ I (CDR TTL))
(NULL (CDR I]])
)
(RPAQQ LABPROPFLAG T)
(DECLARE: DOCOPY
(DECLARE: EVAL@LOADWHEN TESTSYS
[DECLARE: EVAL@COMPILE
(RECORD CODEBOOK NIL [TYPE? (LISTP (CAR (LISTP DATUM]
[PERFORMOPS [FINDCODE (CB LAB)
(fetch CODE
of (for X in CB
thereis (EQ (fetch CODELAB
of X)
LAB]
[FINDLAB (CB CDE)
(for CP (C ← CDE) in CB first
(if (NULL C)
then (RETURN))
when (EQP C (fetch CODE of CP))
do (RETURN (fetch CODELAB of CP]
(LENGTH (CB)
(LENGTH CB))
(INDEX (CB CDE)
(for I (C ← CDE) from 1 as X in CB
first (if (NULL C)
then (RETURN))
when (EQP C (fetch CODE of X))
do (RETURN I)))
(LABFROMINDEX (CB INDEX)
(fetch CODELAB of (CAR (NTH CB INDEX])
(RECORD CODEPAIR (CODE . CODELAB)
(TYPE? LISTP))
(RECORD LABELBLOCK (VALDIM . DIMLABELBLOCK)
(TYPE? LISTP))
]
)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA MAKETITLE)
)
(PUTPROPS LABELS COPYRIGHT ("Xerox Corporation" 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1013 37147 (COPYCODEBOOKS 1023 . 1854) (COPYDIMBLOCK 1856 . 3035) (COPYLEVBLOCK 3037 .
4179) (GETCODELAB 4181 . 4692) (GETCODENUM 4694 . 5607) (GETCODES 5609 . 6205) (GETDIMLAB 6207 . 7234)
(GETDIMNUM 7236 . 9777) (GETELTCODELAB 9779 . 10261) (GETLEVLAB 10263 . 11291) (GETLEVNUM 11293 .
14061) (GETTITLE 14063 . 15363) (GETTITLE.HACK 15365 . 16132) (GETTITLE.SELECTION 16134 . 17319) (
GETVALDIM 17321 . 18045) (IGNOR.SCF 18047 . 18486) (LAB.COPYALL 18488 . 20078) (LAB.COPYDIM 20080 .
21625) (LAB.COPYDIMS 21627 . 22928) (LABELLEVEL 22930 . 23674) (LABELP 23676 . 24279) (MAKETITLE 24281
. 24926) (MAKETITLE.SUBSTARRAY 24928 . 25591) (MAKEUSERTITLE 25593 . 26216) (PLURAL 26218 . 26838) (
SETCODELAB 26840 . 28324) (SETCODES 28326 . 29106) (SETDIMLAB 29108 . 29926) (SETLEVLAB 29928 . 30901)
(SETTITLE 30903 . 31463) (SETVALDIM 31465 . 32111) (SHOWSBASELABELS 32113 . 32617) (TRAVERSE.TITLE
32619 . 37145)))))
STOP