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

Contents of /mcclim/medium.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (hide annotations)
Mon Jul 23 10:49:43 2001 UTC (12 years, 8 months ago) by boninfan
Branch: MAIN
Changes since 1.10: +74 -3 lines
Added native-region, native-transformation, device-region and device-transformation.
Julien
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 boninfan 1.11 (transformation :type transformation
39     :initarg :transformation
40 cvs 1.2 :initform +identity-transformation+
41 mikemac 1.1 :accessor medium-transformation)
42 boninfan 1.11 (device-transformation :type transformation
43     :initform nil
44     :accessor medium-device-transformation)
45     (clipping-region :type region
46     :initarg :clipping-region
47 mikemac 1.1 :initform +everywhere+
48 boninfan 1.11 :documentation "Clipping region in the SHEET coordinates.")
49     (device-region :type region
50     :initform nil
51     :accessor medium-device-region)
52 mikemac 1.1 (line-style :initarg :line-style
53     :initform (make-line-style)
54     :accessor medium-line-style)
55     (text-style :initarg :text-style
56     :initform (make-text-style :fix :roman :normal)
57     :accessor medium-text-style)
58     (default-text-style :initarg :default-text-style
59     :initform (make-text-style :fix :roman :normal)
60     :accessor medium-default-text-style)
61     (sheet :initarg :sheet
62     :accessor medium-sheet)
63     ))
64    
65     (defun mediump (x)
66     (typep x 'medium))
67 adejneka 1.10
68     (defmethod initialize-instance :after ((medium medium) &rest args)
69     ;; Initial CLIPPING-REGION is in coordinates, given by initial
70     ;; TRANSFORMATION, but we store it in SHEET's coords.
71     (setf (medium-clipping-region medium)
72     (slot-value medium 'clipping-region)))
73    
74     (defmethod medium-clipping-region ((medium medium))
75     (untransform-region (medium-transformation medium)
76     (slot-value medium 'clipping-region)))
77    
78     (defmethod (setf medium-clipping-region) (region (medium medium))
79     (setf (slot-value medium 'clipping-region)
80     (transform-region (medium-transformation medium)
81     region)))
82 mikemac 1.1
83     (defmethod medium-merged-text-style ((medium medium))
84     (merge-text-styles (medium-text-style medium) (medium-default-text-style medium)))
85    
86     (defmacro with-sheet-medium ((medium sheet) &body body)
87     (let ((old-medium (gensym))
88     (old-sheet (gensym)))
89     `(let* ((,old-medium (sheet-medium ,sheet))
90     (,medium (or ,old-medium (make-medium (port ,sheet) ,sheet)))
91     (,old-sheet (medium-sheet ,medium)))
92     (setf (sheet-medium ,sheet) ,medium)
93     (setf (medium-sheet ,medium) ,sheet)
94     (unwind-protect
95     (progn
96     ,@body)
97     (setf (sheet-medium ,sheet) ,old-medium)
98     (setf (medium-sheet ,medium) ,old-sheet)))))
99    
100     (defmacro with-sheet-medium-bound ((sheet medium) &body body)
101     (let ((old-medium (gensym))
102     (old-sheet (gensym)))
103     `(let* ((,old-medium (sheet-medium ,sheet))
104     (medium (or ,old-medium ,medium (make-medium (port sheet) sheet)))
105     (,old-sheet (medium-sheet ,medium)))
106     (if (null ,old-medium)
107     (setf (sheet-medium ,sheet) ,medium))
108     (setf (medium-sheet ,medium) ,sheet)
109     (unwind-protect
110     (progn
111     ,@body)
112     (setf (sheet-medium ,sheet) ,old-medium)
113     (setf (medium-sheet ,medium) ,old-sheet)))))
114    
115 cvs 1.7 (defmacro with-pixmap-medium ((medium pixmap) &body body)
116     (let ((old-medium (gensym))
117     (old-pixmap (gensym)))
118     `(let* ((,old-medium (pixmap-medium ,pixmap))
119     (,medium (or ,old-medium (make-medium (port ,pixmap) ,pixmap)))
120     (,old-pixmap (medium-sheet ,medium)))
121     (setf (pixmap-medium ,pixmap) ,medium)
122     (setf (medium-sheet ,medium) ,pixmap)
123     (unwind-protect
124     (progn
125     ,@body)
126     (setf (pixmap-medium ,pixmap) ,old-medium)
127     (setf (medium-sheet ,medium) ,old-pixmap)))))
128 boninfan 1.11
129    
130     ;; medium-device-region and medium-device-transformation
131    
132     ; medium-device-region
133    
134     (defmethod (setf medium-clipping-region) :after (clipping-region (medium medium))
135     (declare (ignore clipping-region))
136     (medium-invalidate-cached-device-region (medium-sheet medium)))
137    
138     (defmethod medium-device-region :before ((medium medium))
139     (with-slots (device-region) medium
140     (unless device-region
141     (region-intersection (transform-region (medium-device-transformation medium)
142     (medium-clipping-region medium))
143     (sheet-native-region (medium-sheet medium))))))
144    
145     (defun get-medium-device-region (sheet)
146     (medium-device-region (sheet-medium sheet)))
147     ; (with-sheet-medium (medium sheet)
148     ; (medium-device-region medium)))
149     ; [Julien] For the moment, i don't know which of the two solutions is the right one.
150    
151     (defun medium-invalidate-cached-device-region (sheet)
152     ; (with-sheet-medium (medium sheet)
153     ; (with-slots (device-region) medium
154     ; [Julien] For the moment, i don't know which of the two solutions is the right one.
155     (let ((medium (sheet-medium sheet)))
156     (when medium
157     (with-slots (device-region) (sheet-medium sheet)
158     (when device-region
159     (setf device-region nil)))))) ;)
160    
161    
162     ; medium-device-transformation
163    
164     (defmethod (setf medium-transformation) :after (transformation (medium medium))
165     (declare (ignore transformation))
166     (medium-invalidate-cached-device-transformation (medium-sheet medium)))
167    
168     (defmethod medium-device-transformation :before ((medium medium))
169     (with-slots (device-transformation) medium
170     (unless device-transformation
171     (setf device-transformation (compose-transformations (medium-transformation medium)
172     (sheet-native-transformation (medium-sheet medium)))))))
173    
174     (defun get-medium-device-transformation (sheet)
175     (medium-device-transformation (sheet-medium sheet)))
176     ; (with-sheet-medium (medium sheet)
177     ; (medium-device-transformation medium)))
178     ; [Julien] For the moment, i don't know which of the two solutions is the right one.
179    
180     (defun medium-invalidate-cached-device-transformation (sheet)
181     ; (with-sheet-medium (medium sheet)
182     ; (with-slots (device-transformation) medium
183     ; [Julien] For the moment, i don't know which of the two solutions is the right one.
184     (let ((medium (sheet-medium sheet)))
185     (when medium
186     (with-slots (device-transformation) (sheet-medium sheet)
187     (when device-transformation
188     (setf device-transformation nil)))))) ; )
189    
190    
191 cvs 1.7
192 mikemac 1.1
193     ;;; Text-Style class
194    
195     (eval-when (eval load compile)
196    
197 cvs 1.4 (defclass text-style ()
198     ((family :initarg :text-family
199     :initform :fix
200     :reader text-style-family)
201     (face :initarg :text-face
202     :initform :roman
203     :reader text-style-face)
204     (size :initarg :text-size
205     :initform :normal
206     :reader text-style-size)
207     ))
208    
209     (defun text-style-p (x)
210     (typep x 'text-style))
211    
212     (defclass standard-text-style (text-style)
213     ())
214    
215     (defun family-key (family)
216     (ecase family
217     ((nil) 0)
218 cvs 1.5 ((:fix :fixed) 1)
219 cvs 1.4 ((:serif) 2)
220     ((:sans-serif) 3)))
221    
222     (defun face-key (face)
223     (if (equal face '(:bold :italic))
224     4
225     (ecase face
226     ((nil) 0)
227     ((:roman) 1)
228     ((:bold) 2)
229 cvs 1.5 ((:italic) 3))))
230 cvs 1.4
231     (defun size-key (size)
232     (if (numberp size)
233     (+ 10 (round (* 256 size)))
234     (ecase size
235     ((nil) 0)
236     ((:tiny) 1)
237     ((:very-small) 2)
238     ((:small) 3)
239     ((:normal) 4)
240     ((:large) 5)
241     ((:very-large) 6)
242     ((:huge) 7)
243     ((:smaller 8))
244     ((:larger 9)))))
245    
246     (defun text-style-key (family face size)
247     (+ (* 256 (size-key size))
248     (* 16 (face-key face))
249     (family-key family)))
250    
251     (defvar *text-style-hash-table* (make-hash-table :test #'eql))
252    
253     (defun make-text-style (family face size)
254     (let ((key (text-style-key family face size)))
255     (declare (type fixnum key))
256     (or (gethash key *text-style-hash-table*)
257     (setf (gethash key *text-style-hash-table*)
258     (make-instance 'standard-text-style
259     :text-family family
260     :text-face face
261     :text-size size)))))
262 cvs 1.7 ) ; end eval-when
263 mikemac 1.1
264     (defconstant *default-text-style* (make-text-style :fix :roman :normal))
265    
266     (defconstant *smaller-sizes* '(:huge :very-large :large :normal
267     :small :very-small :tiny :tiny))
268    
269     (defun find-smaller-size (size)
270     (if (numberp size)
271     (max (round (* size 0.75)) 6)
272     (cadr (member size *smaller-sizes*))))
273    
274     (defconstant *larger-sizes* '(:tiny :very-small :small :normal
275     :large :very-large :huge :huge))
276    
277     (defun find-larger-size (size)
278     (if (numberp size)
279     (max (round (* size 4/3)) 6)
280     (cadr (member size *larger-sizes*))))
281    
282 cvs 1.7
283     ;;; Device-Font-Text-Style class
284    
285     (defclass device-font-text-style (text-style)
286     ())
287    
288     (defun device-font-text-style-p (s)
289     (typep s 'device-font-text-style))
290    
291     (defun make-device-font-text-style (display-device device-font-name)
292     (port-make-font-text-style (port display-device) device-font-name))
293    
294 adejneka 1.8 ;;; Text-style utilities
295 cvs 1.7
296 mikemac 1.1 (defun merge-text-styles (s1 s2)
297 cvs 1.7 (if (and (not (device-font-text-style-p s1))
298     (not (device-font-text-style-p s2)))
299     (let ((new-style (make-text-style (or (text-style-family s1)
300     (text-style-family s2))
301     (or (text-style-face s1)
302     (text-style-face s2))
303     (or (text-style-size s1)
304     (text-style-size s2)))))
305     (with-slots (size) new-style
306     (case size
307     (:smaller
308     (setq size (find-smaller-size (text-style-size s2))))
309     (:larger
310     (setq size (find-larger-size (text-style-size s2))))))
311     new-style)
312     s1))
313 mikemac 1.1
314     (defmethod invoke-with-text-style ((sheet sheet) continuation text-style)
315     (invoke-with-text-style (sheet-medium sheet) continuation text-style))
316    
317     (defmethod invoke-with-text-style ((medium medium) continuation text-style)
318     (let ((old-style (medium-text-style medium)))
319     (setf (slot-value medium 'text-style)
320     (merge-text-styles text-style (medium-merged-text-style medium)))
321     (unwind-protect
322     (funcall continuation)
323     (setf (slot-value medium 'text-style) old-style))))
324    
325     (defun parse-text-style (style)
326     (if (text-style-p style)
327     style
328     (let ((family nil)
329     (face nil)
330     (size nil))
331     (loop for item in style
332     do (cond
333     ((member item '(fix :serif :sans-serif))
334     (setq family item))
335     ((or (member item '(:roman :bold :italic))
336     (listp item))
337     (setq face item))
338     ((or (member item '(:tiny :very-small :small :normal
339     :large :very-large :huge))
340     (numberp item))
341     (setq size item))))
342     (make-text-style family face size))))
343    
344     (defmacro with-text-style ((medium text-style) &body body)
345 adejneka 1.8 (declare (type symbol medium))
346     (when (eq medium t)
347     (setq medium '*standard-output*))
348 mikemac 1.1 `(flet ((continuation ()
349     ,@body))
350 cvs 1.3 #-clisp (declare (dynamic-extent #'continuation))
351 mikemac 1.1 (invoke-with-text-style ,medium #'continuation (parse-text-style ,text-style))))
352    
353     (defmacro with-text-family ((medium family) &body body)
354 adejneka 1.8 (declare (type symbol medium))
355     (when (eq medium t)
356     (setq medium '*standard-output*))
357 mikemac 1.1 `(flet ((continuation ()
358     ,@body))
359 cvs 1.3 #-clisp (declare (dynamic-extent #'continuation))
360 mikemac 1.1 (invoke-with-text-style ,medium #'continuation (make-text-style ,family nil nil))))
361    
362     (defmacro with-text-face ((medium face) &body body)
363 adejneka 1.8 (declare (type symbol medium))
364     (when (eq medium t)
365     (setq medium '*standard-output*))
366 mikemac 1.1 `(flet ((continuation ()
367     ,@body))
368 cvs 1.3 #-clisp (declare (dynamic-extent #'continuation))
369 adejneka 1.8 (invoke-with-text-style ,medium
370     #'continuation (make-text-style nil ,face nil))))
371 mikemac 1.1
372     (defmacro with-text-size ((medium size) &body body)
373 adejneka 1.8 (declare (type symbol medium))
374     (when (eq medium t)
375     (setq medium '*standard-output*))
376 mikemac 1.1 `(flet ((continuation ()
377     ,@body))
378 cvs 1.3 #-clisp (declare (dynamic-extent #'continuation))
379 mikemac 1.1 (invoke-with-text-style ,medium #'continuation (make-text-style nil nil ,size))))
380    
381    
382     ;;; Line-Style class
383    
384     (defclass line-style ()
385     ((unit :initarg :line-unit
386     :initform :normal
387     :reader line-style-unit)
388     (thickness :initarg :line-thickness
389     :initform 1
390     :reader line-style-thickness)
391     (joint-shape :initarg :line-joint-shape
392     :initform :miter
393     :reader line-style-joint-shape)
394     (cap-shape :initarg :line-cap-shape
395     :initform :butt
396     :reader line-style-cap-shape)
397     (dashes :initarg :line-dashes
398     :initform nil
399     :reader line-style-dashes)
400     ))
401    
402     (defun line-style-p (x)
403     (typep x 'line-style))
404    
405     (defclass standard-line-style (line-style)
406     ())
407    
408     (defun make-line-style (&key (unit :normal) (thickness 1)
409     (joint-shape :miter) (cap-shape :butt)
410     (dashes nil))
411     (make-instance 'standard-line-style
412     :line-unit unit
413     :line-thickness thickness
414     :line-joint-shape joint-shape
415     :line-cap-shape cap-shape
416     :line-dashes dashes))
417    
418    
419     ;;; Graphics ops
420    
421     (defgeneric medium-draw-point* (medium x y))
422     (defgeneric medium-draw-points* (medium coord-seq))
423     (defgeneric medium-draw-line* (medium x1 y1 x2 y2))
424     (defgeneric medium-draw-lines* (medium coord-seq))
425     (defgeneric medium-draw-polygon* (medium coord-seq closed filled))
426     (defgeneric medium-draw-rectangle* (medium left top right bottom filled))
427     (defgeneric medium-draw-ellipse* (medium center-x center-y
428     radius-1-dx radius-1-dy radius-2-dx radius-2-dy
429     start-angle end-angle filled))
430     (defgeneric medium-draw-text* (medium string x y
431     start end
432     align-x align-y
433     toward-x toward-y transform-glyphs))
434    
435    
436     ;;; Misc ops
437    
438     (defmacro with-output-buffered ((medium &optional (buffer-p t)) &body body)
439 adejneka 1.8 (declare (type symbol medium))
440     (when (eq medium t)
441     (setq medium '*standard-output*))
442 mikemac 1.1 (let ((old-buffer (gensym)))
443     `(let ((,old-buffer (medium-buffering-output-p ,medium)))
444     (setf (medium-buffering-output-p ,medium) ,buffer-p)
445     (unwind-protect
446     (progn
447     ,@body)
448     (setf (medium-buffering-output-p ,medium) ,old-buffer)))))
449 adejneka 1.9
450    
451     ;;; BASIC-MEDIUM class
452    
453     (defclass basic-medium (medium)
454     ()
455     (:documentation "The basic class, on which all CLIM mediums are built."))
456    
457     (defmacro with-transformed-position ((transformation x y) &body body)
458     `(multiple-value-bind (,x ,y) (transform-position ,transformation ,x ,y)
459     ,@body))
460    
461     (defmacro with-transformed-distance ((transformation dx dy) &body body)
462     `(multiple-value-bind (,dx ,dy) (transform-distance ,transformation ,dx ,dy)
463     ,@body))
464    
465     (defmacro with-transformed-positions ((transformation coord-seq) &body body)
466     `(let ((,coord-seq (transform-positions ,transformation ,coord-seq)))
467     ,@body))
468    
469    
470     (defmethod medium-draw-point* :around ((medium basic-medium) x y)
471     (let ((tr (medium-transformation medium)))
472     (with-transformed-position (tr x y)
473     (call-next-method medium x y))))
474    
475     (defmethod medium-draw-points* :around ((medium basic-medium) coord-seq)
476     (let ((tr (medium-transformation medium)))
477     (with-transformed-positions (tr coord-seq)
478     (call-next-method medium coord-seq))))
479    
480     (defmethod medium-draw-line* :around ((medium basic-medium) x1 y1 x2 y2)
481     (let ((tr (medium-transformation medium)))
482     (with-transformed-position (tr x1 y1)
483     (with-transformed-position (tr x2 y2)
484     (call-next-method medium x1 y1 x2 y2)))))
485    
486     (defmethod medium-draw-lines* :around ((medium basic-medium) coord-seq)
487     (let ((tr (medium-transformation medium)))
488     (with-transformed-positions (tr coord-seq)
489     (call-next-method medium coord-seq))))
490    
491     (defmethod medium-draw-polygon* :around ((medium basic-medium) coord-seq closed filled)
492     (let ((tr (medium-transformation medium)))
493     (with-transformed-positions (tr coord-seq)
494     (call-next-method medium coord-seq closed filled))))
495    
496     (defmethod medium-draw-rectangle* :around ((medium basic-medium) left top right bottom filled)
497     (let ((tr (medium-transformation medium)))
498     (if (rectilinear-transformation-p tr)
499     (multiple-value-bind (left top right bottom)
500     (transform-rectangle* tr left top right bottom)
501     (call-next-method medium left top right bottom filled))
502     (medium-draw-polygon* medium (list left top
503     left bottom
504     right bottom
505     right top)
506     t filled))))
507    
508     (defmethod medium-draw-ellipse* :around ((medium basic-medium) center-x center-y
509     radius-1-dx radius-1-dy radius-2-dx radius-2-dy
510     start-angle end-angle filled)
511     (let* ((ellipse (make-elliptical-arc* center-x center-y
512     radius-1-dx radius-1-dy
513     radius-2-dx radius-2-dy
514     :start-angle start-angle
515     :end-angle end-angle))
516     (transformed-ellipse (transform-region (medium-transformation medium)
517     ellipse))
518     (start-angle (ellipse-start-angle transformed-ellipse))
519     (end-angle (ellipse-end-angle transformed-ellipse)))
520     (multiple-value-bind (center-x center-y) (ellipse-center-point* transformed-ellipse)
521     (multiple-value-bind (radius-1-dx radius-1-dy radius-2-dx radius-2-dy)
522     (ellipse-radii transformed-ellipse)
523     (call-next-method medium center-x center-y
524     radius-1-dx radius-1-dy
525     radius-2-dx radius-2-dy
526     start-angle end-angle filled)))))
527    
528     (defmethod medium-draw-text* :around ((medium basic-medium) string x y
529     start end
530     align-x align-y
531     toward-x toward-y transform-glyphs)
532     ;;!!! FIX ME!
533     (call-next-method medium string x y
534     start end
535     align-x align-y
536     toward-x toward-y transform-glyphs))

  ViewVC Help
Powered by ViewVC 1.1.5