(FILECREATED "28-Jun-86 15:50:02" {QV}<PEDERSEN>LISP>IDLARRAYINSPECTOR.;3 52501
changes to: (VARS IDLARRAYINSPECTORCOMS)
previous date: "25-Jun-86 01:41:37" {QV}<PEDERSEN>LISP>IDLARRAYINSPECTOR.;2)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT IDLARRAYINSPECTORCOMS)
(RPAQQ IDLARRAYINSPECTORCOMS [(FNS IDLARRAY-INSPECT-P 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.MAKE-SLICE IIDL.MEASUREMENULIST
IIDL.MEASURESTATUSLIST IIDL.MENUW.APPLY IIDL.MENUW.GETLEVEL
IIDL.MENUW.SELECTIT IIDL.MENUW.SHOW IIDL.ROWPROPCOMMANDFN
IIDL.SETVALUE IIDL.SLICE-SELECTED-DIM IIDL.SLICE-RANK
IIDL.SLICE-REF IIDL.SLICE-SET IIDL.STATUSW.BUTTONEVENTFN
IIDL.STATUSW.REPAINTFN IIDL.TITLECOMMANDFN IIDL.VALUECOMMANDFN
INSPECTIDLARRAY TRUNCLABEL)
(ADDVARS (INSPECTMACROS (IDLARRAY . INSPECTIDLARRAY)))
(DECLARE: DOEVAL@LOAD DONTCOPY DOEVAL@COMPILE (RECORDS TWODINSPECT.SELECTION))
(RECORDS IIDL.ARRAYSLICE)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA
IIDL.VALUECOMMANDFN
IIDL.SLICE-SET
IIDL.SLICE-REF])
(DEFINEQ
(IDLARRAY-INSPECT-P
[LAMBDA (DATUM) (* jop: "24-Jun-86 14:07")
(AND (type? IDLARRAY DATUM)
(MENU (CONSTANT (create MENU
ITEMS ←(QUOTE ((Contents T)
(Fields NIL])
(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 SLICE DISPLAYW) (* jop: "24-Jun-86 13:44")
(* *)
(LET* ([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 (WINDOWPROP MAINW (QUOTE IDLARRAY)))
(CURRENTLEVELS (WINDOWPROP MAINW (QUOTE CURRENTLEVELS)))
(MENUW (WINDOWPROP MAINW (QUOTE MENUWINDOW)))
(DIM (IIDL.SLICE-SELECTED-DIM SLICE 1))
(LEVEL (IDLARRAY-LEVELINDEX IDLARRAY DIM COLUMNPROP)))
(SELECTQ (MENU COLUMNMENU)
(DELLABEL (if (LITATOM (IDLARRAY-LEVELLABEL IDLARRAY DIM COLUMNPROP))
then (* delete the label)
(IDLARRAY-SETLEVELLABEL IDLARRAY DIM LEVEL 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)
(IDLARRAY-SETLEVELLABEL IDLARRAY DIM LEVEL
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 IDLARRAY
(ASVECTOR (for I from 0
as L in CURRENTLEVELS
collect
(if (EQ I DIM)
then LEVEL
else L]
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: "24-Jun-86 13:44")
(* *)
(LET* ((SLICE (IIDL.MAKE-SLICE IDLARRAY LEVELS))
(SELECTIONRANK (IIDL.SLICE-RANK SLICE)))
(SELECTQ SELECTIONRANK
(1 (ONEDINSPECTW.CREATE SLICE (IDLARRAY-LEVELLABELS IDLARRAY
(
IIDL.SLICE-SELECTED-DIM
SLICE 0))
(FUNCTION IIDL.SLICE-REF)
(FUNCTION IIDL.SLICE-SET)
(FUNCTION IIDL.VALUECOMMANDFN)
NIL "Display Window" (FUNCTION IIDL.TITLECOMMANDFN)
WHERE TOPRIGHT))
(2 (TWODINSPECTW.CREATE SLICE (IDLARRAY-LEVELLABELS IDLARRAY
(
IIDL.SLICE-SELECTED-DIM
SLICE 0))
(IDLARRAY-LEVELLABELS IDLARRAY (
IIDL.SLICE-SELECTED-DIM
SLICE 1))
(FUNCTION IIDL.SLICE-REF)
(FUNCTION IIDL.SLICE-SET)
(FUNCTION IIDL.VALUECOMMANDFN)
(FUNCTION IIDL.ROWPROPCOMMANDFN)
(FUNCTION IIDL.COLUMNPROPCOMMANDFN)
"Display Window"
(FUNCTION IIDL.TITLECOMMANDFN)
WHERE TOPRIGHT))
(SHOULDNT])
(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: "24-Jun-86 22:19")
(* * Constructs the three windows of the status group and puts them up on the screen. returns the mainwindow of the
group.)
(LET* ((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 (IDLARRAY-DIMS IDLARRAY))
(RANK (IDLARRAY-RANK IDLARRAY))
(INITIALLEFT 0)
(INITIALBOTTOM 0)
[MENU? (AND (IGREATERP RANK 1)
(for DIM in DIMS thereis (NEQ DIM 0]
(MAXMENUWIDTH 15)
STATUSLIST MENULIST FIELDWIDTHS GROUPWIDTH SWINDOW PWINDOW PHEIGHT MWINDOW)
[SETQ STATUSLIST
(BQUOTE (((LABEL "Elttype:" FONT , FONT LEFT , INITIALLEFT BOTTOM , INITIALBOTTOM)
(LABEL , (IDLARRAY-ELTTYPE 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 (STR ← "") for I from 1 to RANK as DIM
in (IDLARRAY-DIMS IDLARRAY)
do (SETQ STR (CONCAT STR DIM))
(if (NEQ I RANK)
then (SETQ STR (CONCAT STR " x ")))
finally (RETURN STR))
FONT , BFONT LEFT , INITIALLEFT BOTTOM , INITIALBOTTOM]
(if MENU?
then [SETQ FIELDWIDTHS
(bind (WIDTHALL ←(STRINGWIDTH (QUOTE ALL)
BFONT))
for DIM from 0 upto RANK
collect (IMIN (ITIMES MAXMENUWIDTH (STRINGWIDTH (QUOTE A)
BFONT))
(IMAX WIDTHALL (STRINGWIDTH (IDLARRAY-GETDIMLABEL
IDLARRAY DIM)
FONT)
(bind (LEVWIDTH ← 0) for LEVEL from 0
upto (IDLARRAY-DIMENSION IDLARRAY DIM)
do (SETQ LEVWIDTH
(IMAX LEVWIDTH
(STRINGWIDTH (
IDLARRAY-GETLEVELLABEL
IDLARRAY DIM
LEVEL)
BFONT)))
finally (RETURN LEVWIDTH]
[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 0 upto RANK as FIELDWIDTH in FIELDWIDTHS
collect (BQUOTE (TYPE TITLE ID , (PACK* (QUOTE I)
I)
LABEL , (TRUNCLABEL (
IDLARRAY-GETDIMLABEL
IDLARRAY I)
FONT
FIELDWIDTH)
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 as
FIELDWIDTH
in FIELDWIDTHS
collect (BQUOTE (TYPE MOMENTARY ID , (PACK*
(QUOTE LEVEL)
I)
LABEL ,
(TRUNCLABEL
(if (EQ LEVEL (QUOTE ALL))
then LEVEL
else (IDLARRAY-LEVELLABEL
IDLARRAY I LEVEL))
BFONT FIELDWIDTH)
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)))
SWINDOW])
(IIDL.INDICES
[LAMBDA (DISPLAYWINDOW ROW COLUMN) (* jop: "24-Jun-86 13:08")
(* * Display the indices of the selected item)
(LET* [(MAINW (MAINWINDOW DISPLAYWINDOW))
(IDLARRAY (WINDOWPROP MAINW (QUOTE IDLARRAY)))
(CURRENTLEVELS (WINDOWPROP MAINW (QUOTE CURRENTLEVELS)))
(PRTWINDOW (WINDOWPROP MAINW (QUOTE PRTWINDOW]
(PRINTOUT PRTWINDOW T "Indices: ")
(bind FIRSTFLG for LEVEL in CURRENTLEVELS as DIM from 0
do (if (EQ LEVEL (QUOTE ALL))
then (if FIRSTFLG
then (PRINTOUT PRTWINDOW , (IDLARRAY-LEVELLABEL IDLARRAY DIM
COLUMN)
,)
else (SETQ FIRSTFLG T)
(PRINTOUT PRTWINDOW , (IDLARRAY-LEVELLABEL IDLARRAY DIM ROW)
,))
else (PRINTOUT PRTWINDOW , (IDLARRAY-LEVELLABEL IDLARRAY DIM LEVEL)
,])
(IIDL.LAYOUTMENULIST
[LAMBDA (MENULIST GROUPWIDTH BFONT FONT WHITESPACE FIELDWIDTHS)
(* jop: "24-Jun-86 13:48")
(* * 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 (LISTREF 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.MAKE-SLICE
[LAMBDA (IDLARRAY LEVELS) (* jop: "24-Jun-86 13:43")
(* *)
(LET* ((RANK (IDLARRAY-RANK IDLARRAY))
(DIMS (IDLARRAY-DIMS IDLARRAY))
(OFFSETCONSTANT 0)
(SCANDIMS (bind (PROD ← 1)
RESULT for DIM in (REVERSE DIMS)
do (push RESULT PROD)
(SETQ PROD (ITIMES PROD DIM))
finally (RETURN RESULT)))
SELECTEDDIMS OFFSETS)
[for LEVEL in LEVELS as DIM from 0 as SCANDIM in SCANDIMS
do (if (EQ LEVEL (QUOTE ALL))
then (push SELECTEDDIMS DIM)
(push OFFSETS SCANDIM)
else (SETQ OFFSETCONSTANT (IPLUS OFFSETCONSTANT (ITIMES LEVEL SCANDIM]
(create IIDL.ARRAYSLICE
IDLARRAY ← IDLARRAY
SELECTEDDIMS ←(DREVERSE SELECTEDDIMS)
OFFSETS ←(DREVERSE OFFSETS)
OFFSETCONSTANT ← OFFSETCONSTANT
LINEARIZEDARRAY ←(EARRAY-LINEARIZE (IDLARRAY-CMLARRAY IDLARRAY])
(IIDL.MEASUREMENULIST
[LAMBDA (MENULIST MINWHITESPACE FONT FIELDWIDTHS) (* jop: "24-Jun-86 13:46")
(* * 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 (LISTREF 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: "24-Jun-86 13:11")
(* * Display the slice descibed by the windowprop LEVELS)
(LET* [(MAINW (MAINWINDOW MENUWINDOW))
(IDLARRAY (WINDOWPROP MAINW (QUOTE IDLARRAY)))
(DISPLAYGROUP (WINDOWPROP MAINW (QUOTE DISPLAYGROUP)))
[TOPRIGHT (LET [(REGION (WINDOWPROP MAINW (QUOTE REGION]
(create POSITION
XCOORD ←(SUB1 (fetch LEFT of REGION))
YCOORD ←(fetch TOP of REGION]
[LEVELS (for I from 0 upto (IDLARRAY-RANK IDLARRAY)
collect (FM.ITEMPROP (FM.ITEMFROMID MENUWINDOW (PACK* (QUOTE LEVEL)
I))
(QUOTE LEVEL]
(RANK (for LEVEL in LEVELS count (EQ LEVEL (QUOTE ALL]
(if (OR (EQ RANK 1)
(EQ RANK 2))
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: "24-Jun-86 13:50")
(* * Get a new LEVEL for dim DIM)
(LET ((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"))
(if (ILESSP (IDLARRAY-DIMENSION
IDLARRAY DIM)
10)
then (for I from 0
upto (
IDLARRAY-DIMENSION
IDLARRAY DIM)
collect
(LIST (
IDLARRAY-GETLEVELLABEL
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))
(CHOOSE (RNUMBER "Choose a level" NIL NIL NIL T))
NEWVALUE))
(if LEVEL
then (FM.ITEMPROP ITEM (QUOTE LEVEL)
LEVEL)
(FM.CHANGELABEL ITEM MENUWINDOW (if (EQ LEVEL (QUOTE ALL))
then (QUOTE ALL)
else (TRUNCLABEL (IDLARRAY-GETLEVELLABEL
IDLARRAY DIM LEVEL)
(FM.ITEMPROP
ITEM
(QUOTE FONT))
(LISTREF FIELDWIDTHS
DIM])
(IIDL.MENUW.SELECTIT
[LAMBDA (ITEM MENUWINDOW BUTTONS) (* jop: "24-Jun-86 13:17")
(* *)
(DECLARE (SPECVARS IT))
(LET* [(MAINW (MAINWINDOW MENUWINDOW))
(IDLARRAY (WINDOWPROP MAINW (QUOTE IDLARRAY)))
(LEVELS (for I from 0 upto (IDLARRAY-RANK IDLARRAY)
collect (FM.ITEMPROP (FM.ITEMFROMID MENUWINDOW (PACK* (QUOTE LEVEL)
I))
(QUOTE LEVEL]
(PROMPTPRINT "IT bound to " (SETQ IT (AT IDLARRAY (ASVECTOR LEVELS])
(IIDL.MENUW.SHOW
[LAMBDA (ITEM MENUWINDOW BUTTONS) (* jop: "24-Jun-86 13:18")
(* *)
(PROG [(FIELDWIDTHS (WINDOWPROP MENUWINDOW (QUOTE FIELDWIDTHS)))
(DISPLAYEDLEVELS (WINDOWPROP (MAINWINDOW MENUWINDOW)
(QUOTE CURRENTLEVELS)))
(IDLARRAY (WINDOWPROP (MAINWINDOW MENUWINDOW)
(QUOTE IDLARRAY]
(for DIM from 0 upto (IDLARRAY-RANK 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)
else (TRUNCLABEL (LEVELORLABEL IDLARRAY
DIM
LEVEL)
(FM.ITEMPROP
ITEM
(QUOTE FONT))
FIELDWIDTH])
(IIDL.ROWPROPCOMMANDFN
[LAMBDA (ROWPROP SLICE DISPLAYW) (* jop: "24-Jun-86 13:59")
(* *)
(LET* ([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 (WINDOWPROP MAINW (QUOTE IDLARRAY)))
(CURRENTLEVELS (WINDOWPROP MAINW (QUOTE CURRENTLEVELS)))
(MENUW (WINDOWPROP MAINW (QUOTE MENUWINDOW)))
(DIM (IIDL.SLICE-SELECTED-DIM SLICE 0))
(LEVEL (IDLARRAY-LEVELINDEX IDLARRAY DIM ROWPROP)))
(SELECTQ (MENU ROWMENU)
(DELLABEL (if (LITATOM (IDLARRAY-LEVELLABEL IDLARRAY DIM ROWPROP))
then (* delete the label)
(IDLARRAY-SETLEVELLABEL IDLARRAY DIM LEVEL 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)
(IDLARRAY-SETLEVELLABEL IDLARRAY DIM LEVEL
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 IDLARRAY
(ASVECTOR (for I from 0
as L in CURRENTLEVELS
collect
(if (EQ I DIM)
then LEVEL
else L]
NIL])
(IIDL.SETVALUE
[LAMBDA (DISPLAYWINDOW ROW COLUMN) (* jop: "24-Jun-86 13:56")
(* * In the zero and one-d cases COLUMN should be NIL, and ROW is the only index)
(LET* ((MAINW (MAINWINDOW DISPLAYWINDOW))
(IDLARRAY (WINDOWPROP MAINW (QUOTE IDLARRAY)))
(SLICE (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 (EQ (IIDL.SLICE-RANK SLICE)
2)
then (TWODINSPECT.REPLACE DISPLAYWINDOW (IDLARRAY-LEVELLABEL IDLARRAY
(
IIDL.SLICE-SELECTED-DIM
SLICE 0)
ROW)
(IDLARRAY-LEVELLABEL IDLARRAY (IIDL.SLICE-SELECTED-DIM
SLICE 1)
COLUMN)
NEWVALUE)
else (ONEDINSPECT.REPLACE DISPLAYWINDOW (IDLARRAY-LEVELLABEL IDLARRAY
(
IIDL.SLICE-SELECTED-DIM
SLICE 0)
ROW)
NEWVALUE])
(IIDL.SLICE-SELECTED-DIM
[LAMBDA (SLICE DIM) (* jop: "24-Jun-86 11:43")
(* *)
(LISTREF (fetch (IIDL.ARRAYSLICE SELECTEDDIMS) of SLICE)
DIM])
(IIDL.SLICE-RANK
[LAMBDA (SLICE) (* jop: "24-Jun-86 11:43")
(* *)
(LENGTH (fetch (IIDL.ARRAYSLICE SELECTEDDIMS) of SLICE])
(IIDL.SLICE-REF
[LAMBDA ARGS (* jop: "24-Jun-86 12:07")
(* *)
(if (ILESSP ARGS 1)
then (HELP "Need at least one arg"))
(LET* ((SLICE (ARG ARGS 1))
(IDLARRAY (fetch (IIDL.ARRAYSLICE IDLARRAY) of SLICE))
(LINEARIZEDARRAY (fetch (IIDL.ARRAYSLICE LINEARIZEDARRAY) of SLICE))
(SELECTEDDIMS (fetch (IIDL.ARRAYSLICE SELECTEDDIMS) of SLICE))
(OFFSETS (fetch (IIDL.ARRAYSLICE OFFSETS) of SLICE))
(OFFSETCONSTANT (fetch (IIDL.ARRAYSLICE OFFSETCONSTANT) of SLICE)))
(AREF LINEARIZEDARRAY
(IPLUS OFFSETCONSTANT
(for I from 2 as OFFSET in OFFSETS as DIM in SELECTEDDIMS
sum (ITIMES OFFSET (IDLARRAY-LEVELINDEX IDLARRAY DIM
(ARG ARGS I])
(IIDL.SLICE-SET
[LAMBDA ARGS (* jop: "24-Jun-86 13:51")
(* *)
(if (ILESSP ARGS 2)
then (HELP "Need at least two args"))
(LET* ((NEWVALUE (ARG ARGS 1))
(SLICE (ARG ARGS 2))
(IDLARRAY (fetch (IIDL.ARRAYSLICE IDLARRAY) of SLICE))
(LINEARIZEDARRAY (fetch (IIDL.ARRAYSLICE LINEARIZEDARRAY) of SLICE))
(SELECTEDDIMS (fetch (IIDL.ARRAYSLICE SELECTEDDIMS) of SLICE))
(OFFSETS (fetch (IIDL.ARRAYSLICE OFFSETS) of SLICE))
(OFFSETCONSTANT (fetch (IIDL.ARRAYSLICE OFFSETCONSTANT) of SLICE)))
(ASET NEWVALUE LINEARIZEDARRAY
(IPLUS OFFSETCONSTANT
(for I from 3 as OFFSET in OFFSETS as DIM in SELECTEDDIMS
sum (ITIMES OFFSET (IDLARRAY-LEVELINDEX IDLARRAY DIM
(ARG ARGS I])
(IIDL.STATUSW.BUTTONEVENTFN
[LAMBDA (WINDOW) (* jop: "24-Jun-86 12:36")
(* *)
(TOTOPW WINDOW)
(if (MOUSESTATE MIDDLE)
then (LET [[TITLEMENU (CONSTANT (create MENU
ITEMS ←(QUOTE (("Refetch" (QUOTE REFETCH)
"Refetch the array")
("IT ← Datum" (QUOTE IT)
"Bind IT to the inspected array"]
(MENUW (WINDOWPROP WINDOW (QUOTE MENUWINDOW)))
(IDLARRAY (WINDOWPROP WINDOW (QUOTE IDLARRAY]
(SELECTQ (MENU TITLEMENU)
[REFETCH (if (for DIM in (IDLARRAY-DIMS IDLARRAY)
always (IGREATERP DIM 0))
then (if (IGREATERP (IDLARRAY-RANK 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: "24-Jun-86 13:26")
(* *)
(if (MOUSESTATE MIDDLE)
then (LET* [[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 (WINDOWPROP MAINW (QUOTE MENUWINDOW)))
(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: "24-Jun-86 14:05")
(* *)
(PROG ([STANDARDMENU (CONSTANT (create MENU
ITEMS ←(QUOTE (("Set" (QUOTE SET)
"Set element")
("Indices" (QUOTE INDICES)
"Display indices")
("IT ← Selection" (QUOTE SETIT)
"Bind IT to element"]
[INSPECTMENU (CONSTANT (create MENU
ITEMS ←(QUOTE (("Set" (QUOTE SET)
"Set element")
("Indices" (QUOTE INDICES)
"Display indices")
("IT ← Selection" (QUOTE SETIT)
"Bind IT to element")
("Inspect" (QUOTE INSPECT)
"Inspect this item"]
(VALUE (ARG ARGS 1))
INDEX ROW COLUMN SLICE DISPLAYWINDOW RANK)
(if (EQ ARGS 4)
then (* must be in the one-d case)
(SETQ SLICE (ARG ARGS 3))
(SETQ INDEX (ARG ARGS 2))
(SETQ DISPLAYWINDOW (ARG ARGS 4))
else (* must be in the two-d case)
(SETQ SLICE (ARG ARGS 4))
(SETQ ROW (ARG ARGS 2))
(SETQ COLUMN (ARG ARGS 3))
(SETQ DISPLAYWINDOW (ARG ARGS 5)))
(SETQ RANK (IIDL.SLICE-RANK SLICE))
(SELECTQ (if (ATOM VALUE)
then (MENU STANDARDMENU)
else (MENU INSPECTMENU))
(SET (SELECTQ RANK
(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
(1 (IIDL.INDICES DISPLAYWINDOW INDEX))
(2 (IIDL.INDICES DISPLAYWINDOW ROW COLUMN))
(SHOULDNT)))
(INSPECT (INSPECT VALUE))
NIL])
(INSPECTIDLARRAY
[LAMBDA (IDLARRAY ASTYPE WHERE) (* jop: "24-Jun-86 11:23")
(* * Top level entry point into the IDLARRAY inspector)
(PROG ((DIMS (IDLARRAY-DIMS IDLARRAY))
(RANK (IDLARRAY-RANK IDLARRAY))
(FONT (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 0]
[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])
(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])
)
(ADDTOVAR INSPECTMACROS (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: EVAL@COMPILE
(DATATYPE IIDL.ARRAYSLICE (IDLARRAY SELECTEDDIMS OFFSETS OFFSETCONSTANT LINEARIZEDARRAY))
]
(/DECLAREDATATYPE (QUOTE IIDL.ARRAYSLICE)
(QUOTE (POINTER POINTER POINTER POINTER POINTER))
(QUOTE ((IIDL.ARRAYSLICE 0 POINTER)
(IIDL.ARRAYSLICE 2 POINTER)
(IIDL.ARRAYSLICE 4 POINTER)
(IIDL.ARRAYSLICE 6 POINTER)
(IIDL.ARRAYSLICE 8 POINTER)))
(QUOTE 10))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA IIDL.VALUECOMMANDFN IIDL.SLICE-SET IIDL.SLICE-REF)
)
(PUTPROPS IDLARRAYINSPECTOR COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1468 51283 (IDLARRAY-INSPECT-P 1478 . 1740) (IIDL.ATTACHDISPLAY 1742 . 2356) (
IIDL.CHANGECOLUMNLABEL 2358 . 5658) (IIDL.CHANGEROWLABEL 5660 . 8736) (IIDL.COLUMNPROPCOMMANDFN 8738
. 11797) (IIDL.DETACHDISPLAY 11799 . 12088) (IIDL.DISPLAYSLICE 12090 . 13391) (IIDL.DOWINDOWCOMFN
13393 . 14280) (IIDL.GETREGIONFN 14282 . 15819) (IIDL.GETSTATUSWINDOWGROUP 15821 . 24228) (
IIDL.INDICES 24230 . 25187) (IIDL.LAYOUTMENULIST 25189 . 27467) (IIDL.LAYOUTSTATUSLIST 27469 . 29723)
(IIDL.MAKE-SLICE 29725 . 30784) (IIDL.MEASUREMENULIST 30786 . 31737) (IIDL.MEASURESTATUSLIST 31739 .
32504) (IIDL.MENUW.APPLY 32506 . 33765) (IIDL.MENUW.GETLEVEL 33767 . 35664) (IIDL.MENUW.SELECTIT 35666
. 36258) (IIDL.MENUW.SHOW 36260 . 37319) (IIDL.ROWPROPCOMMANDFN 37321 . 40299) (IIDL.SETVALUE 40301
. 41550) (IIDL.SLICE-SELECTED-DIM 41552 . 41782) (IIDL.SLICE-RANK 41784 . 41992) (IIDL.SLICE-REF
41994 . 42869) (IIDL.SLICE-SET 42871 . 43788) (IIDL.STATUSW.BUTTONEVENTFN 43790 . 45747) (
IIDL.STATUSW.REPAINTFN 45749 . 46551) (IIDL.TITLECOMMANDFN 46553 . 47491) (IIDL.VALUECOMMANDFN 47493
. 49614) (INSPECTIDLARRAY 49616 . 50876) (TRUNCLABEL 50878 . 51281)))))
STOP