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

Contents of /mcclim/sheets.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5