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

Contents of /mcclim/sheets.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (hide annotations)
Tue Aug 29 12:57:06 2000 UTC (13 years, 7 months ago) by cvs
Branch: MAIN
Changes since 1.6: +0 -14 lines
Removed duplicated code for raise-sheet, bury-sheet, and dispatch-repaint.
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     (defgeneric sheet-disown-child (sheet child &key (errorp t)))
56     (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     ;;; not for external use
75     (defgeneric realize-hierarchy (sheet port))
76     (defgeneric realize-sheet (sheet port))
77     (defgeneric unrealize-hierarchy (sheet))
78     (defgeneric unrealize-sheet (sheet))
79    
80     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
81     ;;;
82     ;;; Sheet geometry
83    
84     (defgeneric sheet-transformation (sheet))
85     (defgeneric (setf sheet-transformation) (transformation sheet))
86     (defgeneric sheet-region (sheet))
87     (defgeneric (setf sheet-region) (region sheet))
88     (defgeneric map-sheet-position-to-parent (sheet x y))
89     (defgeneric map-sheet-position-to-child (sheet x y))
90     (defgeneric map-sheet-rectangle*-to-parent (sheet x1 y1 x2 y2))
91     (defgeneric map-sheet-rectangle*-to-child (sheet x1 y1 x2 y2))
92     (defgeneric child-containing-position (sheet x y))
93     (defgeneric children-overlapping-region (sheet region))
94     (defgeneric children-overlapping-rectangle* (sheet x1 y1 x2 y2))
95     (defgeneric sheet-delta-transformation (sheet ancestor))
96     (defgeneric sheet-allocated-region (sheet child))
97    
98     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
99     ;;;
100     ;;; input protocol
101    
102     (defgeneric dispatch-event (client event))
103     (defgeneric queue-event (client event))
104     (defgeneric handle-event (client event))
105     (defgeneric event-read (client))
106     (defgeneric event-read-no-hang (client))
107     (defgeneric event-peek (client &optional event-type))
108     (defgeneric event-unread (client event))
109     (defgeneric event-listen (client))
110     (defgeneric sheet-direct-mirror (sheet))
111     (defgeneric sheet-mirrored-ancestor (sheet))
112     (defgeneric sheet-mirror (sheet))
113    
114     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
115     ;;;
116     ;;; repaint protocol
117    
118     (defgeneric dispatch-repaint (sheet region))
119     (defgeneric queue-repaint (sheet region))
120     (defgeneric handle-repaint (sheet medium region))
121     (defgeneric repaint-sheet (sheet region))
122    
123     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
124     ;;;
125     ;;; notification protocol
126    
127     (defgeneric note-sheet-grafted (sheet))
128     (defgeneric note-sheet-degrafted (sheet))
129     (defgeneric note-sheet-adopted (sheet))
130     (defgeneric note-sheet-disowned (sheet))
131     (defgeneric note-sheet-enabled (sheet))
132     (defgeneric note-sheet-disabled (sheet))
133     (defgeneric note-sheet-region-changed (sheet))
134     (defgeneric note-sheet-transformation-changed (sheet))
135    
136     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
137     ;;;;
138     ;;;; sheet protocol class
139 mikemac 1.1
140     (defclass sheet ()
141 cvs 1.4 ((region :initarg :region :accessor sheet-region)
142     (enabled-p :initform nil :accessor sheet-enabled-p)))
143 mikemac 1.1
144     (defun sheetp (x)
145     (typep x 'sheet))
146    
147     (defmethod sheet-parent ((sheet sheet))
148     nil)
149    
150     (defmethod set-sheets-parent ((sheet sheet) (parent sheet))
151     (error "Attempting to set the parent of a sheet that has no parent"))
152    
153     (defmethod sheet-children ((sheet sheet))
154     nil)
155    
156     (defmethod sheet-adopt-child ((sheet sheet) (child sheet))
157     (error "SHEET attempting to adopt a child"))
158    
159 cvs 1.4 (define-condition sheet-is-not-child (error) ())
160    
161 mikemac 1.1 (defmethod sheet-disown-child ((sheet sheet) (child sheet) &key (errorp t))
162     (cond
163     ((eq (sheet-parent child) sheet)
164     (set-sheets-parent child nil)
165 cvs 1.4 (setf (sheet-children sheet) (remove child (sheet-children sheet))))
166 mikemac 1.1 (errorp
167     (error 'sheet-is-not-child)))
168     child)
169    
170     (defmethod sheet-siblings ((sheet sheet))
171     (remove sheet (sheet-children (sheet-parent sheet))))
172    
173     (defmethod sheet-enabled-children ((sheet sheet))
174 cvs 1.4 (delete-if-not #'sheet-enabled-p (copy-list (sheet-children sheet))))
175 mikemac 1.1
176     (defmethod sheet-ancestor-p ((sheet sheet) (putative-ancestor sheet))
177 cvs 1.4 (eq sheet putative-ancestor))
178 mikemac 1.1
179     (defmethod raise-sheet ((sheet sheet))
180 cvs 1.4 (setf (sheet-children sheet) (cons sheet (remove sheet (sheet-children sheet))))
181 mikemac 1.1 sheet)
182    
183     (defmethod bury-sheet ((sheet sheet))
184 cvs 1.4 (setf (sheet-children sheet) (nconc (remove sheet (sheet-children sheet)) (list sheet)))
185 mikemac 1.1 sheet)
186    
187 cvs 1.4 (define-condition sheet-ordering-underspecified (error) ())
188 mikemac 1.1
189     (defmethod reorder-sheets ((sheet sheet) new-ordering)
190 cvs 1.4 (when (set-difference (sheet-children sheet) new-ordering)
191     (error 'sheet-ordering-underspecified))
192     (when (set-difference new-ordering (sheet-children sheet))
193     (error 'sheet-is-not-child))
194     (setf (sheet-children sheet) new-ordering)
195 mikemac 1.1 sheet)
196    
197     (defmethod sheet-viewable-p ((sheet sheet))
198 cvs 1.4 (and (sheet-parent sheet)
199     (sheet-viewable-p (sheet-parent sheet))
200     (sheet-enabled-p sheet)))
201 mikemac 1.1
202     (defmethod sheet-occluding-sheets ((sheet sheet) (child sheet))
203 cvs 1.4 (labels ((fun (l)
204     (cond ((eq (car l) child) '())
205     ((region-intersects-region-p
206     (sheet-region (car l)) (sheet-region child))
207     (cons (car l) (fun (cdr l))))
208     (t (fun (cdr l))))))
209     (fun (sheet-children sheet))))
210 mikemac 1.1
211 cvs 1.4 (defmethod sheet-transformation ((sheet sheet))
212     (error "Attempting to get the TRANSFORMATION of a SHEET that doesn't contain one"))
213 mikemac 1.1
214 cvs 1.4 (defmethod (setf sheet-transformation) (transformation (sheet sheet))
215     (declare (ignore transformation))
216     (error "Attempting to set the TRANSFORMATION of a SHEET that doesn't contain one"))
217 mikemac 1.1
218     (defmethod map-sheet-position-to-parent ((sheet sheet) x y)
219 cvs 1.4 (declare (ignore x y))
220     (error "Sheet has no parent"))
221 mikemac 1.1
222     (defmethod map-sheet-position-to-child ((sheet sheet) x y)
223 cvs 1.4 (declare (ignore x y))
224     (error "Sheet has no parent"))
225 mikemac 1.1
226     (defmethod map-sheet-rectangle*-to-parent ((sheet sheet) x1 y1 x2 y2)
227 cvs 1.4 (declare (ignore x1 y1 x2 y2))
228     (error "Sheet has no parent"))
229 mikemac 1.1
230     (defmethod map-sheet-rectangle*-to-child ((sheet sheet) x1 y1 x2 y2)
231 cvs 1.4 (declare (ignore x1 y1 x2 y2))
232     (error "Sheet has no parent"))
233 mikemac 1.1
234     (defmethod child-containing-position ((sheet sheet) x y)
235     (loop for child in (sheet-children sheet)
236     do (multiple-value-bind (tx ty) (map-sheet-position-to-child child x y)
237 cvs 1.4 (if (and (sheet-enabled-p child)
238     (region-contains-position-p (sheet-region child) tx ty))
239     (return child)))))
240 mikemac 1.1
241     (defmethod children-overlapping-region ((sheet sheet) (region region))
242     (loop for child in (sheet-children sheet)
243     if (and (sheet-enabled-p child)
244 cvs 1.4 (region-intersects-region-p
245     region
246     (transform-region (sheet-transformation child)
247     (sheet-region child))))
248 mikemac 1.1 collect child))
249    
250     (defmethod children-overlapping-rectangle* ((sheet sheet) x1 y1 x2 y2)
251 cvs 1.4 (children-overlapping-region sheet (make-rectangle* x1 y1 x2 y2)))
252 mikemac 1.1
253 cvs 1.2 (defmethod sheet-delta-transformation ((sheet sheet) (ancestor (eql nil)))
254 cvs 1.4 (cond ((sheet-parent sheet)
255     (compose-transformations (sheet-transformation sheet)
256     (sheet-delta-transformation
257     (sheet-parent sheet) ancestor)))
258     (t (sheet-transformation sheet))))
259 cvs 1.2
260     (define-condition sheet-is-not-ancestor (error) ())
261    
262     (defmethod sheet-delta-transformation ((sheet sheet) (ancestor sheet))
263     (cond ((eq sheet ancestor) +identity-transformation+)
264     ((sheet-parent sheet)
265     (compose-transformations (sheet-transformation sheet)
266     (sheet-delta-transformation
267     (sheet-parent sheet) ancestor)))
268     (t (error 'sheet-is-not-ancestor))))
269 mikemac 1.1
270     (defmethod sheet-allocated-region ((sheet sheet) (child sheet))
271 cvs 1.4 (reduce #'region-difference
272     (mapc #'(lambda (child)
273     (transform-region (sheet-transformation child)
274     (sheet-region child)))
275     (cons child (sheet-occluding-sheets sheet child)))))
276    
277     (defmethod sheet-direct-mirror ((sheet sheet))
278     nil)
279    
280     (defmethod sheet-mirrored-ancestor ((sheet sheet))
281     (if (sheet-parent sheet)
282     (sheet-mirrored-ancestor (sheet-parent sheet))))
283 mikemac 1.1
284 cvs 1.4 (defmethod sheet-mirror ((sheet sheet))
285     (let ((mirrored-ancestor (sheet-mirrored-ancestor sheet)))
286     (if mirrored-ancestor
287     (sheet-direct-mirror mirrored-ancestor))))
288    
289     (defmethod graft ((sheet sheet))
290     nil)
291    
292     (defmethod graft ((sheet null))
293     (values))
294    
295     (defmethod note-sheet-grafted ((sheet sheet))
296     nil)
297    
298     (defmethod note-sheet-degrafted ((sheet sheet))
299     nil)
300    
301     (defmethod note-sheet-adopted ((sheet sheet))
302     (when (sheet-grafted-p sheet)
303     (note-sheet-grafted sheet)))
304    
305     (defmethod note-sheet-disowned ((sheet sheet))
306     ; (when (sheet-grafted-p sheet)
307     (note-sheet-degrafted sheet))
308    
309     (defmethod note-sheet-region-changed ((sheet sheet))
310     nil) ;have to change
311    
312     (defmethod note-sheet-transformation-changed ((sheet sheet))
313     nil)
314    
315     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
316     ;;;
317     ;;; sheet parent mixin
318    
319    
320     (defclass sheet-parent-mixin ()
321     ((parent :initform nil :accessor sheet-parent)))
322    
323    
324     (defmethod set-sheets-parent ((child sheet-parent-mixin) (parent sheet))
325     (setf (slot-value child 'parent) parent))
326    
327     (define-condition sheet-already-has-parent (error) ())
328     (define-condition sheet-is-ancestor (error) ())
329    
330     (defmethod sheet-adopt-child :before (sheet (child sheet-parent-mixin))
331     (when (sheet-parent child) (error 'sheet-already-has-parent))
332     (when (sheet-ancestor-p sheet child) (error 'sheet-is-ancestor)))
333    
334     (defmethod sheet-adopt-child :after (sheet (child sheet-parent-mixin))
335     (setf (sheet-parent child) sheet))
336    
337     (defmethod sheet-disown-child :before (sheet
338     (child sheet-parent-mixin)
339     &key (errorp t))
340     (when (and errorp (not (eq sheet (sheet-parent child))))
341     (error 'sheet-is-not-child)))
342    
343     (defmethod sheet-disown-child :after (sheet
344     (child sheet-parent-mixin)
345     &key (errorp t))
346 cvs 1.5 (declare (ignore sheet errorp))
347 cvs 1.4 (setf (sheet-parent child) nil))
348    
349     (defmethod sheet-siblings ((sheet sheet-parent-mixin))
350     (when (not (sheet-parent sheet))
351     (error 'sheet-is-not-child))
352     (remove sheet (sheet-children (sheet-parent sheet))))
353    
354     (defmethod sheet-ancestor-p ((sheet sheet-parent-mixin)
355     (putative-ancestor sheet))
356     (or (eq sheet putative-ancestor)
357     (and (sheet-parent sheet)
358     (sheet-ancestor-p (sheet-parent sheet) putative-ancestor))))
359    
360     (defmethod raise-sheet ((sheet sheet-parent-mixin))
361     (when (not (sheet-parent sheet))
362     (error 'sheet-is-not-child))
363     (raise-sheet-internal sheet (sheet-parent sheet)))
364    
365     (defmethod bury-sheet ((sheet sheet-parent-mixin))
366     (when (not (sheet-parent sheet))
367     (error 'sheet-is-not-child))
368     (bury-sheet-internal sheet (sheet-parent sheet)))
369    
370     (defmethod graft ((sheet sheet-parent-mixin))
371     (graft (sheet-parent sheet)))
372    
373     (defmethod (setf sheet-transformation) :after (newvalue (sheet sheet-parent-mixin))
374     (declare (ignore newvalue))
375     (note-sheet-transformation-changed sheet))
376    
377     (defmethod map-sheet-position-to-parent ((sheet sheet-parent-mixin) x y)
378     (transform-position (sheet-transformation sheet) x y))
379    
380     (defmethod map-sheet-position-to-child ((sheet sheet-parent-mixin) x y)
381     (transform-position (invert-transformation (sheet-transformation sheet)) x y))
382    
383     (defmethod map-sheet-rectangle*-to-parent ((sheet sheet-parent-mixin) x1 y1 x2 y2)
384     (transform-rectangle* (sheet-transformation sheet) x1 y1 x2 y2))
385    
386     (defmethod map-sheet-rectangle*-to-child ((sheet sheet-parent-mixin) x1 y1 x2 y2)
387     (transform-rectangle* (invert-transformation (sheet-transformation sheet)) x1 y1 x2 y2))
388    
389     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
390     ;;;
391     ;;; sheet leaf mixin
392    
393     (defclass sheet-leaf-mixin () ())
394    
395     (defmethod sheet-children ((sheet sheet-leaf-mixin))
396     nil)
397    
398     (defmethod sheet-adopt-child ((sheet sheet-leaf-mixin) (child sheet))
399     (error "Leaf sheet attempting to adopt a child"))
400    
401     (defmethod sheet-disown-child ((sheet sheet-leaf-mixin) (child sheet) &key (errorp t))
402     (declare (ignorable errorp))
403     (error "Leaf sheet attempting to disown a child"))
404    
405    
406     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
407     ;;;
408     ;;; sheet single child mixin
409    
410     (defclass sheet-single-child-mixin ()
411     ((children :initform nil :initarg :child :accessor sheet-children)))
412    
413     (define-condition sheet-supports-only-one-child (error) ())
414    
415     (define-condition sheet-already-has-parent (error) ())
416    
417     (defmethod sheet-adopt-child :before ((sheet sheet-single-child-mixin)
418     child)
419     (declare (ignorable child))
420     (when (sheet-children sheet) (error 'sheet-supports-only-one-child))
421     (when (sheet-parent child) (error 'sheet-already-has-parent)))
422    
423     (defmethod sheet-adopt-child ((sheet sheet-single-child-mixin)
424     (child sheet-parent-mixin))
425     (setf (sheet-children sheet) child))
426    
427     (defmethod sheet-adopt-child :after ((sheet sheet-single-child-mixin)
428     (child sheet-parent-mixin))
429     (declare (ignorable sheet))
430     (note-sheet-adopted child))
431    
432     (defmethod sheet-disown-child ((sheet sheet-single-child-mixin)
433     (child sheet-parent-mixin)
434     &key (errorp t))
435     (declare (ignorable errorp))
436     (setf (sheet-children sheet) nil))
437    
438     (defmethod sheet-disown-child :after ((sheet sheet-single-child-mixin)
439     (child sheet-parent-mixin)
440     &key (errorp t))
441     (declare (ignorable sheet errorp))
442     (note-sheet-disowned child))
443    
444     (defmethod reorder-sheets ((sheet sheet-single-child-mixin) new-order)
445     (declare (ignorable sheet new-order))
446     nil)
447    
448     (defmethod raise-sheet-internal (sheet (parent sheet-single-child-mixin))
449     (declare (ignorable sheet parent))
450     (values))
451    
452     (defmethod bury-sheet-internal (sheet (parent sheet-single-child-mixin))
453     (declare (ignorable sheet parent))
454     (values))
455    
456     (defmethod note-sheet-grafted ((sheet sheet-single-child-mixin))
457     (note-sheet-grafted (first (sheet-children sheet))))
458    
459     (defmethod note-sheet-degrafted ((sheet sheet-single-child-mixin))
460     (note-sheet-degrafted (first (sheet-children sheet))))
461    
462    
463     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
464     ;;;
465     ;;; sheet multiple child mixin
466    
467     (defclass sheet-multiple-child-mixin ()
468     ((children :initform nil :initarg :children :accessor sheet-children)))
469    
470     (defmethod sheet-adopt-child ((sheet sheet-multiple-child-mixin)
471     (child sheet-parent-mixin))
472     (when (sheet-parent child)
473     (error 'sheet-already-has-parent))
474     (push child (sheet-children sheet)))
475    
476     (defmethod sheet-adopt-child :after ((sheet sheet-multiple-child-mixin)
477     (child sheet-parent-mixin))
478     (declare (ignorable sheet))
479     (note-sheet-adopted child))
480    
481     (defmethod sheet-disown-child ((sheet sheet-multiple-child-mixin)
482     (child sheet-parent-mixin)
483     &key (errorp t))
484     (declare (ignorable errorp))
485     (setf (sheet-children sheet) (delete child (sheet-children sheet))))
486    
487     (defmethod sheet-disown-child :after ((sheet sheet-multiple-child-mixin)
488     (child sheet-parent-mixin)
489     &key (errorp t))
490     (declare (ignorable sheet errorp))
491     (note-sheet-disowned child))
492    
493     (defmethod raise-sheet-internal (sheet (parent sheet-multiple-child-mixin))
494     (setf (sheet-children parent)
495     (cons sheet (delete sheet (sheet-children parent)))))
496    
497     (defmethod bury-sheet-internal (sheet (parent sheet-multiple-child-mixin))
498     (setf (sheet-children parent)
499     (append (delete sheet (sheet-children parent)) (list sheet))))
500    
501     (defmethod note-sheet-grafted ((sheet sheet-multiple-child-mixin))
502     (mapcar #'note-sheet-grafted (sheet-children sheet)))
503    
504     (defmethod note-sheet-degrafted ((sheet sheet-multiple-child-mixin))
505     (mapcar #'note-sheet-degrafted (sheet-children sheet)))
506    
507    
508     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
509     ;;;
510     ;;; sheet geometry classes
511 mikemac 1.1
512     (defclass sheet-identity-transformation-mixin ()
513 cvs 1.3 ((transformation :initform +identity-transformation+
514 cvs 1.4 :reader sheet-transformation)))
515 mikemac 1.1
516     (defclass sheet-translation-transformation-mixin ()
517 cvs 1.3 ((transformation :initform +identity-transformation+
518 mikemac 1.1 :initarg :transformation
519 cvs 1.4 :accessor sheet-transformation)))
520 mikemac 1.1
521 cvs 1.4 (defmethod (setf sheet-transformation) :before ((transformation transformation)
522     (sheet sheet-translation-transformation-mixin))
523 mikemac 1.1 (if (not (translation-transformation-p transformation))
524     (error "Attempting to set the SHEET-TRANSFORMATION of a SHEET-TRANSLATION-TRANSFORMATION-MIXIN to a non translation transformation")))
525    
526     (defclass sheet-y-inverting-transformation-mixin ()
527 cvs 1.3 ((transformation :initform (make-transformation 0 0 0 -1 0 0)
528 mikemac 1.1 :initarg :transformation
529 cvs 1.4 :accessor sheet-transformation)))
530 mikemac 1.1
531 cvs 1.4 (defmethod (setf sheet-transformation) :before ((transformation transformation)
532     (sheet sheet-y-inverting-transformation-mixin))
533 mikemac 1.1 (if (not (y-inverting-transformation-p transformation))
534     (error "Attempting to set the SHEET-TRANSFORMATION of a SHEET-Y-INVERTING-TRANSFORMATION-MIXIN to a non Y inverting transformation")))
535    
536     (defclass sheet-transformation-mixin ()
537 cvs 1.3 ((transformation :initform +identity-transformation+
538 mikemac 1.1 :initarg :transformation
539 cvs 1.4 :accessor sheet-transformation)))
540 mikemac 1.1
541 cvs 1.4
542     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
543     ;;;
544     ;;; mirrored sheet
545 mikemac 1.1
546     (defclass mirrored-sheet (sheet)
547 cvs 1.4 ((port :initform nil :initarg :port :accessor port)))
548 mikemac 1.1
549     (defmethod sheet-direct-mirror ((sheet mirrored-sheet))
550     (port-lookup-mirror (port sheet) sheet))
551    
552     (defmethod sheet-mirrored-ancestor ((sheet mirrored-sheet))
553     sheet)
554    
555 cvs 1.4 (defmethod note-sheet-grafted :before ((sheet mirrored-sheet))
556     (realize-mirror (port sheet) sheet))
557    
558     (defmethod note-sheet-degrafted :after ((sheet mirrored-sheet))
559     (unrealize-mirror (port sheet) sheet))
560    
561 mikemac 1.1
562 cvs 1.4 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
563     ;;;
564     ;;; repaint protocol classes
565 mikemac 1.1
566 cvs 1.4 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
567     ;;;
568     ;;; standard repaint mixin
569 cvs 1.2
570     (defclass standard-repaint-mixin () ())
571    
572     (defmethod dispatch-repaint ((sheet standard-repaint-mixin) region)
573     (queue-repaint sheet region))
574    
575 cvs 1.4 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
576     ;;;
577     ;;; immediate repaint mixin
578    
579 cvs 1.2 (defclass immediate-repaint-mixin () ())
580    
581     (defmethod dispatch-repaint ((sheet immediate-repaint-mixin) region)
582     (handle-repaint sheet nil region))
583    
584 cvs 1.4 (defmethod handle-repaint ((sheet immediate-repaint-mixin) medium region)
585     (declare (ignore medium region))
586     (repaint-sheet sheet (sheet-region sheet))
587     (loop for child in (sheet-children sheet)
588     for region = (sheet-region child)
589     do (repaint-sheet child region)))
590    
591     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
592     ;;;
593     ;;; mute repaint mixin
594    
595 cvs 1.2 (defclass mute-repaint-mixin () ())
596    
597     (defmethod dispatch-repaint ((sheet mute-repaint-mixin) region)
598     (handle-repaint sheet nil region))
599    
600     (defmethod repaint-sheet ((sheet mute-repaint-mixin) region)
601 cvs 1.4 (declare (ignorable sheet region))
602 cvs 1.2 (values))

  ViewVC Help
Powered by ViewVC 1.1.5