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

Contents of /mcclim/sheets.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5