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

Contents of /mcclim/medium.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (show annotations)
Wed Jul 18 05:59:56 2001 UTC (12 years, 9 months ago) by adejneka
Branch: MAIN
Changes since 1.7: +18 -2 lines
* WITH-TEXT-STYLE, WITH-TEXT-FAMILY, WITH-TEXT-FACE, WITH-TEXT-SIZE,
WITH-OUTPUT-BUFFERED: if MEDIUM is T, use *STANDARD-OUTPUT*
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 +foreground-ink+
37 :accessor medium-ink)
38 (transformation :initarg :transformation
39 :initform +identity-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 (defmacro with-pixmap-medium ((medium pixmap) &body body)
93 (let ((old-medium (gensym))
94 (old-pixmap (gensym)))
95 `(let* ((,old-medium (pixmap-medium ,pixmap))
96 (,medium (or ,old-medium (make-medium (port ,pixmap) ,pixmap)))
97 (,old-pixmap (medium-sheet ,medium)))
98 (setf (pixmap-medium ,pixmap) ,medium)
99 (setf (medium-sheet ,medium) ,pixmap)
100 (unwind-protect
101 (progn
102 ,@body)
103 (setf (pixmap-medium ,pixmap) ,old-medium)
104 (setf (medium-sheet ,medium) ,old-pixmap)))))
105
106
107 ;;; Text-Style class
108
109 (eval-when (eval load compile)
110
111 (defclass text-style ()
112 ((family :initarg :text-family
113 :initform :fix
114 :reader text-style-family)
115 (face :initarg :text-face
116 :initform :roman
117 :reader text-style-face)
118 (size :initarg :text-size
119 :initform :normal
120 :reader text-style-size)
121 ))
122
123 (defun text-style-p (x)
124 (typep x 'text-style))
125
126 (defclass standard-text-style (text-style)
127 ())
128
129 (defun family-key (family)
130 (ecase family
131 ((nil) 0)
132 ((:fix :fixed) 1)
133 ((:serif) 2)
134 ((:sans-serif) 3)))
135
136 (defun face-key (face)
137 (if (equal face '(:bold :italic))
138 4
139 (ecase face
140 ((nil) 0)
141 ((:roman) 1)
142 ((:bold) 2)
143 ((:italic) 3))))
144
145 (defun size-key (size)
146 (if (numberp size)
147 (+ 10 (round (* 256 size)))
148 (ecase size
149 ((nil) 0)
150 ((:tiny) 1)
151 ((:very-small) 2)
152 ((:small) 3)
153 ((:normal) 4)
154 ((:large) 5)
155 ((:very-large) 6)
156 ((:huge) 7)
157 ((:smaller 8))
158 ((:larger 9)))))
159
160 (defun text-style-key (family face size)
161 (+ (* 256 (size-key size))
162 (* 16 (face-key face))
163 (family-key family)))
164
165 (defvar *text-style-hash-table* (make-hash-table :test #'eql))
166
167 (defun make-text-style (family face size)
168 (let ((key (text-style-key family face size)))
169 (declare (type fixnum key))
170 (or (gethash key *text-style-hash-table*)
171 (setf (gethash key *text-style-hash-table*)
172 (make-instance 'standard-text-style
173 :text-family family
174 :text-face face
175 :text-size size)))))
176 ) ; end eval-when
177
178 (defconstant *default-text-style* (make-text-style :fix :roman :normal))
179
180 (defconstant *smaller-sizes* '(:huge :very-large :large :normal
181 :small :very-small :tiny :tiny))
182
183 (defun find-smaller-size (size)
184 (if (numberp size)
185 (max (round (* size 0.75)) 6)
186 (cadr (member size *smaller-sizes*))))
187
188 (defconstant *larger-sizes* '(:tiny :very-small :small :normal
189 :large :very-large :huge :huge))
190
191 (defun find-larger-size (size)
192 (if (numberp size)
193 (max (round (* size 4/3)) 6)
194 (cadr (member size *larger-sizes*))))
195
196
197 ;;; Device-Font-Text-Style class
198
199 (defclass device-font-text-style (text-style)
200 ())
201
202 (defun device-font-text-style-p (s)
203 (typep s 'device-font-text-style))
204
205 (defun make-device-font-text-style (display-device device-font-name)
206 (port-make-font-text-style (port display-device) device-font-name))
207
208 ;;; Text-style utilities
209
210 (defun merge-text-styles (s1 s2)
211 (if (and (not (device-font-text-style-p s1))
212 (not (device-font-text-style-p s2)))
213 (let ((new-style (make-text-style (or (text-style-family s1)
214 (text-style-family s2))
215 (or (text-style-face s1)
216 (text-style-face s2))
217 (or (text-style-size s1)
218 (text-style-size s2)))))
219 (with-slots (size) new-style
220 (case size
221 (:smaller
222 (setq size (find-smaller-size (text-style-size s2))))
223 (:larger
224 (setq size (find-larger-size (text-style-size s2))))))
225 new-style)
226 s1))
227
228 (defmethod invoke-with-text-style ((sheet sheet) continuation text-style)
229 (invoke-with-text-style (sheet-medium sheet) continuation text-style))
230
231 (defmethod invoke-with-text-style ((medium medium) continuation text-style)
232 (let ((old-style (medium-text-style medium)))
233 (setf (slot-value medium 'text-style)
234 (merge-text-styles text-style (medium-merged-text-style medium)))
235 (unwind-protect
236 (funcall continuation)
237 (setf (slot-value medium 'text-style) old-style))))
238
239 (defun parse-text-style (style)
240 (if (text-style-p style)
241 style
242 (let ((family nil)
243 (face nil)
244 (size nil))
245 (loop for item in style
246 do (cond
247 ((member item '(fix :serif :sans-serif))
248 (setq family item))
249 ((or (member item '(:roman :bold :italic))
250 (listp item))
251 (setq face item))
252 ((or (member item '(:tiny :very-small :small :normal
253 :large :very-large :huge))
254 (numberp item))
255 (setq size item))))
256 (make-text-style family face size))))
257
258 (defmacro with-text-style ((medium text-style) &body body)
259 (declare (type symbol medium))
260 (when (eq medium t)
261 (setq medium '*standard-output*))
262 `(flet ((continuation ()
263 ,@body))
264 #-clisp (declare (dynamic-extent #'continuation))
265 (invoke-with-text-style ,medium #'continuation (parse-text-style ,text-style))))
266
267 (defmacro with-text-family ((medium family) &body body)
268 (declare (type symbol medium))
269 (when (eq medium t)
270 (setq medium '*standard-output*))
271 `(flet ((continuation ()
272 ,@body))
273 #-clisp (declare (dynamic-extent #'continuation))
274 (invoke-with-text-style ,medium #'continuation (make-text-style ,family nil nil))))
275
276 (defmacro with-text-face ((medium face) &body body)
277 (declare (type symbol medium))
278 (when (eq medium t)
279 (setq medium '*standard-output*))
280 `(flet ((continuation ()
281 ,@body))
282 #-clisp (declare (dynamic-extent #'continuation))
283 (invoke-with-text-style ,medium
284 #'continuation (make-text-style nil ,face nil))))
285
286 (defmacro with-text-size ((medium size) &body body)
287 (declare (type symbol medium))
288 (when (eq medium t)
289 (setq medium '*standard-output*))
290 `(flet ((continuation ()
291 ,@body))
292 #-clisp (declare (dynamic-extent #'continuation))
293 (invoke-with-text-style ,medium #'continuation (make-text-style nil nil ,size))))
294
295
296 ;;; Line-Style class
297
298 (defclass line-style ()
299 ((unit :initarg :line-unit
300 :initform :normal
301 :reader line-style-unit)
302 (thickness :initarg :line-thickness
303 :initform 1
304 :reader line-style-thickness)
305 (joint-shape :initarg :line-joint-shape
306 :initform :miter
307 :reader line-style-joint-shape)
308 (cap-shape :initarg :line-cap-shape
309 :initform :butt
310 :reader line-style-cap-shape)
311 (dashes :initarg :line-dashes
312 :initform nil
313 :reader line-style-dashes)
314 ))
315
316 (defun line-style-p (x)
317 (typep x 'line-style))
318
319 (defclass standard-line-style (line-style)
320 ())
321
322 (defun make-line-style (&key (unit :normal) (thickness 1)
323 (joint-shape :miter) (cap-shape :butt)
324 (dashes nil))
325 (make-instance 'standard-line-style
326 :line-unit unit
327 :line-thickness thickness
328 :line-joint-shape joint-shape
329 :line-cap-shape cap-shape
330 :line-dashes dashes))
331
332
333 ;;; Graphics ops
334
335 (defgeneric medium-draw-point* (medium x y))
336 (defgeneric medium-draw-points* (medium coord-seq))
337 (defgeneric medium-draw-line* (medium x1 y1 x2 y2))
338 (defgeneric medium-draw-lines* (medium coord-seq))
339 (defgeneric medium-draw-polygon* (medium coord-seq closed filled))
340 (defgeneric medium-draw-rectangle* (medium left top right bottom filled))
341 (defgeneric medium-draw-ellipse* (medium center-x center-y
342 radius-1-dx radius-1-dy radius-2-dx radius-2-dy
343 start-angle end-angle filled))
344 (defgeneric medium-draw-text* (medium string x y
345 start end
346 align-x align-y
347 toward-x toward-y transform-glyphs))
348
349
350 ;;; Misc ops
351
352 (defmacro with-output-buffered ((medium &optional (buffer-p t)) &body body)
353 (declare (type symbol medium))
354 (when (eq medium t)
355 (setq medium '*standard-output*))
356 (let ((old-buffer (gensym)))
357 `(let ((,old-buffer (medium-buffering-output-p ,medium)))
358 (setf (medium-buffering-output-p ,medium) ,buffer-p)
359 (unwind-protect
360 (progn
361 ,@body)
362 (setf (medium-buffering-output-p ,medium) ,old-buffer)))))

  ViewVC Help
Powered by ViewVC 1.1.5