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

Contents of /mcclim/medium.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 ;;; MEDIUM class
23
24 (defclass medium ()
25 ((port :initarg :port
26 :accessor port)
27 (graft :initarg :graft
28 :accessor graft)
29 (foreground :initarg :foreground
30 :initform +black+
31 :accessor medium-foreground)
32 (background :initarg :background
33 :initform +white+
34 :accessor medium-background)
35 (ink :initarg :ink
36 :initform +black+
37 :accessor medium-ink)
38 (transformation :initarg :transformation
39 :initform (make-instance 'transformation)
40 :accessor medium-transformation)
41 (clipping-region :initarg :clipping-region
42 :initform +everywhere+
43 :accessor medium-clipping-region)
44 (line-style :initarg :line-style
45 :initform (make-line-style)
46 :accessor medium-line-style)
47 (text-style :initarg :text-style
48 :initform (make-text-style :fix :roman :normal)
49 :accessor medium-text-style)
50 (default-text-style :initarg :default-text-style
51 :initform (make-text-style :fix :roman :normal)
52 :accessor medium-default-text-style)
53 (sheet :initarg :sheet
54 :accessor medium-sheet)
55 ))
56
57 (defun mediump (x)
58 (typep x 'medium))
59
60 (defmethod medium-merged-text-style ((medium medium))
61 (merge-text-styles (medium-text-style medium) (medium-default-text-style medium)))
62
63 (defmacro with-sheet-medium ((medium sheet) &body body)
64 (let ((old-medium (gensym))
65 (old-sheet (gensym)))
66 `(let* ((,old-medium (sheet-medium ,sheet))
67 (,medium (or ,old-medium (make-medium (port ,sheet) ,sheet)))
68 (,old-sheet (medium-sheet ,medium)))
69 (setf (sheet-medium ,sheet) ,medium)
70 (setf (medium-sheet ,medium) ,sheet)
71 (unwind-protect
72 (progn
73 ,@body)
74 (setf (sheet-medium ,sheet) ,old-medium)
75 (setf (medium-sheet ,medium) ,old-sheet)))))
76
77 (defmacro with-sheet-medium-bound ((sheet medium) &body body)
78 (let ((old-medium (gensym))
79 (old-sheet (gensym)))
80 `(let* ((,old-medium (sheet-medium ,sheet))
81 (medium (or ,old-medium ,medium (make-medium (port sheet) sheet)))
82 (,old-sheet (medium-sheet ,medium)))
83 (if (null ,old-medium)
84 (setf (sheet-medium ,sheet) ,medium))
85 (setf (medium-sheet ,medium) ,sheet)
86 (unwind-protect
87 (progn
88 ,@body)
89 (setf (sheet-medium ,sheet) ,old-medium)
90 (setf (medium-sheet ,medium) ,old-sheet)))))
91
92
93 ;;; Text-Style class
94
95 (eval-when (eval load compile)
96
97 (defclass text-style ()
98 ((family :initarg :text-family
99 :initform :fix
100 :reader text-style-family)
101 (face :initarg :text-face
102 :initform :roman
103 :reader text-style-face)
104 (size :initarg :text-size
105 :initform :normal
106 :reader text-style-size)
107 ))
108
109 (defun text-style-p (x)
110 (typep x 'text-style))
111
112 (defclass standard-text-style (text-style)
113 ())
114
115 (defun make-text-style (family face size)
116 (make-instance 'standard-text-style :text-family family :text-face face :text-size size))
117 )
118
119 (defconstant *default-text-style* (make-text-style :fix :roman :normal))
120
121 (defconstant *smaller-sizes* '(:huge :very-large :large :normal
122 :small :very-small :tiny :tiny))
123
124 (defun find-smaller-size (size)
125 (if (numberp size)
126 (max (round (* size 0.75)) 6)
127 (cadr (member size *smaller-sizes*))))
128
129 (defconstant *larger-sizes* '(:tiny :very-small :small :normal
130 :large :very-large :huge :huge))
131
132 (defun find-larger-size (size)
133 (if (numberp size)
134 (max (round (* size 4/3)) 6)
135 (cadr (member size *larger-sizes*))))
136
137 (defun merge-text-styles (s1 s2)
138 (let ((new-style (make-text-style (or (text-style-family s1)
139 (text-style-family s2))
140 (or (text-style-face s1)
141 (text-style-face s2))
142 (or (text-style-size s1)
143 (text-style-size s2)))))
144 (with-slots (size) new-style
145 (case size
146 (:smaller
147 (setq size (find-smaller-size (text-style-size s2))))
148 (:larger
149 (setq size (find-larger-size (text-style-size s2))))))
150 new-style))
151
152 (defmethod invoke-with-text-style ((sheet sheet) continuation text-style)
153 (invoke-with-text-style (sheet-medium sheet) continuation text-style))
154
155 (defmethod invoke-with-text-style ((medium medium) continuation text-style)
156 (let ((old-style (medium-text-style medium)))
157 (setf (slot-value medium 'text-style)
158 (merge-text-styles text-style (medium-merged-text-style medium)))
159 (unwind-protect
160 (funcall continuation)
161 (setf (slot-value medium 'text-style) old-style))))
162
163 (defun parse-text-style (style)
164 (if (text-style-p style)
165 style
166 (let ((family nil)
167 (face nil)
168 (size nil))
169 (loop for item in style
170 do (cond
171 ((member item '(fix :serif :sans-serif))
172 (setq family item))
173 ((or (member item '(:roman :bold :italic))
174 (listp item))
175 (setq face item))
176 ((or (member item '(:tiny :very-small :small :normal
177 :large :very-large :huge))
178 (numberp item))
179 (setq size item))))
180 (make-text-style family face size))))
181
182 (defmacro with-text-style ((medium text-style) &body body)
183 `(flet ((continuation ()
184 ,@body))
185 (declare (dynamic-extent #'continuation))
186 (invoke-with-text-style ,medium #'continuation (parse-text-style ,text-style))))
187
188 (defmacro with-text-family ((medium family) &body body)
189 `(flet ((continuation ()
190 ,@body))
191 (declare (dynamic-extent #'continuation))
192 (invoke-with-text-style ,medium #'continuation (make-text-style ,family nil nil))))
193
194 (defmacro with-text-face ((medium face) &body body)
195 `(flet ((continuation ()
196 ,@body))
197 (declare (dynamic-extent #'continuation))
198 (invoke-with-text-style ,medium #'continuation (make-text-style nil ,face nil))))
199
200 (defmacro with-text-size ((medium size) &body body)
201 `(flet ((continuation ()
202 ,@body))
203 (declare (dynamic-extent #'continuation))
204 (invoke-with-text-style ,medium #'continuation (make-text-style nil nil ,size))))
205
206
207 ;;; Line-Style class
208
209 (defclass line-style ()
210 ((unit :initarg :line-unit
211 :initform :normal
212 :reader line-style-unit)
213 (thickness :initarg :line-thickness
214 :initform 1
215 :reader line-style-thickness)
216 (joint-shape :initarg :line-joint-shape
217 :initform :miter
218 :reader line-style-joint-shape)
219 (cap-shape :initarg :line-cap-shape
220 :initform :butt
221 :reader line-style-cap-shape)
222 (dashes :initarg :line-dashes
223 :initform nil
224 :reader line-style-dashes)
225 ))
226
227 (defun line-style-p (x)
228 (typep x 'line-style))
229
230 (defclass standard-line-style (line-style)
231 ())
232
233 (defun make-line-style (&key (unit :normal) (thickness 1)
234 (joint-shape :miter) (cap-shape :butt)
235 (dashes nil))
236 (make-instance 'standard-line-style
237 :line-unit unit
238 :line-thickness thickness
239 :line-joint-shape joint-shape
240 :line-cap-shape cap-shape
241 :line-dashes dashes))
242
243
244 ;;; Graphics ops
245
246 (defgeneric medium-draw-point* (medium x y))
247 (defgeneric medium-draw-points* (medium coord-seq))
248 (defgeneric medium-draw-line* (medium x1 y1 x2 y2))
249 (defgeneric medium-draw-lines* (medium coord-seq))
250 (defgeneric medium-draw-polygon* (medium coord-seq closed filled))
251 (defgeneric medium-draw-rectangle* (medium left top right bottom filled))
252 (defgeneric medium-draw-ellipse* (medium center-x center-y
253 radius-1-dx radius-1-dy radius-2-dx radius-2-dy
254 start-angle end-angle filled))
255 (defgeneric medium-draw-text* (medium string x y
256 start end
257 align-x align-y
258 toward-x toward-y transform-glyphs))
259
260
261 ;;; Misc ops
262
263 (defmacro with-output-buffered ((medium &optional (buffer-p t)) &body body)
264 (let ((old-buffer (gensym)))
265 `(let ((,old-buffer (medium-buffering-output-p ,medium)))
266 (setf (medium-buffering-output-p ,medium) ,buffer-p)
267 (unwind-protect
268 (progn
269 ,@body)
270 (setf (medium-buffering-output-p ,medium) ,old-buffer)))))

  ViewVC Help
Powered by ViewVC 1.1.5