/[mcclim]/mcclim/gadgets.lisp
ViewVC logotype

Contents of /mcclim/gadgets.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.113 - (show annotations)
Thu Oct 29 14:05:04 2009 UTC (4 years, 5 months ago) by ahefner
Branch: MAIN
CVS Tags: HEAD
Changes since 1.112: +2 -2 lines
Fix dynamic extent declarations in with-output-as-gadget.
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 2000 by
4 ;;; Arthur Lemmens (lemmens@simplex.nl),
5 ;;; Iban Hatchondo (hatchond@emi.u-bordeaux.fr)
6 ;;; and Julien Boninfante (boninfan@emi.u-bordeaux.fr)
7 ;;; (c) copyright 2001 by
8 ;;; Lionel Salabartan (salabart@emi.u-bordeaux.fr)
9 ;;; (c) copyright 2001 by Michael McDonald (mikemac@mikemac.com)
10 ;;; (c) copyright 2001 by Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
11
12 ;;; This library is free software; you can redistribute it and/or
13 ;;; modify it under the terms of the GNU Library General Public
14 ;;; License as published by the Free Software Foundation; either
15 ;;; version 2 of the License, or (at your option) any later version.
16 ;;;
17 ;;; This library is distributed in the hope that it will be useful,
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
20 ;;; Library General Public License for more details.
21 ;;;
22 ;;; You should have received a copy of the GNU Library General Public
23 ;;; License along with this library; if not, write to the
24 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 ;;; Boston, MA 02111-1307 USA.
26
27 (in-package :clim-internals)
28
29 ;;;; Notes
30
31 ;; There is STANDARD-GADGET in this file but not in the spec, where
32 ;; from? Lispworks?
33
34 ;; The spec says ORIENTED-GADGET-MIXIN, we call it ORIENTED-GADGET and
35 ;; later define ORIENTED-GADGET-MIXIN with the remark "Try to be
36 ;; compatible with Lispworks' CLIM."
37 ;;
38 ;; This makes me suspect, that either "ORIENTED-GADGET-MIXIN" in the
39 ;; spec is a typo, or all other classes like e.g. ACTION-GADGET should
40 ;; really be named e.g. ACTION-GADGET-MIXIN. Also that would make more
41 ;; sense to me. --GB
42
43 ;; We have: LABELLED-GADGET, the spec has LABELLED-GADGET-MIXIN. Typo?
44 ;; Compatibility?
45
46 ;; Why is there GADGET-LABEL-TEXT-STYLE? The spec says, that just the
47 ;; pane's text-style should be borrowed.
48
49 ;; RANGE-GADGET / RANGE-GADGET-MIXIN: same thing as with
50 ;; ORIENTED-GADGET-MIXIN.
51
52 ;; Why is there no (SETF GADGET-RANGE*) in the spec? Omission?
53
54 ;; I would like to make COMPOSE-LABEL-SPACE and DRAW-LABEL* into some
55 ;; sort of label protocol, so that application programmers can
56 ;; programm their own sort of labels alleviateing the need for
57 ;; something like a drawn button gadget.
58 ;;
59 ;; Q: Can we make it so that a mixin class can override another mixin
60 ;; class?
61 ;;
62 ;; All the programmer should need to do is e.g.
63 ;;
64 ;; (defclass pattern-label-mixin ()
65 ;; (pattern :initarg :pattern))
66 ;;
67 ;; (defmethod compose-label-space ((me pattern-label-mixin))
68 ;; (with-slots (pattern) me
69 ;; (make-space-requirement :width (pattern-width pattern)
70 ;; :height (pattern-height pattern))))
71 ;;
72 ;; (defmethod draw-label ((me pattern-label-mixin) x1 y1 x2 y2)
73 ;; (with-slots (pattern) me
74 ;; (draw-design me (transform-region (make-translation-transformation x1 y1)
75 ;; pattern))))
76 ;;
77 ;; (defclass patterned-button (pattern-label-mixin push-button-pane)
78 ;; ())
79 ;;
80 ;; But then this probably is backwards. Specifing that :LABEL can be
81 ;; another pane probably is much easier and would still allow for the
82 ;; backend to choose the concrete widget class for us.
83 ;;
84 ;; --GB
85
86 ;; - Should RADIO-BOX-PANE and CHECK-BOX-PANE use rack or box layout?
87
88 ;; - :CHOICES initarg to RADIO-BOX and CHECK-BOX is from Franz' user
89 ;; guide.
90
91 ;;;; TODO
92
93 ;; - the scroll-bar needs more work:
94 ;; . dragging should not change the value, the value should only
95 ;; be changed after releasing the mouse.
96 ;; . it should arm/disarm
97 ;; . it should be deactivatable
98
99 ;; - the slider needs a total overhaul
100
101 ;; - TEXT-FILED, TEXT-AREA dito
102
103 ;; - GADGET-COLOR-MIXIN is currently kind of dangling, we should reuse
104 ;; it for effective-gadget-foreground et al.
105
106 ;; - The color of a 3Dish border should be derived from a gadget's
107 ;; background.
108
109 ;; - It seems that 3D-BORDER-MIXIN is only used for the scroll-bar, so
110 ;; remove it
111
112 ;; - Somehow engrafting the push button's medium does not work. The
113 ;; text-style initarg does not make it to the sheets medium.
114
115 ;; - make NIL a valid label, and take it into account when applying
116 ;; spacing.
117
118 ;;;; --------------------------------------------------------------------------
119 ;;;;
120 ;;;; 30.3 Basic Gadget Classes
121 ;;;;
122
123 ;;; XXX I'm not sure that *application-frame* should be rebound like this. What
124 ;;; about gadgets in accepting-values windows? An accepting-values window
125 ;;; shouldn't be bound to *application-frame*. -- moore
126 (defun invoke-callback (pane callback &rest more-arguments)
127 (when callback
128 (let ((*application-frame* (pane-frame pane)))
129 (apply callback pane more-arguments))))
130
131 ;;
132 ;; gadget sub-classes
133 ;;
134
135 ;;
136 ;; gadget's colors
137 ;;
138
139 (defclass gadget-color-mixin ()
140 ((normal :type color
141 :initform +gray80+
142 :initarg :normal
143 :accessor gadget-normal-color)
144 (highlighted :type color
145 :initform +gray85+
146 :initarg :highlighted
147 :accessor gadget-highlighted-color)
148 (pushed-and-highlighted :type color
149 :initform +gray75+
150 :initarg :pushed-and-highlighted
151 :accessor gadget-pushed-and-highlighted-color)
152 (current-color :type color
153 :accessor gadget-current-color))
154 (:documentation "This class define the gadgets colors."))
155
156 (defmethod initialize-instance :after ((gadget gadget-color-mixin) &rest args)
157 (declare (ignore args))
158 (setf (slot-value gadget 'current-color) (gadget-normal-color gadget)))
159
160 (defmethod (setf gadget-current-color) :after (color (gadget gadget-color-mixin))
161 (declare (ignore color))
162 (dispatch-repaint gadget (sheet-region gadget)))
163
164 #||
165 ;; Labelled-gadget
166
167 (defgeneric draw-label (gadget label x y))
168
169 (defmethod compose-space ((pane labelled-gadget) &key width height)
170 (declare (ignore width height))
171 (compose-space-aux pane (gadget-label pane)))
172
173 (defmethod compose-space-aux ((pane labelled-gadget) (label string))
174 (with-sheet-medium (medium pane)
175 (let ((as (text-style-ascent (gadget-label-text-style pane) pane))
176 (ds (text-style-descent (gadget-label-text-style pane) pane)))
177 (multiple-value-bind (width height)
178 (text-size medium (gadget-label pane)
179 :text-style (gadget-label-text-style pane))
180 (setf height (+ as ds))
181 ;; FIXME remove explicit values
182 ;; instead use spacer pane in derived classes
183 (let ((tw (* 1.3 width))
184 (th (* 2.5 height)))
185 (setf th (+ 6 height))
186 (make-space-requirement :width tw :height th
187 :max-width 400 :max-height 400
188 :min-width tw :min-height th))))))
189
190 (defmethod draw-label ((pane labelled-gadget) (label string) x y)
191 (draw-text* pane label
192 x y
193 :align-x (gadget-label-align-x pane)
194 :align-y (gadget-label-align-y pane)
195 :text-style (gadget-label-text-style pane)))
196 ||#
197
198 (defclass basic-gadget (permanent-medium-sheet-output-mixin
199 ;; sheet-leaf-mixin ; <- this cannot go here...
200 gadget-color-mixin
201 ;; These are inherited from pane, via
202 ;; clim-sheet-input-mixin and clim-repainting-mixin
203 ;; immediate-sheet-input-mixin
204 ;; immediate-repainting-mixin
205 basic-pane
206 gadget)
207 ())
208
209
210
211 ;; Where is this standard-gadget from? --GB
212 (defclass standard-gadget (basic-gadget)
213 ())
214
215 (defgeneric armed-callback (gadget client gadget-id)
216 (:argument-precedence-order client gadget-id gadget))
217
218 (defgeneric disarmed-callback (gadget client gadget-id)
219 (:argument-precedence-order client gadget-id gadget))
220
221 ;; "The default methods (on standard-gadget) call the function stored
222 ;; in gadget-armed-callback or gadget-disarmed-callback with one argument,
223 ;; the gadget."
224
225 (defmethod armed-callback ((gadget basic-gadget) client gadget-id)
226 (declare (ignore client gadget-id))
227 (invoke-callback gadget (gadget-armed-callback gadget)))
228
229 (defmethod disarmed-callback ((gadget basic-gadget) client gadget-id)
230 (declare (ignore client gadget-id))
231 (invoke-callback gadget (gadget-disarmed-callback gadget)))
232
233 ;;
234 ;; arming and disarming gadgets
235 ;;
236
237 ;; Redrawing is supposed to be handled on an :AFTER method on arm- and
238 ;; disarm-callback.
239
240 (defmethod arm-gadget ((gadget basic-gadget) &optional (value t))
241 (with-slots (armed) gadget
242 (unless (eql armed value)
243 (setf armed value)
244 (if value
245 (armed-callback gadget (gadget-client gadget) (gadget-id gadget))
246 (disarmed-callback gadget (gadget-client gadget) (gadget-id gadget))))))
247
248 (defmethod disarm-gadget ((gadget basic-gadget))
249 (arm-gadget gadget nil))
250
251 ;;;
252 ;;; Activation
253 ;;;
254
255 (defgeneric activate-gadget (gadget))
256 (defgeneric deactivate-gadget (gadget))
257 (defgeneric note-gadget-activated (client gadget))
258 (defgeneric note-gadget-deactivated (client gadget))
259
260 (defmethod activate-gadget ((gadget gadget))
261 (with-slots (active-p) gadget
262 (unless active-p
263 (setf active-p t)
264 (note-gadget-activated (gadget-client gadget) gadget))))
265
266 (defmethod deactivate-gadget ((gadget gadget))
267 (with-slots (active-p) gadget
268 (when active-p
269 (setf active-p nil)
270 (note-gadget-deactivated (gadget-client gadget) gadget))))
271
272 (defmethod note-gadget-activated (client (gadget gadget))
273 (declare (ignore client))
274 ;; Default: do nothing
275 )
276
277 (defmethod note-gadget-deactivated (client (gadget gadget))
278 (declare (ignore client))
279 ;; Default: do nothing
280 )
281
282 ;;;
283 ;;; Value-gadget
284 ;;;
285
286 (defclass value-gadget (standard-gadget)
287 ((value :initarg :value
288 :reader gadget-value)
289 (value-changed-callback :initarg :value-changed-callback
290 :initform nil
291 :reader gadget-value-changed-callback)))
292
293 (defmethod (setf gadget-value) (value (gadget value-gadget) &key invoke-callback)
294 (setf (slot-value gadget 'value) value)
295 (when invoke-callback
296 (value-changed-callback gadget
297 (gadget-client gadget)
298 (gadget-id gadget)
299 value)))
300
301 (defgeneric value-changed-callback (gadget client gadget-id value)
302 (:argument-precedence-order client gadget-id value gadget))
303
304 (defmethod value-changed-callback ((gadget value-gadget) client gadget-id value)
305 (declare (ignore client gadget-id))
306 (invoke-callback gadget (gadget-value-changed-callback gadget) value))
307
308 ;;;
309 ;;; Action-gadget
310 ;;;
311
312 (defclass action-gadget (standard-gadget)
313 ((activate-callback :initarg :activate-callback
314 :initform nil
315 :reader gadget-activate-callback)))
316
317 (defgeneric activate-callback (action-gadget client gadget-id)
318 (:argument-precedence-order client gadget-id action-gadget))
319
320 (defmethod activate-callback ((gadget action-gadget) client gadget-id)
321 (declare (ignore client gadget-id))
322 (invoke-callback gadget (gadget-activate-callback gadget)))
323
324 ;;;
325 ;;; Oriented-gadget
326 ;;;
327
328 (defclass oriented-gadget ()
329 ((orientation :type (member :vertical :horizontal)
330 :initarg :orientation
331 :reader gadget-orientation)))
332
333 (defclass oriented-gadget-mixin (oriented-gadget)
334 ;; Try to be compatible with Lispworks' CLIM.
335 ())
336
337 ;;;;
338 ;;;; labelled-gadget
339 ;;;;
340
341 (defclass labelled-gadget ()
342 ((label :initarg :label
343 :initform ""
344 :accessor gadget-label)
345 #+nil
346 (align-x :initarg :align-x
347 :accessor gadget-label-align-x)
348 #+nil
349 (align-y :initarg :align-y
350 :accessor gadget-label-align-y)
351 #+nil
352 (text-style :initform *default-text-style*
353 :initarg :text-style
354 :accessor gadget-text-style)))
355
356 (defclass labelled-gadget-mixin (labelled-gadget)
357 ;; Try to be compatible with Lispworks' CLIM.
358 ())
359
360 ;;;;
361 ;;;; Range-gadget
362 ;;;;
363
364 (defclass range-gadget ()
365 ((min-value :initarg :min-value
366 :accessor gadget-min-value)
367 (max-value :initarg :max-value
368 :accessor gadget-max-value)))
369
370 (defclass range-gadget-mixin (range-gadget)
371 ;; Try to be compatible with Lispworks' CLIM.
372 ())
373
374 (defgeneric gadget-range (range-gadget)
375 (:documentation
376 "Returns the difference of the maximum and minimum value of RANGE-GADGET."))
377
378 (defmethod gadget-range ((gadget range-gadget))
379 (- (gadget-max-value gadget)
380 (gadget-min-value gadget)))
381
382 (defgeneric gadget-range* (range-gadget)
383 (:documentation
384 "Returns the minimum and maximum value of RANGE-GADGET as two values."))
385
386 (defmethod gadget-range* ((gadget range-gadget))
387 (values (gadget-min-value gadget)
388 (gadget-max-value gadget)))
389
390
391 ;;;; ------------------------------------------------------------------------------------------
392 ;;;;
393 ;;;; 30.4 Abstract Gadget Classes
394 ;;;;
395
396 ;;; 30.4.1 The abstract push-button Gadget
397
398 (defclass push-button (labelled-gadget-mixin action-gadget)
399 ())
400
401 ;;; 30.4.2 The abstract toggle-button Gadget
402
403 (defclass toggle-button (labelled-gadget-mixin value-gadget)
404 ()
405 (:documentation "The value is either t either nil"))
406
407 ;;; 30.4.3 The abstract menu-button Gadget
408
409 (defclass menu-button (labelled-gadget-mixin value-gadget)
410 ()
411 (:documentation "The value is a button"))
412
413 ;;; 30.4.4 The abstract scroll-bar Gadget
414
415 (defgeneric drag-callback (pane client gadget-id value)
416 (:argument-precedence-order client gadget-id value pane))
417
418 (defgeneric scroll-to-top-callback (scroll-bar client gadget-id)
419 (:argument-precedence-order client gadget-id scroll-bar))
420
421 (defgeneric scroll-to-bottom-callback (scroll-bar client gadget-id)
422 (:argument-precedence-order client gadget-id scroll-bar))
423
424 (defgeneric scroll-up-line-callback (scroll-bar client gadget-id)
425 (:argument-precedence-order client gadget-id scroll-bar))
426
427 (defgeneric scroll-up-page-callback (scroll-bar client gadget-id)
428 (:argument-precedence-order client gadget-id scroll-bar))
429
430 (defgeneric scroll-down-line-callback (scroll-bar client gadget-id)
431 (:argument-precedence-order client gadget-id scroll-bar))
432
433 (defgeneric scroll-down-page-callback (scroll-bar client gadget-id)
434 (:argument-precedence-order client gadget-id scroll-bar))
435
436 (defclass scroll-bar (value-gadget oriented-gadget-mixin range-gadget-mixin)
437 ((drag-callback :initarg :drag-callback
438 :initform nil
439 :reader scroll-bar-drag-callback)
440 (scroll-to-bottom-callback :initarg :scroll-to-bottom-callback
441 :initform nil
442 :reader scroll-bar-scroll-to-bottom-callback)
443 (scroll-to-top-callback :initarg :scroll-to-top-callback
444 :initform nil
445 :reader scroll-bar-scroll-to-top-callback)
446 (scroll-down-line-callback :initarg :scroll-down-line-callback
447 :initform nil
448 :reader scroll-bar-scroll-down-line-callback)
449 (scroll-up-line-callback :initarg :scroll-up-line-callback
450 :initform nil
451 :reader scroll-bar-scroll-up-line-callback)
452 (scroll-down-page-callback :initarg :scroll-down-page-callback
453 :initform nil
454 :reader scroll-bar-scroll-down-page-callback)
455 (scroll-up-page-callback :initarg :scroll-up-page-callback
456 :initform nil
457 :reader scroll-bar-scroll-up-page-callback)
458 (thumb-size :initarg :thumb-size :initform 1/4
459 :accessor scroll-bar-thumb-size
460 :documentation "The size of the scroll bar thumb (slug) in the
461 units of the gadget value. When the scroll bar is drawn the empty region of
462 the scroll bar and the thumb are drawn in proportion to the values of the
463 gadget range and thumb size."))
464 (:default-initargs :value 0
465 :min-value 0
466 :max-value 1
467 :orientation :vertical))
468
469 (defmethod drag-callback ((pane scroll-bar) client gadget-id value)
470 (declare (ignore client gadget-id))
471 (invoke-callback pane (scroll-bar-drag-callback pane) value))
472
473 (defmethod scroll-to-top-callback ((pane scroll-bar) client gadget-id)
474 (declare (ignore client gadget-id))
475 (invoke-callback pane (scroll-bar-scroll-to-top-callback pane)))
476
477 (defmethod scroll-to-bottom-callback ((pane scroll-bar) client gadget-id)
478 (declare (ignore client gadget-id))
479 (invoke-callback pane (scroll-bar-scroll-to-bottom-callback pane)))
480
481 (defmethod scroll-up-line-callback ((pane scroll-bar) client gadget-id)
482 (declare (ignore client gadget-id))
483 (invoke-callback pane (scroll-bar-scroll-up-line-callback pane)))
484
485 (defmethod scroll-up-page-callback ((pane scroll-bar) client gadget-id)
486 (declare (ignore client gadget-id))
487 (invoke-callback pane (scroll-bar-scroll-up-page-callback pane)))
488
489 (defmethod scroll-down-line-callback ((pane scroll-bar) client gadget-id)
490 (declare (ignore client gadget-id))
491 (invoke-callback pane (scroll-bar-scroll-down-line-callback pane)))
492
493 (defmethod scroll-down-page-callback ((pane scroll-bar) client gadget-id)
494 (declare (ignore client gadget-id))
495 (invoke-callback pane (scroll-bar-scroll-down-page-callback pane)))
496
497 ;;; 30.4.5 The abstract slider Gadget
498
499 (defclass slider-gadget (labelled-gadget-mixin
500 value-gadget
501 oriented-gadget-mixin
502 range-gadget-mixin
503 gadget-color-mixin
504 ;;
505 value-changed-repaint-mixin
506 )
507 ()
508 (:documentation "The value is a real number, and default value for orientation is :vertical,
509 and must never be nil."))
510
511 ;;; 30.4.6 The abstract radio-box and check-box Gadgets
512
513 ;; The only real different between a RADIO-BOX and a CHECK-BOX is the
514 ;; number of allowed selections.
515
516 (defclass radio-box (value-gadget oriented-gadget-mixin)
517 ()
518 (:documentation "The value is a button")
519 (:default-initargs
520 :value nil))
521
522 ;; RADIO-BOX-CURRENT-SELECTION is just a synonym for GADGET-VALUE:
523
524 (defmethod radio-box-current-selection ((radio-box radio-box))
525 (gadget-value radio-box))
526
527 (defmethod (setf radio-box-current-selection) (new-value (radio-box radio-box))
528 (setf (gadget-value radio-box) new-value))
529
530 (defmethod radio-box-selections ((pane radio-box))
531 (let ((v (radio-box-current-selection pane)))
532 (and v (list v))))
533
534 (defmethod value-changed-callback :before (value-gadget (client radio-box) gadget-id value)
535 (declare (ignorable value-gadget gadget-id value))
536 ;; Note that we ignore 'value', this is because if value is non-NIL,
537 ;; then the toggle button was turned off, which would make no
538 ;; toggle-button turned on => constraint "always exactly one
539 ;; selected" missed. So simply turning this toggle button on again
540 ;; fixes it.
541 (unless (or (and (not value)
542 (not (eq (gadget-value client) value-gadget)))
543 (and value
544 (eq (gadget-value client) value-gadget)))
545 (setf (gadget-value client :invoke-callback t) value-gadget)))
546
547 ;;;; CHECK-BOX
548
549 (defclass check-box (value-gadget oriented-gadget-mixin)
550 ()
551 (:documentation "The value is a list of buttons")
552 (:default-initargs
553 :value nil
554 :orientation :vertical))
555
556 ;; CHECK-BOX-CURRENT-SELECTION is just a synonym for GADGET-VALUE:
557
558 (defmethod check-box-current-selection ((check-box check-box))
559 (gadget-value check-box))
560
561 (defmethod (setf check-box-current-selection) (new-value (check-box check-box))
562 (setf (gadget-value check-box) new-value))
563
564 (defmethod value-changed-callback :before (value-gadget (client check-box) gadget-id value)
565 (declare (ignorable gadget-id))
566 (if value
567 (setf (gadget-value client :invoke-callback t)
568 (adjoin value-gadget (gadget-value client)))
569 (setf (gadget-value client :invoke-callback t)
570 (remove value-gadget (gadget-value client)))))
571
572 (defmethod (setf gadget-value) :after (buttons (check-box check-box) &key invoke-callback)
573 ;; this is silly, but works ...
574 (dolist (c (sheet-children check-box))
575 (unless (eq (not (null (member c buttons)))
576 (not (null (gadget-value c))))
577 (setf (gadget-value c :invoke-callback invoke-callback) (member c buttons)) )))
578
579 (defmacro with-radio-box ((&rest options
580 &key (type :one-of) (orientation :vertical) &allow-other-keys)
581 &body body)
582 (let ((contents (gensym "CONTENTS-"))
583 (selected-p (gensym "SELECTED-P-"))
584 (initial-selection (gensym "INITIAL-SELECTION-")))
585 `(let ((,contents nil)
586 (,selected-p nil)
587 (,initial-selection nil))
588 (declare (special ,selected-p))
589 (flet ((make-pane (type &rest options)
590 (cond ((eq type 'toggle-button)
591 (let ((pane (apply #'make-pane type
592 :value ,selected-p
593 :indicator-type ',type
594 options)))
595 (push pane ,contents)
596 (when ,selected-p
597 (push pane ,initial-selection))))
598 (t
599 (error "oops")))))
600 (macrolet ((radio-box-current-selection (subform)
601 `(let ((,',selected-p t))
602 (declare (special ,',selected-p))
603 ,(cond ((stringp subform)
604 `(make-pane 'toggle-button :label ,subform))
605 (t
606 subform)))))
607 ,@(mapcar (lambda (form)
608 (cond ((stringp form)
609 `(make-pane 'toggle-button :label ,form))
610 (t
611 form)))
612 body)))
613 (make-pane ',(if (eq type :one-of)
614 'radio-box
615 'check-box)
616 :orientation ',orientation
617 :current-selection ,(if (eq type :one-of)
618 `(or (first ,initial-selection)
619 (first ,contents))
620 `,initial-selection)
621 :choices (reverse ,contents)
622 ,@options))))
623
624 ;;; 30.4.7 The abstract list-pane and option-pane Gadgets
625
626 (defclass list-pane (value-gadget)
627 ()
628 (:documentation
629 "The instantiable class that implements an abstract list pane, that is, a gadget
630 whose semantics are similar to a radio box or check box, but whose visual
631 appearance is a list of buttons.")
632 (:default-initargs :value nil))
633
634 (defclass option-pane (value-gadget)
635 ()
636 (:documentation
637 "The instantiable class that implements an abstract option pane, that is, a
638 gadget whose semantics are identical to a list pane, but whose visual
639 appearance is a single push button which, when pressed, pops up a menu of
640 selections."))
641
642 ;;; 30.4.8 The abstract text-field Gadget
643
644 (defclass text-field (value-gadget action-gadget)
645 ((editable-p :accessor editable-p :initarg editable-p :initform t))
646 (:documentation "The value is a string")
647 (:default-initargs :value ""))
648
649 (defmethod initialize-instance :after ((gadget text-field) &rest rest)
650 (unless (getf rest :normal)
651 (setf (slot-value gadget 'current-color) +white+
652 (slot-value gadget 'normal) +white+)))
653
654 ;;; 30.4.9 The abstract text-editor Gadget
655
656 (defclass text-editor (text-field)
657 ()
658 (:documentation "The value is a string"))
659
660 ;;;; ------------------------------------------------------------------------------------------
661 ;;;;
662 ;;;; Mixin Classes for Concrete Gadgets
663 ;;;;
664
665 (defclass standard-gadget-pane (;;permanent-medium-sheet-output-mixin
666 ;;immediate-sheet-input-mixin
667 ;;immediate-repainting-mixin
668 sheet-leaf-mixin
669 standard-gadget)
670 ()
671 (:documentation
672 "PANE class to include in gadget pane classes."))
673
674 ;;;; Redrawing mixins
675
676 (defclass arm/disarm-repaint-mixin ()
677 ()
678 (:documentation
679 "Mixin class for gadgets, whose appearence depends on its armed state."))
680
681 (defmethod armed-callback :after ((gadget arm/disarm-repaint-mixin) client id)
682 (declare (ignore client id))
683 (dispatch-repaint gadget (or (pane-viewport-region gadget)
684 (sheet-region gadget))))
685
686 (defmethod disarmed-callback :after ((gadget arm/disarm-repaint-mixin) client id)
687 (declare (ignore client id))
688 (dispatch-repaint gadget (or (pane-viewport-region gadget)
689 (sheet-region gadget))))
690
691 (defclass value-changed-repaint-mixin ()
692 ()
693 (:documentation
694 "Mixin class for gadgets, whose appearence depends on its value."))
695
696 (defmethod (setf gadget-value) :after (new-value (gadget value-changed-repaint-mixin)
697 &key &allow-other-keys)
698 (declare (ignore new-value))
699 (dispatch-repaint gadget (or (pane-viewport-region gadget)
700 (sheet-region gadget))))
701
702 ;;;; Event handling mixins
703
704 (defclass enter/exit-arms/disarms-mixin ()
705 ()
706 (:documentation
707 "Mixin class for gadgets which are armed when the mouse enters and
708 disarmed when the mouse leaves."))
709
710 (defmethod handle-event :before ((pane enter/exit-arms/disarms-mixin) (event pointer-enter-event))
711 (declare (ignorable event))
712 (arm-gadget pane))
713
714 (defmethod handle-event :after ((pane enter/exit-arms/disarms-mixin) (event pointer-exit-event))
715 (declare (ignorable event))
716 (disarm-gadget pane))
717
718 ;;;; changing-label-invokes-layout-protocol-mixin
719
720 (defclass changing-label-invokes-layout-protocol-mixin ()
721 ()
722 (:documentation
723 "Mixin class for gadgets, which want invoke the layout protocol, if the label changes."))
724
725 ;;;; Common behavior on STANDARD-GADGET-PANE and BASIC-GADGET
726
727 ;;
728 ;; When a gadget is not activated, it receives no device events.
729 ;;
730 (defmethod handle-event :around ((pane standard-gadget) (event device-event))
731 (when (gadget-active-p pane)
732 (call-next-method)))
733
734 ;; When a gadget is deactivated, it cannot be armed.
735
736 ;; Glitch: upon re-activation the mouse might happen to be in the
737 ;; gadget and thus re-arm it immediately, that is not implemented.
738
739 (defmethod note-gadget-deactivated :after (client (gadget standard-gadget))
740 (declare (ignorable client))
741 (disarm-gadget gadget))
742
743 ;;;; ------------------------------------------------------------------------------------------
744 ;;;;
745 ;;;; Drawing Utilities for Concrete Gadgets
746 ;;;;
747
748 ;;; Labels
749
750 (defmethod compose-label-space ((gadget labelled-gadget-mixin) &key (wider 0) (higher 0))
751 (with-slots (label align-x align-y) gadget
752 (let* ((as (text-style-ascent (pane-text-style gadget) gadget))
753 (ds (text-style-descent (pane-text-style gadget) gadget))
754 (w (+ (text-size gadget label :text-style (pane-text-style gadget)) wider))
755 (h (+ as ds higher)))
756 (make-space-requirement :width w :min-width w :max-width w
757 :height h :min-height h :max-height h))))
758
759 (defmethod draw-label* ((pane labelled-gadget-mixin) x1 y1 x2 y2
760 &key (ink +foreground-ink+))
761 (with-slots (align-x align-y label) pane
762 (let ((as (text-style-ascent (pane-text-style pane) pane))
763 (ds (text-style-descent (pane-text-style pane) pane))
764 (w (text-size pane label :text-style (pane-text-style pane))))
765 (draw-text* pane label
766 (case align-x
767 ((:left) x1)
768 ((:right) (- x2 w))
769 ((:center) (/ (+ x1 x2 (- w)) 2))
770 (otherwise x1)) ;defensive programming
771 (case align-y
772 ((:top) (+ y1 as))
773 ((:center) (/ (+ y1 y2 (- as ds)) 2))
774 ((:bottom) (- y2 ds))
775 (otherwise (/ (+ y1 y2 (- as ds)) 2))) ;defensive programming
776 ;; Giving the text-style here shouldn't be neccessary --GB
777 :text-style (pane-text-style pane)
778 :ink ink))))
779
780 ;;; 3D-ish Look
781
782 ;; DRAW-BORDERED-POLYGON medium point-seq &key border-width style
783 ;;
784 ;; -GB
785
786 (labels ((line-hnf (x1 y1 x2 y2)
787 (values (- y2 y1) (- x1 x2) (- (* x1 y2) (* y1 x2))))
788
789 (line-line-intersection (x1 y1 x2 y2 x3 y3 x4 y4)
790 (multiple-value-bind (a1 b1 c1) (line-hnf x1 y1 x2 y2)
791 (multiple-value-bind (a2 b2 c2) (line-hnf x3 y3 x4 y4)
792 (let ((d (- (* a1 b2) (* b1 a2))))
793 (cond ((< (abs d) 1e-6)
794 nil)
795 (t
796 (values (/ (- (* b2 c1) (* b1 c2)) d)
797 (/ (- (* a1 c2) (* a2 c1)) d))))))))
798
799 (polygon-orientation (point-seq)
800 "Determines the polygon's orientation.
801 Returns: +1 = counter-clock-wise
802 -1 = clock-wise
803
804 The polygon should be clean from duplicate points or co-linear points.
805 If the polygon self intersects, the orientation may not be defined, this
806 function does not try to detect this situation and happily returns some
807 value."
808 ;;
809 (let ((n (length point-seq)))
810 (let* ((min-i 0)
811 (min-val (point-x (elt point-seq min-i))))
812 ;;
813 (loop for i from 1 below n do
814 (when (< (point-x (elt point-seq i)) min-val)
815 (setf min-val (point-x (elt point-seq i))
816 min-i i)))
817 ;;
818 (let ((p0 (elt point-seq (mod (+ min-i -1) n)))
819 (p1 (elt point-seq (mod (+ min-i 0) n)))
820 (p2 (elt point-seq (mod (+ min-i +1) n))))
821 (signum (- (* (- (point-x p2) (point-x p0)) (- (point-y p1) (point-y p0)))
822 (* (- (point-x p1) (point-x p0)) (- (point-y p2) (point-y p0)))))))))
823
824 (clean-polygon (point-seq)
825 "Cleans a polygon from duplicate points and co-linear points. Furthermore
826 tries to bring it into counter-clock-wise orientation."
827 ;; first step: remove duplicates
828 (setf point-seq
829 (let ((n (length point-seq)))
830 (loop for i from 0 below n
831 for p0 = (elt point-seq (mod (+ i -1) n))
832 for p1 = (elt point-seq (mod (+ i 0) n))
833 unless (and (< (abs (- (point-x p0) (point-x p1))) 10e-8)
834 (< (abs (- (point-y p0) (point-y p1))) 10e-8))
835 collect p1)))
836 ;; second step: remove colinear points
837 (setf point-seq
838 (let ((n (length point-seq)))
839 (loop for i from 0 below n
840 for p0 = (elt point-seq (mod (+ i -1) n))
841 for p1 = (elt point-seq (mod (+ i 0) n))
842 for p2 = (elt point-seq (mod (+ i +1) n))
843 unless (< (abs (- (* (- (point-x p1) (point-x p0)) (- (point-y p2) (point-y p0)))
844 (* (- (point-x p2) (point-x p0)) (- (point-y p1) (point-y p0)))))
845 10e-8)
846 collect p1)))
847 ;; third step: care for the orientation
848 (if (and (not (null point-seq))
849 (minusp (polygon-orientation point-seq)))
850 (reverse point-seq)
851 point-seq) ))
852
853 (defun shrink-polygon (point-seq width)
854 (let ((point-seq (clean-polygon point-seq)))
855 (let ((n (length point-seq)))
856 (values
857 point-seq
858 (loop for i from 0 below n
859 for p0 = (elt point-seq (mod (+ i -1) n))
860 for p1 = (elt point-seq (mod (+ i 0) n))
861 for p2 = (elt point-seq (mod (+ i +1) n))
862 collect
863 (let* ((dx1 (- (point-x p1) (point-x p0))) (dy1 (- (point-y p1) (point-y p0)))
864 (dx2 (- (point-x p2) (point-x p1))) (dy2 (- (point-y p2) (point-y p1)))
865 ;;
866 (m1 (/ width (sqrt (+ (* dx1 dx1) (* dy1 dy1)))))
867 (m2 (/ width (sqrt (+ (* dx2 dx2) (* dy2 dy2)))))
868 ;;
869 (q0 (make-point (+ (point-x p0) (* m1 dy1)) (- (point-y p0) (* m1 dx1))))
870 (q1 (make-point (+ (point-x p1) (* m1 dy1)) (- (point-y p1) (* m1 dx1))))
871 (q2 (make-point (+ (point-x p1) (* m2 dy2)) (- (point-y p1) (* m2 dx2))))
872 (q3 (make-point (+ (point-x p2) (* m2 dy2)) (- (point-y p2) (* m2 dx2)))) )
873 ;;
874 (multiple-value-bind (x y)
875 (multiple-value-call #'line-line-intersection
876 (point-position q0) (point-position q1)
877 (point-position q2) (point-position q3))
878 (if x
879 (make-point x y)
880 (make-point 0 0)))))))))
881
882 (defun draw-bordered-polygon (medium point-seq
883 &key (border-width 2)
884 (style :inset))
885 (labels ((draw-pieces (outer-points inner-points dark light)
886 (let ((n (length outer-points)))
887 (dotimes (i n)
888 (let* ((p1 (elt outer-points (mod (+ i 0) n)))
889 (p2 (elt outer-points (mod (+ i +1) n)))
890 (q1 (elt inner-points (mod (+ i 0) n)))
891 (q2 (elt inner-points (mod (+ i +1) n)))
892 (p1* (transform-region +identity-transformation+ p1))
893 (p2* (transform-region +identity-transformation+ p2))
894 (a (mod (atan (- (point-y p2*) (point-y p1*))
895 (- (point-x p2*) (point-x p1*)))
896 (* 2 pi))))
897 (draw-polygon medium (list p1 q1 q2 p2)
898 :ink
899 (if (<= (* 1/4 pi) a (* 5/4 pi))
900 dark light)))))))
901 (let ((light *3d-light-color*)
902 (dark *3d-dark-color*))
903 ;;
904 (ecase style
905 (:solid
906 (multiple-value-call #'draw-pieces (shrink-polygon point-seq border-width)
907 +black+ +black+))
908 (:inset
909 (multiple-value-call #'draw-pieces (shrink-polygon point-seq border-width)
910 dark light))
911 (:outset
912 (multiple-value-call #'draw-pieces (shrink-polygon point-seq border-width)
913 light dark))
914 ;;
915 ;; Mickey Mouse is the trademark of the Walt Disney Company.
916 ;;
917 (:mickey-mouse-outset
918 (multiple-value-bind (outer-points inner-points) (shrink-polygon point-seq border-width)
919 (declare (ignore outer-points))
920 (multiple-value-bind (outer-points middle-points) (shrink-polygon point-seq (/ border-width 2))
921 (draw-pieces outer-points middle-points +white+ +black+)
922 (draw-pieces middle-points inner-points light dark))))
923 (:mickey-mouse-inset
924 (multiple-value-bind (outer-points inner-points) (shrink-polygon point-seq border-width)
925 (declare (ignore outer-points))
926 (multiple-value-bind (outer-points middle-points) (shrink-polygon point-seq (/ border-width 2))
927 (draw-pieces outer-points middle-points dark light)
928 (draw-pieces middle-points inner-points +black+ +white+))))
929 ;;
930 (:ridge
931 (multiple-value-bind (outer-points inner-points) (shrink-polygon point-seq border-width)
932 (declare (ignore outer-points))
933 (multiple-value-bind (outer-points middle-points) (shrink-polygon point-seq (/ border-width 2))
934 (draw-pieces outer-points middle-points light dark)
935 (draw-pieces middle-points inner-points dark light))))
936 (:groove
937 (multiple-value-bind (outer-points inner-points) (shrink-polygon point-seq border-width)
938 (declare (ignore outer-points))
939 (multiple-value-bind (outer-points middle-points) (shrink-polygon point-seq (/ border-width 2))
940 (draw-pieces outer-points middle-points dark light)
941 (draw-pieces middle-points inner-points light dark))))
942 (:double
943 (multiple-value-bind (outer-points inner-points) (shrink-polygon point-seq border-width)
944 (declare (ignore outer-points))
945 (multiple-value-bind (outer-points imiddle-points) (shrink-polygon point-seq (* 2/3 border-width))
946 (declare (ignore outer-points))
947 (multiple-value-bind (outer-points omiddle-points) (shrink-polygon point-seq (* 1/3 border-width))
948 (draw-pieces outer-points omiddle-points +black+ +black+)
949 (draw-pieces imiddle-points inner-points +black+ +black+))))))))) )
950
951 (defun draw-bordered-rectangle* (medium x1 y1 x2 y2 &rest options)
952 (apply #'draw-bordered-polygon
953 medium
954 (polygon-points (make-rectangle* x1 y1 x2 y2))
955 options))
956
957 (defun draw-engraved-label* (pane x1 y1 x2 y2)
958 (draw-label* pane (1+ x1) (1+ y1) (1+ x2) (1+ y2) :ink *3d-light-color*)
959 (draw-label* pane x1 y1 x2 y2 :ink *3d-dark-color*))
960
961 ;;;;
962 ;;;; 3D-BORDER-MIXIN Class
963 ;;;;
964
965 ;; 3D-BORDER-MIXIN class can be used to add a 3D-ish border to
966 ;; panes. There are three new options:
967 ;;
968 ;; :border-width The width of the border
969 ;; :border-style The border's style one of :inset, :outset, :groove, :ridge, :solid,
970 ;; :double, :dotted, :dashed
971 ;; [:dotted and :dashed are not yet implemented]
972 ;;
973 ;; :border-color The border's color
974 ;; [Not implemented yet]
975 ;;
976 ;; [These options are modelled after CSS].
977 ;;
978 ;; When using 3D-BORDER-MIXIN, one should query the pane's inner
979 ;; region, where drawing should take place, by PANE-INNER-REGION.
980 ;;
981 ;; --GB
982
983 (defclass 3D-border-mixin ()
984 ((border-width :initarg :border-width :initform 2)
985 (border-style :initarg :border-style :initform :outset)
986 (border-color :initarg :border-color :initform "???")))
987
988 (defmethod pane-inner-region ((pane 3D-border-mixin))
989 (with-slots (border-width) pane
990 (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region pane)
991 (make-rectangle* (+ x1 border-width) (+ y1 border-width)
992 (- x2 border-width) (- y2 border-width)))))
993
994 (defmethod handle-repaint :after ((pane 3D-border-mixin) region)
995 (declare (ignore region))
996 (with-slots (border-width border-style) pane
997 (draw-bordered-polygon pane (polygon-points (bounding-rectangle (sheet-region pane)))
998 :border-width border-width
999 :style border-style)))
1000
1001 ;;;; ------------------------------------------------------------------------------------------
1002 ;;;;
1003 ;;;; 30.4a Concrete Gadget Classes
1004 ;;;;
1005
1006 ;; xxx move these!
1007
1008 (defparameter *3d-border-thickness* 2)
1009
1010 ;;; Common colors:
1011
1012 (defmethod gadget-highlight-background ((gadget basic-gadget))
1013 (compose-over (compose-in #|+paleturquoise+|# +white+ (make-opacity .5))
1014 (pane-background gadget)))
1015
1016 (defmethod effective-gadget-foreground ((gadget basic-gadget))
1017 (if (gadget-active-p gadget)
1018 +foreground-ink+
1019 (compose-over (compose-in (pane-foreground gadget)
1020 (make-opacity .5))
1021 (pane-background gadget))))
1022
1023 (defmethod effective-gadget-background ((gadget basic-gadget))
1024 (if (slot-value gadget 'armed)
1025 (gadget-highlight-background gadget)
1026 (pane-background gadget)))
1027
1028 (defmethod effective-gadget-input-area-color ((gadget basic-gadget))
1029 (if (gadget-active-p gadget)
1030 +lemonchiffon+
1031 (compose-over (compose-in +lemonchiffon+ (make-opacity .5))
1032 (pane-background gadget))))
1033
1034 ;;; ------------------------------------------------------------------------------------------
1035 ;;; 30.4.1 The concrete push-button Gadget
1036
1037 (defclass push-button-pane (push-button
1038 labelled-gadget-mixin
1039 changing-label-invokes-layout-protocol-mixin
1040 arm/disarm-repaint-mixin
1041 enter/exit-arms/disarms-mixin
1042 standard-gadget-pane)
1043 ((pressedp :initform nil)
1044 (show-as-default-p :type boolean
1045 :initform nil
1046 :initarg :show-as-default-p
1047 :accessor push-button-show-as-default-p))
1048 (:default-initargs
1049 :text-style (make-text-style :sans-serif nil nil)
1050 :background *3d-normal-color*
1051 :align-x :center
1052 :align-y :center
1053 :x-spacing 4
1054 :y-spacing 2))
1055
1056 (defmethod compose-space ((gadget push-button-pane) &key width height)
1057 (declare (ignore width height))
1058 (space-requirement+* (space-requirement+* (compose-label-space gadget)
1059 :min-width (* 2 (pane-x-spacing gadget))
1060 :width (* 2 (pane-x-spacing gadget))
1061 :max-width (* 2 (pane-x-spacing gadget))
1062 :min-height (* 2 (pane-y-spacing gadget))
1063 :height (* 2 (pane-y-spacing gadget))
1064 :max-height (* 2 (pane-y-spacing gadget)))
1065 :min-width (* 2 *3d-border-thickness*)
1066 :width (* 2 *3d-border-thickness*)
1067 :max-width (* 2 *3d-border-thickness*)
1068 :min-height (* 2 *3d-border-thickness*)
1069 :height (* 2 *3d-border-thickness*)
1070 :max-height (* 2 *3d-border-thickness*)))
1071
1072 (defmethod handle-event ((pane push-button-pane) (event pointer-button-press-event))
1073 (with-slots (pressedp) pane
1074 (setf pressedp t)
1075 (dispatch-repaint pane +everywhere+)))
1076
1077 (defmethod handle-event ((pane push-button-pane) (event pointer-button-release-event))
1078 (with-slots (armed pressedp) pane
1079 (setf pressedp nil)
1080 (when armed
1081 (activate-callback pane (gadget-client pane) (gadget-id pane))
1082 (setf pressedp nil)
1083 (dispatch-repaint pane +everywhere+))))
1084
1085 (defmethod handle-repaint ((pane push-button-pane) region)
1086 (declare (ignore region))
1087 (with-slots (armed pressedp) pane
1088 (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* (sheet-region pane))
1089 (draw-rectangle* pane x1 y1 x2 y2 :ink (effective-gadget-background pane))
1090 (draw-bordered-rectangle* pane x1 y1 x2 y2
1091 :style (if (and pressedp armed) :inset :outset))
1092 (multiple-value-bind (x1 y1 x2 y2) (values (+ x1 *3d-border-thickness* (pane-x-spacing pane))
1093 (+ y1 *3d-border-thickness* (pane-y-spacing pane))
1094 (- x2 *3d-border-thickness* (pane-x-spacing pane))
1095 (- y2 *3d-border-thickness* (pane-y-spacing pane)))
1096 (if (gadget-active-p pane)
1097 (draw-label* pane x1 y1 x2 y2 :ink (effective-gadget-foreground pane))
1098 (draw-engraved-label* pane x1 y1 x2 y2))))))
1099
1100 (defmethod deactivate-gadget :after ((gadget push-button-pane))
1101 (dispatch-repaint gadget +everywhere+))
1102
1103 (defmethod activate-gadget :after ((gadget push-button-pane))
1104 (dispatch-repaint gadget +everywhere+))
1105
1106
1107 ;;; ------------------------------------------------------------------------------------------
1108 ;;; 30.4.2 The concrete toggle-button Gadget
1109
1110 (defclass toggle-button-pane (toggle-button
1111 ;; repaint behavior:
1112 arm/disarm-repaint-mixin
1113 value-changed-repaint-mixin
1114 ;; callback behavior:
1115 changing-label-invokes-layout-protocol-mixin
1116 ;; event handling:
1117 enter/exit-arms/disarms-mixin
1118 ;; other
1119 standard-gadget-pane)
1120 ((indicator-type :type (member :one-of :some-of)
1121 :initarg :indicator-type
1122 :reader toggle-button-indicator-type
1123 :initform :some-of) )
1124 (:default-initargs
1125 :value nil
1126 :text-style (make-text-style :sans-serif nil nil)
1127 :align-x :left
1128 :align-y :center
1129 :x-spacing 2
1130 :y-spacing 2
1131 :background *3d-normal-color*))
1132
1133 (defmethod compose-space ((pane toggle-button-pane) &key width height)
1134 (declare (ignore width height))
1135 (let ((sr (compose-label-space pane)))
1136 (space-requirement+*
1137 (space-requirement+* sr
1138 :min-width (* 3 (pane-x-spacing pane))
1139 :width (* 3 (pane-x-spacing pane))
1140 :max-width (* 3 (pane-x-spacing pane))
1141 :min-height (* 2 (pane-y-spacing pane))
1142 :height (* 2 (pane-y-spacing pane))
1143 :max-height (* 2 (pane-y-spacing pane)))
1144 :min-width (space-requirement-height sr)
1145 :width (space-requirement-height sr)
1146 :max-width (space-requirement-height sr)
1147 :min-height 0
1148 :max-height 0
1149 :height 0)))
1150
1151 (defmethod draw-toggle-button-indicator ((gadget standard-gadget-pane) (type (eql :one-of)) value x1 y1 x2 y2)
1152 (multiple-value-bind (cx cy) (values (/ (+ x1 x2) 2) (/ (+ y1 y2) 2))
1153 (let ((radius (/ (- y2 y1) 2)))
1154 (draw-circle* gadget cx cy radius
1155 :start-angle (* 1/4 pi)
1156 :end-angle (* 5/4 pi)
1157 :ink *3d-dark-color*)
1158 (draw-circle* gadget cx cy radius
1159 :start-angle (* 5/4 pi)
1160 :end-angle (* 9/4 pi)
1161 :ink *3d-light-color*)
1162 (draw-circle* gadget cx cy (max 1 (- radius 2))
1163 :ink (effective-gadget-input-area-color gadget))
1164 (when value
1165 (draw-circle* gadget cx cy (max 1 (- radius 4))
1166 :ink (effective-gadget-foreground gadget))))))
1167
1168 (defmethod draw-toggle-button-indicator ((pane standard-gadget-pane) (type (eql :some-of)) value
1169 x1 y1 x2 y2)
1170 (draw-rectangle* pane x1 y1 x2 y2 :ink (effective-gadget-input-area-color pane))
1171 (draw-bordered-rectangle* pane x1 y1 x2 y2 :style :inset)
1172 (when value
1173 (multiple-value-bind (x1 y1 x2 y2) (values (+ x1 3) (+ y1 3)
1174 (- x2 3) (- y2 3))
1175 (draw-line* pane x1 y1 x2 y2 :ink (effective-gadget-foreground pane) :line-thickness 2)
1176 (draw-line* pane x2 y1 x1 y2 :ink (effective-gadget-foreground pane) :line-thickness 2))))
1177
1178 (defmethod handle-repaint ((pane toggle-button-pane) region)
1179 (declare (ignore region))
1180 (when (sheet-grafted-p pane)
1181 (with-special-choices (pane)
1182 (with-slots (armed) pane
1183 (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* (sheet-region pane))
1184 (draw-rectangle* pane x1 y1 x2 y2 :ink (effective-gadget-background pane))
1185 (let* ((as (text-style-ascent (pane-text-style pane) pane))
1186 (ds (text-style-descent (pane-text-style pane) pane)) )
1187 (multiple-value-bind (tx1 ty1 tx2 ty2)
1188 (values (+ x1 (pane-x-spacing pane))
1189 (- (/ (+ y1 y2) 2) (/ (+ as ds) 2))
1190 (+ x1 (pane-x-spacing pane) (+ as ds))
1191 (+ (/ (+ y1 y2) 2) (/ (+ as ds) 2)))
1192 (draw-toggle-button-indicator pane (toggle-button-indicator-type pane) (gadget-value pane)
1193 tx1 ty1 tx2 ty2)
1194 (draw-label* pane (+ tx2 (pane-x-spacing pane)) y1 x2 y2
1195 :ink (effective-gadget-foreground pane)))))))))
1196
1197 (defmethod handle-event ((pane toggle-button-pane) (event pointer-button-release-event))
1198 (with-slots (armed) pane
1199 (when armed
1200 (setf (gadget-value pane :invoke-callback t) (not (gadget-value pane))))))
1201
1202 ;;; ------------------------------------------------------------------------------------------
1203 ;;; 30.4.3 The concrete menu-button Gadget
1204
1205 (defclass menu-button-pane (menu-button
1206 standard-gadget-pane)
1207 ()
1208 (:default-initargs
1209 :text-style (make-text-style :sans-serif nil nil)
1210 :background *3d-normal-color*
1211 :x-spacing 3
1212 :y-spacing 2
1213 :align-x :left
1214 :align-y :center))
1215
1216 (defmethod handle-repaint ((pane menu-button-pane) region)
1217 (declare (ignore region))
1218 (with-slots (x-spacing y-spacing) pane
1219 (with-special-choices (pane)
1220 (let ((region (sheet-region pane)))
1221 (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* region)
1222 (draw-rectangle* pane x1 y1 x2 y2
1223 :ink (effective-gadget-background pane)
1224 :filled t)
1225 (cond ((slot-value pane 'armed)
1226 (draw-bordered-rectangle* pane x1 y1 x2 y2 :style :outset :border-width *3d-border-thickness*))
1227 (t))
1228 (multiple-value-bind (x1 y1 x2 y2)
1229 (values (+ x1 x-spacing) (+ y1 y-spacing)
1230 (- x2 x-spacing) (- y2 y-spacing))
1231 (if (gadget-active-p pane)
1232 (draw-label* pane x1 y1 x2 y2 :ink (effective-gadget-foreground pane))
1233 (draw-engraved-label* pane x1 y1 x2 y2))))))))
1234
1235 (defmethod compose-space ((gadget menu-button-pane) &key width height)
1236 (declare (ignore width height))
1237 (space-requirement+* (space-requirement+* (compose-label-space gadget)
1238 :min-width (* 2 (pane-x-spacing gadget))
1239 :width (* 2 (pane-x-spacing gadget))
1240 :max-width (* 2 (pane-x-spacing gadget))
1241 :min-height (* 2 (pane-y-spacing gadget))
1242 :height (* 2 (pane-y-spacing gadget))
1243 :max-height (* 2 (pane-y-spacing gadget)))
1244 :min-width (* 2 *3d-border-thickness*)
1245 :width (* 2 *3d-border-thickness*)
1246 :max-width (* 2 *3d-border-thickness*)
1247 :min-height (* 2 *3d-border-thickness*)
1248 :height (* 2 *3d-border-thickness*)
1249 :max-height (* 2 *3d-border-thickness*)))
1250
1251 ;;; ------------------------------------------------------------------------------------------
1252 ;;; 30.4.4 The concrete scroll-bar Gadget
1253
1254 (defclass scroll-bar-pane (3D-border-mixin
1255 scroll-bar)
1256 ((event-state :initform nil)
1257 (drag-dy :initform nil)
1258 ;;; poor man's incremental redisplay
1259 ;; drawn state
1260 (up-state :initform nil)
1261 (dn-state :initform nil)
1262 (tb-state :initform nil)
1263 (tb-y1 :initform nil)
1264 (tb-y2 :initform nil)
1265 ;; old drawn state
1266 (old-up-state :initform nil)
1267 (old-dn-state :initform nil)
1268 (old-tb-state :initform nil)
1269 (old-tb-y1 :initform nil)
1270 (old-tb-y2 :initform nil)
1271 ;;
1272 (all-new-p :initform t) )
1273 (:default-initargs :border-width 2
1274 :border-style :inset
1275 :background *3d-inner-color*))
1276
1277 (defmethod compose-space ((sb scroll-bar-pane) &key width height)
1278 (declare (ignore width height))
1279 (if (eq (gadget-orientation sb) :vertical)
1280 (make-space-requirement :min-width 1
1281 :width *scrollbar-thickness*
1282 :min-height (* 3 *scrollbar-thickness*)
1283 :height (* 4 *scrollbar-thickness*))
1284 (make-space-requirement :min-height 1
1285 :height *scrollbar-thickness*
1286 :min-width (* 3 *scrollbar-thickness*)
1287 :width (* 4 *scrollbar-thickness*))))
1288
1289 ;;;; Redisplay
1290
1291 (defun scroll-bar/update-display (scroll-bar)
1292 (with-slots (up-state dn-state tb-state tb-y1 tb-y2
1293 old-up-state old-dn-state old-tb-state old-tb-y1 old-tb-y2
1294 all-new-p)
1295 scroll-bar
1296 ;;
1297 (scroll-bar/compute-display scroll-bar)
1298 ;; redraw up arrow
1299 (unless (and (not all-new-p) (eql up-state old-up-state))
1300 (with-drawing-options (scroll-bar :transformation (scroll-bar-transformation scroll-bar))
1301 (with-bounding-rectangle* (x1 y1 x2 y2) (scroll-bar-up-region scroll-bar)
1302 (draw-rectangle* scroll-bar x1 y1 x2 y2 :ink *3d-inner-color*)
1303 (let ((pg (list (make-point (/ (+ x1 x2) 2) y1)
1304 (make-point x1 y2)
1305 (make-point x2 y2))))
1306 (case up-state
1307 (:armed
1308 (draw-polygon scroll-bar pg :ink *3d-inner-color*)
1309 (draw-bordered-polygon scroll-bar pg :style :inset :border-width 2))
1310 (otherwise
1311 (draw-polygon scroll-bar pg :ink *3d-normal-color*)
1312 (draw-bordered-polygon scroll-bar pg :style :outset :border-width 2) ))))) )
1313 ;; redraw dn arrow
1314 (unless (and (not all-new-p) (eql dn-state old-dn-state))
1315 (with-drawing-options (scroll-bar :transformation (scroll-bar-transformation scroll-bar))
1316 (with-bounding-rectangle* (x1 y1 x2 y2) (scroll-bar-down-region scroll-bar)
1317 (draw-rectangle* scroll-bar x1 y1 x2 y2 :ink *3d-inner-color*)
1318 (let ((pg (list (make-point (/ (+ x1 x2) 2) y2)
1319 (make-point x1 y1)
1320 (make-point x2 y1))))
1321 (case dn-state
1322 (:armed
1323 (draw-polygon scroll-bar pg :ink *3d-inner-color*)
1324 (draw-bordered-polygon scroll-bar pg :style :inset :border-width 2))
1325 (otherwise
1326 (draw-polygon scroll-bar pg :ink *3d-normal-color*)
1327 (draw-bordered-polygon scroll-bar pg :style :outset :border-width 2)))))))
1328 ;; thumb
1329 (unless (and (not all-new-p)
1330 (and (eql tb-state old-tb-state)
1331 (eql tb-y1 old-tb-y1)
1332 (eql tb-y2 old-tb-y2)))
1333 (cond ((and (not all-new-p)
1334 (eql tb-state old-tb-state)
1335 (numberp tb-y1) (numberp old-tb-y1)
1336 (numberp tb-y2) (numberp old-tb-y2)
1337 (= (- tb-y2 tb-y1) (- old-tb-y2 old-tb-y1)))
1338 ;; Thumb is just moving, compute old and new region
1339 (multiple-value-bind (x1 ignore.1 x2 ignore.2)
1340 (bounding-rectangle* (scroll-bar-thumb-bed-region scroll-bar))
1341 (declare (ignore ignore.1 ignore.2))
1342 ;; compute new and old region
1343 (with-sheet-medium (medium scroll-bar)
1344 (with-drawing-options (medium :transformation (scroll-bar-transformation scroll-bar))
1345 (multiple-value-bind (ox1 oy1 ox2 oy2) (values x1 old-tb-y1 x2 old-tb-y2)
1346 (multiple-value-bind (nx1 ny1 nx2 ny2) (values x1 tb-y1 x2 tb-y2)
1347 (declare (ignore nx2))
1348 (copy-area medium ox1 oy1 (- ox2 ox1) (- oy2 oy1) nx1 ny1)
1349 ;; clear left-overs from the old region
1350 (if (< oy1 ny1)
1351 (draw-rectangle* medium ox1 oy1 ox2 ny1 :ink *3d-inner-color*)
1352 (draw-rectangle* medium ox1 oy2 ox2 ny2 :ink *3d-inner-color*)))) ))))
1353 (t
1354 ;; redraw whole thumb bed and thumb all anew
1355 (with-drawing-options (scroll-bar :transformation (scroll-bar-transformation scroll-bar))
1356 (with-bounding-rectangle* (bx1 by1 bx2 by2) (scroll-bar-thumb-bed-region scroll-bar)
1357 (with-bounding-rectangle* (x1 y1 x2 y2) (scroll-bar-thumb-region scroll-bar)
1358 (draw-rectangle* scroll-bar bx1 by1 bx2 y1 :ink *3d-inner-color*)
1359 (draw-rectangle* scroll-bar bx1 y2 bx2 by2 :ink *3d-inner-color*)
1360 (draw-rectangle* scroll-bar x1 y1 x2 y2 :ink *3d-normal-color*)
1361 (draw-bordered-polygon scroll-bar
1362 (polygon-points (make-rectangle* x1 y1 x2 y2))
1363 :style :outset
1364 :border-width 2)
1365 ;;;;;;
1366 (let ((y (/ (+ y1 y2) 2)))
1367 (draw-bordered-polygon scroll-bar
1368 (polygon-points (make-rectangle* (+ x1 3) (- y 1) (- x2 3) (+ y 1)))
1369 :style :inset
1370 :border-width 1)
1371 (draw-bordered-polygon scroll-bar
1372 (polygon-points (make-rectangle* (+ x1 3) (- y 4) (- x2 3) (- y 2)))
1373 :style :inset
1374 :border-width 1)
1375 (draw-bordered-polygon scroll-bar
1376 (polygon-points (make-rectangle* (+ x1 3) (+ y 4) (- x2 3) (+ y 2)))
1377 :style :inset
1378 :border-width 1))))))))
1379 (setf old-up-state up-state
1380 old-dn-state dn-state
1381 old-tb-state tb-state
1382 old-tb-y1 tb-y1
1383 old-tb-y2 tb-y2
1384 all-new-p nil) ))
1385
1386 (defun scroll-bar/compute-display (scroll-bar)
1387 (with-slots (up-state dn-state tb-state tb-y1 tb-y2
1388 event-state) scroll-bar
1389 (setf up-state (if (eq event-state :up-armed) :armed nil))
1390 (setf dn-state (if (eq event-state :dn-armed) :armed nil))
1391 (setf tb-state nil) ;we have no armed display yet
1392 (with-bounding-rectangle* (x1 y1 x2 y2) (scroll-bar-thumb-region scroll-bar)
1393 (declare (ignore x1 x2))
1394 (setf tb-y1 y1
1395 tb-y2 y2))))
1396
1397 ;;;; Utilities
1398
1399 ;; We think all scroll bars as vertically oriented, therefore we have
1400 ;; SCROLL-BAR-TRANSFORMATION, which should make every scroll bar
1401 ;; look like being vertically oriented -- simplifies much code.
1402
1403 (defmethod scroll-bar-transformation ((sb scroll-bar))
1404 (ecase (gadget-orientation sb)
1405 (:vertical +identity-transformation+)
1406 (:horizontal (make-transformation 0 1 1 0 0 0))))
1407
1408 (defun translate-range-value (a mina maxa mino maxo
1409 &optional (empty-result (/ (+ mino maxo) 2)))
1410 "When \arg{a} is some value in the range from \arg{mina} to \arg{maxa},
1411 proportionally translate the value into the range \arg{mino} to \arg{maxo}."
1412 (if (zerop (- maxa mina))
1413 empty-result
1414 (+ mino (* (/ (- a mina)
1415 (- maxa mina))
1416 (- maxo mino)))))
1417
1418 ;;;; SETF :after methods
1419
1420 (defmethod (setf gadget-min-value) :after (new-value (pane scroll-bar-pane))
1421 (declare (ignore new-value))
1422 (scroll-bar/update-display pane))
1423
1424 (defmethod (setf gadget-max-value) :after (new-value (pane scroll-bar-pane))
1425 (declare (ignore new-value))
1426 (scroll-bar/update-display pane))
1427
1428 (defmethod (setf scroll-bar-thumb-size) :after (new-value (pane scroll-bar-pane))
1429 (declare (ignore new-value))
1430 (scroll-bar/update-display pane))
1431
1432 (defmethod (setf gadget-value) :after (new-value (pane scroll-bar-pane) &key invoke-callback)
1433 (declare (ignore new-value invoke-callback))
1434 (scroll-bar/update-display pane))
1435
1436 (defmethod* (setf scroll-bar-values)
1437 (min-value max-value thumb-size value (scroll-bar scroll-bar-pane))
1438 (setf (slot-value scroll-bar 'min-value) min-value
1439 (slot-value scroll-bar 'max-value) max-value
1440 (slot-value scroll-bar 'thumb-size) thumb-size
1441 (slot-value scroll-bar 'value) value)
1442 (scroll-bar/update-display scroll-bar))
1443
1444 ;;;; geometry
1445
1446 (defparameter +minimum-thumb-size-in-pixels+ 30)
1447
1448 (defmethod scroll-bar-up-region ((sb scroll-bar-pane))
1449 (with-bounding-rectangle* (minx miny maxx maxy) (transform-region (scroll-bar-transformation sb)
1450 (pane-inner-region sb))
1451 (declare (ignore maxy))
1452 (make-rectangle* minx miny
1453 maxx (+ miny (- maxx minx)))))
1454
1455 (defmethod scroll-bar-down-region ((sb scroll-bar-pane))
1456 (with-bounding-rectangle* (minx miny maxx maxy) (transform-region (scroll-bar-transformation sb)
1457 (pane-inner-region sb))
1458 (declare (ignore miny))
1459 (make-rectangle* minx (- maxy (- maxx minx))
1460 maxx maxy)))
1461
1462 (defun scroll-bar/thumb-bed* (sb)
1463 ;; -> y1 y2 y3
1464 (with-bounding-rectangle* (minx miny maxx maxy) (transform-region (scroll-bar-transformation sb)
1465 (pane-inner-region sb))
1466 (let ((y1 (+ miny (- maxx minx) 1))
1467 (y3 (- maxy (- maxx minx) 1)))
1468 (let ((ts (scroll-bar-thumb-size sb)))
1469 ;; This is the right spot to handle ts = :none or perhaps NIL
1470 (multiple-value-bind (range) (gadget-range sb)
1471 (let ((ts-in-pixels (round (* (- y3 y1) (/ ts (max 1 (+ range ts))))))) ; handle range + ts = 0
1472 (setf ts-in-pixels (min (- y3 y1) ;thumb can't be larger than the thumb bed
1473 (max +minimum-thumb-size-in-pixels+ ;but shouldn't be smaller than this.
1474 ts-in-pixels)))
1475 (values
1476 y1
1477 (- y3 ts-in-pixels)
1478 y3)))))))
1479
1480 (defmethod scroll-bar-thumb-bed-region ((sb scroll-bar-pane))
1481 (with-bounding-rectangle* (minx miny maxx maxy) (transform-region (scroll-bar-transformation sb)
1482 (pane-inner-region sb))
1483 (declare (ignore miny maxy))
1484 (multiple-value-bind (y1 y2 y3) (scroll-bar/thumb-bed* sb)
1485 (declare (ignore y2))
1486 (make-rectangle* minx y1
1487 maxx y3))))
1488
1489 (defun scroll-bar/map-coordinate-to-value (sb y)
1490 (multiple-value-bind (y1 y2 y3) (scroll-bar/thumb-bed* sb)
1491 (declare (ignore y3))
1492 (multiple-value-bind (minv maxv) (gadget-range* sb)
1493 (translate-range-value y y1 y2 minv maxv minv))))
1494
1495 (defun scroll-bar/map-value-to-coordinate (sb v)
1496 (multiple-value-bind (y1 y2 y3) (scroll-bar/thumb-bed* sb)
1497 (declare (ignore y3))
1498 (multiple-value-bind (minv maxv) (gadget-range* sb)
1499 (round (translate-range-value v minv maxv y1 y2 y1)))))
1500
1501 (defmethod scroll-bar-thumb-region ((sb scroll-bar-pane))
1502 (with-bounding-rectangle* (x1 y1 x2 y2) (scroll-bar-thumb-bed-region sb)
1503 (declare (ignore y1 y2))
1504 (multiple-value-bind (y1 y2 y3) (scroll-bar/thumb-bed* sb)
1505 (declare (ignore y1))
1506 (let ((y4 (scroll-bar/map-value-to-coordinate sb (gadget-value sb))))
1507 (make-rectangle* x1 y4 x2 (+ y4 (- y3 y2)))))))
1508
1509 ;;;; event handler
1510
1511 (defmethod handle-event ((sb scroll-bar-pane) (event pointer-button-press-event))
1512 (multiple-value-bind (x y) (transform-position (scroll-bar-transformation sb)
1513 (pointer-event-x event) (pointer-event-y event))
1514 (with-slots (event-state drag-dy) sb
1515 (cond ((region-contains-position-p (scroll-bar-up-region sb) x y)
1516 (scroll-up-line-callback sb (gadget-client sb) (gadget-id sb))
1517 (setf event-state :up-armed)
1518 (scroll-bar/update-display sb))
1519 ((region-contains-position-p (scroll-bar-down-region sb) x y)
1520 (scroll-down-line-callback sb (gadget-client sb) (gadget-id sb))
1521 (setf event-state :dn-armed)
1522 (scroll-bar/update-display sb))
1523 ;;
1524 ((region-contains-position-p (scroll-bar-thumb-region sb) x y)
1525 (setf event-state :dragging
1526 drag-dy (- y (bounding-rectangle-min-y (scroll-bar-thumb-region sb)))))
1527 ;;
1528 ((region-contains-position-p (scroll-bar-thumb-bed-region sb) x y)
1529 (if (< y (bounding-rectangle-min-y (scroll-bar-thumb-region sb)))
1530 (scroll-up-page-callback sb (gadget-client sb) (gadget-id sb))
1531 (scroll-down-page-callback sb (gadget-client sb) (gadget-id sb))))
1532 (t
1533 nil)))))
1534
1535 (defmethod handle-event ((sb scroll-bar-pane) (event pointer-motion-event))
1536 (multiple-value-bind (x y) (transform-position (scroll-bar-transformation sb)
1537 (pointer-event-x event) (pointer-event-y event))
1538 (declare (ignore x))
1539 (with-slots (event-state drag-dy) sb
1540 (case event-state
1541 (:dragging
1542 (let* ((y-new-thumb-top (- y drag-dy))
1543 (new-value
1544 (min (gadget-max-value sb)
1545 (max (gadget-min-value sb)
1546 (scroll-bar/map-coordinate-to-value sb y-new-thumb-top)))) )
1547 ;; ### when dragging value shouldn't be immediately updated
1548 (setf (gadget-value sb #|:invoke-callback nil|#)
1549 new-value)
1550 (drag-callback sb (gadget-client sb) (gadget-id sb) new-value)) )))))
1551
1552 (defmethod handle-event ((sb scroll-bar-pane) (event pointer-button-release-event))
1553 (with-slots (event-state) sb
1554 (case event-state
1555 (:up-armed (setf event-state nil))
1556 (:dn-armed (setf event-state nil))
1557 (otherwise
1558 (setf event-state nil) )))
1559 (scroll-bar/update-display sb) )
1560
1561 (defmethod handle-repaint ((pane scroll-bar-pane) region)
1562 (with-slots (all-new-p) pane
1563 (setf all-new-p t)
1564 (scroll-bar/update-display pane)))
1565
1566 ;;; ------------------------------------------------------------------------------------------
1567 ;;; 30.4.5 The concrete slider Gadget
1568
1569 ;; ----------------------------------------------------------
1570 ;; What should be done for having a better look for sliders
1571 ;;
1572 ;; We should find a way to draw the value, when show-value-p
1573 ;; is true, in a good position, or to dedicate a particular
1574 ;; sheet for this drawing (this sheet would be inside the
1575 ;; slider's sheet, probably his child).
1576 ;; ----------------------------------------------------------
1577
1578 ;; This values should be changeable by user. That's
1579 ;; why they are parameters, and not constants.
1580 (defparameter slider-button-long-dim 30)
1581 (defparameter slider-button-short-dim 10)
1582
1583 (defclass slider-pane (slider-gadget basic-pane)
1584 ((drag-callback :initform nil
1585 :initarg :drag-callback
1586 :reader slider-drag-callback)
1587 (show-value-p :type boolean
1588 :initform nil
1589 :initarg :show-value-p
1590 :accessor gadget-show-value-p)
1591 (decimal-places :initform 0
1592 :initarg :decimal-places
1593 :reader slider-decimal-places)
1594 (number-of-quanta :initform nil
1595 :initarg :number-of-quanta
1596 :reader slider-number-of-quanta)))
1597
1598 (defmethod compose-space ((pane slider-pane) &key width height)
1599 (declare (ignore width height))
1600 (let ((minor (+ 50 (if (gadget-show-value-p pane) 30 0)))
1601 (major 128))
1602 (if (eq (gadget-orientation pane) :vertical)
1603 (make-space-requirement :min-width minor :width minor
1604 :min-height major :height major)
1605 (make-space-requirement :min-width major :width major
1606 :min-height minor :height minor))))
1607
1608
1609
1610 (defmethod initialize-instance :before ((pane slider-pane) &rest rest)
1611 (declare (ignore rest))
1612 (setf (slot-value pane 'orientation) :vertical))
1613
1614 (defmethod drag-callback ((pane slider-pane) client gadget-id value)
1615 (declare (ignore client gadget-id))
1616 (when (slider-drag-callback pane)
1617 (funcall (slider-drag-callback pane) pane value)))
1618
1619 (defmethod handle-event ((pane slider-pane) (event pointer-enter-event))
1620 (with-slots (armed) pane
1621 (unless armed
1622 (setf armed t))
1623 (armed-callback pane (gadget-client pane) (gadget-id pane))))
1624
1625 (defmethod handle-event ((pane slider-pane) (event pointer-exit-event))
1626 (with-slots (armed) pane
1627 (when armed
1628 (setf armed nil))
1629 (disarmed-callback pane (gadget-client pane) (gadget-id pane))))
1630
1631 (defmethod handle-event ((pane slider-pane) (event pointer-button-press-event))
1632 (with-slots (armed) pane
1633 (when armed
1634 (setf armed ':button-press))))
1635
1636 (defmethod handle-event ((pane slider-pane) (event pointer-motion-event))
1637 (with-slots (armed) pane
1638 (when (eq armed ':button-press)
1639 (let ((value (convert-position-to-value pane
1640 (if (eq (gadget-orientation pane) :vertical)
1641 (pointer-event-y event)
1642 (pointer-event-x event)))))
1643 (setf (gadget-value pane :invoke-callback nil) value)
1644 (drag-callback pane (gadget-client pane) (gadget-id pane) value)
1645 (dispatch-repaint pane (sheet-region pane))))))
1646
1647 (defmethod handle-event ((pane slider-pane) (event pointer-button-release-event))
1648 (with-slots (armed) pane
1649 (when armed
1650 (setf armed t
1651 (gadget-value pane :invoke-callback t)
1652 (convert-position-to-value pane
1653 (if (eq (gadget-orientation pane) :vertical)
1654 (pointer-event-y event)
1655 (pointer-event-x event))))
1656 (dispatch-repaint pane (sheet-region pane)))))
1657
1658
1659 (defmethod convert-position-to-value ((pane slider-pane) dim)
1660 (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* (sheet-region pane))
1661 (multiple-value-bind (good-dim1 good-dim2)
1662 (if (eq (gadget-orientation pane) :vertical)
1663 ;; vertical orientation
1664 (values (+ y1 (ash slider-button-short-dim -1))
1665 (- y2 (ash slider-button-short-dim -1)))
1666 ;; horizontal orientation
1667 (values (+ x1 (ash slider-button-short-dim -1))
1668 (- x2 (ash slider-button-short-dim -1))))
1669 (let ((displacement
1670 (/ (- (max good-dim1 (min dim good-dim2)) good-dim1)
1671 (- good-dim2 good-dim1)))
1672 (quanta (slider-number-of-quanta pane)))
1673 (+ (gadget-min-value pane)
1674 (* (gadget-range pane)
1675 (if quanta
1676 (/ (round (* displacement quanta)) quanta)
1677 displacement)))))))
1678
1679 (defun format-value (value decimal-places)
1680 (if (<= decimal-places 0)
1681 (format nil "~D" (round value))
1682 (let ((control-string (format nil "~~,~DF" decimal-places)))
1683 (format nil control-string value))))
1684
1685 (defmethod handle-repaint ((pane slider-pane) region)
1686 (declare (ignore region))
1687 (with-special-choices (pane)
1688 (let ((position (convert-value-to-position pane))
1689 (slider-button-half-short-dim (ash slider-button-short-dim -1))
1690 (slider-button-half-long-dim (ash slider-button-long-dim -1))
1691 (background-color (pane-background pane))
1692 (inner-color (gadget-current-color pane)))
1693 (flet ((draw-thingy (x y)
1694 (draw-circle* pane x y 8.0 :filled t :ink inner-color)
1695 (draw-circle* pane x y 8.0 :filled nil :ink +black+)
1696 (draw-circle* pane x y 7.0
1697 :filled nil :ink +white+
1698 :start-angle (* 0.25 pi)
1699 :end-angle (* 1.25 pi))
1700 (draw-circle* pane x y 7.0
1701 :filled nil :ink +black+
1702 :start-angle (* 1.25 pi)
1703 :end-angle (* 2.25 pi))))
1704 (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* (sheet-region pane))
1705 (display-gadget-background pane background-color 0 0 (- x2 x1) (- y2 y1))
1706 (case (gadget-orientation pane)
1707 ((:vertical)
1708 (let ((middle (round (- x2 x1) 2)))
1709 (draw-bordered-polygon pane
1710 (polygon-points
1711 (make-rectangle*
1712 (- middle 2) (+ y1 slider-button-half-short-dim)
1713 (+ middle 2) (- y2 slider-button-half-short-dim)))
1714 :style :inset
1715 :border-width 2)
1716 (draw-thingy middle (- position slider-button-half-short-dim))
1717 (when (gadget-show-value-p pane)
1718 (draw-text* pane (format-value (gadget-value pane)
1719 (slider-decimal-places pane))
1720 5 ;(- position slider-button-half-short-dim)
1721 (- middle slider-button-half-long-dim)))))
1722 ((:horizontal)
1723 (let ((middle (round (- y2 y1) 2)))
1724 (draw-bordered-polygon pane
1725 (polygon-points
1726 (make-rectangle*
1727 (+ x1 slider-button-half-short-dim) (- middle 2)
1728 (- x2 slider-button-half-short-dim) (+ middle 2)))
1729 :style :inset
1730 :border-width 2)
1731 (draw-thingy (- position slider-button-half-short-dim) middle)
1732 (when (gadget-show-value-p pane)
1733 (draw-text* pane (format-value (gadget-value pane)
1734 (slider-decimal-places pane))
1735 5 ;(- position slider-button-half-short-dim)
1736 (- middle slider-button-half-long-dim)))))))))))
1737
1738 #|
1739 (defmethod handle-repaint ((pane slider-pane) region)
1740 (declare (ignore region))
1741 (with-special-choices (pane)
1742 (let ((position (convert-value-to-position pane))
1743 (slider-button-half-short-dim (ash slider-button-short-dim -1))
1744 (slider-button-half-long-dim (ash slider-button-long-dim -1)))
1745 (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* (sheet-region pane))
1746 (display-gadget-background pane (gadget-current-color pane) 0 0 (- x2 x1) (- y2 y1))
1747 (if (eq (gadget-orientation pane) :vertical)
1748 ; vertical case
1749 (let ((middle (round (- x2 x1) 2)))
1750 (draw-line* pane
1751 middle (+ y1 slider-button-half-short-dim)
1752 middle (- y2 slider-button-half-short-dim)
1753 :ink +black+
1754 (draw-rectangle* pane
1755 (- middle slider-button-half-long-dim) (- position slider-button-half-short-dim)
1756 (+ middle slider-button-half-long-dim) (+ position slider-button-half-short-dim)
1757 :ink +gray85+ :filled t)
1758 (draw-edges-lines* pane
1759 +white+
1760 (- middle slider-button-half-long-dim) (- position slider-button-half-short-dim)
1761 +black+
1762 (+ middle slider-button-half-long-dim) (+ position slider-button-half-short-dim))
1763 (when (gadget-show-value-p pane)
1764 (draw-text* pane (format-value (gadget-value pane)
1765 (slider-decimal-places pane))
1766 5 ;(- middle slider-button-half-short-dim)
1767 10))) ;(- position slider-button-half-long-dim)
1768 ; horizontal case
1769 (let ((middle (round (- y2 y1) 2)))
1770 (draw-line* pane
1771 (+ x1 slider-button-half-short-dim) middle
1772 (- x2 slider-button-half-short-dim) middle
1773 :ink +black+)
1774 (draw-rectangle* pane
1775 (- position slider-button-half-short-dim) (- middle slider-button-half-long-dim)
1776 (+ position slider-button-half-short-dim) (+ middle slider-button-half-long-dim)
1777 :ink +gray85+ :filled t)
1778 (draw-edges-lines* pane
1779 +white+
1780 (- position slider-button-half-short-dim) (- middle slider-button-half-long-dim)
1781 +black+
1782 (+ position slider-button-half-short-dim) (+ middle slider-button-half-long-dim))
1783 (when (gadget-show-value-p pane)
1784 (draw-text* pane (format-value (gadget-value pane)
1785 (slider-decimal-places pane))
1786 5 ;(- position slider-button-half-short-dim)
1787 (- middle slider-button-half-long-dim)))))))))
1788 |#
1789
1790
1791 (defmethod convert-value-to-position ((pane slider-pane))
1792 (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* (sheet-region pane))
1793 (let ((x1 (+ x1 8.0)) ; replace this with some rectangle-inset transform or something
1794 (y1 (+ y1 8.0)))
1795 (multiple-value-bind (good-dim1 good-dim2)
1796 (if (eq (gadget-orientation pane) :vertical)
1797 ; vertical orientation
1798 (values (+ y1 (ash slider-button-short-dim -1))
1799 (- y2 (ash slider-button-short-dim -1)))
1800 ; horizontal orientation
1801 (values (+ x1 (ash slider-button-short-dim -1))
1802 (- x2 (ash slider-button-short-dim -1))))
1803 (+ good-dim1 (* (- good-dim2 good-dim1)
1804 (if (zerop (gadget-range pane))
1805 0.5
1806 (/ (- (gadget-value pane) (gadget-min-value pane))
1807 (gadget-range pane)))))))))
1808
1809 ;;; ------------------------------------------------------------------------------------------
1810 ;;; 30.4.6 The concrete radio-box and check-box Gadgets
1811
1812 ;; radio-box
1813
1814 (defclass radio-box-pane (radio-box rack-layout-mixin sheet-multiple-child-mixin basic-pane)
1815 ()
1816 (:default-initargs
1817 :background *3d-normal-color*))
1818
1819 (defmethod initialize-instance :after ((pane radio-box-pane)
1820 &key choices current-selection orientation &allow-other-keys)
1821 (setf (box-layout-orientation pane) orientation)
1822 (setf (gadget-value pane) current-selection)
1823 (let ((children
1824 (mapcar (lambda (c)
1825 (let ((c (if (stringp c)
1826 (make-pane 'toggle-button-pane :label c :value nil)
1827 c)))
1828 (setf (gadget-value c) (if (eq c (radio-box-current-selection pane)) t nil))
1829 (setf (gadget-client c) pane)
1830 c))
1831 choices)))
1832 (mapc (curry #'sheet-adopt-child pane) children)))
1833
1834 (defmethod (setf gadget-value) :after (button (radio-box radio-box-pane) &key invoke-callback)
1835 ;; this is silly, but works ...
1836 (dolist (c (sheet-children radio-box))
1837 (unless (eq (not (null (eq c button)))
1838 (not (null (gadget-value c))))
1839 (setf (gadget-value c :invoke-callback invoke-callback) (eq c button)) )))
1840
1841 ;; check-box
1842
1843 (defclass check-box-pane (check-box rack-layout-mixin sheet-multiple-child-mixin basic-pane)
1844 ()
1845 (:default-initargs
1846 :text-style (make-text-style :sans-serif nil nil)
1847 :background *3d-normal-color*))
1848
1849 (defmethod initialize-instance :after ((pane check-box-pane)
1850 &key choices current-selection orientation &allow-other-keys)
1851 (setf (box-layout-orientation pane) orientation)
1852 (setf (gadget-value pane) current-selection)
1853 (let ((children
1854 (mapcar (lambda (c)
1855 (let ((c (if (stringp c)
1856 (make-pane 'toggle-button-pane :label c :value nil)
1857 c)))
1858 (setf (gadget-value c) (if (member c current-selection) t nil))
1859 (setf (gadget-client c) pane)
1860 c))
1861 choices)))
1862 (mapc (curry #'sheet-adopt-child pane) children) ))
1863
1864 ;;; ------------------------------------------------------------------------------------------
1865 ;;; 30.4.7 The concrete list-pane and option-pane Gadgets
1866
1867
1868 ;;; LIST-PANE
1869
1870 ;; Note: According to the LispWorks CLIM User's Guide, they do some peculiar
1871 ;; things in their list pane. Instead of :exclusive and :nonexclusive modes,
1872 ;; they call them :one-of and :some-of. I've supported these aliases for
1873 ;; compatibility. They also state the default mode is :some-of, which
1874 ;; contradicts the CLIM 2.0 Spec and doesn't make a lot of sense.
1875 ;; McCLIM defaults to :one-of.
1876
1877 ;; TODO: Improve performance in order to scale to extremely large lists.
1878 ;; * Computing text-size for a 100k list items is expensive
1879 ;; * Need to share text size and cache of computed name-key/value-key
1880 ;; results with LIST-PANE when instantiated in the popup for
1881 ;; the OPTION-PANE.
1882 ;; * Improve repaint logic when items are selected to reduce flicker.
1883 ;; Currently the list and option panes are usable up to several thousand
1884 ;; items on a reasonably fast P4.
1885
1886 ;; TODO: Consider appearance of nonexclusive option-pane when multiple items are
1887 ;; selected.
1888
1889 ;; TODO: I think the list/option gadgets currently ignore enabled/disabled status.
1890
1891 ;; Notes
1892 ;; A some-of/nonexclusive list pane (or option-pane popup window) supports
1893 ;; the following behaviors:
1894 ;; single-click: toggle selected item
1895 ;; shift-click: select/deselect multiple items. Selection or deselection
1896 ;; is chosen according to the result of your previous click.
1897 ;; McCLIM adds an initarg :prefer-single-selection. If true, a nonexclusive pane
1898 ;; will deselect other items selected when a new selection is made. Multiple
1899 ;; items can be selected using control-click, or shift-click as before. This
1900 ;; imitates the behvior of certain GUIs and may be useful in applications.
1901
1902 (define-abstract-pane-mapping 'list-pane 'generic-list-pane)
1903
1904 (defclass meta-list-pane ()
1905 ((mode :initarg :mode
1906 :initform :exclusive
1907 :reader list-pane-mode
1908 :type (member :one-of :some-of :exclusive :nonexclusive))
1909 (items :initarg :items
1910 :initform nil
1911 :reader list-pane-items
1912 :type sequence)
1913 (name-key :initarg :name-key
1914 :initform #'princ-to-string
1915 :reader list-pane-name-key
1916 :documentation "A function to be applied to items to gain a printable representation")
1917 (value-key :initarg :value-key
1918 :initform #'identity
1919 :reader list-pane-value-key
1920 :documentation "A function to be applied to items to gain its value
1921 for the purpose of GADGET-VALUE.")
1922 (presentation-type-key :initarg :presentation-type-key
1923 :initform (constantly nil)
1924 :reader list-pane-presentation-type-key
1925 :documentation "A function to be applied to items to find the presentation types for their values, or NIL.")
1926 (test :initarg :test
1927 :initform #'eql
1928 :reader list-pane-test
1929 :documentation "A function to compare two items for equality.")))
1930
1931 (defclass generic-list-pane (list-pane meta-list-pane
1932 standard-sheet-input-mixin ;; Hmm..
1933 value-changed-repaint-mixin
1934 mouse-wheel-scroll-mixin)
1935 ((highlight-ink :initform +royalblue4+
1936 :initarg :highlight-ink
1937 :reader list-pane-highlight-ink)
1938 (item-strings :initform nil
1939 :documentation "Vector of item strings.")
1940 (item-values :initform nil
1941 :documentation "Vector of item values.")
1942 (items-width :initform nil
1943 :documentation "Width sufficient to contain all items")
1944 (last-action :initform nil
1945 :documentation "Last action performed on items in the pane, either
1946 :select, :deselect, or NIL if none has been performed yet.")
1947 (last-index :initform nil
1948 :documentation "Index of last item clicked, for extending selections.")
1949 (prefer-single-selection :initform nil :initarg :prefer-single-selection
1950 :documentation "For nonexclusive menus, emulate the common behavior of
1951 preferring selection of a single item, but allowing extension of the
1952 selection via the control modifier.")
1953 (items-length :initform nil :documentation "Number of items"))
1954 (:default-initargs :text-style (make-text-style :sans-serif :roman :normal)
1955 :background +white+ :foreground +black+))
1956
1957 (defmethod initialize-instance :after ((gadget meta-list-pane) &rest rest)
1958 (declare (ignorable rest))
1959 ;; Initialize slot value if not specified
1960 #+NIL ;; XXX
1961 (when (slot-boundp gadget 'value)
1962 (setf (slot-value gadget 'value)
1963 (if (list-pane-exclusive-p gadget)
1964 (funcall (list-pane-value-key gadget) (first (list-pane-items gadget)))
1965 (mapcar #'list-pane-value-key (list (first (list-pane-items gadget)))))))
1966
1967 (when (and (not (list-pane-exclusive-p gadget))
1968 (not (listp (gadget-value gadget))))
1969 (error "A :nonexclusive list-pane cannot be initialized with a value which is not a list."))
1970 (when (not (list-pane-exclusive-p gadget))
1971 (with-slots (value) gadget
1972 (setf value (copy-list value))))
1973 #+IGNORE
1974 (when (and (list-pane-exclusive-p gadget)
1975 (> (length (gadget-value gadget)) 1))
1976 (error "An 'exclusive' list-pane cannot be initialized with more than one item selected.")))
1977
1978 (defmethod value-changed-callback :before
1979 ((gadget generic-list-pane) client gadget-id value)
1980 (declare (ignore client gadget-id))
1981 ;; Maybe act as if a presentation was clicked on, but only if the
1982 ;; list pane only allows single-selection.
1983 (when (or (eq (list-pane-mode gadget) :one-of)
1984 (eq (list-pane-mode gadget) :exclusive))
1985 (let* ((i (position value (generic-list-pane-item-values gadget)))
1986 (item (elt (list-pane-items gadget) i))
1987 (ptype (funcall (list-pane-presentation-type-key gadget) item)))
1988 (when ptype
1989 (throw-object-ptype value ptype)))))
1990
1991 (defun list-pane-exclusive-p (pane)
1992 (or (eql (list-pane-mode pane) :exclusive)
1993 (eql (list-pane-mode pane) :one-of)))
1994
1995 (defmethod initialize-instance :after ((gadget generic-list-pane) &rest rest)
1996 (declare (ignorable rest))
1997 ;; For a nonexclusive list-pane, compute some reasonable default for the last
1998 ;; selected item to make shift-click do something useful.
1999 (when (not (list-pane-exclusive-p gadget))
2000 (with-slots (test last-action last-index) gadget
2001 (when (not (zerop (length (gadget-value gadget))))
2002 (setf last-action :select
2003 last-index
2004 (reduce #'max
2005 (mapcar #'(lambda (item) (position item (generic-list-pane-item-values gadget) :test test))
2006 (gadget-value gadget))))))))
2007
2008 (defmethod generic-list-pane-item-strings ((pane generic-list-pane))
2009 (with-slots (item-strings) pane
2010 (or item-strings
2011 (setf item-strings
2012 (map 'vector (lambda (item)
2013 (let ((s (funcall (list-pane-name-key pane) item)))
2014 (if (stringp s)
2015 s
2016 (princ-to-string s)))) ;defensive programming!
2017 (list-pane-items pane))))))
2018
2019 (defmethod generic-list-pane-item-values ((pane generic-list-pane))
2020 (with-slots (item-values) pane
2021 (or item-values
2022 (setf item-values
2023 (map 'vector (list-pane-value-key pane) (list-pane-items pane))))))
2024
2025 (defmethod generic-list-pane-items-width ((pane generic-list-pane))
2026 (with-slots (items-width) pane
2027 (or items-width
2028 (setf items-width
2029 (reduce #'max (map 'vector (lambda (item-string)
2030 (text-size pane item-string))
2031 (generic-list-pane-item-strings pane))
2032 :initial-value 0)))))
2033
2034 (defmethod generic-list-pane-items-length ((pane generic-list-pane))
2035 (with-slots (items-length) pane
2036 (or items-length
2037 (setf items-length
2038 (length (generic-list-pane-item-strings pane))))))
2039
2040 (defmethod generic-list-pane-item-height ((pane generic-list-pane))
2041 (+ (text-style-ascent (pane-text-style pane) pane)
2042 (text-style-descent (pane-text-style pane) pane)))
2043
2044 (defmethod compose-space ((pane generic-list-pane) &key width height)
2045 (declare (ignore width height))
2046 (let* ((n (generic-list-pane-items-length pane))
2047 (w (generic-list-pane-items-width pane))
2048 (h (* n (generic-list-pane-item-height pane))))
2049 (make-space-requirement :width w :height h
2050 :min-width w :min-height h
2051 :max-width +fill+ :max-height +fill+)))
2052
2053 (defmethod allocate-space ((pane generic-list-pane) w h)
2054 (resize-sheet pane w h))
2055
2056 (defmethod scroll-quantum ((pane generic-list-pane))
2057 (generic-list-pane-item-height pane))
2058
2059 (defmethod handle-repaint ((pane generic-list-pane) region)
2060 (with-bounding-rectangle* (sx0 sy0 sx1 sy1) (sheet-region pane)
2061 (declare (ignore sx1 sy1))
2062 (with-bounding-rectangle* (rx0 ry0 rx1 ry1)
2063 (if (bounding-rectangle-p region)
2064 region
2065 (or (pane-viewport-region pane) ; workaround for +everywhere+
2066 (sheet-region pane)))
2067 (let ((item-height (generic-list-pane-item-height pane))
2068 (highlight-ink (list-pane-highlight-ink pane)))
2069 (do ((index (floor (- ry0 sy0) item-height) (1+ index)))
2070 ((or (> (+ sy0 (* item-height index)) ry1)
2071 (>= index (generic-list-pane-items-length pane))))
2072 (let ((y0 (+ sy0 (* index item-height)))
2073 (y1 (+ sy0 (* (1+ index) item-height))))
2074 (multiple-value-bind (background foreground)
2075 (cond ((not (slot-boundp pane 'value))
2076 (values (pane-background pane) (pane-foreground pane)))
2077 ((if (list-pane-exclusive-p pane)
2078 (funcall (list-pane-test pane)
2079 (elt (generic-list-pane-item-values pane) index)
2080 (gadget-value pane))
2081 (member (elt (generic-list-pane-item-values pane) index) (gadget-value pane)
2082 :test (list-pane-test pane)))
2083 (values highlight-ink (pane-background pane)))
2084 (t (values (pane-background pane) (pane-foreground pane))))
2085 (draw-rectangle* pane rx0 y0 rx1 y1 :filled t :ink background)
2086 (draw-text* pane (elt (generic-list-pane-item-strings pane) index)
2087 sx0
2088 (+ y0 (text-style-ascent (pane-text-style pane) pane))
2089 :ink foreground
2090 :text-style (pane-text-style pane)))))))))
2091
2092 (defun generic-list-pane-select-item (pane item-value)
2093 "Toggle selection of a single item in the generic-list-pane.
2094 Returns :select or :deselect, depending on what action was performed."
2095 (if (list-pane-exclusive-p pane)
2096 (progn
2097 (setf (gadget-value pane :invoke-callback t) item-value)
2098 :select)
2099 (let ((member (member item-value (gadget-value pane) :test (list-pane-test pane))))
2100 (setf (gadget-value pane :invoke-callback t)
2101 (cond ((list-pane-exclusive-p pane)
2102 (list item-value))
2103 (member
2104 (remove item-value (gadget-value pane)
2105 :test (list-pane-test pane)))
2106 ((not member) (cons item-value (gadget-value pane)))))
2107 (if member :deselect :select))))
2108
2109 (defun generic-list-pane-add-selected-items (pane item-values)
2110 "Add a set of items to the current selection"
2111 (when (not (list-pane-exclusive-p pane))
2112 (setf (gadget-value pane :invoke-callback t)
2113 (remove-duplicates (append item-values
2114 (gadget-value pane))
2115 :test (list-pane-test pane)))))
2116
2117 (defun generic-list-pane-deselect-items (pane item-values)
2118 "Remove a set of items from the current selection"
2119 (when (not (list-pane-exclusive-p pane))
2120 (setf (gadget-value pane :invoke-calback t)
2121 (labels ((fun (item-values result)
2122 (if (null item-values)
2123 result
2124 (fun (rest item-values)
2125 (delete (first item-values) result
2126 :test (list-pane-test pane))))))
2127 (fun item-values (gadget-value pane))))))
2128
2129 (defun generic-list-pane-item-from-x-y (pane mx my)
2130 "Given a pointer event, determine what item in the pane it has fallen upon.
2131 Returns two values, the item itself, and the index within the item list."
2132 (declare (ignore mx))
2133 (with-bounding-rectangle* (sx0 sy0 sx1 sy1) (sheet-region pane)
2134 (declare (ignorable sx0 sx1 sy1))
2135 (with-slots (items) pane
2136 (let* ((item-height (generic-list-pane-item-height pane))
2137 (number-of-items (generic-list-pane-items-length pane))
2138 (n (floor (- my sy0) item-height))
2139 (index (and (>= n 0)
2140 (< n number-of-items)
2141 n))
2142 (item-value (and index (elt (generic-list-pane-item-values pane) index))))
2143 (values item-value index)))))
2144
2145 (defun generic-list-pane-handle-click (pane x y modifier)
2146 (multiple-value-bind (item-value index)
2147 (generic-list-pane-item-from-x-y pane x y)
2148 (if (list-pane-exclusive-p pane)
2149 ;; Exclusive mode
2150 (when index
2151 (setf (slot-value pane 'last-action)
2152 (generic-list-pane-select-item pane item-value)))
2153 ;; Nonexclusive mode
2154 (when index
2155 (with-slots (last-index last-action items prefer-single-selection) pane
2156 (cond
2157 ;; Add single selection
2158 ((not (zerop (logand modifier +control-key+)))
2159 (setf last-action (generic-list-pane-select-item pane item-value)))
2160 ;; Maybe extend selection
2161 ((not (zerop (logand modifier +shift-key+)))
2162 (if (and (numberp last-index)
2163 (not (null last-action)))
2164 ;; Extend last selection
2165 (funcall (if (eql last-action :select)
2166 #'generic-list-pane-add-selected-items
2167 #'generic-list-pane-deselect-items)
2168 pane
2169 (coerce (subseq (generic-list-pane-item-values pane)
2170 (min last-index index)
2171 (1+ (max last-index index))) 'list))
2172 (setf last-action (generic-list-pane-select-item pane item-value))))
2173 ;; Toggle single item
2174 (t (if prefer-single-selection
2175 (setf (gadget-value pane :invoke-callback t) (list item-value)
2176 last-action :select)
2177 (setf last-action (generic-list-pane-select-item pane item-value)))))
2178 (setf last-index index))))))
2179
2180 (defun generic-list-pane-handle-click-from-event (pane event)
2181 (multiple-value-bind (x y) (values (pointer-event-x event) (pointer-event-y event))
2182 (generic-list-pane-handle-click pane x y (event-modifier-state event))))
2183
2184 (defclass ad-hoc-presentation (standard-presentation) ())
2185
2186 (defmethod output-record-hit-detection-rectangle*
2187 ((presentation ad-hoc-presentation))
2188 (values most-negative-fixnum most-negative-fixnum
2189 most-positive-fixnum most-positive-fixnum))
2190
2191 (defun generic-list-pane-handle-right-click (pane event)
2192 (multiple-value-bind (x y)
2193 (values (pointer-event-x event) (pointer-event-y event))
2194 (multiple-value-bind (item-value index)
2195 (generic-list-pane-item-from-x-y pane x y)
2196 (let* ((item (elt (list-pane-items pane) index)))
2197 (meta-list-pane-call-presentation-menu pane item)))))
2198
2199 (defun meta-list-pane-call-presentation-menu (pane item)
2200 (let ((ptype (funcall (list-pane-presentation-type-key pane) item)))
2201 (when ptype
2202 (let ((presentation
2203 (make-instance 'ad-hoc-presentation
2204 :object (funcall (list-pane-value-key pane) item)
2205 :single-box t
2206 :type ptype)))
2207 (call-presentation-menu
2208 presentation
2209 *input-context*
2210 *application-frame*
2211 pane
2212 42 42
2213 :for-menu t
2214 :label (format nil "Operation on ~A" ptype))))))
2215
2216 (defmethod handle-event ((pane generic-list-pane) (event pointer-button-press-event))
2217 (case (pointer-event-button event)
2218 (#.+pointer-left-button+
2219 (generic-list-pane-handle-click-from-event pane event)
2220 (setf (slot-value pane 'armed) nil))
2221 (#.+pointer-right-button+
2222 (generic-list-pane-handle-right-click pane event))
2223 (t
2224 (when (next-method-p) (call-next-method)))))
2225
2226 (defmethod handle-event ((pane generic-list-pane) (event pointer-button-release-event))
2227 (if (eql (pointer-event-button event) +pointer-left-button+)
2228 (and (slot-value pane 'armed)
2229 (generic-list-pane-handle-click-from-event pane event))
2230 (when (next-method-p) (call-next-method))))
2231
2232 (defgeneric (setf list-pane-items)
2233 (newval pane &key invoke-callback)
2234 (:documentation
2235 "Set the current list of items for this list pane.
2236 The current GADGET-VALUE will be adjusted by removing values not
2237 specified by the new items. VALUE-CHANGED-CALLBACK will be called
2238 if INVOKE-CALLBACK is given."))
2239
2240 (defmethod (setf list-pane-items)
2241 (newval (pane meta-list-pane) &key invoke-callback)
2242 (declare (ignore invoke-callback))
2243 (setf (slot-value pane 'items) newval))
2244
2245 (defmethod (setf list-pane-items)
2246 :after
2247 (newval (pane meta-list-pane) &key invoke-callback)
2248 (when (slot-boundp pane 'value)
2249 (let ((new-values
2250 (coerce (climi::generic-list-pane-item-values pane) 'list))
2251 (test (list-pane-test pane)))
2252 (setf (gadget-value pane :invoke-callback invoke-callback)
2253 (if (list-pane-exclusive-p pane)
2254 (if (find (gadget-value pane) new-values :test test)
2255 (gadget-value pane)
2256 nil)
2257 (intersection (gadget-value pane) new-values :test test))))))
2258
2259 (defmethod (setf list-pane-items)
2260 (newval (pane generic-list-pane) &key invoke-callback)
2261 (call-next-method)
2262 (with-slots (items items-length item-strings item-values) pane
2263 (setf items-length (length newval))
2264 (setf item-strings nil)
2265 (setf item-values nil)))
2266
2267 (defmethod (setf list-pane-items) :after
2268 (newval (pane generic-list-pane) &key invoke-callback)
2269 (change-space-requirements
2270 pane
2271 :height (space-requirement-height (compose-space pane)))
2272 (handle-repaint pane +everywhere+))
2273
2274 ;;; OPTION-PANE
2275
2276 (define-abstract-pane-mapping 'option-pane 'generic-option-pane)
2277
2278 (defclass generic-option-pane (option-pane
2279 meta-list-pane
2280 value-changed-repaint-mixin
2281 3d-border-mixin
2282 arm/disarm-repaint-mixin
2283 enter/exit-arms/disarms-mixin)
2284 ((current-label :initform "" :accessor generic-option-pane-label))
2285 (:default-initargs :text-style (make-text-style :sans-serif :roman :normal)))
2286
2287 (defun option-pane-evil-backward-map (pane value)
2288 (let ((key-fn (list-pane-value-key pane)))
2289 (if (eql key-fn #'identity) ;; SANE CASE
2290 value
2291 (find value (list-pane-items pane) ;; INSANE CASE
2292 :key key-fn :test (list-pane-test pane)))))
2293
2294 (defun generic-option-pane-compute-label-from-value (pane value)
2295 (flet ((label (value) (funcall (list-pane-name-key pane) (option-pane-evil-backward-map pane value))))
2296 (if (list-pane-exclusive-p pane)
2297 (if (or value
2298 (member nil (list-pane-items pane) ;; Kludge in case NIL is part of the item set..
2299 :key (list-pane-value-key pane)
2300 :test (list-pane-test pane)))
2301 (label value)
2302 "")
2303 (cond ((= 0 (length value)) "")
2304 ((= 1 (length value)) (label (first value)))
2305 (t "...")))))
2306
2307 (defun generic-option-pane-compute-label-from-item (pane item)
2308 (funcall (list-pane-name-key pane) item))
2309
2310 (defun generic-option-pane-compute-label (pane)
2311 (generic-option-pane-compute-label-from-value pane (gadget-value pane)))
2312
2313 (defmethod initialize-instance :after ((object generic-option-pane) &rest rest)
2314 (declare (ignore rest))
2315 (setf (slot-value object 'current-label)
2316 (if (slot-boundp object 'value)
2317 (generic-option-pane-compute-label object)
2318 "")))
2319
2320 (defmethod (setf gadget-value) :after (new-value (gadget generic-option-pane) &key &allow-other-keys)
2321 (setf (slot-value gadget 'current-label)
2322 (generic-option-pane-compute-label-from-value gadget new-value)))
2323
2324 (defmethod generic-option-pane-widget-size (pane)
2325 ;; We now always make the widget occupying a square.
2326 (let ((h (bounding-rectangle-height pane)))
2327 (values h h)))
2328
2329 (defun draw-engraved-vertical-separator (pane x y0 y1 highlight-color shadow-color)
2330 (draw-line* pane (1+ x) (1+ y0) (1+ x) (1- y1) :ink highlight-color)
2331 (draw-line* pane x y1 (1+ x) y1 :ink highlight-color)
2332 (draw-line* pane x (1+ y0) x (1- y1) :ink shadow-color)
2333 (draw-line* pane x y0 (1+ x) y0 :ink shadow-color))
2334
2335 (defun generic-option-pane-text-size (pane)
2336 (text-size (sheet-medium pane) (slot-value pane 'current-label)
2337 :text-style (pane-text-style pane)))
2338
2339 (defun draw-vertical-arrow (sheet x0 y0 direction)
2340 (assert (or (eq direction :up)
2341 (eq direction :down)))
2342 (let* ((dx -4)
2343 (dy 4)
2344 (shape
2345 (if (eq direction :up) ;; Hack-p?
2346 (list x0 y0
2347 (+ x0 dx) (+ 1 y0 dy)
2348 (- x0 dx) (+ 1 y0 dy))
2349 (list x0 y0
2350 (+ 1 x0 dx) (+ y0 (- dy))
2351 (- x0 dx) (+ y0 (- dy))))))
2352 (draw-polygon* sheet shape :ink +black+)))
2353
2354 (defun generic-option-pane-compute-max-label-width (pane)
2355 (max
2356 (reduce #'max
2357 (mapcar #'(lambda (value)
2358 (text-size (sheet-medium pane)
2359 (generic-option-pane-compute-label-from-item pane value)
2360 :text-style (pane-text-style pane)))
2361 (list-pane-items pane)))
2362 (text-size (sheet-medium pane) "..." :text-style (pane-text-style pane))))
2363
2364 (defmethod compose-space ((pane generic-option-pane) &key width height)
2365 (declare (ignore width height))
2366 (let* ((horizontal-padding 8) ;### 2px border + 2px padding each side
2367 (vertical-padding 8) ;### this should perhaps be computed from
2368 ;### border-width and spacing.
2369 (l-width (generic-option-pane-compute-max-label-width pane))
2370 (l-height (text-style-height (pane-text-style pane) (sheet-medium pane)))
2371 (total-width (+ horizontal-padding l-width
2372 ;; widget width
2373 l-height
2374 8))
2375 (total-height (+ vertical-padding l-height)))
2376 (make-space-requirement :min-width total-width
2377 :width total-width
2378 :max-width +fill+
2379 :min-height total-height
2380 :height total-height
2381 :max-height total-height)))
2382
2383 (defmethod generic-option-pane-draw-widget (pane)
2384 (with-bounding-rectangle* (x0 y0 x1 y1) pane
2385 (declare (ignore x0))
2386 (multiple-value-bind (widget-width widget-height)
2387 (generic-option-pane-widget-size pane)
2388 (let ((center (floor (/ (- y1 y0) 2)))
2389 (height/2 (/ widget-height 2))
2390 (highlight-color (compose-over (compose-in +white+ (make-opacity 0.85))
2391 (pane-background pane)))
2392 (shadow-color (compose-over (compose-in +black+ (make-opacity 0.3))
2393 (pane-background pane))))
2394 (draw-engraved-vertical-separator pane
2395 (- x1 widget-width -1)
2396 (- center height/2)
2397 (+ center height/2)
2398 highlight-color shadow-color)
2399 (let* ((x (+ (- x1 widget-width) (/ widget-width 2)))
2400 (frob-x (+ (floor x) 0)))
2401 (draw-vertical-arrow pane frob-x (- center 6) :up)
2402 (draw-vertical-arrow pane frob-x (+ center 6) :down))))))
2403
2404 (defun rewrite-event-for-grab (grabber event)
2405 (multiple-value-bind (nx ny)
2406 (multiple-value-call #'untransform-position
2407 (sheet-delta-transformation grabber nil) ;; assumes this is the graft's coordinate system..
2408 (values (pointer-event-native-graft-x event)
2409 (pointer-event-native-graft-y event)))
2410 (with-slots (sheet x y) event
2411 (setf sheet grabber
2412 x nx
2413 y ny)))
2414 event)
2415
2416 (defun popup-compute-spaces (pane graft)
2417 (with-bounding-rectangle* (x0 top x1 bottom) (sheet-region pane)
2418 (multiple-value-call #'(lambda (x0 top x1 bottom)
2419 (declare (ignore x0 x1))
2420 (values (max 0 (1- top))
2421 (max 0 (- (graft-height graft) bottom))
2422 top
2423 bottom))
2424 (transform-position (sheet-delta-transformation pane nil) x0 top)<