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

Contents of /mcclim/medium.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (hide annotations)
Mon Sep 11 09:53:32 2000 UTC (13 years, 7 months ago) by cvs
Branch: MAIN
Changes since 1.4: +2 -2 lines
Added :fixed (in addition to :fix) as a valid family.

Fixed a bug in face-key that returned null for :italic face.
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     :initform +black+
37     :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    
93     ;;; Text-Style class
94    
95     (eval-when (eval load compile)
96    
97 cvs 1.4 (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 family-key (family)
116     (ecase family
117     ((nil) 0)
118 cvs 1.5 ((:fix :fixed) 1)
119 cvs 1.4 ((:serif) 2)
120     ((:sans-serif) 3)))
121    
122     (defun face-key (face)
123     (if (equal face '(:bold :italic))
124     4
125     (ecase face
126     ((nil) 0)
127     ((:roman) 1)
128     ((:bold) 2)
129 cvs 1.5 ((:italic) 3))))
130 cvs 1.4
131     (defun size-key (size)
132     (if (numberp size)
133     (+ 10 (round (* 256 size)))
134     (ecase size
135     ((nil) 0)
136     ((:tiny) 1)
137     ((:very-small) 2)
138     ((:small) 3)
139     ((:normal) 4)
140     ((:large) 5)
141     ((:very-large) 6)
142     ((:huge) 7)
143     ((:smaller 8))
144     ((:larger 9)))))
145    
146     (defun text-style-key (family face size)
147     (+ (* 256 (size-key size))
148     (* 16 (face-key face))
149     (family-key family)))
150    
151     (defvar *text-style-hash-table* (make-hash-table :test #'eql))
152    
153     (defun make-text-style (family face size)
154     (let ((key (text-style-key family face size)))
155     (declare (type fixnum key))
156     (or (gethash key *text-style-hash-table*)
157     (setf (gethash key *text-style-hash-table*)
158     (make-instance 'standard-text-style
159     :text-family family
160     :text-face face
161     :text-size size)))))
162     )
163 mikemac 1.1
164     (defconstant *default-text-style* (make-text-style :fix :roman :normal))
165    
166     (defconstant *smaller-sizes* '(:huge :very-large :large :normal
167     :small :very-small :tiny :tiny))
168    
169     (defun find-smaller-size (size)
170     (if (numberp size)
171     (max (round (* size 0.75)) 6)
172     (cadr (member size *smaller-sizes*))))
173    
174     (defconstant *larger-sizes* '(:tiny :very-small :small :normal
175     :large :very-large :huge :huge))
176    
177     (defun find-larger-size (size)
178     (if (numberp size)
179     (max (round (* size 4/3)) 6)
180     (cadr (member size *larger-sizes*))))
181    
182     (defun merge-text-styles (s1 s2)
183     (let ((new-style (make-text-style (or (text-style-family s1)
184     (text-style-family s2))
185     (or (text-style-face s1)
186     (text-style-face s2))
187     (or (text-style-size s1)
188     (text-style-size s2)))))
189     (with-slots (size) new-style
190     (case size
191     (:smaller
192     (setq size (find-smaller-size (text-style-size s2))))
193     (:larger
194     (setq size (find-larger-size (text-style-size s2))))))
195     new-style))
196    
197     (defmethod invoke-with-text-style ((sheet sheet) continuation text-style)
198     (invoke-with-text-style (sheet-medium sheet) continuation text-style))
199    
200     (defmethod invoke-with-text-style ((medium medium) continuation text-style)
201     (let ((old-style (medium-text-style medium)))
202     (setf (slot-value medium 'text-style)
203     (merge-text-styles text-style (medium-merged-text-style medium)))
204     (unwind-protect
205     (funcall continuation)
206     (setf (slot-value medium 'text-style) old-style))))
207    
208     (defun parse-text-style (style)
209     (if (text-style-p style)
210     style
211     (let ((family nil)
212     (face nil)
213     (size nil))
214     (loop for item in style
215     do (cond
216     ((member item '(fix :serif :sans-serif))
217     (setq family item))
218     ((or (member item '(:roman :bold :italic))
219     (listp item))
220     (setq face item))
221     ((or (member item '(:tiny :very-small :small :normal
222     :large :very-large :huge))
223     (numberp item))
224     (setq size item))))
225     (make-text-style family face size))))
226    
227     (defmacro with-text-style ((medium text-style) &body body)
228     `(flet ((continuation ()
229     ,@body))
230 cvs 1.3 #-clisp (declare (dynamic-extent #'continuation))
231 mikemac 1.1 (invoke-with-text-style ,medium #'continuation (parse-text-style ,text-style))))
232    
233     (defmacro with-text-family ((medium family) &body body)
234     `(flet ((continuation ()
235     ,@body))
236 cvs 1.3 #-clisp (declare (dynamic-extent #'continuation))
237 mikemac 1.1 (invoke-with-text-style ,medium #'continuation (make-text-style ,family nil nil))))
238    
239     (defmacro with-text-face ((medium face) &body body)
240     `(flet ((continuation ()
241     ,@body))
242 cvs 1.3 #-clisp (declare (dynamic-extent #'continuation))
243 mikemac 1.1 (invoke-with-text-style ,medium #'continuation (make-text-style nil ,face nil))))
244    
245     (defmacro with-text-size ((medium size) &body body)
246     `(flet ((continuation ()
247     ,@body))
248 cvs 1.3 #-clisp (declare (dynamic-extent #'continuation))
249 mikemac 1.1 (invoke-with-text-style ,medium #'continuation (make-text-style nil nil ,size))))
250    
251    
252     ;;; Line-Style class
253    
254     (defclass line-style ()
255     ((unit :initarg :line-unit
256     :initform :normal
257     :reader line-style-unit)
258     (thickness :initarg :line-thickness
259     :initform 1
260     :reader line-style-thickness)
261     (joint-shape :initarg :line-joint-shape
262     :initform :miter
263     :reader line-style-joint-shape)
264     (cap-shape :initarg :line-cap-shape
265     :initform :butt
266     :reader line-style-cap-shape)
267     (dashes :initarg :line-dashes
268     :initform nil
269     :reader line-style-dashes)
270     ))
271    
272     (defun line-style-p (x)
273     (typep x 'line-style))
274    
275     (defclass standard-line-style (line-style)
276     ())
277    
278     (defun make-line-style (&key (unit :normal) (thickness 1)
279     (joint-shape :miter) (cap-shape :butt)
280     (dashes nil))
281     (make-instance 'standard-line-style
282     :line-unit unit
283     :line-thickness thickness
284     :line-joint-shape joint-shape
285     :line-cap-shape cap-shape
286     :line-dashes dashes))
287    
288    
289     ;;; Graphics ops
290    
291     (defgeneric medium-draw-point* (medium x y))
292     (defgeneric medium-draw-points* (medium coord-seq))
293     (defgeneric medium-draw-line* (medium x1 y1 x2 y2))
294     (defgeneric medium-draw-lines* (medium coord-seq))
295     (defgeneric medium-draw-polygon* (medium coord-seq closed filled))
296     (defgeneric medium-draw-rectangle* (medium left top right bottom filled))
297     (defgeneric medium-draw-ellipse* (medium center-x center-y
298     radius-1-dx radius-1-dy radius-2-dx radius-2-dy
299     start-angle end-angle filled))
300     (defgeneric medium-draw-text* (medium string x y
301     start end
302     align-x align-y
303     toward-x toward-y transform-glyphs))
304    
305    
306     ;;; Misc ops
307    
308     (defmacro with-output-buffered ((medium &optional (buffer-p t)) &body body)
309     (let ((old-buffer (gensym)))
310     `(let ((,old-buffer (medium-buffering-output-p ,medium)))
311     (setf (medium-buffering-output-p ,medium) ,buffer-p)
312     (unwind-protect
313     (progn
314     ,@body)
315     (setf (medium-buffering-output-p ,medium) ,old-buffer)))))

  ViewVC Help
Powered by ViewVC 1.1.5