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

Contents of /mcclim/medium.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (hide annotations)
Thu Sep 7 20:04:24 2000 UTC (13 years, 7 months ago) by cvs
Branch: MAIN
Changes since 1.2: +4 -4 lines
Removed dynamic extend declaration for clisp to avoid compilation error.
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     (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 cvs 1.3 #-clisp (declare (dynamic-extent #'continuation))
186 mikemac 1.1 (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 cvs 1.3 #-clisp (declare (dynamic-extent #'continuation))
192 mikemac 1.1 (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 cvs 1.3 #-clisp (declare (dynamic-extent #'continuation))
198 mikemac 1.1 (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 cvs 1.3 #-clisp (declare (dynamic-extent #'continuation))
204 mikemac 1.1 (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