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

Contents of /mcclim/sheets.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5