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

Contents of /mcclim/sheets.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Mon Jun 12 13:45:40 2000 UTC (13 years, 10 months ago) by cvs
Branch: MAIN
Changes since 1.1: +38 -3 lines
Added second argument to  sheet-delta-transformation to conform to
specification.

Added classes and method for repaint protocol.
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com)
4
5 ;;; This library is free software; you can redistribute it and/or
6 ;;; modify it under the terms of the GNU Library General Public
7 ;;; License as published by the Free Software Foundation; either
8 ;;; version 2 of the License, or (at your option) any later version.
9 ;;;
10 ;;; This library is distributed in the hope that it will be useful,
11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;; Library General Public License for more details.
14 ;;;
15 ;;; You should have received a copy of the GNU Library General Public
16 ;;; License along with this library; if not, write to the
17 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
18 ;;; Boston, MA 02111-1307 USA.
19
20 (in-package :CLIM-INTERNALS)
21
22 ;;; SHEET class
23
24 (defclass sheet ()
25 ((port :initform nil
26 :initarg :port
27 :accessor port)
28 (graft :initform nil
29 :initarg :graft
30 :accessor graft)
31 (enabled :initform t
32 :accessor sheet-enabled-p)
33 (region :initform (make-bounding-rectangle 0 0 100 100)
34 :accessor sheet-region)
35 ))
36
37 (defun sheetp (x)
38 (typep x 'sheet))
39
40 (defmethod sheet-parent ((sheet sheet))
41 nil)
42
43 (defmethod set-sheets-parent ((sheet sheet) (parent sheet))
44 (error "Attempting to set the parent of a sheet that has no parent"))
45
46 (defmethod sheet-children ((sheet sheet))
47 nil)
48
49 (defmethod sheet-transformation ((sheet sheet))
50 (error "Attempting to get the TRANSFORMATION of a SHEET that doesn't contain one"))
51
52 (defmethod (setf sheet-transformation) (transformation (sheet sheet))
53 (declare (ignore transformation))
54 (error "Attempting to set the TRANSFORMATION of a SHEET that doesn't contain one"))
55
56 (defmethod sheet-medium ((sheet sheet))
57 (error "Attempting to get the MEDIUM of a SHEET that doesn't contain one"))
58
59 (defmethod (setf sheet-medium) (medium (sheet sheet))
60 (declare (ignore medium))
61 (error "Attempting to set the MEDIUM of a SHEET that doesn't contain one"))
62
63 ;;; SHEET error conditions
64
65 (define-condition sheet-already-has-parent (error)
66 (
67 ))
68
69 (define-condition sheet-is-not-child (error)
70 (
71 ))
72
73 ;;; SHEET relationship functions
74
75 (defmethod sheet-adopt-child ((sheet sheet) (child sheet))
76 (error "SHEET attempting to adopt a child"))
77
78 (defmethod sheet-disown-child ((sheet sheet) (child sheet) &key (errorp t))
79 (cond
80 ((eq (sheet-parent child) sheet)
81 (set-sheets-parent child nil)
82 (with-slots (children) sheet
83 (setf children (remove child children)))
84 )
85 (errorp
86 (error 'sheet-is-not-child)))
87 child)
88
89 (defmethod sheet-siblings ((sheet sheet))
90 (remove sheet (sheet-children (sheet-parent sheet))))
91
92 (defmethod sheet-enabled-children ((sheet sheet))
93 (loop for child in (sheet-children sheet)
94 if (sheet-enabled-p child)
95 collect child))
96
97 (defmethod sheet-ancestor-p ((sheet sheet) (putative-ancestor sheet))
98 (loop for s = (sheet-parent sheet) then (sheet-parent s)
99 until (null s)
100 if (eq s putative-ancestor)
101 return t
102 finally (return nil)))
103
104 (defmethod raise-sheet ((sheet sheet))
105 (with-slots (children) (sheet-parent sheet)
106 (setf children (cons sheet (remove sheet children))))
107 sheet)
108
109 (defmethod bury-sheet ((sheet sheet))
110 (with-slots (children) (sheet-parent sheet)
111 (setf children (nconc (remove sheet children) (list sheet))))
112 sheet)
113
114 (define-condition sheet-ordering-underspecified (error)
115 (
116 ))
117
118 (defmethod reorder-sheets ((sheet sheet) new-ordering)
119 (with-slots (children) sheet
120 (if (set-difference children new-ordering)
121 (error 'sheet-ordering-underspecified))
122 (if (set-difference new-ordering children)
123 (error 'sheet-is-not-child))
124 (setf children new-ordering))
125 sheet)
126
127 (defmethod sheet-viewable-p ((sheet sheet))
128 (and (sheet-enabled-p sheet)
129 (or (null (sheet-parent sheet))
130 (sheet-viewable-p (sheet-parent sheet)))))
131
132 (defmethod sheet-occluding-sheets ((sheet sheet) (child sheet))
133 (let ((childs-region (sheet-region child))
134 (results nil))
135 (do ((children (sheet-children sheet) (cdr children)))
136 ((or (null children)
137 (eq (first children) child)))
138 (if (and (sheet-enabled-p (first children))
139 (region-intersects-region-p childs-region (sheet-region (first children))))
140 (push (first children) results)))
141 results))
142
143 ;;; SHEET mixin classes
144
145 (defclass sheet-parent-mixin ()
146 ((parent :initform nil
147 :reader sheet-parent)
148 ))
149
150 (defmethod set-sheets-parent ((child sheet-parent-mixin) (parent sheet))
151 (setf (slot-value child 'parent) parent))
152
153 (defclass sheet-leaf-mixin ()
154 (
155 ))
156
157 (defmethod sheet-adopt-child ((sheet sheet-leaf-mixin) (child sheet))
158 (error "Leaf sheet attempting to adopt a child"))
159
160 (defclass sheet-single-child-mixin ()
161 ((children :initform nil
162 :reader sheet-children)
163 ))
164
165 (defmethod sheet-adopt-child ((sheet sheet-single-child-mixin) (child sheet))
166 (if (sheet-parent child)
167 (error 'sheet-already-has-parent))
168 (if (sheet-children sheet)
169 (error "Single Child Sheet attempting to adopt a second child"))
170 (set-sheets-parent child sheet)
171 (with-slots (children) sheet
172 (setf children (list child)))
173 child)
174
175 (defclass sheet-multiple-child-mixin ()
176 ((children :initform nil
177 :reader sheet-children)
178 ))
179
180 (defmethod sheet-adopt-child ((sheet sheet-multiple-child-mixin) (child sheet))
181 (if (sheet-parent child)
182 (error 'sheet-already-has-parent))
183 (set-sheets-parent child sheet)
184 (with-slots (children) sheet
185 (setf children (append children (list child))))
186 child)
187
188 ;;; SHEET geometry functions
189
190 (defmethod map-sheet-position-to-parent ((sheet sheet) x y)
191 (transform-position (sheet-transformation sheet) x y))
192
193 (defmethod map-sheet-position-to-child ((sheet sheet) x y)
194 (transform-position (invert-transformation (sheet-transformation sheet)) x y))
195
196 (defmethod map-sheet-rectangle*-to-parent ((sheet sheet) x1 y1 x2 y2)
197 (transform-rectangle* (sheet-transformation sheet) x1 y1 x2 y2))
198
199 (defmethod map-sheet-rectangle*-to-child ((sheet sheet) x1 y1 x2 y2)
200 (transform-rectangle* (invert-transformation (sheet-transformation sheet)) x1 y1 x2 y2))
201
202 (defmethod child-containing-position ((sheet sheet) x y)
203 (loop for child in (sheet-children sheet)
204 do (multiple-value-bind (tx ty) (map-sheet-position-to-child child x y)
205 (if (and (sheet-enabled-p child)
206 (region-contains-position-p (sheet-region child) tx ty))
207 (return child)))))
208
209 (defmethod children-overlapping-region ((sheet sheet) (region region))
210 (loop for child in (sheet-children sheet)
211 if (and (sheet-enabled-p child)
212 (region-intersects-region-p region (transform-region (sheet-transformation child) (sheet-region child))))
213 collect child))
214
215 (defmethod children-overlapping-rectangle* ((sheet sheet) x1 y1 x2 y2)
216 (loop with region = (make-rectangle* x1 y1 x2 y2)
217 for child in (sheet-children sheet)
218 if (and (sheet-enabled-p child)
219 (region-intersects-region-p region (transform-region (sheet-transformation child) (sheet-region child))))
220 collect child))
221
222 (defmethod sheet-delta-transformation ((sheet sheet) (ancestor (eql nil)))
223 (if (sheet-parent sheet)
224 (compose-transformations (sheet-transformation sheet)
225 (sheet-delta-transformation
226 (sheet-parent sheet) ancestor))
227 (sheet-transformation sheet)))
228
229 (define-condition sheet-is-not-ancestor (error) ())
230
231 (defmethod sheet-delta-transformation ((sheet sheet) (ancestor sheet))
232 (cond ((eq sheet ancestor) +identity-transformation+)
233 ((sheet-parent sheet)
234 (compose-transformations (sheet-transformation sheet)
235 (sheet-delta-transformation
236 (sheet-parent sheet) ancestor)))
237 (t (error 'sheet-is-not-ancestor))))
238
239 (defmethod sheet-allocated-region ((sheet sheet) (child sheet))
240 (loop with region = (sheet-region child)
241 with inverse-transform = (invert-transformation (sheet-transformation child))
242 for sibling in (sheet-siblings child)
243 for siblings-region = (transform-region inverse-transform (transform-region (sheet-transformation sibling) (sheet-region sibling)))
244 do (if (region-intersects-region-p region siblings-region)
245 (setq region (region-difference region siblings-region)))
246 finally (return region)))
247
248 ;;; SHEET geometry classes
249
250 (defclass sheet-identity-transformation-mixin ()
251 ((transformation :initform (make-instance 'transformation)
252 :initarg :transformation
253 :accessor sheet-transformation)
254 ))
255
256 (defmethod (setf sheet-transformation) :before ((transformation transformation) (sheet sheet-identity-transformation-mixin))
257 (if (not (identity-transformation-p transformation))
258 (error "Attempting to set the SHEET-TRANSFORMATION of a SHEET-IDENTITY-TRANSFORMATION-MIXIN to a non identity transformation")))
259
260 (defclass sheet-translation-transformation-mixin ()
261 ((transformation :initform (make-instance 'transformation)
262 :initarg :transformation
263 :accessor sheet-transformation)
264 ))
265
266 (defmethod (setf sheet-transformation) :before ((transformation transformation) (sheet sheet-translation-transformation-mixin))
267 (if (not (translation-transformation-p transformation))
268 (error "Attempting to set the SHEET-TRANSFORMATION of a SHEET-TRANSLATION-TRANSFORMATION-MIXIN to a non translation transformation")))
269
270 (defclass sheet-y-inverting-transformation-mixin ()
271 ((transformation :initform (make-instance 'transformation :myy -1.0)
272 :initarg :transformation
273 :accessor sheet-transformation)
274 ))
275
276 (defmethod (setf sheet-transformation) :before ((transformation transformation) (sheet sheet-y-inverting-transformation-mixin))
277 (if (not (y-inverting-transformation-p transformation))
278 (error "Attempting to set the SHEET-TRANSFORMATION of a SHEET-Y-INVERTING-TRANSFORMATION-MIXIN to a non Y inverting transformation")))
279
280 (defclass sheet-transformation-mixin ()
281 ((transformation :initform (make-instance 'transformation)
282 :initarg :transformation
283 :accessor sheet-transformation)
284 ))
285
286 ;;; Mirrored-Sheet class
287
288 (defclass mirrored-sheet (sheet)
289 ()
290 )
291
292 (defmethod sheet-direct-mirror ((sheet sheet))
293 nil)
294
295 (defmethod sheet-direct-mirror ((sheet mirrored-sheet))
296 (port-lookup-mirror (port sheet) sheet))
297
298 (defmethod sheet-mirrored-ancestor ((sheet sheet))
299 (if (sheet-parent sheet)
300 (sheet-mirrored-ancestor (sheet-parent sheet))))
301
302 (defmethod sheet-mirrored-ancestor ((sheet mirrored-sheet))
303 sheet)
304
305 (defmethod sheet-mirror ((sheet sheet))
306 (let ((mirrored-ancestor (sheet-mirrored-ancestor sheet)))
307 (if mirrored-ancestor
308 (sheet-direct-mirror mirrored-ancestor))))
309
310 ;;; REALIZE-MIRROR and UNREALIZE-MIRROR have been moved to ports.lisp because
311 ;;; they require the PORT class to be defined
312
313 ;;; Repaint protocol
314
315 (defclass standard-repaint-mixin () ())
316
317 (defmethod dispatch-repaint ((sheet standard-repaint-mixin) region)
318 (queue-repaint sheet region))
319
320 (defclass immediate-repaint-mixin () ())
321
322 (defmethod dispatch-repaint ((sheet immediate-repaint-mixin) region)
323 (handle-repaint sheet nil region))
324
325 (defclass mute-repaint-mixin () ())
326
327 (defmethod dispatch-repaint ((sheet mute-repaint-mixin) region)
328 (handle-repaint sheet nil region))
329
330 (defmethod dispatch-repaint ((sheet standard-repaint-mixin) region)
331 (queue-repaint sheet region))
332
333 (defmethod repaint-sheet ((sheet mute-repaint-mixin) region)
334 (declare (ignore region))
335 (values))

  ViewVC Help
Powered by ViewVC 1.1.5