-
-
Notifications
You must be signed in to change notification settings - Fork 24
/
Copy pathTEDIT-BUTTONS
1982 lines (1735 loc) · 123 KB
/
TEDIT-BUTTONS
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
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "22-Mar-2025 14:01:28" {WMEDLEY}<library>TEDIT>TEDIT-BUTTONS.;220 124351
:EDIT-BY rmk
:CHANGES-TO (FNS MB.BUTTONEVENTINFN)
:PREVIOUS-DATE "14-Mar-2025 15:29:51" {WMEDLEY}<library>TEDIT>TEDIT-BUTTONS.;219)
(PRETTYCOMPRINT TEDIT-BUTTONSCOMS)
(RPAQQ TEDIT-BUTTONSCOMS
[
(* ;;
"Implementation of the various kinds of menu buttons: Action, toggle, 3state, N-way, field")
(COMS (* ;
"Generic functions for the various types of buttons.")
(RECORDS MBARG)
(FNS MB.ADD MB.DELETE MB.GET MB.GET.MBARG TEDIT.BACKTOMAIN))
[COMS (* ; "Simple Menu Button support")
(FNS MB.BUTTONEVENTINFN MB.DISPLAYFN MB.SETIMAGE MB.SIZEFN MB.WHENOPERATEDONFN
MB.COPYFN MB.GETFN MB.PUTFN MB.SHOWSELFN MB.CREATE MB.CHANGENAME MB.INIT
MB.TRACK.UNTIL MB.DON'T MB.SPEC.REMAINDER)
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (MB.INIT]
[COMS (* ; "3STATE")
(* ;; "ON-OFF-NEUTRAL menu buttons, for, e.g., character properties like BOLD")
(FNS MB.3STATE.CREATE MB.3STATE.DISPLAYFN MB.3STATE.SHOWSELFN MB.3STATE.INIT
MB.3STATE.SETSTATEFN MB.3STATE.BUTTONEVENTINFN)
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (MB.3STATE.INIT]
[COMS (* ; "NWAY")
(* ;; "Mutually exclusive togggles with a single enclosing object")
(FNS MB.NWAY.CREATE MB.NWAY.DISPLAYFN MB.NWAY.WHENOPERATEDONFN MB.NWAY.SIZEFN
MB.NWAY.SELECT MB.NWAY.BUTTONEVENTINFN MB.NWAY.NEWMENUBUTTON MB.NWAY.COPYFN
MB.NWAY.INIT MB.NWAY.ARRANGEBUTTONS MB.NWAY.ADDITEM MB.NWAY.FINDSUBOBJ
MB.NWAY.SETSTATEFN)
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (MB.NWAY.INIT]
[COMS (* ; "TOGGLE")
(FNS MB.TOGGLE.CREATE MB.TOGGLE.DISPLAYFN MB.TOGGLE.INIT MB.SET.TOGGLE
MB.TOGGLE.SETSTATEFN MB.TOGGLE.BUTTONEVENTINFN MB.TOGGLE.WHENOPERATEDONFN)
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (MB.TOGGLE.INIT]
(COMS (* ; "FIELDS")
(FNS MB.FIELD.CREATE MB.FIELD.DISPLAYFN MB.FIELD.IMAGEBOXFN MB.FIELD.PREFIXCREATE
MB.FIELD.SUFFIXCREATE MB.FIELD.INIT MB.FIELD.WHENOPERATEDONFN MB.FIELD.GETSTATEFN
MB.FIELD.SETSTATEFN MB.FIELD.BUTTONEVENTINFN MB.FIELD.SIZEFN MB.FIELD.INSURETYPE)
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (MB.FIELD.INIT])
(* ;; "Implementation of the various kinds of menu buttons: Action, toggle, 3state, N-way, field")
(* ; "Generic functions for the various types of buttons.")
(DECLARE%: EVAL@COMPILE
(RECORD MBARG (ARGSTATE ARGOBJ ARGSTARTPC ARGENDPC ARGIDPC))
)
(DEFINEQ
(MB.ADD
[LAMBDA (MENUDESC MENUTSTREAM WHERE INCREMENTALUPDATES) (* ; "Edited 5-Jan-2025 11:36 by rmk")
(* ; "Edited 22-Oct-2024 09:16 by rmk")
(* ; "Edited 21-Oct-2024 00:26 by rmk")
(* ; "Edited 18-Oct-2024 13:49 by rmk")
(* ; "Edited 6-Oct-2024 15:25 by rmk")
(* ; "Edited 24-Aug-2024 21:08 by rmk")
(DECLARE (SPECVARS MENUTSTREAM))
(SETQ MENUTSTREAM (TEXTSTREAM MENUTSTREAM)) (* ; "Edited 22-Aug-2024 11:10 by rmk")
(* ;; "MENUDESC is a Tedit menu specification, a list of items describing one or more elements to be inserted in TSTREAM after WHERE. ")
(* ;; "This is a user entry for adding items to a Tedit menu.")
(* ;; "If button-type is a list, it is interpreted as form to be evaluated, with MENUTSTREAM and the current CH# available as free variables. The result of the evaluation should be the increment in CH#.")
(* ;; "An item can be of the form (button-type . attribute-values), a number indicating how many spaces, EOL or TAB atoms, or a string to be inserted as text in the default menu font.")
(* ;; "CH# can be used freely")
(* ;; "Returns the textstream character number of the character just after the last inserted character/object.")
(RESETLST
(CL:UNLESS INCREMENTALUPDATES (TEDIT.DEFER.UPDATES MENUTSTREAM))
(for DESC TYPE SPEC OBJ [EOL _ (CONCATCODES (CHARCODE (EOL]
[TAB _ (CONCATCODES (CHARCODE (TAB]
(CH# _ (if (NULL WHERE)
then (ADD1 (TEXTLEN (FGETTSTR MENUTSTREAM TEXTOBJ)))
elseif (FIXP WHERE)
else (\ILLEGAL.ARG WHERE))) in MENUDESC declare (SPECVARS CH#)
do (SETQ DESC (MKLIST DESC)) (* ; "MKLIST for EOL/TAB, FIXP")
(SETQ TYPE (CAR DESC))
(SETQ SPEC (CDR DESC))
(SELECTQ TYPE
( (* ; ;; NIL)
(* ;
"Ignore comments within menu descriptions")
)
(EOL (TEDIT.INSERT MENUTSTREAM EOL CH# '(PROTECTED ON))
(add CH# 1))
(TAB (TEDIT.INSERT MENUTSTREAM TAB CH# '(PROTECTED ON))
(add CH# 1))
(ACTION (* ; "Hitting calls a function")
(TEDIT.INSERT.OBJECT (MB.CREATE SPEC)
MENUTSTREAM CH# '(PROTECTED OFF))
(add CH# 1))
(3STATE (* ;
"3-state button; hitting it changes state among ON, OFF, and NEUTRAL.")
(TEDIT.INSERT.OBJECT (MB.3STATE.CREATE SPEC)
MENUTSTREAM CH# '(PROTECTED OFF))
(add CH# 1))
(TOGGLE (* ;
"TOGGLE button; hitting it switches between ON and OFF.")
(TEDIT.INSERT.OBJECT (MB.TOGGLE.CREATE SPEC)
MENUTSTREAM CH# '(PROTECTED OFF))
(add CH# 1))
(NWAY (* ;
"N-way buttons; choosing one turns the others off.")
(SETQ OBJ (MB.NWAY.CREATE SPEC))
(TEDIT.INSERT.OBJECT OBJ MENUTSTREAM CH# '(PROTECTED OFF))
(add CH# 1))
(TEXT (* ; "Arbitrary protected text.")
[TEDIT.INSERT MENUTSTREAM (CADR (ASSOC 'STRING SPEC))
CH#
(CL:IF (CADR (ASSOC 'FONT SPEC))
`(FONT ,(CADR (ASSOC 'FONT SPEC))
PROTECTED ON)
'(PROTECTED ON))]
[add CH# (NCHARS (CADR (ASSOC 'STRING SPEC])
(FIELD (SETQ CH# (MB.FIELD.CREATE SPEC MENUTSTREAM CH#)))
(MENU (* ;
"Real menu, except the selection sticks")
(\TEDIT.THELP "NOT IMPLEMENTED")
(TEDIT.INSERT.OBJECT (MB.CREATE.FULLMENU (CADR SPEC))
MENUTSTREAM CH# '(PROTECTED OFF))
(add CH# 1))
(if (STRINGP TYPE)
then (TEDIT.INSERT MENUTSTREAM TYPE CH# '(PROTECTED ON))
(add CH# (NCHARS TYPE))
elseif (FIXP TYPE)
then (* ; "TYPE spaces")
(TEDIT.INSERT MENUTSTREAM (ALLOCSTRING TYPE (CHARCODE SPACE))
CH#
'(PROTECTED ON))
(add CH# TYPE)
elseif (LISTP TYPE)
then
(* ;; "Form to be evaluated")
(add CH# (EVAL TYPE))
else (\ILLEGAL.ARG DESC))) finally (\TEDIT.SHOWSEL NIL NIL MENUTSTREAM)
(* ;
"User has to click to get a selection")
(SETSEL (TEXTSEL (GETTSTR MENUTSTREAM TEXTOBJ))
SET NIL)
(RETURN CH#)))])
(MB.DELETE
[LAMBDA (IDENTIFIERS MENUSTREAM) (* ; "Edited 8-Nov-2024 08:58 by rmk")
(for ID CHNOS inside IDENTIFIERS when [SETQ CHNOS (MB.GET ID MENUSTREAM '(STARTCHNO ENDCHNO]
do (TEDIT.DELETE MENUSTREAM (CAR CHNOS)
(IDIFFERENCE (ADD1 (CADR CHNOS))
(CAR CHNOS])
(MB.GET
[LAMBDA (IDENTIFIERS MENUSTREAM RETURNS START BEFORE) (* ; "Edited 11-Jan-2025 20:49 by rmk")
(* ; "Edited 13-Dec-2024 09:24 by rmk")
(* ; "Edited 2-Dec-2024 09:41 by rmk")
(* ; "Edited 7-Nov-2024 22:20 by rmk")
(* ; "Edited 22-Oct-2024 22:02 by rmk")
(* ; "Edited 20-Oct-2024 21:55 by rmk")
(* ; "Edited 18-Oct-2024 23:12 by rmk")
(* ; "Edited 29-Sep-2024 22:53 by rmk")
(* ; "Edited 2-Sep-2024 23:36 by rmk")
(* ; "Edited 28-Aug-2024 20:06 by rmk")
(* ; "Edited 24-Aug-2024 21:23 by rmk")
(* ; "Edited 16-Aug-2024 13:14 by rmk")
(* ; "Edited 12-Aug-2024 10:25 by rmk")
(* ; "Edited 9-Aug-2024 22:52 by rmk")
(* ; "Edited 29-Jul-2024 11:00 by rmk")
(* ; "Edited 27-Jul-2024 20:48 by rmk")
(* ;; ";; Computes the arguments from other image objects as requested by the object at SEL/PC in TEXTOBJ. START can be a piece, a selection, a character number, or NIL. If NIL, the whole menu is scanned from the beginning or the end.")
(* ;; "If IDENTIFIERS is a list, this returns a plist keyed by each identifier . ")
(* ;; "If IDENTIFIERS is a litatom, the triple for that identifier is returned. ")
(* ;; "RETURNS specifies what information should be returned for each identifier, defaulting to the identified object. If ALL, the value is an instance of the MBARG record. Otherwise RETURNS can be one of OBJECT, STATE, STARTPC, STARTCHNO, ENDPC, ENDCHNO, or a list of those. If a list, the components for each identifier are returned in a list parallel to RETURNS.")
(CL:WHEN IDENTIFIERS
(CL:UNLESS (OR (type? PIECE START)
(type? SELECTION START)
(FIXP START)
(NULL START))
(\ILLEGAL.ARG START))
(SETQ MENUSTREAM (TEXTSTREAM MENUSTREAM))
(LET ((MENUTEXTOBJ (TEXTOBJ MENUSTREAM))
RESULT)
(if (type? SELECTION START)
then (SETQ START (\TEDIT.CHTOPC (GETSEL START CH#)
MENUTEXTOBJ))
elseif (FIXP START)
then (SETQ START (\TEDIT.CHTOPC START MENUTEXTOBJ)))
[SETQ RESULT (if BEFORE
then (for PC ID IDOBJ (REMAINING _ (COPY (MKLIST IDENTIFIERS)))
backpieces (CL:IF START
(PREVPIECE START)
(\TEDIT.LASTPIECE MENUTEXTOBJ)) while REMAINING
when [SETQ ID (AND (SETQ IDOBJ (POBJ PC))
(CAR (MEMB (IMAGEOBJPROP IDOBJ 'IDENTIFIER)
REMAINING]
join (SETQ REMAINING (DREMOVE ID REMAINING))
(MB.GET.MBARG PC MENUSTREAM))
else (for PC ID IDOBJ (REMAINING _ (COPY (MKLIST IDENTIFIERS)))
inpieces (CL:IF START
(NEXTPIECE START)
(\TEDIT.FIRSTPIECE MENUTEXTOBJ)) while REMAINING
when [SETQ ID (AND (SETQ IDOBJ (POBJ PC))
(CAR (MEMB (IMAGEOBJPROP IDOBJ 'IDENTIFIER)
REMAINING]
join (SETQ REMAINING (DREMOVE ID REMAINING))
(MB.GET.MBARG PC MENUSTREAM]
(CL:UNLESS (EQ RETURNS 'ALL)
(CL:UNLESS RETURNS
(SETQ RETURNS 'OBJECT))
(SETQ RETURNS (MKLIST RETURNS))
[for ATAIL A on RESULT by (CDDR ATAIL)
do (SETQ A (CADR ATAIL))
(RPLACA (CDR ATAIL)
(for R in RETURNS
collect (SELECTQ R
((OBJECT NIL)
(fetch (MBARG ARGOBJ) of A))
(STATE (fetch (MBARG ARGSTATE) of A))
(STARTPC (fetch (MBARG ARGSTARTPC) of A))
(ENDPC (fetch (MBARG ARGENDPC) of A))
(STARTCHNO (\TEDIT.PCTOCH (fetch (MBARG ARGSTARTPC)
of A)
MENUTEXTOBJ))
(ENDCHNO (IPLUS -1 (PLEN (fetch (MBARG ARGENDPC)
of A))
(\TEDIT.PCTOCH (fetch (MBARG ARGENDPC)
of A)
MENUTEXTOBJ)))
(IDPC (fetch (MBARG ARGIDPC) of A))
(ERROR R " is not a button return"))
finally (CL:UNLESS (CDR RETURNS)
(RETURN (CAR $$VAL)))])
(CL:IF (LISTP IDENTIFIERS)
RESULT
(CADR RESULT))))])
(MB.GET.MBARG
[LAMBDA (IDPC MENUSTREAM) (* ; "Edited 17-Dec-2024 11:54 by rmk")
(* ; "Edited 4-Dec-2024 16:48 by rmk")
(* ;; "Returns the full set of properties for the argument identified at IDPC, including (for fields) the starting piece, ending piece, and ID piece itself.")
(LET ((IDOBJ (POBJ IDPC))
ENDPC STATEFN STATE)
(if [AND (EQ 'FieldPrefixButton (IMAGEOBJPROP IDOBJ 'IMAGECLASSNAME))
(NOT (IMAGEOBJPROP IDOBJ 'FIELDSUFFIX]
then
(* ;; "Scan forward from prefix to suffix, but don't scan backwards from suffix. Asking for the field ID gets the prefix and everything, asking for the suffix just gets the suffix")
(SETQ ENDPC (OR [for P inpieces (NEXTPIECE IDPC)
suchthat (AND (EQ OBJECT.PTYPE (PTYPE P))
(IMAGEOBJPROP (POBJ P)
'FIELDSUFFIX]
(\TEDIT.THELP "Missing field suffix:")))
else (SETQ ENDPC IDPC))
(CL:WHEN (SETQ STATEFN (IMAGEOBJPROP IDOBJ 'STATEFN))
(APPLY* STATEFN IDPC IDOBJ MENUSTREAM))
(LIST (IMAGEOBJPROP IDOBJ 'IDENTIFIER)
(create MBARG
ARGSTATE _ (IMAGEOBJPROP IDOBJ 'STATE)
ARGOBJ _ IDOBJ
ARGSTARTPC _ IDPC
ARGENDPC _ ENDPC
ARGIDPC _ IDPC])
(TEDIT.BACKTOMAIN
[LAMBDA (MENUSTREAM) (* ; "Edited 20-Oct-2024 10:02 by rmk")
(* ; "Edited 25-Aug-2024 09:17 by rmk")
(* ;; "If MENUSTREAM's window is attached to a main window that is also the window of a running Tedit process, gives the TTY to that main window. Otherwise, gives the TTY to the exec.")
(LET ((MAINW (\TEDIT.MAINW MENUSTREAM)))
(TTY.PROCESS (CL:IF MAINW
(WINDOWPROP MAINW 'PROCESS))
T])
)
(* ; "Simple Menu Button support")
(DEFINEQ
(MB.BUTTONEVENTINFN
[LAMBDA (OBJ MENUSTREAM SEL RELX RELY SELWINDOW HOSTSTREAM BUTTON)
(* ; "Edited 22-Mar-2025 14:00 by rmk")
(* ; "Edited 12-Jan-2025 13:03 by rmk")
(* ; "Edited 28-Dec-2024 20:21 by rmk")
(* ; "Edited 22-Aug-2024 16:26 by rmk")
(* ; "Edited 20-Aug-2024 10:04 by rmk")
(* ; "Edited 20-Jul-2024 15:26 by rmk")
(* ; "Edited 9-Apr-2023 18:22 by rmk")
(* ; "Edited 30-May-91 22:15 by jds")
(* ;; "Called when a mouse-button is down inside the object, RELX and RELY are in the objects coordinate system. Decline unless it is a normal left-button selection within the object.")
(if [OR (EQ BUTTON 'RIGHT)
(SHIFTDOWNP 'CTRL)
(SHIFTDOWNP 'SHIFT)
(LET [(OBJBOX (IMAGEOBJPROP OBJ 'BOUNDBOX]
(OR (ILESSP RELX 0)
(ILESSP RELY 0)
(IGREATERP RELX (fetch XSIZE of OBJBOX))
(IGREATERP RELY (fetch YSIZE of OBJBOX]
then 'DON'T
else T])
(MB.DISPLAYFN
[LAMBDA (OBJ IMAGESTREAM) (* ; "Edited 26-Aug-2024 09:35 by rmk")
(* ; "Edited 19-Jul-2024 23:32 by rmk")
(* ; "Edited 20-Nov-2023 17:31 by rmk")
(* ; "Edited 11-Jan-89 16:58 by jds")
(* ;; "Display the innards of a menu button. Assumes that the stream is set to the bottom-left corner of the object in stream coordinates (so X,Y instead of 0,0).")
(if (EQ 'DISPLAY (IMAGESTREAMTYPE IMAGESTREAM))
then
(* ;; "Going to the display. Use the cached bitmap version of the button")
[LET ((BITMAP (MB.SETIMAGE OBJ))
(OBJBOX (IMAGEOBJPROP OBJ 'BOUNDBOX))
(X (DSPXPOSITION NIL IMAGESTREAM))
(Y (DSPYPOSITION NIL IMAGESTREAM)))
(SETQ Y (IDIFFERENCE Y (fetch YDESC of OBJBOX)))
(BITBLT BITMAP 0 0 IMAGESTREAM X Y) (* ; "Display the button's image")
(CL:WHEN (EQ (IMAGEOBJPROP OBJ 'STATE)
'ON) (* ; "Invert if ON")
(BLTSHADE BLACKSHADE IMAGESTREAM X Y (fetch XSIZE of OBJBOX)
(fetch YSIZE of OBJBOX)
'INVERT))]
else
(* ;; "Going to some output image stream. Just print the text (without ON inversion?)")
(DSPFONT (PROG1 (DSPFONT (FONTCOPY (IMAGEOBJPROP OBJ 'FONT)
'DEVICE IMAGESTREAM)
IMAGESTREAM) (* ;
"Change to the font for this menu button.")
(PRIN1 (IMAGEOBJPROP OBJ 'LABEL)
IMAGESTREAM))])
(MB.SETIMAGE
[LAMBDA (OBJ) (* ; "Edited 26-Aug-2024 09:37 by rmk")
(* ; "Edited 21-Jul-2024 16:20 by rmk")
(* ; "Edited 19-Jul-2024 23:27 by rmk")
(* jds "23-Aug-84 13:22")
(* ;; "Create a bitmap image of the object's text. Assumes that box exists if bitmap exists.")
(OR (IMAGEOBJPROP OBJ 'BITCACHE)
(LET ((FONT (IMAGEOBJPROP OBJ 'FONT))
(BOX (MB.SIZEFN OBJ))
BITMAP DS)
(SETQ BITMAP (BITMAPCREATE (fetch XSIZE of BOX)
(fetch YSIZE of BOX)))
(IMAGEOBJPROP OBJ 'BITCACHE BITMAP)
(SETQ DS (DSPCREATE BITMAP))
(DSPXOFFSET 0 DS)
(DSPYOFFSET 0 DS)
(DSPFONT FONT DS)
(MOVETO 0 (FONTPROP FONT 'DESCENT)
DS)
(PRIN1 (IMAGEOBJPROP OBJ 'LABEL)
DS)
BITMAP])
(MB.SIZEFN
[LAMBDA (OBJ STREAM) (* ; "Edited 26-Aug-2024 09:36 by rmk")
(* ; "Edited 3-Aug-2024 13:10 by rmk")
(* ; "Edited 19-Jul-2024 23:26 by rmk")
(* ; "Edited 11-Oct-2022 22:51 by rmk")
(* ; "Edited 4-Oct-2022 11:59 by rmk")
(* jds "30-Aug-84 11:24")
(* ;;
"Create the box for a menu button containing LABEL in font FONT on STREAM (NIL means display).")
(OR (IMAGEOBJPROP OBJ 'BOUNDBOX)
(LET ((FONT (IMAGEOBJPROP OBJ 'FONT))
BOX)
(CL:UNLESS (AND STREAM (NOT (DISPLAYSTREAMP STREAM)))
(SETQ FONT (FONTCOPY FONT 'DEVICE (IMAGESTREAMTYPE STREAM))))
(SETQ BOX (create IMAGEBOX
XSIZE _ (CL:IF (IMAGEOBJPROP OBJ 'LABEL)
(STRINGWIDTH (IMAGEOBJPROP OBJ 'LABEL)
FONT)
0)
YSIZE _ (FONTPROP FONT 'HEIGHT)
YDESC _ (FONTPROP FONT 'DESCENT)
XKERN _ 0))
(IMAGEOBJPROP OBJ 'BOUNDBOX BOX)
BOX])
(MB.WHENOPERATEDONFN
[LAMBDA (OBJ MENUWINDOW OPERATION MENUSEL MENUSTREAM) (* ; "Edited 20-Oct-2024 09:51 by rmk")
(* ; "Edited 18-Oct-2024 14:22 by rmk")
(* ; "Edited 6-Oct-2024 23:29 by rmk")
(* ; "Edited 29-Sep-2024 15:44 by rmk")
(* ; "Edited 26-Jul-2024 15:24 by rmk")
(* ; "Edited 20-Jul-2024 20:57 by rmk")
(* ; "Edited 17-Jul-2024 21:27 by rmk")
(* ; "Edited 27-Mar-2024 13:49 by rmk")
(* jds " 7-Feb-84 14:20")
(* ;; "HIGHLIGHTED is in OBJ's coordinate system, SELECTED is in PANE's coordinate system.")
(* ;; "Here we deal only with the button hilighting itself.")
(SELECTQ OPERATION
(HIGHLIGHTED (MB.SHOWSELFN OBJ T MENUWINDOW)
(MB.TRACK.UNTIL OBJ MENUWINDOW)
(MB.SHOWSELFN OBJ NIL MENUWINDOW))
(SELECTED
(* ;; "Old code tested for a return of DON'T from the BUTTONFN. That was probably a mistaken carry-over from the description of the BUTTONEVENTINFN, where DON'T meant don't allow the selection. But if we are here, we passed that gate.")
(* ;;
"We don't update the display here: That happens on the separate HIGHLIGHTED call from SHOWSEL")
(LET [(SELECTFN (IMAGEOBJPROP OBJ 'SELECTFN]
(CL:WHEN SELECTFN (APPLY* SELECTFN OBJ MENUSEL MENUWINDOW MENUSTREAM))))
NIL])
(MB.COPYFN
[LAMBDA (OBJ) (* jds "23-May-84 11:32")
(* Copy a menu button object.)
(create IMAGEOBJ
OBJECTDATUM _ (COPY (fetch (IMAGEOBJ OBJECTDATUM) of OBJ))
IMAGEOBJPLIST _ (COPY (fetch (IMAGEOBJ IMAGEOBJPLIST) of OBJ))
IMAGEOBJFNS _ (fetch (IMAGEOBJ IMAGEOBJFNS) of OBJ])
(MB.GETFN
[LAMBDA (OBJ FILE) (* ; "Edited 21-Oct-2024 00:26 by rmk")
(* ; "Edited 26-Aug-2024 09:36 by rmk")
(* ; "Edited 19-Dec-2023 10:24 by rmk")
(* ; "Edited 20-Aug-87 16:17 by jds")
(* READ a menu button from a file.)
(\TEDIT.THELP "HELP FROM JDS--NOT USED?")
(PROG [(TEXT (IMAGEOBJPROP OBJ 'LABEL))
(MBFN (IMAGEOBJPROP OBJ 'MBFN))
(FONT (IMAGEOBJPROP OBJ 'FONT]
(\STRINGOUT FILE TEXT)
(\ATMOUT FILE MBFN)
(\ATMOUT FILE (FONTPROP FONT 'FAMILY))
(\WOUT FILE (FONTPROP FONT 'SIZE))
(for ATTR in (FONTPROP FONT 'FACE) do (\ATMOUT FILE ATTR])
(MB.PUTFN
[LAMBDA (OBJ FILE) (* ; "Edited 21-Oct-2024 00:26 by rmk")
(* ; "Edited 26-Aug-2024 09:36 by rmk")
(* ; "Edited 19-Dec-2023 10:23 by rmk")
(* ; "Edited 20-Aug-87 16:17 by jds")
(* ;; "Write a menu button from a file; suitable for re-reading using the image objects GETFN.")
(PROG [(TEXT (IMAGEOBJPROP OBJ 'LABEL))
(MBFN (IMAGEOBJPROP OBJ 'MBFN))
(FONT (IMAGEOBJPROP OBJ 'FONT]
(\TEDIT.THELP "HELP FROM JDS -- NOT USED?")
(\STRINGOUT FILE TEXT) (* ; "The button's image")
(\ATMOUT FILE MBFN) (* ; "The FN called when hit")
(\ATMOUT FILE (FONTPROP FONT 'FAMILY))
(\WOUT FILE (FONTPROP FONT 'SIZE))
(for ATTR in (FONTPROP FONT 'FACE) do (\ATMOUT FILE ATTR])
(MB.SHOWSELFN
[LAMBDA (OBJ ON PANE) (* ; "Edited 18-Oct-2024 13:17 by rmk")
(* ; "Edited 5-Oct-2024 23:47 by rmk")
(* ; "Edited 20-Jul-2024 20:58 by rmk")
(* ; "Edited 17-Jul-2024 00:49 by rmk")
(* ; "Edited 27-Mar-2024 13:47 by rmk")
(* ; "Edited 20-Nov-2023 20:16 by rmk")
(* ; "Edited 11-Jan-89 16:35 by jds")
(* ;; "Redisplay the bitmap (presumably the button's vanilla label), then invert it if ON.")
(* ;;
"We are in the object's coordinate system for buttonevent, highlighting and unhighlighting. ")
(LET* [(BITMAP (MB.SETIMAGE OBJ))
(OBJBOX (IMAGEOBJPROP OBJ 'BOUNDBOX]
(BITBLT BITMAP 0 0 PANE 0 0 (fetch (IMAGEBOX XSIZE) of OBJBOX)
(fetch (IMAGEBOX YSIZE) of OBJBOX)
'INPUT
'REPLACE)
(CL:WHEN (AND ON (NEQ ON 'OFF))
(BLTSHADE BLACKSHADE PANE 0 0 (fetch (IMAGEBOX XSIZE) of OBJBOX)
(fetch (IMAGEBOX YSIZE) of OBJBOX)
'INVERT))])
(MB.CREATE
[LAMBDA (SPEC IMAGEFNS) (* ; "Edited 12-Jan-2025 12:35 by rmk")
(* ; "Edited 9-Jan-2025 16:51 by rmk")
(* ; "Edited 6-Jan-2025 00:19 by rmk")
(* ; "Edited 4-Jan-2025 16:29 by rmk")
(* ; "Edited 18-Oct-2024 10:27 by rmk")
(* ; "Edited 6-Oct-2024 16:59 by rmk")
(* ; "Edited 5-Oct-2024 11:51 by rmk")
(* ; "Edited 29-Sep-2024 14:51 by rmk")
(* ; "Edited 26-Aug-2024 09:36 by rmk")
(* ; "Edited 20-Aug-2024 16:16 by rmk")
(* ; "Edited 13-Aug-2024 22:16 by rmk")
(* ; "Edited 9-Aug-2024 16:00 by rmk")
(* ; "Edited 31-Jul-2024 22:00 by rmk")
(* ; "Edited 25-Jul-2024 23:42 by rmk")
(* ; "Edited 24-Jul-2024 08:30 by rmk")
(* ; "Edited 21-Jul-2024 22:58 by rmk")
(* ; "Edited 19-Jul-2024 11:00 by rmk")
(* ; "Edited 11-Jan-89 16:10 by jds")
(* ;; "Create a MENU BUTTON image object, and fill in its image and function-hook fields. ")
(for S PROP VAL IDENTIFIER LABEL (OBJ _ (IMAGEOBJCREATE NIL (OR IMAGEFNS
(CADR (ASSOC 'IMAGEFNS SPEC))
MB.IMAGEFNS))) in SPEC
eachtime (SETQ PROP (MKATOM (CAR S)))
(SETQ VAL (CADR S)) unless (EQ PROP 'IMAGEFNS)
do (SELECTQ PROP
(FONT [SETQ VAL (FONTCREATE (FONTCREATE VAL NIL NIL NIL 'DISPLAY])
(LABEL (SETQ LABEL (SETQ VAL (MKSTRING VAL))))
(IDENTIFIER (SETQ IDENTIFIER VAL)
(GO $$ITERATE))
NIL)
(IMAGEOBJPROP OBJ PROP VAL)
finally (CL:UNLESS (IMAGEOBJPROP OBJ 'FONT)
(IMAGEOBJPROP OBJ 'FONT (FONTCREATE '(HELVETICA 8 BOLD)
NIL NIL NIL 'DISPLAY)))
(if (NULL IDENTIFIER)
then (if LABEL
then [SETQ IDENTIFIER (U-CASE (MKATOM (CL:STRING-TRIM '(#\Space #\Tab
#\Newline #\:
)
LABEL]
else (ERROR (ERROR "Missing both IDENTIFIER and LABEL" SPEC)))
elseif (OR (LITATOM IDENTIFIER)
(SMALLP IDENTIFIER))
elseif (STRINGP IDENTIFIER)
then (SETQ IDENTIFIER (MKATOM IDENTIFIER))
else (\ILLEGAL.ARG VAL))
(IMAGEOBJPROP OBJ 'IDENTIFIER IDENTIFIER)
(CL:WHEN (IMAGEOBJPROP OBJ 'INITSTATE)
(IMAGEOBJPROP OBJ 'STATE (IMAGEOBJPROP OBJ 'INITSTATE)))
(MB.SETIMAGE OBJ)
(RETURN OBJ])
(MB.CHANGENAME
[LAMBDA (TEXTOBJ OBJ NEWNAME) (* ; "Edited 26-Aug-2024 09:31 by rmk")
(* jds "23-Aug-84 13:26")
(* Change the text that appears in a button, and redisplay the button if it's
visible)
(PROG (BOX BITMAP DS)
(IMAGEOBJPROP OBJ 'LABEL NEWNAME)
(MB.SETIMAGE OBJ)
(TEDIT.OBJECT.CHANGED TEXTOBJ OBJ])
(MB.INIT
[LAMBDA NIL (* ; "Edited 7-Jan-2025 22:49 by rmk")
(* ; "Edited 7-Dec-2024 09:05 by rmk")
(* ; "Edited 28-Aug-2024 23:34 by rmk")
(* ; "Edited 24-Aug-2024 11:00 by rmk")
(* ; "Edited 20-Aug-2024 15:23 by rmk")
(* ; "Edited 18-Feb-2024 14:15 by rmk")
(* jds "12-Feb-85 14:32")
(DECLARE (GLOBALVARS MB.IMAGEFNS))
(SETQ MB.IMAGEFNS (IMAGEFNSCREATE (FUNCTION MB.DISPLAYFN)
(FUNCTION MB.SIZEFN)
(FUNCTION MB.PUTFN)
(FUNCTION MB.GETFN)
(FUNCTION MB.COPYFN)
(FUNCTION MB.BUTTONEVENTINFN)
'NILL
'NILL
'NILL
(FUNCTION MB.DON'T)
'NILL
(FUNCTION MB.WHENOPERATEDONFN)
(FUNCTION NILL)
'TEditMenuButton])
(MB.TRACK.UNTIL
[LAMBDA (OBJ PANE) (* ; "Edited 23-Oct-2024 10:10 by rmk")
(* ; "Edited 18-Oct-2024 11:57 by rmk")
(* ;; "Track the mouse untill either it leaves the object or the buttons come up. Returns DON'T if it leaves, NIL if buttons are up.")
(do (BLOCK)
(GETMOUSESTATE)
(CL:WHEN (EQ 'DON'T (MB.BUTTONEVENTINFN OBJ PANE NIL (LASTMOUSEX PANE)
(LASTMOUSEY PANE)
PANE))
(RETURN 'DON'T))
(CL:WHEN (ALLBUTTONSUP)
(RETURN NIL])
(MB.DON'T
[LAMBDA (OBJ) (* ; "Edited 16-Dec-2024 13:31 by rmk")
(* ; "Edited 7-Dec-2024 08:58 by rmk")
(CL:UNLESS (IMAGEOBJPROP OBJ 'DELETABLE)
'DON'T])
(MB.SPEC.REMAINDER
[LAMBDA (SPEC IGNORE OBJ) (* ; "Edited 16-Feb-2025 13:07 by rmk")
(* ;; "Reduces SPEC to properties that not to be IGNORED because they have been dealt with separately. If OBJ, those properties are installed as IMAGEOBJPROP's.")
(for S in SPEC unless (MEMB (CAR S)
IGNORE) collect (CL:WHEN OBJ
(IMAGEOBJPROP OBJ (CAR S)
(CADR S)))
S])
)
(DECLARE%: DONTEVAL@LOAD DOCOPY
(MB.INIT)
)
(* ; "3STATE")
(* ;; "ON-OFF-NEUTRAL menu buttons, for, e.g., character properties like BOLD")
(DEFINEQ
(MB.3STATE.CREATE
[LAMBDA (SPEC) (* ; "Edited 6-Oct-2024 17:08 by rmk")
(* ; "Edited 5-Oct-2024 17:00 by rmk")
(* ; "Edited 2-Aug-2024 23:51 by rmk")
(* ; "Edited 21-Jul-2024 00:52 by rmk")
(* ; "Edited 19-Jul-2024 10:48 by rmk")
(* jds "24-Sep-86 00:49")
(CL:UNLESS (ASSOC 'INITSTATE SPEC)
(push SPEC (LIST 'INITSTATE 'NEUTRAL)))
(push SPEC (LIST 'SETSTATEFN (FUNCTION MB.3STATE.SETSTATEFN)))
(MB.CREATE SPEC MB.3STATE.IMAGEFNS])
(MB.3STATE.DISPLAYFN
[LAMBDA (OBJ IMAGESTREAM) (* ; "Edited 5-Oct-2024 16:49 by rmk")
(* ; "Edited 25-Aug-2024 23:11 by rmk")
(* ; "Edited 24-Aug-2024 00:25 by rmk")
(* ; "Edited 26-Jul-2024 16:29 by rmk")
(* ; "Edited 20-Jul-2024 23:57 by rmk")
(* ; "Edited 20-Nov-2023 14:27 by rmk")
(* jds "30-Aug-84 13:53")
(* ;; "IMAGEFNS function called from DISPLAYLINE")
(MB.3STATE.SHOWSELFN OBJ IMAGESTREAM (IMAGEOBJPROP OBJ 'STATE)
(DSPXPOSITION NIL IMAGESTREAM)
(DSPYPOSITION NIL IMAGESTREAM])
(MB.3STATE.SHOWSELFN
[LAMBDA (OBJ IMAGESTREAM SHOWSTATE X Y) (* ; "Edited 5-Oct-2024 16:33 by rmk")
(* ; "Edited 25-Aug-2024 15:01 by rmk")
(* ; "Edited 24-Aug-2024 00:44 by rmk")
(* ; "Edited 20-Jul-2024 23:52 by rmk")
(* ; "Edited 18-Jul-2024 22:41 by rmk")
(* ; "Edited 17-Jul-2024 22:09 by rmk")
(* ; "Edited 20-Nov-2023 14:31 by rmk")
(* ; "Edited 30-May-91 22:16 by jds")
(* ;; "Shows the label of OBJ highlighted according to SHOWSTATE. X and Y are not provided if PANE is already in the object's coordinate system (bottom-left at (0,0).")
(LET* ((BITMAP (MB.SETIMAGE OBJ))
(OBJBOX (MB.SIZEFN OBJ IMAGESTREAM))
(XSIZE (fetch XSIZE of OBJBOX))
(YSIZE (fetch YSIZE of OBJBOX)))
(CL:UNLESS X (* ; "What about kerning?")
(SETQ X 0))
(SETQ Y (CL:IF Y
(IDIFFERENCE Y (fetch YDESC of OBJBOX))
0))
(* ;; "Put down the neutral label, then modify")
(BITBLT BITMAP 0 0 IMAGESTREAM X Y XSIZE YSIZE 'INPUT 'REPLACE)
(SELECTQ SHOWSTATE
(ON (* ;
"Display as white text on black background")
(BLTSHADE BLACKSHADE IMAGESTREAM X Y XSIZE YSIZE 'INVERT))
(OFF (* ;
" Mark with a diagonal line thru it.")
(DRAWLINE X Y (SUB1 (IPLUS X XSIZE))
(SUB1 (IPLUS Y YSIZE))
1
'PAINT IMAGESTREAM))
NIL])
(MB.3STATE.INIT
[LAMBDA NIL (* ; "Edited 7-Jan-2025 22:49 by rmk")
(* ; "Edited 7-Dec-2024 12:38 by rmk")
(* ; "Edited 18-Oct-2024 11:40 by rmk")
(* ; "Edited 25-Aug-2024 23:11 by rmk")
(* ; "Edited 20-Aug-2024 15:36 by rmk")
(* jds " 9-Feb-86 15:17")
(* ;; "Initialize the IMAGEFNS for 3-state menu button IMAGEOBJs")
(DECLARE (GLOBALVARS MB.3STATE.IMAGEFNS))
(SETQ MB.3STATE.IMAGEFNS (IMAGEFNSCREATE (FUNCTION MB.3STATE.DISPLAYFN)
(FUNCTION MB.SIZEFN)
(FUNCTION MB.PUTFN)
(FUNCTION MB.GETFN)
(FUNCTION MB.COPYFN)
(FUNCTION MB.3STATE.BUTTONEVENTINFN)
'NILL
'NILL
'NILL
(FUNCTION MB.DON'T)
'NILL NIL 'NILL '3StateMenuButton])
(MB.3STATE.SETSTATEFN
[LAMBDA (PC NEWVALUE TSTREAM) (* ; "Edited 5-Oct-2024 17:04 by rmk")
(* ; "Edited 25-Aug-2024 12:22 by rmk")
(* ; "Edited 5-Aug-2024 10:06 by rmk")
(* ; "Edited 3-Aug-2024 00:12 by rmk")
(IMAGEOBJPROP (PCONTENTS PC)
'STATE
(SELECTQ NEWVALUE
((NIL OFF)
'OFF)
(NEUTRAL 'NEUTRAL)
'ON))
PC])
(MB.3STATE.BUTTONEVENTINFN
[LAMBDA (OBJ MENUDS SEL RELX RELY MENUWINDOW MENUTSTREAM BUTTON)
(* ; "Edited 22-Dec-2024 22:45 by rmk")
(* ; "Edited 7-Dec-2024 13:11 by rmk")
(* ; "Edited 5-Dec-2024 21:53 by rmk")
(* ; "Edited 18-Oct-2024 12:00 by rmk")
(* ; "Edited 5-Oct-2024 22:42 by rmk")
(* ; "Edited 25-Aug-2024 12:50 by rmk")
(* ; "Edited 6-Aug-2024 10:55 by rmk")
(* ; "Edited 25-Jul-2024 20:13 by rmk")
(* ; "Edited 19-Jul-2024 10:43 by rmk")
(* ; "Edited 18-Jul-2024 10:11 by rmk")
(* ; "Edited 29-Apr-2024 13:30 by rmk")
(* ; "Edited 25-Feb-2024 23:40 by rmk")
(* ; "Edited 21-Oct-2022 18:45 by rmk")
(* ; "Edited 30-May-91 22:16 by jds")
(* ;; "BUTTONEVENTINFN for 3STATE buttons. This run's in the coordinate system of the object. ")
(* ;; "This brings up the display for the next state, tracks the mouse until either it leaves the object or the buttons come up. If the mouse leaves, the original highlighting is restored. Otherwise the state of the obj is advanced to its next state. Either way, we report that the %"selection%" didn't succeed.")
(CL:UNLESS (EQ 'DON'T (MB.BUTTONEVENTINFN OBJ MENUDS SEL RELX RELY MENUWINDOW MENUTSTREAM BUTTON)
)
(LET [(NEXTSTATE (SELECTQ (IMAGEOBJPROP OBJ 'STATE)
(ON 'OFF)
(OFF 'NEUTRAL)
(NEUTRAL 'ON)
(\TEDIT.THELP "ILLEGAL 3STATE" (IMAGEOBJPROP OBJ 'STATE]
(RESETLST
(* ;; "In case of an error or interrupt, make the display consistent with the state")
[RESETSAVE NIL `(PROGN (CL:WHEN RESETSTATE
(MB.3STATE.SHOWSELFN ,OBJ ,MENUDS (IMAGEOBJPROP
,OBJ
'STATE)))]
(MB.3STATE.SHOWSELFN OBJ MENUDS NEXTSTATE)
[if (EQ 'DON'T (MB.TRACK.UNTIL OBJ MENUDS))
then (* ; "Mouse moved out of object")
(MB.3STATE.SHOWSELFN OBJ MENUDS (IMAGEOBJPROP OBJ 'STATE))
else (* ; "Buttons came up: do it")
(IMAGEOBJPROP OBJ 'STATE NEXTSTATE)
(CL:WHEN (SETQ STATECHANGEFN (IMAGEOBJPROP OBJ 'STATECHANGEFN))
(APPLY* STATECHANGEFN OBJ NEXTSTATE (fetch (TEXTWINDOW WTEXTSTREAM)
of MENUDS)))])
(TEDIT.BACKTOMAIN MENUTSTREAM)))
'DON'T])
)
(DECLARE%: DONTEVAL@LOAD DOCOPY
(MB.3STATE.INIT)
)
(* ; "NWAY")
(* ;; "Mutually exclusive togggles with a single enclosing object")
(DEFINEQ
(MB.NWAY.CREATE
[LAMBDA (SPEC MENUTSTREAM CH#) (* ; "Edited 16-Feb-2025 12:08 by rmk")
(* ; "Edited 9-Jan-2025 11:38 by rmk")
(* ; "Edited 4-Jan-2025 21:39 by rmk")
(* ; "Edited 20-Dec-2024 22:17 by rmk")
(* ; "Edited 22-Oct-2024 00:26 by rmk")
(* ; "Edited 29-Sep-2024 12:43 by rmk")
(* ; "Edited 31-Aug-2024 14:57 by rmk")
(* ; "Edited 26-Aug-2024 09:36 by rmk")
(* ; "Edited 20-Aug-2024 16:06 by rmk")
(* ; "Edited 13-Aug-2024 22:44 by rmk")
(* ; "Edited 9-Aug-2024 12:14 by rmk")
(* ; "Edited 2-Aug-2024 23:12 by rmk")
(* ; "Edited 23-Jul-2024 11:43 by rmk")
(* ; "Edited 22-Jul-2024 08:38 by rmk")
(* gbn "24-Sep-84 15:31")
(LET ((IDENTIFIER (CADR (ASSOC 'IDENTIFIER SPEC)))
(BUTTONS (CADR (ASSOC 'BUTTONS SPEC)))
[FONT (FONTCREATE (OR (CADR (ASSOC 'FONT SPEC))
'(HELVETICA 8 BOLD]
(STATECHANGEFN (CADR (ASSOC 'STATECHANGEFN SPEC)))
(STATEFN (CADR (ASSOC 'STATEFN SPEC)))
(INITSTATE (OR (CADR (ASSOC 'INITSTATE SPEC))
'OFF))
(MAXITEMS/LINE (OR (CADR (ASSOC 'MAXITEMS/LINE SPEC))
5))
(DONTAPPLY (CADR (ASSOC 'DONTAPPLY SPEC)))
(OBJ (IMAGEOBJCREATE NIL MB.NWAY.IMAGEFNS))
SPACING HEIGHT SUBOBJECTS)
(if (AND IDENTIFIER (LITATOM IDENTIFIER))
elseif (STRINGP IDENTIFIER)
then (SETQ IDENTIFIER (MKATOM IDENTIFIER))
else (\ILLEGAL.ARG IDENTIFIER))
(SETQ SPACING (STRINGWIDTH " " FONT))
[SETQ HEIGHT (IPLUS 2 (FONTPROP FONT 'HEIGHT]
(CL:UNLESS (LISTP BUTTONS)
(ERROR "BAD BUTTONS" BUTTONS))
[SETQ SUBOBJECTS (for BUTTON in BUTTONS collect (MB.TOGGLE.CREATE
`((LABEL ,BUTTON)
(FONT ,FONT]
(* ; "Initially all OFF")
(CL:UNLESS (EQ 'OFF INITSTATE)
(for SOBJ in SUBOBJECTS when [OR (STRING.EQUAL INITSTATE (IMAGEOBJPROP SOBJ 'LABEL))
(STRING.EQUAL INITSTATE (IMAGEOBJPROP SOBJ 'IDENTIFIER]
do (IMAGEOBJPROP SOBJ 'STATE 'ON)
(IMAGEOBJPROP OBJ 'SELECTED SOBJ)
(RETURN) finally (ERROR "INITSTATE must be a button" INITSTATE)))
(IMAGEOBJPROP OBJ 'STATE INITSTATE)
(IMAGEOBJPROP OBJ 'MAXITEMS/LINE MAXITEMS/LINE)
[IMAGEOBJPROP OBJ 'MINWIDTH (fetch XSIZE
of (IMAGEOBJPROP [for SOBJ in SUBOBJECTS
largest (fetch XSIZE
of (IMAGEOBJPROP SOBJ
'BOUNDBOX]
'BOUNDBOX]
(IMAGEOBJPROP OBJ 'MINHEIGHT HEIGHT) (* ;
"MIN: all on same line. MAX: all on separate lines")
(IMAGEOBJPROP OBJ 'MAXHEIGHT (ITIMES HEIGHT (LENGTH BUTTONS)))
(* ;; "At most, we're as wide as the N widest buttons put together. COPY because we want to preserve the original order")
[IMAGEOBJPROP OBJ 'MAXWIDTH (for SOBJ
in [SORT (COPY SUBOBJECTS)
(FUNCTION (LAMBDA (A B)
(IGEQ (fetch XSIZE
of (IMAGEOBJPROP A 'BOUNDBOX))
(fetch XSIZE
of (IMAGEOBJPROP B 'BOUNDBOX]
as I from 1 to MAXITEMS/LINE
sum (fetch XSIZE of (IMAGEOBJPROP SOBJ 'BOUNDBOX))
finally (RETURN (IPLUS $$VAL (ITIMES SPACING (SUB1
MAXITEMS/LINE
]
(IMAGEOBJPROP OBJ 'SUBOBJECTS SUBOBJECTS)
(IMAGEOBJPROP OBJ 'ITEMSPACE SPACING)
(IMAGEOBJPROP OBJ 'BUTTONHEIGHT HEIGHT)
(IMAGEOBJPROP OBJ 'FONT FONT)
(IMAGEOBJPROP OBJ 'IDENTIFIER IDENTIFIER)
(IMAGEOBJPROP OBJ 'STATECHANGEFN STATECHANGEFN)
(IMAGEOBJPROP OBJ 'STATEFN STATEFN)
(IMAGEOBJPROP OBJ 'DONTAPPLY DONTAPPLY)
(IMAGEOBJPROP OBJ 'SETSTATEFN (FUNCTION MB.NWAY.SETSTATEFN))
(CL:IF (CADR (ASSOC 'IGNORE SPEC))
(IMAGEOBJPROP OBJ 'IGNORE T))
OBJ])
(MB.NWAY.DISPLAYFN
[LAMBDA (OBJ STREAM) (* ; "Edited 22-Jul-2024 10:31 by rmk")
(* ; "Edited 18-Jul-2024 17:02 by rmk")
(* jds "28-Aug-84 15:07")
(* ;; "Each of the subobjects has its own positions relative to X and Y and its own displayfn. Each object also knows whether it is on or off.")
(for SOBJ (X _ (DSPXPOSITION NIL STREAM))
(Y _ (DSPYPOSITION NIL STREAM)) in (IMAGEOBJPROP OBJ 'SUBOBJECTS)
do (DSPXPOSITION (IPLUS X (IMAGEOBJPROP SOBJ 'X))
STREAM)
(DSPYPOSITION (IPLUS Y (IMAGEOBJPROP SOBJ 'Y))
STREAM)
(APPLY* (IMAGEOBJPROP SOBJ 'DISPLAYFN)
SOBJ STREAM])
(MB.NWAY.WHENOPERATEDONFN
[LAMBDA (OBJ PANE OPERATION SEL) (* ; "Edited 21-Oct-2024 00:26 by rmk")
(* ; "Edited 24-Aug-2024 23:38 by rmk")
(* ; "Edited 13-Aug-2024 23:43 by rmk")
(* ; "Edited 2-Aug-2024 00:36 by rmk")
(* ; "Edited 21-Jul-2024 13:17 by rmk")
(* ; "Edited 17-Jul-2024 21:51 by rmk")
(* ; "Edited 9-Apr-2023 15:57 by rmk")
(* ; "Edited 13-Sep-2022 12:09 by rmk")
(* ; "Edited 30-May-91 22:16 by jds")
(* ;; "Perhaps the selected subobject should be stored here, as the state?")
(* ;; "Mouse tracking and highlighting happens in the BUTTONEVENTINFN (MB.NWAYBUTTON.SELFN). The code here applies the STATECHANGEFN on the main object")
(NOTUSED)
(SELECTQ OPERATION
(SELECTED [AND NIL (\TEDIT.THELP)
(LET [(SELECTED (IMAGEOBJPROP OBJ 'SELECTED]
(if (IMAGEOBJPROP OBJ 'STATECHANGEFN)
then (\TEDIT.THELP)
(APPLY* (IMAGEOBJPROP OBJ 'STATECHANGEFN)
OBJ SELECTED SEL PANE)
elseif (AND NIL SELECTED (IMAGEOBJPROP SELECTED 'STATECHANGEFN))
then
(* ;;
"This is nuked out: the selected object may be should have done its own thing?")
(APPLY* (IMAGEOBJPROP SELECTED 'STATECHANGEFN)
OBJ SELECTED SEL PANE])
((HIGHLIGHTED UNHIGHLIGHTED DESELECTED))
NIL])
(MB.NWAY.SIZEFN
[LAMBDA (OBJ STREAM CURX RIGHTMARGIN) (* ; "Edited 20-Aug-2024 15:12 by rmk")
(* ; "Edited 22-Jul-2024 11:31 by rmk")
(* jds " 6-Sep-84 14:19")
(* ; "Tell the size of an n-way menu")
(OR (IMAGEOBJPROP OBJ 'BOUNDBOX)
(LET ((OLDBOX (IMAGEOBJPROP OBJ 'BOUNDBOX))
(SUBOBJECTS (IMAGEOBJPROP OBJ 'SUBOBJECTS))
(MAXITEMS/LINE (IMAGEOBJPROP OBJ 'MAXITEMS/LINE))
(MAXWIDTH (IMAGEOBJPROP OBJ 'MAXWIDTH))
(MINHEIGHT (IMAGEOBJPROP OBJ 'MINHEIGHT))
(BUTTONHEIGHT (IMAGEOBJPROP OBJ 'BUTTONHEIGHT))
(SPACING (IMAGEOBJPROP OBJ 'ITEMSPACE))
(SLACK (IDIFFERENCE RIGHTMARGIN CURX))
BOX XSIZE YSIZE LINES)
[if (AND (IGEQ SLACK MAXWIDTH)
(EQ MAXITEMS/LINE (LENGTH SUBOBJECTS)))
then (* ;
"All the subjobjects fit on one line.")
(SETQ XSIZE MAXWIDTH)
(SETQ YSIZE MINHEIGHT)
(for SO (X _ 0) in SUBOBJECTS do (IMAGEOBJPROP SO 'X X)
(add X (fetch XSIZE of (IMAGEOBJPROP
SO
'BOUNDBOX))
SPACING)
(IMAGEOBJPROP SO 'Y 0))
elseif (ILEQ SLACK (IMAGEOBJPROP OBJ 'MINWIDTH))
then (* ; "Stack them vertically.")
(for SO (Y _ (ITIMES BUTTONHEIGHT (LENGTH SUBOBJECTS))) in SUBOBJECTS
do (add Y (IMINUS BUTTONHEIGHT))
(IMAGEOBJPROP SO 'Y Y)
(IMAGEOBJPROP SO 'X 0))
else (* ; "Divide them into lines")
(SETQ LINES (MB.NWAY.ARRANGEBUTTONS SLACK SUBOBJECTS SPACING MAXITEMS/LINE))
(SETQ XSIZE (for LINE LASTSO in LINES
largest (SETQ LASTSO (CAR (LAST LINE)))
[IPLUS (IMAGEOBJPROP LASTSO 'X)
(fetch XSIZE of (IMAGEOBJPROP LASTSO 'BOUNDBOX]
finally (RETURN $$EXTREME)))
(SETQ YSIZE (ITIMES BUTTONHEIGHT (LENGTH LINES)))
(for LINE (Y _ YSIZE) in LINES do (add Y (IMINUS BUTTONHEIGHT))
(for SO in LINE
do (IMAGEOBJPROP SO 'Y Y]
(if (AND OLDBOX (IEQP XSIZE (fetch XSIZE of OLDBOX))
(IEQP YSIZE (fetch YSIZE of OLDBOX)))
then
(* ;; "Nothing changed.")