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

Contents of /mcclim/sheets.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5