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

Contents of /mcclim/sheets.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.28 - (hide annotations)
Sun Apr 21 18:46:26 2002 UTC (11 years, 11 months ago) by moore
Branch: MAIN
Changes since 1.27: +1 -1 lines
Remove reference to sb-pcl in sheet-adopt-child.

Add the medium- accessors for sheets.

Get Goatee to compile.
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 gilbert 1.23 ;;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 boninfan 1.15
104 cvs 1.4 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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 rouanet 1.19 (defgeneric handle-repaint (sheet region))
127 cvs 1.4 (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 mikemac 1.1
146 gilbert 1.25 (define-protocol-class sheet (bounding-rectangle)
147 rouanet 1.19 ())
148    
149     (defclass basic-sheet (sheet)
150 boninfan 1.15 ((region :type region
151     :initarg :region
152 cvs 1.12 :initform (make-bounding-rectangle 0 0 100 100)
153     :accessor sheet-region)
154 rouanet 1.20 (native-transformation :type transformation
155     :initform nil)
156 boninfan 1.15 (native-region :type region
157 rouanet 1.20 :initform nil)
158     (device-transformation :type transformation
159     :initform nil)
160     (device-region :type region
161     :initform nil)
162 boninfan 1.15 (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 mikemac 1.1
166 rouanet 1.19 (defmethod sheet-parent ((sheet basic-sheet))
167 mikemac 1.1 nil)
168    
169 rouanet 1.19 (defmethod sheet-children ((sheet basic-sheet))
170 mikemac 1.1 nil)
171    
172 rouanet 1.19 (defmethod sheet-adopt-child ((sheet basic-sheet) (child sheet))
173 gilbert 1.26 (error "~S attempting to adopt ~S" sheet child))
174 mikemac 1.1
175 rouanet 1.19 (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 cvs 1.4 (define-condition sheet-is-not-child (error) ())
181    
182 rouanet 1.19 (defmethod sheet-disown-child :before ((sheet basic-sheet) (child sheet) &key (errorp t))
183     (when (and (not (member child (sheet-children sheet))) errorp)
184 mikemac 1.1 (error 'sheet-is-not-child)))
185    
186 rouanet 1.19 (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 mikemac 1.1 (remove sheet (sheet-children (sheet-parent sheet))))
196    
197 rouanet 1.19 (defmethod sheet-enabled-children ((sheet basic-sheet))
198 cvs 1.4 (delete-if-not #'sheet-enabled-p (copy-list (sheet-children sheet))))
199 mikemac 1.1
200 rouanet 1.19 (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 mikemac 1.1
206 rouanet 1.19 (defmethod raise-sheet ((sheet basic-sheet))
207     (error 'sheet-is-not-child))
208 mikemac 1.1
209 rouanet 1.19 (defmethod bury-sheet ((sheet basic-sheet))
210     (error 'sheet-is-not-child))
211 mikemac 1.1
212 cvs 1.4 (define-condition sheet-ordering-underspecified (error) ())
213 mikemac 1.1
214 rouanet 1.19 (defmethod reorder-sheets ((sheet basic-sheet) new-ordering)
215 cvs 1.4 (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 mikemac 1.1 sheet)
221    
222 rouanet 1.19 (defmethod sheet-viewable-p ((sheet basic-sheet))
223 cvs 1.4 (and (sheet-parent sheet)
224     (sheet-viewable-p (sheet-parent sheet))
225     (sheet-enabled-p sheet)))
226 mikemac 1.1
227 rouanet 1.19 (defmethod sheet-occluding-sheets ((sheet basic-sheet) (child sheet))
228 cvs 1.4 (labels ((fun (l)
229     (cond ((eq (car l) child) '())
230 rouanet 1.19 ((and (sheet-enabled-p (car l))
231     (region-intersects-region-p
232     (sheet-region (car l)) (sheet-region child)))
233 cvs 1.4 (cons (car l) (fun (cdr l))))
234     (t (fun (cdr l))))))
235     (fun (sheet-children sheet))))
236 mikemac 1.1
237 rouanet 1.19 (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 cvs 1.4 (error "Attempting to get the TRANSFORMATION of a SHEET that doesn't contain one"))
251 mikemac 1.1
252 rouanet 1.19 (defmethod (setf sheet-transformation) (transformation (sheet basic-sheet))
253 cvs 1.4 (declare (ignore transformation))
254     (error "Attempting to set the TRANSFORMATION of a SHEET that doesn't contain one"))
255 mikemac 1.1
256 rouanet 1.19 (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 cvs 1.4 (declare (ignore x y))
274     (error "Sheet has no parent"))
275 mikemac 1.1
276 rouanet 1.19 (defmethod map-sheet-position-to-child ((sheet basic-sheet) x y)
277 cvs 1.4 (declare (ignore x y))
278     (error "Sheet has no parent"))
279 mikemac 1.1
280 rouanet 1.19 (defmethod map-sheet-rectangle*-to-parent ((sheet basic-sheet) x1 y1 x2 y2)
281 cvs 1.4 (declare (ignore x1 y1 x2 y2))
282     (error "Sheet has no parent"))
283 mikemac 1.1
284 rouanet 1.19 (defmethod map-sheet-rectangle*-to-child ((sheet basic-sheet) x1 y1 x2 y2)
285 cvs 1.4 (declare (ignore x1 y1 x2 y2))
286     (error "Sheet has no parent"))
287 mikemac 1.1
288 rouanet 1.19 (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 mikemac 1.1 (loop for child in (sheet-children sheet)
309     do (multiple-value-bind (tx ty) (map-sheet-position-to-child child x y)
310 cvs 1.4 (if (and (sheet-enabled-p child)
311     (region-contains-position-p (sheet-region child) tx ty))
312     (return child)))))
313 mikemac 1.1
314 rouanet 1.19 (defmethod children-overlapping-region ((sheet basic-sheet) (region region))
315 mikemac 1.1 (loop for child in (sheet-children sheet)
316     if (and (sheet-enabled-p child)
317 cvs 1.4 (region-intersects-region-p
318     region
319     (transform-region (sheet-transformation child)
320     (sheet-region child))))
321 mikemac 1.1 collect child))
322    
323 rouanet 1.19 (defmethod children-overlapping-rectangle* ((sheet basic-sheet) x1 y1 x2 y2)
324 cvs 1.4 (children-overlapping-region sheet (make-rectangle* x1 y1 x2 y2)))
325 mikemac 1.1
326 rouanet 1.19 (defmethod sheet-delta-transformation ((sheet basic-sheet) (ancestor (eql nil)))
327 cvs 1.4 (cond ((sheet-parent sheet)
328     (compose-transformations (sheet-transformation sheet)
329     (sheet-delta-transformation
330     (sheet-parent sheet) ancestor)))
331 cvs 1.12 (t +identity-transformation+)))
332 cvs 1.2
333     (define-condition sheet-is-not-ancestor (error) ())
334    
335 rouanet 1.19 (defmethod sheet-delta-transformation ((sheet basic-sheet) (ancestor sheet))
336 cvs 1.2 (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 mikemac 1.1
343 rouanet 1.19 (defmethod sheet-allocated-region ((sheet basic-sheet) (child sheet))
344 cvs 1.4 (reduce #'region-difference
345 rouanet 1.19 (mapcar #'(lambda (child)
346     (transform-region (sheet-transformation child)
347     (sheet-region child)))
348     (cons child (sheet-occluding-sheets sheet child)))))
349 cvs 1.4
350 rouanet 1.19 (defmethod sheet-direct-mirror ((sheet basic-sheet))
351 cvs 1.4 nil)
352    
353 rouanet 1.19 (defmethod sheet-mirrored-ancestor ((sheet basic-sheet))
354 cvs 1.4 (if (sheet-parent sheet)
355     (sheet-mirrored-ancestor (sheet-parent sheet))))
356 mikemac 1.1
357 rouanet 1.19 (defmethod sheet-mirror ((sheet basic-sheet))
358 cvs 1.4 (let ((mirrored-ancestor (sheet-mirrored-ancestor sheet)))
359     (if mirrored-ancestor
360     (sheet-direct-mirror mirrored-ancestor))))
361    
362 rouanet 1.19 (defmethod graft ((sheet basic-sheet))
363 cvs 1.4 nil)
364    
365 rouanet 1.19 (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 cvs 1.4
371 rouanet 1.19 (defmethod note-sheet-adopted ((sheet basic-sheet))
372 cvs 1.4 nil)
373    
374 rouanet 1.19 (defmethod note-sheet-disowned ((sheet basic-sheet))
375 cvs 1.4 nil)
376    
377 rouanet 1.19 (defmethod note-sheet-enabled ((sheet basic-sheet))
378     (mapc #'note-sheet-enabled (sheet-children sheet)))
379 cvs 1.4
380 rouanet 1.19 (defmethod note-sheet-disabled ((sheet basic-sheet))
381     (mapc #'note-sheet-disabled (sheet-children sheet)))
382 cvs 1.4
383 rouanet 1.19 (defmethod note-sheet-region-changed ((sheet basic-sheet))
384 cvs 1.4 nil) ;have to change
385    
386 rouanet 1.19 (defmethod note-sheet-transformation-changed ((sheet basic-sheet))
387 cvs 1.4 nil)
388    
389 rouanet 1.20 (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 boninfan 1.15 (with-slots (native-region) sheet
403     (unless native-region
404 rouanet 1.20 (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 boninfan 1.15
423 rouanet 1.19 (defmethod sheet-device-region ((sheet basic-sheet))
424 rouanet 1.20 (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 boninfan 1.15
437 rouanet 1.20 (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 boninfan 1.15
444 rouanet 1.19 (defmethod invalidate-cached-regions ((sheet basic-sheet))
445 rouanet 1.20 (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 boninfan 1.15
457 rouanet 1.19 (defmethod (setf sheet-region) :after (region (sheet basic-sheet))
458 boninfan 1.15 (declare (ignore region))
459 boninfan 1.16 (note-sheet-region-changed sheet)
460 boninfan 1.15 (invalidate-cached-regions sheet))
461    
462    
463 cvs 1.4 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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 rouanet 1.19 (declare (ignore sheet errorp))
485     (setf (sheet-parent child) nil))
486 cvs 1.4
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 rouanet 1.19 (untransform-position (sheet-transformation sheet) x y))
509 cvs 1.4
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 rouanet 1.19 (untransform-rectangle* (sheet-transformation sheet) x1 y1 x2 y2))
515 cvs 1.4
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 moore 1.28 (describe (class-of sheet) *debug-io*)
527 cvs 1.4 (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 rouanet 1.19 ((child :initform nil :accessor sheet-child)))
540    
541     (defmethod sheet-children ((sheet sheet-single-child-mixin))
542     (list (sheet-child sheet)))
543 cvs 1.4
544     (define-condition sheet-supports-only-one-child (error) ())
545    
546     (defmethod sheet-adopt-child :before ((sheet sheet-single-child-mixin)
547 rouanet 1.19 (child sheet-parent-mixin))
548     (when (sheet-child sheet)
549     (error 'sheet-supports-only-one-child)))
550 cvs 1.4
551     (defmethod sheet-adopt-child ((sheet sheet-single-child-mixin)
552     (child sheet-parent-mixin))
553 rouanet 1.19 (setf (sheet-child sheet) child))
554 cvs 1.4
555     (defmethod sheet-disown-child ((sheet sheet-single-child-mixin)
556     (child sheet-parent-mixin)
557     &key (errorp t))
558 cvs 1.12 (declare (ignore errorp))
559 rouanet 1.19 (setf (sheet-child sheet) nil))
560 cvs 1.4
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 cvs 1.12 (declare (ignore errorp))
585 cvs 1.4 (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 mikemac 1.1
600 rouanet 1.20 (defclass sheet-identity-transformation-mixin ()
601     ())
602 boninfan 1.15
603 rouanet 1.20 (defmethod sheet-transformation ((sheet sheet-identity-transformation-mixin))
604     +identity-transformation+)
605 boninfan 1.15
606 rouanet 1.20 (defclass sheet-transformation-mixin ()
607 cvs 1.3 ((transformation :initform +identity-transformation+
608 mikemac 1.1 :initarg :transformation
609 cvs 1.4 :accessor sheet-transformation)))
610 mikemac 1.1
611 rouanet 1.19 (defclass sheet-translation-transformation-mixin (sheet-transformation-mixin)
612     ())
613    
614 cvs 1.4 (defmethod (setf sheet-transformation) :before ((transformation transformation)
615     (sheet sheet-translation-transformation-mixin))
616 mikemac 1.1 (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 rouanet 1.19 (defclass sheet-y-inverting-transformation-mixin (sheet-transformation-mixin)
620     ()
621     (:default-initargs :transformation (make-transformation 1 0 0 -1 0 0)))
622 mikemac 1.1
623 cvs 1.4 (defmethod (setf sheet-transformation) :before ((transformation transformation)
624     (sheet sheet-y-inverting-transformation-mixin))
625 mikemac 1.1 (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 cvs 1.4
629     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
630     ;;;
631     ;;; mirrored sheet
632 mikemac 1.1
633 rouanet 1.18 (defclass mirrored-sheet-mixin ()
634 gilbert 1.24 ((port :initform nil :initarg :port :accessor port)
635     (mirror-transformation
636     :initform nil
637     :accessor sheet-mirror-transformation
638     )))
639 mikemac 1.1
640 rouanet 1.18 (defmethod sheet-direct-mirror ((sheet mirrored-sheet-mixin))
641 mikemac 1.1 (port-lookup-mirror (port sheet) sheet))
642    
643 rouanet 1.18 (defmethod (setf sheet-direct-mirror) (mirror (sheet mirrored-sheet-mixin))
644 boninfan 1.14 (port-register-mirror (port sheet) sheet mirror))
645    
646 rouanet 1.18 (defmethod sheet-mirrored-ancestor ((sheet mirrored-sheet-mixin))
647 mikemac 1.1 sheet)
648    
649 rouanet 1.18 (defmethod sheet-mirror ((sheet mirrored-sheet-mixin))
650     (sheet-direct-mirror sheet))
651    
652     (defmethod note-sheet-grafted :before ((sheet mirrored-sheet-mixin))
653 gilbert 1.24 (unless (port sheet)
654     (error "~S called on sheet ~S, which has no port?!" 'note-sheet-grafted sheet))
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))
693 gilbert 1.25
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 gilbert 1.26
709     ;;; The null sheet
710    
711     (defclass null-sheet (basic-sheet) ())
712    

  ViewVC Help
Powered by ViewVC 1.1.5