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

Contents of /mcclim/sheets.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.50 - (show annotations)
Fri Mar 10 21:58:13 2006 UTC (8 years, 1 month ago) by tmoore
Branch: MAIN
CVS Tags: McCLIM-0-9-2
Changes since 1.49: +0 -2 lines
Move most protocol class definitions into protocol-classes.lisp, which
is compiled and loaded early. Some class definitions, which had slot
definitions that I didn't have the stomach to tease apart, stayed
behind.

Replace the presentation documentation state mechanism with
updating-output so that other functions / programs can write to the
pointer documentation area and not screw things up. We still use the
state to actually print the documentation.
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 ;;; (c) copyright 2001 by
9 ;;; Arnaud Rouanet (rouanet@emi.u-bordeaux.fr)
10 ;;; Lionel Salabartan (salabart@emi.u-bordeaux.fr)
11
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
28
29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
30 ;;;
31 ;;; The sheet protocol
32
33 (in-package :clim-internals)
34
35 (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 (defgeneric sheet-disown-child (sheet child &key errorp))
59 (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 ;;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
104 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
105 ;;;
106 ;;; input protocol
107
108 (defgeneric dispatch-event (client event))
109 (defgeneric queue-event (client event))
110 (defgeneric schedule-event (client event delay))
111 (defgeneric handle-event (client event))
112 (defgeneric event-read (client))
113 (defgeneric event-read-no-hang (client))
114 (defgeneric event-peek (client &optional event-type))
115 (defgeneric event-unread (client event))
116 (defgeneric event-listen (client))
117 ;(defgeneric sheet-direct-mirror (sheet))
118 ;(defgeneric sheet-mirrored-ancestor (sheet))
119 ;(defgeneric sheet-mirror (sheet))
120
121 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
122 ;;;
123 ;;; repaint protocol
124
125 (defgeneric dispatch-repaint (sheet region))
126 ;(defgeneric queue-repaint (sheet region))
127 ;(defgeneric handle-repaint (sheet region))
128 ;(defgeneric repaint-sheet (sheet region))
129
130 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
131 ;;;
132 ;;; notification protocol
133
134 (defgeneric note-sheet-grafted (sheet))
135 (defgeneric note-sheet-degrafted (sheet))
136 (defgeneric note-sheet-adopted (sheet))
137 (defgeneric note-sheet-disowned (sheet))
138 (defgeneric note-sheet-enabled (sheet))
139 (defgeneric note-sheet-disabled (sheet))
140 (defgeneric note-sheet-region-changed (sheet))
141 (defgeneric note-sheet-transformation-changed (sheet))
142
143 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
144 ;;;;
145 ;;;; sheet protocol class
146
147 (defclass basic-sheet (sheet)
148 ((region :type region
149 :initarg :region
150 :initform (make-bounding-rectangle 0 0 100 100)
151 :accessor sheet-region)
152 (native-transformation :type (or null transformation)
153 :initform nil
154 :writer %%set-sheet-native-transformation
155 :reader %%sheet-native-transformation)
156 (native-region :type (or null region)
157 :initform nil)
158 (device-transformation :type (or null transformation)
159 :initform nil)
160 (device-region :type (or null region)
161 :initform nil)
162 (pointer-cursor :accessor sheet-pointer-cursor
163 :initarg :pointer-cursor
164 :initform :default)
165 (enabled-p :type boolean
166 :initarg :enabled-p
167 :initform t
168 :accessor sheet-enabled-p)))
169 ; Native region is volatile, and is only computed at the first request when it's equal to nil.
170 ; Invalidate-cached-region method sets the native-region to nil.
171
172 (defmethod sheet-parent ((sheet basic-sheet))
173 nil)
174
175 (defmethod sheet-children ((sheet basic-sheet))
176 nil)
177
178 (defmethod sheet-adopt-child ((sheet basic-sheet) (child sheet))
179 (error "~S attempting to adopt ~S" sheet child))
180
181 (defmethod sheet-adopt-child :after ((sheet basic-sheet) (child sheet))
182 (note-sheet-adopted child)
183 (when (sheet-grafted-p sheet)
184 (note-sheet-grafted child)))
185
186 (define-condition sheet-is-not-child (error) ())
187
188 (defmethod sheet-disown-child :before ((sheet basic-sheet) (child sheet) &key (errorp t))
189 (when (and (not (member child (sheet-children sheet))) errorp)
190 (error 'sheet-is-not-child)))
191
192 (defmethod sheet-disown-child :after ((sheet basic-sheet) (child sheet) &key (errorp t))
193 (declare (ignore errorp))
194 (note-sheet-disowned child)
195 (when (sheet-grafted-p sheet)
196 (note-sheet-degrafted child)))
197
198 (defmethod sheet-siblings ((sheet basic-sheet))
199 (when (not (sheet-parent sheet))
200 (error 'sheet-is-not-child))
201 (remove sheet (sheet-children (sheet-parent sheet))))
202
203 (defmethod sheet-enabled-children ((sheet basic-sheet))
204 (delete-if-not #'sheet-enabled-p (copy-list (sheet-children sheet))))
205
206 (defmethod sheet-ancestor-p ((sheet basic-sheet)
207 (putative-ancestor sheet))
208 (or (eq sheet putative-ancestor)
209 (and (sheet-parent sheet)
210 (sheet-ancestor-p (sheet-parent sheet) putative-ancestor))))
211
212 (defmethod raise-sheet ((sheet basic-sheet))
213 (error 'sheet-is-not-child))
214
215 (defmethod bury-sheet ((sheet basic-sheet))
216 (error 'sheet-is-not-child))
217
218 (define-condition sheet-ordering-underspecified (error) ())
219
220 (defmethod reorder-sheets ((sheet basic-sheet) new-ordering)
221 (when (set-difference (sheet-children sheet) new-ordering)
222 (error 'sheet-ordering-underspecified))
223 (when (set-difference new-ordering (sheet-children sheet))
224 (error 'sheet-is-not-child))
225 (setf (sheet-children sheet) new-ordering)
226 sheet)
227
228 (defmethod sheet-viewable-p ((sheet basic-sheet))
229 (and (sheet-parent sheet)
230 (sheet-viewable-p (sheet-parent sheet))
231 (sheet-enabled-p sheet)))
232
233 (defmethod sheet-occluding-sheets ((sheet basic-sheet) (child sheet))
234 (labels ((fun (l)
235 (cond ((eq (car l) child) '())
236 ((and (sheet-enabled-p (car l))
237 (region-intersects-region-p
238 (sheet-region (car l)) (sheet-region child)))
239 (cons (car l) (fun (cdr l))))
240 (t (fun (cdr l))))))
241 (fun (sheet-children sheet))))
242
243 (defmethod map-over-sheets (function (sheet basic-sheet))
244 (funcall function sheet)
245 (mapc #'(lambda (child) (map-over-sheets function child))
246 (sheet-children sheet))
247 nil)
248
249 (defmethod (setf sheet-enabled-p) :after (enabled-p (sheet basic-sheet))
250 (if enabled-p
251 (note-sheet-enabled sheet)
252 (note-sheet-disabled sheet)))
253
254 (defmethod sheet-transformation ((sheet basic-sheet))
255 (error "Attempting to get the TRANSFORMATION of a SHEET that doesn't contain one"))
256
257 (defmethod (setf sheet-transformation) (transformation (sheet basic-sheet))
258 (declare (ignore transformation))
259 (error "Attempting to set the TRANSFORMATION of a SHEET that doesn't contain one"))
260
261 (defmethod move-sheet ((sheet basic-sheet) x y)
262 (let ((transform (sheet-transformation sheet)))
263 (multiple-value-bind (old-x old-y)
264 (transform-position transform 0 0)
265 (setf (sheet-transformation sheet)
266 (compose-translation-with-transformation
267 transform (- x old-x) (- y old-y))))))
268
269 (defmethod resize-sheet ((sheet basic-sheet) width height)
270 (setf (sheet-region sheet)
271 (make-bounding-rectangle 0 0 width height)))
272
273 (defmethod move-and-resize-sheet ((sheet basic-sheet) x y width height)
274 (move-sheet sheet x y)
275 (resize-sheet sheet width height))
276
277 (defmethod map-sheet-position-to-parent ((sheet basic-sheet) x y)
278 (declare (ignore x y))
279 (error "Sheet has no parent"))
280
281 (defmethod map-sheet-position-to-child ((sheet basic-sheet) x y)
282 (declare (ignore x y))
283 (error "Sheet has no parent"))
284
285 (defmethod map-sheet-rectangle*-to-parent ((sheet basic-sheet) x1 y1 x2 y2)
286 (declare (ignore x1 y1 x2 y2))
287 (error "Sheet has no parent"))
288
289 (defmethod map-sheet-rectangle*-to-child ((sheet basic-sheet) x1 y1 x2 y2)
290 (declare (ignore x1 y1 x2 y2))
291 (error "Sheet has no parent"))
292
293 (defmethod map-over-sheets-containing-position (function (sheet basic-sheet) x y)
294 (map-over-sheets #'(lambda (child)
295 (multiple-value-bind (tx ty) (map-sheet-position-to-child child x y)
296 (when (region-contains-position-p (sheet-region child) tx ty)
297 (funcall function child))))
298 sheet))
299
300
301 (defmethod map-over-sheets-overlapping-region (function (sheet basic-sheet) region)
302 (map-over-sheets #'(lambda (child)
303 (when (region-intersects-region-p
304 region
305 (transform-region
306 (if (eq child sheet)
307 +identity-transformation+
308 (sheet-transformation child))
309 (sheet-region child)))
310 (funcall function child)))
311 sheet))
312
313 (defmethod child-containing-position ((sheet basic-sheet) x y)
314 (loop for child in (sheet-children sheet)
315 do (multiple-value-bind (tx ty) (map-sheet-position-to-child child x y)
316 (if (and (sheet-enabled-p child)
317 (region-contains-position-p (sheet-region child) tx ty))
318 (return child)))))
319
320 (defmethod children-overlapping-region ((sheet basic-sheet) (region region))
321 (loop for child in (sheet-children sheet)
322 if (and (sheet-enabled-p child)
323 (region-intersects-region-p
324 region
325 (transform-region (sheet-transformation child)
326 (sheet-region child))))
327 collect child))
328
329 (defmethod children-overlapping-rectangle* ((sheet basic-sheet) x1 y1 x2 y2)
330 (children-overlapping-region sheet (make-rectangle* x1 y1 x2 y2)))
331
332 (defmethod sheet-delta-transformation ((sheet basic-sheet) (ancestor (eql nil)))
333 (cond ((sheet-parent sheet)
334 (compose-transformations (sheet-transformation sheet)
335 (sheet-delta-transformation
336 (sheet-parent sheet) ancestor)))
337 (t +identity-transformation+)))
338
339 (define-condition sheet-is-not-ancestor (error) ())
340
341 (defmethod sheet-delta-transformation ((sheet basic-sheet) (ancestor sheet))
342 (cond ((eq sheet ancestor) +identity-transformation+)
343 ((sheet-parent sheet)
344 (compose-transformations (sheet-transformation sheet)
345 (sheet-delta-transformation
346 (sheet-parent sheet) ancestor)))
347 (t (error 'sheet-is-not-ancestor))))
348
349 (defmethod sheet-allocated-region ((sheet basic-sheet) (child sheet))
350 (reduce #'region-difference
351 (mapcar #'(lambda (child)
352 (transform-region (sheet-transformation child)
353 (sheet-region child)))
354 (cons child (sheet-occluding-sheets sheet child)))))
355
356 (defmethod sheet-direct-mirror ((sheet basic-sheet))
357 nil)
358
359 (defmethod sheet-mirrored-ancestor ((sheet basic-sheet))
360 (if (sheet-parent sheet)
361 (sheet-mirrored-ancestor (sheet-parent sheet))))
362
363 (defmethod sheet-mirror ((sheet basic-sheet))
364 (let ((mirrored-ancestor (sheet-mirrored-ancestor sheet)))
365 (if mirrored-ancestor
366 (sheet-direct-mirror mirrored-ancestor))))
367
368 (defmethod graft ((sheet basic-sheet))
369 nil)
370
371 (defmethod note-sheet-grafted ((sheet basic-sheet))
372 (mapc #'note-sheet-grafted (sheet-children sheet)))
373
374 (defmethod note-sheet-degrafted ((sheet basic-sheet))
375 (mapc #'note-sheet-degrafted (sheet-children sheet)))
376
377 (defmethod note-sheet-adopted ((sheet basic-sheet))
378 (declare (ignorable sheet))
379 nil)
380
381 (defmethod note-sheet-disowned ((sheet basic-sheet))
382 (declare (ignorable sheet))
383 nil)
384
385 (defmethod note-sheet-enabled ((sheet basic-sheet))
386 (declare (ignorable sheet))
387 nil)
388
389 (defmethod note-sheet-disabled ((sheet basic-sheet))
390 (declare (ignorable sheet))
391 nil)
392
393 (defmethod note-sheet-region-changed ((sheet basic-sheet))
394 nil) ;have to change
395
396 (defmethod note-sheet-transformation-changed ((sheet basic-sheet))
397 nil)
398
399 (defmethod sheet-native-transformation ((sheet basic-sheet))
400 (with-slots (native-transformation) sheet
401 (unless native-transformation
402 (setf native-transformation
403 (let ((parent (sheet-parent sheet)))
404 (if parent
405 (compose-transformations
406 (sheet-native-transformation parent)
407 (sheet-transformation sheet))
408 +identity-transformation+))))
409 native-transformation))
410
411 (defmethod sheet-native-region ((sheet basic-sheet))
412 (with-slots (native-region) sheet
413 (unless native-region
414 (let ((this-native-region (transform-region
415 (sheet-native-transformation sheet)
416 (sheet-region sheet)))
417 (parent (sheet-parent sheet)))
418 (setf native-region (if parent
419 (region-intersection this-native-region
420 (sheet-native-region
421 parent))
422 this-native-region))))
423 native-region))
424
425 (defmethod sheet-device-transformation ((sheet basic-sheet))
426 (with-slots (device-transformation) sheet
427 (unless device-transformation
428 (setf device-transformation
429 (let ((medium (sheet-medium sheet)))
430 (compose-transformations
431 (sheet-native-transformation sheet)
432 (if medium
433 (medium-transformation medium)
434 +identity-transformation+)))))
435 device-transformation))
436
437 (defmethod sheet-device-region ((sheet basic-sheet))
438 (with-slots (device-region) sheet
439 (unless device-region
440 (setf device-region
441 (let ((medium (sheet-medium sheet)))
442 (region-intersection
443 (sheet-native-region sheet)
444 (if medium
445 (transform-region
446 (sheet-device-transformation sheet)
447 (medium-clipping-region medium))
448 +everywhere+)))))
449 device-region))
450
451 (defmethod invalidate-cached-transformations ((sheet basic-sheet))
452 (with-slots (native-transformation device-transformation) sheet
453 (setf native-transformation nil
454 device-transformation nil))
455 (loop for child in (sheet-children sheet)
456 do (invalidate-cached-transformations child)))
457
458 (defmethod invalidate-cached-regions ((sheet basic-sheet))
459 (with-slots (native-region device-region) sheet
460 (setf native-region nil
461 device-region nil))
462 (loop for child in (sheet-children sheet)
463 do (invalidate-cached-regions child)))
464
465 (defmethod (setf sheet-transformation) :after (transformation (sheet basic-sheet))
466 (declare (ignore transformation))
467 (note-sheet-transformation-changed sheet)
468 (invalidate-cached-transformations sheet)
469 (invalidate-cached-regions sheet))
470
471 (defmethod (setf sheet-region) :after (region (sheet basic-sheet))
472 (declare (ignore region))
473 (note-sheet-region-changed sheet)
474 (invalidate-cached-regions sheet))
475
476 (defmethod (setf sheet-pointer-cursor) :after (cursor (sheet basic-sheet))
477 (set-sheet-pointer-cursor (port sheet) sheet cursor))
478
479 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
480 ;;;
481 ;;; sheet parent mixin
482
483
484 (defclass sheet-parent-mixin ()
485 ((parent :initform nil :accessor sheet-parent)))
486
487 (define-condition sheet-already-has-parent (error) ())
488 (define-condition sheet-is-ancestor (error) ())
489
490 (defmethod sheet-adopt-child :before (sheet (child sheet-parent-mixin))
491 (when (sheet-parent child) (error 'sheet-already-has-parent))
492 (when (sheet-ancestor-p sheet child) (error 'sheet-is-ancestor)))
493
494 (defmethod sheet-adopt-child :after (sheet (child sheet-parent-mixin))
495 (setf (sheet-parent child) sheet))
496
497 (defmethod sheet-disown-child :after (sheet
498 (child sheet-parent-mixin)
499 &key (errorp t))
500 (declare (ignore sheet errorp))
501 (setf (sheet-parent child) nil))
502
503 (defmethod raise-sheet ((sheet sheet-parent-mixin))
504 (when (sheet-parent sheet)
505 (raise-sheet-internal sheet (sheet-parent sheet)))
506 (when (sheet-direct-mirror sheet)
507 (raise-mirror (port sheet) sheet)))
508
509 (defmethod bury-sheet ((sheet sheet-parent-mixin))
510 (when (sheet-parent sheet)
511 (bury-sheet-internal sheet (sheet-parent sheet)))
512 (when (sheet-direct-mirror sheet)
513 (bury-mirror (port sheet) sheet)))
514
515 (defmethod graft ((sheet sheet-parent-mixin))
516 (graft (sheet-parent sheet)))
517
518 (defmethod (setf sheet-transformation) :after (newvalue (sheet sheet-parent-mixin))
519 (declare (ignore newvalue))
520 #+nil(note-sheet-transformation-changed sheet))
521
522 (defmethod map-sheet-position-to-parent ((sheet sheet-parent-mixin) x y)
523 (transform-position (sheet-transformation sheet) x y))
524
525 (defmethod map-sheet-position-to-child ((sheet sheet-parent-mixin) x y)
526 (untransform-position (sheet-transformation sheet) x y))
527
528 (defmethod map-sheet-rectangle*-to-parent ((sheet sheet-parent-mixin) x1 y1 x2 y2)
529 (transform-rectangle* (sheet-transformation sheet) x1 y1 x2 y2))
530
531 (defmethod map-sheet-rectangle*-to-child ((sheet sheet-parent-mixin) x1 y1 x2 y2)
532 (untransform-rectangle* (sheet-transformation sheet) x1 y1 x2 y2))
533
534 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
535 ;;;
536 ;;; sheet leaf mixin
537
538 (defclass sheet-leaf-mixin () ())
539
540 (defmethod sheet-children ((sheet sheet-leaf-mixin))
541 nil)
542
543 (defmethod sheet-adopt-child ((sheet sheet-leaf-mixin) (child sheet))
544 (error "Leaf sheet attempting to adopt a child"))
545
546 (defmethod sheet-disown-child ((sheet sheet-leaf-mixin) (child sheet) &key (errorp t))
547 (declare (ignorable errorp))
548 (error "Leaf sheet attempting to disown a child"))
549
550
551 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
552 ;;;
553 ;;; sheet single child mixin
554
555 (defclass sheet-single-child-mixin ()
556 ((child :initform nil :accessor sheet-child)))
557
558 (defmethod sheet-children ((sheet sheet-single-child-mixin))
559 (and (sheet-child sheet) (list (sheet-child sheet))))
560
561 (define-condition sheet-supports-only-one-child (error) ())
562
563 (defmethod sheet-adopt-child :before ((sheet sheet-single-child-mixin)
564 (child sheet-parent-mixin))
565 (when (sheet-child sheet)
566 (error 'sheet-supports-only-one-child)))
567
568 (defmethod sheet-adopt-child ((sheet sheet-single-child-mixin)
569 (child sheet-parent-mixin))
570 (setf (sheet-child sheet) child))
571
572 (defmethod sheet-disown-child ((sheet sheet-single-child-mixin)
573 (child sheet-parent-mixin)
574 &key (errorp t))
575 (declare (ignore errorp))
576 (setf (sheet-child sheet) nil))
577
578 (defmethod raise-sheet-internal (sheet (parent sheet-single-child-mixin))
579 (declare (ignorable sheet parent))
580 (values))
581
582 (defmethod bury-sheet-internal (sheet (parent sheet-single-child-mixin))
583 (declare (ignorable sheet parent))
584 (values))
585
586
587 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
588 ;;;
589 ;;; sheet multiple child mixin
590
591 (defclass sheet-multiple-child-mixin ()
592 ((children :initform nil :initarg :children :accessor sheet-children)))
593
594 (defmethod sheet-adopt-child ((sheet sheet-multiple-child-mixin)
595 (child sheet-parent-mixin))
596 (push child (sheet-children sheet)))
597
598 (defmethod sheet-disown-child ((sheet sheet-multiple-child-mixin)
599 (child sheet-parent-mixin)
600 &key (errorp t))
601 (declare (ignore errorp))
602 (setf (sheet-children sheet) (delete child (sheet-children sheet))))
603
604 (defmethod raise-sheet-internal (sheet (parent sheet-multiple-child-mixin))
605 (setf (sheet-children parent)
606 (cons sheet (delete sheet (sheet-children parent)))))
607
608 (defmethod bury-sheet-internal (sheet (parent sheet-multiple-child-mixin))
609 (setf (sheet-children parent)
610 (append (delete sheet (sheet-children parent)) (list sheet))))
611
612
613 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
614 ;;;
615 ;;; sheet geometry classes
616
617 (defclass sheet-identity-transformation-mixin ()
618 ())
619
620 (defmethod sheet-transformation ((sheet sheet-identity-transformation-mixin))
621 +identity-transformation+)
622
623 (defclass sheet-transformation-mixin ()
624 ((transformation :initform +identity-transformation+
625 :initarg :transformation
626 :accessor sheet-transformation)))
627
628 (defclass sheet-translation-transformation-mixin (sheet-transformation-mixin)
629 ())
630
631 (defmethod (setf sheet-transformation) :before ((transformation transformation)
632 (sheet sheet-translation-transformation-mixin))
633 (if (not (translation-transformation-p transformation))
634 (error "Attempting to set the SHEET-TRANSFORMATION of a SHEET-TRANSLATION-TRANSFORMATION-MIXIN to a non translation transformation")))
635
636 (defclass sheet-y-inverting-transformation-mixin (sheet-transformation-mixin)
637 ()
638 (:default-initargs :transformation (make-transformation 1 0 0 -1 0 0)))
639
640 (defmethod (setf sheet-transformation) :before ((transformation transformation)
641 (sheet sheet-y-inverting-transformation-mixin))
642 (if (not (y-inverting-transformation-p transformation))
643 (error "Attempting to set the SHEET-TRANSFORMATION of a SHEET-Y-INVERTING-TRANSFORMATION-MIXIN to a non Y inverting transformation")))
644
645
646 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
647 ;;;
648 ;;; mirrored sheet
649
650
651 ;; We assume the following limitations of the host window systems:
652 ;;
653 ;; mirror transformations:
654 ;; . can only be translations
655 ;; . are limited to 16-bit signed integer deltas
656 ;;
657 ;; mirror regions:
658 ;; . can only be axis-aligend rectangles
659 ;; . min-x = min-y = 0
660 ;; . max-x, max-y < 2^16
661 ;;
662 ;; These are the limitations of the X Window System.
663 ;;
664
665 (defclass mirrored-sheet-mixin ()
666 ((port :initform nil :initarg :port :accessor port)
667
668 (mirror-transformation
669 :documentation "Our idea of the current mirror transformation. Might not
670 be correct if a foreign application changes our mirror's geometry."
671 :initform +identity-transformation+
672 :accessor %sheet-mirror-transformation)
673
674 (mirror-region
675 :documentation "Our idea of the current mirror region. Might not be
676 correct if a foreign application changes our mirror's geometry. Also note
677 that this might be different from the sheet's native region."
678 :initform nil
679 :accessor %sheet-mirror-region)))
680
681 (defmethod sheet-direct-mirror ((sheet mirrored-sheet-mixin))
682 (port-lookup-mirror (port sheet) sheet))
683
684 (defmethod (setf sheet-direct-mirror) (mirror (sheet mirrored-sheet-mixin))
685 (port-register-mirror (port sheet) sheet mirror))
686
687 (defmethod sheet-mirrored-ancestor ((sheet mirrored-sheet-mixin))
688 sheet)
689
690 (defmethod sheet-mirror ((sheet mirrored-sheet-mixin))
691 (sheet-direct-mirror sheet))
692
693 (defmethod note-sheet-grafted :before ((sheet mirrored-sheet-mixin))
694 (unless (port sheet)
695 (error "~S called on sheet ~S, which has no port?!" 'note-sheet-grafted sheet))
696 (realize-mirror (port sheet) sheet))
697
698 (defmethod note-sheet-degrafted :after ((sheet mirrored-sheet-mixin))
699 (destroy-mirror (port sheet) sheet))
700
701 (defmethod (setf sheet-region) :after (region (sheet mirrored-sheet-mixin))
702 (declare (ignore region))
703 #+nil(port-set-sheet-region (port sheet) sheet region)
704 (update-mirror-geometry sheet)
705 )
706
707 (defmethod note-sheet-transformation-changed ((sheet mirrored-sheet-mixin))
708 (update-mirror-geometry sheet))
709
710 (defmethod sheet-native-region ((sheet mirrored-sheet-mixin))
711 (with-slots (native-region) sheet
712 (unless native-region
713 (let ((this-region (transform-region (sheet-native-transformation sheet)
714 (sheet-region sheet)))
715 (parent (sheet-parent sheet)))
716 (setf native-region
717 (if parent
718 (region-intersection this-region
719 (transform-region
720 (invert-transformation
721 (%sheet-mirror-transformation sheet))
722 (sheet-native-region parent)))
723 this-region))))
724 native-region))
725
726 (defmethod (setf sheet-enabled-p) :after (new-value (sheet mirrored-sheet-mixin))
727 (when (sheet-direct-mirror sheet) ;only do this if the sheet actually has a mirror
728 (if new-value
729 (port-enable-sheet (port sheet) sheet)
730 (port-disable-sheet (port sheet) sheet))))
731
732 ;;; Reflecting a Sheet's Geometry to the Mirror
733
734 (defmethod sheet-mirror-region ((sheet mirrored-sheet-mixin))
735 (cond
736 ;; for grafts or top-level-sheet's always read the mirror region from
737 ;; the server, since it is not under our control.
738 ((or (null (sheet-parent sheet))
739 (null (sheet-parent (sheet-parent sheet))))
740 (make-rectangle* 0 0 #x10000 #x10000)
741 #+nil
742 (make-rectangle* 0 0
743 (port-mirror-width (port sheet) sheet)
744 (port-mirror-height (port sheet) sheet)))
745 (t
746 ;; For other sheets just use the calculated value, saves a round trip.
747 (or (%sheet-mirror-region sheet)
748 ;; XXX what to do if the sheet has no idea about its region?
749 ;; XXX can we consider calling sheet-mirror-region then an error?
750 (make-rectangle* 0 0 #x10000 #x10000) ))))
751
752 (defmethod sheet-native-transformation ((sheet mirrored-sheet-mixin))
753 ;; XXX hm...
754 (with-slots (native-transformation) sheet
755 (unless native-transformation
756 (setf native-transformation
757 (compose-transformations
758 (invert-transformation
759 (%sheet-mirror-transformation sheet))
760 (compose-transformations
761 (sheet-native-transformation (sheet-parent sheet))
762 (sheet-transformation sheet)))))
763 native-transformation))
764
765 (defmethod invalidate-cached-transformations ((sheet mirrored-sheet-mixin))
766 (with-slots (native-transformation device-transformation) sheet
767 (setf ;; native-transformation nil XXX hm...
768 device-transformation nil))
769 (loop for child in (sheet-children sheet)
770 do (invalidate-cached-transformations child)))
771
772 (defmethod effective-mirror-region ((sheet mirrored-sheet-mixin))
773 ;; XXX is this really needed, can't we deduce this information more easily?
774 (let* ((parent (sheet-parent sheet))
775 (ancestor (and parent (sheet-mirrored-ancestor parent))))
776 (if ancestor
777 (region-intersection (sheet-mirror-region sheet)
778 (untransform-region (%sheet-mirror-transformation sheet)
779 (effective-mirror-region ancestor)))
780 (sheet-mirror-region sheet))))
781
782 ;;; Internal interface for enabling/disabling motion hints
783
784 (defgeneric sheet-motion-hints (sheet)
785 (:documentation "Returns t if motion hints are enabled for this sheet"))
786
787 (defmethod sheet-motion-hints ((sheet mirrored-sheet-mixin))
788 (when (sheet-direct-mirror sheet)
789 (port-motion-hints (port sheet) sheet)))
790
791 (defgeneric (setf sheet-motion-hints) (val sheet))
792
793 (defmethod (setf sheet-motion-hints) (val (sheet mirrored-sheet-mixin))
794 (when (sheet-direct-mirror sheet)
795 (setf (port-motion-hints (port sheet) sheet) val)))
796
797 ;;;; Coordinate Swizzling
798
799 ;; This implements what I call "coordinate swizzling", the illusion that
800 ;; sheets can be arbitrary large. The key idea here is that there is a
801 ;; certain kind freedom in choosing the native transformation. A little
802 ;; diagram to illustrate the involved transformations:
803
804 ;;
805 ;; NT NT = native transformation
806 ;; sheet ----------------> mirror PNT = parent's NT
807 ;; | | MT = mirror transformation
808 ;; | | T = sheet transformation
809 ;; | |
810 ;; T | | MT
811 ;; | |
812 ;; | |
813 ;; | |
814 ;; v PNT v
815 ;; parent ----------------> parent
816 ;; mirror
817 ;;
818
819 ;; To setup both the mirror transformation (MR) and the mirror region (MR),
820 ;; we start with the mirror region. The window systems limitations are here:
821 ;; We can only have a certain size and its upper-left corner must be at the
822 ;; origin.
823
824 ;; Now the parent already has a mirror region (PMR) assigned, which obeys to
825 ;; the very same size restrictions. Since every part of MR outside of (PMR o
826 ;; MT^1) is not visible, the first idea is to just clip it by the visible
827 ;; part:
828
829 ;; MR_1 = intersection (SR o NT, PMR o MT^-1) [mirror space]
830
831 ;; Since both NT and MT^-1 are not yet known let us reformulate that region
832 ;; in the parent mirror space:
833
834 ;; MR_2 = MR_1 o MT [parent mirror space]
835 ;; = intersection (SR o NT, PMR o MT^-1) o MT
836 ;; = intersection (SR o NT o MT, PMR o MT^-1 o MT)
837 ;; = intersection (SR o (T o PNT o MT^-1) o MT, PMR)
838 ;; = intersection (SR o T o PNT, PMR)
839
840 ;; MR_2 now is a good candidate for a mirror region. Unfortunately it is
841 ;; still in parent mirror space, so we transform it back, yielding MR_3:
842
843 ;; MR_3 = MR_2 o MT^-1
844 ;; = intersection (SR o T o PNT, PMR) o MT^-1
845
846 ;; Here the only unknown is the mirror transformation MT, we can still
847 ;; choose any as long as the window system limitations are met for both MR
848 ;; and MT.
849
850 ;; 1. MT should be a translation, whose delta x and y components are within
851 ;; limits.
852
853 ;; 2. The size limitation of MR is already met, since MR_3's size is no
854 ;; larger than PMR's size (which mets the limitations). [Remember that MT
855 ;; was defined to be some translation].
856
857 ;; 3. MR_3's upper left corner should also be at the origin which nicely
858 ;; defines MT^-1: Just choose this upper left corner coordinates as MT's x
859 ;; and y deltas.
860
861 ;; So we can meet all criteria. The NT can easily be set up by the identity:
862
863 ;; NT = T o PNT o MT^-1
864
865 ;;; Notes
866
867 ;; . when the native transformation changes, we need to:
868
869 ;; a. Redraw the mirror's contents since the mapping from the sheet space
870 ;; to the mirror space (that is the native transformation) just changed.
871 ;; Translational changes in the native transformation can be catered by
872 ;; blittering, but then have a nice synchronization problem: Suppose
873 ;; a repaint event is underway as we blitter from some region R_1 to
874 ;; region R_2. Say the repaint event's region intersects with R_1. In
875 ;; this case we just blittered pixels which were considered dirty into
876 ;; R_2. Redrawing R_1 now does not repair the defect, since R_2 now also
877 ;; contains dirty pixels. => oops, redraw error.
878 ;;
879 ;; b. Since the above above calculation took the parent's native
880 ;; transformation into account, (and even the naively wanted mirror
881 ;; region depends on the parent's native transformation), we need to
882 ;; redo mirror geometry calculation for any child.
883 ;;
884 ;; c. I imagine more aggressive output records which remember the actual
885 ;; octets which need to be send to the X server. These would contain
886 ;; mirror coordinates and will need to be recalculated, when the native
887 ;; transformation changes.
888
889 ;; => Changing the native transformation can be expensive, so we want a way
890 ;; to minimize changes to the native transformation.
891
892 ;;
893
894 ;; What did we do? We clipped the wanted mirror region, SR o NT, inside the
895 ;; parent's mirror region to meet the window system limitations. We can make
896 ;; this clip region larger as long as we still come up with an mirror
897 ;; region, which meets the limits.
898
899 (defun update-mirror-geometry (sheet &key)
900 "This function reflects the current sheet region and sheet transformation
901 to the mirror. It also sets up the native transformation. This function is
902 supposed to be called whenever one of the following happens:
903
904 - the sheet's transformation changed
905 - the sheet's region changed
906 - the parent's native transformation changed
907 - the parent's transformation changed
908 - the parent's mirror region changed
909
910 Also if the sheet's native transformation changes the mirror's contents need
911 to be redrawn, which is achieved by calling PORT-DIRTY-MIRROR-REGION.
912
913 Since changing the sheet's native transformation might thus be expensive,
914 this function tries to minimize changes to it. (although it does not try
915 very hard)."
916 (let ((old-native-transformation (%%sheet-native-transformation sheet)))
917 (cond ((null (sheet-parent sheet))
918 ;; Ugh, we have no parent, this must be the graft, we cannot resize it can we?
919 nil)
920 ;;
921 ;; Otherwise, the native transformation has to changed or needs to be computed initially
922 ;;
923 (t
924 (let* ((parent (sheet-parent sheet))
925 (sheet-region-in-native-parent
926 ;; this now is the wanted sheet mirror region
927 (transform-region (sheet-native-transformation parent)
928 (transform-region (sheet-transformation sheet)
929 (sheet-region sheet)))))
930
931 (when (region-equal sheet-region-in-native-parent +nowhere+)
932 ;; hmm
933 (setf (%sheet-mirror-transformation sheet) (make-translation-transformation -5 -5))
934 (setf (%sheet-mirror-region sheet) (make-rectangle* 0 0 1 1))
935 (when (sheet-direct-mirror sheet)
936 (port-set-mirror-region (port sheet) (sheet-direct-mirror sheet)
937 (%sheet-mirror-region sheet))
938 (port-set-mirror-transformation (port sheet)
939 (sheet-direct-mirror sheet)
940 (%sheet-mirror-transformation sheet)))
941 (return-from update-mirror-geometry))
942
943 ;; mx1 .. my2 are is now the wanted mirror region in the parent
944 ;; coordinate system.
945 (with-bounding-rectangle* (mx1 my1 mx2 my2) sheet-region-in-native-parent
946 (let (;; pw, ph is the width/height of the parent
947 (pw (bounding-rectangle-width (sheet-mirror-region parent)))
948 (ph (bounding-rectangle-height (sheet-mirror-region parent))))
949 (labels ((choose (MT)
950 ;; -> fits-p mirror-region
951 (multiple-value-bind (x1 y1) (transform-position MT 0 0)
952 (let ((x2 (if (<= mx2 pw)
953 mx2
954 (floor (+ pw (min mx2 (+ #x8000 x1) #x8000)) 2)))
955 (y2 (if (<= my2 ph)
956 my2
957 (floor (+ ph (min my2 (+ #x8000 y1) #x8000)) 2))))
958 (when (and (< (- x2 x1) #x8000)
959 (or (<= (max (- pw #x8000) mx1) x1 0) (coordinate= x1 mx1))
960 (< (- y2 y1) #x8000)
961 (or (<= (max (- pw #x8000) my1) y1 0) (coordinate= y1 my1))
962 (> (round (- x2 x1)) 0)
963 (> (round (- y2 y1)) 0))
964 (values t (make-rectangle* 0 0 (round (- x2 x1)) (round (- y2 y1)))))))))
965 ;;
966 ;; Try reusing the native transformation:
967 ;;
968 (when old-native-transformation
969 (let ((MT (compose-transformations
970 (compose-transformations
971 (sheet-native-transformation (sheet-parent sheet))
972 (sheet-transformation sheet))
973 (invert-transformation old-native-transformation))))
974 (multiple-value-bind (fits-p MR) (choose MT)
975 (when fits-p
976 (setf (%sheet-mirror-region sheet) MR)
977 (setf (%sheet-mirror-transformation sheet) MT)
978 (when (sheet-direct-mirror sheet)
979 (let ((port (port sheet))
980 (mirror (sheet-direct-mirror sheet)))
981 (port-set-mirror-region port mirror MR)
982 (port-set-mirror-transformation port mirror MT)))
983 (return-from update-mirror-geometry nil) ))))
984
985 ;;
986 ;; Try reusing the mirror transformation:
987 ;;
988 '
989 (let ((MT (%sheet-mirror-transformation sheet)))
990 (when MT
991 (multiple-value-bind (fits-p MR) (choose MT)
992 (when fits-p
993 (let ((native-transformation
994 ;; NT = T o PNT o -MT
995 (compose-transformations
996 (invert-transformation MT)
997 (compose-transformations
998 (sheet-native-transformation (sheet-parent sheet))
999 (sheet-transformation sheet)))))
1000 ;; finally reflect the change to the host window system
1001 (setf (%sheet-mirror-region sheet) MR)
1002 (setf (%sheet-mirror-transformation sheet) MT)
1003 (when (sheet-direct-mirror sheet)
1004 (let ((port (port sheet))
1005 (mirror (sheet-direct-mirror sheet)))
1006 (port-set-mirror-region port mirror MR)
1007 (port-set-mirror-transformation port mirror MT)))
1008 ;; update the native transformation if neccessary.
1009 (unless (and old-native-transformation
1010 (transformation-equal native-transformation old-native-transformation))
1011 (invalidate-cached-transformations sheet)
1012 (%%set-sheet-native-transformation native-transformation sheet)
1013 (when old-native-transformation
1014 (care-for-new-native-transformation
1015 sheet old-native-transformation native-transformation))))
1016 (return-from update-mirror-geometry nil)
1017 ))))
1018
1019 ;; Otherwise just choose
1020
1021 ;; Conditions to be met:
1022 ;; x2 < #x8000 + x1
1023 ;; x1 in [max(pw - #x8000, mx1), 0] u {mx1}
1024 ;; x2 in [pw, min (#x8000, mx2)] u {mx2}
1025 ;;
1026 ;; It can still happend, that we cannot meet the
1027 ;; window system limitations => the sheet is
1028 ;; unvisible.
1029 (let* ((x1 (if (>= mx1 0) (round mx1) (floor (max (- pw #x8000) mx1) 2)))
1030 (y1 (if (>= my1 0) (round my1) (floor (max (- ph #x8000) my1) 2)))
1031 (x2 (if (<= mx2 pw) mx2 (floor (+ pw (min mx2 (- #x8000 x1))) 2)))
1032 (y2 (if (<= my2 ph) my2 (floor (+ ph (min my2 (- #x8000 y1))) 2)))
1033 (MT (make-translation-transformation x1 y1))
1034 (MR (make-rectangle* 0 0 (round (- x2 x1)) (round (- y2 y1))))
1035 (native-transformation
1036 ;; NT = T o PNT o -MT
1037 (compose-transformations
1038 (invert-transformation MT)
1039 (compose-transformations
1040 (sheet-native-transformation (sheet-parent sheet))
1041 (sheet-transformation sheet))))
1042 (old-native-transformation
1043 (%%sheet-native-transformation sheet)))
1044
1045 (cond ((and (> (round (- x2 x1)) 0)
1046 (> (round (- y2 y1)) 0))
1047 ;; finally reflect the change to the host window system
1048 (setf (%sheet-mirror-region sheet) MR)
1049 (setf (%sheet-mirror-transformation sheet) MT)
1050 (when (sheet-direct-mirror sheet)
1051 (let ((port (port sheet))
1052 (mirror (sheet-direct-mirror sheet)))
1053 (port-set-mirror-region port mirror MR)
1054 (port-set-mirror-transformation port mirror MT)))
1055 ;; update the native transformation if neccessary.
1056 (unless (and old-native-transformation
1057 (transformation-equal native-transformation old-native-transformation))
1058 (invalidate-cached-transformations sheet)
1059 (%%set-sheet-native-transformation native-transformation sheet)
1060 (when old-native-transformation
1061 (care-for-new-native-transformation
1062 sheet old-native-transformation native-transformation))))
1063
1064 (t
1065 (setf (%sheet-mirror-transformation sheet) (make-translation-transformation -5 -5))
1066 (setf (%sheet-mirror-region sheet) (make-rectangle* 0 0 1 1))
1067 (when (sheet-direct-mirror sheet)
1068 (port-set-mirror-region (port sheet) (sheet-direct-mirror sheet)
1069 (%sheet-mirror-region sheet))
1070 (port-set-mirror-transformation (port sheet)
1071 (sheet-direct-mirror sheet)
1072 (%sheet-mirror-transformation sheet)))) ))))))))))
1073
1074 (defun care-for-new-native-transformation (sheet old-native-transformation native-transformation)
1075 "Internal and helper for UPDATE-MIRROR-GEOMETRY. This is called in
1076 case the native transformation changed and takes care that the
1077 sheet contents get redrawn as appropriate. It also attempts to
1078 save some redraws by blittering."
1079 ;;
1080 ;; compute D := -NT_old o NT_new
1081 ;;
1082 ;; if D is a translation then
1083 ;; blitter from: (MR o -D) ^ MR to: (MR o D) ^ MR
1084 ;; clear MR \ (MR o -D)
1085 ;; else
1086 ;; clear MR
1087 ;;
1088 (let* (;; Compute the transformation to get from an old coordinate in
1089 ;; the mirror coordinate system to its new location.
1090 (delta (compose-transformations
1091 native-transformation
1092 (invert-transformation old-native-transformation)))
1093 ;;
1094 (MR (effective-mirror-region sheet)))
1095 (declare (ignorable delta))
1096 ;; When this delta transformation is a translation, we can
1097 ;; possibly blitter the pixels. Otherwise not, since blittering
1098 ;; cannot account for say scaling or rotation.
1099 (cond
1100 ;;; <-- please leave this code commented out for now -->
1101 ;;; ;; Blittering will never work reliable soon.
1102 ;;; ;; --GB
1103 ;;; ((translation-transformation-p delta)
1104 ;;; ;; We want to bitter. So compute, dMR, the region in mirror
1105 ;;; ;; coordinate space where MR should end up. Clip it to the actual
1106 ;;; ;; mirror, which gives us the destination rectangle. Transform this
1107 ;;; ;; destination back to the old space to get the source rectangle.
1108 ;;; ;; Finally compute the region, which is not occupied by the
1109 ;;; ;; destination and thus must be redrawn.
1110 ;;; ;;
1111 ;;; ;; Note that by using region operations, we automatically take care
1112 ;;; ;; for the case that the window was scrolled too far to reuse any
1113 ;;; ;; pixels.
1114 ;;; (let* ((dMR (transform-region delta MR))
1115 ;;; (dest (region-intersection dMR MR))
1116 ;;; (src (untransform-region delta dest))
1117 ;;; (lack (region-difference MR dMR)))
1118 ;;; ;; Now actually blitter, take care for empty regions.
1119 ;;; (unless (or (region-equal src +nowhere+)
1120 ;;; (region-equal dest +nowhere+))
1121 ;;; (let ((gc (xlib:create-gcontext :drawable (sheet-direct-mirror sheet))))
1122 ;;; (xlib:copy-area (sheet-direct-mirror sheet) gc
1123 ;;; (floor (bounding-rectangle-min-x src))
1124 ;;; (floor (bounding-rectangle-min-y src))
1125 ;;; (floor (bounding-rectangle-width src))
1126 ;;; (floor (bounding-rectangle-height src))
1127 ;;; (sheet-direct-mirror sheet)
1128 ;;; (floor (bounding-rectangle-min-x dest))
1129 ;;; (floor (bounding-rectangle-min-y dest)))) )
1130 ;;; ;; And handle the exposure
1131 ;;; (unless (region-equal lack +nowhere+)
1132 ;;; (xlib:clear-area (sheet-direct-mirror sheet)
1133 ;;; :x (floor (bounding-rectangle-min-x lack))
1134 ;;; :y (floor (bounding-rectangle-min-y lack))
1135 ;;; :width (floor (bounding-rectangle-width lack))
1136 ;;; :height (floor (bounding-rectangle-height lack))
1137 ;;; :exposures-p nil)
1138 ;;; (handle-repaint sheet (untransform-region native-transformation lack)))))
1139 (t
1140 ;; Full sheet contents need to be redrawn, since transformation is no
1141 ;; translation.
1142 (dispatch-repaint sheet
1143 (untransform-region native-transformation MR)) ))))
1144
1145
1146 ;;; Sheets as bounding rectangles
1147
1148 ;; Somewhat hidden in the spec, we read (section 4.1.1 "The Bounding
1149 ;; Rectangle Protocol")
1150 ;;
1151
1152 ;; | bounding-rectangle* region [Generic Function]
1153 ;; |
1154 ;; | [...] The argument region must be either a bounded region [...] or
1155 ;; | some other object that obeys the bounding rectangle protocol, such
1156 ;; | as a sheet or an output record. [...]
1157
1158 (defmethod bounding-rectangle* ((sheet sheet))
1159 (bounding-rectangle* (sheet-region sheet)))
1160
1161 ;;; The null sheet
1162
1163 (defclass null-sheet (basic-sheet) ())
1164

  ViewVC Help
Powered by ViewVC 1.1.5