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

Contents of /mcclim/medium.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5