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

Contents of /mcclim/sheets.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.20 - (show annotations)
Tue Sep 11 12:44:18 2001 UTC (12 years, 7 months ago) by rouanet
Branch: MAIN
Changes since 1.19: +103 -62 lines
Implemented the methods to compute the native transformation and region,
as well as the device transformation and region.

Added the mirror-transformation method.
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 (defgeneric sheet-native-region (sheet))
96 (defgeneric sheet-device-region (sheet))
97 (defgeneric invalidate-cached-regions (sheet))
98
99 (defgeneric sheet-native-transformation (sheet))
100 (defgeneric sheet-device-transformation (sheet))
101 (defgeneric invalidate-cached-transformations (sheet))
102
103 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
104 ;;;
105 ;;; input protocol
106
107 (defgeneric dispatch-event (client event))
108 (defgeneric queue-event (client event))
109 (defgeneric handle-event (client event))
110 (defgeneric event-read (client))
111 (defgeneric event-read-no-hang (client))
112 (defgeneric event-peek (client &optional event-type))
113 (defgeneric event-unread (client event))
114 (defgeneric event-listen (client))
115 (defgeneric sheet-direct-mirror (sheet))
116 (defgeneric sheet-mirrored-ancestor (sheet))
117 (defgeneric sheet-mirror (sheet))
118
119 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
120 ;;;
121 ;;; repaint protocol
122
123 (defgeneric dispatch-repaint (sheet region))
124 (defgeneric queue-repaint (sheet region))
125 (defgeneric handle-repaint (sheet region))
126 (defgeneric repaint-sheet (sheet region))
127
128 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
129 ;;;
130 ;;; notification protocol
131
132 (defgeneric note-sheet-grafted (sheet))
133 (defgeneric note-sheet-degrafted (sheet))
134 (defgeneric note-sheet-adopted (sheet))
135 (defgeneric note-sheet-disowned (sheet))
136 (defgeneric note-sheet-enabled (sheet))
137 (defgeneric note-sheet-disabled (sheet))
138 (defgeneric note-sheet-region-changed (sheet))
139 (defgeneric note-sheet-transformation-changed (sheet))
140
141 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
142 ;;;;
143 ;;;; sheet protocol class
144
145 (defclass sheet ()
146 ())
147
148 (defun sheetp (x)
149 (typep x 'sheet))
150
151 (defclass basic-sheet (sheet)
152 ((region :type region
153 :initarg :region
154 :initform (make-bounding-rectangle 0 0 100 100)
155 :accessor sheet-region)
156 (native-transformation :type transformation
157 :initform nil)
158 (native-region :type region
159 :initform nil)
160 (device-transformation :type transformation
161 :initform nil)
162 (device-region :type region
163 :initform nil)
164 (enabled-p :type boolean :initform nil :accessor sheet-enabled-p)))
165 ; Native region is volatile, and is only computed at the first request when it's equal to nil.
166 ; Invalidate-cached-region method sets the native-region to nil.
167
168 (defmethod sheet-parent ((sheet basic-sheet))
169 nil)
170
171 (defmethod sheet-children ((sheet basic-sheet))
172 nil)
173
174 (defmethod sheet-adopt-child ((sheet basic-sheet) (child sheet))
175 (error "SHEET attempting to adopt a child"))
176
177 (defmethod sheet-adopt-child :after ((sheet basic-sheet) (child sheet))
178 (note-sheet-adopted child)
179 (when (sheet-grafted-p sheet)
180 (note-sheet-grafted child)))
181
182 (define-condition sheet-is-not-child (error) ())
183
184 (defmethod sheet-disown-child :before ((sheet basic-sheet) (child sheet) &key (errorp t))
185 (when (and (not (member child (sheet-children sheet))) errorp)
186 (error 'sheet-is-not-child)))
187
188 (defmethod sheet-disown-child :after ((sheet basic-sheet) (child sheet) &key (errorp t))
189 (declare (ignore errorp))
190 (note-sheet-disowned child)
191 (when (sheet-grafted-p sheet)
192 (note-sheet-degrafted child)))
193
194 (defmethod sheet-siblings ((sheet basic-sheet))
195 (when (not (sheet-parent sheet))
196 (error 'sheet-is-not-child))
197 (remove sheet (sheet-children (sheet-parent sheet))))
198
199 (defmethod sheet-enabled-children ((sheet basic-sheet))
200 (delete-if-not #'sheet-enabled-p (copy-list (sheet-children sheet))))
201
202 (defmethod sheet-ancestor-p ((sheet basic-sheet)
203 (putative-ancestor sheet))
204 (or (eq sheet putative-ancestor)
205 (and (sheet-parent sheet)
206 (sheet-ancestor-p (sheet-parent sheet) putative-ancestor))))
207
208 (defmethod raise-sheet ((sheet basic-sheet))
209 (error 'sheet-is-not-child))
210
211 (defmethod bury-sheet ((sheet basic-sheet))
212 (error 'sheet-is-not-child))
213
214 (define-condition sheet-ordering-underspecified (error) ())
215
216 (defmethod reorder-sheets ((sheet basic-sheet) new-ordering)
217 (when (set-difference (sheet-children sheet) new-ordering)
218 (error 'sheet-ordering-underspecified))
219 (when (set-difference new-ordering (sheet-children sheet))
220 (error 'sheet-is-not-child))
221 (setf (sheet-children sheet) new-ordering)
222 sheet)
223
224 (defmethod sheet-viewable-p ((sheet basic-sheet))
225 (and (sheet-parent sheet)
226 (sheet-viewable-p (sheet-parent sheet))
227 (sheet-enabled-p sheet)))
228
229 (defmethod sheet-occluding-sheets ((sheet basic-sheet) (child sheet))
230 (labels ((fun (l)
231 (cond ((eq (car l) child) '())
232 ((and (sheet-enabled-p (car l))
233 (region-intersects-region-p
234 (sheet-region (car l)) (sheet-region child)))
235 (cons (car l) (fun (cdr l))))
236 (t (fun (cdr l))))))
237 (fun (sheet-children sheet))))
238
239 (defmethod map-over-sheets (function (sheet basic-sheet))
240 (declare (dynamic-extent function))
241 (funcall function sheet)
242 (mapc #'(lambda (child) (map-over-sheets function child))
243 (sheet-children sheet))
244 nil)
245
246 (defmethod (setf sheet-enabled-p) :after (enabled-p (sheet basic-sheet))
247 (if enabled-p
248 (note-sheet-enabled sheet)
249 (note-sheet-disabled sheet)))
250
251 (defmethod sheet-transformation ((sheet basic-sheet))
252 (error "Attempting to get the TRANSFORMATION of a SHEET that doesn't contain one"))
253
254 (defmethod (setf sheet-transformation) (transformation (sheet basic-sheet))
255 (declare (ignore transformation))
256 (error "Attempting to set the TRANSFORMATION of a SHEET that doesn't contain one"))
257
258 (defmethod move-sheet ((sheet basic-sheet) x y)
259 (let ((transform (sheet-transformation sheet)))
260 (multiple-value-bind (old-x old-y)
261 (transform-position transform 0 0)
262 (setf (sheet-transformation sheet)
263 (compose-translation-with-transformation
264 transform (- x old-x) (- y old-y))))))
265
266 (defmethod resize-sheet ((sheet basic-sheet) width height)
267 (setf (sheet-region sheet)
268 (make-bounding-rectangle 0 0 width height)))
269
270 (defmethod move-and-resize-sheet ((sheet basic-sheet) x y width height)
271 (move-sheet sheet x y)
272 (resize-sheet sheet width height))
273
274 (defmethod map-sheet-position-to-parent ((sheet basic-sheet) x y)
275 (declare (ignore x y))
276 (error "Sheet has no parent"))
277
278 (defmethod map-sheet-position-to-child ((sheet basic-sheet) x y)
279 (declare (ignore x y))
280 (error "Sheet has no parent"))
281
282 (defmethod map-sheet-rectangle*-to-parent ((sheet basic-sheet) x1 y1 x2 y2)
283 (declare (ignore x1 y1 x2 y2))
284 (error "Sheet has no parent"))
285
286 (defmethod map-sheet-rectangle*-to-child ((sheet basic-sheet) x1 y1 x2 y2)
287 (declare (ignore x1 y1 x2 y2))
288 (error "Sheet has no parent"))
289
290 (defmethod map-over-sheets-containing-position (function (sheet basic-sheet) x y)
291 (declare (dynamic-extent function))
292 (map-over-sheets #'(lambda (child)
293 (multiple-value-bind (tx ty) (map-sheet-position-to-child child x y)
294 (when (region-contains-position-p (sheet-region child) tx ty)
295 (funcall function child))))
296 sheet))
297
298
299 (defmethod map-over-sheets-overlapping-region (function (sheet basic-sheet) region)
300 (declare (dynamic-extent function))
301 (map-over-sheets #'(lambda (child)
302 (when (region-intersects-region-p
303 region
304 (transform-region (sheet-transformation child)
305 (sheet-region child)))
306 (funcall function child)))
307 sheet))
308
309 (defmethod child-containing-position ((sheet basic-sheet) x y)
310 (loop for child in (sheet-children sheet)
311 do (multiple-value-bind (tx ty) (map-sheet-position-to-child child x y)
312 (if (and (sheet-enabled-p child)
313 (region-contains-position-p (sheet-region child) tx ty))
314 (return child)))))
315
316 (defmethod children-overlapping-region ((sheet basic-sheet) (region region))
317 (loop for child in (sheet-children sheet)
318 if (and (sheet-enabled-p child)
319 (region-intersects-region-p
320 region
321 (transform-region (sheet-transformation child)
322 (sheet-region child))))
323 collect child))
324
325 (defmethod children-overlapping-rectangle* ((sheet basic-sheet) x1 y1 x2 y2)
326 (children-overlapping-region sheet (make-rectangle* x1 y1 x2 y2)))
327
328 (defmethod sheet-delta-transformation ((sheet basic-sheet) (ancestor (eql nil)))
329 (cond ((sheet-parent sheet)
330 (compose-transformations (sheet-transformation sheet)
331 (sheet-delta-transformation
332 (sheet-parent sheet) ancestor)))
333 (t +identity-transformation+)))
334
335 (define-condition sheet-is-not-ancestor (error) ())
336
337 (defmethod sheet-delta-transformation ((sheet basic-sheet) (ancestor sheet))
338 (cond ((eq sheet ancestor) +identity-transformation+)
339 ((sheet-parent sheet)
340 (compose-transformations (sheet-transformation sheet)
341 (sheet-delta-transformation
342 (sheet-parent sheet) ancestor)))
343 (t (error 'sheet-is-not-ancestor))))
344
345 (defmethod sheet-allocated-region ((sheet basic-sheet) (child sheet))
346 (reduce #'region-difference
347 (mapcar #'(lambda (child)
348 (transform-region (sheet-transformation child)
349 (sheet-region child)))
350 (cons child (sheet-occluding-sheets sheet child)))))
351
352 (defmethod sheet-direct-mirror ((sheet basic-sheet))
353 nil)
354
355 (defmethod sheet-mirrored-ancestor ((sheet basic-sheet))
356 (if (sheet-parent sheet)
357 (sheet-mirrored-ancestor (sheet-parent sheet))))
358
359 (defmethod sheet-mirror ((sheet basic-sheet))
360 (let ((mirrored-ancestor (sheet-mirrored-ancestor sheet)))
361 (if mirrored-ancestor
362 (sheet-direct-mirror mirrored-ancestor))))
363
364 (defmethod graft ((sheet basic-sheet))
365 nil)
366
367 (defmethod note-sheet-grafted ((sheet basic-sheet))
368 (mapc #'note-sheet-grafted (sheet-children sheet)))
369
370 (defmethod note-sheet-degrafted ((sheet basic-sheet))
371 (mapc #'note-sheet-degrafted (sheet-children sheet)))
372
373 (defmethod note-sheet-adopted ((sheet basic-sheet))
374 nil)
375
376 (defmethod note-sheet-disowned ((sheet basic-sheet))
377 nil)
378
379 (defmethod note-sheet-enabled ((sheet basic-sheet))
380 (mapc #'note-sheet-enabled (sheet-children sheet)))
381
382 (defmethod note-sheet-disabled ((sheet basic-sheet))
383 (mapc #'note-sheet-disabled (sheet-children sheet)))
384
385 (defmethod note-sheet-region-changed ((sheet basic-sheet))
386 nil) ;have to change
387
388 (defmethod note-sheet-transformation-changed ((sheet basic-sheet))
389 nil)
390
391 (defmethod sheet-native-transformation ((sheet basic-sheet))
392 (with-slots (native-transformation) sheet
393 (unless native-transformation
394 (setf native-transformation
395 (let ((parent (sheet-parent sheet)))
396 (if parent
397 (compose-transformations
398 (sheet-native-transformation parent)
399 (sheet-transformation sheet))
400 +identity-transformation+))))
401 native-transformation))
402
403 (defmethod sheet-native-region ((sheet basic-sheet))
404 (with-slots (native-region) sheet
405 (unless native-region
406 (setf native-region (region-intersection
407 (transform-region
408 (sheet-native-transformation sheet)
409 (sheet-region sheet))
410 (sheet-native-region (sheet-parent sheet)))))
411 native-region))
412
413 (defmethod sheet-device-transformation ((sheet basic-sheet))
414 (with-slots (device-transformation) sheet
415 (unless device-transformation
416 (setf device-transformation
417 (let ((medium (sheet-medium sheet)))
418 (compose-transformations
419 (sheet-native-transformation sheet)
420 (if medium
421 (medium-transformation medium)
422 +identity-transformation+)))))
423 device-transformation))
424
425 (defmethod sheet-device-region ((sheet basic-sheet))
426 (with-slots (device-region) sheet
427 (unless device-region
428 (setf device-region
429 (let ((medium (sheet-medium sheet)))
430 (region-intersection
431 (sheet-native-region sheet)
432 (if medium
433 (transform-region
434 (sheet-device-transformation sheet)
435 (medium-clipping-region medium))
436 +everywhere+)))))
437 device-region))
438
439 (defmethod invalidate-cached-transformations ((sheet basic-sheet))
440 (with-slots (native-transformation device-transformation) sheet
441 (setf native-transformation nil
442 device-transformation nil))
443 (loop for child in (sheet-children sheet)
444 do (invalidate-cached-transformations child)))
445
446 (defmethod invalidate-cached-regions ((sheet basic-sheet))
447 (with-slots (native-region device-region) sheet
448 (setf native-region nil
449 device-region nil))
450 (loop for child in (sheet-children sheet)
451 do (invalidate-cached-regions child)))
452
453 (defmethod (setf sheet-transformation) :after (transformation (sheet basic-sheet))
454 (declare (ignore transformation))
455 (note-sheet-transformation-changed sheet)
456 (invalidate-cached-transformations sheet)
457 (invalidate-cached-regions sheet))
458
459 (defmethod (setf sheet-region) :after (region (sheet basic-sheet))
460 (declare (ignore region))
461 (note-sheet-region-changed sheet)
462 (invalidate-cached-regions sheet))
463
464
465 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
466 ;;;
467 ;;; sheet parent mixin
468
469
470 (defclass sheet-parent-mixin ()
471 ((parent :initform nil :accessor sheet-parent)))
472
473 (define-condition sheet-already-has-parent (error) ())
474 (define-condition sheet-is-ancestor (error) ())
475
476 (defmethod sheet-adopt-child :before (sheet (child sheet-parent-mixin))
477 (when (sheet-parent child) (error 'sheet-already-has-parent))
478 (when (sheet-ancestor-p sheet child) (error 'sheet-is-ancestor)))
479
480 (defmethod sheet-adopt-child :after (sheet (child sheet-parent-mixin))
481 (setf (sheet-parent child) sheet))
482
483 (defmethod sheet-disown-child :after (sheet
484 (child sheet-parent-mixin)
485 &key (errorp t))
486 (declare (ignore sheet errorp))
487 (setf (sheet-parent child) nil))
488
489 (defmethod raise-sheet ((sheet sheet-parent-mixin))
490 (when (not (sheet-parent sheet))
491 (error 'sheet-is-not-child))
492 (raise-sheet-internal sheet (sheet-parent sheet)))
493
494 (defmethod bury-sheet ((sheet sheet-parent-mixin))
495 (when (not (sheet-parent sheet))
496 (error 'sheet-is-not-child))
497 (bury-sheet-internal sheet (sheet-parent sheet)))
498
499 (defmethod graft ((sheet sheet-parent-mixin))
500 (graft (sheet-parent sheet)))
501
502 (defmethod (setf sheet-transformation) :after (newvalue (sheet sheet-parent-mixin))
503 (declare (ignore newvalue))
504 (note-sheet-transformation-changed sheet))
505
506 (defmethod map-sheet-position-to-parent ((sheet sheet-parent-mixin) x y)
507 (transform-position (sheet-transformation sheet) x y))
508
509 (defmethod map-sheet-position-to-child ((sheet sheet-parent-mixin) x y)
510 (untransform-position (sheet-transformation sheet) x y))
511
512 (defmethod map-sheet-rectangle*-to-parent ((sheet sheet-parent-mixin) x1 y1 x2 y2)
513 (transform-rectangle* (sheet-transformation sheet) x1 y1 x2 y2))
514
515 (defmethod map-sheet-rectangle*-to-child ((sheet sheet-parent-mixin) x1 y1 x2 y2)
516 (untransform-rectangle* (sheet-transformation sheet) x1 y1 x2 y2))
517
518 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
519 ;;;
520 ;;; sheet leaf mixin
521
522 (defclass sheet-leaf-mixin () ())
523
524 (defmethod sheet-children ((sheet sheet-leaf-mixin))
525 nil)
526
527 (defmethod sheet-adopt-child ((sheet sheet-leaf-mixin) (child sheet))
528 (error "Leaf sheet attempting to adopt a child"))
529
530 (defmethod sheet-disown-child ((sheet sheet-leaf-mixin) (child sheet) &key (errorp t))
531 (declare (ignorable errorp))
532 (error "Leaf sheet attempting to disown a child"))
533
534
535 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
536 ;;;
537 ;;; sheet single child mixin
538
539 (defclass sheet-single-child-mixin ()
540 ((child :initform nil :accessor sheet-child)))
541
542 (defmethod sheet-children ((sheet sheet-single-child-mixin))
543 (list (sheet-child sheet)))
544
545 (define-condition sheet-supports-only-one-child (error) ())
546
547 (defmethod sheet-adopt-child :before ((sheet sheet-single-child-mixin)
548 (child sheet-parent-mixin))
549 (when (sheet-child sheet)
550 (error 'sheet-supports-only-one-child)))
551
552 (defmethod sheet-adopt-child ((sheet sheet-single-child-mixin)
553 (child sheet-parent-mixin))
554 (setf (sheet-child sheet) child))
555
556 (defmethod sheet-disown-child ((sheet sheet-single-child-mixin)
557 (child sheet-parent-mixin)
558 &key (errorp t))
559 (declare (ignore errorp))
560 (setf (sheet-child sheet) nil))
561
562 (defmethod raise-sheet-internal (sheet (parent sheet-single-child-mixin))
563 (declare (ignorable sheet parent))
564 (values))
565
566 (defmethod bury-sheet-internal (sheet (parent sheet-single-child-mixin))
567 (declare (ignorable sheet parent))
568 (values))
569
570
571 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
572 ;;;
573 ;;; sheet multiple child mixin
574
575 (defclass sheet-multiple-child-mixin ()
576 ((children :initform nil :initarg :children :accessor sheet-children)))
577
578 (defmethod sheet-adopt-child ((sheet sheet-multiple-child-mixin)
579 (child sheet-parent-mixin))
580 (push child (sheet-children sheet)))
581
582 (defmethod sheet-disown-child ((sheet sheet-multiple-child-mixin)
583 (child sheet-parent-mixin)
584 &key (errorp t))
585 (declare (ignore errorp))
586 (setf (sheet-children sheet) (delete child (sheet-children sheet))))
587
588 (defmethod raise-sheet-internal (sheet (parent sheet-multiple-child-mixin))
589 (setf (sheet-children parent)
590 (cons sheet (delete sheet (sheet-children parent)))))
591
592 (defmethod bury-sheet-internal (sheet (parent sheet-multiple-child-mixin))
593 (setf (sheet-children parent)
594 (append (delete sheet (sheet-children parent)) (list sheet))))
595
596
597 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
598 ;;;
599 ;;; sheet geometry classes
600
601 (defclass sheet-identity-transformation-mixin ()
602 ())
603
604 (defmethod sheet-transformation ((sheet sheet-identity-transformation-mixin))
605 +identity-transformation+)
606
607 (defclass sheet-transformation-mixin ()
608 ((transformation :initform +identity-transformation+
609 :initarg :transformation
610 :accessor sheet-transformation)))
611
612 (defclass sheet-translation-transformation-mixin (sheet-transformation-mixin)
613 ())
614
615 (defmethod (setf sheet-transformation) :before ((transformation transformation)
616 (sheet sheet-translation-transformation-mixin))
617 (if (not (translation-transformation-p transformation))
618 (error "Attempting to set the SHEET-TRANSFORMATION of a SHEET-TRANSLATION-TRANSFORMATION-MIXIN to a non translation transformation")))
619
620 (defclass sheet-y-inverting-transformation-mixin (sheet-transformation-mixin)
621 ()
622 (:default-initargs :transformation (make-transformation 1 0 0 -1 0 0)))
623
624 (defmethod (setf sheet-transformation) :before ((transformation transformation)
625 (sheet sheet-y-inverting-transformation-mixin))
626 (if (not (y-inverting-transformation-p transformation))
627 (error "Attempting to set the SHEET-TRANSFORMATION of a SHEET-Y-INVERTING-TRANSFORMATION-MIXIN to a non Y inverting transformation")))
628
629
630 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
631 ;;;
632 ;;; mirrored sheet
633
634 (defclass mirrored-sheet-mixin ()
635 ((port :initform nil :initarg :port :accessor port)))
636
637 (defmethod sheet-direct-mirror ((sheet mirrored-sheet-mixin))
638 (port-lookup-mirror (port sheet) sheet))
639
640 (defmethod (setf sheet-direct-mirror) (mirror (sheet mirrored-sheet-mixin))
641 (port-register-mirror (port sheet) sheet mirror))
642
643 (defmethod sheet-mirrored-ancestor ((sheet mirrored-sheet-mixin))
644 sheet)
645
646 (defmethod sheet-mirror ((sheet mirrored-sheet-mixin))
647 (sheet-direct-mirror sheet))
648
649 (defmethod note-sheet-grafted :before ((sheet mirrored-sheet-mixin))
650 (realize-mirror (port sheet) sheet))
651
652 (defmethod note-sheet-degrafted :after ((sheet mirrored-sheet-mixin))
653 (destroy-mirror (port sheet) sheet))
654
655 (defmethod (setf sheet-region) :after (region (sheet mirrored-sheet-mixin))
656 (port-set-sheet-region (port sheet) sheet region))
657
658 (defmethod (setf sheet-transformation) :after (transformation (sheet mirrored-sheet-mixin))
659 (port-set-sheet-transformation (port sheet) sheet transformation))
660
661 (defmethod sheet-native-transformation ((sheet mirrored-sheet-mixin))
662 (with-slots (native-transformation) sheet
663 (unless native-transformation
664 (setf native-transformation
665 (compose-transformations
666 (invert-transformation
667 (mirror-transformation (port sheet)
668 (sheet-direct-mirror sheet)))
669 (compose-transformations
670 (sheet-native-transformation (sheet-parent sheet))
671 (sheet-transformation sheet)))))
672 native-transformation))
673
674 (defmethod sheet-native-region ((sheet mirrored-sheet-mixin))
675 (with-slots (native-region) sheet
676 (unless native-region
677 (setf native-region
678 (region-intersection
679 (transform-region
680 (sheet-native-transformation sheet)
681 (sheet-region sheet))
682 (transform-region
683 (invert-transformation
684 (mirror-transformation (port sheet)
685 (sheet-direct-mirror sheet)))
686 (sheet-native-region (sheet-parent sheet))))))
687 native-region))

  ViewVC Help
Powered by ViewVC 1.1.5