(FILECREATED " 4-Nov-85 17:13:45" {QV}<PEDERSEN>LISP>INSPECTGENARRAY.;7 36826
changes to: (FNS CREATEMAPPING IGA.DISPLAYSLICE CREATESELECTION SELECTION.DIMENSION
SELECTION.RANK SELECTION.SET SELECTION.REF IGA.GETSTATUSWINDOWGROUP
IGA.SETVALUE IGA.VALUECOMMANDFN IGA.ZEROD.FETCHFN IGA.ZEROD.STOREFN)
(VARS INSPECTGENARRAYCOMS)
(RECORDS IGA.SELECTION)
previous date: "27-Oct-85 17:58:13" {QV}<PEDERSEN>LISP>INSPECTGENARRAY.;6)
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT INSPECTGENARRAYCOMS)
(RPAQQ INSPECTGENARRAYCOMS [(FNS CREATESELECTION GENARRAY? IGA.ATTACHDISPLAY IGA.DETACHDISPLAY
IGA.DISPLAYSLICE IGA.GETSTATUSWINDOWGROUP IGA.INDICES
IGA.LAYOUTMENULIST IGA.LAYOUTSTATUSLIST IGA.MEASUREMENULIST
IGA.MEASURESTATUSLIST IGA.MENUW.APPLY IGA.MENUW.GETLEVEL
IGA.MENUW.SHOW IGA.SETVALUE IGA.STATUSW.BUTTONEVENTFN
IGA.STATUSW.REPAINTFN IGA.TITLECOMMANDFN IGA.VALUECOMMANDFN
IGA.ZEROD.FETCHFN IGA.ZEROD.STOREFN INSPECTGENARRAY
SELECTION.DIMENSION SELECTION.RANK SELECTION.REF SELECTION.SET)
[ADDVARS (INSPECTMACROS ((FUNCTION GENARRAY?) . INSPECTGENARRAY]
(P (LOAD? (QUOTE TWODINSPECTOR.DCOM))
(LOAD? (QUOTE FREEMENU.DCOM)))
(DECLARE: DONTEVAL@LOAD (LOCALVARS . T))
(RECORDS IGA.SELECTION)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA
IGA.VALUECOMMANDFN])
(DEFINEQ
(CREATESELECTION
[LAMBDA (ARRAY LEVELS) (* jop: " 4-Nov-85 16:54")
(* * An ARRAYSLICE is a zero, one or two dimensional slice of a CMLARRAY. LEVELS is a list of length
(ARRAY-RANK ARRAY) which descibes the slice. The atom ALL indications that that dimension is unrestricted)
(PROG ((RANK (GENARRAY.RANK ARRAY))
(DIMS (GENARRAY.DIMS ARRAY))
(SCANDIMS (GENARRAY.SCANDIMS ARRAY))
(OFFSETCONSTANT 0)
SELECTIONDIMS OFFSETS)
[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 IGA.SELECTION
SELECTEDDIMS ←(DREVERSE SELECTIONDIMS)
OFFSETS ←(DREVERSE OFFSETS)
OFFSETCONSTANT ← OFFSETCONSTANT
LINEARIZEDARRAY ←(GENARRAY.LINEARIZE ARRAY])
(GENARRAY?
[LAMBDA (DATUM) (* jop: "14-Oct-85 12:41")
(if (type? GENARRAY DATUM)
then (MENU (create MENU
ITEMS ←(QUOTE ((Fields NIL)
(Contents T])
(IGA.ATTACHDISPLAY
[LAMBDA (DISPLAYGROUP STATUSGROUP DISPLAYEDLEVELS) (* jop: " 6-Oct-85 12:46")
(ATTACHWINDOW DISPLAYGROUP STATUSGROUP (QUOTE LEFT)
(QUOTE TOP))
[WINDOWPROP DISPLAYGROUP (QUOTE PASSTOMAINCOMS)
(REMOVE (QUOTE SHAPEW)
(WINDOWPROP DISPLAYGROUP (QUOTE PASSTOMAINCOMS]
(WINDOWPROP DISPLAYGROUP (QUOTE DOWINDOWCOMFN)
(FUNCTION ICMLARRAY.DOWINDOWCOMFN))
(WINDOWPROP STATUSGROUP (QUOTE DISPLAYGROUP)
DISPLAYGROUP)
(WINDOWPROP STATUSGROUP (QUOTE CURRENTLEVELS)
DISPLAYEDLEVELS])
(IGA.DETACHDISPLAY
[LAMBDA (STATUSGROUP) (* jop: " 4-Oct-85 17:53")
(* *)
(PROG [(DISPLAYGROUP (WINDOWPROP STATUSGROUP (QUOTE DISPLAYGROUP]
(DETACHWINDOW DISPLAYGROUP)
(CLOSEW DISPLAYGROUP])
(IGA.DISPLAYSLICE
[LAMBDA (GENARRAY LEVELS WHERE TOPRIGHT) (* jop: " 4-Nov-85 17:04")
(PROG ((SELECTION (CREATESELECTION GENARRAY LEVELS))
SELECTIONRANK)
(SETQ SELECTIONRANK (SELECTION.RANK SELECTION))
(RETURN (if (EQP SELECTIONRANK 2)
then (TWODINSPECTW.CREATE SELECTION (for I from 0
to (SUB1 (
SELECTION.DIMENSION
SELECTION 0))
collect I)
(for I from 0
to (SUB1 (SELECTION.DIMENSION
SELECTION 1))
collect I)
(FUNCTION SELECTION.REF)
(FUNCTION SELECTION.SET)
(FUNCTION IGA.VALUECOMMANDFN)
NIL NIL "Display Window"
(FUNCTION IGA.TITLECOMMANDFN)
WHERE TOPRIGHT)
elseif (EQP SELECTIONRANK 1)
then (ONEDINSPECTW.CREATE SELECTION (for I from 0
to (SUB1 (
SELECTION.DIMENSION
SELECTION 0))
collect I)
(FUNCTION SELECTION.REF)
(FUNCTION SELECTION.SET)
(FUNCTION IGA.VALUECOMMANDFN)
NIL "Display Window" (FUNCTION
IGA.TITLECOMMANDFN)
WHERE TOPRIGHT)
else (* Must be a zero d slice)
(ONEDINSPECTW.CREATE SELECTION (QUOTE ("Entry"))
(FUNCTION IGA.ZEROD.FETCHFN)
(FUNCTION IGA.ZEROD.STOREFN)
(FUNCTION IGA.VALUECOMMANDFN)
NIL "Display Window" (FUNCTION
IGA.TITLECOMMANDFN)
WHERE TOPRIGHT])
(IGA.GETSTATUSWINDOWGROUP
[LAMBDA (GENARRAY FONTDESCRIPTOR DISPLAYEDLEVELS TOPLEFT)
(* jop: " 4-Nov-85 16:59")
(* * 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 (GENARRAY.DIMS GENARRAY))
(RANK (GENARRAY.RANK GENARRAY))
(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 "Array-type:" FONT , FONT LEFT , INITIALLEFT BOTTOM , INITIALBOTTOM)
(LABEL , (GENARRAY.ARRAYTYPE GENARRAY)
FONT , BFONT LEFT , INITIALLEFT BOTTOM , INITIALBOTTOM))
((LABEL "Element-type:" FONT , FONT LEFT , INITIALLEFT BOTTOM ,
INITIALBOTTOM)
(LABEL , (GENARRAY.ELTTYPE GENARRAY)
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 (GENARRAY.DIMENSION GENARRAY 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
IGA.MENUW.SHOW)
(TYPE MOMENTARY ID BUTTON LABEL "APPLY" FONT , BFONT LEFT ,
INITIALLEFT BOTTOM , INITIALBOTTOM SELECTEDFN
IGA.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
IGA.MENUW.GETLEVEL]
(WINDOWPROPS TITLE "Format menu"]
(SETQ GROUPWIDTH (IMAX (IGA.MEASURESTATUSLIST STATUSLIST " " FONT)
(IGA.MEASUREMENULIST MENULIST " " FONT
FIELDWIDTH)))
(SETQ STATUSLIST (IGA.LAYOUTSTATUSLIST STATUSLIST GROUPWIDTH BFONT FONT
" "))
(SETQ MENULIST (IGA.LAYOUTMENULIST MENULIST GROUPWIDTH BFONT FONT " "
FIELDWIDTH))
else (SETQ GROUPWIDTH (IGA.MEASURESTATUSLIST STATUSLIST " " FONT))
(SETQ STATUSLIST (IGA.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))
(CONCAT "Inspector of " GENARRAY)
NIL T)) (* Makes no sense to reshape the statuswindow group)
(WINDOWPROP SWINDOW (QUOTE REPAINTFN)
(FUNCTION IGA.STATUSW.REPAINTFN))
(WINDOWPROP SWINDOW (QUOTE RESHAPEFN)
(QUOTE DON'T))
(WINDOWPROP SWINDOW (QUOTE BUTTONEVENTFN)
(QUOTE IGA.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 GENARRAY)
GENARRAY) (* 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])
(IGA.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 ,])
(IGA.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])
(IGA.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])
(IGA.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])
(IGA.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])
(IGA.MENUW.APPLY
[LAMBDA (ITEM MENUWINDOW BUTTONS) (* jop: "14-Oct-85 12:55")
(* * Display the slice descibed by the windowprop LEVELS)
(PROG ((MAINW (MAINWINDOW MENUWINDOW))
LEVELS GENARRAY DISPLAYGROUP TOPRIGHT)
(SETQ GENARRAY (WINDOWPROP MAINW (QUOTE GENARRAY)))
(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 (GENARRAY.RANK GENARRAY))
collect (FM.ITEMPROP (FM.ITEMFROMID MENUWINDOW
(PACK* (QUOTE LEVEL)
I))
(QUOTE LABEL]
(if (ILESSP (for LEVEL in LEVELS count (EQ LEVEL (QUOTE ALL)))
3)
then (if DISPLAYGROUP
then (IGA.DETACHDISPLAY MAINW))
(SETQ DISPLAYGROUP (IGA.DISPLAYSLICE GENARRAY LEVELS DISPLAYGROUP TOPRIGHT)
)
(IGA.ATTACHDISPLAY DISPLAYGROUP MAINW LEVELS)
else (PRINTOUT (WINDOWPROP MAINW (QUOTE PRTWINDOW))
T "Illegal slice"])
(IGA.MENUW.GETLEVEL
[LAMBDA (ITEM MENUWINDOW BUTTONS) (* jop: "14-Oct-85 12:47")
(* * Get a new LEVEL for dim DIM)
(PROG ((MAINW (MAINWINDOW MENUWINDOW))
(DIM (FM.ITEMPROP ITEM (QUOTE DIM)))
(LEVEL (FM.ITEMPROP ITEM (QUOTE LABEL)))
GENARRAY LEVMENU PRTWINDOW NEWVALUE)
(SETQ GENARRAY (WINDOWPROP MAINW (QUOTE GENARRAY)))
(SETQ LEVEL (if (ILESSP (GENARRAY.DIMENSION GENARRAY 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 (GENARRAY.DIMENSION
GENARRAY 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
(GENARRAY.DIMENSION
GENARRAY DIM)))
then NEWVALUE
else (PRINTOUT (WINDOWPROP MAINW
(QUOTE
PRTWINDOW))
T
(CONCAT "Illegal value "
NEWVALUE))
LEVEL))
else LEVEL)))
(FM.CHANGELABEL ITEM MENUWINDOW LEVEL])
(IGA.MENUW.SHOW
[LAMBDA (ITEM MENUWINDOW BUTTONS) (* jop: "14-Oct-85 12:25")
(PROG [(DISPLAYEDLEVELS (WINDOWPROP (MAINWINDOW MENUWINDOW)
(QUOTE CURRENTLEVELS)))
(GENARRAY (WINDOWPROP (MAINWINDOW MENUWINDOW)
(QUOTE GENARRAY]
(for I from 0 to (SUB1 (GENARRAY.RANK GENARRAY)) as LEVEL in
DISPLAYEDLEVELS
do (FM.CHANGELABEL (FM.ITEMFROMID MENUWINDOW (PACK* (QUOTE LEVEL)
I))
MENUWINDOW LEVEL])
(IGA.SETVALUE
[LAMBDA (DISPLAYWINDOW ROW COLUMN) (* jop: " 4-Nov-85 17:00")
(* * In the zero and one-d cases COLUMN should be NIL, and ROW is the only index)
(PROG ((MAINW (MAINWINDOW DISPLAYWINDOW))
[RANK (SELECTION.RANK (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 RANK 2)
then (TWODINSPECT.REPLACE DISPLAYWINDOW ROW COLUMN NEWVALUE)
else (ONEDINSPECT.REPLACE DISPLAYWINDOW ROW NEWVALUE])
(IGA.STATUSW.BUTTONEVENTFN
[LAMBDA (WINDOW) (* jop: "14-Oct-85 12:34")
(* *)
(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 GENARRAY)
(SETQ MENUW (WINDOWPROP WINDOW (QUOTE MENUWINDOW)))
(SETQ GENARRAY (WINDOWPROP WINDOW (QUOTE GENARRAY)))
(SELECTQ (MENU TITLEMENU)
[REFETCH (if (for DIM in (GENARRAY.DIMS GENARRAY)
always (IGREATERP DIM 0))
then
(if (IGREATERP (GENARRAY.RANK GENARRAY)
1)
then (IGA.MENUW.SHOW (FM.ITEMFROMID
MENUW
(QUOTE SHOW))
MENUW)
(IGA.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 (IGA.DETACHDISPLAY WINDOW))
[SETQ DISPLAYGROUP
(IGA.DISPLAYSLICE
GENARRAY LEVELS DISPLAYGROUP
(create POSITION
XCOORD ←(SUB1
(fetch LEFT
of REGION))
YCOORD ←(fetch TOP
of REGION]
(IGA.ATTACHDISPLAY DISPLAYGROUP
WINDOW LEVELS]
(IT (SETQ IT GENARRAY)
(PROMPTPRINT "IT bound to " GENARRAY))
NIL])
(IGA.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])
(IGA.TITLECOMMANDFN
[LAMBDA (WINDOW) (* jop: "14-Oct-85 12:28")
(* *)
(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 GENARRAY)
(SETQ MENUW (WINDOWPROP MAINW (QUOTE MENUWINDOW)))
(SETQ GENARRAY (WINDOWPROP MAINW (QUOTE GENARRAY)))
(SELECTQ (MENU TITLEMENU)
(REFETCH (IGA.MENUW.SHOW (FM.ITEMFROMID MENUW (QUOTE SHOW))
MENUW)
(IGA.MENUW.APPLY (FM.ITEMFROMID MENUW (QUOTE APPLY))
MENUW))
(IT (SETQ IT GENARRAY)
(RESETVAR *PRINT-ARRAY* NIL (PROMPTPRINT "IT bound to "
GENARRAY)))
NIL])
(IGA.VALUECOMMANDFN
[LAMBDA ARGS (* jop: " 4-Nov-85 17:01")
(* *)
(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 SELECTION DISPLAYWINDOW RANK)
(if (EQP ARGS 4)
then (* must be in the one-d case)
(SETQ INDEX (ARG ARGS 2))
(SETQ SELECTION (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 SELECTION (ARG ARGS 4))
(SETQ DISPLAYWINDOW (ARG ARGS 5)))
(SETQ RANK (SELECTION.RANK SELECTION))
(SELECTQ (if (OR (NUMBERP VALUE)
(NULL VALUE))
then (MENU SETABLEMENU)
else (MENU INSPECTABLEMENU))
(INSPECT (INSPECT VALUE))
(SET (SELECTQ RANK
(0 (IGA.SETVALUE DISPLAYWINDOW INDEX))
(1 (IGA.SETVALUE DISPLAYWINDOW INDEX))
(2 (IGA.SETVALUE DISPLAYWINDOW ROW COLUMN))
(SHOULDNT)))
[SETIT (* Nice to have some feedback)
(RESETLST [RESETSAVE (PRINTLEVEL (QUOTE (2 . 5]
(RESETSAVE PLVLFILEFLG T)
(RESETSAVE *PRINT-ARRAY* NIL)
(PROMPTPRINT (CONCAT "IT bound to " (SETQ IT VALUE]
(INDICES (SELECTQ RANK
(0 (IGA.INDICES DISPLAYWINDOW))
(1 (IGA.INDICES DISPLAYWINDOW INDEX))
(2 (IGA.INDICES DISPLAYWINDOW ROW COLUMN))
(SHOULDNT)))
NIL])
(IGA.ZEROD.FETCHFN
[LAMBDA (SELECTION PROP) (* jop: " 4-Nov-85 17:02")
(SELECTION.REF SELECTION])
(IGA.ZEROD.STOREFN
[LAMBDA (NEWVALUE SELECTION PROP) (* jop: " 4-Nov-85 17:02")
(SELECTION.REF NEWVALUE SELECTION])
(INSPECTGENARRAY
[LAMBDA (GENARRAY ASTYPE WHERE) (* jop: "14-Oct-85 12:42")
(* * Top level entry point into the GENARRAY inspector)
(PROG ((DIMS (GENARRAY.DIMS GENARRAY))
(RANK (GENARRAY.RANK GENARRAY))
[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 (IGA.DISPLAYSLICE GENARRAY DISPLAYEDLEVELS WHERE))
(SETQ TOPLEFT (create POSITION
XCOORD ←(ADD1 (fetch RIGHT of (WINDOWREGION
DISPLAY)))
YCOORD ←(fetch TOP of (WINDOWREGION DISPLAY]
(SETQ STATUSGROUP (IGA.GETSTATUSWINDOWGROUP GENARRAY FONT DISPLAYEDLEVELS TOPLEFT))
(if DISPLAYSLICE?
then (IGA.ATTACHDISPLAY DISPLAY STATUSGROUP DISPLAYEDLEVELS))
(RETURN STATUSGROUP])
(SELECTION.DIMENSION
[LAMBDA (SELECTION DIM) (* jop: " 4-Nov-85 16:51")
(LISTREF (fetch (IGA.SELECTION SELECTEDDIMS) of SELECTION)
DIM])
(SELECTION.RANK
[LAMBDA (SELECTION) (* jop: " 4-Nov-85 16:49")
(LENGTH (fetch (IGA.SELECTION SELECTEDDIMS) of SELECTION])
(SELECTION.REF
[LAMBDA ARGS (* jop: " 4-Nov-85 16:56")
(* * First arg is the Genarray. Next is a list of indices, or a scalar in the one-d case)
(if (ILESSP ARGS 1)
then (HELP "Need at least one arg"))
(PROG ((SELECTION (ARG ARGS 1))
LINEARIZEDARRAY OFFSETS OFFSETCONSTANT)
(SETQ LINEARIZEDARRAY (fetch (IGA.SELECTION LINEARIZEDARRAY) of SELECTION))
(SETQ OFFSETS (fetch (IGA.SELECTION OFFSETS) of SELECTION))
(SETQ OFFSETCONSTANT (fetch (IGA.SELECTION OFFSETCONSTANT) of SELECTION))
(RETURN (GENARRAY.REF LINEARIZEDARRAY
(IPLUS OFFSETCONSTANT
(for OFFSET in OFFSETS as I from 2
sum (ITIMES OFFSET (ARG ARGS I])
(SELECTION.SET
[LAMBDA ARGS (* jop: " 4-Nov-85 16:58")
(* * First arg is the Genarray. Next is a list of indices, or a scalar in the one-d case)
(if (ILESSP ARGS 2)
then (HELP "Need at least two args"))
(PROG ((NEWVALUE (ARG ARGS 1))
(SELECTION (ARG ARGS 2))
LINEARIZEDARRAY OFFSETS OFFSETCONSTANT)
(SETQ LINEARIZEDARRAY (fetch (IGA.SELECTION LINEARIZEDARRAY) of SELECTION))
(SETQ OFFSETS (fetch (IGA.SELECTION OFFSETS) of SELECTION))
(SETQ OFFSETCONSTANT (fetch (IGA.SELECTION OFFSETCONSTANT) of SELECTION))
(RETURN (GENARRAY.SET NEWVALUE LINEARIZEDARRAY
(IPLUS OFFSETCONSTANT
(for OFFSET in OFFSETS as I from 3
sum (ITIMES OFFSET (ARG ARGS I])
)
(ADDTOVAR INSPECTMACROS ((FUNCTION GENARRAY?) . INSPECTGENARRAY))
(LOAD? (QUOTE TWODINSPECTOR.DCOM))
(LOAD? (QUOTE FREEMENU.DCOM))
(DECLARE: DONTEVAL@LOAD
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
)
[DECLARE: EVAL@COMPILE
(DATATYPE IGA.SELECTION (SELECTEDDIMS OFFSETS OFFSETCONSTANT LINEARIZEDARRAY))
]
(/DECLAREDATATYPE (QUOTE IGA.SELECTION)
(QUOTE (POINTER POINTER POINTER POINTER))
(QUOTE ((IGA.SELECTION 0 POINTER)
(IGA.SELECTION 2 POINTER)
(IGA.SELECTION 4 POINTER)
(IGA.SELECTION 6 POINTER)))
(QUOTE 8))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA IGA.VALUECOMMANDFN)
)
(PRETTYCOMPRINT INSPECTGENARRAYCOMS)
(RPAQQ INSPECTGENARRAYCOMS [(FNS CREATESELECTION GENARRAY? IGA.ATTACHDISPLAY IGA.DETACHDISPLAY
IGA.DISPLAYSLICE IGA.GETSTATUSWINDOWGROUP IGA.INDICES
IGA.LAYOUTMENULIST IGA.LAYOUTSTATUSLIST IGA.MEASUREMENULIST
IGA.MEASURESTATUSLIST IGA.MENUW.APPLY IGA.MENUW.GETLEVEL
IGA.MENUW.SHOW IGA.SETVALUE IGA.STATUSW.BUTTONEVENTFN
IGA.STATUSW.REPAINTFN IGA.TITLECOMMANDFN IGA.VALUECOMMANDFN
IGA.ZEROD.FETCHFN IGA.ZEROD.STOREFN INSPECTGENARRAY
SELECTION.DIMENSION SELECTION.RANK SELECTION.REF SELECTION.SET)
[ADDVARS (INSPECTMACROS ((FUNCTION GENARRAY?) . INSPECTGENARRAY]
(P (LOAD? (QUOTE TWODINSPECTOR.DCOM))
(LOAD? (QUOTE FREEMENU.DCOM)))
(DECLARE: DONTEVAL@LOAD (LOCALVARS . T))
(RECORDS IGA.SELECTION)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA SELECTION.SET
SELECTION.REF
IGA.VALUECOMMANDFN])
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA SELECTION.SET SELECTION.REF IGA.VALUECOMMANDFN)
)
(PUTPROPS INSPECTGENARRAY COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1497 34847 (CREATESELECTION 1507 . 2576) (GENARRAY? 2578 . 2820) (IGA.ATTACHDISPLAY
2822 . 3439) (IGA.DETACHDISPLAY 3441 . 3729) (IGA.DISPLAYSLICE 3731 . 5415) (IGA.GETSTATUSWINDOWGROUP
5417 . 12853) (IGA.INDICES 12855 . 13734) (IGA.LAYOUTMENULIST 13736 . 15941) (IGA.LAYOUTSTATUSLIST
15943 . 18196) (IGA.MEASUREMENULIST 18198 . 19082) (IGA.MEASURESTATUSLIST 19084 . 19848) (
IGA.MENUW.APPLY 19850 . 21184) (IGA.MENUW.GETLEVEL 21186 . 23327) (IGA.MENUW.SHOW 23329 . 23905) (
IGA.SETVALUE 23907 . 24704) (IGA.STATUSW.BUTTONEVENTFN 24706 . 26734) (IGA.STATUSW.REPAINTFN 26736 .
27537) (IGA.TITLECOMMANDFN 27539 . 28573) (IGA.VALUECOMMANDFN 28575 . 31007) (IGA.ZEROD.FETCHFN 31009
. 31158) (IGA.ZEROD.STOREFN 31160 . 31318) (INSPECTGENARRAY 31320 . 32704) (SELECTION.DIMENSION 32706
. 32911) (SELECTION.RANK 32913 . 33099) (SELECTION.REF 33101 . 33950) (SELECTION.SET 33952 . 34845)))
))
STOP