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

Contents of /mcclim/sheets.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.18 - (hide annotations)
Thu Aug 23 23:18:11 2001 UTC (12 years, 8 months ago) by rouanet
Branch: MAIN
Changes since 1.17: +12 -9 lines
The former mirrored-sheet class is now mirrored-sheet-mixin.
Changed the name in the existing code and made the necessary
adaptations.

Renamed the unrealize-mirror function, which was previously only
used internally by CLIM, but is now publicly advertised in the spec
as destroy-mirror.
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 mikemac 1.1
9     ;;; This library is free software; you can redistribute it and/or
10     ;;; modify it under the terms of the GNU Library General Public
11     ;;; License as published by the Free Software Foundation; either
12     ;;; version 2 of the License, or (at your option) any later version.
13     ;;;
14     ;;; This library is distributed in the hope that it will be useful,
15     ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16     ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17     ;;; Library General Public License for more details.
18     ;;;
19     ;;; You should have received a copy of the GNU Library General Public
20     ;;; License along with this library; if not, write to the
21     ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22     ;;; Boston, MA 02111-1307 USA.
23    
24 cvs 1.4
25    
26     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
27     ;;;
28     ;;; The sheet protocol
29    
30 mikemac 1.1 (in-package :CLIM-INTERNALS)
31    
32 cvs 1.4 (defgeneric sheet-parent (sheet)
33     (:documentation
34     "Returns the parent of the sheet SHEET or nil if the sheet has
35     no parent"))
36    
37     (defgeneric sheet-children (sheet)
38     (:documentation
39     "Returns a list of sheets that are the children of the sheet SHEET.
40     Some sheet classes support only a single child; in this case, the
41     result of sheet-children will be a list of one element. This
42     function returns objects that reveal CLIM's internal state ; do not
43     modify those objects."))
44    
45     (defgeneric sheet-adopt-child (sheet child)
46     (:documentation
47     "Adds the child sheet child to the set of children of the sheet SHEET,
48     and makes the sheet the child's parent. If child already has a parent,
49     the sheet-already-has-parent error will be signalled.
50    
51     Some sheet classes support only a single child. For such sheets,
52     attempting to adopt more than a single child will cause the
53     sheet-supports-only-one-child error to be signalled."))
54    
55 cvs 1.9 (defgeneric sheet-disown-child (sheet child &key errorp))
56 cvs 1.4 (defgeneric sheet-enabled-children (sheet))
57     (defgeneric sheet-ancestor-p (sheet putative-ancestor))
58     (defgeneric raise-sheet (sheet))
59    
60     ;;; not for external use
61     (defgeneric raise-sheet-internal (sheet parent))
62    
63     (defgeneric bury-sheet (sheet))
64    
65     ;;; not for external use
66     (defgeneric bury-sheet-internal (sheet parent))
67    
68     (defgeneric reorder-sheets (sheet new-ordering))
69     (defgeneric sheet-enabled-p (sheet))
70     (defgeneric (setf sheet-enabled-p) (enabled-p sheet))
71     (defgeneric sheet-viewable-p (sheet))
72     (defgeneric sheet-occluding-sheets (sheet child))
73    
74     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
75     ;;;
76     ;;; Sheet geometry
77    
78     (defgeneric sheet-transformation (sheet))
79     (defgeneric (setf sheet-transformation) (transformation sheet))
80     (defgeneric sheet-region (sheet))
81     (defgeneric (setf sheet-region) (region sheet))
82     (defgeneric map-sheet-position-to-parent (sheet x y))
83     (defgeneric map-sheet-position-to-child (sheet x y))
84     (defgeneric map-sheet-rectangle*-to-parent (sheet x1 y1 x2 y2))
85     (defgeneric map-sheet-rectangle*-to-child (sheet x1 y1 x2 y2))
86     (defgeneric child-containing-position (sheet x y))
87     (defgeneric children-overlapping-region (sheet region))
88     (defgeneric children-overlapping-rectangle* (sheet x1 y1 x2 y2))
89     (defgeneric sheet-delta-transformation (sheet ancestor))
90     (defgeneric sheet-allocated-region (sheet child))
91    
92 boninfan 1.15 (defgeneric sheet-native-region (sheet))
93     (defgeneric sheet-device-region (sheet))
94     (defgeneric compute-native-region (sheet))
95     (defgeneric invalidate-cached-regions (sheet))
96    
97     (defgeneric sheet-native-transformation (sheet))
98     (defgeneric sheet-device-transformation (sheet))
99     (defgeneric compute-native-transformation (sheet))
100     (defgeneric invalidate-cached-transformations (sheet))
101    
102 cvs 1.4 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
103     ;;;
104     ;;; input protocol
105    
106     (defgeneric dispatch-event (client event))
107     (defgeneric queue-event (client event))
108     (defgeneric handle-event (client event))
109     (defgeneric event-read (client))
110     (defgeneric event-read-no-hang (client))
111     (defgeneric event-peek (client &optional event-type))
112     (defgeneric event-unread (client event))
113     (defgeneric event-listen (client))
114     (defgeneric sheet-direct-mirror (sheet))
115     (defgeneric sheet-mirrored-ancestor (sheet))
116     (defgeneric sheet-mirror (sheet))
117    
118     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
119     ;;;
120     ;;; repaint protocol
121    
122     (defgeneric dispatch-repaint (sheet region))
123     (defgeneric queue-repaint (sheet region))
124     (defgeneric handle-repaint (sheet medium region))
125     (defgeneric repaint-sheet (sheet region))
126    
127     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
128     ;;;
129     ;;; notification protocol
130    
131     (defgeneric note-sheet-grafted (sheet))
132     (defgeneric note-sheet-degrafted (sheet))
133     (defgeneric note-sheet-adopted (sheet))
134     (defgeneric note-sheet-disowned (sheet))
135     (defgeneric note-sheet-enabled (sheet))
136     (defgeneric note-sheet-disabled (sheet))
137     (defgeneric note-sheet-region-changed (sheet))
138     (defgeneric note-sheet-transformation-changed (sheet))
139    
140     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
141     ;;;;
142     ;;;; sheet protocol class
143 mikemac 1.1
144     (defclass sheet ()
145 boninfan 1.15 ((region :type region
146     :initarg :region
147 cvs 1.12 :initform (make-bounding-rectangle 0 0 100 100)
148     :accessor sheet-region)
149 boninfan 1.15 (native-region :type region
150     :initform nil
151     :accessor sheet-native-region)
152     (enabled-p :type boolean :initform nil :accessor sheet-enabled-p)))
153     ; Native region is volatile, and is only computed at the first request when it's equal to nil.
154     ; Invalidate-cached-region method sets the native-region to nil.
155 mikemac 1.1
156     (defun sheetp (x)
157     (typep x 'sheet))
158    
159     (defmethod sheet-parent ((sheet sheet))
160     nil)
161    
162     (defmethod set-sheets-parent ((sheet sheet) (parent sheet))
163     (error "Attempting to set the parent of a sheet that has no parent"))
164    
165     (defmethod sheet-children ((sheet sheet))
166     nil)
167    
168     (defmethod sheet-adopt-child ((sheet sheet) (child sheet))
169     (error "SHEET attempting to adopt a child"))
170    
171 cvs 1.4 (define-condition sheet-is-not-child (error) ())
172    
173 mikemac 1.1 (defmethod sheet-disown-child ((sheet sheet) (child sheet) &key (errorp t))
174 cvs 1.12 (when errorp
175 mikemac 1.1 (error 'sheet-is-not-child)))
176    
177     (defmethod sheet-siblings ((sheet sheet))
178     (remove sheet (sheet-children (sheet-parent sheet))))
179    
180     (defmethod sheet-enabled-children ((sheet sheet))
181 cvs 1.4 (delete-if-not #'sheet-enabled-p (copy-list (sheet-children sheet))))
182 mikemac 1.1
183     (defmethod sheet-ancestor-p ((sheet sheet) (putative-ancestor sheet))
184 cvs 1.4 (eq sheet putative-ancestor))
185 mikemac 1.1
186     (defmethod raise-sheet ((sheet sheet))
187 cvs 1.4 (setf (sheet-children sheet) (cons sheet (remove sheet (sheet-children sheet))))
188 mikemac 1.1 sheet)
189    
190     (defmethod bury-sheet ((sheet sheet))
191 cvs 1.4 (setf (sheet-children sheet) (nconc (remove sheet (sheet-children sheet)) (list sheet)))
192 mikemac 1.1 sheet)
193    
194 cvs 1.4 (define-condition sheet-ordering-underspecified (error) ())
195 mikemac 1.1
196     (defmethod reorder-sheets ((sheet sheet) new-ordering)
197 cvs 1.4 (when (set-difference (sheet-children sheet) new-ordering)
198     (error 'sheet-ordering-underspecified))
199     (when (set-difference new-ordering (sheet-children sheet))
200     (error 'sheet-is-not-child))
201     (setf (sheet-children sheet) new-ordering)
202 mikemac 1.1 sheet)
203    
204     (defmethod sheet-viewable-p ((sheet sheet))
205 cvs 1.4 (and (sheet-parent sheet)
206     (sheet-viewable-p (sheet-parent sheet))
207     (sheet-enabled-p sheet)))
208 mikemac 1.1
209     (defmethod sheet-occluding-sheets ((sheet sheet) (child sheet))
210 cvs 1.4 (labels ((fun (l)
211     (cond ((eq (car l) child) '())
212     ((region-intersects-region-p
213     (sheet-region (car l)) (sheet-region child))
214     (cons (car l) (fun (cdr l))))
215     (t (fun (cdr l))))))
216     (fun (sheet-children sheet))))
217 mikemac 1.1
218 cvs 1.4 (defmethod sheet-transformation ((sheet sheet))
219     (error "Attempting to get the TRANSFORMATION of a SHEET that doesn't contain one"))
220 mikemac 1.1
221 cvs 1.4 (defmethod (setf sheet-transformation) (transformation (sheet sheet))
222     (declare (ignore transformation))
223     (error "Attempting to set the TRANSFORMATION of a SHEET that doesn't contain one"))
224 mikemac 1.1
225     (defmethod map-sheet-position-to-parent ((sheet sheet) x y)
226 cvs 1.4 (declare (ignore x y))
227     (error "Sheet has no parent"))
228 mikemac 1.1
229     (defmethod map-sheet-position-to-child ((sheet sheet) x y)
230 cvs 1.4 (declare (ignore x y))
231     (error "Sheet has no parent"))
232 mikemac 1.1
233     (defmethod map-sheet-rectangle*-to-parent ((sheet sheet) x1 y1 x2 y2)
234 cvs 1.4 (declare (ignore x1 y1 x2 y2))
235     (error "Sheet has no parent"))
236 mikemac 1.1
237     (defmethod map-sheet-rectangle*-to-child ((sheet sheet) x1 y1 x2 y2)
238 cvs 1.4 (declare (ignore x1 y1 x2 y2))
239     (error "Sheet has no parent"))
240 mikemac 1.1
241     (defmethod child-containing-position ((sheet sheet) x y)
242     (loop for child in (sheet-children sheet)
243     do (multiple-value-bind (tx ty) (map-sheet-position-to-child child x y)
244 cvs 1.4 (if (and (sheet-enabled-p child)
245     (region-contains-position-p (sheet-region child) tx ty))
246     (return child)))))
247 mikemac 1.1
248     (defmethod children-overlapping-region ((sheet sheet) (region region))
249     (loop for child in (sheet-children sheet)
250     if (and (sheet-enabled-p child)
251 cvs 1.4 (region-intersects-region-p
252     region
253     (transform-region (sheet-transformation child)
254     (sheet-region child))))
255 mikemac 1.1 collect child))
256    
257     (defmethod children-overlapping-rectangle* ((sheet sheet) x1 y1 x2 y2)
258 cvs 1.4 (children-overlapping-region sheet (make-rectangle* x1 y1 x2 y2)))
259 mikemac 1.1
260 cvs 1.2 (defmethod sheet-delta-transformation ((sheet sheet) (ancestor (eql nil)))
261 cvs 1.4 (cond ((sheet-parent sheet)
262     (compose-transformations (sheet-transformation sheet)
263     (sheet-delta-transformation
264     (sheet-parent sheet) ancestor)))
265 cvs 1.12 (t +identity-transformation+)))
266 cvs 1.2
267     (define-condition sheet-is-not-ancestor (error) ())
268    
269     (defmethod sheet-delta-transformation ((sheet sheet) (ancestor sheet))
270     (cond ((eq sheet ancestor) +identity-transformation+)
271     ((sheet-parent sheet)
272     (compose-transformations (sheet-transformation sheet)
273     (sheet-delta-transformation
274     (sheet-parent sheet) ancestor)))
275     (t (error 'sheet-is-not-ancestor))))
276 mikemac 1.1
277     (defmethod sheet-allocated-region ((sheet sheet) (child sheet))
278 cvs 1.4 (reduce #'region-difference
279     (mapc #'(lambda (child)
280     (transform-region (sheet-transformation child)
281     (sheet-region child)))
282     (cons child (sheet-occluding-sheets sheet child)))))
283    
284     (defmethod sheet-direct-mirror ((sheet sheet))
285     nil)
286    
287     (defmethod sheet-mirrored-ancestor ((sheet sheet))
288     (if (sheet-parent sheet)
289     (sheet-mirrored-ancestor (sheet-parent sheet))))
290 mikemac 1.1
291 cvs 1.4 (defmethod sheet-mirror ((sheet sheet))
292     (let ((mirrored-ancestor (sheet-mirrored-ancestor sheet)))
293     (if mirrored-ancestor
294     (sheet-direct-mirror mirrored-ancestor))))
295    
296     (defmethod graft ((sheet sheet))
297     nil)
298    
299     (defmethod graft ((sheet null))
300     (values))
301    
302     (defmethod note-sheet-grafted ((sheet sheet))
303     nil)
304    
305     (defmethod note-sheet-degrafted ((sheet sheet))
306     nil)
307    
308     (defmethod note-sheet-adopted ((sheet sheet))
309     (when (sheet-grafted-p sheet)
310     (note-sheet-grafted sheet)))
311    
312     (defmethod note-sheet-disowned ((sheet sheet))
313 cvs 1.12 nil)
314 cvs 1.4
315     (defmethod note-sheet-region-changed ((sheet sheet))
316     nil) ;have to change
317    
318     (defmethod note-sheet-transformation-changed ((sheet sheet))
319     nil)
320    
321 boninfan 1.15 (defmethod sheet-native-region :before ((sheet sheet))
322     (with-slots (native-region) sheet
323     (unless native-region
324     (setf native-region (compute-native-region sheet)))))
325    
326     (defmethod sheet-device-region ((sheet sheet))
327     (get-medium-device-region sheet))
328    
329     (defmethod compute-native-region ((sheet sheet))
330     (port-compute-native-region (port sheet) sheet))
331    
332     (defmethod invalidate-cached-regions ((sheet sheet))
333     (with-slots (native-region) sheet
334     (when native-region
335     (setf native-region nil)
336     (medium-invalidate-cached-device-region sheet))
337     (loop for child of-type sheet in (sheet-children sheet)
338     do (invalidate-cached-regions child))))
339    
340     (defmethod (setf sheet-region) :after (region (sheet sheet))
341     (declare (ignore region))
342 boninfan 1.16 (note-sheet-region-changed sheet)
343 boninfan 1.15 ; when sheet-region changes, native-region and device-region change too. So, the old-values are false.
344     (invalidate-cached-regions sheet))
345    
346     (defmethod sheet-native-transformation ((sheet sheet))
347     (error "Attempting to get the native-transformation of a generic sheet"))
348    
349     (defmethod sheet-device-transformation ((sheet sheet))
350     (error "Attempting to get the device-transformation of a generic sheet"))
351    
352     (defmethod compute-native-transformation ((sheet sheet))
353     (error "Attempting to compute the native-transformation of a generic sheet"))
354    
355     (defmethod invalidate-cached-transformations ((sheet sheet))
356     (error "Attempting to invalidate native- and device-transformation of a generic sheet"))
357    
358    
359 cvs 1.4 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
360     ;;;
361     ;;; sheet parent mixin
362    
363    
364     (defclass sheet-parent-mixin ()
365     ((parent :initform nil :accessor sheet-parent)))
366    
367    
368     (defmethod set-sheets-parent ((child sheet-parent-mixin) (parent sheet))
369     (setf (slot-value child 'parent) parent))
370    
371     (define-condition sheet-already-has-parent (error) ())
372     (define-condition sheet-is-ancestor (error) ())
373    
374     (defmethod sheet-adopt-child :before (sheet (child sheet-parent-mixin))
375     (when (sheet-parent child) (error 'sheet-already-has-parent))
376     (when (sheet-ancestor-p sheet child) (error 'sheet-is-ancestor)))
377    
378     (defmethod sheet-adopt-child :after (sheet (child sheet-parent-mixin))
379     (setf (sheet-parent child) sheet))
380    
381     (defmethod sheet-disown-child :before (sheet
382     (child sheet-parent-mixin)
383     &key (errorp t))
384     (when (and errorp (not (eq sheet (sheet-parent child))))
385     (error 'sheet-is-not-child)))
386    
387     (defmethod sheet-disown-child :after (sheet
388     (child sheet-parent-mixin)
389     &key (errorp t))
390 cvs 1.12 (declare (ignore errorp))
391     (setf (sheet-parent child) nil)
392     (note-sheet-disowned child)
393     (when (sheet-grafted-p sheet)
394     (note-sheet-degrafted child)))
395 cvs 1.4
396     (defmethod sheet-siblings ((sheet sheet-parent-mixin))
397     (when (not (sheet-parent sheet))
398     (error 'sheet-is-not-child))
399     (remove sheet (sheet-children (sheet-parent sheet))))
400    
401     (defmethod sheet-ancestor-p ((sheet sheet-parent-mixin)
402     (putative-ancestor sheet))
403     (or (eq sheet putative-ancestor)
404     (and (sheet-parent sheet)
405     (sheet-ancestor-p (sheet-parent sheet) putative-ancestor))))
406    
407     (defmethod raise-sheet ((sheet sheet-parent-mixin))
408     (when (not (sheet-parent sheet))
409     (error 'sheet-is-not-child))
410     (raise-sheet-internal sheet (sheet-parent sheet)))
411    
412     (defmethod bury-sheet ((sheet sheet-parent-mixin))
413     (when (not (sheet-parent sheet))
414     (error 'sheet-is-not-child))
415     (bury-sheet-internal sheet (sheet-parent sheet)))
416    
417     (defmethod graft ((sheet sheet-parent-mixin))
418     (graft (sheet-parent sheet)))
419    
420     (defmethod (setf sheet-transformation) :after (newvalue (sheet sheet-parent-mixin))
421     (declare (ignore newvalue))
422     (note-sheet-transformation-changed sheet))
423    
424     (defmethod map-sheet-position-to-parent ((sheet sheet-parent-mixin) x y)
425     (transform-position (sheet-transformation sheet) x y))
426    
427     (defmethod map-sheet-position-to-child ((sheet sheet-parent-mixin) x y)
428     (transform-position (invert-transformation (sheet-transformation sheet)) x y))
429    
430     (defmethod map-sheet-rectangle*-to-parent ((sheet sheet-parent-mixin) x1 y1 x2 y2)
431     (transform-rectangle* (sheet-transformation sheet) x1 y1 x2 y2))
432    
433     (defmethod map-sheet-rectangle*-to-child ((sheet sheet-parent-mixin) x1 y1 x2 y2)
434     (transform-rectangle* (invert-transformation (sheet-transformation sheet)) x1 y1 x2 y2))
435    
436     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
437     ;;;
438     ;;; sheet leaf mixin
439    
440     (defclass sheet-leaf-mixin () ())
441    
442     (defmethod sheet-children ((sheet sheet-leaf-mixin))
443     nil)
444    
445     (defmethod sheet-adopt-child ((sheet sheet-leaf-mixin) (child sheet))
446     (error "Leaf sheet attempting to adopt a child"))
447    
448     (defmethod sheet-disown-child ((sheet sheet-leaf-mixin) (child sheet) &key (errorp t))
449     (declare (ignorable errorp))
450     (error "Leaf sheet attempting to disown a child"))
451    
452    
453     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
454     ;;;
455     ;;; sheet single child mixin
456    
457     (defclass sheet-single-child-mixin ()
458     ((children :initform nil :initarg :child :accessor sheet-children)))
459    
460     (define-condition sheet-supports-only-one-child (error) ())
461    
462     (defmethod sheet-adopt-child :before ((sheet sheet-single-child-mixin)
463     child)
464     (declare (ignorable child))
465     (when (sheet-children sheet) (error 'sheet-supports-only-one-child))
466     (when (sheet-parent child) (error 'sheet-already-has-parent)))
467    
468     (defmethod sheet-adopt-child ((sheet sheet-single-child-mixin)
469     (child sheet-parent-mixin))
470 cvs 1.13 (setf (sheet-children sheet) (list child)))
471 cvs 1.4
472     (defmethod sheet-adopt-child :after ((sheet sheet-single-child-mixin)
473     (child sheet-parent-mixin))
474     (declare (ignorable sheet))
475     (note-sheet-adopted child))
476    
477     (defmethod sheet-disown-child ((sheet sheet-single-child-mixin)
478     (child sheet-parent-mixin)
479     &key (errorp t))
480 cvs 1.12 (declare (ignore errorp))
481 cvs 1.4 (setf (sheet-children sheet) nil))
482    
483     (defmethod reorder-sheets ((sheet sheet-single-child-mixin) new-order)
484     (declare (ignorable sheet new-order))
485     nil)
486    
487     (defmethod raise-sheet-internal (sheet (parent sheet-single-child-mixin))
488     (declare (ignorable sheet parent))
489     (values))
490    
491     (defmethod bury-sheet-internal (sheet (parent sheet-single-child-mixin))
492     (declare (ignorable sheet parent))
493     (values))
494    
495     (defmethod note-sheet-grafted ((sheet sheet-single-child-mixin))
496     (note-sheet-grafted (first (sheet-children sheet))))
497    
498     (defmethod note-sheet-degrafted ((sheet sheet-single-child-mixin))
499     (note-sheet-degrafted (first (sheet-children sheet))))
500    
501    
502     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
503     ;;;
504     ;;; sheet multiple child mixin
505    
506     (defclass sheet-multiple-child-mixin ()
507     ((children :initform nil :initarg :children :accessor sheet-children)))
508    
509     (defmethod sheet-adopt-child ((sheet sheet-multiple-child-mixin)
510     (child sheet-parent-mixin))
511     (when (sheet-parent child)
512     (error 'sheet-already-has-parent))
513     (push child (sheet-children sheet)))
514    
515     (defmethod sheet-adopt-child :after ((sheet sheet-multiple-child-mixin)
516     (child sheet-parent-mixin))
517     (declare (ignorable sheet))
518     (note-sheet-adopted child))
519    
520     (defmethod sheet-disown-child ((sheet sheet-multiple-child-mixin)
521     (child sheet-parent-mixin)
522     &key (errorp t))
523 cvs 1.12 (declare (ignore errorp))
524 cvs 1.4 (setf (sheet-children sheet) (delete child (sheet-children sheet))))
525    
526     (defmethod raise-sheet-internal (sheet (parent sheet-multiple-child-mixin))
527     (setf (sheet-children parent)
528     (cons sheet (delete sheet (sheet-children parent)))))
529    
530     (defmethod bury-sheet-internal (sheet (parent sheet-multiple-child-mixin))
531     (setf (sheet-children parent)
532     (append (delete sheet (sheet-children parent)) (list sheet))))
533    
534     (defmethod note-sheet-grafted ((sheet sheet-multiple-child-mixin))
535     (mapcar #'note-sheet-grafted (sheet-children sheet)))
536    
537     (defmethod note-sheet-degrafted ((sheet sheet-multiple-child-mixin))
538     (mapcar #'note-sheet-degrafted (sheet-children sheet)))
539    
540    
541     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
542     ;;;
543     ;;; sheet geometry classes
544 mikemac 1.1
545 boninfan 1.15 (defclass sheet-native-transformation-mixin ()
546     ((native-transformation :type transformation
547     :initform nil
548     :accessor sheet-native-transformation))
549     (:documentation "This class is a mixin for all sheet-*-tranformation-mixin with the purpose to managed sheet-native-region"))
550    
551     (defmethod (setf sheet-transformation) :after (transformation (sheet sheet-native-transformation-mixin))
552     (declare (ignore transformation))
553     ; when sheet-trfansformation changes, native-transformation and device-transformation change too. So, the old-values are false.
554     (invalidate-cached-transformations sheet))
555    
556    
557     (defmethod sheet-native-transformation :before ((sheet sheet-native-transformation-mixin))
558     (with-slots (native-transformation) sheet
559     (unless native-transformation
560     (setf native-transformation (compute-native-transformation sheet)))))
561    
562     (defmethod sheet-device-transformation ((sheet sheet-native-transformation-mixin))
563     (get-medium-device-transformation sheet))
564    
565     (defmethod compute-native-transformation ((sheet sheet-native-transformation-mixin))
566     (port-compute-native-transformation (port sheet) sheet))
567    
568     (defmethod invalidate-cached-transformations ((sheet sheet-native-transformation-mixin))
569     (with-slots (native-transformation) sheet
570     (when native-transformation
571     (setf native-transformation nil)
572     (medium-invalidate-cached-device-transformation sheet))
573     (loop for child of-type sheet in (sheet-children sheet)
574     do (invalidate-cached-transformations child))))
575    
576     (defclass sheet-identity-transformation-mixin (sheet-native-transformation-mixin)
577 cvs 1.3 ((transformation :initform +identity-transformation+
578 cvs 1.4 :reader sheet-transformation)))
579 mikemac 1.1
580 boninfan 1.15 (defclass sheet-translation-transformation-mixin (sheet-native-transformation-mixin)
581 cvs 1.3 ((transformation :initform +identity-transformation+
582 mikemac 1.1 :initarg :transformation
583 cvs 1.4 :accessor sheet-transformation)))
584 mikemac 1.1
585 cvs 1.4 (defmethod (setf sheet-transformation) :before ((transformation transformation)
586     (sheet sheet-translation-transformation-mixin))
587 mikemac 1.1 (if (not (translation-transformation-p transformation))
588     (error "Attempting to set the SHEET-TRANSFORMATION of a SHEET-TRANSLATION-TRANSFORMATION-MIXIN to a non translation transformation")))
589    
590 boninfan 1.15 (defclass sheet-y-inverting-transformation-mixin (sheet-native-transformation-mixin)
591 cvs 1.3 ((transformation :initform (make-transformation 0 0 0 -1 0 0)
592 mikemac 1.1 :initarg :transformation
593 cvs 1.4 :accessor sheet-transformation)))
594 mikemac 1.1
595 cvs 1.4 (defmethod (setf sheet-transformation) :before ((transformation transformation)
596     (sheet sheet-y-inverting-transformation-mixin))
597 mikemac 1.1 (if (not (y-inverting-transformation-p transformation))
598     (error "Attempting to set the SHEET-TRANSFORMATION of a SHEET-Y-INVERTING-TRANSFORMATION-MIXIN to a non Y inverting transformation")))
599    
600 boninfan 1.15 (defclass sheet-transformation-mixin (sheet-native-transformation-mixin)
601 cvs 1.3 ((transformation :initform +identity-transformation+
602 mikemac 1.1 :initarg :transformation
603 cvs 1.4 :accessor sheet-transformation)))
604 mikemac 1.1
605 cvs 1.4
606     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
607     ;;;
608     ;;; mirrored sheet
609 mikemac 1.1
610 rouanet 1.18 (defclass mirrored-sheet-mixin ()
611 cvs 1.4 ((port :initform nil :initarg :port :accessor port)))
612 mikemac 1.1
613 rouanet 1.18 (defmethod sheet-direct-mirror ((sheet mirrored-sheet-mixin))
614 mikemac 1.1 (port-lookup-mirror (port sheet) sheet))
615    
616 rouanet 1.18 (defmethod (setf sheet-direct-mirror) (mirror (sheet mirrored-sheet-mixin))
617 boninfan 1.14 (port-register-mirror (port sheet) sheet mirror))
618    
619 rouanet 1.18 (defmethod sheet-mirrored-ancestor ((sheet mirrored-sheet-mixin))
620 mikemac 1.1 sheet)
621    
622 rouanet 1.18 (defmethod sheet-mirror ((sheet mirrored-sheet-mixin))
623     (sheet-direct-mirror sheet))
624    
625     (defmethod note-sheet-grafted :before ((sheet mirrored-sheet-mixin))
626 cvs 1.4 (realize-mirror (port sheet) sheet))
627    
628 rouanet 1.18 (defmethod note-sheet-degrafted :after ((sheet mirrored-sheet-mixin))
629     (destroy-mirror (port sheet) sheet))
630 cvs 1.4
631 rouanet 1.18 (defmethod (setf sheet-region) :after (region (sheet mirrored-sheet-mixin))
632 cvs 1.11 (port-set-sheet-region (port sheet) sheet region))
633    
634 rouanet 1.18 (defmethod (setf sheet-transformation) :after (transformation (sheet mirrored-sheet-mixin))
635 cvs 1.11 (port-set-sheet-transformation (port sheet) sheet transformation))
636 boninfan 1.15
637 mikemac 1.1
638 cvs 1.4 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
639     ;;;
640     ;;; repaint protocol classes
641 mikemac 1.1
642 cvs 1.4 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
643     ;;;
644 rouanet 1.17 ;;; standard repainting mixin
645 cvs 1.2
646 rouanet 1.17 (defclass standard-repainting-mixin () ())
647 cvs 1.2
648 rouanet 1.17 (defmethod dispatch-repaint ((sheet standard-repainting-mixin) region)
649 cvs 1.2 (queue-repaint sheet region))
650    
651 cvs 1.4 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
652     ;;;
653 rouanet 1.17 ;;; immediate repainting mixin
654 cvs 1.4
655 rouanet 1.17 (defclass immediate-repainting-mixin () ())
656 cvs 1.2
657 rouanet 1.17 (defmethod dispatch-repaint ((sheet immediate-repainting-mixin) region)
658 cvs 1.2 (handle-repaint sheet nil region))
659    
660 rouanet 1.17 (defmethod handle-repaint ((sheet immediate-repainting-mixin) medium region)
661 cvs 1.4 (declare (ignore medium region))
662     (repaint-sheet sheet (sheet-region sheet))
663     (loop for child in (sheet-children sheet)
664     for region = (sheet-region child)
665     do (repaint-sheet child region)))
666    
667     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
668     ;;;
669 rouanet 1.17 ;;; sheet mute repainting mixin
670 cvs 1.4
671 rouanet 1.17 (defclass sheet-mute-repainting-mixin () ())
672 cvs 1.2
673 rouanet 1.17 (defmethod dispatch-repaint ((sheet sheet-mute-repainting-mixin) region)
674 cvs 1.2 (handle-repaint sheet nil region))
675 cvs 1.8
676 rouanet 1.17 (defmethod repaint-sheet ((sheet sheet-mute-repainting-mixin) region)
677 cvs 1.4 (declare (ignorable sheet region))
678 cvs 1.13 (format *debug-io* "repaint ~S~%" sheet)
679 cvs 1.2 (values))
680 cvs 1.8

  ViewVC Help
Powered by ViewVC 1.1.5