(FILECREATED "30-Dec-85 16:20:36" {ERIS}<LISPCORE>LIBRARY>CMLARRAYINSPECTOR.;6 38499
changes to: (RECORDS ICML.ARRAYSLICE)
(VARS CMLARRAYINSPECTORCOMS)
previous date: "30-Dec-85 16:20:00" {ERIS}<LISPCORE>LIBRARY>CMLARRAYINSPECTOR.;5)
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLARRAYINSPECTORCOMS)
(RPAQQ CMLARRAYINSPECTORCOMS [(FNS CREATEARRAYSLICE ICMLARRAY ICMLARRAY.ATTACHDISPLAY
ICMLARRAY.DETACHDISPLAY ICMLARRAY.DOWINDOWCOMFN
ICMLARRAY.INDICES ICMLARRAY.LAYOUTMENULIST
ICMLARRAY.LAYOUTSTATUSLIST ICMLARRAY.MEASUREMENULIST
ICMLARRAY.MEASURESTATUSLIST ICMLARRAY.SETVALUE
ICMLARRAY.STATUSW.BUTTONEVENTFN ICMLARRAY.STATUSW.REPAINTFN
ICMLARRAY.TITLECOMMANDFN ICMLARRAY.VALUECOMMANDFN
ICMLARRAY.DISPLAYSLICE ICMLARRAY.GETREGIONFN
ICMLARRAY.GETSTATUSWINDOWGROUP ICMLARRAY.MENUW.APPLY
ICMLARRAY.MENUW.GETLEVEL ICMLARRAY.MENUW.SHOW SLICEDIMENSION
SLICERANK SLICEREF SLICESET ZEROD.FETCHFN ZEROD.STOREFN)
(ADDVARS (INSPECTMACROS (ARRAY . ICMLARRAY)))
(INITRECORDS ICML.ARRAYSLICE)
(FILES TWODINSPECTOR)
(P (LOAD? (QUOTE FREEMENU.DCOM)))
(DECLARE: EVAL@COMPILE DONTCOPY (RECORDS ICML.ARRAYSLICE))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA SLICESET SLICEREF
ICMLARRAY.VALUECOMMANDFN])
(DEFINEQ
(CREATEARRAYSLICE
[LAMBDA (CMLARRAY LEVELS) (* jop: "20-Nov-85 20:18")
(* * An ARRAYSLICE is a zero, one or two dimensional slice of a CMLARRAY. LEVELS is a list of length
(ARRAY-RANK CMLARRAY) which descibes the slice. The atom ALL indications that that dimension is unrestricted)
(PROG ((RANK (ARRAY-RANK CMLARRAY))
(DIMS (ARRAY-DIMENSIONS CMLARRAY))
(OFFSETCONSTANT 0)
SCANDIMS SELECTIONDIMS OFFSETS)
(SETQ SCANDIMS (bind (PROD ← 1)
RESULT for DIM in (REVERSE DIMS)
do (push RESULT PROD)
(SETQ PROD (ITIMES PROD DIM))
finally (RETURN RESULT)))
[for LEVEL in LEVELS as DIM in DIMS as SCANDIM in SCANDIMS
do (if (EQ LEVEL (QUOTE ALL))
then (push SELECTIONDIMS DIM)
(push OFFSETS SCANDIM)
else (SETQ OFFSETCONSTANT (IPLUS OFFSETCONSTANT (ITIMES LEVEL SCANDIM]
(RETURN (create ICML.ARRAYSLICE
SELECTEDDIMS ←(DREVERSE SELECTIONDIMS)
OFFSETS ←(DREVERSE OFFSETS)
OFFSETCONSTANT ← OFFSETCONSTANT
LINEARIZEDARRAY ←(MAKE-ARRAY (ARRAY-TOTAL-SIZE CMLARRAY)
(QUOTE :ELEMENT-TYPE)
(ARRAY-ELEMENT-TYPE CMLARRAY)
(QUOTE :DISPLACED-TO)
CMLARRAY])
(ICMLARRAY
[LAMBDA (CMLARRAY ASTYPE WHERE) (* jop: " 6-Oct-85 16:10")
(* * Top level entry point into the CMLARRAY inspector)
(PROG ((DIMS (ARRAY-DIMENSIONS CMLARRAY))
(RANK (ARRAY-RANK CMLARRAY))
[FONT (OR INSPECTORFONT (DEFAULTFONT (QUOTE DISPLAY]
DISPLAY DISPLAYEDLEVELS DISPLAYSLICE? STATUSGROUP TOPLEFT)
[if (OR (IEQP RANK 0)
(for DIM in DIMS always (IGREATERP DIM 0)))
then (SETQ DISPLAYSLICE? T)
(SETQ DISPLAYEDLEVELS (bind (LESS1RANK ←(SUB1 RANK)) for I
from 0 to (SUB1 RANK)
collect (if (ILESSP (IDIFFERENCE LESS1RANK
I)
2)
then (QUOTE ALL)
else 0]
[if DISPLAYSLICE?
then (SETQ DISPLAY (ICMLARRAY.DISPLAYSLICE CMLARRAY DISPLAYEDLEVELS WHERE))
(SETQ TOPLEFT (create POSITION
XCOORD ←(ADD1 (fetch RIGHT of (WINDOWREGION
DISPLAY)))
YCOORD ←(fetch TOP of (WINDOWREGION DISPLAY]
(SETQ STATUSGROUP (ICMLARRAY.GETSTATUSWINDOWGROUP CMLARRAY FONT DISPLAYEDLEVELS
TOPLEFT))
(if DISPLAYSLICE?
then (ICMLARRAY.ATTACHDISPLAY DISPLAY STATUSGROUP DISPLAYEDLEVELS))
(RETURN STATUSGROUP])
(ICMLARRAY.ATTACHDISPLAY
[LAMBDA (DISPLAYGROUP STATUSGROUP DISPLAYEDLEVELS) (* jop: "24-Nov-85 15:45")
(ATTACHWINDOW DISPLAYGROUP STATUSGROUP (QUOTE LEFT)
(QUOTE TOP))
(for W in (CONS DISPLAYGROUP (ALLATTACHEDWINDOWS DISPLAYGROUP))
do (WINDOWPROP W (QUOTE DOWINDOWCOMFN)
(FUNCTION ICMLARRAY.DOWINDOWCOMFN)))
(WINDOWPROP STATUSGROUP (QUOTE DISPLAYGROUP)
DISPLAYGROUP)
(WINDOWPROP STATUSGROUP (QUOTE CURRENTLEVELS)
DISPLAYEDLEVELS])
(ICMLARRAY.DETACHDISPLAY
[LAMBDA (STATUSGROUP) (* jop: " 4-Oct-85 17:53")
(* *)
(PROG [(DISPLAYGROUP (WINDOWPROP STATUSGROUP (QUOTE DISPLAYGROUP]
(DETACHWINDOW DISPLAYGROUP)
(CLOSEW DISPLAYGROUP])
(ICMLARRAY.DOWINDOWCOMFN
[LAMBDA (WINDOW) (* jop: "24-Nov-85 15:45")
(* * Pass on the usual comms, except for SHAPEW)
(PROG ((PASSTOMAINCOMS (WINDOWPROP WINDOW (QUOTE PASSTOMAINCOMS)))
(COM (MENU WindowMenu)))
(if COM
then (LET* [(CENTRAL (CENTRALWINDOW WINDOW))
(DISPLAYGROUP (WINDOWPROP CENTRAL (QUOTE DISPLAYGROUP]
(if (EQ COM (QUOTE SHAPEW))
then [SHAPEW DISPLAYGROUP (GETREGION NIL NIL NIL
(FUNCTION
ICMLARRAY.GETREGIONFN)
(CONS DISPLAYGROUP
(QUOTE CLOSED]
elseif (MEMB COM PASSTOMAINCOMS)
then (APPLY* COM CENTRAL)
else (APPLY* COM WINDOW])
(ICMLARRAY.INDICES
[LAMBDA (DISPLAYWINDOW ROW COLUMN) (* jop: "10-Oct-85 15:37")
(* * Display the indices of the selected item)
(PROG ((MAINW (MAINWINDOW DISPLAYWINDOW))
CURRENTLEVELS PRTWINDOW CMLARRAY)
(SETQ CURRENTLEVELS (WINDOWPROP MAINW (QUOTE CURRENTLEVELS)))
(SETQ PRTWINDOW (WINDOWPROP MAINW (QUOTE PRTWINDOW)))
(PRINTOUT PRTWINDOW T "Indices: ") (* In the zero-d case ROW and COLUMN are NIL.
In the one-d case COLUMN is NIL)
(bind FIRSTFLG for LEVEL in CURRENTLEVELS
do (if (EQ LEVEL (QUOTE ALL))
then (if FIRSTFLG
then (PRINTOUT PRTWINDOW , COLUMN ,)
else (SETQ FIRSTFLG T)
(PRINTOUT PRTWINDOW , ROW ,))
else (PRINTOUT PRTWINDOW , LEVEL ,])
(ICMLARRAY.LAYOUTMENULIST
[LAMBDA (MENULIST GROUPWIDTH BFONT FONT WHITESPACE FIELDWIDTH)
(* jop: " 4-Oct-85 16:20")
(* * MENULIST is an list of item lists of the form that freemenu expects)
(bind (SPACE ←(STRINGWIDTH WHITESPACE FONT))
[LINEHEIGHT ←(IMAX (FONTPROP BFONT (QUOTE HEIGHT))
(FONTPROP FONT (QUOTE HEIGHT]
BOTTOM GAPINC LABELFIELDWIDTH first (SETQ BOTTOM (ITIMES (SUB1 (LENGTH MENULIST)
)
LINEHEIGHT))
for ROW in MENULIST
join (if (NEQ (CAR ROW)
(QUOTE WINDOWPROPS))
then [SETQ GAPINC (if (EQ (LISTGET (CAR ROW)
(QUOTE ID))
(QUOTE BUTTON))
then (LET [(BUTTONWIDTHS
(for BUTTON in ROW
collect (STRINGWIDTH
(LISTGET BUTTON
(QUOTE LABEL))
(LISTGET BUTTON
(QUOTE FONT]
(IQUOTIENT (IDIFFERENCE GROUPWIDTH
(for WIDTH
in
BUTTONWIDTHS
sum WIDTH))
(IMAX 1 (SUB1 (LENGTH
BUTTONWIDTHS]
[bind (LEFT ← 0) for ITEM in ROW
do (LISTPUT ITEM (QUOTE LEFT)
LEFT)
(LISTPUT ITEM (QUOTE BOTTOM)
BOTTOM)
(SETQ LEFT (IPLUS LEFT [if (LISTGET ITEM (QUOTE DIM))
then FIELDWIDTH
else (STRINGWIDTH
(LISTGET ITEM (QUOTE
LABEL))
(LISTGET ITEM (QUOTE
FONT]
(if (EQ (LISTGET ITEM (QUOTE ID))
(QUOTE BUTTON))
then GAPINC
else SPACE]
(SETQ BOTTOM (IDIFFERENCE BOTTOM
(ITIMES (if (EQ (LISTGET (CAR ROW)
(QUOTE
ID))
(QUOTE BUTTON))
then 2
else 1)
LINEHEIGHT)))
ROW
else (LIST ROW])
(ICMLARRAY.LAYOUTSTATUSLIST
[LAMBDA (STATUSLIST GROUPWIDTH BFONT FONT WHITESPACE) (* jop: " 6-Oct-85 14:14")
(* * STATUSLIST is an list of item lists of the form that freemenu expects)
(bind (SPACE ←(STRINGWIDTH WHITESPACE FONT))
[LINEHEIGHT ←(IMAX (FONTPROP BFONT (QUOTE HEIGHT))
(FONTPROP FONT (QUOTE HEIGHT]
BOTTOM KEYWORDWIDTHS SPACEINC first (SETQ BOTTOM (ITIMES (IDIFFERENCE
(LENGTH STATUSLIST)
1)
LINEHEIGHT))
for ROW in STATUSLIST
do [SETQ KEYWORDWIDTHS (bind (TEMPROW ← ROW)
KEYWORD VALUE while TEMPROW
collect (SETQ KEYWORD (CAR TEMPROW))
(SETQ VALUE (CADR TEMPROW))
(SETQ TEMPROW (CDDR TEMPROW))
(IPLUS (STRINGWIDTH (LISTGET KEYWORD
(QUOTE LABEL))
(LISTGET KEYWORD
(QUOTE FONT)))
SPACE
(STRINGWIDTH (LISTGET VALUE (QUOTE
LABEL))
(LISTGET VALUE (QUOTE
FONT]
[SETQ SPACEINC (IQUOTIENT (IDIFFERENCE GROUPWIDTH (for WIDTH in KEYWORDWIDTHS
sum WIDTH))
(IMAX 1 (SUB1 (LENGTH KEYWORDWIDTHS]
(bind (LEFT ← 0)
(TEMPROW ← ROW)
KEYWORD VALUE while TEMPROW
do (SETQ KEYWORD (CAR TEMPROW))
(SETQ VALUE (CADR TEMPROW))
(SETQ TEMPROW (CDDR TEMPROW))
(LISTPUT KEYWORD (QUOTE LEFT)
LEFT)
(LISTPUT KEYWORD (QUOTE BOTTOM)
BOTTOM)
[SETQ LEFT (IPLUS LEFT SPACE (STRINGWIDTH (LISTGET KEYWORD (QUOTE
LABEL))
(LISTGET KEYWORD (QUOTE
FONT]
(LISTPUT VALUE (QUOTE LEFT)
LEFT)
(LISTPUT VALUE (QUOTE BOTTOM)
BOTTOM)
(SETQ LEFT (IPLUS LEFT (STRINGWIDTH (LISTGET VALUE (QUOTE LABEL))
(LISTGET VALUE (QUOTE FONT)))
SPACEINC)))
(SETQ BOTTOM (IDIFFERENCE BOTTOM LINEHEIGHT))
finally (RETURN STATUSLIST])
(ICMLARRAY.MEASUREMENULIST
[LAMBDA (MENULIST MINWHITESPACE FONT FIELDWIDTH) (* jop: " 4-Oct-85 16:17")
(* * MENULIST is an list of item lists of the form that freemenu expects)
(bind (MAX ← 0)
(SPACE ←(STRINGWIDTH MINWHITESPACE FONT))
ROWWIDTH for ROW in MENULIST unless (EQ (CAR ROW)
(QUOTE WINDOWPROPS))
do [SETQ ROWWIDTH (for ITEM in ROW sum (IPLUS SPACE
(if (LISTGET ITEM (QUOTE
DIM))
then FIELDWIDTH
else (STRINGWIDTH
(LISTGET ITEM
(QUOTE
LABEL))
(LISTGET ITEM
(QUOTE
FONT]
(if (ILESSP MAX ROWWIDTH)
then (SETQ MAX ROWWIDTH))
finally (RETURN MAX])
(ICMLARRAY.MEASURESTATUSLIST
[LAMBDA (STATUSLIST MINWHITESPACE FONT) (* jop: " 6-Oct-85 18:51")
(* * STATUSLIST is an list of item lists of the form that freemenu expects)
(bind (MAX ← 0)
(SPACE ←(STRINGWIDTH MINWHITESPACE FONT))
ROWWIDTH for ROW in STATUSLIST
do [SETQ ROWWIDTH (IPLUS (ITIMES (SUB1 (LENGTH ROW))
(STRINGWIDTH MINWHITESPACE FONT))
(for ITEM in ROW sum (STRINGWIDTH (LISTGET
ITEM
(QUOTE LABEL))
(LISTGET
ITEM
(QUOTE FONT]
(if (ILESSP MAX ROWWIDTH)
then (SETQ MAX ROWWIDTH))
finally (RETURN MAX])
(ICMLARRAY.SETVALUE
[LAMBDA (DISPLAYWINDOW ROW COLUMN) (* jop: "10-Oct-85 15:36")
(* * In the zero and one-d cases COLUMN should be NIL, and ROW is the only index)
(PROG ((MAINW (MAINWINDOW DISPLAYWINDOW))
[SLICERANK (SLICERANK (WINDOWPROP DISPLAYWINDOW (QUOTE DATUM]
PRTWINDOW NEWVALUE)
(SETQ PRTWINDOW (WINDOWPROP MAINW (QUOTE PRTWINDOW)))
[RESETFORM (SET.TTYINEDIT.WINDOW PRTWINDOW)
(SETQ NEWVALUE (EVAL (CAR (TTYIN "Newvalue? " NIL NIL (QUOTE
EVALQT)
NIL NIL NIL T]
(if (EQP SLICERANK 2)
then (TWODINSPECT.REPLACE DISPLAYWINDOW ROW COLUMN NEWVALUE)
else (ONEDINSPECT.REPLACE DISPLAYWINDOW ROW NEWVALUE])
(ICMLARRAY.STATUSW.BUTTONEVENTFN
[LAMBDA (WINDOW) (* jop: " 6-Oct-85 22:14")
(* *)
(TOTOPW WINDOW)
(if (MOUSESTATE MIDDLE)
then (PROG ([TITLEMENU (CONSTANT (create MENU
ITEMS ←(QUOTE (("Refetch" (QUOTE REFETCH)
"Refetch the array")
("IT ← Datum"
(QUOTE IT)
"Bind IT to the inspected array"]
MENUW CMLARRAY)
(SETQ MENUW (WINDOWPROP WINDOW (QUOTE MENUWINDOW)))
(SETQ CMLARRAY (WINDOWPROP WINDOW (QUOTE CMLARRAY)))
(SELECTQ (MENU TITLEMENU)
[REFETCH (if (for DIM in (ARRAY-DIMENSIONS CMLARRAY)
always (IGREATERP DIM 0))
then
(if (IGREATERP (ARRAY-RANK CMLARRAY)
1)
then (ICMLARRAY.MENUW.SHOW
(FM.ITEMFROMID MENUW (QUOTE SHOW))
MENUW)
(ICMLARRAY.MENUW.APPLY
(FM.ITEMFROMID MENUW (QUOTE APPLY))
MENUW)
else (LET [(REGION (WINDOWPROP WINDOW
(QUOTE REGION))
)
(LEVELS (WINDOWPROP WINDOW
(QUOTE
CURRENTLEVELS)))
(DISPLAYGROUP (WINDOWPROP
WINDOW
(QUOTE DISPLAYGROUP]
(if DISPLAYGROUP
then (ICMLARRAY.DETACHDISPLAY
WINDOW))
[SETQ DISPLAYGROUP
(ICMLARRAY.DISPLAYSLICE
CMLARRAY LEVELS DISPLAYGROUP
(create POSITION
XCOORD ←(SUB1
(fetch LEFT
of REGION))
YCOORD ←(fetch TOP
of REGION]
(ICMLARRAY.ATTACHDISPLAY DISPLAYGROUP
WINDOW
LEVELS]
(IT (SETQ IT CMLARRAY)
(RESETVAR *PRINT-ARRAY* NIL (PROMPTPRINT "IT bound to "
CMLARRAY)))
NIL])
(ICMLARRAY.STATUSW.REPAINTFN
[LAMBDA (WINDOW) (* jop: " 6-Oct-85 14:17")
(* *)
(DSPRESET WINDOW)
(PROG [(DISPLAYLIST (WINDOWPROP WINDOW (QUOTE DISPLAYLIST]
(for ROW in DISPLAYLIST do (bind FONT for ITEM in ROW
do (SETQ FONT (LISTGET ITEM (QUOTE FONT)))
(DSPFONT FONT WINDOW)
(MOVETO (LISTGET ITEM (QUOTE LEFT))
(IPLUS (LISTGET ITEM (QUOTE
BOTTOM))
(FONTPROP FONT
(QUOTE DESCENT))
)
WINDOW)
(DSPFONT (LISTGET ITEM (QUOTE FONT))
WINDOW)
(PRINTOUT WINDOW (LISTGET ITEM (QUOTE LABEL])
(ICMLARRAY.TITLECOMMANDFN
[LAMBDA (WINDOW) (* jop: " 6-Oct-85 12:21")
(* *)
(if (MOUSESTATE MIDDLE)
then (PROG ([TITLEMENU (CONSTANT (create MENU
ITEMS ←(QUOTE (("Refetch" (QUOTE REFETCH)
"Refetch the array")
("IT ← Datum"
(QUOTE IT)
"Bind IT to the inspected array"]
(MAINW (MAINWINDOW WINDOW))
MENUW CMLARRAY)
(SETQ MENUW (WINDOWPROP MAINW (QUOTE MENUWINDOW)))
(SETQ CMLARRAY (WINDOWPROP MAINW (QUOTE CMLARRAY)))
(SELECTQ (MENU TITLEMENU)
(REFETCH (ICMLARRAY.MENUW.SHOW (FM.ITEMFROMID MENUW
(QUOTE SHOW))
MENUW)
(ICMLARRAY.MENUW.APPLY (FM.ITEMFROMID MENUW
(QUOTE APPLY))
MENUW))
(IT (SETQ IT CMLARRAY)
(RESETVAR *PRINT-ARRAY* NIL (PROMPTPRINT "IT bound to "
CMLARRAY)))
NIL])
(ICMLARRAY.VALUECOMMANDFN
[LAMBDA ARGS (* jop: "10-Oct-85 15:37")
(* *)
(PROG ([INSPECTABLEMENU (CONSTANT (create MENU
ITEMS ←(QUOTE (("Inspect" (QUOTE INSPECT)
"Inspect element")
("Set" (QUOTE SET)
"Set element")
("Indices" (QUOTE INDICES)
"Display indices")
("IT ← Selection" (QUOTE
SETIT)
"Bind IT to element"]
[SETABLEMENU (CONSTANT (create MENU
ITEMS ←(QUOTE (("Set" (QUOTE SET)
"Set element")
("Indices" (QUOTE INDICES)
"Display indices")
("IT ← Selection" (QUOTE SETIT)
"Bind IT to element"]
(VALUE (ARG ARGS 1))
INDEX ROW COLUMN SLICE DISPLAYWINDOW SLICERANK)
(if (EQP ARGS 4)
then (* must be in the one-d case)
(SETQ INDEX (ARG ARGS 2))
(SETQ SLICE (ARG ARGS 3))
(SETQ DISPLAYWINDOW (ARG ARGS 4))
else (* must be in the two-d case)
(SETQ ROW (ARG ARGS 2))
(SETQ COLUMN (ARG ARGS 3))
(SETQ SLICE (ARG ARGS 4))
(SETQ DISPLAYWINDOW (ARG ARGS 5)))
(SETQ SLICERANK (SLICERANK SLICE))
(SELECTQ (if (OR (NUMBERP VALUE)
(NULL VALUE))
then (MENU SETABLEMENU)
else (MENU INSPECTABLEMENU))
(INSPECT (INSPECT VALUE))
(SET (SELECTQ SLICERANK
(0 (ICMLARRAY.SETVALUE DISPLAYWINDOW INDEX))
(1 (ICMLARRAY.SETVALUE DISPLAYWINDOW INDEX))
(2 (ICMLARRAY.SETVALUE DISPLAYWINDOW ROW COLUMN))
(SHOULDNT)))
[SETIT (SETQ IT (SELECTQ SLICERANK
(0 (SLICEREF SLICE))
(1 (SLICEREF SLICE INDEX))
(2 (SLICEREF SLICE ROW COLUMN))
(SHOULDNT)))
(* Nice to have some feedback)
(RESETLST [RESETSAVE (PRINTLEVEL (QUOTE (2 . 5]
(RESETSAVE PLVLFILEFLG T)
(RESETSAVE *PRINT-ARRAY* NIL)
(PROMPTPRINT (CONCAT "IT bound to " VALUE]
(INDICES (SELECTQ SLICERANK
(0 (ICMLARRAY.INDICES DISPLAYWINDOW))
(1 (ICMLARRAY.INDICES DISPLAYWINDOW INDEX))
(2 (ICMLARRAY.INDICES DISPLAYWINDOW ROW COLUMN))
(SHOULDNT)))
NIL])
(ICMLARRAY.DISPLAYSLICE
[LAMBDA (CMLARRAY LEVELS WHERE TOPRIGHT) (* jop: "10-Oct-85 15:45")
(PROG ((SLICE (CREATEARRAYSLICE CMLARRAY LEVELS))
SLICERANK)
(SETQ SLICERANK (SLICERANK SLICE))
(RETURN (if (EQP SLICERANK 2)
then (TWODINSPECTW.CREATE SLICE (for I from 0
to (SUB1 (SLICEDIMENSION
SLICE 0))
collect I)
(for I from 0
to (SUB1 (SLICEDIMENSION SLICE 1))
collect I)
(FUNCTION SLICEREF)
(FUNCTION SLICESET)
(FUNCTION ICMLARRAY.VALUECOMMANDFN)
NIL NIL "Display Window"
(FUNCTION ICMLARRAY.TITLECOMMANDFN)
WHERE TOPRIGHT)
elseif (EQP SLICERANK 1)
then (ONEDINSPECTW.CREATE SLICE (for I from 0
to (SUB1 (SLICEDIMENSION
SLICE 0))
collect I)
(FUNCTION SLICEREF)
(FUNCTION SLICESET)
(FUNCTION ICMLARRAY.VALUECOMMANDFN)
NIL "Display Window" (FUNCTION
ICMLARRAY.TITLECOMMANDFN)
WHERE TOPRIGHT)
else (* Must be a zero d slice)
(ONEDINSPECTW.CREATE SLICE (QUOTE ("Entry"))
(FUNCTION ZEROD.FETCHFN)
(FUNCTION ZEROD.STOREFN)
(FUNCTION ICMLARRAY.VALUECOMMANDFN)
NIL "Display Window" (FUNCTION
ICMLARRAY.TITLECOMMANDFN)
WHERE TOPRIGHT])
(ICMLARRAY.GETREGIONFN
[LAMBDA (FIXEDPOINT MOVINGPOINT INFO) (* jop: " 6-Oct-85 12:48")
(* * Controled reshape of a CMLARRAY inspector display window. For use with GETREGION Assumes that info is CONS
pair (WINDOW . STATE) The initial state is CLOSED. Assumes no init region or minsize)
(PROG ((WINDOW (CAR INFO))
(STATE (CDR INFO))
WINDOWREGION) (* Assumes Window is an attached window)
(SETQ WINDOWREGION (WINDOWREGION WINDOW))
(if (NULL MOVINGPOINT)
then [RETURN (create POSITION
XCOORD ←(ADD1 (fetch RIGHT of WINDOWREGION))
YCOORD ←(ADD1 (fetch TOP of WINDOWREGION]
else (if (EQ STATE (QUOTE CLOSED))
then (RPLACD INFO (QUOTE OPEN))
[RETURN (create POSITION
XCOORD ←(SUB1 (fetch LEFT of WINDOWREGION))
YCOORD ←(SUB1 (fetch BOTTOM of WINDOWREGION]
else (if (IGREATERP (fetch XCOORD of MOVINGPOINT)
(fetch RIGHT of WINDOWREGION))
then (replace XCOORD of MOVINGPOINT
with (fetch RIGHT of WINDOWREGION)))
(if (IGREATERP (fetch YCOORD of MOVINGPOINT)
(fetch TOP of WINDOWREGION))
then (replace YCOORD of MOVINGPOINT
with (fetch TOP of WINDOWREGION)))
(RETURN MOVINGPOINT])
(ICMLARRAY.GETSTATUSWINDOWGROUP
[LAMBDA (CMLARRAY FONTDESCRIPTOR DISPLAYEDLEVELS TOPLEFT)
(* jop: " 6-Oct-85 18:38")
(* * Constructs the three windows of the status group and puts them up on the screen. returns the mainwindow of the
group.)
(PROG ((FONT (LIST (FONTPROP FONTDESCRIPTOR (QUOTE FAMILY))
(FONTPROP FONTDESCRIPTOR (QUOTE SIZE))
(QUOTE MRR)))
(BFONT (LIST (FONTPROP FONTDESCRIPTOR (QUOTE FAMILY))
(FONTPROP FONTDESCRIPTOR (QUOTE SIZE))
(QUOTE BRR)))
(DIMS (ARRAY-DIMENSIONS CMLARRAY))
(RANK (ARRAY-RANK CMLARRAY))
(INITIALLEFT 0)
(INITIALBOTTOM 0)
(MENU? T)
STATUSLIST MENULIST FIELDWIDTH GROUPWIDTH SWINDOW PWINDOW PHEIGHT MWINDOW)
(if (OR (ILESSP RANK 2)
(for DIM in DIMS thereis (EQP DIM 0)))
then (SETQ MENU? NIL))
[SETQ STATUSLIST
(BQUOTE (((LABEL "Element-type:" FONT , FONT LEFT , INITIALLEFT BOTTOM ,
INITIALBOTTOM)
(LABEL , (ARRAY-ELEMENT-TYPE CMLARRAY)
FONT , BFONT LEFT , INITIALLEFT BOTTOM , INITIALBOTTOM))
((LABEL "Rank:" FONT , FONT LEFT , INITIALLEFT BOTTOM , INITIALBOTTOM)
(LABEL , RANK FONT , BFONT LEFT , INITIALLEFT BOTTOM , INITIALBOTTOM))
((LABEL "Dimensions:" FONT , FONT LEFT , INITIALLEFT BOTTOM , INITIALBOTTOM)
(LABEL , (bind (STR ← "") for I from 0 to (SUB1 RANK)
do (SETQ STR (CONCAT STR (ARRAY-DIMENSION CMLARRAY I)))
(if (LESSP I (SUB1 RANK))
then (SETQ STR (CONCAT STR " x ")))
finally (RETURN STR))
FONT , BFONT LEFT , INITIALLEFT BOTTOM , INITIALBOTTOM]
(if MENU?
then (SETQ FIELDWIDTH (IMAX (STRINGWIDTH (QUOTE ALL)
BFONT)
(STRINGWIDTH (for DIM in DIMS
largest (STRINGWIDTH DIM
BFONT))
BFONT)))
[SETQ MENULIST
(BQUOTE (((TYPE MOMENTARY ID BUTTON LABEL "SHOW" FONT , BFONT LEFT ,
INITIALLEFT BOTTOM , INITIALBOTTOM SELECTEDFN
ICMLARRAY.MENUW.SHOW)
(TYPE MOMENTARY ID BUTTON LABEL "APPLY" FONT , BFONT LEFT ,
INITIALLEFT BOTTOM , INITIALBOTTOM SELECTEDFN
ICMLARRAY.MENUW.APPLY))
[(TYPE TITLE ID TITLEDIM LABEL "Dimension:" FONT , FONT LEFT ,
INITIALLEFT BOTTOM , INITIALBOTTOM)
,@(for I from 0 to (SUB1 RANK)
collect (BQUOTE (TYPE TITLE ID , (PACK* (QUOTE
DIM)
I)
LABEL , I FONT , FONT LEFT ,
INITIALLEFT BOTTOM ,
INITIALBOTTOM DIM , I]
[(TYPE TITLE ID TITLELEVEL LABEL "Level: " FONT , FONT LEFT ,
INITIALLEFT BOTTOM , INITIALBOTTOM)
,@(for LEVEL in DISPLAYEDLEVELS as I from 0
collect (BQUOTE (TYPE MOMENTARY ID ,
(PACK* (QUOTE LEVEL)
I)
LABEL , LEVEL FONT , BFONT LEFT ,
INITIALLEFT BOTTOM ,
INITIALBOTTOM DIM , I SELECTEDFN
ICMLARRAY.MENUW.GETLEVEL]
(WINDOWPROPS TITLE "Format menu"]
(SETQ GROUPWIDTH (IMAX (ICMLARRAY.MEASURESTATUSLIST STATUSLIST " " FONT)
(ICMLARRAY.MEASUREMENULIST MENULIST " " FONT
FIELDWIDTH)))
(SETQ STATUSLIST (ICMLARRAY.LAYOUTSTATUSLIST STATUSLIST GROUPWIDTH BFONT
FONT " "))
(SETQ MENULIST (ICMLARRAY.LAYOUTMENULIST MENULIST GROUPWIDTH BFONT FONT
" "
FIELDWIDTH))
else (SETQ GROUPWIDTH (ICMLARRAY.MEASURESTATUSLIST STATUSLIST " " FONT))
(SETQ STATUSLIST (ICMLARRAY.LAYOUTSTATUSLIST STATUSLIST GROUPWIDTH BFONT
FONT " ")))
(* SWINDOW is the status window)
(SETQ SWINDOW (CREATEW (CREATEREGION 0 0 (WIDTHIFWINDOW GROUPWIDTH)
(HEIGHTIFWINDOW
[ITIMES (LENGTH STATUSLIST)
(IMAX (FONTPROP FONT
(QUOTE
HEIGHT))
(FONTPROP BFONT
(QUOTE
HEIGHT]
T))
(RESETVAR *PRINT-ARRAY* NIL (CONCAT "Inspector of "
CMLARRAY))
NIL T)) (* Makes no sense to reshape the statuswindow group)
(WINDOWPROP SWINDOW (QUOTE REPAINTFN)
(FUNCTION ICMLARRAY.STATUSW.REPAINTFN))
(WINDOWPROP SWINDOW (QUOTE RESHAPEFN)
(QUOTE DON'T))
(WINDOWPROP SWINDOW (QUOTE BUTTONEVENTFN)
(QUOTE ICMLARRAY.STATUSW.BUTTONEVENTFN))
[WINDOWPROP SWINDOW (QUOTE MINSIZE)
(CONS GROUPWIDTH (fetch HEIGHT of (WINDOWPROP SWINDOW (QUOTE
REGION]
(DSPFONT FONT SWINDOW) (* STATUSLIST describes what is to be displayed and
where)
(WINDOWPROP SWINDOW (QUOTE DISPLAYLIST)
STATUSLIST) (* Cache the datum)
(WINDOWPROP SWINDOW (QUOTE CMLARRAY)
CMLARRAY) (* DISPLAYEDLEVELS is a description of the array slice
to be displayed)
(WINDOWPROP SWINDOW (QUOTE DISPLAYEDLEVELS)
DISPLAYEDLEVELS) (* PWINDOW is the prompt window)
[SETQ PHEIGHT (HEIGHTIFWINDOW (FONTPROP FONT (QUOTE HEIGHT]
(SETQ PWINDOW (CREATEW (CREATEREGION 0 0 100 PHEIGHT)
NIL NIL T))
(WINDOWPROP PWINDOW (QUOTE MINSIZE)
(CONS 0 PHEIGHT))
(WINDOWPROP PWINDOW (QUOTE MAXSIZE)
(CONS MAX.SMALLP PHEIGHT))
(WINDOWPROP PWINDOW (QUOTE PAGEFULLFN)
(FUNCTION NILL))
(DSPSCROLL (QUOTE ON)
PWINDOW)
(WINDOWPROP SWINDOW (QUOTE PRTWINDOW)
PWINDOW)
(DSPFONT FONT PWINDOW) (* MWINDOW is the menu window)
(if MENU?
then (SETQ MWINDOW (FM.MAKEMENU MENULIST))
[WINDOWPROP MWINDOW (QUOTE MINSIZE)
(CONS GROUPWIDTH (fetch HEIGHT of (WINDOWPROP
MWINDOW
(QUOTE REGION]
(WINDOWPROP SWINDOW (QUOTE MENUWINDOW)
MWINDOW)
(DSPFONT FONT MWINDOW)) (* position and open the windowgroup)
[MOVEW SWINDOW (if TOPLEFT
then [create POSITION
XCOORD ←(fetch XCOORD of TOPLEFT)
YCOORD ←(IDIFFERENCE
(fetch YCOORD of TOPLEFT)
(SUB1 (fetch HEIGHT
of (WINDOWPROP SWINDOW
(QUOTE REGION]
else (GETBOXPOSITION (fetch WIDTH of (WINDOWPROP
SWINDOW
(QUOTE REGION)))
(fetch HEIGHT of (WINDOWPROP
SWINDOW
(QUOTE REGION]
(REDISPLAYW SWINDOW)
(ATTACHWINDOW PWINDOW SWINDOW (QUOTE BOTTOM))
(if MENU?
then (ATTACHWINDOW MWINDOW SWINDOW (QUOTE BOTTOM)))
(RETURN SWINDOW])
(ICMLARRAY.MENUW.APPLY
[LAMBDA (ITEM MENUWINDOW BUTTONS) (* jop: "14-Oct-85 12:58")
(* * Display the slice descibed by the windowprop LEVELS)
(PROG ((MAINW (MAINWINDOW MENUWINDOW))
LEVELS CMLARRAY SLICEDIM DISPLAYGROUP TOPRIGHT)
(SETQ CMLARRAY (WINDOWPROP MAINW (QUOTE CMLARRAY)))
(SETQ DISPLAYGROUP (WINDOWPROP MAINW (QUOTE DISPLAYGROUP)))
[SETQ TOPRIGHT (LET [(REGION (WINDOWPROP MAINW (QUOTE REGION]
(create POSITION
XCOORD ←(SUB1 (fetch LEFT of REGION))
YCOORD ←(fetch TOP of REGION]
[SETQ LEVELS (for I from 0 to (SUB1 (ARRAY-RANK CMLARRAY))
collect (FM.ITEMPROP (FM.ITEMFROMID MENUWINDOW
(PACK* (QUOTE LEVEL)
I))
(QUOTE LABEL]
(if (IGREATERP (for LEVEL in LEVELS count (EQ LEVEL (QUOTE ALL)))
2)
then (PRINTOUT (WINDOWPROP MAINW (QUOTE PRTWINDOW))
T "Rank too high")
else (if DISPLAYGROUP
then (ICMLARRAY.DETACHDISPLAY MAINW))
(SETQ DISPLAYGROUP (ICMLARRAY.DISPLAYSLICE CMLARRAY LEVELS DISPLAYGROUP
TOPRIGHT))
(ICMLARRAY.ATTACHDISPLAY DISPLAYGROUP MAINW LEVELS])
(ICMLARRAY.MENUW.GETLEVEL
[LAMBDA (ITEM MENUWINDOW BUTTONS) (* jop: "10-Oct-85 15:04")
(* * Get a new LEVEL for dim DIM)
(PROG ((MAINW (MAINWINDOW MENUWINDOW))
(DIM (FM.ITEMPROP ITEM (QUOTE DIM)))
(LEVEL (FM.ITEMPROP ITEM (QUOTE LABEL)))
CMLARRAY LEVMENU PRTWINDOW NEWVALUE)
(SETQ CMLARRAY (WINDOWPROP MAINW (QUOTE CMLARRAY)))
(SETQ LEVEL (if (ILESSP (ARRAY-DIMENSION CMLARRAY DIM)
10)
then (SETQ LEVMENU (FM.ITEMPROP ITEM (QUOTE LEVMENU)))
(if (NULL LEVMENU)
then [SETQ LEVMENU
(create MENU
ITEMS ←(CONS
(QUOTE (ALL (QUOTE ALL)
"Unrestricted"))
(for I from 0
to (SUB1 (ARRAY-DIMENSION
CMLARRAY DIM))
collect (LIST I (KWOTE I]
(FM.ITEMPROP ITEM (QUOTE LEVMENU)
LEVMENU))
(OR (MENU LEVMENU)
LEVEL)
else (SETQ PRTWINDOW (WINDOWPROP MAINW (QUOTE PRTWINDOW)))
(PRINTOUT PRTWINDOW T)
(RESETFORM (TTY.PROCESS (THIS.PROCESS))
(SETQ NEWVALUE (PROMPTFORWORD "New level?" LEVEL
(CONCAT
"Type new level for dim "
DIM)
PRTWINDOW)))
(if (STRINGP NEWVALUE)
then (if (STREQUAL (U-CASE NEWVALUE)
"ALL")
then (QUOTE ALL)
else (SETQ NEWVALUE (READ (OPENSTRINGSTREAM
NEWVALUE)))
(if (AND (FIXP NEWVALUE)
(GEQ NEWVALUE 0)
(LESSP NEWVALUE
(ARRAY-DIMENSION
CMLARRAY DIM)))
then NEWVALUE
else (PRINTOUT (WINDOWPROP MAINW
(QUOTE
PRTWINDOW))
T
(CONCAT "Illegal value "
NEWVALUE))
LEVEL))
else LEVEL)))
(FM.CHANGELABEL ITEM MENUWINDOW LEVEL])
(ICMLARRAY.MENUW.SHOW
[LAMBDA (ITEM MENUWINDOW BUTTONS) (* jop: " 4-Oct-85 15:18")
(PROG [(DISPLAYEDLEVELS (WINDOWPROP (MAINWINDOW MENUWINDOW)
(QUOTE CURRENTLEVELS)))
(CMLARRAY (WINDOWPROP (MAINWINDOW MENUWINDOW)
(QUOTE CMLARRAY]
(for I from 0 to (SUB1 (ARRAY-RANK CMLARRAY)) as LEVEL in DISPLAYEDLEVELS
do (FM.CHANGELABEL (FM.ITEMFROMID MENUWINDOW (PACK* (QUOTE LEVEL)
I))
MENUWINDOW LEVEL])
(SLICEDIMENSION
[LAMBDA (SELECTION DIM) (* jop: "20-Nov-85 20:23")
(* *)
(CAR (FNTH (fetch (ICML.ARRAYSLICE SELECTEDDIMS) of SELECTION)
(ADD1 DIM])
(SLICERANK
[LAMBDA (SELECTION) (* jop: "20-Nov-85 20:23")
(* *)
(LENGTH (fetch (ICML.ARRAYSLICE SELECTEDDIMS) of SELECTION])
(SLICEREF
[LAMBDA ARGS (* jop: "20-Nov-85 20:22")
(* *)
(if (ILESSP ARGS 1)
then (HELP "Need at least one arg"))
(PROG ((SLICE (ARG ARGS 1))
LINEARIZEDARRAY OFFSETS OFFSETCONSTANT)
(SETQ LINEARIZEDARRAY (fetch (ICML.ARRAYSLICE LINEARIZEDARRAY) of SLICE))
(SETQ OFFSETS (fetch (ICML.ARRAYSLICE OFFSETS) of SLICE))
(SETQ OFFSETCONSTANT (fetch (ICML.ARRAYSLICE OFFSETCONSTANT) of SLICE))
(RETURN (AREF LINEARIZEDARRAY (IPLUS OFFSETCONSTANT
(for OFFSET in OFFSETS as I
from 2 sum (ITIMES OFFSET
(ARG ARGS I])
(SLICESET
[LAMBDA ARGS (* jop: "20-Nov-85 20:22")
(* *)
(if (ILESSP ARGS 2)
then (HELP "Need at least two args"))
(PROG ((NEWVALUE (ARG ARGS 1))
(SLICE (ARG ARGS 2))
LINEARIZEDARRAY OFFSETS OFFSETCONSTANT)
(SETQ LINEARIZEDARRAY (fetch (ICML.ARRAYSLICE LINEARIZEDARRAY) of SLICE))
(SETQ OFFSETS (fetch (ICML.ARRAYSLICE OFFSETS) of SLICE))
(SETQ OFFSETCONSTANT (fetch (ICML.ARRAYSLICE OFFSETCONSTANT) of SLICE))
(RETURN (ASET NEWVALUE LINEARIZEDARRAY
(IPLUS OFFSETCONSTANT (for OFFSET in OFFSETS as I from 3
sum (ITIMES OFFSET (ARG ARGS I])
(ZEROD.FETCHFN
[LAMBDA (SLICE PROP) (* jop: " 6-Oct-85 15:59")
(SLICEREF SLICE])
(ZEROD.STOREFN
[LAMBDA (NEWVALUE SLICE PROP) (* jop: " 6-Oct-85 16:02")
(SLICESET NEWVALUE SLICE])
)
(ADDTOVAR INSPECTMACROS (ARRAY . ICMLARRAY))
(/DECLAREDATATYPE (QUOTE ICML.ARRAYSLICE)
(QUOTE (POINTER POINTER POINTER POINTER))
(QUOTE ((ICML.ARRAYSLICE 0 POINTER)
(ICML.ARRAYSLICE 2 POINTER)
(ICML.ARRAYSLICE 4 POINTER)
(ICML.ARRAYSLICE 6 POINTER)))
(QUOTE 8))
(FILESLOAD TWODINSPECTOR)
(LOAD? (QUOTE FREEMENU.DCOM))
(DECLARE: EVAL@COMPILE DONTCOPY
[DECLARE: EVAL@COMPILE
(DATATYPE ICML.ARRAYSLICE (SELECTEDDIMS OFFSETS OFFSETCONSTANT LINEARIZEDARRAY))
]
(/DECLAREDATATYPE (QUOTE ICML.ARRAYSLICE)
(QUOTE (POINTER POINTER POINTER POINTER))
(QUOTE ((ICML.ARRAYSLICE 0 POINTER)
(ICML.ARRAYSLICE 2 POINTER)
(ICML.ARRAYSLICE 4 POINTER)
(ICML.ARRAYSLICE 6 POINTER)))
(QUOTE 8))
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA SLICESET SLICEREF ICMLARRAY.VALUECOMMANDFN)
)
(PUTPROPS CMLARRAYINSPECTOR COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1519 37392 (CREATEARRAYSLICE 1529 . 2953) (ICMLARRAY 2955 . 4362) (
ICMLARRAY.ATTACHDISPLAY 4364 . 4914) (ICMLARRAY.DETACHDISPLAY 4916 . 5210) (ICMLARRAY.DOWINDOWCOMFN
5212 . 6041) (ICMLARRAY.INDICES 6043 . 6928) (ICMLARRAY.LAYOUTMENULIST 6930 . 9141) (
ICMLARRAY.LAYOUTSTATUSLIST 9143 . 11402) (ICMLARRAY.MEASUREMENULIST 11404 . 12294) (
ICMLARRAY.MEASURESTATUSLIST 12296 . 13066) (ICMLARRAY.SETVALUE 13068 . 13880) (
ICMLARRAY.STATUSW.BUTTONEVENTFN 13882 . 15984) (ICMLARRAY.STATUSW.REPAINTFN 15986 . 16793) (
ICMLARRAY.TITLECOMMANDFN 16795 . 17874) (ICMLARRAY.VALUECOMMANDFN 17876 . 20551) (
ICMLARRAY.DISPLAYSLICE 20553 . 22108) (ICMLARRAY.GETREGIONFN 22110 . 23652) (
ICMLARRAY.GETSTATUSWINDOWGROUP 23654 . 31056) (ICMLARRAY.MENUW.APPLY 31058 . 32425) (
ICMLARRAY.MENUW.GETLEVEL 32427 . 34565) (ICMLARRAY.MENUW.SHOW 34567 . 35133) (SLICEDIMENSION 35135 .
35373) (SLICERANK 35375 . 35581) (SLICEREF 35583 . 36330) (SLICESET 36332 . 37105) (ZEROD.FETCHFN
37107 . 37243) (ZEROD.STOREFN 37245 . 37390)))))
STOP