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

Contents of /mcclim/medium.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.39 - (hide annotations)
Tue Jul 9 17:27:35 2002 UTC (11 years, 9 months ago) by adejneka
Branch: MAIN
Changes since 1.38: +14 -0 lines
* Made WITH-SPECIAL-CHOICES work.
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 gilbert 1.28 ;;;; TODO
21 mikemac 1.1
22 gilbert 1.28 ;;; Text Styles
23 mikemac 1.1
24 gilbert 1.28 ;; - *UNDEFINED-TEXT-STYLE* is missing
25     ;; - Why is (EQ (MAKE-TEXT-STYLE NIL NIL 10) (MAKE-TEXT-STYLE NIL NIL 10.0005)) = T?
26     ;; Does it matter?
27     ;; - Don't we want a weak hash-table for *TEXT-STYLE-HASH-TABLE*
28     ;;
29     ;; --GB 2002-02-26
30    
31     ;;; Notes
32    
33     ;; The text-style protocol is kind of useless for now. How is an
34     ;; application programmer expected to implement new text-styles? I
35     ;; think we would need something like:
36     ;;
37     ;; TEXT-STYLE-CHARACTER-METRICS text-style character[1]
38     ;; -> width, ascent, descent, left-bearing, right-bearing
39     ;;
40     ;; TEXT-STYLE-DRAW-TEXT text-style medium string x y
41     ;; Or even better:
42     ;; DESIGN-FROM-TEXT-STYLE-CHARACTER text-style character
43     ;;
44     ;;
45     ;; And when you start to think about it, text-styles are not fonts. So
46     ;; we need two protocols: A text style protocol and a font protocol.
47     ;;
48     ;; A text style is then something, which maps a sequence of characters
49     ;; into a couple of drawing commands, while probably using some font.
50     ;;
51     ;; While a font is something, which maps a _glyph index_ into a design.
52     ;;
53     ;; Example: Underlined with extra word spacing is a text style, while
54     ;; Adobe Times Roman 12pt is a font.
55     ;;
56     ;; And [it can't be said too often] unicode is not a glyph encoding
57     ;; but more a kind of text formating.
58     ;;
59     ;; [1] or even a code position
60     ;; --GB
61 gilbert 1.24
62 gilbert 1.28 (in-package :CLIM-INTERNALS)
63 gilbert 1.24
64 gilbert 1.28 ;; This must come early, because of implementation quirks:
65 mikemac 1.1
66 gilbert 1.28 (define-protocol-class medium ()
67     ())
68 adejneka 1.10
69 gilbert 1.28 ;;;;
70     ;;;; 11 Text Styles
71     ;;;;
72 mikemac 1.1
73     (eval-when (eval load compile)
74    
75 gilbert 1.28 (define-protocol-class text-style ()
76 gilbert 1.23 ())
77    
78 gilbert 1.28 (defgeneric text-style-components (text-style))
79     (defgeneric text-style-family (text-style))
80     (defgeneric text-style-face (text-style))
81     (defgeneric text-style-size (text-style))
82 adejneka 1.34 (defgeneric merge-text-styles (text-style-1 text-style-2))
83 gilbert 1.28 (defgeneric text-style-ascent (text-style medium))
84     (defgeneric text-style-descent (text-style medium))
85     (defgeneric text-style-height (text-style medium))
86     (defgeneric text-style-width (text-style medium))
87     (defgeneric text-style-fixed-width-p (text-style medium))
88 gilbert 1.23
89     (defclass standard-text-style (text-style)
90 cvs 1.4 ((family :initarg :text-family
91     :initform :fix
92     :reader text-style-family)
93 gilbert 1.28 (face :initarg :text-face
94     :initform :roman
95     :reader text-style-face)
96     (size :initarg :text-size
97     :initform :normal
98     :reader text-style-size)))
99 cvs 1.4
100     (defun family-key (family)
101     (ecase family
102     ((nil) 0)
103 cvs 1.5 ((:fix :fixed) 1)
104 cvs 1.4 ((:serif) 2)
105     ((:sans-serif) 3)))
106    
107     (defun face-key (face)
108     (if (equal face '(:bold :italic))
109     4
110     (ecase face
111     ((nil) 0)
112     ((:roman) 1)
113     ((:bold) 2)
114 cvs 1.5 ((:italic) 3))))
115 cvs 1.4
116     (defun size-key (size)
117     (if (numberp size)
118     (+ 10 (round (* 256 size)))
119     (ecase size
120     ((nil) 0)
121     ((:tiny) 1)
122     ((:very-small) 2)
123     ((:small) 3)
124     ((:normal) 4)
125     ((:large) 5)
126     ((:very-large) 6)
127     ((:huge) 7)
128     ((:smaller 8))
129     ((:larger 9)))))
130    
131     (defun text-style-key (family face size)
132     (+ (* 256 (size-key size))
133     (* 16 (face-key face))
134     (family-key family)))
135    
136     (defvar *text-style-hash-table* (make-hash-table :test #'eql))
137    
138     (defun make-text-style (family face size)
139     (let ((key (text-style-key family face size)))
140     (declare (type fixnum key))
141     (or (gethash key *text-style-hash-table*)
142     (setf (gethash key *text-style-hash-table*)
143     (make-instance 'standard-text-style
144     :text-family family
145     :text-face face
146     :text-size size)))))
147 cvs 1.7 ) ; end eval-when
148 mikemac 1.1
149 gilbert 1.24 (defmethod print-object ((self text-style) stream)
150     (print-unreadable-object (self stream :type t :identity nil)
151     (format stream "~{~S~^ ~}" (multiple-value-list (text-style-components self)))))
152    
153 mikemac 1.1 (defconstant *default-text-style* (make-text-style :fix :roman :normal))
154    
155     (defconstant *smaller-sizes* '(:huge :very-large :large :normal
156     :small :very-small :tiny :tiny))
157    
158 gilbert 1.24 (defconstant *font-scaling-factor* 4/3)
159     (defconstant *font-min-size* 6)
160     (defconstant *font-max-size* 48)
161    
162 mikemac 1.1 (defun find-smaller-size (size)
163     (if (numberp size)
164 gilbert 1.24 (max (round (/ size *font-scaling-factor*)) *font-min-size*)
165 mikemac 1.1 (cadr (member size *smaller-sizes*))))
166    
167     (defconstant *larger-sizes* '(:tiny :very-small :small :normal
168     :large :very-large :huge :huge))
169    
170     (defun find-larger-size (size)
171     (if (numberp size)
172 gilbert 1.24 (min (round (* size *font-scaling-factor*)) *font-max-size*)
173 mikemac 1.1 (cadr (member size *larger-sizes*))))
174    
175 gilbert 1.23 (defmethod text-style-components ((text-style standard-text-style))
176     (values (text-style-family text-style)
177     (text-style-face text-style)
178     (text-style-size text-style)))
179 cvs 1.7
180     ;;; Device-Font-Text-Style class
181    
182     (defclass device-font-text-style (text-style)
183     ())
184    
185     (defun device-font-text-style-p (s)
186     (typep s 'device-font-text-style))
187    
188 adejneka 1.38 (defmethod text-style-mapping ((port basic-port) text-style
189     &optional character-set)
190     (declare (ignore character-set))
191     (gethash (parse-text-style text-style) (port-text-style-mappings port)))
192    
193     (defmethod (setf text-style-mapping) (mapping (port basic-port)
194     text-style
195     &optional character-set)
196     (declare (ignore character-set))
197     (setf (text-style-mapping port (parse-text-style text-style)) mapping))
198    
199     (defmethod (setf text-style-mapping) (mapping (port basic-port)
200     (text-style text-style)
201     &optional character-set)
202     (declare (ignore character-set))
203     (when (listp mapping)
204     (error "Delayed mapping is not supported.")) ; FIXME
205     (setf (gethash text-style (port-text-style-mappings port))
206     mapping))
207    
208     (defun make-device-font-text-style (port font-name)
209     (let ((text-style (make-instance 'device-font-text-style
210     :text-family font-name
211     :text-face nil
212     :text-size nil)))
213     (setf (text-style-mapping port text-style) font-name)
214     text-style))
215 cvs 1.7
216 adejneka 1.8 ;;; Text-style utilities
217 cvs 1.7
218 adejneka 1.34 (defmethod merge-text-styles (s1 s2)
219     (setq s1 (parse-text-style s1))
220     (setq s2 (parse-text-style s2))
221 cvs 1.7 (if (and (not (device-font-text-style-p s1))
222     (not (device-font-text-style-p s2)))
223 adejneka 1.36 (let* ((family (or (text-style-family s1) (text-style-family s2)))
224 adejneka 1.37 (face1 (text-style-face s1))
225     (face2 (text-style-face s2))
226     (face (if (subsetp '(:bold :italic) (list face1 face2))
227     '(:bold :italic)
228     (or face1 face2)))
229 adejneka 1.36 (size1 (text-style-size s1))
230     (size2 (text-style-size s2))
231     (size (case size1
232     ((nil) size2)
233     (:smaller (find-smaller-size size2))
234     (:larger (find-larger-size size2))
235     (t size1))))
236     (make-text-style family face size))
237 cvs 1.7 s1))
238 mikemac 1.1
239     (defun parse-text-style (style)
240 adejneka 1.37 (cond ((text-style-p style) style)
241     ((null style) (make-text-style nil nil nil)) ; ?
242     ((and (listp style) (= 3 (length style)))
243     (apply #'make-text-style style))
244     (t (error "Invalid text style specification ~S." style))))
245 mikemac 1.1
246     (defmacro with-text-style ((medium text-style) &body body)
247 adejneka 1.8 (when (eq medium t)
248     (setq medium '*standard-output*))
249 adejneka 1.36 (check-type medium symbol)
250 adejneka 1.37 (with-gensyms (cont)
251     `(flet ((,cont (,medium)
252     (declare (ignorable ,medium))
253     ,@body))
254     (declare (dynamic-extent #',cont))
255     (invoke-with-text-style ,medium #',cont
256     (parse-text-style ,text-style)))))
257 adejneka 1.36
258     (defmethod invoke-with-text-style ((sheet sheet) continuation text-style)
259     (let ((medium (sheet-medium sheet))) ; FIXME: WITH-SHEET-MEDIUM
260     (with-text-style (medium text-style)
261     (funcall continuation sheet))))
262    
263     (defmethod invoke-with-text-style ((medium medium) continuation text-style)
264     (letf (((medium-text-style medium)
265     (merge-text-styles text-style (medium-merged-text-style medium))))
266     (funcall continuation medium)))
267 mikemac 1.1
268     (defmacro with-text-family ((medium family) &body body)
269 adejneka 1.8 (declare (type symbol medium))
270     (when (eq medium t)
271     (setq medium '*standard-output*))
272 adejneka 1.37 (with-gensyms (cont)
273     `(flet ((,cont (,medium)
274     (declare (ignorable ,medium))
275     ,@body))
276     (declare (dynamic-extent #',cont))
277     (invoke-with-text-style ,medium #',cont
278     (make-text-style ,family nil nil)))))
279 mikemac 1.1
280     (defmacro with-text-face ((medium face) &body body)
281 adejneka 1.8 (declare (type symbol medium))
282     (when (eq medium t)
283     (setq medium '*standard-output*))
284 adejneka 1.37 (with-gensyms (cont)
285     `(flet ((,cont (,medium)
286     (declare (ignorable ,medium))
287     ,@body))
288     (declare (dynamic-extent #',cont))
289     (invoke-with-text-style ,medium #',cont
290     (make-text-style nil ,face nil)))))
291 mikemac 1.1
292     (defmacro with-text-size ((medium size) &body body)
293 adejneka 1.8 (declare (type symbol medium))
294 adejneka 1.36 (when (eq medium t) (setq medium '*standard-output*))
295 adejneka 1.37 (with-gensyms (cont)
296     `(flet ((,cont (,medium)
297     (declare (ignorable ,medium))
298     ,@body))
299     (declare (dynamic-extent #',cont))
300     (invoke-with-text-style ,medium #',cont
301     (make-text-style nil nil ,size)))))
302 mikemac 1.1
303    
304 gilbert 1.28 ;;; MEDIUM class
305    
306     (defclass basic-medium (medium)
307     ((foreground :initarg :foreground
308     :initform +black+
309     :accessor medium-foreground)
310     (background :initarg :background
311     :initform +white+
312     :accessor medium-background)
313     (ink :initarg :ink
314     :initform +foreground-ink+
315     :accessor medium-ink)
316     (transformation :type transformation
317     :initarg :transformation
318     :initform +identity-transformation+
319     :accessor medium-transformation)
320     (clipping-region :type region
321     :initarg :clipping-region
322     :initform +everywhere+
323     :documentation "Clipping region in the SHEET coordinates.")
324     ;; always use this slot through its accessor, since there may
325     ;; be secondary methods on it -RS 2001-08-23
326     (line-style :initarg :line-style
327     :initform (make-line-style)
328     :accessor medium-line-style)
329     ;; always use this slot through its accessor, since there may
330     ;; be secondary methods on it -RS 2001-08-23
331     (text-style :initarg :text-style
332     :initform *default-text-style*
333     :accessor medium-text-style)
334     (default-text-style :initarg :default-text-style
335     :initform *default-text-style*
336     :accessor medium-default-text-style)
337     (sheet :initarg :sheet
338     :initform nil ; this means that medium is not linked to a sheet
339     :reader medium-sheet
340     :writer (setf %medium-sheet) ))
341 brian 1.29 (:documentation "The basic class, on which all CLIM mediums are built."))
342 gilbert 1.28
343     (defclass ungrafted-medium (basic-medium) ())
344    
345 mikemac 1.32 (defmethod initialize-instance :after ((medium basic-medium) &rest args)
346 gilbert 1.28 (declare (ignore args))
347     ;; Initial CLIPPING-REGION is in coordinates, given by initial
348     ;; TRANSFORMATION, but we store it in SHEET's coords.
349     (with-slots (clipping-region) medium
350     (setf clipping-region (transform-region (medium-transformation medium)
351     clipping-region))))
352    
353     (defmethod medium-clipping-region ((medium medium))
354     (untransform-region (medium-transformation medium)
355     (slot-value medium 'clipping-region)))
356    
357     (defmethod (setf medium-clipping-region) (region (medium medium))
358     (setf (slot-value medium 'clipping-region)
359     (transform-region (medium-transformation medium)
360     region)))
361    
362     (defmethod (setf medium-clipping-region) :after (region (medium medium))
363     (declare (ignore region))
364     (let ((sheet (medium-sheet medium)))
365     (when sheet
366     (invalidate-cached-regions sheet))))
367    
368     (defmethod (setf medium-transformation) :after (transformation (medium medium))
369     (declare (ignore transformation))
370     (let ((sheet (medium-sheet medium)))
371     (when sheet
372     (invalidate-cached-transformations sheet))))
373    
374     (defmethod medium-merged-text-style ((medium medium))
375     (merge-text-styles (medium-text-style medium) (medium-default-text-style medium)))
376    
377     ;; with-sheet-medium moved to output.lisp. --GB
378     ;; with-sheet-medium-bound moved to output.lisp. --GB
379    
380     (defmacro with-pixmap-medium ((medium pixmap) &body body)
381     (let ((old-medium (gensym))
382     (old-pixmap (gensym)))
383     `(let* ((,old-medium (pixmap-medium ,pixmap))
384     (,medium (or ,old-medium (make-medium (port ,pixmap) ,pixmap)))
385     (,old-pixmap (medium-sheet ,medium)))
386     (setf (pixmap-medium ,pixmap) ,medium)
387     (setf (%medium-sheet ,medium) ,pixmap) ;is medium a basic medium? --GB
388     (unwind-protect
389     (progn
390     ,@body)
391     (setf (pixmap-medium ,pixmap) ,old-medium)
392     (setf (%medium-sheet ,medium) ,old-pixmap)))))
393    
394     ;;; Medium Device functions
395    
396     (defmethod medium-device-transformation ((medium medium))
397     (sheet-device-transformation (medium-sheet medium)))
398    
399     (defmethod medium-device-region ((medium medium))
400     (sheet-device-region (medium-sheet medium)))
401    
402    
403 mikemac 1.1 ;;; Line-Style class
404    
405     (defclass line-style ()
406 gilbert 1.24 ())
407    
408     (defclass standard-line-style (line-style)
409     ((unit :initarg :line-unit
410     :initform :normal
411     :reader line-style-unit
412     :type (member :normal :point :coordinate))
413     (thickness :initarg :line-thickness
414     :initform 1
415     :reader line-style-thickness
416     :type real)
417 mikemac 1.1 (joint-shape :initarg :line-joint-shape
418     :initform :miter
419 gilbert 1.24 :reader line-style-joint-shape
420     :type (member :miter :bevel :round :none))
421     (cap-shape :initarg :line-cap-shape
422     :initform :butt
423     :reader line-style-cap-shape
424     :type (member :butt :squere :round :no-end-point))
425     (dashes :initarg :line-dashes
426     :initform nil
427     :reader line-style-dashes
428     :type (or (member t nil)
429     sequence)) ))
430    
431     (defmethod line-style-p ((x line-style))
432     (declare (ignorable x))
433     t)
434 mikemac 1.1
435 gilbert 1.24 (defmethod line-style-p ((x t))
436     (declare (ignorable x))
437     nil)
438 mikemac 1.1
439     (defun make-line-style (&key (unit :normal) (thickness 1)
440     (joint-shape :miter) (cap-shape :butt)
441     (dashes nil))
442     (make-instance 'standard-line-style
443     :line-unit unit
444     :line-thickness thickness
445     :line-joint-shape joint-shape
446     :line-cap-shape cap-shape
447     :line-dashes dashes))
448    
449 gilbert 1.24 (defmethod print-object ((self standard-line-style) stream)
450     (print-unreadable-object (self stream :type t :identity nil)
451     (format stream "~{~S ~S~^ ~}"
452     (mapcan (lambda (slot)
453     (when (slot-boundp self slot)
454     (list
455     (intern (symbol-name slot) :keyword)
456     (slot-value self slot))))
457     '(unit thickness joint-shape cap-shape dashes)))))
458 mikemac 1.1
459 adejneka 1.35 (defmethod line-style-effective-thickness (line-style medium)
460     ;; FIXME
461     (declare (ignore medium))
462     (line-style-thickness line-style))
463    
464 mikemac 1.1
465     ;;; Misc ops
466    
467     (defmacro with-output-buffered ((medium &optional (buffer-p t)) &body body)
468 adejneka 1.8 (declare (type symbol medium))
469     (when (eq medium t)
470     (setq medium '*standard-output*))
471 mikemac 1.1 (let ((old-buffer (gensym)))
472     `(let ((,old-buffer (medium-buffering-output-p ,medium)))
473     (setf (medium-buffering-output-p ,medium) ,buffer-p)
474     (unwind-protect
475     (progn
476     ,@body)
477     (setf (medium-buffering-output-p ,medium) ,old-buffer)))))
478 adejneka 1.9
479    
480     ;;; BASIC-MEDIUM class
481    
482     (defmacro with-transformed-position ((transformation x y) &body body)
483     `(multiple-value-bind (,x ,y) (transform-position ,transformation ,x ,y)
484     ,@body))
485    
486     (defmacro with-transformed-distance ((transformation dx dy) &body body)
487     `(multiple-value-bind (,dx ,dy) (transform-distance ,transformation ,dx ,dy)
488     ,@body))
489    
490     (defmacro with-transformed-positions ((transformation coord-seq) &body body)
491     `(let ((,coord-seq (transform-positions ,transformation ,coord-seq)))
492     ,@body))
493    
494 rouanet 1.21
495     ;;; Pixmaps
496    
497     (defmethod medium-copy-area ((from-drawable basic-medium) from-x from-y width height
498     to-drawable to-x to-y)
499     (declare (ignore from-x from-y width height to-drawable to-x to-y))
500 rouanet 1.22 (error "MEDIUM-COPY-AREA is not implemented for basic MEDIUMs"))
501 rouanet 1.21
502     (defmethod medium-copy-area (from-drawable from-x from-y width height
503     (to-drawable basic-medium) to-x to-y)
504     (declare (ignore from-drawable from-x from-y width height to-x to-y))
505 rouanet 1.22 (error "MEDIUM-COPY-AREA is not implemented for basic MEDIUMs"))
506 rouanet 1.21
507    
508     ;;; Medium-specific Drawing Functions
509 adejneka 1.9
510     (defmethod medium-draw-point* :around ((medium basic-medium) x y)
511     (let ((tr (medium-transformation medium)))
512     (with-transformed-position (tr x y)
513 adejneka 1.36 (call-next-method medium x y))))
514 adejneka 1.9
515     (defmethod medium-draw-points* :around ((medium basic-medium) coord-seq)
516     (let ((tr (medium-transformation medium)))
517     (with-transformed-positions (tr coord-seq)
518 adejneka 1.36 (call-next-method medium coord-seq))))
519 adejneka 1.9
520     (defmethod medium-draw-line* :around ((medium basic-medium) x1 y1 x2 y2)
521     (let ((tr (medium-transformation medium)))
522     (with-transformed-position (tr x1 y1)
523 adejneka 1.36 (with-transformed-position (tr x2 y2)
524     (call-next-method medium x1 y1 x2 y2)))))
525 adejneka 1.9
526     (defmethod medium-draw-lines* :around ((medium basic-medium) coord-seq)
527     (let ((tr (medium-transformation medium)))
528     (with-transformed-positions (tr coord-seq)
529 adejneka 1.36 (call-next-method medium coord-seq))))
530 adejneka 1.9
531     (defmethod medium-draw-polygon* :around ((medium basic-medium) coord-seq closed filled)
532     (let ((tr (medium-transformation medium)))
533     (with-transformed-positions (tr coord-seq)
534 adejneka 1.36 (call-next-method medium coord-seq closed filled))))
535 adejneka 1.9
536     (defmethod medium-draw-rectangle* :around ((medium basic-medium) left top right bottom filled)
537     (let ((tr (medium-transformation medium)))
538     (if (rectilinear-transformation-p tr)
539     (multiple-value-bind (left top right bottom)
540     (transform-rectangle* tr left top right bottom)
541     (call-next-method medium left top right bottom filled))
542     (medium-draw-polygon* medium (list left top
543     left bottom
544     right bottom
545     right top)
546     t filled))))
547    
548 rouanet 1.14 (defmethod medium-draw-rectangles* :around ((medium basic-medium) position-seq filled)
549     (let ((tr (medium-transformation medium)))
550     (if (rectilinear-transformation-p tr)
551     (loop for (left top right bottom) on position-seq by #'cddddr
552 adejneka 1.31 ;; point-seq can be a vector! --GB
553 rouanet 1.14 nconcing (multiple-value-list
554     (transform-rectangle* tr left top right bottom)) into position-seq
555     finally (call-next-method medium position-seq filled))
556 adejneka 1.31 (map-repeated-sequence nil 4
557     (lambda (left top right bottom)
558     (medium-draw-polygon* medium (list left top
559     left bottom
560     right bottom
561     right top)
562     t filled))
563     position-seq))))
564 rouanet 1.14
565 adejneka 1.9 (defmethod medium-draw-ellipse* :around ((medium basic-medium) center-x center-y
566     radius-1-dx radius-1-dy radius-2-dx radius-2-dy
567     start-angle end-angle filled)
568     (let* ((ellipse (make-elliptical-arc* center-x center-y
569     radius-1-dx radius-1-dy
570     radius-2-dx radius-2-dy
571     :start-angle start-angle
572     :end-angle end-angle))
573     (transformed-ellipse (transform-region (medium-transformation medium)
574     ellipse))
575     (start-angle (ellipse-start-angle transformed-ellipse))
576     (end-angle (ellipse-end-angle transformed-ellipse)))
577     (multiple-value-bind (center-x center-y) (ellipse-center-point* transformed-ellipse)
578     (multiple-value-bind (radius-1-dx radius-1-dy radius-2-dx radius-2-dy)
579     (ellipse-radii transformed-ellipse)
580     (call-next-method medium center-x center-y
581     radius-1-dx radius-1-dy
582     radius-2-dx radius-2-dy
583     start-angle end-angle filled)))))
584 brian 1.29
585     (defmethod medium-draw-circle* :around ((medium basic-medium) center-x center-y
586 gilbert 1.30 radius start-angle end-angle filled)
587 brian 1.29 (let* ((ellipse (make-elliptical-arc* center-x center-y
588     radius 0
589     0 radius
590     :start-angle start-angle
591     :end-angle end-angle))
592     (transformed-ellipse (transform-region (medium-transformation medium)
593     ellipse))
594     (start-angle (ellipse-start-angle transformed-ellipse))
595     (end-angle (ellipse-end-angle transformed-ellipse)))
596     (multiple-value-bind (center-x center-y) (ellipse-center-point* transformed-ellipse)
597     (call-next-method medium center-x center-y radius start-angle end-angle filled))))
598 adejneka 1.9
599     (defmethod medium-draw-text* :around ((medium basic-medium) string x y
600     start end
601     align-x align-y
602     toward-x toward-y transform-glyphs)
603     ;;!!! FIX ME!
604 rouanet 1.14 (let ((tr (medium-transformation medium)))
605     (with-transformed-position (tr x y)
606     (call-next-method medium string x y
607     start end
608     align-x align-y
609     toward-x toward-y transform-glyphs))))
610    
611     (defmethod medium-draw-glyph :around ((medium basic-medium) element x y
612     align-x align-y toward-x toward-y
613     transform-glyphs)
614     (let ((tr (medium-transformation medium)))
615     (with-transformed-position (tr x y)
616 rouanet 1.16 (call-next-method medium element x y
617     align-x align-y toward-x toward-y
618     transform-glyphs))))
619 rouanet 1.22
620     (defmethod medium-copy-area :around ((from-drawable basic-medium)
621     from-x from-y width height
622     to-drawable to-x to-y)
623     (with-transformed-position ((medium-transformation from-drawable)
624     from-x from-y)
625     (call-next-method from-drawable from-x from-y width height
626     to-drawable to-x to-y)))
627    
628     (defmethod medium-copy-area :around (from-drawable from-x from-y width height
629     (to-drawable basic-medium)
630     to-x to-y)
631     (with-transformed-position ((medium-transformation to-drawable)
632     to-x to-y)
633     (call-next-method from-drawable from-x from-y width height
634     to-drawable to-x to-y)))
635 rouanet 1.13
636 rouanet 1.18 ;;; Fall-through Methods For Multiple Objects Drawing Functions
637    
638     (defmethod medium-draw-points* ((medium basic-medium) coord-seq)
639     (let ((tr (invert-transformation (medium-transformation medium))))
640     (with-transformed-positions (tr coord-seq)
641 adejneka 1.37 (map-repeated-sequence nil 2
642     (lambda (x y)
643     (medium-draw-point* medium x y))
644     coord-seq))))
645 rouanet 1.18
646     (defmethod medium-draw-lines* ((medium basic-medium) position-seq)
647     (let ((tr (invert-transformation (medium-transformation medium))))
648     (with-transformed-positions (tr position-seq)
649 adejneka 1.37 (map-repeated-sequence nil 4
650     (lambda (x1 y1 x2 y2)
651     (medium-draw-line* medium x1 y1 x2 y2))
652     position-seq))))
653 rouanet 1.18
654     (defmethod medium-draw-rectangles* ((medium basic-medium) coord-seq filled)
655     (let ((tr (invert-transformation (medium-transformation medium))))
656     (with-transformed-positions (tr coord-seq)
657 adejneka 1.37 (map-repeated-sequence nil 4
658     (lambda (x1 y1 x2 y2)
659     (medium-draw-rectangle* medium
660     x1 y1 x2 y2
661     filled))
662     coord-seq))))
663 rouanet 1.18
664 rouanet 1.13
665     ;;; Other Medium-specific Output Functions
666    
667     (defmethod medium-finish-output ((medium basic-medium))
668     nil)
669    
670     (defmethod medium-force-output ((medium basic-medium))
671     nil)
672    
673     (defmethod medium-clear-area ((medium basic-medium) left top right bottom)
674     (draw-rectangle* medium left top right bottom :ink +background-ink+))
675    
676     (defmethod medium-beep ((medium basic-medium))
677     nil)
678 gilbert 1.24
679     ;;;;;;;;;
680    
681     (defmethod engraft-medium ((medium basic-medium) port sheet)
682 gilbert 1.30 (declare (ignore port))
683 gilbert 1.27 (setf (%medium-sheet medium) sheet)
684     #||
685     (medium-foreground medium) (medium-foreground sheet)
686     (medium-background medium) (medium-background sheet)
687     (medium-ink medium) (medium-ink sheet)
688     (medium-transformation medium) (medium-transformation sheet)
689     (medium-clipping-region medium) (medium-clipping-region sheet)
690     (medium-line-style medium) (medium-line-style sheet)
691     (medium-text-stle medium) (medium-text-stle sheet)
692     ||#
693     )
694 gilbert 1.24
695     (defmethod degraft-medium ((medium basic-medium) port sheet)
696 gilbert 1.30 (declare (ignore port sheet))
697 gilbert 1.24 (setf (%medium-sheet medium) nil))
698    
699     (defmethod allocate-medium ((port port) sheet)
700     (make-medium port sheet))
701    
702     (defmethod deallocate-medium ((port port) medium)
703     (declare (ignorable port medium))
704     nil)
705    
706     (defmethod port ((medium basic-medium))
707     (and (medium-sheet medium)
708     (port (medium-sheet medium))))
709    
710     (defmethod graft ((medium basic-medium))
711     (and (medium-sheet medium)
712     (graft (medium-sheet medium))))
713 gilbert 1.26
714 adejneka 1.39
715     (defmacro with-special-choices ((medium) &body body)
716     "Macro for optimizing drawing with graphical system dependant mechanisms."
717     (with-gensyms (fn)
718     `(flet ((,fn (,medium)
719     (declare (ignorable ,medium))
720     ,@body))
721     (declare (dynamic-extent #',fn))
722     (invoke-with-special-choices #',fn ,medium))))
723    
724     (defgeneric invoke-with-special-choices (continuation sheet))
725    
726     (defmethod invoke-with-special-choices (continuation (medium t))
727     (funcall continuation medium))

  ViewVC Help
Powered by ViewVC 1.1.5