-
-
Notifications
You must be signed in to change notification settings - Fork 24
/
Copy pathCMLARRAYINSPECTOR
632 lines (549 loc) · 34.7 KB
/
CMLARRAYINSPECTOR
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "31-Dec-93 12:26:35" {DSK}<king>export>lispcore>sources>CMLARRAYINSPECTOR.;2 34659
changes to%: (FILES TWODINSPECTOR)
(VARS CMLARRAYINSPECTORCOMS)
(FNS ICMLARRAY ICMLARRAY.GETREGIONFN ICMLARRAY.GETMENUWGROUP)
previous date%: "17-Aug-90 14:15:43" {DSK}<king>export>lispcore>sources>CMLARRAYINSPECTOR.;1)
(* ; "
Copyright (c) 1985, 1986, 1987, 1990, 1993 by Venue & Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT CMLARRAYINSPECTORCOMS)
(RPAQQ CMLARRAYINSPECTORCOMS
[
(* ;; "Inspector for Common-Lisp arrays.")
(* ;; "Functions used to compute load-time constants later (so must come first!):")
(FNS \CREATE.INSPECTABLEMENU \CREATE.SETABLEMENU \CREATE.TITLEMENU)
(FNS CREATEARRAYSLICE GET.MENU.LIST ICMLARRAY ICMLARRAY.ATTACHDISPLAY ICMLARRAY.DETACHDISPLAY
ICMLARRAY.DOWINDOWCOMFN ICMLARRAY.INDICES ICMLARRAY.SETVALUE ICMLARRAY.TITLECOMMANDFN
ICMLARRAY.VALUECOMMANDFN ICMLARRAY.DISPLAYSLICE ICMLARRAY.GETREGIONFN
ICMLARRAY.GETMENUWGROUP ICMLARRAY.MENUW.APPLY ICMLARRAY.MENUW.GETLEVEL
ICMLARRAY.MENUW.SHOW SLICEDIMENSION SLICERANK SLICEREF SLICESET ZEROD.FETCHFN
ZEROD.STOREFN)
[ADDVARS (INSPECTMACROS ((FUNCTION CL:ARRAYP) . ICMLARRAY]
(INITRECORDS ICML.ARRAYSLICE)
(FILES TWODINSPECTOR FREEMENU)
(DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS ICML.ARRAYSLICE))
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T))
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA SLICESET SLICEREF
ICMLARRAY.VALUECOMMANDFN
])
(* ;; "Inspector for Common-Lisp arrays.")
(* ;; "Functions used to compute load-time constants later (so must come first!):")
(DEFINEQ
(\CREATE.INSPECTABLEMENU
[LAMBDA NIL
(create MENU
ITEMS _ '(("Inspect" 'INSPECT "Inspect element")
("Set" 'SET "Set element")
("Indices" 'INDICES "Display indices")
("IT _ Selection" 'SETIT "Bind IT to element"])
(\CREATE.SETABLEMENU
[LAMBDA NIL
(create MENU
ITEMS _ '(("Set" 'SET "Set element")
("Indices" 'INDICES "Display indices")
("IT _ Selection" 'SETIT "Bind IT to element"])
(\CREATE.TITLEMENU
[LAMBDA NIL
(create MENU
ITEMS _ '(("Refetch" 'REFETCH "Refetch the array")
("IT _ Datum" 'IT "Bind IT to the inspected array"])
)
(DEFINEQ
(CREATEARRAYSLICE
[LAMBDA (CMLARRAY LEVELS) (* jop%: "22-May-86 11:53")
(* * An ARRAYSLICE is a zero, one or two dimensional slice of a CMLARRAY.
LEVELS is a list of length (CL:ARRAY-RANK CMLARRAY) which descibes the slice.
The atom ALL indications that that dimension is unrestricted)
(LET* ((RANK (CL:ARRAY-RANK CMLARRAY))
(DIMS (CL:ARRAY-DIMENSIONS CMLARRAY))
(OFFSETCONSTANT 0)
(SCANDIMS (bind (PROD _ 1)
RESULT for DIM in (REVERSE DIMS) do (push RESULT PROD)
(SETQ PROD (ITIMES PROD DIM))
finally (RETURN RESULT)))
SELECTIONDIMS OFFSETS)
[for LEVEL in LEVELS as DIM in DIMS as SCANDIM in SCANDIMS
do (if (EQ LEVEL 'ALL)
then (push SELECTIONDIMS DIM)
(push OFFSETS SCANDIM)
else (SETQ OFFSETCONSTANT (IPLUS OFFSETCONSTANT (ITIMES LEVEL SCANDIM]
(create ICML.ARRAYSLICE
SELECTEDDIMS _ (DREVERSE SELECTIONDIMS)
OFFSETS _ (DREVERSE OFFSETS)
OFFSETCONSTANT _ OFFSETCONSTANT
LINEARIZEDARRAY _ (%%FLATTEN-ARRAY CMLARRAY])
(GET.MENU.LIST
[LAMBDA (CMLARRAY DISPLAYEDLEVELS MAXWIDTH FONT BFONT) (* ; "Edited 5-Apr-87 18:05 by jop")
(LET*
[(RANK (CL:ARRAY-RANK CMLARRAY))
(MENU-P (AND (IGREATERP RANK 1)
(for DIM in (CL:ARRAY-DIMENSIONS CMLARRAY) always (NEQ DIM 0]
`((PROPS FONT ,FONT)
,[if MENU-P
then `((TYPE MOMENTARY LABEL "SHOW" FONT ,BFONT BOX 1 SELECTEDFN ICMLARRAY.MENUW.SHOW)
(TYPE MOMENTARY LABEL "APPLY" FONT ,BFONT BOX 1 SELECTEDFN ICMLARRAY.MENUW.APPLY]
((GROUP
(PROPS FORMAT TABLE)
((TYPE DISPLAY LABEL "Element type:")
(TYPE DISPLAY LABEL ,(MKSTRING (CL:ARRAY-ELEMENT-TYPE CMLARRAY)) FONT ,BFONT))
,@[IF (SIMPLE-ARRAY-P CMLARRAY)
THEN `[((TYPE DISPLAY LABEL "Simple-p:")
(TYPE DISPLAY LABEL T FONT ,BFONT]
ELSE `(,@[IF (CL:ADJUSTABLE-ARRAY-P CMLARRAY)
THEN `[((TYPE DISPLAY LABEL "Adjustable-p:")
(TYPE DISPLAY LABEL T FONT ,BFONT]
ELSEIF (EXTENDABLE-ARRAY-P CMLARRAY)
THEN `(((TYPE DISPLAY LABEL "Extendable-p:")
(TYPE DISPLAY LABEL T FONT ,BFONT]
,@[IF (CL:ARRAY-HAS-FILL-POINTER-P CMLARRAY)
THEN `(((TYPE DISPLAY LABEL "Fill-pointer-p:")
(TYPE DISPLAY LABEL T FONT ,BFONT]
,@(IF (DISPLACED-ARRAY-P CMLARRAY)
THEN `(((TYPE DISPLAY LABEL "Displaced-p:")
(TYPE DISPLAY LABEL T FONT ,BFONT]
((TYPE DISPLAY LABEL "Rank:")
(TYPE DISPLAY LABEL ,RANK FONT ,BFONT))
,@[if (ILESSP RANK 2)
then `[((TYPE DISPLAY LABEL "Total-size:")
(TYPE DISPLAY LABEL ,(CL:ARRAY-TOTAL-SIZE CMLARRAY) FONT ,BFONT]
else `([(TYPE DISPLAY LABEL "Dimension:")
,@(for I from 0 to (SUB1 RANK) collect `(TYPE DISPLAY LABEL ,I FONT ,BFONT]
((TYPE DISPLAY LABEL "Levels:")
,@(for I from 0 to (SUB1 RANK)
collect `(TYPE DISPLAY LABEL ,(CL:ARRAY-DIMENSION CMLARRAY I) FONT
,BFONT]
,@(if MENU-P
then `(((TYPE DISPLAY LABEL "Shown:")
,@(for LEVEL in DISPLAYEDLEVELS as I from 0
collect `(TYPE MOMENTARY ID ,(PACK* 'LEVEL I) LABEL ,LEVEL FONT
,BFONT MAXWIDTH ,MAXWIDTH BOX 1 DIM ,I SELECTEDFN
ICMLARRAY.MENUW.GETLEVEL])
(ICMLARRAY
[LAMBDA (CMLARRAY ASTYPE WHERE) (* ; "Edited 5-Apr-87 17:26 by jop")
(* ;; "Top level entry point into the CMLARRAY inspector")
(LET* ((RANK (CL:ARRAY-RANK CMLARRAY))
(FONT (DEFAULTFONT 'DISPLAY))
(DISPLAYEDLEVELS (bind (LESS1RANK _ (SUB1 RANK)) for I from 0
to (SUB1 RANK) collect (if (ILESSP (IDIFFERENCE LESS1RANK
I)
2)
then 'ALL
else 0)))
DISPLAYGROUP MENUGROUP TOPLEFT)
[if (for DIM in (CL:ARRAY-DIMENSIONS CMLARRAY) always (IGREATERP DIM 0))
then (SETQ DISPLAYGROUP (ICMLARRAY.DISPLAYSLICE CMLARRAY DISPLAYEDLEVELS WHERE)
)
(SETQ TOPLEFT (create POSITION
XCOORD _ (ADD1 (fetch (REGION RIGHT) of (
WINDOWREGION
DISPLAYGROUP
)))
YCOORD _ (fetch (REGION TOP) of (WINDOWREGION
DISPLAYGROUP]
(SETQ MENUGROUP (ICMLARRAY.GETMENUWGROUP CMLARRAY FONT DISPLAYEDLEVELS TOPLEFT))
(if DISPLAYGROUP
then (ICMLARRAY.ATTACHDISPLAY DISPLAYGROUP MENUGROUP DISPLAYEDLEVELS))
MENUGROUP])
(ICMLARRAY.ATTACHDISPLAY
[LAMBDA (DISPLAYGROUP STATUSGROUP DISPLAYEDLEVELS) (* jop%: "24-Nov-85 15:45")
(ATTACHWINDOW DISPLAYGROUP STATUSGROUP 'LEFT 'TOP)
(for W in (CONS DISPLAYGROUP (ALLATTACHEDWINDOWS DISPLAYGROUP))
do (WINDOWPROP W 'DOWINDOWCOMFN (FUNCTION ICMLARRAY.DOWINDOWCOMFN)))
(WINDOWPROP STATUSGROUP 'DISPLAYGROUP DISPLAYGROUP)
(WINDOWPROP STATUSGROUP 'CURRENTLEVELS DISPLAYEDLEVELS])
(ICMLARRAY.DETACHDISPLAY
[LAMBDA (STATUSGROUP) (* jop%: " 4-Oct-85 17:53")
(* *)
(PROG [(DISPLAYGROUP (WINDOWPROP STATUSGROUP 'DISPLAYGROUP]
(DETACHWINDOW DISPLAYGROUP)
(CLOSEW DISPLAYGROUP])
(ICMLARRAY.DOWINDOWCOMFN
[LAMBDA (WINDOW) (* jop%: "24-Nov-85 15:45")
(* * Pass on the usual comms, except for SHAPEW)
(PROG ((PASSTOMAINCOMS (WINDOWPROP WINDOW 'PASSTOMAINCOMS))
(COM (MENU WindowMenu)))
(if COM
then (LET* [(CENTRAL (CENTRALWINDOW WINDOW))
(DISPLAYGROUP (WINDOWPROP CENTRAL 'DISPLAYGROUP]
(if (EQ COM 'SHAPEW)
then [SHAPEW DISPLAYGROUP (GETREGION NIL NIL NIL (FUNCTION
ICMLARRAY.GETREGIONFN)
(CONS DISPLAYGROUP 'CLOSED]
elseif (MEMB COM PASSTOMAINCOMS)
then (APPLY* COM CENTRAL)
else (APPLY* COM WINDOW])
(ICMLARRAY.INDICES
[LAMBDA (DISPLAYWINDOW ROW COLUMN) (* ; "Edited 5-Apr-87 17:11 by jop")
(* ;; "Display the indices of the selected item")
(LET* [(MAINW (MAINWINDOW DISPLAYWINDOW))
(CURRENTLEVELS (WINDOWPROP MAINW 'CURRENTLEVELS))
(PRTWINDOW (WINDOWPROP MAINW '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 'ALL)
then (if FIRSTFLG
then (PRINTOUT PRTWINDOW %, COLUMN %,)
else (SETQ FIRSTFLG T)
(PRINTOUT PRTWINDOW %, ROW %,))
else (PRINTOUT PRTWINDOW %, LEVEL %,])
(ICMLARRAY.SETVALUE
[LAMBDA (DISPLAYWINDOW ROW COLUMN) (* ; "Edited 8-Apr-87 16:47 by jop")
(* ;; "In the zero and one-d cases COLUMN should be NIL, and ROW is the only index")
(PROG ((MAINW (MAINWINDOW DISPLAYWINDOW))
[SLICERANK (SLICERANK (WINDOWPROP DISPLAYWINDOW 'DATUM]
PRTWINDOW NEWVALUE)
(SETQ PRTWINDOW (WINDOWPROP MAINW 'PRTWINDOW))
(WITH-INSPECTOR-ENV (WINDOWPROP DISPLAYWINDOW 'PROFILE)
(RESETLST (RESETSAVE (TTYDISPLAYSTREAM PRTWINDOW))
(RESETSAVE (TTY.PROCESS (THIS.PROCESS)))
(CLEARBUF T T)
(PRINTOUT T T "Eval> ")
(SETQ NEWVALUE (CL:FUNCALL XCL:*EVAL-FUNCTION* (LISPXREAD T T)))
(* ;
"clear tty buffer because it sometimes has stuff left.")
(CLEARBUF T T)))
(if (EQL SLICERANK 2)
then (TWODINSPECT.REPLACE DISPLAYWINDOW ROW COLUMN NEWVALUE)
else (ONEDINSPECT.REPLACE DISPLAYWINDOW ROW NEWVALUE])
(ICMLARRAY.TITLECOMMANDFN
[LAMBDA (WINDOW) (* ; "Edited 20-Jul-90 20:02 by yabu")
(if (MOUSESTATE MIDDLE)
then (LET* ((TITLEMENU (CONSTANT (\CREATE.TITLEMENU)))
(* ; "Original was (create MENU ITEMS _ '((%"Refetch%" 'REFETCH %"Refetch the array%") (%"IT _ Datum%" 'IT %"Bind IT to the inspected array%"))).")
(* ;
"Changed by yabu.fx, for SUNLOADUP without DWIM.")
(CMLARRAY (WINDOWPROP (MAINWINDOW WINDOW)
'CMLARRAY))
(MENUW (MAINWINDOW WINDOW)))
(SELECTQ (MENU TITLEMENU)
(REFETCH (ICMLARRAY.MENUW.SHOW (FM.GETITEM 'SHOW NIL MENUW)
MENUW)
(LET [(DISPLAYGROUP (WINDOWPROP MENUW 'DISPLAYGROUP))
(TOPRIGHT (with REGION (WINDOWPROP MENUW 'REGION)
(create POSITION
XCOORD _ (SUB1 LEFT)
YCOORD _ TOP)))
(LEVELS (WINDOWPROP MENUW 'CURRENTLEVELS]
(ICMLARRAY.DETACHDISPLAY MENUW)
(SETQ DISPLAYGROUP (XCL:WITH-PROFILE (WINDOWPROP
DISPLAYGROUP
'PROFILE)
(ICMLARRAY.DISPLAYSLICE
CMLARRAY LEVELS
DISPLAYGROUP TOPRIGHT)))
(ICMLARRAY.ATTACHDISPLAY DISPLAYGROUP MENUW LEVELS)))
(IT (SETQ IT CMLARRAY)
(PROMPTPRINT "IT bound to " CMLARRAY))
NIL])
(ICMLARRAY.VALUECOMMANDFN
[LAMBDA ARGS (* ; "Edited 20-Jul-90 19:59 by yabu")
(PROG ((INSPECTABLEMENU (CONSTANT (\CREATE.INSPECTABLEMENU)))
(* ; "Original was (create MENU ITEMS _ '((%"Inspect%" 'INSPECT %"Inspect element%") (%"Set%" 'SET %"Set element%") (%"Indices%" 'INDICES %"Display indices%") (%"IT _ Selection%" 'SETIT %"Bind IT to element%"))).")
(* ;
"Changed by yabu.fx, for SUNLOADUP without DWIM.")
(SETABLEMENU (CONSTANT (\CREATE.SETABLEMENU)))(* ; "Original was (create MENU ITEMS _ '((%"Set%" 'SET %"Set element%") (%"Indices%" 'INDICES %"Display indices%") (%"IT _ Selection%" 'SETIT %"Bind IT to element%"))).")
(* ;
"Changed by yabu.fx, for SUNLOADUP without DWIM.")
(VALUE (ARG ARGS 1))
INDEX ROW COLUMN SLICE DISPLAYWINDOW SLICERANK)
(if (EQL ARGS 4)
then (* ; "must be in the one-d case")
(SETQ INDEX (ARG ARGS 2))
(SETQ SLICE (ARG ARGS 3))
(SETQ DISPLAYWINDOW (ARG ARGS 4))
else (* ; "must be in the two-d case")
(SETQ ROW (ARG ARGS 2))
(SETQ COLUMN (ARG ARGS 3))
(SETQ SLICE (ARG ARGS 4))
(SETQ DISPLAYWINDOW (ARG ARGS 5)))
(SETQ SLICERANK (SLICERANK SLICE))
(SELECTQ (if (OR (NUMBERP VALUE)
(NULL VALUE))
then (MENU SETABLEMENU)
else (MENU INSPECTABLEMENU))
(INSPECT (INSPECT VALUE))
(SET (SELECTQ SLICERANK
(0 (ICMLARRAY.SETVALUE DISPLAYWINDOW INDEX))
(1 (ICMLARRAY.SETVALUE DISPLAYWINDOW INDEX))
(2 (ICMLARRAY.SETVALUE DISPLAYWINDOW ROW COLUMN))
(SHOULDNT)))
(SETIT (SETQ IT (SELECTQ SLICERANK
(0 (SLICEREF SLICE))
(1 (SLICEREF SLICE INDEX))
(2 (SLICEREF SLICE ROW COLUMN))
(SHOULDNT))) (* ; "Nice to have some feedback")
(PROMPTPRINT (CONCAT "IT bound to " VALUE)))
(INDICES (SELECTQ SLICERANK
(0 (ICMLARRAY.INDICES DISPLAYWINDOW))
(1 (ICMLARRAY.INDICES DISPLAYWINDOW INDEX))
(2 (ICMLARRAY.INDICES DISPLAYWINDOW ROW COLUMN))
(SHOULDNT)))
NIL])
(ICMLARRAY.DISPLAYSLICE
[LAMBDA (CMLARRAY LEVELS WHERE TOPRIGHT) (* ; "Edited 5-Apr-87 17:15 by jop")
(LET ((SLICE (CREATEARRAYSLICE CMLARRAY LEVELS)))
(SELECTQ (SLICERANK SLICE)
(0 (ONEDINSPECTW.CREATE SLICE '("Entry") (FUNCTION ZEROD.FETCHFN)
(FUNCTION ZEROD.STOREFN)
(FUNCTION ICMLARRAY.VALUECOMMANDFN)
NIL "Display Window" (FUNCTION ICMLARRAY.TITLECOMMANDFN)
WHERE TOPRIGHT))
(1 (ONEDINSPECTW.CREATE SLICE (for I from 0 to (SUB1 (SLICEDIMENSION SLICE 0))
collect I)
(FUNCTION SLICEREF)
(FUNCTION SLICESET)
(FUNCTION ICMLARRAY.VALUECOMMANDFN)
NIL "Display Window" (FUNCTION ICMLARRAY.TITLECOMMANDFN)
WHERE TOPRIGHT))
(2 (TWODINSPECTW.CREATE SLICE (for I from 0 to (SUB1 (SLICEDIMENSION SLICE 0))
collect I)
(for I from 0 to (SUB1 (SLICEDIMENSION SLICE 1)) collect I)
(FUNCTION SLICEREF)
(FUNCTION SLICESET)
(FUNCTION ICMLARRAY.VALUECOMMANDFN)
NIL NIL "Display Window" (FUNCTION ICMLARRAY.TITLECOMMANDFN)
WHERE TOPRIGHT))
(SHOULDNT "Should not happen"])
(ICMLARRAY.GETREGIONFN
[LAMBDA (FIXEDPOINT MOVINGPOINT INFO) (* ; "Edited 5-Apr-87 17:26 by jop")
(* ;; "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 (REGION RIGHT) of WINDOWREGION))
YCOORD _ (ADD1 (fetch (REGION TOP) of WINDOWREGION]
else (if (EQ STATE 'CLOSED)
then (RPLACD INFO 'OPEN)
[RETURN (create POSITION
XCOORD _ (SUB1 (fetch (REGION LEFT) of
WINDOWREGION
))
YCOORD _ (SUB1 (fetch (REGION BOTTOM) of
WINDOWREGION
]
else (if (IGREATERP (fetch (POSITION XCOORD) of MOVINGPOINT)
(fetch (REGION RIGHT) of WINDOWREGION))
then (replace (POSITION XCOORD) of MOVINGPOINT
with (fetch (REGION RIGHT) of
WINDOWREGION
)))
(if (IGREATERP (fetch (POSITION YCOORD) of MOVINGPOINT)
(fetch (REGION TOP) of WINDOWREGION))
then (replace (POSITION YCOORD) of MOVINGPOINT
with (fetch (REGION TOP) of WINDOWREGION)))
(RETURN MOVINGPOINT])
(ICMLARRAY.GETMENUWGROUP
[LAMBDA (CMLARRAY FONT DISPLAYEDLEVELS TOPLEFT) (* ; "Edited 5-Apr-87 17:25 by jop")
(* ;; "Constructs the three windows of the status group and puts them up on the screen. returns the mainwindow of the group.")
(LET* ((BFONT (FONTCREATE (FONTPROP FONT 'FAMILY)
(FONTPROP FONT 'SIZE)
'BRR))
(DIMS (CL:ARRAY-DIMENSIONS CMLARRAY))
(RANK (CL:ARRAY-RANK CMLARRAY))
[PHEIGHT (HEIGHTIFWINDOW (FONTPROP FONT 'HEIGHT]
SWINDOW PWINDOW) (* ; "SWINDOW is the status window")
[SETQ SWINDOW (FREEMENU (GET.MENU.LIST CMLARRAY DISPLAYEDLEVELS
(IMAX (STRINGWIDTH 'ALL BFONT)
(STRINGWIDTH (for DIM in DIMS
largest (STRINGWIDTH DIM BFONT))
BFONT))
FONT BFONT)
(RESETVAR *PRINT-ARRAY* NIL (CONCAT CMLARRAY " Inspector"]
(* ;
"Makes no sense to reshape the statuswindow group")
(WINDOWPROP SWINDOW 'RESHAPEFN 'DON'T) (* ; "Cache the datum")
(WINDOWPROP SWINDOW 'CMLARRAY CMLARRAY) (* ;
"DISPLAYEDLEVELS is a description of the array slice to be displayed")
(WINDOWPROP SWINDOW 'DISPLAYEDLEVELS DISPLAYEDLEVELS)
(* ; "PWINDOW is the prompt window")
(if (for DIM in DIMS always (NEQ DIM 0))
then (SETQ PWINDOW (CREATEW (CREATEREGION 0 0 100 PHEIGHT)
NIL NIL T))
(WINDOWPROP PWINDOW 'MINSIZE (CONS 0 PHEIGHT))
(WINDOWPROP PWINDOW 'MAXSIZE (CONS MAX.SMALLP PHEIGHT))
(WINDOWPROP PWINDOW 'PAGEFULLFN (FUNCTION NILL))
(DSPSCROLL 'ON PWINDOW)
(WINDOWPROP SWINDOW 'PRTWINDOW PWINDOW)
(DSPFONT FONT PWINDOW)) (* ;
"position and open the windowgroup")
[MOVEW SWINDOW (if TOPLEFT
then [create POSITION
XCOORD _ (fetch (POSITION XCOORD) of TOPLEFT)
YCOORD _ (IDIFFERENCE (fetch (POSITION YCOORD)
of TOPLEFT)
(SUB1 (fetch (REGION HEIGHT)
of (WINDOWPROP SWINDOW
'REGION]
else (GETBOXPOSITION (fetch (REGION WIDTH)
of (WINDOWPROP SWINDOW 'REGION))
(fetch (REGION HEIGHT) of (WINDOWPROP SWINDOW
'REGION]
(REDISPLAYW SWINDOW)
(if PWINDOW
then (ATTACHWINDOW PWINDOW SWINDOW 'BOTTOM))
SWINDOW])
(ICMLARRAY.MENUW.APPLY
[LAMBDA (ITEM MENUWINDOW BUTTONS) (* ; "Edited 5-Apr-87 17:28 by jop")
(* ;; "Display the slice descibed by the windowprop LEVELS")
(LET* [(CMLARRAY (WINDOWPROP MENUWINDOW 'CMLARRAY))
(DISPLAYGROUP (WINDOWPROP MENUWINDOW 'DISPLAYGROUP))
(TOPRIGHT (with REGION (WINDOWPROP MENUWINDOW 'REGION)
(create POSITION
XCOORD _ (SUB1 LEFT)
YCOORD _ TOP)))
(LEVELS (for I from 0 to (SUB1 (CL:ARRAY-RANK CMLARRAY))
collect (FM.ITEMPROP (FM.GETITEM (PACK* 'LEVEL I)
NIL MENUWINDOW)
'LABEL]
(if (IGREATERP (for LEVEL in LEVELS count (EQ LEVEL 'ALL))
2)
then (PRINTOUT (WINDOWPROP MENUWINDOW 'PRTWINDOW)
T "Rank too high")
else (ICMLARRAY.DETACHDISPLAY MENUWINDOW)
(SETQ DISPLAYGROUP (XCL:WITH-PROFILE (WINDOWPROP DISPLAYGROUP 'PROFILE)
(ICMLARRAY.DISPLAYSLICE CMLARRAY LEVELS DISPLAYGROUP
TOPRIGHT)))
(ICMLARRAY.ATTACHDISPLAY DISPLAYGROUP MENUWINDOW LEVELS])
(ICMLARRAY.MENUW.GETLEVEL
[LAMBDA (ITEM MENUWINDOW BUTTONS) (* ; "Edited 5-Apr-87 17:28 by jop")
(* ;; "Get a new LEVEL for dim DIM")
(LET ((DIM (FM.ITEMPROP ITEM 'DIM))
(LEVEL (FM.ITEMPROP ITEM 'LABEL))
(CMLARRAY (WINDOWPROP MENUWINDOW 'CMLARRAY))
(PRTWINDOW (WINDOWPROP MENUWINDOW 'PRTWINDOW))
LEVMENU NEWVALUE)
(SETQ LEVEL
(if (ILESSP (CL:ARRAY-DIMENSION CMLARRAY DIM)
10)
then (LET [(LEVMENU (OR (FM.ITEMPROP ITEM 'LEVMENU)
(create MENU
ITEMS _ (CONS '(ALL 'ALL "Unrestricted")
(for I from 0
to (SUB1 (CL:ARRAY-DIMENSION CMLARRAY
DIM))
collect (LIST I (KWOTE I]
(FM.ITEMPROP ITEM 'LEVMENU LEVMENU)
(OR (MENU LEVMENU)
LEVEL))
else (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 'ALL
else (SETQ NEWVALUE (READ (OPENSTRINGSTREAM NEWVALUE)))
(if (AND (FIXP NEWVALUE)
(GEQ NEWVALUE 0)
(LESSP NEWVALUE (CL:ARRAY-DIMENSION CMLARRAY DIM)))
then NEWVALUE
else (PRINTOUT (WINDOWPROP MENUWINDOW 'PRTWINDOW)
T
(CONCAT "Illegal value " NEWVALUE))
LEVEL))
else LEVEL)))
(FM.CHANGELABEL ITEM LEVEL MENUWINDOW])
(ICMLARRAY.MENUW.SHOW
[LAMBDA (ITEM MENUWINDOW BUTTONS) (* ; "Edited 7-Apr-87 10:25 by jop")
(LET [(DISPLAYEDLEVELS (WINDOWPROP MENUWINDOW 'CURRENTLEVELS))
(CMLARRAY (WINDOWPROP MENUWINDOW 'CMLARRAY]
(bind LEVEL-ITEM for I from 0 to (SUB1 (CL:ARRAY-RANK CMLARRAY)) as LEVEL in DISPLAYEDLEVELS
do (SETQ LEVEL-ITEM (FM.GETITEM (PACK* 'LEVEL I)
NIL MENUWINDOW))
(if LEVEL-ITEM
then (FM.CHANGELABEL LEVEL-ITEM LEVEL MENUWINDOW])
(SLICEDIMENSION
[LAMBDA (SELECTION DIM) (* jop%: "20-Nov-85 20:23")
(* *)
(CAR (FNTH (fetch (ICML.ARRAYSLICE SELECTEDDIMS) of SELECTION)
(ADD1 DIM])
(SLICERANK
[LAMBDA (SELECTION) (* jop%: "20-Nov-85 20:23")
(* *)
(LENGTH (fetch (ICML.ARRAYSLICE SELECTEDDIMS) of SELECTION])
(SLICEREF
[LAMBDA ARGS (* ; "Edited 5-Apr-87 17:11 by jop")
(if (ILESSP ARGS 1)
then (HELP "Need at least one arg"))
(LET* ((SLICE (ARG ARGS 1))
(LINEARIZEDARRAY (fetch (ICML.ARRAYSLICE LINEARIZEDARRAY) of SLICE))
(OFFSETS (fetch (ICML.ARRAYSLICE OFFSETS) of SLICE))
(OFFSETCONSTANT (fetch (ICML.ARRAYSLICE OFFSETCONSTANT) of SLICE)))
(CL:AREF LINEARIZEDARRAY (IPLUS OFFSETCONSTANT
(for OFFSET in OFFSETS as I from 2
sum (ITIMES OFFSET (ARG ARGS I])
(SLICESET
[LAMBDA ARGS (* jop%: " 5-Aug-86 12:20")
(* *)
(if (ILESSP ARGS 2)
then (HELP "Need at least two args"))
(LET* ((NEWVALUE (ARG ARGS 1))
(SLICE (ARG ARGS 2))
(LINEARIZEDARRAY (fetch (ICML.ARRAYSLICE LINEARIZEDARRAY) of SLICE))
(OFFSETS (fetch (ICML.ARRAYSLICE OFFSETS) of SLICE))
(OFFSETCONSTANT (fetch (ICML.ARRAYSLICE OFFSETCONSTANT) of SLICE)))
(ASET NEWVALUE LINEARIZEDARRAY (IPLUS OFFSETCONSTANT
(for OFFSET in OFFSETS as I from 3
sum (ITIMES OFFSET (ARG ARGS I])
(ZEROD.FETCHFN
[LAMBDA (SLICE PROP) (* jop%: " 5-Aug-86 12:20")
(* *)
(SLICEREF SLICE])
(ZEROD.STOREFN
[LAMBDA (NEWVALUE SLICE PROP) (* jop%: " 5-Aug-86 12:20")
(* *)
(SLICESET NEWVALUE SLICE])
)
(ADDTOVAR INSPECTMACROS ((FUNCTION CL:ARRAYP) . ICMLARRAY))
(/DECLAREDATATYPE 'ICML.ARRAYSLICE '(POINTER POINTER POINTER POINTER)
'((ICML.ARRAYSLICE 0 POINTER)
(ICML.ARRAYSLICE 2 POINTER)
(ICML.ARRAYSLICE 4 POINTER)
(ICML.ARRAYSLICE 6 POINTER))
'8)
(FILESLOAD TWODINSPECTOR FREEMENU)
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(DATATYPE ICML.ARRAYSLICE (SELECTEDDIMS OFFSETS OFFSETCONSTANT LINEARIZEDARRAY))
)
(/DECLAREDATATYPE 'ICML.ARRAYSLICE '(POINTER POINTER POINTER POINTER)
'((ICML.ARRAYSLICE 0 POINTER)
(ICML.ARRAYSLICE 2 POINTER)
(ICML.ARRAYSLICE 4 POINTER)
(ICML.ARRAYSLICE 6 POINTER))
'8)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA SLICESET SLICEREF ICMLARRAY.VALUECOMMANDFN)
)
(PUTPROPS CMLARRAYINSPECTOR COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990 1993))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (2345 3090 (\CREATE.INSPECTABLEMENU 2355 . 2655) (\CREATE.SETABLEMENU 2657 . 2893) (
\CREATE.TITLEMENU 2895 . 3088)) (3091 33550 (CREATEARRAYSLICE 3101 . 4523) (GET.MENU.LIST 4525 . 7397)
(ICMLARRAY 7399 . 9425) (ICMLARRAY.ATTACHDISPLAY 9427 . 9880) (ICMLARRAY.DETACHDISPLAY 9882 . 10174)
(ICMLARRAY.DOWINDOWCOMFN 10176 . 11151) (ICMLARRAY.INDICES 11153 . 12100) (ICMLARRAY.SETVALUE 12102 .
13332) (ICMLARRAY.TITLECOMMANDFN 13334 . 15726) (ICMLARRAY.VALUECOMMANDFN 15728 . 18766) (
ICMLARRAY.DISPLAYSLICE 18768 . 20326) (ICMLARRAY.GETREGIONFN 20328 . 22925) (ICMLARRAY.GETMENUWGROUP
22927 . 26582) (ICMLARRAY.MENUW.APPLY 26584 . 28029) (ICMLARRAY.MENUW.GETLEVEL 28031 . 30613) (
ICMLARRAY.MENUW.SHOW 30615 . 31223) (SLICEDIMENSION 31225 . 31475) (SLICERANK 31477 . 31693) (SLICEREF
31695 . 32403) (SLICESET 32405 . 33189) (ZEROD.FETCHFN 33191 . 33364) (ZEROD.STOREFN 33366 . 33548)))
))
STOP