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

Contents of /mcclim/medium.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (hide 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 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     ;;; 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 cvs 1.6 :initform +foreground-ink+
37 mikemac 1.1 :accessor medium-ink)
38     (transformation :initarg :transformation
39 cvs 1.2 :initform +identity-transformation+
40 mikemac 1.1 :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 cvs 1.7 (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 mikemac 1.1
107     ;;; Text-Style class
108    
109     (eval-when (eval load compile)
110    
111 cvs 1.4 (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 cvs 1.5 ((:fix :fixed) 1)
133 cvs 1.4 ((: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 cvs 1.5 ((:italic) 3))))
144 cvs 1.4
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 cvs 1.7 ) ; end eval-when
177 mikemac 1.1
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 cvs 1.7
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 adejneka 1.8 ;;; Text-style utilities
209 cvs 1.7
210 mikemac 1.1 (defun merge-text-styles (s1 s2)
211 cvs 1.7 (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 mikemac 1.1
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 adejneka 1.8 (declare (type symbol medium))
260     (when (eq medium t)
261     (setq medium '*standard-output*))
262 mikemac 1.1 `(flet ((continuation ()
263     ,@body))
264 cvs 1.3 #-clisp (declare (dynamic-extent #'continuation))
265 mikemac 1.1 (invoke-with-text-style ,medium #'continuation (parse-text-style ,text-style))))
266    
267     (defmacro with-text-family ((medium family) &body body)
268 adejneka 1.8 (declare (type symbol medium))
269     (when (eq medium t)
270     (setq medium '*standard-output*))
271 mikemac 1.1 `(flet ((continuation ()
272     ,@body))
273 cvs 1.3 #-clisp (declare (dynamic-extent #'continuation))
274 mikemac 1.1 (invoke-with-text-style ,medium #'continuation (make-text-style ,family nil nil))))
275    
276     (defmacro with-text-face ((medium face) &body body)
277 adejneka 1.8 (declare (type symbol medium))
278     (when (eq medium t)
279     (setq medium '*standard-output*))
280 mikemac 1.1 `(flet ((continuation ()
281     ,@body))
282 cvs 1.3 #-clisp (declare (dynamic-extent #'continuation))
283 adejneka 1.8 (invoke-with-text-style ,medium
284     #'continuation (make-text-style nil ,face nil))))
285 mikemac 1.1
286     (defmacro with-text-size ((medium size) &body body)
287 adejneka 1.8 (declare (type symbol medium))
288     (when (eq medium t)
289     (setq medium '*standard-output*))
290 mikemac 1.1 `(flet ((continuation ()
291     ,@body))
292 cvs 1.3 #-clisp (declare (dynamic-extent #'continuation))
293 mikemac 1.1 (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 adejneka 1.8 (declare (type symbol medium))
354     (when (eq medium t)
355     (setq medium '*standard-output*))
356 mikemac 1.1 (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