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

Contents of /mcclim/medium.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.14 - (hide annotations)
Tue Aug 21 13:37:08 2001 UTC (12 years, 7 months ago) by rouanet
Branch: MAIN
Changes since 1.13: +31 -4 lines
- clx-medium is now a subclass of basic-medium.  As a consequence, the
medium-transformation stuff has been removed from the medium-draw-*
methods on clx-medium, because the arguments are automatically
transformed by the basic-medium.

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

  ViewVC Help
Powered by ViewVC 1.1.5