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

Contents of /mcclim/sheets.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.56 - (hide annotations)
Tue May 13 03:04:37 2008 UTC (5 years, 11 months ago) by ahefner
Branch: MAIN
CVS Tags: HEAD
Changes since 1.55: +1 -1 lines
clim:graft should return nil for degrafted sheets. Also, strengthen
conditions necessary to process configure-notify for toplevel sheets.
This should reduce or eliminate 'No applicable method for generic funciton
clim:graft with arguments NIL' errors when closing the listener, due to
a race condition between disown-frame and the CLX event thread.
1 mikemac 1.1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2    
3 gilbert 1.33 ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com),
4     ;;; (c) copyright 2000 by
5 cvs 1.6 ;;; Iban Hatchondo (hatchond@emi.u-bordeaux.fr)
6     ;;; Julien Boninfante (boninfan@emi.u-bordeaux.fr)
7     ;;; Robert Strandh (strandh@labri.u-bordeaux.fr)
8 rouanet 1.20 ;;; (c) copyright 2001 by
9     ;;; Arnaud Rouanet (rouanet@emi.u-bordeaux.fr)
10     ;;; Lionel Salabartan (salabart@emi.u-bordeaux.fr)
11 mikemac 1.1
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 gilbert 1.33 ;;; License along with this library; if not, write to the
24     ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 mikemac 1.1 ;;; Boston, MA 02111-1307 USA.
26    
27 cvs 1.4
28    
29     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
30     ;;;
31     ;;; The sheet protocol
32    
33 mikemac 1.41 (in-package :clim-internals)
34 mikemac 1.1
35 cvs 1.4 (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 brian 1.36 (defgeneric schedule-event (client event delay))
45 cvs 1.4 (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 mikemac 1.32 ;(defgeneric sheet-direct-mirror (sheet))
52     ;(defgeneric sheet-mirrored-ancestor (sheet))
53     ;(defgeneric sheet-mirror (sheet))
54 cvs 1.4
55     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
56     ;;;
57     ;;; repaint protocol
58    
59     (defgeneric dispatch-repaint (sheet region))
60 mikemac 1.32 ;(defgeneric queue-repaint (sheet region))
61     ;(defgeneric handle-repaint (sheet region))
62     ;(defgeneric repaint-sheet (sheet region))
63 cvs 1.4
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 mikemac 1.1
81 rouanet 1.19 (defclass basic-sheet (sheet)
82 boninfan 1.15 ((region :type region
83     :initarg :region
84 cvs 1.12 :initform (make-bounding-rectangle 0 0 100 100)
85     :accessor sheet-region)
86 gilbert 1.39 (native-transformation :type (or null transformation)
87 ahefner 1.54 ;:initform nil
88     :initform +identity-transformation+
89 gilbert 1.33 :writer %%set-sheet-native-transformation
90     :reader %%sheet-native-transformation)
91 gilbert 1.39 (native-region :type (or null region)
92 rouanet 1.20 :initform nil)
93 gilbert 1.39 (device-transformation :type (or null transformation)
94 rouanet 1.20 :initform nil)
95 gilbert 1.39 (device-region :type (or null region)
96 rouanet 1.20 :initform nil)
97 hefner1 1.46 (pointer-cursor :accessor sheet-pointer-cursor
98     :initarg :pointer-cursor
99 ahefner 1.54 :initform :default)
100 gilbert 1.30 (enabled-p :type boolean
101 moore 1.34 :initarg :enabled-p
102 gilbert 1.30 :initform t
103     :accessor sheet-enabled-p)))
104 boninfan 1.15 ; 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 mikemac 1.1
107 rouanet 1.19 (defmethod sheet-parent ((sheet basic-sheet))
108 mikemac 1.1 nil)
109    
110 rouanet 1.19 (defmethod sheet-children ((sheet basic-sheet))
111 mikemac 1.1 nil)
112    
113 rouanet 1.19 (defmethod sheet-adopt-child ((sheet basic-sheet) (child sheet))
114 gilbert 1.26 (error "~S attempting to adopt ~S" sheet child))
115 mikemac 1.1
116 rouanet 1.19 (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 cvs 1.4 (define-condition sheet-is-not-child (error) ())
122    
123 rouanet 1.19 (defmethod sheet-disown-child :before ((sheet basic-sheet) (child sheet) &key (errorp t))
124     (when (and (not (member child (sheet-children sheet))) errorp)
125 mikemac 1.1 (error 'sheet-is-not-child)))
126    
127 rouanet 1.19 (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 mikemac 1.1 (remove sheet (sheet-children (sheet-parent sheet))))
137    
138 rouanet 1.19 (defmethod sheet-enabled-children ((sheet basic-sheet))
139 cvs 1.4 (delete-if-not #'sheet-enabled-p (copy-list (sheet-children sheet))))
140 mikemac 1.1
141 rouanet 1.19 (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 mikemac 1.1
147 rouanet 1.19 (defmethod raise-sheet ((sheet basic-sheet))
148     (error 'sheet-is-not-child))
149 mikemac 1.1
150 rouanet 1.19 (defmethod bury-sheet ((sheet basic-sheet))
151     (error 'sheet-is-not-child))
152 mikemac 1.1
153 cvs 1.4 (define-condition sheet-ordering-underspecified (error) ())
154 mikemac 1.1
155 rouanet 1.19 (defmethod reorder-sheets ((sheet basic-sheet) new-ordering)
156 cvs 1.4 (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 mikemac 1.1 sheet)
162    
163 rouanet 1.19 (defmethod sheet-viewable-p ((sheet basic-sheet))
164 cvs 1.4 (and (sheet-parent sheet)
165     (sheet-viewable-p (sheet-parent sheet))
166     (sheet-enabled-p sheet)))
167 mikemac 1.1
168 rouanet 1.19 (defmethod sheet-occluding-sheets ((sheet basic-sheet) (child sheet))
169 cvs 1.4 (labels ((fun (l)
170     (cond ((eq (car l) child) '())
171 rouanet 1.19 ((and (sheet-enabled-p (car l))
172     (region-intersects-region-p
173     (sheet-region (car l)) (sheet-region child)))
174 cvs 1.4 (cons (car l) (fun (cdr l))))
175     (t (fun (cdr l))))))
176     (fun (sheet-children sheet))))
177 mikemac 1.1
178 rouanet 1.19 (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 cvs 1.4 (error "Attempting to get the TRANSFORMATION of a SHEET that doesn't contain one"))
191 mikemac 1.1
192 rouanet 1.19 (defmethod (setf sheet-transformation) (transformation (sheet basic-sheet))
193 cvs 1.4 (declare (ignore transformation))
194     (error "Attempting to set the TRANSFORMATION of a SHEET that doesn't contain one"))
195 mikemac 1.1
196 rouanet 1.19 (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 gilbert 1.33 transform (- x old-x) (- y old-y))))))
203 rouanet 1.19
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 cvs 1.4 (declare (ignore x y))
214     (error "Sheet has no parent"))
215 mikemac 1.1
216 rouanet 1.19 (defmethod map-sheet-position-to-child ((sheet basic-sheet) x y)
217 cvs 1.4 (declare (ignore x y))
218     (error "Sheet has no parent"))
219 mikemac 1.1
220 rouanet 1.19 (defmethod map-sheet-rectangle*-to-parent ((sheet basic-sheet) x1 y1 x2 y2)
221 cvs 1.4 (declare (ignore x1 y1 x2 y2))
222     (error "Sheet has no parent"))
223 mikemac 1.1
224 rouanet 1.19 (defmethod map-sheet-rectangle*-to-child ((sheet basic-sheet) x1 y1 x2 y2)
225 cvs 1.4 (declare (ignore x1 y1 x2 y2))
226     (error "Sheet has no parent"))
227 mikemac 1.1
228 rouanet 1.19 (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 gilbert 1.43 (transform-region
241     (if (eq child sheet)
242     +identity-transformation+
243     (sheet-transformation child))
244     (sheet-region child)))
245 rouanet 1.19 (funcall function child)))
246     sheet))
247    
248     (defmethod child-containing-position ((sheet basic-sheet) x y)
249 mikemac 1.1 (loop for child in (sheet-children sheet)
250     do (multiple-value-bind (tx ty) (map-sheet-position-to-child child x y)
251 cvs 1.4 (if (and (sheet-enabled-p child)
252     (region-contains-position-p (sheet-region child) tx ty))
253     (return child)))))
254 mikemac 1.1
255 rouanet 1.19 (defmethod children-overlapping-region ((sheet basic-sheet) (region region))
256 mikemac 1.1 (loop for child in (sheet-children sheet)
257     if (and (sheet-enabled-p child)
258 gilbert 1.33 (region-intersects-region-p
259     region
260 cvs 1.4 (transform-region (sheet-transformation child)
261     (sheet-region child))))
262 mikemac 1.1 collect child))
263    
264 rouanet 1.19 (defmethod children-overlapping-rectangle* ((sheet basic-sheet) x1 y1 x2 y2)
265 cvs 1.4 (children-overlapping-region sheet (make-rectangle* x1 y1 x2 y2)))
266 mikemac 1.1
267 rouanet 1.19 (defmethod sheet-delta-transformation ((sheet basic-sheet) (ancestor (eql nil)))
268 cvs 1.4 (cond ((sheet-parent sheet)
269     (compose-transformations (sheet-transformation sheet)
270     (sheet-delta-transformation
271     (sheet-parent sheet) ancestor)))
272 cvs 1.12 (t +identity-transformation+)))
273 gilbert 1.33
274 cvs 1.2 (define-condition sheet-is-not-ancestor (error) ())
275    
276 rouanet 1.19 (defmethod sheet-delta-transformation ((sheet basic-sheet) (ancestor sheet))
277 cvs 1.2 (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 mikemac 1.1
284 rouanet 1.19 (defmethod sheet-allocated-region ((sheet basic-sheet) (child sheet))
285 cvs 1.4 (reduce #'region-difference
286 rouanet 1.19 (mapcar #'(lambda (child)
287     (transform-region (sheet-transformation child)
288     (sheet-region child)))
289     (cons child (sheet-occluding-sheets sheet child)))))
290 cvs 1.4
291 rouanet 1.19 (defmethod sheet-direct-mirror ((sheet basic-sheet))
292 cvs 1.4 nil)
293    
294 rouanet 1.19 (defmethod sheet-mirrored-ancestor ((sheet basic-sheet))
295 cvs 1.4 (if (sheet-parent sheet)
296     (sheet-mirrored-ancestor (sheet-parent sheet))))
297 mikemac 1.1
298 rouanet 1.19 (defmethod sheet-mirror ((sheet basic-sheet))
299 cvs 1.4 (let ((mirrored-ancestor (sheet-mirrored-ancestor sheet)))
300     (if mirrored-ancestor
301     (sheet-direct-mirror mirrored-ancestor))))
302    
303 rouanet 1.19 (defmethod graft ((sheet basic-sheet))
304 cvs 1.4 nil)
305    
306 rouanet 1.19 (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 cvs 1.4
312 rouanet 1.19 (defmethod note-sheet-adopted ((sheet basic-sheet))
313 gilbert 1.30 (declare (ignorable sheet))
314 cvs 1.4 nil)
315    
316 rouanet 1.19 (defmethod note-sheet-disowned ((sheet basic-sheet))
317 gilbert 1.30 (declare (ignorable sheet))
318 cvs 1.4 nil)
319    
320 rouanet 1.19 (defmethod note-sheet-enabled ((sheet basic-sheet))
321 gilbert 1.30 (declare (ignorable sheet))
322     nil)
323 cvs 1.4
324 rouanet 1.19 (defmethod note-sheet-disabled ((sheet basic-sheet))
325 gilbert 1.30 (declare (ignorable sheet))
326     nil)
327 cvs 1.4
328 rouanet 1.19 (defmethod note-sheet-region-changed ((sheet basic-sheet))
329 cvs 1.4 nil) ;have to change
330    
331 rouanet 1.19 (defmethod note-sheet-transformation-changed ((sheet basic-sheet))
332 cvs 1.4 nil)
333    
334 rouanet 1.20 (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 boninfan 1.15 (with-slots (native-region) sheet
348     (unless native-region
349 tmoore 1.48 (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 rouanet 1.20 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 boninfan 1.15
372 rouanet 1.19 (defmethod sheet-device-region ((sheet basic-sheet))
373 rouanet 1.20 (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 boninfan 1.15
386 rouanet 1.20 (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 boninfan 1.15
393 rouanet 1.19 (defmethod invalidate-cached-regions ((sheet basic-sheet))
394 rouanet 1.20 (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 boninfan 1.15
406 rouanet 1.19 (defmethod (setf sheet-region) :after (region (sheet basic-sheet))
407 boninfan 1.15 (declare (ignore region))
408 boninfan 1.16 (note-sheet-region-changed sheet)
409 boninfan 1.15 (invalidate-cached-regions sheet))
410 hefner1 1.46
411     (defmethod (setf sheet-pointer-cursor) :after (cursor (sheet basic-sheet))
412     (set-sheet-pointer-cursor (port sheet) sheet cursor))
413 boninfan 1.15
414 cvs 1.4 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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 rouanet 1.19 (declare (ignore sheet errorp))
436     (setf (sheet-parent child) nil))
437 cvs 1.4
438     (defmethod raise-sheet ((sheet sheet-parent-mixin))
439 tmoore 1.49 (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 cvs 1.4
444     (defmethod bury-sheet ((sheet sheet-parent-mixin))
445 tmoore 1.49 (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 cvs 1.4
450     (defmethod graft ((sheet sheet-parent-mixin))
451 ahefner 1.56 (and (sheet-parent sheet) (graft (sheet-parent sheet))))
452 cvs 1.4
453     (defmethod (setf sheet-transformation) :after (newvalue (sheet sheet-parent-mixin))
454     (declare (ignore newvalue))
455 mikemac 1.40 #+nil(note-sheet-transformation-changed sheet))
456 cvs 1.4
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 rouanet 1.19 (untransform-position (sheet-transformation sheet) x y))
462 cvs 1.4
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 rouanet 1.19 (untransform-rectangle* (sheet-transformation sheet) x1 y1 x2 y2))
468 cvs 1.4
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 rouanet 1.19 ((child :initform nil :accessor sheet-child)))
492    
493     (defmethod sheet-children ((sheet sheet-single-child-mixin))
494 mikemac 1.42 (and (sheet-child sheet) (list (sheet-child sheet))))
495 cvs 1.4
496     (define-condition sheet-supports-only-one-child (error) ())
497    
498     (defmethod sheet-adopt-child :before ((sheet sheet-single-child-mixin)
499 rouanet 1.19 (child sheet-parent-mixin))
500     (when (sheet-child sheet)
501     (error 'sheet-supports-only-one-child)))
502 cvs 1.4
503     (defmethod sheet-adopt-child ((sheet sheet-single-child-mixin)
504     (child sheet-parent-mixin))
505 rouanet 1.19 (setf (sheet-child sheet) child))
506 cvs 1.4
507     (defmethod sheet-disown-child ((sheet sheet-single-child-mixin)
508     (child sheet-parent-mixin)
509     &key (errorp t))
510 cvs 1.12 (declare (ignore errorp))
511 rouanet 1.19 (setf (sheet-child sheet) nil))
512 cvs 1.4
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 cvs 1.12 (declare (ignore errorp))
537 cvs 1.4 (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 mikemac 1.1
552 rouanet 1.20 (defclass sheet-identity-transformation-mixin ()
553     ())
554 boninfan 1.15
555 rouanet 1.20 (defmethod sheet-transformation ((sheet sheet-identity-transformation-mixin))
556     +identity-transformation+)
557 boninfan 1.15
558 rouanet 1.20 (defclass sheet-transformation-mixin ()
559 cvs 1.3 ((transformation :initform +identity-transformation+
560 mikemac 1.1 :initarg :transformation
561 cvs 1.4 :accessor sheet-transformation)))
562 mikemac 1.1
563 rouanet 1.19 (defclass sheet-translation-transformation-mixin (sheet-transformation-mixin)
564     ())
565    
566 cvs 1.4 (defmethod (setf sheet-transformation) :before ((transformation transformation)
567     (sheet sheet-translation-transformation-mixin))
568 mikemac 1.1 (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 rouanet 1.19 (defclass sheet-y-inverting-transformation-mixin (sheet-transformation-mixin)
572     ()
573     (:default-initargs :transformation (make-transformation 1 0 0 -1 0 0)))
574 mikemac 1.1
575 cvs 1.4 (defmethod (setf sheet-transformation) :before ((transformation transformation)
576     (sheet sheet-y-inverting-transformation-mixin))
577 mikemac 1.1 (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 cvs 1.4
581     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
582     ;;;
583     ;;; mirrored sheet
584 mikemac 1.1
585 gilbert 1.33
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 rouanet 1.18 (defclass mirrored-sheet-mixin ()
601 gilbert 1.24 ((port :initform nil :initarg :port :accessor port)
602 gilbert 1.33
603 gilbert 1.24 (mirror-transformation
604 gilbert 1.33 :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 gilbert 1.24 :initform nil
614 gilbert 1.33 :accessor %sheet-mirror-region)))
615 mikemac 1.1
616 rouanet 1.18 (defmethod sheet-direct-mirror ((sheet mirrored-sheet-mixin))
617 mikemac 1.1 (port-lookup-mirror (port sheet) sheet))
618    
619 rouanet 1.18 (defmethod (setf sheet-direct-mirror) (mirror (sheet mirrored-sheet-mixin))
620 boninfan 1.14 (port-register-mirror (port sheet) sheet mirror))
621    
622 rouanet 1.18 (defmethod sheet-mirrored-ancestor ((sheet mirrored-sheet-mixin))
623 mikemac 1.1 sheet)
624    
625 rouanet 1.18 (defmethod sheet-mirror ((sheet mirrored-sheet-mixin))
626     (sheet-direct-mirror sheet))
627    
628     (defmethod note-sheet-grafted :before ((sheet mirrored-sheet-mixin))
629 gilbert 1.24 (unless (port sheet)
630     (error "~S called on sheet ~S, which has no port?!" 'note-sheet-grafted sheet))
631 cvs 1.4 (realize-mirror (port sheet) sheet))
632    
633 rouanet 1.18 (defmethod note-sheet-degrafted :after ((sheet mirrored-sheet-mixin))
634     (destroy-mirror (port sheet) sheet))
635 cvs 1.4
636 rouanet 1.18 (defmethod (setf sheet-region) :after (region (sheet mirrored-sheet-mixin))
637 strandh 1.45 (declare (ignore region))
638 mikemac 1.40 #+nil(port-set-sheet-region (port sheet) sheet region)
639 gilbert 1.33 (update-mirror-geometry sheet)
640     )
641 cvs 1.11
642 gilbert 1.33 (defmethod note-sheet-transformation-changed ((sheet mirrored-sheet-mixin))
643     (update-mirror-geometry sheet))
644 rouanet 1.20
645     (defmethod sheet-native-region ((sheet mirrored-sheet-mixin))
646 ahefner 1.55 (with-slots (native-region) sheet
647     (unless native-region
648 tmoore 1.48 (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 rouanet 1.20 native-region))
660 gilbert 1.30
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 gilbert 1.25
667 gilbert 1.33 ;;; 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 dlichteblau 1.53 (make-rectangle* 0 0 #x10000 #x10000)
676     #+nil
677 gilbert 1.33 (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 dlichteblau 1.53 ;; 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 gilbert 1.33
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 moore 1.35 ;;; 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 gilbert 1.33 ;;;; 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 hefner1 1.47 ;; transformation into account, (and even the naively wanted mirror
816 gilbert 1.33 ;; 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 gilbert 1.25 ;;; 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 gilbert 1.33 ;; |
1089 gilbert 1.25 ;; | [...] 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 gilbert 1.26
1096     ;;; The null sheet
1097    
1098     (defclass null-sheet (basic-sheet) ())
1099    

  ViewVC Help
Powered by ViewVC 1.1.5