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

Contents of /mcclim/sheets.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.27 - (show annotations)
Sun Apr 21 12:41:15 2002 UTC (11 years, 11 months ago) by brian
Branch: MAIN
Changes since 1.26: +1 -0 lines
Sundry fixes to run without multiprocessing support.

Added images/ to hold bitmaps for tests.

Added looks/ to hold neutral look-and-feel realizer packages.

Added Examples/gadget-test to test many gadgets with a look and feel.

Added a pixie look and feel, and a pixie/clx to work with the clx backend.

Added drawing support in the CLX backend for ovals and circles.

Fixed pixmaps to work with with-output-to-pixmap with draw-image, etc.

Moved sheet-leaf-mixin to standard-gadget-pane so it doesn't break radio-box-pane, etc.

Misc fixes.
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 1998,1999,2000 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 ;;; Robert Strandh (strandh@labri.u-bordeaux.fr)
8 ;;; (c) copyright 2001 by
9 ;;; Arnaud Rouanet (rouanet@emi.u-bordeaux.fr)
10 ;;; Lionel Salabartan (salabart@emi.u-bordeaux.fr)
11
12 ;;; This library is free software; you can redistribute it and/or
13 ;;; modify it under the terms of the GNU Library General Public
14 ;;; License as published by the Free Software Foundation; either
15 ;;; version 2 of the License, or (at your option) any later version.
16 ;;;
17 ;;; This library is distributed in the hope that it will be useful,
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
20 ;;; Library General Public License for more details.
21 ;;;
22 ;;; You should have received a copy of the GNU Library General Public
23 ;;; License along with this library; if not, write to the
24 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 ;;; Boston, MA 02111-1307 USA.
26
27
28
29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
30 ;;;
31 ;;; The sheet protocol
32
33 (in-package :CLIM-INTERNALS)
34
35 (defgeneric sheet-parent (sheet)
36 (:documentation
37 "Returns the parent of the sheet SHEET or nil if the sheet has
38 no parent"))
39
40 (defgeneric sheet-children (sheet)
41 (:documentation
42 "Returns a list of sheets that are the children of the sheet SHEET.
43 Some sheet classes support only a single child; in this case, the
44 result of sheet-children will be a list of one element. This
45 function returns objects that reveal CLIM's internal state ; do not
46 modify those objects."))
47
48 (defgeneric sheet-adopt-child (sheet child)
49 (:documentation
50 "Adds the child sheet child to the set of children of the sheet SHEET,
51 and makes the sheet the child's parent. If child already has a parent,
52 the sheet-already-has-parent error will be signalled.
53
54 Some sheet classes support only a single child. For such sheets,
55 attempting to adopt more than a single child will cause the
56 sheet-supports-only-one-child error to be signalled."))
57
58 (defgeneric sheet-disown-child (sheet child &key errorp))
59 (defgeneric sheet-enabled-children (sheet))
60 (defgeneric sheet-ancestor-p (sheet putative-ancestor))
61 (defgeneric raise-sheet (sheet))
62
63 ;;; not for external use
64 (defgeneric raise-sheet-internal (sheet parent))
65
66 (defgeneric bury-sheet (sheet))
67
68 ;;; not for external use
69 (defgeneric bury-sheet-internal (sheet parent))
70
71 (defgeneric reorder-sheets (sheet new-ordering))
72 (defgeneric sheet-enabled-p (sheet))
73 (defgeneric (setf sheet-enabled-p) (enabled-p sheet))
74 (defgeneric sheet-viewable-p (sheet))
75 (defgeneric sheet-occluding-sheets (sheet child))
76
77 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
78 ;;;
79 ;;; Sheet geometry
80
81 (defgeneric sheet-transformation (sheet))
82 (defgeneric (setf sheet-transformation) (transformation sheet))
83 (defgeneric sheet-region (sheet))
84 (defgeneric (setf sheet-region) (region sheet))
85 (defgeneric map-sheet-position-to-parent (sheet x y))
86 (defgeneric map-sheet-position-to-child (sheet x y))
87 (defgeneric map-sheet-rectangle*-to-parent (sheet x1 y1 x2 y2))
88 (defgeneric map-sheet-rectangle*-to-child (sheet x1 y1 x2 y2))
89 (defgeneric child-containing-position (sheet x y))
90 (defgeneric children-overlapping-region (sheet region))
91 (defgeneric children-overlapping-rectangle* (sheet x1 y1 x2 y2))
92 (defgeneric sheet-delta-transformation (sheet ancestor))
93 (defgeneric sheet-allocated-region (sheet child))
94
95 ;;these are now in decls.lisp --GB
96 ;;(defgeneric sheet-native-region (sheet))
97 ;;(defgeneric sheet-device-region (sheet))
98 ;;(defgeneric invalidate-cached-regions (sheet))
99
100 ;;(defgeneric sheet-native-transformation (sheet))
101 ;;(defgeneric sheet-device-transformation (sheet))
102 ;;(defgeneric invalidate-cached-transformations (sheet))
103
104 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
105 ;;;
106 ;;; input protocol
107
108 (defgeneric dispatch-event (client event))
109 (defgeneric queue-event (client event))
110 (defgeneric handle-event (client event))
111 (defgeneric event-read (client))
112 (defgeneric event-read-no-hang (client))
113 (defgeneric event-peek (client &optional event-type))
114 (defgeneric event-unread (client event))
115 (defgeneric event-listen (client))
116 (defgeneric sheet-direct-mirror (sheet))
117 (defgeneric sheet-mirrored-ancestor (sheet))
118 (defgeneric sheet-mirror (sheet))
119
120 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
121 ;;;
122 ;;; repaint protocol
123
124 (defgeneric dispatch-repaint (sheet region))
125 (defgeneric queue-repaint (sheet region))
126 (defgeneric handle-repaint (sheet region))
127 (defgeneric repaint-sheet (sheet region))
128
129 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
130 ;;;
131 ;;; notification protocol
132
133 (defgeneric note-sheet-grafted (sheet))
134 (defgeneric note-sheet-degrafted (sheet))
135 (defgeneric note-sheet-adopted (sheet))
136 (defgeneric note-sheet-disowned (sheet))
137 (defgeneric note-sheet-enabled (sheet))
138 (defgeneric note-sheet-disabled (sheet))
139 (defgeneric note-sheet-region-changed (sheet))
140 (defgeneric note-sheet-transformation-changed (sheet))
141
142 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
143 ;;;;
144 ;;;; sheet protocol class
145
146 (define-protocol-class sheet (bounding-rectangle)
147 ())
148
149 (defclass basic-sheet (sheet)
150 ((region :type region
151 :initarg :region
152 :initform (make-bounding-rectangle 0 0 100 100)
153 :accessor sheet-region)
154 (native-transformation :type transformation
155 :initform nil)
156 (native-region :type region
157 :initform nil)
158 (device-transformation :type transformation
159 :initform nil)
160 (device-region :type region
161 :initform nil)
162 (enabled-p :type boolean :initform nil :accessor sheet-enabled-p)))
163 ; Native region is volatile, and is only computed at the first request when it's equal to nil.
164 ; Invalidate-cached-region method sets the native-region to nil.
165
166 (defmethod sheet-parent ((sheet basic-sheet))
167 nil)
168
169 (defmethod sheet-children ((sheet basic-sheet))
170 nil)
171
172 (defmethod sheet-adopt-child ((sheet basic-sheet) (child sheet))
173 (error "~S attempting to adopt ~S" sheet child))
174
175 (defmethod sheet-adopt-child :after ((sheet basic-sheet) (child sheet))
176 (note-sheet-adopted child)
177 (when (sheet-grafted-p sheet)
178 (note-sheet-grafted child)))
179
180 (define-condition sheet-is-not-child (error) ())
181
182 (defmethod sheet-disown-child :before ((sheet basic-sheet) (child sheet) &key (errorp t))
183 (when (and (not (member child (sheet-children sheet))) errorp)
184 (error 'sheet-is-not-child)))
185
186 (defmethod sheet-disown-child :after ((sheet basic-sheet) (child sheet) &key (errorp t))
187 (declare (ignore errorp))
188 (note-sheet-disowned child)
189 (when (sheet-grafted-p sheet)
190 (note-sheet-degrafted child)))
191
192 (defmethod sheet-siblings ((sheet basic-sheet))
193 (when (not (sheet-parent sheet))
194 (error 'sheet-is-not-child))
195 (remove sheet (sheet-children (sheet-parent sheet))))
196
197 (defmethod sheet-enabled-children ((sheet basic-sheet))
198 (delete-if-not #'sheet-enabled-p (copy-list (sheet-children sheet))))
199
200 (defmethod sheet-ancestor-p ((sheet basic-sheet)
201 (putative-ancestor sheet))
202 (or (eq sheet putative-ancestor)
203 (and (sheet-parent sheet)
204 (sheet-ancestor-p (sheet-parent sheet) putative-ancestor))))
205
206 (defmethod raise-sheet ((sheet basic-sheet))
207 (error 'sheet-is-not-child))
208
209 (defmethod bury-sheet ((sheet basic-sheet))
210 (error 'sheet-is-not-child))
211
212 (define-condition sheet-ordering-underspecified (error) ())
213
214 (defmethod reorder-sheets ((sheet basic-sheet) new-ordering)
215 (when (set-difference (sheet-children sheet) new-ordering)
216 (error 'sheet-ordering-underspecified))
217 (when (set-difference new-ordering (sheet-children sheet))
218 (error 'sheet-is-not-child))
219 (setf (sheet-children sheet) new-ordering)
220 sheet)
221
222 (defmethod sheet-viewable-p ((sheet basic-sheet))
223 (and (sheet-parent sheet)
224 (sheet-viewable-p (sheet-parent sheet))
225 (sheet-enabled-p sheet)))
226
227 (defmethod sheet-occluding-sheets ((sheet basic-sheet) (child sheet))
228 (labels ((fun (l)
229 (cond ((eq (car l) child) '())
230 ((and (sheet-enabled-p (car l))
231 (region-intersects-region-p
232 (sheet-region (car l)) (sheet-region child)))
233 (cons (car l) (fun (cdr l))))
234 (t (fun (cdr l))))))
235 (fun (sheet-children sheet))))
236
237 (defmethod map-over-sheets (function (sheet basic-sheet))
238 (declare (dynamic-extent function))
239 (funcall function sheet)
240 (mapc #'(lambda (child) (map-over-sheets function child))
241 (sheet-children sheet))
242 nil)
243
244 (defmethod (setf sheet-enabled-p) :after (enabled-p (sheet basic-sheet))
245 (if enabled-p
246 (note-sheet-enabled sheet)
247 (note-sheet-disabled sheet)))
248
249 (defmethod sheet-transformation ((sheet basic-sheet))
250 (error "Attempting to get the TRANSFORMATION of a SHEET that doesn't contain one"))
251
252 (defmethod (setf sheet-transformation) (transformation (sheet basic-sheet))
253 (declare (ignore transformation))
254 (error "Attempting to set the TRANSFORMATION of a SHEET that doesn't contain one"))
255
256 (defmethod move-sheet ((sheet basic-sheet) x y)
257 (let ((transform (sheet-transformation sheet)))
258 (multiple-value-bind (old-x old-y)
259 (transform-position transform 0 0)
260 (setf (sheet-transformation sheet)
261 (compose-translation-with-transformation
262 transform (- x old-x) (- y old-y))))))
263
264 (defmethod resize-sheet ((sheet basic-sheet) width height)
265 (setf (sheet-region sheet)
266 (make-bounding-rectangle 0 0 width height)))
267
268 (defmethod move-and-resize-sheet ((sheet basic-sheet) x y width height)
269 (move-sheet sheet x y)
270 (resize-sheet sheet width height))
271
272 (defmethod map-sheet-position-to-parent ((sheet basic-sheet) x y)
273 (declare (ignore x y))
274 (error "Sheet has no parent"))
275
276 (defmethod map-sheet-position-to-child ((sheet basic-sheet) x y)
277 (declare (ignore x y))
278 (error "Sheet has no parent"))
279
280 (defmethod map-sheet-rectangle*-to-parent ((sheet basic-sheet) x1 y1 x2 y2)
281 (declare (ignore x1 y1 x2 y2))
282 (error "Sheet has no parent"))
283
284 (defmethod map-sheet-rectangle*-to-child ((sheet basic-sheet) x1 y1 x2 y2)
285 (declare (ignore x1 y1 x2 y2))
286 (error "Sheet has no parent"))
287
288 (defmethod map-over-sheets-containing-position (function (sheet basic-sheet) x y)
289 (declare (dynamic-extent function))
290 (map-over-sheets #'(lambda (child)
291 (multiple-value-bind (tx ty) (map-sheet-position-to-child child x y)
292 (when (region-contains-position-p (sheet-region child) tx ty)
293 (funcall function child))))
294 sheet))
295
296
297 (defmethod map-over-sheets-overlapping-region (function (sheet basic-sheet) region)
298 (declare (dynamic-extent function))
299 (map-over-sheets #'(lambda (child)
300 (when (region-intersects-region-p
301 region
302 (transform-region (sheet-transformation child)
303 (sheet-region child)))
304 (funcall function child)))
305 sheet))
306
307 (defmethod child-containing-position ((sheet basic-sheet) x y)
308 (loop for child in (sheet-children sheet)
309 do (multiple-value-bind (tx ty) (map-sheet-position-to-child child x y)
310 (if (and (sheet-enabled-p child)
311 (region-contains-position-p (sheet-region child) tx ty))
312 (return child)))))
313
314 (defmethod children-overlapping-region ((sheet basic-sheet) (region region))
315 (loop for child in (sheet-children sheet)
316 if (and (sheet-enabled-p child)
317 (region-intersects-region-p
318 region
319 (transform-region (sheet-transformation child)
320 (sheet-region child))))
321 collect child))
322
323 (defmethod children-overlapping-rectangle* ((sheet basic-sheet) x1 y1 x2 y2)
324 (children-overlapping-region sheet (make-rectangle* x1 y1 x2 y2)))
325
326 (defmethod sheet-delta-transformation ((sheet basic-sheet) (ancestor (eql nil)))
327 (cond ((sheet-parent sheet)
328 (compose-transformations (sheet-transformation sheet)
329 (sheet-delta-transformation
330 (sheet-parent sheet) ancestor)))
331 (t +identity-transformation+)))
332
333 (define-condition sheet-is-not-ancestor (error) ())
334
335 (defmethod sheet-delta-transformation ((sheet basic-sheet) (ancestor sheet))
336 (cond ((eq sheet ancestor) +identity-transformation+)
337 ((sheet-parent sheet)
338 (compose-transformations (sheet-transformation sheet)
339 (sheet-delta-transformation
340 (sheet-parent sheet) ancestor)))
341 (t (error 'sheet-is-not-ancestor))))
342
343 (defmethod sheet-allocated-region ((sheet basic-sheet) (child sheet))
344 (reduce #'region-difference
345 (mapcar #'(lambda (child)
346 (transform-region (sheet-transformation child)
347 (sheet-region child)))
348 (cons child (sheet-occluding-sheets sheet child)))))
349
350 (defmethod sheet-direct-mirror ((sheet basic-sheet))
351 nil)
352
353 (defmethod sheet-mirrored-ancestor ((sheet basic-sheet))
354 (if (sheet-parent sheet)
355 (sheet-mirrored-ancestor (sheet-parent sheet))))
356
357 (defmethod sheet-mirror ((sheet basic-sheet))
358 (let ((mirrored-ancestor (sheet-mirrored-ancestor sheet)))
359 (if mirrored-ancestor
360 (sheet-direct-mirror mirrored-ancestor))))
361
362 (defmethod graft ((sheet basic-sheet))
363 nil)
364
365 (defmethod note-sheet-grafted ((sheet basic-sheet))
366 (mapc #'note-sheet-grafted (sheet-children sheet)))
367
368 (defmethod note-sheet-degrafted ((sheet basic-sheet))
369 (mapc #'note-sheet-degrafted (sheet-children sheet)))
370
371 (defmethod note-sheet-adopted ((sheet basic-sheet))
372 nil)
373
374 (defmethod note-sheet-disowned ((sheet basic-sheet))
375 nil)
376
377 (defmethod note-sheet-enabled ((sheet basic-sheet))
378 (mapc #'note-sheet-enabled (sheet-children sheet)))
379
380 (defmethod note-sheet-disabled ((sheet basic-sheet))
381 (mapc #'note-sheet-disabled (sheet-children sheet)))
382
383 (defmethod note-sheet-region-changed ((sheet basic-sheet))
384 nil) ;have to change
385
386 (defmethod note-sheet-transformation-changed ((sheet basic-sheet))
387 nil)
388
389 (defmethod sheet-native-transformation ((sheet basic-sheet))
390 (with-slots (native-transformation) sheet
391 (unless native-transformation
392 (setf native-transformation
393 (let ((parent (sheet-parent sheet)))
394 (if parent
395 (compose-transformations
396 (sheet-native-transformation parent)
397 (sheet-transformation sheet))
398 +identity-transformation+))))
399 native-transformation))
400
401 (defmethod sheet-native-region ((sheet basic-sheet))
402 (with-slots (native-region) sheet
403 (unless native-region
404 (setf native-region (region-intersection
405 (transform-region
406 (sheet-native-transformation sheet)
407 (sheet-region sheet))
408 (sheet-native-region (sheet-parent sheet)))))
409 native-region))
410
411 (defmethod sheet-device-transformation ((sheet basic-sheet))
412 (with-slots (device-transformation) sheet
413 (unless device-transformation
414 (setf device-transformation
415 (let ((medium (sheet-medium sheet)))
416 (compose-transformations
417 (sheet-native-transformation sheet)
418 (if medium
419 (medium-transformation medium)
420 +identity-transformation+)))))
421 device-transformation))
422
423 (defmethod sheet-device-region ((sheet basic-sheet))
424 (with-slots (device-region) sheet
425 (unless device-region
426 (setf device-region
427 (let ((medium (sheet-medium sheet)))
428 (region-intersection
429 (sheet-native-region sheet)
430 (if medium
431 (transform-region
432 (sheet-device-transformation sheet)
433 (medium-clipping-region medium))
434 +everywhere+)))))
435 device-region))
436
437 (defmethod invalidate-cached-transformations ((sheet basic-sheet))
438 (with-slots (native-transformation device-transformation) sheet
439 (setf native-transformation nil
440 device-transformation nil))
441 (loop for child in (sheet-children sheet)
442 do (invalidate-cached-transformations child)))
443
444 (defmethod invalidate-cached-regions ((sheet basic-sheet))
445 (with-slots (native-region device-region) sheet
446 (setf native-region nil
447 device-region nil))
448 (loop for child in (sheet-children sheet)
449 do (invalidate-cached-regions child)))
450
451 (defmethod (setf sheet-transformation) :after (transformation (sheet basic-sheet))
452 (declare (ignore transformation))
453 (note-sheet-transformation-changed sheet)
454 (invalidate-cached-transformations sheet)
455 (invalidate-cached-regions sheet))
456
457 (defmethod (setf sheet-region) :after (region (sheet basic-sheet))
458 (declare (ignore region))
459 (note-sheet-region-changed sheet)
460 (invalidate-cached-regions sheet))
461
462
463 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
464 ;;;
465 ;;; sheet parent mixin
466
467
468 (defclass sheet-parent-mixin ()
469 ((parent :initform nil :accessor sheet-parent)))
470
471 (define-condition sheet-already-has-parent (error) ())
472 (define-condition sheet-is-ancestor (error) ())
473
474 (defmethod sheet-adopt-child :before (sheet (child sheet-parent-mixin))
475 (when (sheet-parent child) (error 'sheet-already-has-parent))
476 (when (sheet-ancestor-p sheet child) (error 'sheet-is-ancestor)))
477
478 (defmethod sheet-adopt-child :after (sheet (child sheet-parent-mixin))
479 (setf (sheet-parent child) sheet))
480
481 (defmethod sheet-disown-child :after (sheet
482 (child sheet-parent-mixin)
483 &key (errorp t))
484 (declare (ignore sheet errorp))
485 (setf (sheet-parent child) nil))
486
487 (defmethod raise-sheet ((sheet sheet-parent-mixin))
488 (when (not (sheet-parent sheet))
489 (error 'sheet-is-not-child))
490 (raise-sheet-internal sheet (sheet-parent sheet)))
491
492 (defmethod bury-sheet ((sheet sheet-parent-mixin))
493 (when (not (sheet-parent sheet))
494 (error 'sheet-is-not-child))
495 (bury-sheet-internal sheet (sheet-parent sheet)))
496
497 (defmethod graft ((sheet sheet-parent-mixin))
498 (graft (sheet-parent sheet)))
499
500 (defmethod (setf sheet-transformation) :after (newvalue (sheet sheet-parent-mixin))
501 (declare (ignore newvalue))
502 (note-sheet-transformation-changed sheet))
503
504 (defmethod map-sheet-position-to-parent ((sheet sheet-parent-mixin) x y)
505 (transform-position (sheet-transformation sheet) x y))
506
507 (defmethod map-sheet-position-to-child ((sheet sheet-parent-mixin) x y)
508 (untransform-position (sheet-transformation sheet) x y))
509
510 (defmethod map-sheet-rectangle*-to-parent ((sheet sheet-parent-mixin) x1 y1 x2 y2)
511 (transform-rectangle* (sheet-transformation sheet) x1 y1 x2 y2))
512
513 (defmethod map-sheet-rectangle*-to-child ((sheet sheet-parent-mixin) x1 y1 x2 y2)
514 (untransform-rectangle* (sheet-transformation sheet) x1 y1 x2 y2))
515
516 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
517 ;;;
518 ;;; sheet leaf mixin
519
520 (defclass sheet-leaf-mixin () ())
521
522 (defmethod sheet-children ((sheet sheet-leaf-mixin))
523 nil)
524
525 (defmethod sheet-adopt-child ((sheet sheet-leaf-mixin) (child sheet))
526 (describe (sb-pcl::class-of sheet))
527 (error "Leaf sheet attempting to adopt a child"))
528
529 (defmethod sheet-disown-child ((sheet sheet-leaf-mixin) (child sheet) &key (errorp t))
530 (declare (ignorable errorp))
531 (error "Leaf sheet attempting to disown a child"))
532
533
534 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
535 ;;;
536 ;;; sheet single child mixin
537
538 (defclass sheet-single-child-mixin ()
539 ((child :initform nil :accessor sheet-child)))
540
541 (defmethod sheet-children ((sheet sheet-single-child-mixin))
542 (list (sheet-child sheet)))
543
544 (define-condition sheet-supports-only-one-child (error) ())
545
546 (defmethod sheet-adopt-child :before ((sheet sheet-single-child-mixin)
547 (child sheet-parent-mixin))
548 (when (sheet-child sheet)
549 (error 'sheet-supports-only-one-child)))
550
551 (defmethod sheet-adopt-child ((sheet sheet-single-child-mixin)
552 (child sheet-parent-mixin))
553 (setf (sheet-child sheet) child))
554
555 (defmethod sheet-disown-child ((sheet sheet-single-child-mixin)
556 (child sheet-parent-mixin)
557 &key (errorp t))
558 (declare (ignore errorp))
559 (setf (sheet-child sheet) nil))
560
561 (defmethod raise-sheet-internal (sheet (parent sheet-single-child-mixin))
562 (declare (ignorable sheet parent))
563 (values))
564
565 (defmethod bury-sheet-internal (sheet (parent sheet-single-child-mixin))
566 (declare (ignorable sheet parent))
567 (values))
568
569
570 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
571 ;;;
572 ;;; sheet multiple child mixin
573
574 (defclass sheet-multiple-child-mixin ()
575 ((children :initform nil :initarg :children :accessor sheet-children)))
576
577 (defmethod sheet-adopt-child ((sheet sheet-multiple-child-mixin)
578 (child sheet-parent-mixin))
579 (push child (sheet-children sheet)))
580
581 (defmethod sheet-disown-child ((sheet sheet-multiple-child-mixin)
582 (child sheet-parent-mixin)
583 &key (errorp t))
584 (declare (ignore errorp))
585 (setf (sheet-children sheet) (delete child (sheet-children sheet))))
586
587 (defmethod raise-sheet-internal (sheet (parent sheet-multiple-child-mixin))
588 (setf (sheet-children parent)
589 (cons sheet (delete sheet (sheet-children parent)))))
590
591 (defmethod bury-sheet-internal (sheet (parent sheet-multiple-child-mixin))
592 (setf (sheet-children parent)
593 (append (delete sheet (sheet-children parent)) (list sheet))))
594
595
596 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
597 ;;;
598 ;;; sheet geometry classes
599
600 (defclass sheet-identity-transformation-mixin ()
601 ())
602
603 (defmethod sheet-transformation ((sheet sheet-identity-transformation-mixin))
604 +identity-transformation+)
605
606 (defclass sheet-transformation-mixin ()
607 ((transformation :initform +identity-transformation+
608 :initarg :transformation
609 :accessor sheet-transformation)))
610
611 (defclass sheet-translation-transformation-mixin (sheet-transformation-mixin)
612 ())
613
614 (defmethod (setf sheet-transformation) :before ((transformation transformation)
615 (sheet sheet-translation-transformation-mixin))
616 (if (not (translation-transformation-p transformation))
617 (error "Attempting to set the SHEET-TRANSFORMATION of a SHEET-TRANSLATION-TRANSFORMATION-MIXIN to a non translation transformation")))
618
619 (defclass sheet-y-inverting-transformation-mixin (sheet-transformation-mixin)
620 ()
621 (:default-initargs :transformation (make-transformation 1 0 0 -1 0 0)))
622
623 (defmethod (setf sheet-transformation) :before ((transformation transformation)
624 (sheet sheet-y-inverting-transformation-mixin))
625 (if (not (y-inverting-transformation-p transformation))
626 (error "Attempting to set the SHEET-TRANSFORMATION of a SHEET-Y-INVERTING-TRANSFORMATION-MIXIN to a non Y inverting transformation")))
627
628
629 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
630 ;;;
631 ;;; mirrored sheet
632
633 (defclass mirrored-sheet-mixin ()
634 ((port :initform nil :initarg :port :accessor port)
635 (mirror-transformation
636 :initform nil
637 :accessor sheet-mirror-transformation
638 )))
639
640 (defmethod sheet-direct-mirror ((sheet mirrored-sheet-mixin))
641 (port-lookup-mirror (port sheet) sheet))
642
643 (defmethod (setf sheet-direct-mirror) (mirror (sheet mirrored-sheet-mixin))
644 (port-register-mirror (port sheet) sheet mirror))
645
646 (defmethod sheet-mirrored-ancestor ((sheet mirrored-sheet-mixin))
647 sheet)
648
649 (defmethod sheet-mirror ((sheet mirrored-sheet-mixin))
650 (sheet-direct-mirror sheet))
651
652 (defmethod note-sheet-grafted :before ((sheet mirrored-sheet-mixin))
653 (unless (port sheet)
654 (error "~S called on sheet ~S, which has no port?!" 'note-sheet-grafted sheet))
655 (realize-mirror (port sheet) sheet))
656
657 (defmethod note-sheet-degrafted :after ((sheet mirrored-sheet-mixin))
658 (destroy-mirror (port sheet) sheet))
659
660 (defmethod (setf sheet-region) :after (region (sheet mirrored-sheet-mixin))
661 (port-set-sheet-region (port sheet) sheet region))
662
663 (defmethod (setf sheet-transformation) :after (transformation (sheet mirrored-sheet-mixin))
664 (port-set-sheet-transformation (port sheet) sheet transformation))
665
666 (defmethod sheet-native-transformation ((sheet mirrored-sheet-mixin))
667 (with-slots (native-transformation) sheet
668 (unless native-transformation
669 (setf native-transformation
670 (compose-transformations
671 (invert-transformation
672 (mirror-transformation (port sheet)
673 (sheet-direct-mirror sheet)))
674 (compose-transformations
675 (sheet-native-transformation (sheet-parent sheet))
676 (sheet-transformation sheet)))))
677 native-transformation))
678
679 (defmethod sheet-native-region ((sheet mirrored-sheet-mixin))
680 (with-slots (native-region) sheet
681 (unless native-region
682 (setf native-region
683 (region-intersection
684 (transform-region
685 (sheet-native-transformation sheet)
686 (sheet-region sheet))
687 (transform-region
688 (invert-transformation
689 (mirror-transformation (port sheet)
690 (sheet-direct-mirror sheet)))
691 (sheet-native-region (sheet-parent sheet))))))
692 native-region))
693
694 ;;; Sheets as bounding rectangles
695
696 ;; Somewhat hidden in the spec, we read (section 4.1.1 "The Bounding
697 ;; Rectangle Protocol")
698 ;;
699
700 ;; | bounding-rectangle* region [Generic Function]
701 ;; |
702 ;; | [...] The argument region must be either a bounded region [...] or
703 ;; | some other object that obeys the bounding rectangle protocol, such
704 ;; | as a sheet or an output record. [...]
705
706 (defmethod bounding-rectangle* ((sheet sheet))
707 (bounding-rectangle* (sheet-region sheet)))
708
709 ;;; The null sheet
710
711 (defclass null-sheet (basic-sheet) ())
712

  ViewVC Help
Powered by ViewVC 1.1.5