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

Contents of /mcclim/medium.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.37 - (hide annotations)
Thu Jun 13 07:22:08 2002 UTC (11 years, 10 months ago) by adejneka
Branch: MAIN
Changes since 1.36: +52 -57 lines
* MERGE-TEXT-STYLES: :BOLD + :ITALIC -> (:BOLD :ITALIC).

* PARSE-TEXT-STYLE: parse only canonical specifications.

* WITH-TEXT-{STYLE,FAMILY,FACE,SIZE): really declare MEDIUM to be
  IGNORABLE; use GENSYMed continuation names.

* MEDIUM-DRAW-{POINTS,LINES,RECTANGLES}* (BASIC-MEDIUM ...): use
  MAP-REPEATED-SEQUENCE.
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     (defun make-device-font-text-style (display-device device-font-name)
189 adejneka 1.36 ;; FIXME!!! Non-standard GF.
190 cvs 1.7 (port-make-font-text-style (port display-device) device-font-name))
191    
192 adejneka 1.8 ;;; Text-style utilities
193 cvs 1.7
194 adejneka 1.34 (defmethod merge-text-styles (s1 s2)
195     (setq s1 (parse-text-style s1))
196     (setq s2 (parse-text-style s2))
197 cvs 1.7 (if (and (not (device-font-text-style-p s1))
198     (not (device-font-text-style-p s2)))
199 adejneka 1.36 (let* ((family (or (text-style-family s1) (text-style-family s2)))
200 adejneka 1.37 (face1 (text-style-face s1))
201     (face2 (text-style-face s2))
202     (face (if (subsetp '(:bold :italic) (list face1 face2))
203     '(:bold :italic)
204     (or face1 face2)))
205 adejneka 1.36 (size1 (text-style-size s1))
206     (size2 (text-style-size s2))
207     (size (case size1
208     ((nil) size2)
209     (:smaller (find-smaller-size size2))
210     (:larger (find-larger-size size2))
211     (t size1))))
212     (make-text-style family face size))
213 cvs 1.7 s1))
214 mikemac 1.1
215     (defun parse-text-style (style)
216 adejneka 1.37 (cond ((text-style-p style) style)
217     ((null style) (make-text-style nil nil nil)) ; ?
218     ((and (listp style) (= 3 (length style)))
219     (apply #'make-text-style style))
220     (t (error "Invalid text style specification ~S." style))))
221 mikemac 1.1
222     (defmacro with-text-style ((medium text-style) &body body)
223 adejneka 1.8 (when (eq medium t)
224     (setq medium '*standard-output*))
225 adejneka 1.36 (check-type medium symbol)
226 adejneka 1.37 (with-gensyms (cont)
227     `(flet ((,cont (,medium)
228     (declare (ignorable ,medium))
229     ,@body))
230     (declare (dynamic-extent #',cont))
231     (invoke-with-text-style ,medium #',cont
232     (parse-text-style ,text-style)))))
233 adejneka 1.36
234     (defmethod invoke-with-text-style ((sheet sheet) continuation text-style)
235     (let ((medium (sheet-medium sheet))) ; FIXME: WITH-SHEET-MEDIUM
236     (with-text-style (medium text-style)
237     (funcall continuation sheet))))
238    
239     (defmethod invoke-with-text-style ((medium medium) continuation text-style)
240     (letf (((medium-text-style medium)
241     (merge-text-styles text-style (medium-merged-text-style medium))))
242     (funcall continuation medium)))
243 mikemac 1.1
244     (defmacro with-text-family ((medium family) &body body)
245 adejneka 1.8 (declare (type symbol medium))
246     (when (eq medium t)
247     (setq medium '*standard-output*))
248 adejneka 1.37 (with-gensyms (cont)
249     `(flet ((,cont (,medium)
250     (declare (ignorable ,medium))
251     ,@body))
252     (declare (dynamic-extent #',cont))
253     (invoke-with-text-style ,medium #',cont
254     (make-text-style ,family nil nil)))))
255 mikemac 1.1
256     (defmacro with-text-face ((medium face) &body body)
257 adejneka 1.8 (declare (type symbol medium))
258     (when (eq medium t)
259     (setq medium '*standard-output*))
260 adejneka 1.37 (with-gensyms (cont)
261     `(flet ((,cont (,medium)
262     (declare (ignorable ,medium))
263     ,@body))
264     (declare (dynamic-extent #',cont))
265     (invoke-with-text-style ,medium #',cont
266     (make-text-style nil ,face nil)))))
267 mikemac 1.1
268     (defmacro with-text-size ((medium size) &body body)
269 adejneka 1.8 (declare (type symbol medium))
270 adejneka 1.36 (when (eq medium t) (setq medium '*standard-output*))
271 adejneka 1.37 (with-gensyms (cont)
272     `(flet ((,cont (,medium)
273     (declare (ignorable ,medium))
274     ,@body))
275     (declare (dynamic-extent #',cont))
276     (invoke-with-text-style ,medium #',cont
277     (make-text-style nil nil ,size)))))
278 mikemac 1.1
279    
280 gilbert 1.28 ;;; MEDIUM class
281    
282     (defclass basic-medium (medium)
283     ((foreground :initarg :foreground
284     :initform +black+
285     :accessor medium-foreground)
286     (background :initarg :background
287     :initform +white+
288     :accessor medium-background)
289     (ink :initarg :ink
290     :initform +foreground-ink+
291     :accessor medium-ink)
292     (transformation :type transformation
293     :initarg :transformation
294     :initform +identity-transformation+
295     :accessor medium-transformation)
296     (clipping-region :type region
297     :initarg :clipping-region
298     :initform +everywhere+
299     :documentation "Clipping region in the SHEET coordinates.")
300     ;; always use this slot through its accessor, since there may
301     ;; be secondary methods on it -RS 2001-08-23
302     (line-style :initarg :line-style
303     :initform (make-line-style)
304     :accessor medium-line-style)
305     ;; always use this slot through its accessor, since there may
306     ;; be secondary methods on it -RS 2001-08-23
307     (text-style :initarg :text-style
308     :initform *default-text-style*
309     :accessor medium-text-style)
310     (default-text-style :initarg :default-text-style
311     :initform *default-text-style*
312     :accessor medium-default-text-style)
313     (sheet :initarg :sheet
314     :initform nil ; this means that medium is not linked to a sheet
315     :reader medium-sheet
316     :writer (setf %medium-sheet) ))
317 brian 1.29 (:documentation "The basic class, on which all CLIM mediums are built."))
318 gilbert 1.28
319     (defclass ungrafted-medium (basic-medium) ())
320    
321 mikemac 1.32 (defmethod initialize-instance :after ((medium basic-medium) &rest args)
322 gilbert 1.28 (declare (ignore args))
323     ;; Initial CLIPPING-REGION is in coordinates, given by initial
324     ;; TRANSFORMATION, but we store it in SHEET's coords.
325     (with-slots (clipping-region) medium
326     (setf clipping-region (transform-region (medium-transformation medium)
327     clipping-region))))
328    
329     (defmethod medium-clipping-region ((medium medium))
330     (untransform-region (medium-transformation medium)
331     (slot-value medium 'clipping-region)))
332    
333     (defmethod (setf medium-clipping-region) (region (medium medium))
334     (setf (slot-value medium 'clipping-region)
335     (transform-region (medium-transformation medium)
336     region)))
337    
338     (defmethod (setf medium-clipping-region) :after (region (medium medium))
339     (declare (ignore region))
340     (let ((sheet (medium-sheet medium)))
341     (when sheet
342     (invalidate-cached-regions sheet))))
343    
344     (defmethod (setf medium-transformation) :after (transformation (medium medium))
345     (declare (ignore transformation))
346     (let ((sheet (medium-sheet medium)))
347     (when sheet
348     (invalidate-cached-transformations sheet))))
349    
350     (defmethod medium-merged-text-style ((medium medium))
351     (merge-text-styles (medium-text-style medium) (medium-default-text-style medium)))
352    
353     ;; with-sheet-medium moved to output.lisp. --GB
354     ;; with-sheet-medium-bound moved to output.lisp. --GB
355    
356     (defmacro with-pixmap-medium ((medium pixmap) &body body)
357     (let ((old-medium (gensym))
358     (old-pixmap (gensym)))
359     `(let* ((,old-medium (pixmap-medium ,pixmap))
360     (,medium (or ,old-medium (make-medium (port ,pixmap) ,pixmap)))
361     (,old-pixmap (medium-sheet ,medium)))
362     (setf (pixmap-medium ,pixmap) ,medium)
363     (setf (%medium-sheet ,medium) ,pixmap) ;is medium a basic medium? --GB
364     (unwind-protect
365     (progn
366     ,@body)
367     (setf (pixmap-medium ,pixmap) ,old-medium)
368     (setf (%medium-sheet ,medium) ,old-pixmap)))))
369    
370     ;;; Medium Device functions
371    
372     (defmethod medium-device-transformation ((medium medium))
373     (sheet-device-transformation (medium-sheet medium)))
374    
375     (defmethod medium-device-region ((medium medium))
376     (sheet-device-region (medium-sheet medium)))
377    
378    
379 mikemac 1.1 ;;; Line-Style class
380    
381     (defclass line-style ()
382 gilbert 1.24 ())
383    
384     (defclass standard-line-style (line-style)
385     ((unit :initarg :line-unit
386     :initform :normal
387     :reader line-style-unit
388     :type (member :normal :point :coordinate))
389     (thickness :initarg :line-thickness
390     :initform 1
391     :reader line-style-thickness
392     :type real)
393 mikemac 1.1 (joint-shape :initarg :line-joint-shape
394     :initform :miter
395 gilbert 1.24 :reader line-style-joint-shape
396     :type (member :miter :bevel :round :none))
397     (cap-shape :initarg :line-cap-shape
398     :initform :butt
399     :reader line-style-cap-shape
400     :type (member :butt :squere :round :no-end-point))
401     (dashes :initarg :line-dashes
402     :initform nil
403     :reader line-style-dashes
404     :type (or (member t nil)
405     sequence)) ))
406    
407     (defmethod line-style-p ((x line-style))
408     (declare (ignorable x))
409     t)
410 mikemac 1.1
411 gilbert 1.24 (defmethod line-style-p ((x t))
412     (declare (ignorable x))
413     nil)
414 mikemac 1.1
415     (defun make-line-style (&key (unit :normal) (thickness 1)
416     (joint-shape :miter) (cap-shape :butt)
417     (dashes nil))
418     (make-instance 'standard-line-style
419     :line-unit unit
420     :line-thickness thickness
421     :line-joint-shape joint-shape
422     :line-cap-shape cap-shape
423     :line-dashes dashes))
424    
425 gilbert 1.24 (defmethod print-object ((self standard-line-style) stream)
426     (print-unreadable-object (self stream :type t :identity nil)
427     (format stream "~{~S ~S~^ ~}"
428     (mapcan (lambda (slot)
429     (when (slot-boundp self slot)
430     (list
431     (intern (symbol-name slot) :keyword)
432     (slot-value self slot))))
433     '(unit thickness joint-shape cap-shape dashes)))))
434 mikemac 1.1
435 adejneka 1.35 (defmethod line-style-effective-thickness (line-style medium)
436     ;; FIXME
437     (declare (ignore medium))
438     (line-style-thickness line-style))
439    
440 mikemac 1.1
441     ;;; Misc ops
442    
443     (defmacro with-output-buffered ((medium &optional (buffer-p t)) &body body)
444 adejneka 1.8 (declare (type symbol medium))
445     (when (eq medium t)
446     (setq medium '*standard-output*))
447 mikemac 1.1 (let ((old-buffer (gensym)))
448     `(let ((,old-buffer (medium-buffering-output-p ,medium)))
449     (setf (medium-buffering-output-p ,medium) ,buffer-p)
450     (unwind-protect
451     (progn
452     ,@body)
453     (setf (medium-buffering-output-p ,medium) ,old-buffer)))))
454 adejneka 1.9
455    
456     ;;; BASIC-MEDIUM class
457    
458     (defmacro with-transformed-position ((transformation x y) &body body)
459     `(multiple-value-bind (,x ,y) (transform-position ,transformation ,x ,y)
460     ,@body))
461    
462     (defmacro with-transformed-distance ((transformation dx dy) &body body)
463     `(multiple-value-bind (,dx ,dy) (transform-distance ,transformation ,dx ,dy)
464     ,@body))
465    
466     (defmacro with-transformed-positions ((transformation coord-seq) &body body)
467     `(let ((,coord-seq (transform-positions ,transformation ,coord-seq)))
468     ,@body))
469    
470 rouanet 1.21
471     ;;; Pixmaps
472    
473     (defmethod medium-copy-area ((from-drawable basic-medium) from-x from-y width height
474     to-drawable to-x to-y)
475     (declare (ignore from-x from-y width height to-drawable to-x to-y))
476 rouanet 1.22 (error "MEDIUM-COPY-AREA is not implemented for basic MEDIUMs"))
477 rouanet 1.21
478     (defmethod medium-copy-area (from-drawable from-x from-y width height
479     (to-drawable basic-medium) to-x to-y)
480     (declare (ignore from-drawable from-x from-y width height to-x to-y))
481 rouanet 1.22 (error "MEDIUM-COPY-AREA is not implemented for basic MEDIUMs"))
482 rouanet 1.21
483    
484     ;;; Medium-specific Drawing Functions
485 adejneka 1.9
486     (defmethod medium-draw-point* :around ((medium basic-medium) x y)
487     (let ((tr (medium-transformation medium)))
488     (with-transformed-position (tr x y)
489 adejneka 1.36 (call-next-method medium x y))))
490 adejneka 1.9
491     (defmethod medium-draw-points* :around ((medium basic-medium) coord-seq)
492     (let ((tr (medium-transformation medium)))
493     (with-transformed-positions (tr coord-seq)
494 adejneka 1.36 (call-next-method medium coord-seq))))
495 adejneka 1.9
496     (defmethod medium-draw-line* :around ((medium basic-medium) x1 y1 x2 y2)
497     (let ((tr (medium-transformation medium)))
498     (with-transformed-position (tr x1 y1)
499 adejneka 1.36 (with-transformed-position (tr x2 y2)
500     (call-next-method medium x1 y1 x2 y2)))))
501 adejneka 1.9
502     (defmethod medium-draw-lines* :around ((medium basic-medium) coord-seq)
503     (let ((tr (medium-transformation medium)))
504     (with-transformed-positions (tr coord-seq)
505 adejneka 1.36 (call-next-method medium coord-seq))))
506 adejneka 1.9
507     (defmethod medium-draw-polygon* :around ((medium basic-medium) coord-seq closed filled)
508     (let ((tr (medium-transformation medium)))
509     (with-transformed-positions (tr coord-seq)
510 adejneka 1.36 (call-next-method medium coord-seq closed filled))))
511 adejneka 1.9
512     (defmethod medium-draw-rectangle* :around ((medium basic-medium) left top right bottom filled)
513     (let ((tr (medium-transformation medium)))
514     (if (rectilinear-transformation-p tr)
515     (multiple-value-bind (left top right bottom)
516     (transform-rectangle* tr left top right bottom)
517     (call-next-method medium left top right bottom filled))
518     (medium-draw-polygon* medium (list left top
519     left bottom
520     right bottom
521     right top)
522     t filled))))
523    
524 rouanet 1.14 (defmethod medium-draw-rectangles* :around ((medium basic-medium) position-seq filled)
525     (let ((tr (medium-transformation medium)))
526     (if (rectilinear-transformation-p tr)
527     (loop for (left top right bottom) on position-seq by #'cddddr
528 adejneka 1.31 ;; point-seq can be a vector! --GB
529 rouanet 1.14 nconcing (multiple-value-list
530     (transform-rectangle* tr left top right bottom)) into position-seq
531     finally (call-next-method medium position-seq filled))
532 adejneka 1.31 (map-repeated-sequence nil 4
533     (lambda (left top right bottom)
534     (medium-draw-polygon* medium (list left top
535     left bottom
536     right bottom
537     right top)
538     t filled))
539     position-seq))))
540 rouanet 1.14
541 adejneka 1.9 (defmethod medium-draw-ellipse* :around ((medium basic-medium) center-x center-y
542     radius-1-dx radius-1-dy radius-2-dx radius-2-dy
543     start-angle end-angle filled)
544     (let* ((ellipse (make-elliptical-arc* center-x center-y
545     radius-1-dx radius-1-dy
546     radius-2-dx radius-2-dy
547     :start-angle start-angle
548     :end-angle end-angle))
549     (transformed-ellipse (transform-region (medium-transformation medium)
550     ellipse))
551     (start-angle (ellipse-start-angle transformed-ellipse))
552     (end-angle (ellipse-end-angle transformed-ellipse)))
553     (multiple-value-bind (center-x center-y) (ellipse-center-point* transformed-ellipse)
554     (multiple-value-bind (radius-1-dx radius-1-dy radius-2-dx radius-2-dy)
555     (ellipse-radii transformed-ellipse)
556     (call-next-method medium center-x center-y
557     radius-1-dx radius-1-dy
558     radius-2-dx radius-2-dy
559     start-angle end-angle filled)))))
560 brian 1.29
561     (defmethod medium-draw-circle* :around ((medium basic-medium) center-x center-y
562 gilbert 1.30 radius start-angle end-angle filled)
563 brian 1.29 (let* ((ellipse (make-elliptical-arc* center-x center-y
564     radius 0
565     0 radius
566     :start-angle start-angle
567     :end-angle end-angle))
568     (transformed-ellipse (transform-region (medium-transformation medium)
569     ellipse))
570     (start-angle (ellipse-start-angle transformed-ellipse))
571     (end-angle (ellipse-end-angle transformed-ellipse)))
572     (multiple-value-bind (center-x center-y) (ellipse-center-point* transformed-ellipse)
573     (call-next-method medium center-x center-y radius start-angle end-angle filled))))
574 adejneka 1.9
575     (defmethod medium-draw-text* :around ((medium basic-medium) string x y
576     start end
577     align-x align-y
578     toward-x toward-y transform-glyphs)
579     ;;!!! FIX ME!
580 rouanet 1.14 (let ((tr (medium-transformation medium)))
581     (with-transformed-position (tr x y)
582     (call-next-method medium string x y
583     start end
584     align-x align-y
585     toward-x toward-y transform-glyphs))))
586    
587     (defmethod medium-draw-glyph :around ((medium basic-medium) element x y
588     align-x align-y toward-x toward-y
589     transform-glyphs)
590     (let ((tr (medium-transformation medium)))
591     (with-transformed-position (tr x y)
592 rouanet 1.16 (call-next-method medium element x y
593     align-x align-y toward-x toward-y
594     transform-glyphs))))
595 rouanet 1.22
596     (defmethod medium-copy-area :around ((from-drawable basic-medium)
597     from-x from-y width height
598     to-drawable to-x to-y)
599     (with-transformed-position ((medium-transformation from-drawable)
600     from-x from-y)
601     (call-next-method from-drawable from-x from-y width height
602     to-drawable to-x to-y)))
603    
604     (defmethod medium-copy-area :around (from-drawable from-x from-y width height
605     (to-drawable basic-medium)
606     to-x to-y)
607     (with-transformed-position ((medium-transformation to-drawable)
608     to-x to-y)
609     (call-next-method from-drawable from-x from-y width height
610     to-drawable to-x to-y)))
611 rouanet 1.13
612 rouanet 1.18 ;;; Fall-through Methods For Multiple Objects Drawing Functions
613    
614     (defmethod medium-draw-points* ((medium basic-medium) coord-seq)
615     (let ((tr (invert-transformation (medium-transformation medium))))
616     (with-transformed-positions (tr coord-seq)
617 adejneka 1.37 (map-repeated-sequence nil 2
618     (lambda (x y)
619     (medium-draw-point* medium x y))
620     coord-seq))))
621 rouanet 1.18
622     (defmethod medium-draw-lines* ((medium basic-medium) position-seq)
623     (let ((tr (invert-transformation (medium-transformation medium))))
624     (with-transformed-positions (tr position-seq)
625 adejneka 1.37 (map-repeated-sequence nil 4
626     (lambda (x1 y1 x2 y2)
627     (medium-draw-line* medium x1 y1 x2 y2))
628     position-seq))))
629 rouanet 1.18
630     (defmethod medium-draw-rectangles* ((medium basic-medium) coord-seq filled)
631     (let ((tr (invert-transformation (medium-transformation medium))))
632     (with-transformed-positions (tr coord-seq)
633 adejneka 1.37 (map-repeated-sequence nil 4
634     (lambda (x1 y1 x2 y2)
635     (medium-draw-rectangle* medium
636     x1 y1 x2 y2
637     filled))
638     coord-seq))))
639 rouanet 1.18
640 rouanet 1.13
641     ;;; Other Medium-specific Output Functions
642    
643     (defmethod medium-finish-output ((medium basic-medium))
644     nil)
645    
646     (defmethod medium-force-output ((medium basic-medium))
647     nil)
648    
649     (defmethod medium-clear-area ((medium basic-medium) left top right bottom)
650     (draw-rectangle* medium left top right bottom :ink +background-ink+))
651    
652     (defmethod medium-beep ((medium basic-medium))
653     nil)
654 gilbert 1.24
655     ;;;;;;;;;
656    
657     (defmethod engraft-medium ((medium basic-medium) port sheet)
658 gilbert 1.30 (declare (ignore port))
659 gilbert 1.27 (setf (%medium-sheet medium) sheet)
660     #||
661     (medium-foreground medium) (medium-foreground sheet)
662     (medium-background medium) (medium-background sheet)
663     (medium-ink medium) (medium-ink sheet)
664     (medium-transformation medium) (medium-transformation sheet)
665     (medium-clipping-region medium) (medium-clipping-region sheet)
666     (medium-line-style medium) (medium-line-style sheet)
667     (medium-text-stle medium) (medium-text-stle sheet)
668     ||#
669     )
670 gilbert 1.24
671     (defmethod degraft-medium ((medium basic-medium) port sheet)
672 gilbert 1.30 (declare (ignore port sheet))
673 gilbert 1.24 (setf (%medium-sheet medium) nil))
674    
675     (defmethod allocate-medium ((port port) sheet)
676     (make-medium port sheet))
677    
678     (defmethod deallocate-medium ((port port) medium)
679     (declare (ignorable port medium))
680     nil)
681    
682     (defmethod port ((medium basic-medium))
683     (and (medium-sheet medium)
684     (port (medium-sheet medium))))
685    
686     (defmethod graft ((medium basic-medium))
687     (and (medium-sheet medium)
688     (graft (medium-sheet medium))))
689 gilbert 1.26

  ViewVC Help
Powered by ViewVC 1.1.5