(FILECREATED " 1-Jun-86 16:01:36" {QV}<IDL>SOURCES>INSPECTIDLARRAY.;11 62036
changes to: (FNS IIDL.SETVALUE)
previous date: " 2-Apr-86 23:18:24" {QV}<IDL>SOURCES>INSPECTIDLARRAY.;10)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT INSPECTIDLARRAYCOMS)
(RPAQQ INSPECTIDLARRAYCOMS [(FNS DIMORLABEL IDLARRAY? IDLARRAYDIMENSION IDLARRAYDIMS IDLARRAYRANK
IIDL.ATTACHDISPLAY IIDL.CHANGECOLUMNLABEL IIDL.CHANGEROWLABEL
IIDL.COLUMNPROPCOMMANDFN IIDL.DETACHDISPLAY IIDL.DISPLAYSLICE
IIDL.DOWINDOWCOMFN IIDL.GETREGIONFN IIDL.GETSTATUSWINDOWGROUP
IIDL.INDICES IIDL.LAYOUTMENULIST IIDL.LAYOUTSTATUSLIST
IIDL.MEASUREMENULIST IIDL.MEASURESTATUSLIST IIDL.MENUW.APPLY
IIDL.MENUW.GETLEVEL IIDL.MENUW.SELECTIT IIDL.MENUW.SHOW
IIDL.ROWPROPCOMMANDFN IIDL.SETVALUE IIDL.SOMELEVELS
IIDL.STATUSW.BUTTONEVENTFN IIDL.STATUSW.REPAINTFN
IIDL.TITLECOMMANDFN IIDL.VALUECOMMANDFN INSPECTIDLARRAY
LEVELORLABEL ONEDSLICEREF ONEDSLICESET TRUNCLABEL TWODSLICEREF
TWODSLICESET ZERODSLICEREF ZERODSLICESET)
[ADDVARS (INSPECTMACROS ((FUNCTION IDLARRAY?) . INSPECTIDLARRAY]
(DECLARE: DOEVAL@LOAD DONTCOPY DOEVAL@COMPILE (RECORDS TWODINSPECT.SELECTION))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA
IIDL.VALUECOMMANDFN])
(DEFINEQ
(DIMORLABEL
[LAMBDA (IDLARRAY DIM) (* jop: "24-Nov-85 16:02")
(* *)
(OR (GETDIMLAB IDLARRAY DIM)
DIM])
(IDLARRAY?
[LAMBDA (A) (* jop: "24-Nov-85 14:25" posted: "19-JUL-78 10:52")
(* *)
(type? ARRAYFRAME A])
(IDLARRAYDIMENSION
[LAMBDA (IDLARRAY DIM) (* jop: "22-Nov-85 17:37")
(GETRELT (fetch SHAPE of IDLARRAY)
DIM])
(IDLARRAYDIMS
[DLAMBDA ((IDLARRAY (ONEOF VSCALARP ARRAY)))
(* jop: "24-Nov-85 14:22")
(bind (S ←(fetch SHAPE of IDLARRAY)) for I from 1 to (IDLARRAYRANK IDLARRAY)
collect (GETRELT S I))])
(IDLARRAYRANK
[DLAMBDA ((ARRAY (ONEOF VSCALARP ARRAY))
(RETURNS SCALAR))
(* jop: "24-Nov-85 14:10" posted: " 5-AUG-77 09:57")
(fetch NDIMS of ARRAY)])
(IIDL.ATTACHDISPLAY
[LAMBDA (DISPLAYGROUP STATUSGROUP DISPLAYEDLEVELS) (* jop: "24-Nov-85 15:42")
(* *)
(ATTACHWINDOW DISPLAYGROUP STATUSGROUP (QUOTE LEFT)
(QUOTE TOP)) (* Intercept SHAPEW)
(for W in (CONS DISPLAYGROUP (ALLATTACHEDWINDOWS DISPLAYGROUP))
do (WINDOWPROP W (QUOTE DOWINDOWCOMFN)
(FUNCTION IIDL.DOWINDOWCOMFN)))
(WINDOWPROP STATUSGROUP (QUOTE DISPLAYGROUP)
DISPLAYGROUP)
(WINDOWPROP STATUSGROUP (QUOTE CURRENTLEVELS)
DISPLAYEDLEVELS])
(IIDL.CHANGECOLUMNLABEL
[LAMBDA (DISPLAYW OLDCOLUMNPROP NEWCOLUMNPROP) (* jop: "26-Nov-85 00:43")
(* *)
(PROG ((TOPWINDOW (WINDOWPROP DISPLAYW (QUOTE TOPWINDOW)))
(HORZMARKS (WINDOWPROP DISPLAYW (QUOTE HORZMARKS)))
(COLUMNPROPS (WINDOWPROP DISPLAYW (QUOTE COLUMNPROPS)))
(COLUMNWIDTHS (WINDOWPROP DISPLAYW (QUOTE COLUMNWIDTHS)))
(COLUMNPROPSPACE (WINDOWPROP DISPLAYW (QUOTE COLUMNPROPSPACE)))
HORZMARK COLUMNWIDTH NEWCOLUMNPROPS)
(SETQ NEWCOLUMNPROPS
(for CP in COLUMNPROPS as HMARK in HORZMARKS as CWIDTH in COLUMNWIDTHS
collect (if (EQUAL OLDCOLUMNPROP CP)
then (SETQ HORZMARK HMARK)
(SETQ COLUMNWIDTH CWIDTH)
NEWCOLUMNPROP
else CP)))
(if (ILEQ (STRINGWIDTH NEWCOLUMNPROP TOPWINDOW)
COLUMNWIDTH)
then (* Do some surgury on the display)
(LET [(FHEIGHT (FONTPROP TOPWINDOW (QUOTE HEIGHT)))
(FDESCENT (FONTPROP TOPWINDOW (QUOTE DESCENT)))
(TOPW.SELECTION (WINDOWPROP TOPWINDOW (QUOTE SELECTION)))
(DISPLAYW.SELECTION (WINDOWPROP DISPLAYW (QUOTE SELECTION]
(* Lowlight the current selection, if any)
(TWODINSPECT.INVERTSELECTION TOPWINDOW)
(* Erase the previous rowprop)
(BITBLT NIL NIL NIL TOPWINDOW (ADD1 (IDIFFERENCE HORZMARK
COLUMNWIDTH))
0 COLUMNWIDTH FHEIGHT (QUOTE TEXTURE)
(QUOTE REPLACE)
WHITESHADE) (* Print new rowprop)
(MOVETO (ADD1 (IDIFFERENCE HORZMARK (STRINGWIDTH NEWCOLUMNPROP
TOPWINDOW)))
FDESCENT TOPWINDOW)
(PRINTOUT TOPWINDOW NEWCOLUMNPROP)
(* update the row props)
(WINDOWPROP DISPLAYW (QUOTE COLUMNPROPS)
NEWCOLUMNPROPS) (* fix up the selection to retain EQ'ness)
[if TOPW.SELECTION
then (replace (TWODINSPECT.SELECTION COLUMNPROP) of
TOPW.SELECTION
with (for CP on NEWCOLUMNPROPS
thereis (EQUAL (CAR CP)
NEWCOLUMNPROP]
[if DISPLAYW.SELECTION
then (replace (TWODINSPECT.SELECTION COLUMNPROP) of
DISPLAYW.SELECTION
with (for CP on NEWCOLUMNPROPS
thereis (EQUAL (CAR CP)
NEWCOLUMNPROP]
(TWODINSPECT.ADJUSTCOLUMNSELECTION TOPWINDOW)
(TWODINSPECT.INVERTSELECTION TOPWINDOW)
(* update the row props)
)
else (* Must refetch)
(LET [(MENUW (WINDOWPROP (MAINWINDOW DISPLAYW)
(QUOTE MENUWINDOW]
(IIDL.MENUW.SHOW (FM.ITEMFROMID MENUW (QUOTE SHOW))
MENUW)
(IIDL.MENUW.APPLY (FM.ITEMFROMID MENUW (QUOTE APPLY))
MENUW])
(IIDL.CHANGEROWLABEL
[LAMBDA (DISPLAYW OLDROWPROP NEWROWPROP) (* jop: "25-Nov-85 20:40")
(* *)
(PROG ((RIGHTW (WINDOWPROP DISPLAYW (QUOTE RIGHTWINDOW)))
(VERTMARKS (WINDOWPROP DISPLAYW (QUOTE VERTMARKS)))
(ROWPROPS (WINDOWPROP DISPLAYW (QUOTE ROWPROPS)))
(ROWPROPWIDTH (WINDOWPROP DISPLAYW (QUOTE ROWPROPWIDTH)))
(ROWPROPSPACE (WINDOWPROP DISPLAYW (QUOTE ROWPROPSPACE)))
VERTMARK NEWROWPROPS) (* Change the row props)
(SETQ NEWROWPROPS (for RP in ROWPROPS as VMARK in VERTMARKS
collect (if (EQUAL OLDROWPROP RP)
then (SETQ VERTMARK VMARK)
NEWROWPROP
else RP)))
(if (ILEQ (STRINGWIDTH NEWROWPROP RIGHTW)
ROWPROPWIDTH)
then (* Do some surgury on the display)
(LET [(FHEIGHT (FONTPROP RIGHTW (QUOTE HEIGHT)))
(FDESCENT (FONTPROP RIGHTW (QUOTE DESCENT)))
(RIGHTW.SELECTION (WINDOWPROP RIGHTW (QUOTE SELECTION)))
(DISPLAYW.SELECTION (WINDOWPROP DISPLAYW (QUOTE SELECTION]
(* Lowlight the current selection, if any)
(TWODINSPECT.INVERTSELECTION RIGHTW)
(* Erase the previous rowprop)
(BITBLT NIL NIL NIL RIGHTW (STRINGWIDTH ROWPROPSPACE RIGHTW)
VERTMARK ROWPROPWIDTH FHEIGHT (QUOTE TEXTURE)
(QUOTE REPLACE)
WHITESHADE) (* Print new rowprop)
(MOVETO (STRINGWIDTH ROWPROPSPACE RIGHTW)
(IPLUS VERTMARK FDESCENT)
RIGHTW)
(PRINTOUT RIGHTW NEWROWPROP) (* update the row props)
(WINDOWPROP DISPLAYW (QUOTE ROWPROPS)
NEWROWPROPS) (* fix up the selection to retain EQ'ness)
[if RIGHTW.SELECTION
then (replace (TWODINSPECT.SELECTION ROWPROP) of
RIGHTW.SELECTION
with (for RP on NEWROWPROPS
thereis (EQUAL (CAR RP)
NEWROWPROP]
[if DISPLAYW.SELECTION
then (replace (TWODINSPECT.SELECTION ROWPROP) of
DISPLAYW.SELECTION
with (for RP on NEWROWPROPS
thereis (EQUAL (CAR RP)
NEWROWPROP]
(TWODINSPECT.ADJUSTROWSELECTION RIGHTW)
(TWODINSPECT.INVERTSELECTION RIGHTW)
(* update the row props)
)
else (* Must refetch)
(LET [(MENUW (WINDOWPROP (MAINWINDOW DISPLAYW)
(QUOTE MENUWINDOW]
(IIDL.MENUW.SHOW (FM.ITEMFROMID MENUW (QUOTE SHOW))
MENUW)
(IIDL.MENUW.APPLY (FM.ITEMFROMID MENUW (QUOTE APPLY))
MENUW])
(IIDL.COLUMNPROPCOMMANDFN
[LAMBDA (COLUMNPROP SELECTION DISPLAYW) (* jop: "17-Feb-86 16:01")
(PROG ([COLUMNMENU (CONSTANT (create MENU
ITEMS ←(QUOTE (("Del Label" (QUOTE DELLABEL)
"Delete the level label")
("Relabel" (QUOTE RELABEL)
"Change the level label")
("IT ← Column" (QUOTE SETIT)
"Bind IT to selected column"]
(MAINW (MAINWINDOW DISPLAYW))
IDLARRAY CURRENTLEVELS MENUW DIM)
(SETQ IDLARRAY (WINDOWPROP MAINW (QUOTE IDLARRAY)))
(SETQ CURRENTLEVELS (WINDOWPROP MAINW (QUOTE CURRENTLEVELS)))
(SETQ MENUW (WINDOWPROP MAINW (QUOTE MENUWINDOW)))
(* Real column dimension)
[SETQ DIM (for DM from (IDLARRAYRANK IDLARRAY) by -1 as LEV
in (REVERSE CURRENTLEVELS) thereis (EQ LEV (QUOTE ALL]
(SELECTQ (MENU COLUMNMENU)
[DELLABEL (* delete the label)
(LET [(LEVEL (AND (LITATOM COLUMNPROP)
(GETLEVNUM IDLARRAY DIM COLUMNPROP]
(if (FIXP LEVEL)
then (ASSIGN (AT IDLARRAY (LABEL DIM COLUMNPROP))
NIL)
(* fush a cached menu)
(FM.ITEMPROP (FM.ITEMFROMID MENUW
(PACK*
(QUOTE LEVEL)
DIM))
(QUOTE LEVMENU)
NIL)
(* Refetch)
(IIDL.CHANGECOLUMNLABEL DISPLAYW COLUMNPROP LEVEL]
[RELABEL (LET ((PRTWINDOW (WINDOWPROP MAINW (QUOTE PRTWINDOW)))
NEWLABEL)
(PRINTOUT PRTWINDOW T)
(RESETFORM (TTY.PROCESS (THIS.PROCESS))
(SETQ NEWLABEL (PROMPTFORWORD "New Label?"
COLUMNPROP
"Type new level label"
PRTWINDOW)))
(if (STRINGP NEWLABEL)
then (SETQ NEWLABEL (READ (OPENSTRINGSTREAM NEWLABEL)
))
(if (LITATOM NEWLABEL)
then
(* Change the label)
(ASSIGN (AT IDLARRAY (LABEL DIM
COLUMNPROP))
NEWLABEL)
(* fush a cached menu)
(FM.ITEMPROP (FM.ITEMFROMID
MENUW
(PACK* (QUOTE LEVEL)
DIM))
(QUOTE LEVMENU)
NIL)
(* Refetch)
(IIDL.CHANGECOLUMNLABEL DISPLAYW
COLUMNPROP
NEWLABEL)
else (PRINTOUT (WINDOWPROP MAINW (QUOTE
PRTWINDOW))
T
(CONCAT "Bad label " NEWLABEL]
[SETIT (* Nice to have some feedback)
(PROMPTPRINT (CONCAT "IT bound to " (SETQ IT
(AT SELECTION (LIST (QUOTE ALL)
COLUMNPROP]
NIL])
(IIDL.DETACHDISPLAY
[LAMBDA (STATUSGROUP) (* jop: " 4-Oct-85 17:53")
(* *)
(PROG [(DISPLAYGROUP (WINDOWPROP STATUSGROUP (QUOTE DISPLAYGROUP]
(DETACHWINDOW DISPLAYGROUP)
(CLOSEW DISPLAYGROUP])
(IIDL.DISPLAYSLICE
[LAMBDA (IDLARRAY LEVELS WHERE TOPRIGHT) (* jop: "26-Nov-85 22:31")
(PROG ((SELECTION (if (AND (VSCALARP IDLARRAY)
(NULL LEVELS))
then IDLARRAY
else (AT IDLARRAY LEVELS)))
VALDIM SELECTIONRANK)
(SETQ SELECTIONRANK (IDLARRAYRANK SELECTION))
[if (SETQ VALDIM (GETVALDIM IDLARRAY))
then (SETARRAYPROP SELECTION (QUOTE CODEBOOK)
(LET [(VALDIMLEV (CAR (FNTH LEVELS VALDIM]
(if (OR (EQ VALDIMLEV (QUOTE ALL))
(LISTP VALDIMLEV))
then T
else (GETCODES IDLARRAY VALDIMLEV]
(RETURN (if (IEQP SELECTIONRANK 2)
then (TWODINSPECTW.CREATE SELECTION (for I from 1
to (IDLARRAYDIMENSION
SELECTION 1)
collect (LEVELORLABEL
SELECTION 1 I)
)
(for I from 1 to (IDLARRAYDIMENSION
SELECTION 2)
collect (LEVELORLABEL SELECTION 2 I))
(FUNCTION TWODSLICEREF)
(FUNCTION TWODSLICESET)
(FUNCTION IIDL.VALUECOMMANDFN)
(FUNCTION IIDL.ROWPROPCOMMANDFN)
(FUNCTION IIDL.COLUMNPROPCOMMANDFN)
"Display Window"
(FUNCTION IIDL.TITLECOMMANDFN)
WHERE TOPRIGHT)
elseif (IEQP SELECTIONRANK 1)
then (ONEDINSPECTW.CREATE SELECTION (for I from 1
to (IDLARRAYDIMENSION
SELECTION 1)
collect (LEVELORLABEL
SELECTION 1 I)
)
(FUNCTION ONEDSLICEREF)
(FUNCTION ONEDSLICESET)
(FUNCTION IIDL.VALUECOMMANDFN)
NIL "Display Window" (FUNCTION
IIDL.TITLECOMMANDFN)
WHERE TOPRIGHT)
else (* Must be a zero d slice)
(ONEDINSPECTW.CREATE SELECTION (QUOTE ("Scalar"))
(FUNCTION ZERODSLICEREF)
(FUNCTION ZERODSLICESET)
(FUNCTION IIDL.VALUECOMMANDFN)
NIL "Display Window" (FUNCTION
IIDL.TITLECOMMANDFN)
WHERE TOPRIGHT])
(IIDL.DOWINDOWCOMFN
[LAMBDA (WINDOW) (* jop: "24-Nov-85 15:40")
(* * Pass on the usual comms, except for SHAPEW)
(DECLARE (SPECVARS WindowMenu))
(PROG ((PASSTOMAINCOMS (WINDOWPROP WINDOW (QUOTE PASSTOMAINCOMS)))
(COM (MENU WindowMenu)))
(if COM
then (LET* [(CENTRALWINDOW (CENTRALWINDOW WINDOW))
(DISPLAYGROUP (WINDOWPROP CENTRALWINDOW (QUOTE DISPLAYGROUP]
(if (EQ COM (QUOTE SHAPEW))
then [SHAPEW DISPLAYGROUP (GETREGION NIL NIL NIL
(FUNCTION
IIDL.GETREGIONFN)
(CONS DISPLAYGROUP
(QUOTE CLOSED]
elseif (MEMB COM PASSTOMAINCOMS)
then (APPLY* COM CENTRALWINDOW)
else (APPLY* COM WINDOW])
(IIDL.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])
(IIDL.GETSTATUSWINDOWGROUP
[LAMBDA (IDLARRAY FONTDESCRIPTOR DISPLAYEDLEVELS TOPLEFT)
(* jop: "26-Nov-85 16:25")
(* * 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 (IDLARRAYDIMS IDLARRAY))
(RANK (IDLARRAYRANK IDLARRAY))
(INITIALLEFT 0)
(INITIALBOTTOM 0)
(MENU? T)
(VALDIM (GETVALDIM IDLARRAY))
STATUSLIST MENULIST FIELDWIDTHS GROUPWIDTH SWINDOW PWINDOW PHEIGHT MWINDOW)
(if (OR (ILESSP RANK 2)
(for DIM in DIMS thereis (IEQP DIM 0)))
then (SETQ MENU? NIL))
[SETQ STATUSLIST
(BQUOTE (((LABEL "Format:" FONT , FONT LEFT , INITIALLEFT BOTTOM , INITIALBOTTOM)
(LABEL , (fetch FORMAT of IDLARRAY)
FONT , BFONT LEFT , INITIALLEFT BOTTOM , INITIALBOTTOM))
,
[if VALDIM
then (BQUOTE ((LABEL "Value Label Dim:" FONT , FONT LEFT ,
INITIALLEFT BOTTOM , INITIALBOTTOM)
(LABEL , (DIMORLABEL IDLARRAY VALDIM)
FONT , BFONT LEFT , INITIALLEFT BOTTOM ,
INITIALBOTTOM))
((LABEL "Element Type:" FONT , FONT LEFT ,
INITIALLEFT BOTTOM , INITIALBOTTOM)
(LABEL , (AELTTYPE IDLARRAY)
FONT , BFONT LEFT , INITIALLEFT BOTTOM ,
INITIALBOTTOM)))
else (BQUOTE ((LABEL "Element Type:" FONT , FONT LEFT , INITIALLEFT
BOTTOM , INITIALBOTTOM)
(LABEL , (AELTTYPE IDLARRAY)
FONT , BFONT LEFT , INITIALLEFT BOTTOM ,
INITIALBOTTOM]
((LABEL "Rank:" FONT , FONT LEFT , INITIALLEFT BOTTOM , INITIALBOTTOM)
(LABEL , RANK FONT , BFONT LEFT , INITIALLEFT BOTTOM , INITIALBOTTOM))
((LABEL "Shape:" FONT , FONT LEFT , INITIALLEFT BOTTOM , INITIALBOTTOM)
(LABEL , (bind (SHAPE ←(fetch SHAPE of IDLARRAY))
(STR ← "") for I from 1 to RANK
do (SETQ STR (CONCAT STR (GETRELT SHAPE I)))
(if (ILESSP I RANK)
then (SETQ STR (CONCAT STR " x ")))
finally (RETURN STR))
FONT , BFONT LEFT , INITIALLEFT BOTTOM , INITIALBOTTOM]
(if MENU?
then [SETQ FIELDWIDTHS (bind (WIDTHSOME ←(STRINGWIDTH (QUOTE SOME)
BFONT))
for I from 1 to RANK
collect (IMAX (STRINGWIDTH (DIMORLABEL IDLARRAY
I)
FONT)
WIDTHSOME
(bind (MAX ← 0)
LEVWIDTH for J
from 1 to (IDLARRAYDIMENSION
IDLARRAY I)
do (SETQ LEVWIDTH
(STRINGWIDTH
(LEVELORLABEL IDLARRAY
I J)
BFONT))
(if (IGREATERP LEVWIDTH
MAX)
then (SETQ MAX
LEVWIDTH))
finally (RETURN MAX]
[SETQ MENULIST
(BQUOTE (((TYPE MOMENTARY ID BUTTON LABEL "SHOW" FONT , BFONT LEFT ,
INITIALLEFT BOTTOM , INITIALBOTTOM SELECTEDFN
IIDL.MENUW.SHOW)
(TYPE MOMENTARY ID BUTTON LABEL "IT←SELECTION" FONT , BFONT LEFT
, INITIALLEFT BOTTOM , INITIALBOTTOM SELECTEDFN
IIDL.MENUW.SELECTIT)
(TYPE MOMENTARY ID BUTTON LABEL "APPLY" FONT , BFONT LEFT ,
INITIALLEFT BOTTOM , INITIALBOTTOM SELECTEDFN
IIDL.MENUW.APPLY))
[(TYPE TITLE ID TITLEDIM LABEL "Dimension:" FONT , FONT LEFT ,
INITIALLEFT BOTTOM , INITIALBOTTOM)
,@(for I from 1 to RANK
collect (BQUOTE (TYPE TITLE ID , (PACK* (QUOTE
DIM)
I)
LABEL , (DIMORLABEL IDLARRAY 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 1
collect (BQUOTE (TYPE MOMENTARY ID ,
(PACK* (QUOTE LEVEL)
I)
LABEL ,
(if (EQ LEVEL (QUOTE ALL))
then LEVEL
else (LEVELORLABEL IDLARRAY
I LEVEL))
FONT , BFONT LEFT , INITIALLEFT
BOTTOM , INITIALBOTTOM DIM , I
LEVEL , LEVEL SELECTEDFN
IIDL.MENUW.GETLEVEL]
(WINDOWPROPS TITLE "Format menu"]
(SETQ GROUPWIDTH (IMAX (IIDL.MEASURESTATUSLIST STATUSLIST " " FONT)
(IIDL.MEASUREMENULIST MENULIST " " FONT
FIELDWIDTHS)))
(SETQ STATUSLIST (IIDL.LAYOUTSTATUSLIST STATUSLIST GROUPWIDTH BFONT FONT
" "))
(SETQ MENULIST (IIDL.LAYOUTMENULIST MENULIST GROUPWIDTH BFONT FONT " "
FIELDWIDTHS))
else (SETQ GROUPWIDTH (IIDL.MEASURESTATUSLIST STATUSLIST " " FONT))
(SETQ STATUSLIST (IIDL.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 " IDLARRAY)
NIL T)) (* Makes no sense to reshape the statuswindow group)
(WINDOWPROP SWINDOW (QUOTE REPAINTFN)
(FUNCTION IIDL.STATUSW.REPAINTFN))
(WINDOWPROP SWINDOW (QUOTE RESHAPEFN)
(QUOTE DON'T))
(WINDOWPROP SWINDOW (QUOTE BUTTONEVENTFN)
(QUOTE IIDL.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 IDLARRAY)
IDLARRAY) (* 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 MWINDOW (QUOTE FIELDWIDTHS)
FIELDWIDTHS)
(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])
(IIDL.INDICES
[LAMBDA (DISPLAYWINDOW ROW COLUMN) (* jop: " 2-Apr-86 23:07")
(* * Display the indices of the selected item)
(PROG ((MAINW (MAINWINDOW DISPLAYWINDOW))
IDLARRAY CURRENTLEVELS PRTWINDOW)
(SETQ IDLARRAY (WINDOWPROP MAINW (QUOTE IDLARRAY)))
(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 as DIM from 1
do (if (OR (EQ LEVEL (QUOTE ALL))
(LISTP LEVEL))
then (if FIRSTFLG
then (PRINTOUT PRTWINDOW , (LEVELORLABEL IDLARRAY DIM COLUMN)
,)
else (SETQ FIRSTFLG T)
(PRINTOUT PRTWINDOW , (LEVELORLABEL IDLARRAY DIM ROW)
,))
else (PRINTOUT PRTWINDOW , (LEVELORLABEL IDLARRAY DIM LEVEL)
,])
(IIDL.LAYOUTMENULIST
[LAMBDA (MENULIST GROUPWIDTH BFONT FONT WHITESPACE FIELDWIDTHS)
(* jop: "24-Nov-85 16:24")
(* * 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)
DIM for ITEM in ROW
do (LISTPUT ITEM (QUOTE LEFT)
LEFT)
(LISTPUT ITEM (QUOTE BOTTOM)
BOTTOM)
(SETQ LEFT (IPLUS LEFT [if (SETQ DIM (LISTGET
ITEM
(QUOTE DIM)))
then (CAR (FNTH FIELDWIDTHS DIM)
)
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])
(IIDL.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])
(IIDL.MEASUREMENULIST
[LAMBDA (MENULIST MINWHITESPACE FONT FIELDWIDTHS) (* jop: "24-Nov-85 16:21")
(* * MENULIST is an list of item lists of the form that freemenu expects)
(bind (MAX ← 0)
(SPACE ←(STRINGWIDTH MINWHITESPACE FONT))
ROWWIDTH DIM for ROW in MENULIST unless (EQ (CAR ROW)
(QUOTE WINDOWPROPS))
do [SETQ ROWWIDTH (for ITEM in ROW sum (IPLUS SPACE
(if (SETQ DIM
(LISTGET ITEM
(QUOTE DIM)))
then (CAR (FNTH
FIELDWIDTHS DIM)
)
else (STRINGWIDTH
(LISTGET ITEM
(QUOTE
LABEL))
(LISTGET ITEM
(QUOTE
FONT]
(if (IGREATERP ROWWIDTH MAX)
then (SETQ MAX ROWWIDTH))
finally (RETURN MAX])
(IIDL.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])
(IIDL.MENUW.APPLY
[LAMBDA (ITEM MENUWINDOW BUTTONS) (* jop: "26-Nov-85 22:22")
(* * Display the slice descibed by the windowprop LEVELS)
(PROG ((MAINW (MAINWINDOW MENUWINDOW))
LEVELS IDLARRAY DISPLAYGROUP TOPRIGHT)
(SETQ IDLARRAY (WINDOWPROP MAINW (QUOTE IDLARRAY)))
(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 1 to (IDLARRAYRANK IDLARRAY)
collect (FM.ITEMPROP (FM.ITEMFROMID MENUWINDOW
(PACK* (QUOTE LEVEL)
I))
(QUOTE LEVEL]
(if (ILESSP (for LEVEL in LEVELS count (OR (EQ LEVEL (QUOTE ALL))
(LISTP LEVEL)))
3)
then (if DISPLAYGROUP
then (IIDL.DETACHDISPLAY MAINW))
(SETQ DISPLAYGROUP (IIDL.DISPLAYSLICE IDLARRAY LEVELS DISPLAYGROUP
TOPRIGHT))
(IIDL.ATTACHDISPLAY DISPLAYGROUP MAINW LEVELS)
else (PRINTOUT (WINDOWPROP MAINW (QUOTE PRTWINDOW))
T "Illegal slice"])
(IIDL.MENUW.GETLEVEL
[LAMBDA (ITEM MENUWINDOW BUTTONS) (* jop: "17-Feb-86 16:15")
(* * Get a new LEVEL for dim DIM)
(PROG ((MAINW (MAINWINDOW MENUWINDOW))
(DIM (FM.ITEMPROP ITEM (QUOTE DIM)))
(LEVEL (FM.ITEMPROP ITEM (QUOTE LEVEL)))
(FIELDWIDTHS (WINDOWPROP MENUWINDOW (QUOTE FIELDWIDTHS)))
(LEVMENU (FM.ITEMPROP ITEM (QUOTE LEVMENU)))
IDLARRAY NEWVALUE)
(SETQ IDLARRAY (WINDOWPROP MAINW (QUOTE IDLARRAY)))
(if (NULL LEVMENU)
then [SETQ LEVMENU
(create MENU
ITEMS ←(CONS (QUOTE (All (QUOTE ALL)
"Unrestricted"))
(CONS (QUOTE (Some (QUOTE SOME)
"Some levels"))
(if (ILESSP (IDLARRAYDIMENSION
IDLARRAY DIM)
10)
then (for I from 1
to (IDLARRAYDIMENSION
IDLARRAY DIM)
collect
(LIST (LEVELORLABEL
IDLARRAY DIM I)
I))
else (QUOTE ((Choose (QUOTE CHOOSE)
"Type in a level"]
(FM.ITEMPROP ITEM (QUOTE LEVMENU)
LEVMENU))
(SETQ LEVEL (SELECTQ (SETQ NEWVALUE (MENU LEVMENU))
(ALL (QUOTE ALL))
[SOME (IIDL.SOMELEVELS IDLARRAY DIM (WINDOWPROP
MAINW
(QUOTE CURRENTLEVELS]
(CHOOSE (RNUMBER "Choose a level" NIL NIL NIL T))
NEWVALUE))
(if LEVEL
then (if (AND (LISTP LEVEL)
(EQLENGTH LEVEL 1))
then (SETQ LEVEL (CAR LEVEL)))
(FM.ITEMPROP ITEM (QUOTE LEVEL)
LEVEL)
(FM.CHANGELABEL ITEM MENUWINDOW (if (EQ LEVEL (QUOTE ALL))
then (QUOTE ALL)
elseif (LISTP LEVEL)
then (QUOTE SOME)
else (TRUNCLABEL (LEVELORLABEL
IDLARRAY DIM LEVEL)
(FM.ITEMPROP
ITEM
(QUOTE FONT))
(CAR (FNTH
FIELDWIDTHS DIM]
)
(IIDL.MENUW.SELECTIT
[LAMBDA (ITEM MENUWINDOW BUTTONS) (* jop: "24-Nov-85 17:17")
(* *)
(DECLARE (SPECVARS IT))
(PROG ((MAINW (MAINWINDOW MENUWINDOW))
IDLARRAY LEVELS)
(SETQ IDLARRAY (WINDOWPROP MAINW (QUOTE IDLARRAY)))
[SETQ LEVELS (for I from 1 to (IDLARRAYRANK IDLARRAY)
collect (FM.ITEMPROP (FM.ITEMFROMID MENUWINDOW
(PACK* (QUOTE LEVEL)
I))
(QUOTE LEVEL]
(PROMPTPRINT "IT bound to " (SETQ IT (AT IDLARRAY LEVELS])
(IIDL.MENUW.SHOW
[LAMBDA (ITEM MENUWINDOW BUTTONS) (* jop: "25-Nov-85 22:44")
(* *)
(PROG [(FIELDWIDTHS (WINDOWPROP MENUWINDOW (QUOTE FIELDWIDTHS)))
(DISPLAYEDLEVELS (WINDOWPROP (MAINWINDOW MENUWINDOW)
(QUOTE CURRENTLEVELS)))
(IDLARRAY (WINDOWPROP (MAINWINDOW MENUWINDOW)
(QUOTE IDLARRAY]
(for DIM from 1 to (IDLARRAYRANK IDLARRAY) as LEVEL in DISPLAYEDLEVELS
as FIELDWIDTH in FIELDWIDTHS
do (SETQ ITEM (FM.ITEMFROMID MENUWINDOW (PACK* (QUOTE LEVEL)
DIM)))
(FM.ITEMPROP ITEM (QUOTE LEVEL)
LEVEL)
(FM.CHANGELABEL ITEM MENUWINDOW (if (EQ LEVEL (QUOTE ALL))
then (QUOTE ALL)
elseif (LISTP LEVEL)
then (QUOTE SOME)
else (TRUNCLABEL (LEVELORLABEL IDLARRAY
DIM
LEVEL)
(FM.ITEMPROP
ITEM
(QUOTE FONT))
FIELDWIDTH])
(IIDL.ROWPROPCOMMANDFN
[LAMBDA (ROWPROP SELECTION DISPLAYW) (* jop: "26-Nov-85 00:44")
(PROG ([ROWMENU (CONSTANT (create MENU
ITEMS ←(QUOTE (("Del Label" (QUOTE DELLABEL)
"Delete the level label")
("Relabel" (QUOTE RELABEL)
"Change the level label")
("IT ← Row" (QUOTE SETIT)
"Bind IT to selected row"]
(MAINW (MAINWINDOW DISPLAYW))
IDLARRAY CURRENTLEVELS MENUW DIM)
(SETQ IDLARRAY (WINDOWPROP MAINW (QUOTE IDLARRAY)))
(SETQ CURRENTLEVELS (WINDOWPROP MAINW (QUOTE CURRENTLEVELS)))
(SETQ MENUW (WINDOWPROP MAINW (QUOTE MENUWINDOW)))
[SETQ DIM (for DM from 1 as LEV in CURRENTLEVELS thereis (EQ LEV
(QUOTE
ALL]
(SELECTQ (MENU ROWMENU)
[DELLABEL (* delete the label)
(LET [(LEVEL (AND (LITATOM ROWPROP)
(GETLEVNUM IDLARRAY DIM ROWPROP]
(if (FIXP LEVEL)
then (ASSIGN (AT IDLARRAY (LABEL DIM ROWPROP))
NIL)
(* fush a cached menu)
(FM.ITEMPROP (FM.ITEMFROMID MENUW
(PACK*
(QUOTE LEVEL)
DIM))
(QUOTE LEVMENU)
NIL)
(* Refetch)
(IIDL.CHANGEROWLABEL DISPLAYW ROWPROP LEVEL]
[RELABEL (LET ((PRTWINDOW (WINDOWPROP MAINW (QUOTE PRTWINDOW)))
NEWLABEL)
(PRINTOUT PRTWINDOW T)
(RESETFORM (TTY.PROCESS (THIS.PROCESS))
(SETQ NEWLABEL (PROMPTFORWORD "New Label?"
ROWPROP
"Type new level label"
PRTWINDOW)))
(if (STRINGP NEWLABEL)
then (SETQ NEWLABEL (READ (OPENSTRINGSTREAM NEWLABEL)
))
(if (LITATOM NEWLABEL)
then
(* Change the label)
(ASSIGN (AT IDLARRAY (LABEL DIM
ROWPROP))
NEWLABEL)
(* fush a cached menu)
(FM.ITEMPROP (FM.ITEMFROMID
MENUW
(PACK* (QUOTE LEVEL)
DIM))
(QUOTE LEVMENU)
NIL)
(* Refetch)
(IIDL.CHANGEROWLABEL DISPLAYW ROWPROP
NEWLABEL)
else (PRINTOUT (WINDOWPROP MAINW (QUOTE
PRTWINDOW))
T
(CONCAT "Bad label " NEWLABEL]
[SETIT (* Nice to have some feedback)
(PROMPTPRINT (CONCAT "IT bound to " (SETQ IT
(AT SELECTION (LIST ROWPROP
(QUOTE ALL]
NIL])
(IIDL.SETVALUE
[LAMBDA (DISPLAYWINDOW ROW COLUMN) (* edited: " 1-Jun-86 15:53")
(* * In the zero and one-d cases COLUMN should be NIL, and ROW is the only index)
(PROG ((MAINW (MAINWINDOW DISPLAYWINDOW))
(IDLARRAY (WINDOWPROP DISPLAYWINDOW (QUOTE DATUM)))
[RANK (IDLARRAYRANK (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 NEWVALUE
then (if (EQP RANK 2)
then (TWODINSPECT.REPLACE DISPLAYWINDOW (LEVELORLABEL IDLARRAY 1 ROW)
(LEVELORLABEL IDLARRAY 2 COLUMN)
NEWVALUE)
else (ONEDINSPECT.REPLACE DISPLAYWINDOW (LEVELORLABEL IDLARRAY 1 ROW)
NEWVALUE])
(IIDL.SOMELEVELS
[LAMBDA (IDLARRAY DIM CURRENTLEVELS) (* jop: " 1-Dec-85 13:00")
(* * Returns a list of levels)
(PROG ([FONT (LIST (FONTPROP MENUFONT (QUOTE FAMILY))
(FONTPROP MENUFONT (QUOTE SIZE))
(FONTPROP MENUFONT (QUOTE FACE]
(FHEIGHT (FONTPROP MENUFONT (QUOTE HEIGHT)))
(BFONT (LIST (FONTPROP MENUFONT (QUOTE FAMILY))
(FONTPROP MENUFONT (QUOTE SIZE))
(QUOTE BRR)))
(N (IDLARRAYDIMENSION IDLARRAY DIM))
(SPACE " ")
FIELDWIDTH TOTALWIDTH BUTTONWIDTH NUMROW NUMCOL FLIST FMENU)
[SETQ FIELDWIDTH (IPLUS (STRINGWIDTH SPACE FONT)
(bind (MAX ← 0)
SIZE for I from 1 to N
do (SETQ SIZE (STRINGWIDTH (LEVELORLABEL IDLARRAY
DIM I)
FONT))
(if (IGREATERP SIZE MAX)
then (SETQ MAX SIZE))
finally (RETURN MAX]
[first (SETQ NUMROW N)
(SETQ NUMCOL 1) while (ILESSP (ITIMES 2 NUMCOL FIELDWIDTH)
(ITIMES NUMROW FHEIGHT))
do (SETQ NUMCOL (ADD1 NUMCOL))
(SETQ NUMROW (IPLUS (IQUOTIENT N NUMCOL)
(if (IGREATERP (IREMAINDER N NUMCOL)
0)
then 1
else 0]
(if [ILESSP (SETQ TOTALWIDTH (ITIMES FIELDWIDTH NUMCOL))
(SETQ BUTTONWIDTH (IPLUS (STRINGWIDTH (QUOTE QUIT)
BFONT)
(STRINGWIDTH " " BFONT)
(STRINGWIDTH (QUOTE ABORT)
BFONT]
then (SETQ TOTALWIDTH BUTTONWIDTH)
(SETQ FIELDWIDTH (IQUOTIENT TOTALWIDTH NUMCOL)))
[SETQ FLIST (bind (I ← 1)
[FTOP ←(IPLUS (ITIMES (SUB1 NUMROW)
FHEIGHT)
(FONTPROP FONT (QUOTE DESCENT]
(LEFT ← 0)
(LEVELS ←(CAR (FNTH CURRENTLEVELS DIM))) for C from 1
to NUMCOL
join (PROG1 [bind (BOTTOM ← FTOP) for R from 1 to NUMROW
while (ILEQ I N)
collect
(PROG1 [BQUOTE
(TYPE TOGGLE LABEL ,
(LEVELORLABEL IDLARRAY DIM I)
FONT , FONT LEFT , LEFT BOTTOM ,
BOTTOM STATE ,
(if (EQ LEVELS (QUOTE ALL))
then T
elseif (LISTP LEVELS)
then (MEMB I LEVELS)
else (IEQP I LEVELS]
(SETQ BOTTOM (IDIFFERENCE BOTTOM
FHEIGHT))
(SETQ I (ADD1 I]
(SETQ LEFT (IPLUS LEFT FIELDWIDTH]
(SETQ FMENU
(FM.MAKEMENU (NCONC [BQUOTE ([TYPE TOGGLE LABEL QUIT FONT , BFONT LEFT 0 BOTTOM ,
(IPLUS (ITIMES NUMROW FHEIGHT)
(FONTPROP BFONT (QUOTE DESCENT]
(TYPE TOGGLE LABEL ABORT FONT , BFONT LEFT ,
(ADD1 (IDIFFERENCE TOTALWIDTH
(STRINGWIDTH
(QUOTE ABORT)
BFONT)))
BOTTOM , (IPLUS (ITIMES NUMROW FHEIGHT)
(FONTPROP BFONT
(QUOTE DESCENT]
FLIST)))
(MOVEW FMENU (create POSITION
XCOORD ← LASTMOUSEX
YCOORD ← LASTMOUSEY))
(OPENW FMENU)
(bind (ABORT ←(FM.ITEMFROMID FMENU (QUOTE ABORT)))
(QUIT ←(FM.ITEMFROMID FMENU (QUOTE QUIT)))
while [AND (NULL (FM.ITEMPROP ABORT (QUOTE STATE)))
(NULL (FM.ITEMPROP QUIT (QUOTE STATE]
do (BLOCK 10))
(CLOSEW FMENU)
(RETURN (if (NULL (FM.ITEMPROP (FM.ITEMFROMID FMENU (QUOTE ABORT))
(QUOTE STATE)))
then (for ITEM on (FM.READSTATE FMENU) by (CDDR ITEM)
unless (EQ (CAR ITEM)
(QUOTE QUIT))
collect (if (LITATOM (CAR ITEM))
then (GETLEVNUM IDLARRAY DIM (CAR ITEM))
else (CAR ITEM])
(IIDL.STATUSW.BUTTONEVENTFN
[LAMBDA (WINDOW) (* jop: "22-Nov-85 17:42")
(* *)
(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 IDLARRAY)
(SETQ MENUW (WINDOWPROP WINDOW (QUOTE MENUWINDOW)))
(SETQ IDLARRAY (WINDOWPROP WINDOW (QUOTE IDLARRAY)))
(SELECTQ (MENU TITLEMENU)
[REFETCH (if (for DIM in (IDLARRAYDIMS IDLARRAY)
always (IGREATERP DIM 0))
then
(if (IGREATERP (IDLARRAYRANK IDLARRAY)
1)
then (IIDL.MENUW.SHOW (FM.ITEMFROMID
MENUW
(QUOTE SHOW))
MENUW)
(IIDL.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 (IIDL.DETACHDISPLAY WINDOW)
)
[SETQ DISPLAYGROUP
(IIDL.DISPLAYSLICE
IDLARRAY LEVELS DISPLAYGROUP
(create POSITION
XCOORD ←(SUB1
(fetch LEFT
of REGION))
YCOORD ←(fetch TOP
of REGION]
(IIDL.ATTACHDISPLAY DISPLAYGROUP
WINDOW LEVELS]
(IT (SETQ IT IDLARRAY)
(PROMPTPRINT "IT bound to " IDLARRAY))
NIL])
(IIDL.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])
(IIDL.TITLECOMMANDFN
[LAMBDA (WINDOW) (* jop: "22-Nov-85 17:45")
(* *)
(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 IDLARRAY)
(SETQ MENUW (WINDOWPROP MAINW (QUOTE MENUWINDOW)))
(SETQ IDLARRAY (WINDOWPROP MAINW (QUOTE IDLARRAY)))
(SELECTQ (MENU TITLEMENU)
(REFETCH (IIDL.MENUW.SHOW (FM.ITEMFROMID MENUW (QUOTE SHOW))
MENUW)
(IIDL.MENUW.APPLY (FM.ITEMFROMID MENUW (QUOTE APPLY))
MENUW))
(IT (SETQ IT IDLARRAY)
(PROMPTPRINT "IT bound to " IDLARRAY))
NIL])
(IIDL.VALUECOMMANDFN
[LAMBDA ARGS (* jop: "25-Nov-85 21:23")
(* *)
(PROG ([CODEBOOKMENU (CONSTANT (create MENU
ITEMS ←(QUOTE (("Code value" (QUOTE CODE)
"Display code value")
("Set" (QUOTE SET)
"Set element")
("Indices" (QUOTE INDICES)
"Display indices")
("IT ← Selection" (QUOTE SETIT)
"Bind IT to element"]
[STANDARDMENU (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 SELECTION (ARG ARGS 3))
(if (LITATOM (SETQ INDEX (ARG ARGS 2)))
then (SETQ INDEX (GETLEVNUM SELECTION 1 INDEX)))
(SETQ DISPLAYWINDOW (ARG ARGS 4))
else (* must be in the two-d case)
(SETQ SELECTION (ARG ARGS 4))
(if (LITATOM (SETQ ROW (ARG ARGS 2)))
then (SETQ ROW (GETLEVNUM SELECTION 1 ROW)))
(if (LITATOM (SETQ COLUMN (ARG ARGS 3)))
then (SETQ COLUMN (GETLEVNUM SELECTION 2 COLUMN)))
(SETQ DISPLAYWINDOW (ARG ARGS 5)))
(SETQ RANK (IDLARRAYRANK SELECTION))
(SELECTQ (if (LITATOM VALUE)
then (MENU CODEBOOKMENU)
else (MENU STANDARDMENU))
[CODE (LET [(CODEBOOK (GETARRAYPROP SELECTION (QUOTE CODEBOOK)))
(PRTWINDOW (WINDOWPROP (MAINWINDOW DISPLAYWINDOW)
(QUOTE PRTWINDOW]
[if (EQ CODEBOOK T)
then (SETQ CODEBOOK
(GETCODES SELECTION
(OR INDEX (if (IEQP (GETVALDIM
SELECTION)
1)
then ROW
else COLUMN]
(PRINTOUT PRTWINDOW T "Code Value: ")
(PRINTOUT PRTWINDOW (fetch CODE
of (for CP in CODEBOOK
thereis (EQ VALUE
(fetch CODELAB
of CP]
(SET (SELECTQ RANK
(0 (IIDL.SETVALUE DISPLAYWINDOW INDEX))
(1 (IIDL.SETVALUE DISPLAYWINDOW INDEX))
(2 (IIDL.SETVALUE DISPLAYWINDOW ROW COLUMN))
(SHOULDNT)))
[SETIT (* Nice to have some feedback)
(PROMPTPRINT (CONCAT "IT bound to " (SETQ IT VALUE]
(INDICES (SELECTQ RANK
(0 (IIDL.INDICES DISPLAYWINDOW))
(1 (IIDL.INDICES DISPLAYWINDOW INDEX))
(2 (IIDL.INDICES DISPLAYWINDOW ROW COLUMN))
(SHOULDNT)))
NIL])
(INSPECTIDLARRAY
[LAMBDA (IDLARRAY ASTYPE WHERE) (* jop: "22-Nov-85 17:07")
(* * Top level entry point into the IDLARRAY inspector)
(PROG ((DIMS (IDLARRAYDIMS IDLARRAY))
(RANK (IDLARRAYRANK IDLARRAY))
[FONT (OR INSPECTORFONT (DEFAULTFONT (QUOTE DISPLAY]
DISPLAY DISPLAYEDLEVELS DISPLAYSLICE? STATUSGROUP TOPLEFT)
[if (for DIM in DIMS always (IGREATERP DIM 0))
then (SETQ DISPLAYSLICE? T)
(SETQ DISPLAYEDLEVELS (for I from 1 to RANK
collect (if (ILESSP (IDIFFERENCE RANK I)
2)
then (QUOTE ALL)
else 1]
[if DISPLAYSLICE?
then (SETQ DISPLAY (IIDL.DISPLAYSLICE IDLARRAY DISPLAYEDLEVELS WHERE))
(SETQ TOPLEFT (create POSITION
XCOORD ←(ADD1 (fetch RIGHT of (WINDOWREGION
DISPLAY)))
YCOORD ←(fetch TOP of (WINDOWREGION DISPLAY]
(SETQ STATUSGROUP (IIDL.GETSTATUSWINDOWGROUP IDLARRAY FONT DISPLAYEDLEVELS TOPLEFT))
(if DISPLAYSLICE?
then (IIDL.ATTACHDISPLAY DISPLAY STATUSGROUP DISPLAYEDLEVELS))
(RETURN STATUSGROUP])
(LEVELORLABEL
[LAMBDA (IDLARRAY DIM LEV) (* jop: " 7-Aug-85 22:47")
(PROG ((LAB (GETLEVLAB IDLARRAY DIM LEV)))
(RETURN (OR LAB LEV])
(ONEDSLICEREF
[LAMBDA (ONEDSLICE I) (* jop: "24-Nov-85 18:37")
(* *)
(if (LITATOM I)
then (SETQ I (GETLEVNUM ONEDSLICE 1 I)))
(PROG ((CODEBOOK (GETARRAYPROP ONEDSLICE (QUOTE CODEBOOK)))
ELT)
(if (EQ CODEBOOK T)
then (SETQ CODEBOOK (GETCODES ONEDSLICE I)))
(SETQ ELT (GETAELT ONEDSLICE (AELTPTR1 ONEDSLICE I)))
[if CODEBOOK
then (SETQ ELT (AND ELT (OR [fetch CODELAB
of (for CP in CODEBOOK
thereis (EQP ELT
(fetch CODE
of CP]
ELT]
(RETURN ELT])
(ONEDSLICESET
[LAMBDA (NEWVALUE ONEDSLICE I) (* jop: "24-Nov-85 19:04")
(* *)
(if (LITATOM I)
then (SETQ I (GETLEVNUM ONEDSLICE 1 I)))
(PROG [(CODEBOOK (GETARRAYPROP ONEDSLICE (QUOTE CODEBOOK]
(if (EQ CODEBOOK T)
then (SETQ CODEBOOK (GETCODES ONEDSLICE I)))
(if (AND (LITATOM NEWVALUE)
CODEBOOK)
then (SETQ NEWVALUE (OR [fetch CODE
of (for CP in CODEBOOK
thereis (EQ NEWVALUE
(fetch CODELAB
of CP]
NEWVALUE)))
(RETURN (SETAELT ONEDSLICE (AELTPTR1 ONEDSLICE I)
NEWVALUE])
(TRUNCLABEL
[LAMBDA (LABEL FONT FIELDWIDTH) (* jop: "25-Nov-85 21:47")
(* * Returns a STRINGP or an LITATOM guaranteed to fit in FIELDWIDTH (in pixels))
(if (ILEQ (STRINGWIDTH LABEL FONT)
FIELDWIDTH)
then LABEL
else (SUBSTRING LABEL 1 (IQUOTIENT FIELDWIDTH (STRINGWIDTH (QUOTE A)
FONT])
(TWODSLICEREF
[LAMBDA (TWODSLICE I J) (* jop: "25-Nov-85 23:58")
(* *)
(if (LITATOM I)
then (SETQ I (GETLEVNUM TWODSLICE 1 I)))
(if (LITATOM J)
then (SETQ J (GETLEVNUM TWODSLICE 2 J)))
(PROG ((CODEBOOK (GETARRAYPROP TWODSLICE (QUOTE CODEBOOK)))
ELT)
[if (EQ CODEBOOK T)
then (SETQ CODEBOOK (GETCODES TWODSLICE (if (IEQP (GETVALDIM TWODSLICE)
1)
then I
else J]
(SETQ ELT (GETAELT TWODSLICE (AELTPTR2 TWODSLICE I J)))
[if CODEBOOK
then (SETQ ELT (AND ELT (OR [fetch CODELAB
of (for CP in CODEBOOK
thereis (EQP ELT
(fetch CODE
of CP]
ELT]
(RETURN ELT])
(TWODSLICESET
[LAMBDA (NEWVALUE TWODSLICE I J) (* jop: "24-Nov-85 19:04")
(* *)
(if (LITATOM I)
then (SETQ I (GETLEVNUM TWODSLICE 1 I)))
(if (LITATOM J)
then (SETQ J (GETLEVNUM TWODSLICE 2 J)))
(PROG [(CODEBOOK (GETARRAYPROP TWODSLICE (QUOTE CODEBOOK]
[if (EQ CODEBOOK T)
then (SETQ CODEBOOK (GETCODES TWODSLICE (if (IEQP (GETVALDIM TWODSLICE)
1)
then I
else J]
(if (AND (LITATOM NEWVALUE)
CODEBOOK)
then (SETQ NEWVALUE (OR [fetch CODE
of (for CP in CODEBOOK
thereis (EQ NEWVALUE
(fetch CODELAB
of CP]
NEWVALUE)))
(RETURN (SETAELT TWODSLICE (AELTPTR2 TWODSLICE I J)
NEWVALUE])
(ZERODSLICEREF
[LAMBDA (ZERODSLICE) (* jop: "24-Nov-85 18:43")
(PROG ((INDEXROW (CONSTANT (create ROWINT
NELTS ← 0)))
(CODEBOOK (GETARRAYPROP ZERODSLICE (QUOTE CODEBOOK)))
ELT)
(SETQ ELT (GETAELT ZERODSLICE (AELTPTR ZERODSLICE INDEXROW)))
[if CODEBOOK
then (SETQ ELT (AND ELT (OR [fetch CODELAB
of (for CP in CODEBOOK
thereis (EQP ELT
(fetch CODE
of CP]
ELT]
(RETURN ELT])
(ZERODSLICESET
[LAMBDA (NEWVALUE ZERODSLICE) (* jop: "24-Nov-85 19:16")
(PROG [(INDEXROW (CONSTANT (create ROWINT
NELTS ← 0)))
(CODEBOOK (GETARRAYPROP ZERODSLICE (QUOTE CODEBOOK]
(if (AND (LITATOM NEWVALUE)
CODEBOOK)
then (SETQ NEWVALUE (OR [fetch CODE
of (for CP in CODEBOOK
thereis (EQ NEWVALUE
(fetch CODELAB
of CP]
NEWVALUE)))
(RETURN (SETAELT ZERODSLICE (AELTPTR ZERODSLICE INDEXROW)
NEWVALUE])
)
(ADDTOVAR INSPECTMACROS ((FUNCTION IDLARRAY?) . INSPECTIDLARRAY))
(DECLARE: DOEVAL@LOAD DONTCOPY DOEVAL@COMPILE
[DECLARE: EVAL@COMPILE
(DATATYPE TWODINSPECT.SELECTION (ROWPROP COLUMNPROP ELTBOTTOM ELTLEFT ELTWIDTH))
]
(/DECLAREDATATYPE (QUOTE TWODINSPECT.SELECTION)
(QUOTE (POINTER POINTER POINTER POINTER POINTER))
(QUOTE ((TWODINSPECT.SELECTION 0 POINTER)
(TWODINSPECT.SELECTION 2 POINTER)
(TWODINSPECT.SELECTION 4 POINTER)
(TWODINSPECT.SELECTION 6 POINTER)
(TWODINSPECT.SELECTION 8 POINTER)))
(QUOTE 10))
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA IIDL.VALUECOMMANDFN)
)
(PUTPROPS INSPECTIDLARRAY COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1431 61245 (DIMORLABEL 1441 . 1623) (IDLARRAY? 1625 . 1810) (IDLARRAYDIMENSION 1812 .
1993) (IDLARRAYDIMS 1995 . 2300) (IDLARRAYRANK 2302 . 2547) (IIDL.ATTACHDISPLAY 2549 . 3163) (
IIDL.CHANGECOLUMNLABEL 3165 . 6465) (IIDL.CHANGEROWLABEL 6467 . 9543) (IIDL.COLUMNPROPCOMMANDFN 9545
. 12832) (IIDL.DETACHDISPLAY 12834 . 13123) (IIDL.DISPLAYSLICE 13125 . 15377) (IIDL.DOWINDOWCOMFN
15379 . 16266) (IIDL.GETREGIONFN 16268 . 17805) (IIDL.GETSTATUSWINDOWGROUP 17807 . 26819) (
IIDL.INDICES 26821 . 27948) (IIDL.LAYOUTMENULIST 27950 . 30251) (IIDL.LAYOUTSTATUSLIST 30253 . 32507)
(IIDL.MEASUREMENULIST 32509 . 33480) (IIDL.MEASURESTATUSLIST 33482 . 34247) (IIDL.MENUW.APPLY 34249 .
35618) (IIDL.MENUW.GETLEVEL 35620 . 37837) (IIDL.MENUW.SELECTIT 37839 . 38464) (IIDL.MENUW.SHOW 38466
. 39599) (IIDL.ROWPROPCOMMANDFN 39601 . 42687) (IIDL.SETVALUE 42689 . 43710) (IIDL.SOMELEVELS 43712
. 47863) (IIDL.STATUSW.BUTTONEVENTFN 47865 . 49902) (IIDL.STATUSW.REPAINTFN 49904 . 50706) (
IIDL.TITLECOMMANDFN 50708 . 51699) (IIDL.VALUECOMMANDFN 51701 . 54836) (INSPECTIDLARRAY 54838 . 56122)
(LEVELORLABEL 56124 . 56325) (ONEDSLICEREF 56327 . 57053) (ONEDSLICESET 57055 . 57786) (TRUNCLABEL
57788 . 58191) (TWODSLICEREF 58193 . 59099) (TWODSLICESET 59101 . 60012) (ZERODSLICEREF 60014 . 60625)
(ZERODSLICESET 60627 . 61243)))))
STOP