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
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
|
;;; -*- Mode:Lisp; Package:CLIO-OPEN; Base:10; Lowercase:T; Syntax:Common-Lisp -*-
;;;----------------------------------------------------------------------------------+
;;; |
;;; TEXAS INSTRUMENTS INCORPORATED |
;;; P.O. BOX 149149 |
;;; AUSTIN, TEXAS 78714 |
;;; |
;;; Copyright (C) 1989, 1990 Texas Instruments Incorporated. |
;;; |
;;; Permission is granted to any individual or institution to use, copy, modify, and |
;;; distribute this software, provided that this complete copyright and permission |
;;; notice is maintained, intact, in all copies and supporting documentation. |
;;; |
;;; Texas Instruments Incorporated provides this software "as is" without express or |
;;; implied warranty. |
;;; |
;;;----------------------------------------------------------------------------------+
(in-package "CLIO-OPEN")
(export '(
make-menu
menu
menu-choice
menu-title
)
'clio-open)
;================================================================;
; THE PUSHPIN CONTACT ;
;================================================================;
(defcontact pushpin-button (button)
((pointer-pressed :type boolean
:initform nil))
(:resources
(border-width :initform 0)
(switch :type (member :in :out)
:initform :out)))
(defun make-pushpin-button (&rest initargs)
(apply #'make-contact 'pushpin-button initargs))
(let
((last-scale '()) ;These state variables are used to cache the menu spec for the
(last-spec '())) ;most recent scale requested.
(defun get-OL-menu-spec (self)
(declare (type (or NULL contact) self))
(if (null self)
(setf last-scale NIL) ;This is just in case anyone ever needs to reset state
(let((this-scale (contact-scale self)))
(if (eq this-scale last-scale)
last-spec
(let
((spec (cdr (assoc this-scale *OL-menu-spec-alist*))))
(setf last-scale this-scale)
(setf last-spec spec)))))))
(defun get-pushpin-spec (self)
(declare (type pushpin-button self))
(OL-menu-spec-pushpin (get-OL-menu-spec self)))
(defmethod initialize-instance :after ((self pushpin-button)
&key switch &allow-other-keys)
(with-slots (border-width selected) self
(setf border-width 0)
(when (eq switch :in)
(setf selected 2))))
(DEFMETHOD preferred-size ((self pushpin-button) &key width height border-width)
(declare (ignore width height border-width))
(let*
((menu-spec (get-OL-menu-spec self))
(pushpin-spec (OL-menu-spec-pushpin menu-spec)))
(with-slots (preferred-width) self
(VALUES
(OR preferred-width
(SETF preferred-width
(+ (pushpin-spec-box-width pushpin-spec)
(- (OL-menu-spec-pushpin-dx menu-spec) ;Spec left margin
(pushpin-spec-left-margin pushpin-spec))))) ;Account for (possible) padding in image
(+ (OL-menu-spec-pushpin-dy menu-spec) ;menu top to pushpin baseline distance
(OL-menu-spec-title-bar-dy menu-spec)) ;pushpin (title) baseline to title bar
0))))
;;; =================================================================================== ;;;
;;; ;;;
;;; Display a Pushpin Button... ;;;
;;; ;;;
;;; =================================================================================== ;;;
(flet
((display-pushpin-button (self menu-spec spec &optional completely-p)
(with-slots (font background foreground width height label) self
(WHEN (realized-p self)
(using-gcontext (gc
:drawable self
:exposures :off
;; :foreground foreground
;; :background background
:font font
:line-width 1)
(WHEN completely-p
(clear-area self
:x 0
:y 0
:width width
:height height))
(let*
((lab-width (drawable-width label))
(lab-height (drawable-height label))
(x (- (OL-menu-spec-pushpin-dx menu-spec) ;desired dx to left of pin
(pushpin-spec-left-margin spec))) ;left margin padding in pixmap
(y (- (OL-menu-spec-pushpin-dy menu-spec) ;desired baseline relative menu
(pushpin-spec-baseline spec) ;pin baseline relative box
(pushpin-spec-top-margin spec)))) ;top margin padding in pixmap
(copy-area label gc 0 0 lab-width lab-height self x y)
))))))
(DEFMETHOD display-button-highlighted ((self pushpin-button) &optional completely-p)
(with-slots (last-displayed-as label) self
(let*
((menu-spec (get-OL-menu-spec self))
(spec (OL-menu-spec-pushpin menu-spec))
(screen (contact-screen self)))
(setf label
(contact-image-mask
self
(pushpin-spec-image-in spec)
:foreground (screen-black-pixel screen)
:background (screen-white-pixel screen)))
(display-pushpin-button self menu-spec spec completely-p))
(SETF last-displayed-as :highlighted)))
(DEFMETHOD display-button-unhighlighted ((self pushpin-button) &optional completely-p)
(with-slots (last-displayed-as highlight-default-p label) self
(let*
((menu-spec (get-OL-menu-spec self))
(spec (OL-menu-spec-pushpin menu-spec))
(screen (contact-screen self)))
(setf label
(contact-image-mask
self
(pushpin-spec-image-out spec)
:foreground (screen-black-pixel screen)
:background (screen-white-pixel screen)))
(display-pushpin-button self menu-spec spec completely-p))
(SETF last-displayed-as :unhighlighted))) )
;;; NOTE: The following choice item methods for pushpins should invoke the choice
;;; item callbacks, but I haven't done this yet.
(defmethod choice-item-press ((pushpin-button pushpin-button))
(with-slots (selected) pushpin-button
(LET((to-selected-p (= selected 1)))
(SETF selected (- selected))
(IF to-selected-p
(display-button-highlighted pushpin-button)
(display-button-unhighlighted pushpin-button))
T)))
(defmethod choice-item-release ((pushpin-button pushpin-button))
(with-slots (selected) pushpin-button
(apply-callback pushpin-button (IF (= 2 (SETF selected (+ 3 selected))) :on :off))))
(defmethod choice-item-leave ((pushpin-button pushpin-button))
(display-button-unhighlighted pushpin-button))
(defun menu-leave-pushpin-button (self)
(declare (type pushpin-button self))
(with-slots (pointer-pressed) self
(when pointer-pressed
(choice-item-leave self)
(setq pointer-pressed nil))))
(defun menu-release-pushpin-button (self)
(declare (type pushpin-button self))
;; Eventually this is where the logic associated with pinning a menu will exist.
; (format t "~%Sorry - Pinning of menus not yet implemented.")
; ;; For now we treat a release just like a leave 'cause pinning
; ;; isn't implemented yet.
; (menu-leave-pushpin-button self)
;; +++ For now we hack pushpins to just change the pushpin state, and let
;; menu-dismissal fake pinning by not dismissing if the pushpin is in.
;; So, do press-and-release and delete the events.
(with-slots (pointer-pressed) self
(when pointer-pressed
(choice-item-release self)
(setq pointer-pressed nil))))
(DEFMETHOD press-select ((self pushpin-button))
(WHEN (choice-item-press self)
(with-slots (pointer-pressed) self
(setq pointer-pressed t))))
(DEFMETHOD release-select ((self pushpin-button))
(with-event (state)
(with-slots (selected pointer-pressed) self
(WHEN (AND (> 0 selected)
(NOT (ZEROP (LOGAND #.(make-state-mask :button-1) state))))
(UNWIND-PROTECT
(choice-item-release self)
(setq pointer-pressed nil))))))
(DEFMETHOD menu-enter-pushpin-button ((self pushpin-button))
(with-event (state)
(unless (zerop (logand #.(make-state-mask :button-3) state))
(when (choice-item-press self)
;(display-button-highlighted self)
(with-slots (pointer-pressed) self
(setq pointer-pressed t))))))
(DEFMETHOD (SETF choice-item-selected-p) (new-value (self pushpin-button))
;; Identical to (SETF button-switch) except returns boolean in/out indicator.
(EQ (SETF (button-switch self) (if new-value :in :out)) :in))
;;; ========================================================================== ;;;
;;; ;;;
;;; ( P u s h p i n ) B u t t o n P r o t o c o l M e t h o d s ;;;
;;; ;;;
;;; ========================================================================== ;;;
(DEFMETHOD button-switch ((self pushpin-button))
(with-slots (selected) self
(NTH (1- (ABS selected)) '(:out :in))))
(DEFMETHOD (SETF button-switch) (new-state (self pushpin-button))
(check-type new-state (member :in :out))
(LET ((current-state (button-switch self)))
(WHEN (NOT (EQ current-state new-state))
;; We simulate a button press and release to implement identical
;; semantics whether done via API or via gesture.
(WHEN (choice-item-press self)
;; When toggle press succeeded we follow it
;; with a release.
(choice-item-release self)))
(button-switch self)))
(DEFEVENT pushpin-button
:enter-notify
menu-enter-pushpin-button)
(defevent pushpin-button
:leave-notify
menu-leave-pushpin-button)
(defevent pushpin-button
(:button-release :button-1)
pp-maybe-release-select)
(defun pp-maybe-release-select (button)
(with-slots (pointer-pressed) (the pushpin-button button)
(when pointer-pressed
(release-select button))))
;; These two translations are for Open Look menus, which allow item selection
;; on both button-1 and button-3 presses.
(DEFEVENT pushpin-button
(:button-press :button-3)
press-select)
(DEFEVENT pushpin-button
(:button-release :button-3)
menu-release-pushpin-button)
;================================================================;
; MENU CONTACT ;
;================================================================;
(defcontact menu (core-shell core override-shell)
()
(:resources
(title :type (or null string)
:initform nil)
(pushpin :type switch
:initform :off)
(save-under :initform :on)
(border-width :initform 0))
(:documentation "A shell which presents a set of choice items."))
(defun make-menu (&rest initargs)
"Creates and returns a menu instance."
(apply #'make-contact 'menu initargs))
(defmethod initialize-instance :after ((menu menu) &rest args
&key (choice 'make-choices) &allow-other-keys)
(with-slots (background border-width width height) menu
;; Can't do this now that the choice arg is a constructor rather than a type.
; (let ((choice-class (if (consp choice) (first choice) choice)))
; (assert (subtypep choice-class 'composite) nil
; "~s is not a composite subclass name." choice-class))
(apply #'make-contact
'drop-shadow
:parent menu
:x 0
:y 0
:width width
:height height
:content choice
args)
;; Now that content is created with initial attributes,
;; reset background, border-width to accommodate drop-shadow.
(setf background :none
border-width 0)))
;; When asked for background, give the background of the container.
(defmethod contact-background ((menu menu))
(with-slots (children) menu
(let ((container (and children (menu-container menu))))
(if container
(contact-background container)
:none))))
(defmethod (setf contact-background) (new-value (menu menu))
(setf (contact-background (menu-container menu)) new-value))
(defmethod (setf contact-foreground) (new-value (menu menu))
(setf (contact-foreground (menu-container menu)) new-value))
(defmethod menu-choice ((menu menu))
(find :content (composite-children (menu-container menu)) :key #'contact-name))
(defun menu-container (menu)
(first (composite-children (first (composite-children menu)))))
(defmethod (setf menu-title) (new-title (menu menu))
(let
((title-field (find :menu-title
(composite-children (menu-container menu))
:key 'contact-name))
(title (convert menu new-title 'string)))
(assert title nil "~a cannot be converted to a title string." new-title)
(cond
(title-field
(change-geometry
title-field
:width (text-width (display-text-font title-field) title)
:accept-p t)
(setf (display-text-source title-field) title))
(t
(make-display-text-field
:name :menu-title
:parent (menu-container menu)
:display-gravity :center
:source title)))
title))
(defmethod menu-title ((menu menu))
(let ((title-field (find :menu-title
(composite-children (menu-container menu))
:key 'contact-name)))
(when title-field
(display-text-source title-field))))
(defmethod preferred-size ((self menu) &key width height border-width)
(declare (ignore width height border-width))
(preferred-size (first (composite-children self))))
(defmethod shell-mapped ((self menu))
"Invokes :initialize callback function."
(apply-callback self :map)
(apply-callback-else (self :initialize)
(with-slots ((members children)) (menu-choice self)
(dolist (member members)
(apply-callback member :initialize)))))
;================================================================;
; DROP SHADOW CONTACT ;
;================================================================;
(defcontact drop-shadow (core composite)
((compress-exposures :initform :on))
(:documentation "A composite containing a content and a drop-shadow.")
(:resources (event-mask :initform #.(make-event-mask :exposure))))
(defmethod initialize-instance :after ((drop-shadow drop-shadow) &rest args)
(with-slots (background border-width) drop-shadow
;; Ignore background, border-width
(setf background :none)
(setf border-width 0))
;; Make the menu container to hold the content, title, & pushpin components.
(apply #'make-contact 'menu-container
:name :menu-container
:parent drop-shadow
args))
(defmethod preferred-size ((self drop-shadow) &key width height border-width)
(declare (ignore width height border-width))
(let*
((spec (get-OL-menu-spec self))
(dsw (OL-menu-spec-drop-shadow-width spec)))
(multiple-value-bind (pw ph pbw)
(preferred-size (first (composite-children self)))
(values
(+ dsw pbw pbw pw)
(+ dsw pbw pbw ph)
0))))
(defmethod display ((drop-shadow drop-shadow) &optional x y width height &key)
(declare (ignore x y width height))
(with-slots (children) drop-shadow
(when children
(with-slots (width height border-width) (first children)
(let*
((spec (get-OL-menu-spec drop-shadow))
(dsw (OL-menu-spec-drop-shadow-width spec))
(dso (OL-menu-spec-drop-shadow-offset spec))
(menu-container-width (+ width border-width border-width))
(menu-container-height (+ height border-width border-width)))
(using-gcontext (gc :drawable drop-shadow
:foreground (contact-foreground drop-shadow)
:fill-style :stippled
:stipple (contact-image-mask drop-shadow 50%gray :depth 1))
;; We draw a full rectangle, depending on the server to clip the
;; portion covered by the menu container.
(draw-rectangle drop-shadow gc
dso dso
(- (+ menu-container-width dsw) dso)
(- (+ menu-container-height dsw) dso)
:fill-p)))))))
(defmethod manage-geometry ((self drop-shadow) child x y width height border-width &key)
(let*
((spec (get-OL-menu-spec self))
(dsw (OL-menu-spec-drop-shadow-width spec))
(child-bw (or border-width (contact-border-width child)))
(width (or width (contact-width child)))
(height (or height (contact-height child)))
(drop-shadow-contact-width (+ width child-bw child-bw dsw))
(drop-shadow-contact-height (+ height child-bw child-bw dsw))
(self-change-not-required-p
(and (= (contact-width self) drop-shadow-contact-width)
(= (contact-height self) drop-shadow-contact-height)))
(approved-p
(and
(or (null x) (= x 0))
(or (null y) (= y 0))
(or self-change-not-required-p
(change-geometry self
:width drop-shadow-contact-width
:height drop-shadow-contact-height
:accept-p t)))))
(values
approved-p
0 0
(- (contact-width self) child-bw child-bw dsw)
(- (contact-height self) child-bw child-bw dsw)
child-bw)))
(defmethod change-layout ((self drop-shadow) &optional newly-managed)
(declare (ignore newly-managed))
(let((children (composite-children self)))
(when children
(let*
((spec (get-OL-menu-spec self))
(dsw (OL-menu-spec-drop-shadow-width spec))
(menu-container (first children))
(border-width (contact-border-width menu-container))
(width (contact-width menu-container))
(height (contact-height menu-container)))
(change-geometry
self
:width (+ width border-width border-width dsw)
:height (+ height border-width border-width dsw)
:accept-p t)))))
(defmethod add-child :before ((self drop-shadow) child &key)
(let((children (composite-children self)))
(when children
(error "~s already has child ~s; cannot add child ~s."
self
(first children)
child))))
(defmethod resize :after ((self drop-shadow) width height border-width)
(declare (ignore border-width))
(let*
((children (composite-children self))
(menu-container (first children))
(spec (get-OL-menu-spec self))
(dsw (OL-menu-spec-drop-shadow-width spec))
(bw (contact-border-width menu-container)))
(resize menu-container
(max 1 (- width bw bw dsw))
(max 1 (- height bw bw dsw))
bw)))
;================================================================;
; MENU-CONTAINER CONTACT ;
;================================================================;
(defcontact menu-container (core composite)
((compress-exposures :initform :on))
(:resources
(event-mask :initform #.(make-event-mask :exposure)))
(:documentation
"A composite containing a content and (optionally) a title and pushpin"))
(defmethod initialize-instance :after ((self menu-container)
&rest args
&key content (pushpin :off) title
&allow-other-keys)
(let ((menu (contact-parent (contact-parent self)))
(menu-spec (get-OL-menu-spec self)))
;; Initialize container window attributes.
(with-slots (background border-width) self
;; Inherit background from menu, not drop-shadow.
(when (eq :parent-relative background)
(setf background (contact-current-background menu)))
;; Inherit border-width from menu
(setf border-width (max (contact-border-width menu)
(point-pixels (contact-screen self)))))
;; Initialize content
(multiple-value-bind (content-constructor content-args)
(if (consp content) (values (first content) (rest content)) content)
(add-callback
(if (null content-args)
;; Default choice initialization
(funcall content-constructor
:name :content
:parent self
:border-width 0
:left-margin (OL-menu-spec-pushpin-dx menu-spec)
:right-margin (OL-menu-spec-pushpin-dx menu-spec)
:bottom-margin (OL-menu-spec-drop-shadow-offset menu-spec)
:top-margin (OL-menu-spec-drop-shadow-offset menu-spec)
:columns 1
:same-width-in-column :on)
;; Else use given content initargs
(apply content-constructor
:name :content
:parent self
:border-width 0
content-args))
:new-choice-item
#'add-menu-item-callbacks menu))
;; Initialize title field
(when title
(setf (menu-title menu) title))
;; Initialize pushpin
(when (eq pushpin :on)
(add-callback
(make-pushpin-button
:name :pushpin
:parent self
:label (pushpin-spec-image-out (get-pushpin-spec self)))
:off
#'dismiss-menu menu))))
;; A method so dialog-button can add daemons.
(defmethod add-menu-item-callbacks (item menu)
(when (typep item 'toggle-button)
(add-callback item :on #'dismiss-menu menu))
(add-callback item :off #'dismiss-menu menu))
(defun dismiss-menu (menu)
(unless (eq (contact-state menu) :withdrawn) ;i.e., already dismissed
;; +++ Pushpin hack: If the menu has a pushpin and it's :in, don't
;; withdraw the menu. It doesn't clone, but it does stay up.
(let ((pushpin (find :pushpin (composite-children
(contact-parent (menu-choice menu)))
:key #'contact-name)))
(unless (and pushpin
(eq :in (button-switch pushpin)))
(setf (contact-state menu) :withdrawn)))))
(defmethod display ((self menu-container)
&optional exposed-x exposed-y exposed-width exposed-height &key)
(declare (ignore exposed-x exposed-y exposed-width exposed-height))
(with-slots (children width foreground) self
(when (find :menu-title children :key #'contact-name)
(let ((tbar-x 4) ; Kludge! this is actually a function of scale.
(tbar-y (- (contact-y (find :content children :key #'contact-name)) 1)))
(using-gcontext (gc :drawable self :foreground foreground)
(draw-line self gc tbar-x tbar-y (- width tbar-x) tbar-y))))))
;================================================================;
; MENU-CONTAINER GEOMETRY MANAGEMENT ;
;================================================================;
(labels
(
(disapprove () NIL)
(fail () (error "Unable to layout menu-container." ))
(shrink/expand-title (title pw ph tw th cw ch failure-thunk)
(multiple-value-bind (tw1 th1)
(preferred-size title :width 0 :height 0)
(if (<= tw1 tw)
;; We assume it's OK to make title *wider* than preferred width,
;; but avoid making it narrower.
(values
(+ 2 (max (or (and pw tw (+ pw
(ol-menu-spec-title-dx (get-ol-menu-spec title))
(ol-menu-spec-title-dx (get-ol-menu-spec title))
tw))
(and tw
(+ tw
(ol-menu-spec-title-dx (get-ol-menu-spec title))
(ol-menu-spec-title-dx (get-ol-menu-spec title))))
0)
(+ cw (ol-menu-spec-title-dx (get-ol-menu-spec title))
(ol-menu-spec-title-dx (get-ol-menu-spec title))))) ;Allow 2 pixels for left & right border
(+ 2 ;Allow 2 pixels for top & bottom border
(or (and ph (max ph th1)) th1)
1 ;Allow 1 pixel for title bar
ch)
pw
ph
tw
th
cw
ch)
(funcall failure-thunk))))
(shrink/expand-content (content pw ph tw th cw ch failure-thunk)
(multiple-value-bind (cw1 ch1)
(preferred-size content :width 0 :height 0)
(if (<= cw1 cw)
;; We assume it's OK to make content *wider* than preferred width,
;; but avoid making it narrower.
(values
(+ 2 (max (or (and pw tw (+ pw
(ol-menu-spec-title-dx (get-ol-menu-spec content))
(ol-menu-spec-title-dx (get-ol-menu-spec content))
tw))
(and tw
(+ tw
(ol-menu-spec-title-dx (get-ol-menu-spec content))
(ol-menu-spec-title-dx (get-ol-menu-spec content))))
0)
(+ cw (ol-menu-spec-title-dx (get-ol-menu-spec content))
(ol-menu-spec-title-dx (get-ol-menu-spec content)))
)) ;Allow 2 pixels for left & right border ;; jba
(+ 2 ;Allow 2 pixels for top & bottom border
(or (and ph th (max ph th)) ph th 0)
(if th 1 0) ;Title bar only if title
ch1)
pw
ph
tw
th
cw1
ch)
(funcall failure-thunk))))
(reposition&resize (component cx cy cw ch)
(let
((x (contact-x component))
(y (contact-y component))
(w (contact-width component))
(h (contact-height component)))
(unless (and (= x cx) (= y cy)) (move component cx cy))
(unless (and (= w cw) (= h ch)) (resize component cw ch 0))))
(execute-layout (self width height ppin pw ph title tw th content cw ch)
(assert
(change-geometry self :width width :height height)
()
"Unable to layout menu ~a" self)
(multiple-value-bind (px py tx ty cx cy)
(locate-menu-components pw ph tw th width self)
(when ppin (reposition&resize ppin px py pw ph))
(when title
(reposition&resize title tx ty tw th))
(when content (reposition&resize content cx cy cw ch))) )
(locate-menu-components (pw ph tw th width self)
(cond
((and pw tw)
(values
0 0 ; x & y for pushpin
(+ pw (ol-menu-spec-title-dx (get-ol-menu-spec self)) ) 0 ; x & y for title
(max (ol-menu-spec-title-dx (get-ol-menu-spec self))
(pixel-round (- width
(contact-width (find :content (composite-children self) :key #'contact-name)))
2))
(+ (max ph th) 1))) ;x & y for content
(pw
(values
0 0
NIL NIL
(max (ol-menu-spec-title-dx (get-ol-menu-spec self))
(pixel-round (- width
(contact-width (find :content (composite-children self) :key #'contact-name)))
2))
ph))
(tw
(values
NIL NIL
(max (ol-menu-spec-title-dx (get-ol-menu-spec self))
(pixel-round (- width
(contact-width (find :menu-title (composite-children self) :key #'contact-name)))
2))
0
(max (ol-menu-spec-title-dx (get-ol-menu-spec self))
(pixel-round (- width
(contact-width (find :content (composite-children self) :key #'contact-name)))
2))
(+ 1 th)))
(t
(values
NIL NIL
NIL NIL
0 0))))
(layout-menu-container (ppin pw ph title tw th content cw ch)
(cond
((and title ppin)
; Menu has title and pushpin in addition to content
(let ((title-area-height (max ph th)))
(if (= (+ tw pw) cw)
(values
(+ 2 cw (ol-menu-spec-title-dx (get-ol-menu-spec content))
(ol-menu-spec-title-dx (get-ol-menu-spec content)))
(+ 2 title-area-height 1 ch)
pw title-area-height
tw title-area-height
cw ch)
;; We must expand/shrink title or shrink/expand content.
(let((newtw (- cw pw)))
(if (< newtw 0)
(shrink/expand-content content pw ph tw th (+ tw pw) ch #'fail)
(shrink/expand-title
title
pw
title-area-height
newtw
title-area-height
cw
ch
#'(lambda()
(shrink/expand-content
content
pw
title-area-height
tw
title-area-height
(+ tw pw) ; Will fail when title is bigger, so width is title width.
ch
#'fail))))))))
(title
;Menu has title, but no pushpin
(if (= tw cw)
(values
(+ 2 cw (ol-menu-spec-title-dx (get-ol-menu-spec content))
(ol-menu-spec-title-dx (get-ol-menu-spec content)))
(+ 2 th 1 ch)
pw ph
tw th
cw ch)
(shrink/expand-title
title
pw
ph
tw
th
cw
ch
#'(lambda()
(shrink/expand-content content pw ph tw th tw ch #'fail)))
))
(ppin
;Menu has pushpin, but no title
(if (> cw pw)
(values (+ 2 cw (ol-menu-spec-title-dx (get-ol-menu-spec content))
(ol-menu-spec-title-dx (get-ol-menu-spec content)))
(+ 2 ph ch) pw ph tw th cw ch)
(shrink/expand-content content pw ph tw th pw ch #'fail)))
(t
;Menu has neither pushpin nor title
(values (+ 2 cw) (+ 2 ch) pw ph tw th cw ch)))) )
(defmethod change-layout ((self menu-container) &optional newly-managed)
(declare (ignore newly-managed))
(let*
((children (composite-children self))
(content (find :content children :key #'contact-name))
(cw (contact-width content))
(ch (contact-height content))
(title (find :menu-title children :key #'contact-name))
(tw (and title (contact-width title)))
(th (and title (contact-height title)))
(ppin (find :pushpin children :key #'contact-name))
(pw (and ppin (contact-width ppin)))
(ph (and ppin (contact-height ppin))))
(multiple-value-bind (width height pw1 ph1 tw1 th1 cw1 ch1)
(layout-menu-container ppin pw ph title tw th content cw ch)
(execute-layout self width height ppin pw1 ph1 title tw1 th1 content cw1 ch1))))
(defmethod preferred-size ((self menu-container) &key width height border-width)
(declare (ignore width height border-width))
(let*
((children (composite-children self))
(content (find :content children :key #'contact-name))
(title (find :menu-title children :key #'contact-name))
(ppin (find :pushpin children :key #'contact-name)))
(MULTIPLE-VALUE-BIND (cw ch)
(preferred-size content :width 0 :height 0)
(MULTIPLE-VALUE-BIND (tw th)
(AND title (preferred-size title :width 0 :height 0))
(MULTIPLE-VALUE-BIND (pw ph)
(AND ppin (preferred-size ppin))
(MULTIPLE-VALUE-BIND (preferred-width preferred-height)
(layout-menu-container ppin pw ph title tw th content cw ch)
(VALUES preferred-width preferred-height 0)))))))
(defmethod manage-geometry ((self menu-container) child x y width height bw &key)
(let*
((children (composite-children self))
(content (find :content children :key #'contact-name))
(cw (contact-width content))
(ch (contact-height content))
(title (find :menu-title children :key #'contact-name))
(tw (and title (contact-width title)))
(th (and title (contact-height title)))
(ppin (find :pushpin children :key #'contact-name))
(pw (and ppin (contact-width ppin)))
(ph (and ppin (contact-height ppin)))
(x (or x (contact-x child)))
(y (or y (contact-y child)))
(width (or width (contact-width child)))
(height (or height (contact-height child))))
(multiple-value-bind (self-width self-height pw1 ph1 tw1 th1 cw1 ch1)
(cond
((eq child content)
(cond
(title
;; If there is a title then try to adjust it
(shrink/expand-title
title
pw
ph
(if pw (- width pw) width)
th
width
height
;; If title adjust fails then try to adjust content
;; so can at least offer compromise.
#'(lambda()
(shrink/expand-content
content
pw
ph
tw
th
(or (and pw (+ pw tw)) tw)
height
#'disapprove))))
(ppin
;; If ppin exists must make sure content is at least as wide
(if (> width pw)
(values (+ 2 width) (+ 2 height ph 1) pw ph tw th width height)
(shrink/expand-content
content
pw
ph
tw
th
pw
height
#'disapprove)))
(t
;; Menu has neither pushpin nor title
(values
(+ 2 width) (+ 2 height) pw ph tw th width height))))
((eq child title)
(shrink/expand-content
content
pw
ph
width
height
(if ppin (+ pw tw) tw)
ch
#'(lambda()
(shrink/expand-title
title
pw
ph
(if ppin (- cw pw) width)
height
cw
ch
#'disapprove))))
;; It must be the pushpin which has changed
(title
(shrink/expand-title
title
width
height
(- cw width)
th
cw
ch
#'(lambda()
(shrink/expand-content
content
width
height
tw
th
(+ width tw)
ch
#'disapprove))))
;; Pushpin is being managed, but no title to adjust, so must adjust content.
((< cw width)
;; If the content width is less than the requested pushpin width we try to
;; shrink the content accordingly. (Pretty unlikely case, eh?)
(shrink/expand-content
content
width
height
tw
th
width
ch
#'disapprove))
(t
;; Else the content is at least as wide as the pushpin and we can simply
;; accept the pushpin change without any ripple effects.
(values
(+ 2 cw) (+ 2 ch ph)
width height
tw th
cw ch)))
(and
self-width ;Width = NIL implies failure without suggesting compromise.
(multiple-value-bind (px1 py1 tx1 ty1 cx1 cy1)
(locate-menu-components pw1 ph1 tw1 th1 self-width self)
(let
((self-change-approved
(or
(and
(= self-width (contact-width self))
(= self-height (contact-height self)))
(change-geometry self
:width self-width
:height self-height
:accept-p nil)))
(approve-p
(and
(or (null bw) (= 0 bw))
(cond
((eq child ppin) (and (= pw1 width) (= ph1 height)
(= px1 x) (= py1 y)))
((eq child title) (and (= tw1 width) (= th1 height)
(= tx1 x) (= ty1 y)
)
)
(t (and (= cw1 width) (= ch1 height)
(= cx1 x) (= cy1 y)))))))
(and
self-change-approved
(progn
(when approve-p
(execute-layout
self self-width self-height
ppin pw1 ph1
title tw1 th1
content cw1 ch1))
(cond
((eq child ppin) (values approve-p px1 py1 pw1 ph1 0))
((eq child title) (values approve-p tx1 ty1 tw1 th1 0))
(t (values approve-p cx1 cy1 cw1 ch1 0))))))))))))
|
