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

Contents of /mcclim/sheets.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (hide 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 mikemac 1.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