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

Contents of /mcclim/sheets.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5