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

Contents of /mcclim/panes.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.197 - (show annotations)
Sat Aug 1 22:11:06 2009 UTC (4 years, 8 months ago) by gbaumann
Branch: MAIN
CVS Tags: HEAD
Changes since 1.196: +2 -15 lines
(ALLOCATE-SPACE SCROLLER-PANE T T)
    Missed one *SCROLLBAR-THICKNESS*

SCROLL-AREA
    Removed this ticking bomb.
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 1998,1999,2000,2001 by Michael McDonald (mikemac@mikemac.com)
4 ;;; (c) copyright 2000 by
5 ;;; Iban Hatchondo (hatchond@emi.u-bordeaux.fr)
6 ;;; Julien Boninfante (boninfan@emi.u-bordeaux.fr)
7 ;;; (c) copyright 2000, 2001 by
8 ;;; Robert Strandh (strandh@labri.u-bordeaux.fr)
9 ;;; (c) copyright 2001 by
10 ;;; Lionel Salabartan (salabart@emi.u-bordeaux.fr)
11 ;;; Arnaud Rouanet (rouanet@emi.u-bordeaux.fr)
12 ;;; (c) copyright 2002, 2003 by
13 ;;; Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
14
15 ;;; This library is free software; you can redistribute it and/or
16 ;;; modify it under the terms of the GNU Library General Public
17 ;;; License as published by the Free Software Foundation; either
18 ;;; version 2 of the License, or (at your option) any later version.
19 ;;;
20 ;;; This library is distributed in the hope that it will be useful,
21 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
22 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
23 ;;; Library General Public License for more details.
24 ;;;
25 ;;; You should have received a copy of the GNU Library General Public
26 ;;; License along with this library; if not, write to the
27 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
28 ;;; Boston, MA 02111-1307 USA.
29
30 ;;; $Id: panes.lisp,v 1.197 2009/08/01 22:11:06 gbaumann Exp $
31
32 (in-package :clim-internals)
33
34 ;;;;
35 ;;;; Ambiguities and Obmissions
36 ;;;;
37
38 ;; This is a scratch pad, were we can document, what the spec doesn't
39 ;; tells us about CLIM. Reason: While coding, one sees were the spec
40 ;; is vague or wrong; later when the task to update the spec is due,
41 ;; things might be forgotten. --GB
42
43 ;;
44 ;; - Default of :equalize-width / :equalize-height is T
45 ;;
46 ;; - LAYOUT-PANE is mentioned in the spec's example, but not in the
47 ;; text.
48 ;;
49 ;; - Behaviour of :align-x, :align-y is uncertain.
50 ;; (Should it be specifed on the childs? on the parents?)
51 ;;
52 ;; - BORDER-PANE is not in the spec and just a different name of
53 ;; OUTLINED-PANE, where is it from? --GB
54 ;;
55 ;; - RAISED-PANE, where form? --GB
56 ;;
57
58 ;; - In XBOX-PANE: I would like to also allow for (1 <pane>) being a
59 ;; proportional content.
60
61
62 ;;;; TODO
63
64 ;; - VBOX/HBOX/VRACK/HRACK:
65 ;; . should align its children
66 ;; Q: Should we cope with proportional content differently?
67 ;; . test units for spacing and fixed width
68 ;; Q: When to resolve?
69 ;; . adopt/disown/enable/disable
70 ;;
71 ;; - TABLE-PANE
72 ;; . test units
73 ;; . adopt/disown/enable/disable
74 ;; . allow for partially filled rows/cols?
75 ;;
76 ;; - GRID-PANE
77 ;; . align children
78 ;; . test units
79 ;; . adopt/disown/enable/disable
80 ;;
81 ;; - SPACING-PANE
82 ;; . align child
83 ;; Or: expand them as we did?
84 ;; . adopt/disown/enable/disable
85 ;;
86 ;; - RESTRAINING-PANE
87 ;; . ???
88 ;;
89 ;; - LABEL-PANE
90 ;; . test units
91 ;; . adopt/disown/enable/disable
92 ;; . expand child? leave it?
93 ;;
94 ;; - SCROLLER-PANE
95 ;; . much!
96 ;;
97 ;; - we still need to think about what should happen when children
98 ;; get disabled or adopted or disowned.
99 ;;
100 ;; - adjust class names.
101 ;;
102 ;; - advertise layout-child et al
103 ;;
104 ;; - reuse single-child-composite-pane
105 ;;
106 ;; - MAKE-SPACE-REQUIREMENT right?
107 ;; . default arguments in the spec are different
108 ;; . DUIM's default for maxima is not +fill+ but the dimension
109 ;;
110 ;; - what are the appropriate default values for align?
111 ;;
112
113 ;; - for layout purposes the list of children should be considered in
114 ;; reverse: The first element of children should come last.
115
116 ;;--GB 2002-02-27
117
118 ;;;; CLIM Layout Protocol for Dummies
119
120 ;; Here is how I interpret the relevant sections of the specification:
121 ;;
122 ;; COMPOSE-SPACE
123 ;;
124 ;; This is called by CLIM, when it wants to find out what the pane
125 ;; thinks are its space requirements. The result of COMPOSE-SPACE is
126 ;; cached by CLIM.
127 ;;
128 ;; ALLOCATE-SPACE
129 ;;
130 ;; This method is called by CLIM when a pane is allocate space. It
131 ;; should layout its possible children.
132 ;;
133 ;; CHANGE-SPACE-REQUIREMENTS
134 ;;
135 ;; This is called by the application programmer to a) indicate that
136 ;; COMPOSE-SPACE may now return something different from previous
137 ;; invocations and/or b) to update the user space requirements
138 ;; options (the :width, :height etc keywords as upon pane creation).
139 ;;
140 ;; NOTE-SPACE-REQUIREMENTS-CHANGED
141 ;;
142 ;; Called by CLIM when the space requirements of a pane have
143 ;; changed. Not called to layout a pane; This is only a kind of signal.
144 ;;
145 ;; LAYOUT-FRAME
146 ;;
147 ;; Maybe called by both CLIM and the application programmer to
148 ;; "invoke the space allocation protocol", that is CLIM calls
149 ;; ALLOCATE-SPACE on the top level sheet. This in turn will probably
150 ;; call COMPOSE-SPACE on its children and layout then accordingly by
151 ;; calling ALLOCATE-SPACE again.
152 ;;
153 ;; The effect is that ALLOCATE-SPACE propagate down the sheet
154 ;; hierarchy.
155 ;;
156 ;; --GB 2003-08-06
157
158 ;; For each of the builtin CLIM gadgets there is an abstract gadget class
159 ;; and at least one "concrete" subclass which can be chosen by the
160 ;; frame manager. The CLIM 2.0 spec names one concrete class for each
161 ;; abstract class. Frame managers need a mechanism to look up these
162 ;; concrete classes. The current practice of the CLX backend is to
163 ;; search for classes of various names based on the name of the abstract
164 ;; class. This mostly works as all but two of the specified concrete
165 ;; class names can be produced by appending "-PANE" to the abstract class
166 ;; name. The classes GENERIC-LIST-PANE and GENERIC-OPTION-PANE break this
167 ;; convention.
168
169 ;; I've extended the CLX frame manager to additionally search the property
170 ;; list of the pane class name when searching for a concrete pane class. The
171 ;; function below can be used where needed to place the concrete class name
172 ;; where it needs to go.
173
174 ;; This could be easily extended to allow mappings for specific backends..
175
176 (defun define-abstract-pane-mapping (abstract-class-name concrete-class-name)
177 (setf (get abstract-class-name 'concrete-pane-class-name)
178 concrete-class-name))
179
180
181
182 ;;; Default Color Scheme Options
183
184 #||
185 ;; Motif-ish
186 (defparameter *3d-dark-color* (make-gray-color .45))
187 (defparameter *3d-normal-color* (make-gray-color .75))
188 (defparameter *3d-light-color* (make-gray-color .92))
189 (defparameter *3d-inner-color* (make-gray-color .65))
190 ||#
191
192 ;; Gtk-ish
193
194 (defparameter *3d-dark-color* (make-gray-color .59))
195 (defparameter *3d-normal-color* (make-gray-color .84))
196 (defparameter *3d-light-color* (make-gray-color 1.0))
197 (defparameter *3d-inner-color* (make-gray-color .75))
198
199 ;;; Gadget "Feel"
200
201 (defparameter *double-click-delay* 0.25
202 "Maximum time in seconds between clicks in order to produce a double-click")
203
204 (defparameter *double-click-max-travel* 7
205 "Maximum distance in device units that the cursor may move between clicks in
206 order to produce a double-click")
207
208 ;;;
209 ;;; gadgets look
210 ;;;
211
212 ;; Only used by some gadgets, I suggest using my more flexible and
213 ;; general DRAW-BORDERED-POLYGON.
214
215 (defun display-gadget-background (gadget color x1 y1 x2 y2)
216 (draw-rectangle* gadget x1 y1 x2 y2 :ink color :filled t))
217
218 (defun draw-edges-lines* (pane ink1 x1 y1 ink2 x2 y2)
219 (draw-line* pane x1 y1 x2 y1 :ink ink1)
220 (draw-line* pane x1 y1 x1 y2 :ink ink1)
221 (draw-line* pane x1 y2 x2 y2 :ink ink2)
222 (draw-line* pane x2 y1 x2 y2 :ink ink2))
223
224
225 ;;; Space Requirements
226
227 (defconstant +fill+ (expt 10 (floor (log most-positive-fixnum 10))))
228
229 (defclass space-requirement () ())
230
231 (defclass standard-space-requirement (space-requirement)
232 ((width :initform 1
233 :initarg :width
234 :reader space-requirement-width)
235 (max-width :initform 1
236 :initarg :max-width
237 :reader space-requirement-max-width)
238 (min-width :initform 1
239 :initarg :min-width
240 :reader space-requirement-min-width)
241 (height :initform 1
242 :initarg :height
243 :reader space-requirement-height)
244 (max-height :initform 1
245 :initarg :max-height
246 :reader space-requirement-max-height)
247 (min-height :initform 1
248 :initarg :min-height
249 :reader space-requirement-min-height) ) )
250
251 (defmethod print-object ((space standard-space-requirement) stream)
252 (with-slots (width height min-width max-width min-height max-height) space
253 (print-unreadable-object (space stream :type t :identity nil)
254 (format stream "width: ~S [~S,~S] height: ~S [~S,~S]"
255 width
256 min-width
257 max-width
258 height
259 min-height
260 max-height))))
261
262 (defun make-space-requirement (&key (width 1) (height 1)
263 (min-width 0) (min-height 0)
264 (max-width +fill+) (max-height +fill+))
265 (assert (<= 0 min-width width max-width) (min-width width max-width))
266 (assert (<= 0 min-height height max-height) (min-height height max-height))
267 (make-instance 'standard-space-requirement
268 :width width
269 :max-width max-width
270 :min-width min-width
271 :height height
272 :max-height max-height
273 :min-height min-height))
274
275 (defmethod space-requirement-components ((space-req standard-space-requirement))
276 (with-slots (width min-width max-width height min-height max-height) space-req
277 (values width min-width max-width height min-height max-height)))
278
279 (defun space-requirement-combine* (function sr1 &key (width 0) (min-width 0) (max-width 0)
280 (height 0) (min-height 0) (max-height 0))
281 (apply #'make-space-requirement
282 (mapcan #'(lambda (c1 c2 keyword)
283 (list keyword (funcall function c1 c2)))
284 (multiple-value-list (space-requirement-components sr1))
285 (list width min-width max-width height min-height max-height)
286 '(:width :min-width :max-width :height :min-height :max-height))))
287
288 (defun space-requirement-combine (function sr1 sr2)
289 (multiple-value-bind (width min-width max-width height min-height max-height)
290 (space-requirement-components sr2)
291 (space-requirement-combine* function sr1
292 :width width
293 :min-width min-width
294 :max-width max-width
295 :height height
296 :min-height min-height
297 :max-height max-height)))
298
299 (defun space-requirement+ (sr1 sr2)
300 (space-requirement-combine #'+ sr1 sr2))
301
302 (defun space-requirement+* (space-req &key (width 0) (min-width 0) (max-width 0)
303 (height 0) (min-height 0) (max-height 0))
304 (space-requirement-combine* #'+ space-req
305 :width width
306 :min-width min-width
307 :max-width max-width
308 :height height
309 :min-height min-height
310 :max-height max-height))
311
312 (eval-when (:compile-toplevel :load-toplevel :execute)
313 (defun spacing-value-p (x)
314 (or (and (realp x) (>= x 0))
315 (and (consp x)
316 (realp (car x))
317 (consp (cdr x))
318 (member (cadr x) '(:point :pixel :mm :character :line))
319 (null (cddr x)))
320 ;; For clim-stream-pane
321 (eq x :compute)))
322 )
323
324 (deftype spacing-value ()
325 ;; just for documentation
326 `(satisfies spacing-value-p))
327
328 ;;; PANES
329
330 ;; Macros for quick access to space-requirement slots.
331 (defmacro sr-width (pane)
332 `(space-requirement-width (pane-space-requirement ,pane)))
333 (defmacro sr-height (pane)
334 `(space-requirement-height (pane-space-requirement ,pane)))
335 (defmacro sr-max-width (pane)
336 `(space-requirement-max-width (pane-space-requirement ,pane)))
337 (defmacro sr-max-height (pane)
338 `(space-requirement-max-height (pane-space-requirement ,pane)))
339 (defmacro sr-min-width (pane)
340 `(space-requirement-min-width (pane-space-requirement ,pane)))
341 (defmacro sr-min-height (pane)
342 `(space-requirement-min-height (pane-space-requirement ,pane)))
343
344 (defclass layout-protocol-mixin ()
345 ((space-requirement :accessor pane-space-requirement
346 :initform nil
347 :documentation "The cache of the space requirements of the pane. NIL means: need to recompute.")
348 (current-width :accessor pane-current-width
349 :initform nil)
350 (current-height :accessor pane-current-height
351 :initform nil) ))
352
353 ;;; XXX Move to protocol-classes.lisp. Should this really have all these
354 ;;; superclasses?
355 (define-protocol-class pane (clim-repainting-mixin
356 clim-sheet-input-mixin
357 sheet-transformation-mixin
358 layout-protocol-mixin
359 basic-sheet)
360 (
361 (text-style :initarg :text-style :initform nil :reader pane-text-style)
362 (name :initarg :name :initform "(Unnamed Pane)" :reader pane-name)
363 (manager :initarg :manager)
364 (port :initarg :port)
365 (frame :initarg :frame :initform *application-frame* :reader pane-frame)
366 (enabledp :initform nil :initarg :enabledp :accessor pane-enabledp)
367 (space-requirement :initform nil :accessor pane-space-requirement)
368 ;; New sizes, for allocating protocol
369 (new-width :initform nil)
370 (new-height :initform nil)
371 (redisplay-needed :accessor pane-redisplay-needed
372 :initarg :redisplay-needed :initform nil))
373 (:documentation ""))
374
375 (defmethod print-object ((pane pane) sink)
376 (print-unreadable-object (pane sink :type t :identity t)
377 (prin1 (pane-name pane) sink)))
378
379 (defun make-pane (type &rest args)
380 (when (eql (symbol-package type)
381 (symbol-package :foo))
382 (setf type (or (find-symbol (symbol-name type) (find-package :clim))
383 type)))
384 (apply #'make-pane-1 *pane-realizer* *application-frame* type args))
385
386 (defmethod medium-foreground ((pane pane))
387 (medium-foreground (sheet-medium pane)))
388
389 (defmethod (setf medium-foreground) (ink (pane pane))
390 (setf (medium-foreground (sheet-medium pane)) ink))
391
392 (defmethod medium-background ((pane pane))
393 (medium-background (sheet-medium pane)))
394
395 (defmethod (setf medium-background) (ink (pane pane))
396 (setf (medium-background (sheet-medium pane)) ink))
397
398 (defmethod compose-space ((pane pane) &key width height)
399 (make-space-requirement :width (or width 200)
400 :height (or height 200)))
401
402 (defmethod allocate-space ((pane pane) width height)
403 (declare (ignorable pane width height))
404 )
405
406 (defmethod pane-needs-redisplay ((pane pane))
407 (let ((do-redisplay (pane-redisplay-needed pane)))
408 (values do-redisplay
409 (and do-redisplay (not (eq do-redisplay :no-clear))))))
410
411 (defmethod (setf pane-needs-redisplay) (value (pane pane))
412 (setf (pane-redisplay-needed pane) value))
413
414 (defmethod window-clear ((pane pane))
415 nil)
416
417 ;;; WINDOW STREAM
418
419 ;; ???
420 (defclass window-stream (standard-extended-output-stream
421 standard-extended-input-stream)
422 () )
423
424 ;;;
425 ;;; Utilities
426 ;;;
427
428 ;; Since, I hate to duplicate code for HBOX and VBOX, I define this
429 ;; evil macro:
430
431 (defmacro dada ((&rest substs) &body body)
432 "This is an evil macro."
433 (setf substs (sort substs #'> :key (lambda (s) (length (symbol-name (first s))))))
434 `(progn
435 ,@(loop for k from 1 below (length (first substs)) collect
436 (labels ((subst-one (new old sym)
437 (let ((p (search (symbol-name old) (symbol-name sym))))
438 (cond ((not (null p))
439 (let ((pack (if (eq (symbol-package sym)
440 (find-package :keyword))
441 (symbol-package sym)
442 *package*)))
443 (intern (concatenate 'string
444 (subseq (symbol-name sym) 0 p)
445 (symbol-name new)
446 (subseq (symbol-name sym)
447 (+ p (length (symbol-name old)))))
448 pack)))
449 (t
450 sym))))
451 (walk (x)
452 (cond ((symbolp x)
453 (dolist (subst substs)
454 (setf x (subst-one (elt subst k) (first subst) x)))
455 x)
456 ((atom x) x)
457 ((consp x)
458 (cons (walk (car x)) (walk (cdr x)))))))
459 `(locally
460 ,@(walk body))))))
461
462 ;;;; Layout Utilities
463
464 (defun layout-child (child align-x align-y x y width height)
465 "Allocates space to a child of a pane.
466 x, y, width, height designate the area of available space.
467 align-x, align-y name the desired child alignment.
468 If the child does not have enough strechability to cover all of the
469 given area, it is aligned within that area according to the given
470 options.
471
472 As a special option we allow align-x or align-y be :expand, which
473 means that the child wouldn't be aligned in that direction but its
474 size would be forced."
475 (let* ((sr (compose-space child))
476 ;; The child's dimension is clamped within its min/max space requirement
477 (child-width (if (eql :expand align-x)
478 width
479 (clamp width
480 (space-requirement-min-width sr)
481 (space-requirement-max-width sr))))
482 (child-height (if (eql :expand align-y)
483 height
484 (clamp height
485 (space-requirement-min-height sr)
486 (space-requirement-max-height sr))))
487 ;; Align the child within the available area
488 (child-x (ecase align-x
489 ((:left) x)
490 ((:center) (+ x (/ (- width child-width) 2)))
491 ((:right) (+ x (- width child-width)))
492 ((:expand) x) ))
493 (child-y (ecase align-y
494 ((:top) y)
495 ((:center) (+ y (/ (- height child-height) 2)))
496 ((:bottom) (+ y (- height child-height)))
497 ((:expand) y) )))
498 ;; Actually layout the child
499 (move-sheet child child-x child-y)
500 (resize-sheet child child-width child-height)
501 (allocate-space child child-width child-height)))
502
503
504 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
505
506 ;;;; User Space Requirements
507
508 (defclass space-requirement-options-mixin ()
509 ((user-width
510 :initarg :width
511 :initform nil
512 :reader pane-user-width
513 :type (or null spacing-value))
514 (user-min-width
515 :initarg :min-width
516 :initform nil
517 :reader pane-user-min-width
518 :type (or null spacing-value))
519 (user-max-width
520 :initarg :max-width
521 :initform nil
522 :reader pane-user-max-width
523 :type (or null spacing-value))
524 (user-height
525 :initarg :height
526 :initform nil
527 :reader pane-user-height
528 :type (or null spacing-value))
529 (user-min-height
530 :initarg :min-height
531 :initform nil
532 :reader pane-user-min-height
533 :type (or null spacing-value))
534 (user-max-height
535 :initarg :max-height
536 :initform nil
537 :reader pane-user-max-height
538 :type (or null spacing-value))
539 (x-spacing
540 :initarg :x-spacing
541 :initform 0
542 :reader pane-x-spacing
543 :type (or null spacing-value))
544 (y-spacing
545 :initarg :y-spacing
546 :initform 0
547 :reader pane-y-spacing
548 :type (or null spacing-value)))
549 (:documentation
550 "Mixin class for panes which offer the standard user space requirements options."))
551
552 (defclass standard-space-requirement-options-mixin (space-requirement-options-mixin)
553 ())
554
555 (defun merge-one-option
556 (pane foo user-foo user-min-foo user-max-foo min-foo max-foo)
557
558
559 ;; NOTE: The defaulting for :min-foo and :max-foo is different from MAKE-SPACE-REQUIREMENT.
560 ;; MAKE-SPACE-REQUIREMENT has kind of &key foo (min-foo 0) (max-foo +fill+)
561 ;; While user space requirements has &key foo (min-foo foo) (max-foo foo).
562 ;; I as a user would pretty much expect the same behavior, therefore I'll take the
563 ;; following route:
564 ;; When the :foo option is given, I'll let MAKE-SPACE-REQUIREMENT decide.
565 ;;
566 ;; old code:
567 ;;
568 ;; ;; Then we resolve defaulting. sec 29.3.1 says:
569 ;; ;; | If either of the :max-width or :min-width options is not
570 ;; ;; | supplied, it defaults to the value of the :width option. If
571 ;; ;; | either of the :max-height or :min-height options is not
572 ;; ;; | supplied, it defaults to the value of the :height option.
573 ;; (setf user-max-foo (or user-max-foo user-foo)
574 ;; user-min-foo (or user-min-foo user-foo))
575 ;; --GB 2003-01-23
576
577 (when (and (null user-max-foo) (not (null user-foo)))
578 (setf user-max-foo (space-requirement-max-width
579 (make-space-requirement
580 :width (spacing-value-to-device-units pane foo)))))
581 (when (and (null user-min-foo) (not (null user-foo)))
582 (setf user-min-foo (space-requirement-min-width
583 (make-space-requirement
584 :width (spacing-value-to-device-units pane foo)))))
585
586 ;; when the user has no idea about the preferred size just take the
587 ;; panes preferred size.
588 (setf user-foo (or user-foo foo))
589 (setf user-foo (spacing-value-to-device-units pane user-foo))
590
591 ;; dito for min/max
592 (setf user-min-foo (or user-min-foo min-foo)
593 user-max-foo (or user-max-foo max-foo))
594
595 ;; | :max-width, :min-width, :max-height, and :min-height can
596 ;; | also be specified as a relative size by supplying a list of
597 ;; | the form (number :relative). In this case, the number
598 ;; | indicates the number of device units that the pane is
599 ;; | willing to stretch or shrink.
600 (labels ((resolve-relative (dimension sign base)
601 (if (and (consp dimension) (eq (car dimension) :relative))
602 (+ base (* sign (cadr dimension)))
603 (spacing-value-to-device-units pane dimension))))
604 (setf user-min-foo (and user-min-foo
605 (resolve-relative user-min-foo -1 user-foo))
606 user-max-foo (and user-max-foo
607 (resolve-relative user-max-foo +1 user-foo))))
608
609 ;; Now we have two space requirements which need to be 'merged'.
610 (setf min-foo (clamp user-min-foo min-foo max-foo)
611 max-foo (clamp user-max-foo min-foo max-foo)
612 foo (clamp user-foo min-foo max-foo))
613 (values foo min-foo max-foo))
614
615 (defmethod merge-user-specified-options ((pane space-requirement-options-mixin)
616 sr)
617 ;; ### I want proper error checking and in case there is an error we
618 ;; should just emit a warning and move on. CLIM should not die from
619 ;; garbage passed in here.
620 (multiple-value-bind (width min-width max-width height min-height max-height)
621 (space-requirement-components sr)
622 (multiple-value-bind (new-width new-min-width new-max-width)
623 (merge-one-option pane
624 width
625 (pane-user-width pane)
626 (pane-user-min-width pane)
627 (pane-user-max-width pane)
628 min-width
629 max-width)
630 (multiple-value-bind (new-height new-min-height new-max-height)
631 (merge-one-option pane
632 height
633 (pane-user-height pane)
634 (pane-user-min-height pane)
635 (pane-user-max-height pane)
636 min-height
637 max-height)
638 (make-space-requirement
639 :width new-width
640 :min-width new-min-width
641 :max-width new-max-width
642 :height new-height
643 :min-height new-min-height
644 :max-height new-max-height)))))
645
646
647 (defmethod compose-space :around ((pane space-requirement-options-mixin)
648 &key width height)
649 (declare (ignore width height))
650 ;; merge user specified options.
651 (let ((sr (call-next-method)))
652 (unless sr
653 (warn "~S has no idea about its space-requirements." pane)
654 (setf sr (make-space-requirement :width 100 :height 100)))
655 (merge-user-specified-options pane sr)))
656
657 (defmethod change-space-requirements :before ((pane space-requirement-options-mixin)
658 &key (width :nochange) (min-width :nochange) (max-width :nochange)
659 (height :nochange) (min-height :nochange) (max-height :nochange)
660 (x-spacing :nochange) (y-spacing :nochange)
661 &allow-other-keys)
662 (with-slots (user-width user-min-width user-max-width
663 user-height user-min-height user-max-height
664 (user-x-spacing x-spacing)
665 (user-y-spacing y-spacing))
666 pane
667 (unless (eq width :nochange) (setf user-width width))
668 (unless (eq min-width :nochange) (setf user-min-width min-width))
669 (unless (eq max-width :nochange) (setf user-max-width max-width))
670 (unless (eq height :nochange) (setf user-height height))
671 (unless (eq min-height :nochange) (setf user-min-height min-height))
672 (unless (eq max-height :nochange) (setf user-max-height max-height))
673 (unless (eq x-spacing :nochange) (setf user-x-spacing x-spacing))
674 (unless (eq y-spacing :nochange) (setf user-y-spacing y-spacing)) ))
675
676 ;;;; LAYOUT-PROTOCOL-MIXIN
677
678 ;;; Note
679
680 ;; This is how I read the relevant section of the specification:
681 ;;
682 ;; - space is only allocated / composed when the space allocation
683 ;; protocol is invoked, that is when layout-frame is called.
684 ;;
685 ;; - CHANGE-SPACE-REQUIREMENTS is only for
686 ;; . reparsing the user space options
687 ;; . flushing the space requirement cache of that pane.
688 ;;
689 ;; - when within CHANGING-SPACE-REQUIREMENTS, the method for
690 ;; CHANGING-SPACE-REQUIREMENTS on the top level sheet should not
691 ;; invoke the layout protocol but remember that the SR of the frame
692 ;; LAYOUT-FRAME then is then called when leaving
693 ;; CHANGING-SPACE-REQUIREMENTS.
694 ;;
695 ;; - NOTE-SPACE-REQUIREMENTS-CHANGED is solely for the user.
696 ;;
697 ;; --GB 2003-03-16
698
699 (defmethod allocate-space :around ((pane layout-protocol-mixin) width height)
700 (unless (and (eql (pane-current-width pane) width)
701 (eql (pane-current-height pane) height))
702 (setf (pane-current-width pane) width
703 (pane-current-height pane) height)
704 (unless (typep pane 'top-level-sheet-pane)
705 (resize-sheet pane width height))
706 (call-next-method)))
707
708 (defmethod compose-space :around ((pane layout-protocol-mixin) &key width height)
709 (declare (ignore width height))
710 (or (pane-space-requirement pane)
711 (setf (pane-space-requirement pane)
712 (call-next-method))))
713
714 ;;; changing space requirements
715
716 ;; Here is what we do:
717 ;;
718 ;; change-space-requirements (pane) :=
719 ;; clear space requirements cache
720 ;; call change-space-requirements on parent pane
721 ;; call note-space-requirements-changed
722 ;;
723 ;; This is split into :before, primary and :after method to allow for
724 ;; easy overriding of change-space-requirements without needing to
725 ;; know the details of the space requirement cache and the
726 ;; note-space-requirements-changed notifications.
727 ;;
728 ;; The calls to change-space-requirements travel all the way up to the
729 ;; top-level-sheet-pane which then invokes the layout protocol calling
730 ;; layout-frame.
731 ;;
732 ;; In case this happens within changing-space-requirements layout
733 ;; frame is not called but simply recorded and then called when
734 ;; changing-space-requirements is left.
735 ;;
736 ;; No action is taken in note-space-requirements-changed. We leave
737 ;; that to the user.
738
739 (defvar *changing-space-requirements* nil
740 "Bound to non-NIL while within the execution of CHANGING-SPACE-REQUIREMENTS.")
741
742 (defvar *changed-space-requirements* nil
743 "A list of (frame pane resize-frame) tuples recording frames and their panes which
744 changed during the current execution of CHANGING-SPACE-REQUIREMENTS.
745 [This is expected to change]")
746
747 (defmethod change-space-requirements :before ((pane layout-protocol-mixin)
748 &rest space-req-keys
749 &key resize-frame &allow-other-keys)
750 (declare (ignore resize-frame space-req-keys))
751 ;; Clear the space requirements cache
752 (setf (pane-space-requirement pane) nil)
753 (setf (pane-current-width pane) nil)
754 (setf (pane-current-height pane) nil) )
755
756 (defmethod change-space-requirements ((pane layout-protocol-mixin)
757 &key resize-frame &allow-other-keys)
758 (when (sheet-parent pane)
759 (change-space-requirements (sheet-parent pane)
760 :resize-frame resize-frame)))
761
762 (defmethod change-space-requirements :after ((pane layout-protocol-mixin)
763 &key resize-frame &allow-other-keys)
764 (declare (ignore resize-frame))
765 (note-space-requirements-changed (sheet-parent pane) pane))
766
767 (defmethod note-space-requirements-changed (pane client)
768 "Just a no-op fallback method."
769 nil)
770
771 ;;; CHANGING-SPACE-REQUIREMENTS macro
772
773 (defmacro changing-space-requirements ((&key resize-frame layout) &body body)
774 `(invoke-with-changing-space-requirements (lambda () ,@body) :resize-frame ,resize-frame :layout ,layout))
775
776 (defun invoke-with-changing-space-requirements (continuation &key resize-frame layout)
777 (cond (*changed-space-requirements*
778 ;; We are already within changing-space-requirements, so just
779 ;; call the body. This might however lead to surprising
780 ;; behavior in case the outer changing-space-requirements has
781 ;; resize-frame = NIL while the inner has resize-frame = T.
782 (funcall continuation))
783 (t
784 (let ((*changed-space-requirements* nil))
785 (let ((*changing-space-requirements* t))
786 (funcall continuation))
787 ;;
788 ;; Note: That 'resize-frame' and especially 'layout' are
789 ;; options to this strongly suggests that the authors of
790 ;; the clim specification may have meant that
791 ;; changing-space-requirements records space requirements
792 ;; of the *application-frame* only.
793 ;;
794 ;; We solve this by recording all frames but applying
795 ;; resize-frame and layout only to *application-frame*.
796 ;;
797 (dolist (q *changed-space-requirements*)
798 (destructuring-bind (frame pane resize-frame-2) q
799 (cond ((eq frame *application-frame*)
800 (when layout
801 (setf (frame-current-layout frame) layout))
802 (cond (resize-frame
803 (layout-frame frame))
804 (t
805 (layout-frame frame (bounding-rectangle-width pane) (bounding-rectangle-height pane)))))
806 (t
807 (cond (resize-frame-2
808 (layout-frame frame))
809 (t
810 (layout-frame frame (bounding-rectangle-width pane) (bounding-rectangle-height pane)))))))) ))))
811
812 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
813
814 ;;; BASIC PANE
815
816 (defclass basic-pane (;; layout-protocol-mixin
817 standard-space-requirement-options-mixin
818 sheet-parent-mixin mirrored-sheet-mixin
819 pane)
820 ((foreground :initarg :foreground
821 :reader pane-foreground)
822 (background :initarg :background
823 :reader pane-background)
824 (text-style :initarg :text-style
825 :reader pane-text-style)
826 (align-x :initarg :align-x
827 :type (member :left :center :right)
828 :reader pane-align-x)
829 (align-y :initarg :align-y
830 :type (member :top :center :bottom)
831 :reader pane-align-y))
832 (:default-initargs
833 :foreground +black+
834 :background *3d-normal-color*
835 :text-style *default-text-style*
836 :align-x :left
837 :align-y :top))
838
839 (defmethod initialize-instance :after ((obj basic-pane) &key text-style)
840 (when (consp text-style)
841 (setf (slot-value obj 'text-style) (apply #'make-text-style text-style))))
842
843 (defmethod engraft-medium :after (medium port (pane basic-pane))
844 (declare (ignore port))
845 ;; implements 29.2.2, last sentence.
846 (setf (medium-foreground medium) (pane-foreground pane)
847 (medium-background medium) (pane-background pane)
848 (medium-text-style medium) (pane-text-style pane)))
849
850 ;;;;
851 ;;;; Composite Panes
852 ;;;;
853
854 (defclass composite-pane (sheet-multiple-child-mixin
855 basic-pane)
856 ()
857 (:documentation "protocol class"))
858
859 (defmethod spacing-value-to-device-units (pane x)
860 (cond ((realp x) x)
861 ((consp x)
862 (ecase (cadr x)
863 (:pixels (car x))
864 (:point (* (car x) (graft-pixels-per-inch (graft pane)) 1/72))
865 (:mm (* (car x) (graft-pixels-per-millimeter (graft pane))))
866 (:character (* (car x) (text-style-character-width (pane-text-style pane)
867 (sheet-medium pane)
868 #\m)))
869 (:line (* (car x)
870 (stream-line-height pane)))))))
871
872 ;;; SINGLE-CHILD-COMPOSITE PANE
873
874 (defclass single-child-composite-pane (sheet-single-child-mixin basic-pane) ())
875
876
877 (defmethod initialize-instance :after ((pane single-child-composite-pane)
878 &rest args
879 &key contents
880 &allow-other-keys)
881 (declare (ignore args))
882 (when contents
883 (sheet-adopt-child pane (first contents))))
884
885 (defmethod compose-space ((pane single-child-composite-pane) &key width height)
886 (if (sheet-child pane)
887 (compose-space (sheet-child pane)
888 :width width :height height)
889 (make-space-requirement)))
890
891 (defmethod allocate-space ((pane single-child-composite-pane) width height)
892 (when (sheet-child pane)
893 (allocate-space (sheet-child pane) width height)))
894
895 ;;;; TOP-LEVEL-SHEET
896
897 (defclass top-level-sheet-pane (composite-pane)
898 ()
899 (:documentation "For the first pane in the architecture"))
900
901 (defun top-level-sheet-pane-p (pane)
902 (typep pane 'top-level-sheet-pane))
903
904 (defmethod change-space-requirements ((pane top-level-sheet-pane)
905 &rest space-req-keys
906 &key resize-frame &allow-other-keys)
907 (declare (ignore space-req-keys))
908 (cond (*changing-space-requirements*
909 ;; Record changed space requirements.
910 ;; What happens if we change the requirements successively
911 ;; with different values? Only the first takes effect?
912 ;; -Hefner
913 (unless (find pane *changed-space-requirements* :key #'second)
914 (push (list (pane-frame pane) pane resize-frame)
915 *changed-space-requirements*)))
916 (t
917 (let ((frame (pane-frame pane)))
918 ;; ### we miss the :resize-frame option
919 (cond (resize-frame
920 (layout-frame frame))
921 (t
922 (layout-frame frame (bounding-rectangle-width pane) (bounding-rectangle-height pane))))))))
923
924 (defmethod compose-space ((pane top-level-sheet-pane) &key width height)
925 (declare (ignore width height))
926 (compose-space (first (sheet-children pane))))
927
928 (defmethod allocate-space ((pane top-level-sheet-pane) width height)
929 (unless (pane-space-requirement pane)
930 (setf (pane-space-requirement pane)
931 (compose-space pane)))
932 (when (first (sheet-children pane))
933 (allocate-space
934 (first (sheet-children pane))
935 (clamp width (sr-min-width pane) (sr-max-width pane))
936 (clamp height (sr-min-height pane) (sr-max-height pane)))))
937
938 #+nil ; old
939 (defmethod handle-event ((pane top-level-sheet-pane)
940 (event window-configuration-event))
941 (let ((x (window-configuration-event-x event))
942 (y (window-configuration-event-y event))
943 (width (window-configuration-event-width event))
944 (height (window-configuration-event-height event)))
945 ;; avoid going into an infinite loop by not using (setf sheet-transformation)
946 (setf (slot-value pane 'transformation)
947 (make-translation-transformation x y))
948 (invalidate-cached-transformations pane)
949 ;; avoid going into an infinite loop by not using (setf sheet-region)
950 (setf (slot-value pane 'region)
951 (make-bounding-rectangle 0 0 width height))
952 (invalidate-cached-regions pane)
953 (allocate-space pane width height)))
954
955 (defmethod handle-event ((pane top-level-sheet-pane)
956 (event window-configuration-event))
957 (let ((x (window-configuration-event-x event))
958 (y (window-configuration-event-y event))
959 (width (window-configuration-event-width event))
960 (height (window-configuration-event-height event)))
961 (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) (sheet-region pane)
962 (let ((old-width (- old-x2 old-x1))
963 (old-height (- old-y2 old-y1)))
964 ;; avoid going into an infinite loop by not using (setf sheet-transformation)
965 (setf (slot-value pane 'transformation)
966 (make-translation-transformation x y))
967 (invalidate-cached-transformations pane)
968 ;; avoid going into an infinite loop by not using (setf sheet-region)
969 (setf (slot-value pane 'region)
970 (make-bounding-rectangle 0 0 width height))
971 (when (or (/= width old-width)
972 (/= height old-height))
973 (invalidate-cached-regions pane)
974 (allocate-space pane width height))))))
975
976 (defmethod handle-event ((pane top-level-sheet-pane)
977 (event window-manager-delete-event))
978 (frame-exit (pane-frame (event-sheet event))))
979
980 ;;;; UNMANAGED-TOP-LEVEL-SHEET PANE
981
982 (defclass unmanaged-top-level-sheet-pane (top-level-sheet-pane)
983 ()
984 (:documentation "Top-level sheet without window manager intervention"))
985
986 (defmethod sheet-native-transformation ((sheet top-level-sheet-pane))
987 +identity-transformation+)
988
989 (defmethod change-space-requirements ((pane unmanaged-top-level-sheet-pane)
990 &rest space-req-keys
991 &key resize-frame &allow-other-keys)
992 ;; Special variant for unmanaged-top-level-sheet-pane. Since the
993 ;; pane is unmanaged there is no window manager which can offer the
994 ;; user options to resize this top level pane.
995 ;;
996 ;; This should however be changed by turning on the :resize-frame
997 ;; option of the frame of the unmanaged-top-level-sheet-pane and
998 ;; handle it in the method on top-level-sheet.
999 ;;
1000 ;; This is currently not done, since:
1001 ;; . we obviously lack the :resize-frame option
1002 ;; . of some reason the frame of e.g. a command-menu is the
1003 ;; application-frame. I am not sure if this is totally right.
1004 ;;
1005 ;; --GB 2003-03-16
1006 (declare (ignore space-req-keys resize-frame))
1007 (let ((w (space-requirement-width (compose-space pane)))
1008 (h (space-requirement-height (compose-space pane))))
1009 (resize-sheet pane w h)
1010 (allocate-space pane w h) ))
1011
1012 ;;;; box-layout-mixin
1013
1014 ;; Now each child (client) of a box-layout pane is described by the
1015 ;; following class:
1016
1017 (defclass box-client ()
1018 ((fillp
1019 :initarg :fillp
1020 :initform nil
1021 :reader box-client-fillp
1022 :documentation "Whether this child can stretch infinitly.")
1023 (fixed-size
1024 :initarg :fixed-size
1025 :initform nil
1026 :reader box-client-fixed-size
1027 :documentation "Possible fixed size of a child.")
1028 (proportion
1029 :initarg :proportion
1030 :initform nil
1031 :reader box-client-proportion
1032 :documentation "Proportion child should get of excess space.")
1033 (pane
1034 :initarg :pane
1035 :reader box-client-pane
1036 :documentation "Either the child pane or NIL.")))
1037
1038 (defclass box-layout-mixin ()
1039 ((box-layout-orientation
1040 :initarg :box-layout-orientation
1041 :initform :vertical
1042 :type (member :vertical :horizontal)
1043 :accessor box-layout-orientation)
1044 (clients
1045 :accessor box-layout-mixin-clients
1046 :initform nil) )
1047 (:documentation
1048 "Mixin class for layout panes, which want to behave like a HBOX/VBOX."))
1049
1050 ;; First we need to make sure that the list of clients and the list of
1051 ;; children agree with each other.
1052
1053 (defmethod sheet-adopt-child :after ((sheet box-layout-mixin) child)
1054 ;; When the child is already known in the client list we add no new
1055 ;; client object.
1056 (unless (find child (box-layout-mixin-clients sheet) :key #'box-client-pane)
1057 (setf (box-layout-mixin-clients sheet)
1058 (append (box-layout-mixin-clients sheet)
1059 (list (make-instance 'box-client
1060 :pane child))))
1061 (when (and (sheet-enabled-p sheet)
1062 (sheet-parent sheet))
1063 (change-space-requirements sheet))))
1064
1065 (defmethod sheet-disown-child :after ((sheet box-layout-mixin) (child sheet) &key errorp)
1066 (declare (ignore errorp))
1067 (setf (box-layout-mixin-clients sheet)
1068 (remove-if (lambda (client)
1069 (eq (box-client-pane client) child))
1070 (box-layout-mixin-clients sheet)))
1071 (when (and (sheet-enabled-p sheet)
1072 (sheet-parent sheet))
1073 (change-space-requirements sheet)))
1074
1075
1076 (defclass rack-layout-mixin (box-layout-mixin)
1077 ((box-layout-orientation
1078 :initarg :box-layout-orientation
1079 :initform :vertical
1080 :type (member :vertical :horizontal)
1081 :accessor box-layout-orientation))
1082 (:documentation
1083 "Mixin class for layout panes, which want to behave like a HRACK/VRACK."))
1084
1085 (defmethod compose-space ((pane box-layout-mixin) &key width height)
1086 (declare (ignore width height))
1087 (if (eq (box-layout-orientation pane) :vertical)
1088 (box-layout-mixin/vertically-compose-space pane)
1089 (box-layout-mixin/horizontally-compose-space pane)))
1090
1091 (defmethod allocate-space ((pane box-layout-mixin) width height)
1092 (if (eq (box-layout-orientation pane) :vertical)
1093 (box-layout-mixin/vertically-allocate-space pane width height)
1094 (box-layout-mixin/horizontally-allocate-space pane width height)))
1095
1096 (defvar *dump-allocate-space* nil)
1097
1098 (dada
1099 ((major width height)
1100 (minor height width)
1101 (xbox hbox vbox)
1102 (xrack hrack vrack)
1103 (xically horizontally vertically)
1104 (major-spacing x-spacing y-spacing)
1105 (minor-spacing x-spacing y-spacing) )
1106
1107 (defmethod xically-content-sr** ((pane box-layout-mixin) client)
1108 (let (p)
1109 (let ((sr (if (box-client-pane client)
1110 (compose-space (box-client-pane client))
1111 (make-space-requirement :width 0 :min-width 0 :max-width 0
1112 :height 0 :min-height 0 :max-height 0))))
1113 (cond ((box-client-fillp client)
1114 (make-space-requirement
1115 :major (space-requirement-major sr)
1116 :min-major (space-requirement-min-major sr)
1117 :max-major +fill+
1118 :minor (space-requirement-minor sr)
1119 :min-minor (space-requirement-min-minor sr)
1120 :max-minor (space-requirement-max-minor sr)))
1121 ((setq p (box-client-fixed-size client))
1122 (make-space-requirement
1123 :major p
1124 :min-major p
1125 :max-major p
1126 :minor (if sr (space-requirement-minor sr) 0)
1127 :min-minor (if sr (space-requirement-min-minor sr) 0)
1128 :max-minor (if sr (space-requirement-max-minor sr) 0)))
1129 (t
1130 sr) ))))
1131
1132 (defmethod xically-content-sr*** ((pane box-layout-mixin) client major)
1133 (let (p)
1134 (let ((sr (if (box-client-pane client)
1135 (compose-space (box-client-pane client))
1136 (make-space-requirement :width 0 :min-width 0 :max-width 0
1137 :height 0 :min-height 0 :max-height 0))))
1138 (cond ((box-client-fillp client)
1139 (make-space-requirement
1140 :major (space-requirement-major sr)
1141 :min-major (space-requirement-min-major sr)
1142 :max-major +fill+
1143 :minor (space-requirement-minor sr)
1144 :min-minor (space-requirement-min-minor sr)
1145 :max-minor (space-requirement-max-minor sr)))
1146 ((setq p (box-client-fixed-size client))
1147 (make-space-requirement
1148 :major p
1149 :min-major p
1150 :max-major p
1151 :minor (if sr (space-requirement-minor sr) 0)
1152 :min-minor (if sr (space-requirement-min-minor sr) 0)
1153 :max-minor (if sr (space-requirement-max-minor sr) 0)))
1154 ((setq p (box-client-proportion client))
1155 (make-space-requirement
1156 :major (clamp (* p major)
1157 (space-requirement-min-major sr)
1158 (space-requirement-max-major sr))
1159 :min-major (space-requirement-min-major sr)
1160 :max-major (space-requirement-max-major sr)
1161 :minor (if sr (space-requirement-minor sr) 0)
1162 :min-minor (if sr (space-requirement-min-minor sr) 0)
1163 :max-minor (if sr (space-requirement-max-minor sr) 0)))
1164 (t
1165 sr) ))))
1166
1167 (defmethod box-layout-mixin/xically-compose-space ((pane box-layout-mixin))
1168 (let ((n (length (sheet-enabled-children pane))))
1169 (with-slots (major-spacing) pane
1170 (loop
1171 for client in (box-layout-mixin-clients pane)
1172 for sr = (xically-content-sr** pane client)
1173 sum (space-requirement-major sr) into major
1174 sum (space-requirement-min-major sr) into min-major
1175 sum (space-requirement-max-major sr) into max-major
1176 maximize (space-requirement-minor sr) into minor
1177 maximize (space-requirement-min-minor sr) into min-minor
1178 minimize (space-requirement-max-minor sr) into max-minor
1179 finally
1180 (return
1181 (space-requirement+*
1182 (make-space-requirement
1183 :major major
1184 :min-major (min min-major major)
1185 :max-major (max max-major major)
1186 :minor minor
1187 :min-minor (min min-minor minor)
1188 :max-minor (max max-minor minor))
1189 :min-major (* (1- n) major-spacing)
1190 :max-major (* (1- n) major-spacing)
1191 :major (* (1- n) major-spacing)
1192 :min-minor 0
1193 :max-minor 0
1194 :minor 0))))))
1195
1196 (defmethod box-layout-mixin/xically-allocate-space-aux* ((box box-layout-mixin) width height)
1197 (declare (ignorable width height))
1198 (let ((children (reverse (sheet-enabled-children box))))
1199 (with-slots (major-spacing) box
1200 (let* ((content-srs (mapcar #'(lambda (c) (xically-content-sr*** box c major))
1201 (box-layout-mixin-clients box)))
1202 (allot (mapcar #'ceiling (mapcar #'space-requirement-major content-srs)))
1203 (wanted (reduce #'+ allot))
1204 (excess (- major wanted
1205 (* (1- (length children)) major-spacing))))
1206 (when *dump-allocate-space*
1207 (format *trace-output* "~&;; ~S ~S~%"
1208 'box-layout-mixin/xically-allocate-space-aux* box)
1209 (format *trace-output* "~&;; major = ~D, wanted = ~D, excess = ~D, allot = ~D.~%"
1210 major wanted excess allot))
1211
1212 (let ((qvector
1213 (mapcar
1214 (lambda (c)
1215 (cond
1216 ((box-client-fillp c)
1217 (vector 1 0 0))
1218 (t
1219 (vector 0 0
1220 (abs (- (if (> excess 0)
1221 (space-requirement-max-major (xically-content-sr*** box c major))
1222 (space-requirement-min-major (xically-content-sr*** box c major)))
1223 (space-requirement-major (xically-content-sr*** box c major))))))))
1224 (box-layout-mixin-clients box))))
1225 ;;
1226 (when *dump-allocate-space*
1227 (format *trace-output* "~&;; old allotment = ~S.~%" allot)
1228 (format *trace-output* "~&;; qvector = ~S.~%" qvector)
1229 (format *trace-output* "~&;; qvector 0 = ~S.~%" (mapcar #'(lambda (x) (elt x 0)) qvector))
1230 (format *trace-output* "~&;; qvector 1 = ~S.~%" (mapcar #'(lambda (x) (elt x 1)) qvector))
1231 (format *trace-output* "~&;; qvector 2 = ~S.~%" (mapcar #'(lambda (x) (elt x 2)) qvector)))
1232 ;;
1233 (dotimes (j 3)
1234 (let ((sum (reduce #'+ (mapcar (lambda (x) (elt x j)) qvector))))
1235 (unless (zerop sum)
1236 (setf allot
1237 (mapcar (lambda (allot q)
1238 (let ((q (elt q j)))
1239 (let ((delta (ceiling (if (zerop sum) 0 (/ (* excess q) sum)))))
1240 (decf excess delta)
1241 (decf sum q)
1242 (+ allot delta))))
1243 allot qvector))
1244 (when *dump-allocate-space*
1245 (format *trace-output* "~&;; new excess = ~F, allotment = ~S.~%" excess allot)) )))
1246 ;;
1247 (when *dump-allocate-space*
1248 (format *trace-output* "~&;; excess = ~F.~%" excess)
1249 (format *trace-output* "~&;; new allotment = ~S.~%" allot))
1250
1251 (values allot
1252 (mapcar #'ceiling (mapcar #'space-requirement-minor content-srs))) )))))
1253
1254 (defmethod box-layout-mixin/xically-allocate-space-aux* :around ((box rack-layout-mixin) width height)
1255 (declare (ignorable width height))
1256 (multiple-value-bind (majors minors) (call-next-method)
1257 (values majors
1258 (mapcar (lambda (x) x minor) minors))))
1259
1260 ;; Now actually layout the children
1261 ;;
1262 ;; A rack pane would force the minor dimension of the child. A
1263 ;; box pane would just align the child according to the
1264 ;; alignment option. We do the same with the minor dimension.
1265 ;;
1266
1267 (defmethod box-layout-mixin/xically-allocate-space ((pane box-layout-mixin) real-width real-height)
1268 (with-slots (major-spacing) pane
1269 (multiple-value-bind (majors minors)
1270 (box-layout-mixin/xically-allocate-space-aux* pane real-width real-height)
1271 (let ((x 0))
1272 (loop
1273 for child in (box-layout-mixin-clients pane)
1274 for major in majors
1275 for minor in minors
1276 do
1277 (when (box-client-pane child)
1278 #+NIL
1279 (format *trace-output* "~&;; child ~S at 0, ~D ~D x ~D(~D)~%;; ~S~%"
1280 (box-client-pane child)
1281 x width height real-height
1282 (compose-space (box-client-pane child)))
1283 (layout-child (box-client-pane child)
1284 (pane-align-x (box-client-pane child))
1285 (pane-align-y (box-client-pane child))
1286 ((lambda (major minor) height width) x 0)
1287 ((lambda (major minor) width height) x 0)
1288 ((lambda (major minor) height width) width real-width)
1289 ((lambda (major minor) height width) real-height height) ))
1290 (incf x major)
1291 (incf x major-spacing))))))
1292
1293 (defmethod box-layout-mixin/xically-allocate-space ((pane rack-layout-mixin) real-width real-height)
1294 (with-slots (major-spacing) pane
1295 (multiple-value-bind (majors minors)
1296 (box-layout-mixin/xically-allocate-space-aux* pane real-width real-height)
1297 (let ((x 0))
1298 (loop
1299 for child in (box-layout-mixin-clients pane)
1300 for major in majors
1301 for minor in minors
1302 do
1303 (when (box-client-pane child)
1304 #+NIL
1305 (format *trace-output* "~&;; child ~S at 0, ~D ~D x ~D(~D)~%;; ~S~%"
1306 (box-client-pane child)
1307 x width height real-height
1308 (compose-space (box-client-pane child)))
1309 (layout-child (box-client-pane child)
1310 :expand
1311 :expand
1312 ((lambda (major minor) height width) x 0)
1313 ((lambda (major minor) width height) x 0)
1314 ((lambda (major minor) height width) width real-width)
1315 ((lambda (major minor) height width) real-height height) ))
1316 (incf x major)
1317 (incf x major-spacing)))))))
1318
1319 ;; #+nil
1320 (defmethod note-sheet-enabled :before ((pane pane))
1321 ;; hmmm
1322 (when (panep (sheet-parent pane))
1323 (change-space-requirements pane)) )
1324
1325 ;; #+nil
1326 (defmethod note-sheet-disabled :before ((pane pane))
1327 ;; hmmm
1328 (when (panep (sheet-parent pane))
1329 (change-space-requirements pane)) )
1330
1331 (defmethod reorder-sheets :after ((pane box-layout-mixin) new-order)
1332 ;; Bring the order of the clients in sync with the new order of the
1333 ;; children.
1334 (setf new-order (reverse new-order))
1335 (let ((new-bcs
1336 (loop for bc in (box-layout-mixin-clients pane)
1337 collect
1338 (cond ((box-client-pane bc)
1339 (find (pop new-order) (box-layout-mixin-clients pane) :key #'box-client-pane))
1340 (t
1341 bc)))))
1342 (assert (null (set-difference new-bcs (box-layout-mixin-clients pane))))
1343 (setf (box-layout-mixin-clients pane) new-bcs))
1344 ;; finally do a re-layout.
1345 (change-space-requirements pane) )
1346
1347 ;;;;
1348
1349 (eval-when (:compile-toplevel :load-toplevel :execute)
1350 (defun make-box-macro-contents (contents)
1351 (loop
1352 for content in contents
1353 collect (if (and (consp content)
1354 (or (realp (car content))
1355 (member (car content) '(+fill+ :fill))))
1356 `(list ',(car content) ,(cadr content))
1357 content))))
1358
1359 (macrolet ((frob (macro-name box rack equalize-arg equalize-key)
1360 (let ((equalize-key (make-keyword equalize-arg)))
1361 `(defmacro ,macro-name ((&rest options
1362 &key (,equalize-arg t)
1363 &allow-other-keys)
1364 &body contents)
1365 (with-keywords-removed (options (,equalize-key))
1366 `(make-pane (if ,,equalize-arg
1367 ',',rack
1368 ',',box)
1369 ,@options
1370 :contents (list ,@(make-box-macro-contents
1371 contents))))))))
1372 (frob horizontally hbox-pane hrack-pane equalize-height :equalize-height)
1373 (frob vertically vbox-pane vrack-pane equalize-width :equalize-width))
1374
1375 (defclass box-pane (box-layout-mixin
1376 composite-pane
1377 permanent-medium-sheet-output-mixin ;arg!
1378 )
1379 ()
1380 (:documentation "Superclass for hbox-pane and vbox-pane that provides the
1381 initialization common to both."))
1382
1383 (defmethod initialize-instance :after ((pane box-pane) &key contents)
1384 (labels ((parse-box-content (content)
1385 "Parses a box/rack content and returns a BOX-CLIENT instance."
1386 ;; ### we need to parse more
1387 (cond
1388 ;; <pane>
1389 ((panep content)
1390 (make-instance 'box-client :pane content))
1391 ;; +fill+
1392 ((or (eql content +fill+)
1393 (eql content '+fill+)
1394 (eql content :fill))
1395 (make-instance 'box-client
1396 :pane nil
1397 :fillp t))
1398 ;; (+fill+ <pane>)
1399 ((and (consp content)
1400 (or (member (car content) '(+fill+ :fill))
1401 (eql (car content) +fill+)))
1402 (make-instance 'box-client
1403 :pane (cadr content)
1404 :fillp t))
1405 ;; <n>
1406 ;;
1407 ;; what about something like (30 :mm) ?
1408 ;;
1409 ((and (realp content) (>= content 0))
1410 (make-instance 'box-client
1411 :pane nil
1412 :fixed-size content))
1413
1414 ;; (<n> pane)
1415 ((and (consp content)
1416 (realp (car content))
1417 (>= (car content) 0)
1418 (consp (cdr content))
1419 (panep (cadr content))
1420 (null (cddr content)))
1421 (let ((number (car content))
1422 (child (cadr content)))
1423 (if (< number 1)
1424 (make-instance 'box-client
1425 :pane child
1426 :proportion number)
1427 (make-instance 'box-client
1428 :pane child
1429 :fixed-size number))))
1430
1431 (t
1432 (error "~S is not a valid element in the ~S option of ~S."
1433 content :contents pane)) )))
1434
1435 (let* ((clients (mapcar #'parse-box-content contents))
1436 (children (remove nil (mapcar #'box-client-pane clients))))
1437 ;;
1438 (setf (box-layout-mixin-clients pane) clients)
1439 (mapc (curry #'sheet-adopt-child pane) children))))
1440
1441 (defclass hbox-pane (box-pane)
1442 ()
1443 (:default-initargs :box-layout-orientation :horizontal))
1444
1445 (defclass vbox-pane (box-pane)
1446 ()
1447 (:default-initargs :box-layout-orientation :vertical))
1448
1449 (defclass hrack-pane (rack-layout-mixin hbox-pane)
1450 ()
1451 (:default-initargs :box-layout-orientation :horizontal))
1452
1453 (defclass vrack-pane (rack-layout-mixin vbox-pane)
1454 ()
1455 (:default-initargs :box-layout-orientation :vertical))
1456
1457 ;;; TABLE PANE
1458
1459 ;; TODO: The table and grid panes should respect the :x-spacing,
1460 ;; :y-spacing, and :spacing initargs.
1461
1462 (defclass table-pane (composite-pane)
1463 ((array
1464 :documentation "Two-dimensional array holding the child panes as they are to be arranged."))
1465 ;;
1466 (:documentation
1467 "The table layout implies that each colums has the same width
1468 and each lines has the same height - same rules for max and min -") )
1469
1470 (defmethod initialize-instance :after ((pane table-pane) &key contents &allow-other-keys)
1471 ;; check the format: contents should be list of lists of panes
1472 (unless (and (listp contents)
1473 (every (lambda (x)
1474 (and (listp x)
1475 (every #'panep x)))
1476 contents))
1477 (error "~S option to ~S has bad format; should be a list of lists of panes.~%But its value is ~S."
1478 :contents pane contents))
1479 ;; shovel child panes into the array and adopt them
1480 (let ((nrows (length contents))
1481 (ncols (reduce #'max (mapcar #'length contents)
1482 :initial-value 0)))
1483 (with-slots (array) pane
1484 (setf array (make-array (list nrows ncols)
1485 :initial-element nil))
1486 (loop for row in contents
1487 for i from 0 do
1488 (loop for cell in row
1489 for j from 0 do
1490 (setf (aref array i j) cell)
1491 (sheet-adopt-child pane cell))))))
1492
1493 (dada ((xically horizontally vertically)
1494 (major width height)
1495 (minor height width))
1496 ;;
1497 (defun stack-space-requirements-xically (srs)
1498 (loop
1499 for sr in srs
1500 sum (space-requirement-major sr) into major
1501 sum (space-requirement-min-major sr) into min-major
1502 sum (space-requirement-max-major sr) into max-major
1503 maximize (space-requirement-minor sr) into minor
1504 maximize (space-requirement-min-minor sr) into min-minor
1505 minimize (space-requirement-max-minor sr) into max-minor
1506 finally
1507 (return
1508 (make-space-requirement
1509 :major major
1510 :min-major (min min-major major)
1511 :max-major (max max-major major)
1512 :minor minor
1513 :min-minor (min min-minor minor)
1514 :max-minor (max max-minor minor)))))
1515
1516 (defun allot-space-xically (srs major)
1517 (let* ((allot (mapcar #'space-requirement-major srs))
1518 (wanted (reduce #'+ allot))
1519 (excess (- major wanted))
1520 (qs
1521 (mapcar (lambda (sr)
1522 (abs (- (if (> excess 0)
1523 (space-requirement-max-major sr)
1524 (space-requirement-min-major sr))
1525 (space-requirement-major sr))))
1526 srs)))
1527 #+nil
1528 (format t "~&;; ~S: allot=~S, wanted=~S, excess=~S, qs=~S~%"
1529 'allot-space-xically allot wanted excess qs)
1530 (let ((sum (reduce #'+ qs)))
1531 (cond ((zerop sum)
1532 (let ((n (length qs)))
1533 (setf allot
1534 (mapcar (lambda (allot q)
1535 (let ((delta (floor excess n)))
1536 (decf n)
1537 (decf excess delta)
1538 (decf sum q)
1539 (+ allot delta)))
1540 allot qs))))
1541 (t
1542 (setf allot
1543 (mapcar (lambda (allot q)
1544 (let ((delta (ceiling (if (zerop sum) 0 (/ (* excess q) sum)))))
1545 (decf excess delta)
1546 (decf sum q)
1547 (+ allot delta)))
1548 allot qs)))))
1549 allot)) )
1550
1551 (defmethod table-pane-row-space-requirement ((pane table-pane) i)
1552 (with-slots (array) pane
1553 (stack-space-requirements-horizontally
1554 (loop for j from 0 below (array-dimension array 1)
1555 collect (compose-space (aref array i j))))))
1556
1557 (defmethod table-pane-col-space-requirement ((pane table-pane) j)
1558 (with-slots (array) pane
1559 (stack-space-requirements-vertically
1560 (loop for i from 0 below (array-dimension array 0)
1561 collect (compose-space (aref array i j))))))
1562
1563 (defmethod compose-space ((pane table-pane) &key width height)
1564 (declare (ignore width height))
1565 (with-slots (array x-spacing y-spacing) pane
1566 ; ---v our problem is here.
1567 ; Which problem? --GB
1568 (let ((rsrs (loop for i from 0 below (array-dimension array 0)
1569 collect (table-pane-row-space-requirement pane i)))
1570 (csrs (loop for j from 0 below (array-dimension array 1)
1571 collect (table-pane-col-space-requirement pane j)))
1572 (xs (* x-spacing (1- (array-dimension array 1))))
1573 (ys (* y-spacing (1- (array-dimension array 0)))))
1574 (let ((r (stack-space-requirements-vertically rsrs))
1575 (c (stack-space-requirements-horizontally csrs)))
1576 (let ((res
1577 (make-space-requirement
1578 :width (+ (space-requirement-width r) xs)
1579 :min-width (+ (space-requirement-min-width r) xs)
1580 :max-width (+ (space-requirement-max-width r) xs)
1581 :height (+ (space-requirement-height c) ys)
1582 :min-height (+ (space-requirement-min-height c) ys)
1583 :max-height (+ (space-requirement-max-height c) ys))))
1584 #+nil
1585 (format *trace-output* "~%;;; TABLE-PANE sr = ~S." res)
1586 res)))))
1587
1588 (defmethod allocate-space ((pane table-pane) width height)
1589 (let (rsrs csrs)
1590 (declare (ignorable rsrs csrs))
1591 (with-slots (array x-spacing y-spacing) pane
1592 ;; allot rows
1593 (let* ((xs (* x-spacing (1- (array-dimension array 1))))
1594 (ys (* y-spacing (1- (array-dimension array 0))))
1595 (rows (allot-space-vertically
1596 (setq rsrs (loop for i from 0 below (array-dimension array 0)
1597 collect (table-pane-row-space-requirement pane i)))
1598 (- height ys)))
1599 (cols (allot-space-horizontally
1600 (setq csrs (loop for j from 0 below (array-dimension array 1)
1601 collect (table-pane-col-space-requirement pane j)))
1602 (- width xs))))
1603 #+nil
1604 (progn
1605 (format t "~&;; row space requirements = ~S." rsrs)
1606 (format t "~&;; col space requirements = ~S." csrs)
1607 (format t "~&;; row allotment: needed = ~S result = ~S (sum ~S)." height rows (reduce #'+ rows))
1608 (format t "~&;; col allotment: needed = ~S result = ~S (sum ~S)." width cols (reduce #'+ cols))
1609 (format t "~&;; align-x = ~S, align-y ~S~%"
1610 (pane-align-x pane)
1611 (pane-align-y pane)))
1612 ;; now finally layout each child
1613 (loop
1614 for y = 0 then (+ y h y-spacing)
1615 for h in rows
1616 for i from 0
1617 do (loop
1618 for x = 0 then (+ x w x-spacing)
1619 for w in cols
1620 for j from 0
1621 do (let ((child (aref array i j)))
1622 (layout-child child
1623 (pane-align-x child)
1624 (pane-align-y child)
1625 x y w h))))))))
1626
1627 (defun table-pane-p (pane)
1628 (typep pane 'table-pane))
1629
1630 (defmacro tabling ((&rest options &key (grid nil) &allow-other-keys) &body contents)
1631 (if grid
1632 `(make-pane 'grid-pane ,@options :contents (list ,@contents))
1633 `(make-pane 'table-pane ,@options :contents (list ,@contents))))
1634
1635
1636
1637 ;(defmethod sheet-adopt-child :before ((table table-pane) child)
1638 ; (declare (ignore child))
1639 ; (when (= (length (sheet-children table)) (table-pane-number table))
1640 ; (error "The table can't adopt more childs than specified by the table-number")))
1641
1642 (defmethod sheet-disowned-child :before ((table table-pane) child
1643 &key (error-p t))
1644 (declare (ignore child error-p))
1645 (error "The table pane can't disown one of its child"))
1646
1647
1648 ;;; GRID PANE
1649
1650 (defclass grid-pane (table-pane)
1651 ()
1652 (:documentation
1653 "Be careful : each cells has the same size in the two dimentions.
1654 In other words : if the cell sizes are width, height then
1655 width = grid-width / number of children per line
1656 height = grid-height / number of children per column.
1657 =====> this is for all cells."))
1658
1659 (defun grid-p (pane)
1660 (typep pane 'grid-pane))
1661
1662 (defmethod compose-space ((grid grid-pane) &key width height)
1663 (declare (ignore width height))
1664 (mapc #'compose-space (sheet-children grid))
1665 (with-slots (array) grid
1666 (loop with nb-children-pl = (array-dimension array 1) ;(table-pane-number grid)
1667 with nb-children-pc = (array-dimension array 0) ;(/ (length (sheet-children grid)) nb-children-pl)
1668 for child in (sheet-children grid)
1669 and width = 0 then (max width (sr-width child))
1670 and height = 0 then (max height (sr-height child))
1671 and max-width = 5000000 then (min max-width (sr-min-width child))
1672 and max-height = 5000000 then (min max-height (sr-max-height child))
1673 and min-width = 0 then (max min-width (sr-min-width child))
1674 and min-height = 0 then (max min-height (sr-min-height child))
1675 finally (return
1676 (make-space-requirement
1677 :width (* width nb-children-pl)
1678 :height (* height nb-children-pc)
1679 :max-width (* width nb-children-pl)
1680 :max-height (* max-height nb-children-pc)
1681 :min-width (* min-width nb-children-pl)
1682 :min-height (* min-height nb-children-pc))))))
1683
1684 (defmethod allocate-space ((grid grid-pane) width height)
1685 (with-slots (array) grid
1686 (loop with nb-kids-p-l = (array-dimension array 1) ;(table-pane-number grid)
1687 with nb-kids-p-c = (array-dimension array 0) ;(/ (length (sheet-children grid)) nb-kids-p-l)
1688 for c from nb-kids-p-c downto 1
1689 for row-index from 0 by 1
1690 for tmp-height = height then (decf tmp-height new-height)
1691 for new-height = (/ tmp-height c)
1692 for y = 0 then (+ y new-height)
1693 do (loop
1694 for col-index from 0 by 1
1695 for l from nb-kids-p-l downto 1
1696 for child = (aref array row-index col-index)
1697 for tmp-width = width then (decf tmp-width new-width)
1698 for new-width = (/ tmp-width l)
1699 for x = 0 then (+ x new-width)
1700 do (move-sheet child x y)
1701 (allocate-space child (round new-width) (round new-height))))))
1702
1703 ;;; SPACING PANE
1704
1705 (defclass spacing-pane (;;standard-space-requirement-options-mixin
1706 single-child-composite-pane
1707 permanent-medium-sheet-output-mixin)
1708 ((border-width :initarg :thickness
1709 :initform 1))
1710 (:documentation "Never trust a random documentation string."))
1711
1712 (defmacro spacing ((&rest options) &body contents)
1713 `(make-pane 'spacing-pane ,@options :contents (list ,@contents)))
1714
1715 (defun spacing-p (pane)
1716 (typep pane 'spacing-pane))
1717
1718 (defmethod initialize-instance :after ((spacing spacing-pane) &key thickness contents &allow-other-keys)
1719 (declare (ignorable thickness contents))
1720 (with-slots (user-width user-min-width user-max-width
1721 user-height user-min-height user-max-height)
1722 spacing
1723 #+nil(setf user-width (max (or thickness 0) (or user-width 0)))
1724 #+nil(setf user-height (max (or thickness 0) (or user-height 0)))))
1725
1726 (defmethod compose-space ((pane spacing-pane) &key width height)
1727 (declare (ignore width height))
1728 (with-slots (border-width) pane
1729 (let ((sr (call-next-method)))
1730 (make-space-requirement
1731 :width (+ (* 2 border-width) (space-requirement-width sr))
1732 :height (+ (* 2 border-width) (space-requirement-height sr))
1733 :min-width (+ (* 2 border-width) (space-requirement-min-width sr))
1734 :min-height (+ (* 2 border-width) (space-requirement-min-height sr))
1735 :max-width (+ (* 2 border-width) (space-requirement-max-width sr))
1736 :max-height (+ (* 2 border-width) (space-requirement-max-height sr))))))
1737
1738 (defmethod allocate-space ((pane spacing-pane) width height)
1739 (with-slots (border-width) pane
1740 (let ((child (first (sheet-children pane)))
1741 (new-width (- width border-width border-width))
1742 (new-height (- height border-width border-width)))
1743 (layout-child child (pane-align-x pane) (pane-align-y pane)
1744 border-width border-width
1745 new-width new-height))))
1746
1747 ;;; OUTLINED PANE
1748
1749 ;; same as SPACING-PANE but a different default background.
1750
1751 (defclass outlined-pane (spacing-pane)
1752 ()
1753 (:default-initargs :background +black+))
1754
1755 (defmacro outlining ((&rest options) &body contents)
1756 `(make-pane 'outlined-pane ,@options :contents (list ,@contents)))
1757
1758 ;;; BORDER PANE
1759
1760 ;; same as outlined-pane, but thickness is now called border-width.
1761
1762 (defclass border-pane (outlined-pane)
1763 ((border-width :initarg :border-width
1764 :initform 1
1765 :reader border-pane-width))
1766 (:documentation ""))
1767
1768 (defmacro bordering ((&rest options) &body contents)
1769 `(make-pane 'border-pane ,@options :contents (list ,@contents)))
1770
1771 (defmethod pane-border ((pane basic-pane))
1772 (let ((parent (sheet-parent pane)))
1773 (when (and parent (typep parent 'border-pane))
1774 parent)))
1775
1776 ;;; RAISED PANE
1777
1778 (defclass raised-pane (border-pane permanent-medium-sheet-output-mixin)
1779 ()
1780 (:default-initargs
1781 :border-width 2))
1782
1783 (defmacro raising ((&rest options) &body contents)
1784 `(make-pane 'raised-pane ,@options :contents (list ,@contents)))
1785
1786 (defmethod handle-repaint ((pane raised-pane) region)
1787 (declare (ignore region))
1788 (with-slots (border-width) pane
1789 (multiple-value-call #'draw-bordered-rectangle* pane (bounding-rectangle* (sheet-region pane))
1790 :style :outset
1791 :border-width border-width)))
1792
1793 ;;; LOWERED PANE
1794
1795 (defclass lowered-pane (border-pane permanent-medium-sheet-output-mixin)
1796 ()
1797 (:default-initargs
1798 :border-width 2))
1799
1800 (defmacro lowering ((&rest options) &body contents)
1801 `(make-pane 'lowered-pane ,@options :contents (list ,@contents)))
1802
1803 (defmethod handle-repaint ((pane lowered-pane) region)
1804 (declare (ignore region))
1805 (with-slots (border-width) pane
1806 (multiple-value-call #'draw-bordered-rectangle* pane (bounding-rectangle* (sheet-region pane))
1807 :style :inset
1808 :border-width border-width)))
1809
1810 ;;; RESTRAINING PANE
1811
1812 (defclass restraining-pane (single-child-composite-pane) ())
1813
1814 (defun restraining-pane-p (pane)
1815 (typep pane 'restraining-pane))
1816
1817 (defmacro restraining ((&rest options) &body contents)
1818 `(make-pane 'restraining-pane ,@options :contents (list ,@contents)))
1819
1820 (defmethod note-space-requirements-changed ((pane restraining-pane) child)
1821 (declare (ignore pane child)))
1822
1823 ;;; BBOARD PANE
1824
1825 (defclass bboard-pane (composite-pane) ())
1826
1827 (defmethod compose-space ((bboard bboard-pane) &key width height)
1828 (declare (ignore width height))
1829 (make-space-requirement :width 300 :height 300))
1830
1831 ;;; VIEWPORT
1832
1833 (defclass viewport-pane (single-child-composite-pane) ())
1834
1835 (defmethod compose-space ((pane viewport-pane) &key width height)
1836 (declare (ignorable width height))
1837 ;; I _think_ this is right, it certainly shouldn't be the
1838 ;; requirements of the child, apart from the max sizes. If the child
1839 ;; does not want to go bigger than a specific size, we should not
1840 ;; force it to do so.
1841 (let ((child-sr (compose-space (first (sheet-children pane)))))
1842 (if child-sr
1843 (make-space-requirement :max-width (space-requirement-max-width child-sr)
1844 :max-height (space-requirement-max-height child-sr))
1845 (make-space-requirement))))
1846
1847 (defmethod allocate-space ((pane viewport-pane) width height)
1848 (with-slots (hscrollbar vscrollbar) (sheet-parent pane)
1849 (let* ((child (sheet-child pane))
1850 (child-space (compose-space child))
1851 (child-width (space-requirement-width child-space))
1852 (child-min-width (space-requirement-min-width child-space))
1853 (child-height (space-requirement-height child-space))
1854 (child-min-height (space-requirement-min-height child-space)))
1855 (move-and-resize-sheet child
1856 (if hscrollbar (- (gadget-value hscrollbar)) 0)
1857 (if vscrollbar (- (gadget-value vscrollbar)) 0)
1858 (max child-width width)
1859 (max child-height height))
1860 ; move-and-resize-sheet does not allocate space for the sheet...
1861 ; so we do it manually for this case, which may be wrong - CHECKME
1862 ; if this is the right place, reusing the above calculation might be a good idea
1863 (allocate-space child
1864 (max child-min-width child-width width)
1865 (max child-min-height child-height height)))))
1866
1867 (defmethod note-input-focus-changed ((pane viewport-pane) state)
1868 (note-input-focus-changed (sheet-child pane) state))
1869
1870 ;; This method ensures that when the child changes size, the viewport
1871 ;; will move its focus so that it will not display a region outside of
1872 ;; `child' (if at all possible, this ideal can be circumvented by
1873 ;; creating a child sheet that is smaller than the viewport). I do not
1874 ;; believe having a viewport look at "empty" space is ever useful.
1875 (defmethod note-space-requirements-changed ((pane viewport-pane) child)
1876 (let ((viewport-width (bounding-rectangle-width pane))
1877 (viewport-height (bounding-rectangle-height pane))
1878 (child-width (bounding-rectangle-width child))
1879 (child-height (bounding-rectangle-height child)))
1880 (destructuring-bind (horizontal-scroll vertical-scroll)
1881 (mapcar #'- (multiple-value-list
1882 (transform-position (sheet-transformation child) 0 0)))
1883 ;; XXX: We cannot use `scroll-extent', because McCLIM ignores it
1884 ;; unless the scrollee happens to be drawing. Very weird, should
1885 ;; be fixed.
1886
1887 ;; It's not a bug, it's a feature. This requires further thought. -Hefner
1888 (move-sheet child
1889 (round (- (if (> (+ horizontal-scroll viewport-width)
1890 child-width)
1891 (- child-width viewport-width)
1892 horizontal-scroll)))
1893 (round (- (if (> (+ vertical-scroll viewport-height)
1894 child-height)
1895 (- child-height viewport-height)
1896 vertical-scroll))))
1897 (scroller-pane/update-scroll-bars (sheet-parent pane))
1898 #+NIL
1899 (scroll-extent child
1900 (if (> (+ horizontal-scroll viewport-width)
1901 child-width)
1902 (max 0 (- child-width viewport-width))
1903 horizontal-scroll)
1904 (if (> (+ vertical-scroll viewport-height)
1905 child-height)
1906 (max 0 (- child-height viewport-height))
1907 vertical-scroll)))))
1908
1909 ;;;;
1910 ;;;; SCROLLER PANE
1911 ;;;;
1912
1913 ;;; How scrolling is done
1914
1915 ;; The scroll-pane has a child window called the 'viewport', which
1916 ;; itself has the scrolled client pane as child. To scroll the client
1917 ;; pane is to move it [to possibly negative coordinates].
1918 ;;
1919 ;; So the viewport is just a kind of hole, where some part of the
1920 ;; scrolled window shows through.
1921 ;;
1922
1923 ;;; How the scroll bars are set up
1924
1925 ;; The scroll-bar's min/max values match the min/max arguments to
1926 ;; scroll-extent. The thumb-size is then calculated accordingly.
1927
1928 ;;
1929
1930 (defparameter *scrollbar-thickness* 17)
1931
1932 (defvar clim-extensions:*default-vertical-scroll-bar-position*
1933 :right
1934 "Default for the :VERTICAL-SCROLL-BAR-POSITION init arg of a
1935 SCROLLER-PANE. Set it to :LEFT to have the vertical scroll bar of a
1936 SCROLLER-PANE appear on the ergonomic left hand side, or leave set to
1937 :RIGHT to have it on the distant right hand side of the scroller.")
1938
1939 (defclass scroller-pane (composite-pane)
1940 ((scroll-bar :type scroll-bar-spec ; (member t :vertical :horizontal nil)
1941 ;; ### Note: I added NIL here, so that the application
1942 ;; programmer can switch off scroll bars alltogether.
1943 ;; The spec though has it neither in the description of
1944 ;; SCROLLER-PANE, nor in the description of
1945 ;; MAKE-CLIM-STREAM-PANE, but in OPEN-WINDOW-STREAM.
1946 ;;
1947 ;; One might argue that in case of no scroll-bars the
1948 ;; application programmer can just skip the scroller
1949 ;; pane altogether. Bu I think that the then needed
1950 ;; special casing on having a scroller pane or a bare
1951 ;; viewport at hand is an extra burden, that can be
1952 ;; avoided.
1953 ;; --GB 2005-11-29
1954 :initform t
1955 :initarg :scroll-bar
1956 :accessor scroller-pane-scroll-bar)
1957 (viewport :initform nil)
1958 (vscrollbar :initform nil)
1959 (hscrollbar :initform nil)
1960 (suggested-width :initform 300 :initarg :suggested-width)
1961 (suggested-height :initform 300 :initarg :suggested-height)
1962 (vertical-scroll-bar-position
1963 :initform clim-extensions:*default-vertical-scroll-bar-position*
1964 :initarg :vertical-scroll-bar-position
1965 :type (member :left :right)
1966 :documentation "Whether to put the vertical scroll bar on the left hand or
1967 right hand side of the scroller pane."))
1968 (:default-initargs
1969 :x-spacing 4
1970 :y-spacing 4))
1971
1972 (defgeneric scroll-bar-values (scroll-bar)
1973 (:documentation "Returns the min value, max value, thumb size, and value of a
1974 scroll bar. When Setf-ed, updates the scroll bar graphics"))
1975
1976 (defgeneric* (setf scroll-bar-values) (min-value max-value thumb-size value scroll-bar))
1977
1978 (defmacro scrolling ((&rest options) &body contents)
1979 `(let ((viewport (make-pane 'viewport-pane :contents (list ,@contents))))
1980 (make-pane 'scroller-pane ,@options :contents (list viewport))))
1981
1982 ;;; Layout
1983
1984 (defmethod compose-space ((pane scroller-pane) &key width height)
1985 (declare (ignore width height))
1986 (with-slots (viewport vscrollbar hscrollbar suggested-width suggested-height
1987 x-spacing y-spacing scroll-bar)
1988 pane
1989 (if viewport
1990 (let ((req
1991 ;; v-- where does this requirement come from?
1992 ;; a: just an arbitrary default
1993 (make-space-requirement
1994 :width suggested-width :height suggested-height :max-width +fill+ :max-height +fill+
1995 :min-width (max (* 2 x-spacing) (if (null scroll-bar) 0 30))
1996 :min-height (max (* 2 y-spacing) (if (null scroll-bar) 0 30))))
1997 (viewport-child (first (sheet-children viewport))))
1998 (when vscrollbar
1999 (setq req (space-requirement+*
2000 (space-requirement-combine #'max
2001 req
2002 (compose-space vscrollbar))
2003 :height *scrollbar-thickness*
2004 :min-height *scrollbar-thickness*
2005 :max-height *scrollbar-thickness*)))
2006 (when hscrollbar
2007 (setq req (space-requirement+*
2008 (space-requirement-combine
2009 #'max req (compose-space hscrollbar))
2010 :width *scrollbar-thickness*
2011 :min-width *scrollbar-thickness*
2012 :max-width *scrollbar-thickness*)))
2013 (let* ((viewport-sr (compose-space viewport
2014 :width suggested-width
2015 :height suggested-height))
2016 (max-width (+ (space-requirement-max-width viewport-sr)
2017 (if vscrollbar *scrollbar-thickness* 0)
2018 ;; I don't know why this is necessary.
2019 (if (extended-output-stream-p viewport-child)
2020 (* 4 (stream-vertical-spacing viewport-child))
2021 0)))
2022 (max-height (+ (space-requirement-max-height viewport-sr)
2023 (if hscrollbar *scrollbar-thickness* 0)
2024 ;; I don't know why this is necessary.
2025 (if (extended-output-stream-p viewport-child)
2026 (* 4 (stream-vertical-spacing viewport-child))
2027 0))))
2028 (setq req (make-space-requirement
2029 :width (min (space-requirement-width req)
2030 max-width)
2031 :height (min (space-requirement-height req)
2032 max-height)
2033 :min-width (min (space-requirement-min-width req)
2034 max-width)
2035 :min-height (min (space-requirement-min-height req)
2036 max-height)
2037 :max-width max-width
2038 :max-height max-height)))
2039
2040 req)
2041 (make-space-requirement))))
2042
2043 (defmethod allocate-space ((pane scroller-pane) width height)
2044 (with-slots (viewport vscrollbar hscrollbar x-spacing y-spacing vertical-scroll-bar-position) pane
2045 (let* ((vsbar-width (if vscrollbar (space-requirement-width (compose-space vscrollbar)) 0))
2046 (hsbar-height (if hscrollbar (space-requirement-height (compose-space hscrollbar)) 0))
2047 (viewport-width (- width vsbar-width))
2048 (viewport-height (- height hsbar-height)))
2049 (when vscrollbar
2050 (move-sheet vscrollbar
2051 (ecase vertical-scroll-bar-position
2052 (:left 0)
2053 (:right (- width vsbar-width)))
2054 0)
2055 (allocate-space vscrollbar
2056 vsbar-width
2057 (- height hsbar-height)))
2058 (when hscrollbar
2059 (move-sheet hscrollbar
2060 (ecase vertical-scroll-bar-position
2061 (:left vsbar-width)
2062 (:right 0))
2063 (- height hsbar-height))
2064 (allocate-space hscrollbar
2065 (- width vsbar-width)
2066 hsbar-height))
2067 ;;
2068 ;; Recalculate the gadget-values of the scrollbars
2069 ;;
2070 (when vscrollbar
2071 (let* ((scrollee (first (sheet-children viewport)))
2072 (min 0)
2073 (max (- (max (space-requirement-height (compose-space scrollee))
2074 viewport-height)
2075 viewport-height))
2076 (ts viewport-height)
2077 (val (if (zerop (gadget-max-value vscrollbar))
2078 0
2079 (* (/ (gadget-value vscrollbar) (gadget-max-value vscrollbar))
2080 max))))
2081 (setf (scroll-bar-values vscrollbar) (values min max ts val))))
2082 (when hscrollbar
2083 (let* ((scrollee (first (sheet-children viewport)))
2084 (min 0)
2085 (max (- (max (space-requirement-width (compose-space scrollee))
2086 viewport-width)
2087 viewport-width))
2088 (ts viewport-width)
2089 (val (if (zerop (gadget-max-value hscrollbar))
2090 0
2091 (* (/ (gadget-value hscrollbar) (gadget-max-value hscrollbar))
2092 max))))
2093 (setf (scroll-bar-values hscrollbar) (values min max ts val))))
2094 (when viewport
2095 (move-sheet viewport
2096 (+ x-spacing
2097 (ecase vertical-scroll-bar-position
2098 (:left vsbar-width)
2099 (:right 0)))
2100 (+ y-spacing 0))
2101 (allocate-space viewport
2102 (- viewport-width (* 2 x-spacing))
2103 (- viewport-height (* 2 y-spacing)))))))
2104
2105 ;;;; Initialization
2106
2107 (defmethod scroller-pane/vertical-drag-callback ((pane scroller-pane) new-value)
2108 "Callback for the vertical scroll-bar of a scroller-pane."
2109 (with-slots (viewport hscrollbar vscrollbar) pane
2110 (let ((scrollee (first (sheet-children viewport))))
2111 (when (pane-viewport scrollee)
2112 (move-sheet scrollee
2113 (round (if hscrollbar
2114 (- (gadget-value hscrollbar))
2115 0))
2116 (round (- new-value)))))))
2117
2118 (defmethod scroller-pane/horizontal-drag-callback ((pane scroller-pane) new-value)
2119 "Callback for the horizontal scroll-bar of a scroller-pane."
2120 (with-slots (viewport hscrollbar vscrollbar) pane
2121 (let ((scrollee (first (sheet-children viewport))))
2122 (when (pane-viewport scrollee)
2123 (move-sheet scrollee
2124 (round (- new-value))
2125 (round (if vscrollbar
2126 (- (gadget-value vscrollbar))
2127 0)))))))
2128
2129
2130 (defmethod scroller-pane/update-scroll-bars ((pane scroller-pane))
2131 (with-slots (viewport hscrollbar vscrollbar) pane
2132 (let* ((scrollee (first (sheet-children viewport)))
2133 (scrollee-sr (sheet-region scrollee))
2134 (viewport-sr (sheet-region viewport)))
2135 ;;
2136 (when hscrollbar
2137 (setf (scroll-bar-values hscrollbar)
2138 (values (bounding-rectangle-min-x scrollee-sr)
2139 (max (- (bounding-rectangle-max-x scrollee-sr)
2140 (bounding-rectangle-width viewport-sr))
2141 (bounding-rectangle-min-x scrollee-sr))
2142 (bounding-rectangle-width viewport-sr)
2143 (- (nth-value 0 (transform-position
2144 (sheet-transformation scrollee) 0 0))))))
2145 ;;
2146 (when vscrollbar
2147 (setf (scroll-bar-values vscrollbar)
2148 (values (bounding-rectangle-min-y scrollee-sr)
2149 (max (- (bounding-rectangle-max-y scrollee-sr)
2150 (bounding-rectangle-height viewport-sr))
2151 (bounding-rectangle-min-y scrollee-sr))
2152 (bounding-rectangle-height viewport-sr)
2153 (- (nth-value 1 (transform-position
2154 (sheet-transformation scrollee)
2155 0
2156 0)))))))))
2157
2158
2159 (defmethod initialize-instance :after ((pane scroller-pane) &key contents &allow-other-keys)
2160 (sheet-adopt-child pane (first contents))
2161 (with-slots (scroll-bar viewport vscrollbar hscrollbar) pane
2162 (setq viewport (first (sheet-children pane)))
2163 ;; make the background of the viewport match the background of the
2164 ;; things scrolled.
2165 ;; This doesn't appear to work, hence the "gray space" bugs. Actually
2166 ;; handy for observing when the space requirements get messed up.. -Hefner
2167 (when (first (sheet-children viewport))
2168 (setf (slot-value pane 'background) ;### hmm ...
2169 (pane-background (first (sheet-children viewport)))))
2170 ;; make sure that we have ok options for the scroll-bar argument...
2171 (check-type scroll-bar scroll-bar-spec) ; (member :vertical :horizontal :both t nil))
2172 (when (member scroll-bar '(:vertical :both t))
2173 (setq vscrollbar
2174 (make-pane 'scroll-bar
2175 :orientation :vertical
2176 :client (first (sheet-children viewport))
2177 :drag-callback (lambda (gadget new-value)
2178 (declare (ignore gadget))
2179 (scroller-pane/vertical-drag-callback pane new-value))
2180 :scroll-up-page-callback
2181 #'(lambda (scroll-bar)
2182 (scroll-page-callback scroll-bar 1))
2183 :scroll-down-page-callback
2184 #'(lambda (scroll-bar)
2185 (scroll-page-callback scroll-bar -1))
2186 :scroll-up-line-callback
2187 #'(lambda (scroll-bar)
2188 (scroll-line-callback scroll-bar 1))
2189 :scroll-down-line-callback
2190 #'(lambda (scroll-bar)
2191 (scroll-line-callback scroll-bar -1))
2192 :value-changed-callback (lambda (gadget new-value)
2193 (declare (ignore gadget))
2194 (scroller-pane/vertical-drag-callback pane new-value))
2195 :min-value 0
2196 :max-value 1))
2197 (sheet-adopt-child pane vscrollbar))
2198 (when (member scroll-bar '(:horizontal :both t))
2199 (setq hscrollbar
2200 (make-pane 'scroll-bar
2201 :orientation :horizontal
2202 :client (first (sheet-children viewport))
2203 :drag-callback (lambda (gadget new-value)
2204 (declare (ignore gadget))
2205 (scroller-pane/horizontal-drag-callback pane new-value))
2206 :scroll-up-page-callback
2207 #'(lambda (scroll-bar)
2208 (scroll-page-callback scroll-bar 1))
2209 :scroll-down-page-callback
2210 #'(lambda (scroll-bar)
2211 (scroll-page-callback scroll-bar -1))
2212 :scroll-up-line-callback
2213 #'(lambda (scroll-bar)
2214 (scroll-line-callback scroll-bar 1))
2215 :scroll-down-line-callback
2216 #'(lambda (scroll-bar)
2217 (scroll-line-callback scroll-bar -1))
2218 :value-changed-callback (lambda (gadget new-value)
2219 (declare (ignore gadget))
2220 (scroller-pane/horizontal-drag-callback pane new-value))
2221 :min-value 0
2222 :max-value 1))
2223 (sheet-adopt-child pane hscrollbar))))
2224
2225 ;;;; Scrolling itself
2226
2227 ;;;; Accounting for changed space requirements
2228
2229 (defmethod change-space-requirements ((pane clim-extensions:viewport-pane) &rest ignore)
2230 (declare (ignore ignore))
2231 (let* ((client (first (sheet-children pane)))
2232 (sr (compose-space client))
2233 (width (max (bounding-rectangle-width pane)
2234 (space-requirement-width sr)))
2235 (height (max (bounding-rectangle-height pane)
2236 (space-requirement-height sr))))
2237 (resize-sheet client width height)
2238 (allocate-space client width height)
2239 (scroller-pane/update-scroll-bars (sheet-parent pane))))
2240
2241 ;;;;
2242
2243 (defun scroll-page-callback (scroll-bar direction)
2244 (let ((client (gadget-client scroll-bar)))
2245 (setf (gadget-value scroll-bar :invoke-callback t)
2246 (clamp
2247 (- (gadget-value scroll-bar)
2248 (* direction
2249 (funcall (if (eq (gadget-orientation scroll-bar) :vertical)
2250 #'bounding-rectangle-height
2251 #'bounding-rectangle-width)
2252 (pane-viewport-region client))))
2253 (gadget-min-value scroll-bar)
2254 (gadget-max-value scroll-bar)))))
2255
2256 (defun scroll-line-callback (scroll-bar direction)
2257 (let ((client (gadget-client scroll-bar)))
2258 (setf (gadget-value scroll-bar :invoke-callback t)
2259 (clamp
2260 (- (gadget-value scroll-bar)
2261 (* direction
2262 (if (extended-output-stream-p client)
2263 (stream-line-height client)
2264 10))) ; picked an arbitrary number - BTS
2265 (gadget-min-value scroll-bar)
2266 (gadget-max-value scroll-bar)))))
2267
2268 (defmethod pane-viewport ((pane basic-pane))
2269 (let ((parent (sheet-parent pane)))
2270 (when (and parent (typep parent 'viewport-pane))
2271 parent)))
2272
2273 ;;; Default for streams that aren't even panes.
2274
2275 (defmethod pane-viewport-region ((pane t))
2276 nil)
2277
2278 (defmethod pane-viewport-region ((pane basic-pane))
2279 (let ((viewport (pane-viewport pane)))
2280 (and viewport
2281 (untransform-region
2282 (sheet-delta-transformation pane viewport)
2283 (sheet-region viewport)))))
2284
2285 (defmethod pane-scroller ((pane basic-pane))
2286 (let ((viewport (pane-viewport pane)))
2287 (when viewport
2288 (sheet-parent viewport))))
2289
2290 (defmethod scroll-extent ((pane basic-pane) x y)
2291 (when (pane-viewport pane)
2292 (move-sheet pane (round (- x)) (round (- y)))
2293 (when (pane-scroller pane)
2294 (scroller-pane/update-scroll-bars (pane-scroller pane)))))
2295
2296 ;;; LABEL PANE
2297
2298 (defclass label-pane (composite-pane permanent-medium-sheet-output-mixin)
2299 ((label :type string
2300 :initarg :label
2301 :accessor label-pane-label
2302 :initform "")
2303 (alignment :type (member :bottom :top)
2304 :initform :top
2305 :initarg :label-alignment
2306 :reader label-pane-label-alignment)
2307 (background :initform *3d-normal-color*))
2308 (:default-initargs
2309 :align-y :center
2310 :text-style (make-text-style :sans-serif nil nil))
2311 (:documentation ""))
2312
2313 (defmacro labelling ((&rest options) &body contents)
2314 `(make-pane 'label-pane ,@options :contents (list ,@contents)))
2315
2316 (defmethod label-pane-margins ((pane label-pane))
2317 (let ((m0 2)
2318 (a (text-style-ascent (pane-text-style pane) pane))
2319 (d (text-style-descent (pane-text-style pane) pane)))
2320 (values
2321 ;; margins of inner sheet region
2322 (+ a (* 2 m0))
2323 (+ a (if (eq (label-pane-label-alignment pane) :top) d 0) (* 2 m0))
2324 (+ a (* 2 m0))
2325 (+ a (if (eq (label-pane-label-alignment pane) :top) 0 d) (* 2 m0))
2326 ;; margins of surrounding border
2327 (+ m0 (/ a 2))
2328 (+ m0 (/ a 2))
2329 (+ m0 (/ a 2))
2330 (+ m0 (if (eq (label-pane-label-alignment pane) :top) 0 d) (/ a 2))
2331 ;; position of text
2332 (+ m0 (if (sheet-children pane)
2333 (+ a m0 m0 d)
2334 0))
2335 (+ m0 a))))
2336
2337 (defmethod compose-space ((pane label-pane) &key width height)
2338 (declare (ignore width height))
2339 (let* ((w (text-size pane (label-pane-label pane)))
2340 (a (text-style-ascent (pane-text-style pane) pane))
2341 (d (text-style-descent (pane-text-style pane) pane))
2342 (m0 2)
2343 (h (+ a d m0 m0)))
2344 (cond ((and (sheet-children pane)
2345 ;; ### this other test below seems to be neccessary since
2346 ;; somebody decided that (NIL) is a valid return value
2347 ;; from sheet-children. --GB 2002-11-10
2348 (first (sheet-children pane)))
2349 (let ((sr2 (compose-space (first (sheet-children pane)))))
2350 (multiple-value-bind (right top left bottom) (label-pane-margins pane)
2351 (make-space-requirement
2352 ;; label!
2353 :width (+ left right (max (+ w m0 m0) (space-requirement-width sr2)))
2354 :min-width (+ left right (max (+ w m0 m0) (space-requirement-min-width sr2)))
2355 :max-width (+ left right (max (+ w m0 m0) (space-requirement-max-width sr2)))
2356 :height (+ top bottom (space-requirement-height sr2))
2357 :min-height (+ top bottom (space-requirement-min-height sr2))
2358 :max-height (+ top bottom (space-requirement-max-height sr2))))))
2359 (t
2360 (incf w m0)
2361 (incf w m0)
2362 (let ((sr1 (make-space-requirement :width w :min-width w
2363 :height h :min-height h :max-height h)))
2364 (when (sheet-children pane)
2365 (let ((sr2 (compose-space (first (sheet-children pane)))))
2366 (setf sr1
2367 (make-space-requirement
2368 :width (max (space-requirement-width sr1) (space-requirement-width sr2))
2369 :min-width (max (space-requirement-min-width sr1) (space-requirement-min-width sr2))
2370 :max-width (max (space-requirement-max-width sr1) (space-requirement-max-width sr2))
2371 :height (+ (space-requirement-height sr1) (space-requirement-height sr2))
2372 :min-height (+ (space-requirement-min-height sr1) (space-requirement-min-height sr2))
2373 :max-height (+ (space-requirement-max-height sr1) (space-requirement-max-height sr2))))))
2374 sr1)))))
2375
2376 (defmethod allocate-space ((pane label-pane) width height)
2377 (multiple-value-bind (right top left bottom) (label-pane-margins pane)
2378 (when (sheet-children pane)
2379 (multiple-value-bind (x1 y1 x2 y2) (values 0 0 width height)
2380 (move-sheet (first (sheet-children pane))
2381 (+ x1 left) (+ y1 top))
2382 (allocate-space (first (sheet-children pane))
2383 (- (- x2 right) (+ x1 left))
2384 (- (- y2 bottom) (+ y1 top)))))))
2385
2386 (defmethod handle-repaint ((pane label-pane) region)
2387 (declare (ignore region))
2388 (let ((m0 2)
2389 (a (text-style-ascent (pane-text-style pane) pane))
2390 (d (text-style-descent (pane-text-style pane) pane))
2391 (tw (text-size pane (label-pane-label pane))))
2392 (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region pane)
2393 (multiple-value-bind (iright itop ileft ibottom
2394 bright btop bleft bbottom)
2395 (label-pane-margins pane)
2396 (declare (ignorable iright itop ileft ibottom))
2397 (multiple-value-bind (tx ty)
2398 (values (ecase (pane-align-x pane)
2399 (:left (+ x1 m0 (if (sheet-children pane)
2400 (+ a m0 m0 d)
2401 0)))
2402 (:right (- x2 m0 (if (sheet-children pane)
2403 (+ a m0 m0 d)
2404 0)
2405 tw))
2406 (:center (- (/ (- x2 x1) 2) (/ tw 2))))
2407 (ecase (label-pane-label-alignment pane)
2408 (:top (+ y1 m0 a))
2409 (:bottom (- y2 m0 d))))
2410 (draw-text* pane (label-pane-label pane)
2411 tx ty)
2412 ;;;
2413 (when (sheet-children pane)
2414 (with-drawing-options (pane
2415 :clipping-region
2416 (region-difference
2417 (sheet-region pane)
2418 (make-rectangle* (- tx m0) (- ty a) (+ tx tw m0) (+ ty d))))
2419 (draw-bordered-rectangle* pane (+ x1 bleft) (+ y1 btop) (- x2 bright) (- y2 bbottom)
2420 :style :groove))))))))
2421
2422
2423 (defmethod initialize-instance :after ((pane label-pane) &key contents &allow-other-keys)
2424 (when contents
2425 (sheet-adopt-child pane (first contents))))
2426
2427 ;;; GENERIC FUNCTIONS
2428
2429 (defgeneric* (setf window-viewport-position) (x y clim-stream-pane))
2430
2431 ;;; Mixin for panes which want the mouse wheel to scroll vertically
2432
2433 (defclass mouse-wheel-scroll-mixin () ())
2434
2435 (defparameter *mouse-scroll-distance* 4
2436 "Number of lines by which to scroll the window in response to the scroll wheel")
2437
2438 (defgeneric scroll-quantum (pane)
2439 (:documentation "Returns the number of pixels respresenting a 'line', used
2440 to computed distance to scroll in response to mouse wheel events."))
2441
2442 (defmethod scroll-quantum (pane) 10) ; TODO: Connect this with the scroller-pane motion
2443
2444 (defun find-viewport-for-scroll (pane)
2445 "Find a viewport in the chain of parents which contains 'pane',
2446 returning this viewport and the sheet immediately contained within."
2447 (cond ((not (typep pane 'basic-pane))
2448 (values nil nil))
2449 ((pane-viewport pane) (values (pane-viewport pane) pane))
2450 (t (find-viewport-for-scroll (sheet-parent pane)))))
2451
2452 (defun scroll-sheet (sheet vertical horizontal)
2453 (multiple-value-bind (viewport sheet)
2454 (find-viewport-for-scroll sheet)
2455 (declare (ignore viewport))
2456 (with-bounding-rectangle* (vx0 vy0 vx1 vy1) (pane-viewport-region sheet)
2457 (with-bounding-rectangle* (sx0 sy0 sx1 sy1) (sheet-region sheet)
2458 (let ((viewport-height (- vy1 vy0))
2459 (viewport-width (- vx1 vx0))
2460 (delta (* *mouse-scroll-distance*
2461 (scroll-quantum sheet))))
2462 ;; The coordinates (x,y) of the new upper-left corner of the viewport
2463 ;; must be "sx0 < x < sx1 - viewport-width" and
2464 ;; "sy0 < y < sy1 - viewport-height"
2465 (scroll-extent sheet
2466 (max sx0 (min (- sx1 viewport-width) (+ vx0 (* delta horizontal))))
2467 (max sy0 (min (- sy1 viewport-height) (+ vy0 (* delta vertical))))))))))
2468
2469 ;; Note that handling this from dispatch-event is evil, and we shouldn't.
2470 (defmethod dispatch-event :around ((sheet mouse-wheel-scroll-mixin)
2471 (event pointer-button-press-event))
2472 (if (find-viewport-for-scroll sheet)
2473 (let ((button (pointer-event-button event)))
2474 (cond
2475 ((eq button +pointer-wheel-up+) (scroll-sheet sheet -1 0))
2476 ((eq button +pointer-wheel-down+) (scroll-sheet sheet 1 0))
2477 ((eq button +pointer-wheel-left+) (scroll-sheet sheet 0 -1))
2478 ((eq button +pointer-wheel-right+) (scroll-sheet sheet 0 1))
2479 (t (call-next-method)))) ; not a scroll wheel button
2480 (call-next-method))) ; no viewport
2481
2482 ;;;
2483 ;;; 29.4 CLIM Stream Panes
2484 ;;;
2485
2486 ;;; A class that implements the display function invocation. It's put
2487 ;;; in a super class of clim-stream-pane so that redisplay-frame-pane
2488 ;;; on updating-output-stream-mixin can override that method.
2489
2490 (defclass pane-display-mixin ()
2491 ((display-function :initform 'clim-stream-pane-default-display-function
2492 :initarg :display-function
2493 :accessor pane-display-function)))
2494
2495 (defmethod redisplay-frame-pane ((frame application-frame)
2496 (pane pane-display-mixin)
2497 &key force-p)
2498 (declare (ignore force-p))
2499 (invoke-display-function frame pane)
2500 (fit-pane-to-output pane))
2501
2502 (defgeneric pane-double-buffering (pane))
2503
2504 (defmethod pane-double-buffering (pane)
2505 (declare (ignore pane))
2506 nil)
2507
2508 (defclass clim-stream-pane (updating-output-stream-mixin
2509 pane-display-mixin
2510 permanent-medium-sheet-output-mixin
2511 #-clim-mp standard-repainting-mixin
2512 standard-extended-input-stream
2513 standard-extended-output-stream
2514 standard-output-recording-stream
2515 ;; sheet-leaf-mixin
2516 sheet-multiple-child-mixin ; needed for GADGET-OUTPUT-RECORD
2517 basic-pane)
2518 ((redisplay-needed :initarg :display-time)
2519 (scroll-bars :type scroll-bar-spec ; (member t :vertical :horizontal nil)
2520 :initform nil
2521 :initarg :scroll-bars
2522 :accessor pane-scroll-bars)
2523
2524 ; Should inherit from label-pane for this one ??
2525 (label :type string
2526 :initform ""
2527 :initarg :label
2528 :reader pane-label)
2529 (text-margin :initarg :text-margin
2530 :reader pane-text-margin)
2531 (vertical-spacing :initarg :vertical-spacing
2532 :reader pane-vertical-spacing)
2533 (end-of-line-action :initform :wrap
2534 :initarg :end-of-line-action
2535 :reader pane-end-of-line-action)
2536 (end-of-page-action :initform :scroll
2537 :initarg :end-of-page-action
2538 :reader pane-end-of-page-action)
2539 (double-buffering :initform nil
2540 :initarg :double-buffering
2541 :reader pane-double-buffering