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

Contents of /mcclim/medium.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5