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

Contents of /mcclim/sheets.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5