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

Contents of /mcclim/sheets.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Thu Jun 8 22:01:12 2000 UTC (13 years, 10 months ago) by mikemac
Branch: MAIN
Branch point for: initial
Initial revision
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))
223 (if (sheet-parent sheet)
224 (compose-transformations (sheet-transformation sheet) (sheet-delta-transformation (sheet-parent sheet)))
225 (compose-transformations (sheet-transformation sheet) +identity-transformation+)))
226
227 (defmethod sheet-allocated-region ((sheet sheet) (child sheet))
228 (loop with region = (sheet-region child)
229 with inverse-transform = (invert-transformation (sheet-transformation child))
230 for sibling in (sheet-siblings child)
231 for siblings-region = (transform-region inverse-transform (transform-region (sheet-transformation sibling) (sheet-region sibling)))
232 do (if (region-intersects-region-p region siblings-region)
233 (setq region (region-difference region siblings-region)))
234 finally (return region)))
235
236 ;;; SHEET geometry classes
237
238 (defclass sheet-identity-transformation-mixin ()
239 ((transformation :initform (make-instance 'transformation)
240 :initarg :transformation
241 :accessor sheet-transformation)
242 ))
243
244 (defmethod (setf sheet-transformation) :before ((transformation transformation) (sheet sheet-identity-transformation-mixin))
245 (if (not (identity-transformation-p transformation))
246 (error "Attempting to set the SHEET-TRANSFORMATION of a SHEET-IDENTITY-TRANSFORMATION-MIXIN to a non identity transformation")))
247
248 (defclass sheet-translation-transformation-mixin ()
249 ((transformation :initform (make-instance 'transformation)
250 :initarg :transformation
251 :accessor sheet-transformation)
252 ))
253
254 (defmethod (setf sheet-transformation) :before ((transformation transformation) (sheet sheet-translation-transformation-mixin))
255 (if (not (translation-transformation-p transformation))
256 (error "Attempting to set the SHEET-TRANSFORMATION of a SHEET-TRANSLATION-TRANSFORMATION-MIXIN to a non translation transformation")))
257
258 (defclass sheet-y-inverting-transformation-mixin ()
259 ((transformation :initform (make-instance 'transformation :myy -1.0)
260 :initarg :transformation
261 :accessor sheet-transformation)
262 ))
263
264 (defmethod (setf sheet-transformation) :before ((transformation transformation) (sheet sheet-y-inverting-transformation-mixin))
265 (if (not (y-inverting-transformation-p transformation))
266 (error "Attempting to set the SHEET-TRANSFORMATION of a SHEET-Y-INVERTING-TRANSFORMATION-MIXIN to a non Y inverting transformation")))
267
268 (defclass sheet-transformation-mixin ()
269 ((transformation :initform (make-instance 'transformation)
270 :initarg :transformation
271 :accessor sheet-transformation)
272 ))
273
274 ;;; Mirrored-Sheet class
275
276 (defclass mirrored-sheet (sheet)
277 ()
278 )
279
280 (defmethod sheet-direct-mirror ((sheet sheet))
281 nil)
282
283 (defmethod sheet-direct-mirror ((sheet mirrored-sheet))
284 (port-lookup-mirror (port sheet) sheet))
285
286 (defmethod sheet-mirrored-ancestor ((sheet sheet))
287 (if (sheet-parent sheet)
288 (sheet-mirrored-ancestor (sheet-parent sheet))))
289
290 (defmethod sheet-mirrored-ancestor ((sheet mirrored-sheet))
291 sheet)
292
293 (defmethod sheet-mirror ((sheet sheet))
294 (let ((mirrored-ancestor (sheet-mirrored-ancestor sheet)))
295 (if mirrored-ancestor
296 (sheet-direct-mirror mirrored-ancestor))))
297
298 ;;; REALIZE-MIRROR and UNREALIZE-MIRROR have been moved to ports.lisp because
299 ;;; they require the PORT class to be defined
300

  ViewVC Help
Powered by ViewVC 1.1.5