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

Diff of /mcclim/sheets.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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

Legend:
Removed from v.1.1.1.1  
changed lines
  Added in v.1.56

  ViewVC Help
Powered by ViewVC 1.1.5