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

Contents of /mcclim/medium.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.48 - (hide annotations)
Tue Jan 28 08:17:41 2003 UTC (11 years, 2 months ago) by moore
Branch: MAIN
Changes since 1.47: +19 -0 lines
Output record values are stored in stream coordinates, not user (post
medium transformation) coordinates.

All medium state values are stored in output records by individual
mixin classes that are assembled for each output record type.

Medium parameters are only set in replay-output-record, not set and
restored.  Medium values are set/restored in replay.

Checkpoint of incremental redisplay, currently disabled.

Implement match-output-record.
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 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     (defclass basic-medium (medium)
410     ((foreground :initarg :foreground
411     :initform +black+
412     :accessor medium-foreground)
413     (background :initarg :background
414     :initform +white+
415     :accessor medium-background)
416     (ink :initarg :ink
417     :initform +foreground-ink+
418     :accessor medium-ink)
419     (transformation :type transformation
420     :initarg :transformation
421     :initform +identity-transformation+
422     :accessor medium-transformation)
423     (clipping-region :type region
424     :initarg :clipping-region
425     :initform +everywhere+
426     :documentation "Clipping region in the SHEET coordinates.")
427     ;; always use this slot through its accessor, since there may
428     ;; be secondary methods on it -RS 2001-08-23
429     (line-style :initarg :line-style
430     :initform (make-line-style)
431     :accessor medium-line-style)
432     ;; always use this slot through its accessor, since there may
433     ;; be secondary methods on it -RS 2001-08-23
434     (text-style :initarg :text-style
435     :initform *default-text-style*
436     :accessor medium-text-style)
437     (default-text-style :initarg :default-text-style
438     :initform *default-text-style*
439     :accessor medium-default-text-style)
440     (sheet :initarg :sheet
441     :initform nil ; this means that medium is not linked to a sheet
442     :reader medium-sheet
443     :writer (setf %medium-sheet) ))
444 brian 1.29 (:documentation "The basic class, on which all CLIM mediums are built."))
445 gilbert 1.28
446     (defclass ungrafted-medium (basic-medium) ())
447    
448 mikemac 1.32 (defmethod initialize-instance :after ((medium basic-medium) &rest args)
449 gilbert 1.28 (declare (ignore args))
450     ;; Initial CLIPPING-REGION is in coordinates, given by initial
451     ;; TRANSFORMATION, but we store it in SHEET's coords.
452     (with-slots (clipping-region) medium
453     (setf clipping-region (transform-region (medium-transformation medium)
454     clipping-region))))
455    
456     (defmethod medium-clipping-region ((medium medium))
457     (untransform-region (medium-transformation medium)
458     (slot-value medium 'clipping-region)))
459    
460     (defmethod (setf medium-clipping-region) (region (medium medium))
461     (setf (slot-value medium 'clipping-region)
462     (transform-region (medium-transformation medium)
463     region)))
464    
465     (defmethod (setf medium-clipping-region) :after (region (medium medium))
466     (declare (ignore region))
467     (let ((sheet (medium-sheet medium)))
468     (when sheet
469     (invalidate-cached-regions sheet))))
470    
471     (defmethod (setf medium-transformation) :after (transformation (medium medium))
472     (declare (ignore transformation))
473     (let ((sheet (medium-sheet medium)))
474     (when sheet
475     (invalidate-cached-transformations sheet))))
476    
477     (defmethod medium-merged-text-style ((medium medium))
478     (merge-text-styles (medium-text-style medium) (medium-default-text-style medium)))
479    
480     ;; with-sheet-medium moved to output.lisp. --GB
481     ;; with-sheet-medium-bound moved to output.lisp. --GB
482    
483     (defmacro with-pixmap-medium ((medium pixmap) &body body)
484     (let ((old-medium (gensym))
485     (old-pixmap (gensym)))
486     `(let* ((,old-medium (pixmap-medium ,pixmap))
487     (,medium (or ,old-medium (make-medium (port ,pixmap) ,pixmap)))
488     (,old-pixmap (medium-sheet ,medium)))
489     (setf (pixmap-medium ,pixmap) ,medium)
490     (setf (%medium-sheet ,medium) ,pixmap) ;is medium a basic medium? --GB
491     (unwind-protect
492     (progn
493     ,@body)
494     (setf (pixmap-medium ,pixmap) ,old-medium)
495     (setf (%medium-sheet ,medium) ,old-pixmap)))))
496    
497     ;;; Medium Device functions
498    
499     (defmethod medium-device-transformation ((medium medium))
500     (sheet-device-transformation (medium-sheet medium)))
501    
502     (defmethod medium-device-region ((medium medium))
503     (sheet-device-region (medium-sheet medium)))
504    
505    
506 mikemac 1.1 ;;; Line-Style class
507    
508 gilbert 1.47 (define-protocol-class line-style ())
509 gilbert 1.24
510 moore 1.48 (defgeneric line-style-equalp (arg1 arg2))
511    
512 gilbert 1.24 (defclass standard-line-style (line-style)
513     ((unit :initarg :line-unit
514     :initform :normal
515     :reader line-style-unit
516     :type (member :normal :point :coordinate))
517     (thickness :initarg :line-thickness
518     :initform 1
519     :reader line-style-thickness
520     :type real)
521 mikemac 1.1 (joint-shape :initarg :line-joint-shape
522     :initform :miter
523 gilbert 1.24 :reader line-style-joint-shape
524     :type (member :miter :bevel :round :none))
525     (cap-shape :initarg :line-cap-shape
526     :initform :butt
527     :reader line-style-cap-shape
528     :type (member :butt :squere :round :no-end-point))
529     (dashes :initarg :line-dashes
530     :initform nil
531     :reader line-style-dashes
532     :type (or (member t nil)
533     sequence)) ))
534    
535     (defmethod line-style-p ((x line-style))
536     (declare (ignorable x))
537     t)
538 mikemac 1.1
539 gilbert 1.24 (defmethod line-style-p ((x t))
540     (declare (ignorable x))
541     nil)
542 mikemac 1.1
543     (defun make-line-style (&key (unit :normal) (thickness 1)
544     (joint-shape :miter) (cap-shape :butt)
545     (dashes nil))
546     (make-instance 'standard-line-style
547     :line-unit unit
548     :line-thickness thickness
549     :line-joint-shape joint-shape
550     :line-cap-shape cap-shape
551     :line-dashes dashes))
552    
553 gilbert 1.24 (defmethod print-object ((self standard-line-style) stream)
554     (print-unreadable-object (self stream :type t :identity nil)
555     (format stream "~{~S ~S~^ ~}"
556     (mapcan (lambda (slot)
557     (when (slot-boundp self slot)
558     (list
559     (intern (symbol-name slot) :keyword)
560     (slot-value self slot))))
561     '(unit thickness joint-shape cap-shape dashes)))))
562 mikemac 1.1
563 adejneka 1.35 (defmethod line-style-effective-thickness (line-style medium)
564     ;; FIXME
565     (declare (ignore medium))
566     (line-style-thickness line-style))
567    
568 adejneka 1.40 (defmethod medium-miter-limit ((medium medium))
569     #.(* 2 single-float-epsilon))
570    
571 moore 1.48 (defmethod line-style-equalp ((style1 standard-line-style)
572     (style2 standard-line-style))
573     (and (eql (line-style-unit style1) (line-style-unit style2))
574     (eql (line-style-thickness style1) (line-style-thickness style2))
575     (eql (line-style-joint-shape style1) (line-style-joint-shape style2))
576     (eql (line-style-cap-shape style1) (line-style-cap-shape style2))
577     (eql (line-style-thickness style1) (line-style-thickness style2))))
578 mikemac 1.1
579     ;;; Misc ops
580    
581     (defmacro with-output-buffered ((medium &optional (buffer-p t)) &body body)
582 adejneka 1.8 (declare (type symbol medium))
583     (when (eq medium t)
584     (setq medium '*standard-output*))
585 mikemac 1.1 (let ((old-buffer (gensym)))
586     `(let ((,old-buffer (medium-buffering-output-p ,medium)))
587     (setf (medium-buffering-output-p ,medium) ,buffer-p)
588     (unwind-protect
589     (progn
590     ,@body)
591     (setf (medium-buffering-output-p ,medium) ,old-buffer)))))
592 adejneka 1.9
593    
594     ;;; BASIC-MEDIUM class
595    
596     (defmacro with-transformed-position ((transformation x y) &body body)
597     `(multiple-value-bind (,x ,y) (transform-position ,transformation ,x ,y)
598     ,@body))
599    
600     (defmacro with-transformed-distance ((transformation dx dy) &body body)
601     `(multiple-value-bind (,dx ,dy) (transform-distance ,transformation ,dx ,dy)
602     ,@body))
603    
604     (defmacro with-transformed-positions ((transformation coord-seq) &body body)
605     `(let ((,coord-seq (transform-positions ,transformation ,coord-seq)))
606     ,@body))
607    
608 rouanet 1.21
609     ;;; Pixmaps
610    
611     (defmethod medium-copy-area ((from-drawable basic-medium) from-x from-y width height
612     to-drawable to-x to-y)
613     (declare (ignore from-x from-y width height to-drawable to-x to-y))
614 rouanet 1.22 (error "MEDIUM-COPY-AREA is not implemented for basic MEDIUMs"))
615 rouanet 1.21
616     (defmethod medium-copy-area (from-drawable from-x from-y width height
617     (to-drawable basic-medium) to-x to-y)
618     (declare (ignore from-drawable from-x from-y width height to-x to-y))
619 rouanet 1.22 (error "MEDIUM-COPY-AREA is not implemented for basic MEDIUMs"))
620 rouanet 1.21
621    
622     ;;; Medium-specific Drawing Functions
623 adejneka 1.9
624     (defmethod medium-draw-point* :around ((medium basic-medium) x y)
625     (let ((tr (medium-transformation medium)))
626     (with-transformed-position (tr x y)
627 adejneka 1.36 (call-next-method medium x y))))
628 adejneka 1.9
629     (defmethod medium-draw-points* :around ((medium basic-medium) coord-seq)
630     (let ((tr (medium-transformation medium)))
631     (with-transformed-positions (tr coord-seq)
632 adejneka 1.36 (call-next-method medium coord-seq))))
633 adejneka 1.9
634     (defmethod medium-draw-line* :around ((medium basic-medium) x1 y1 x2 y2)
635     (let ((tr (medium-transformation medium)))
636     (with-transformed-position (tr x1 y1)
637 adejneka 1.36 (with-transformed-position (tr x2 y2)
638     (call-next-method medium x1 y1 x2 y2)))))
639 adejneka 1.9
640     (defmethod medium-draw-lines* :around ((medium basic-medium) coord-seq)
641     (let ((tr (medium-transformation medium)))
642     (with-transformed-positions (tr coord-seq)
643 adejneka 1.36 (call-next-method medium coord-seq))))
644 adejneka 1.9
645     (defmethod medium-draw-polygon* :around ((medium basic-medium) coord-seq closed filled)
646     (let ((tr (medium-transformation medium)))
647     (with-transformed-positions (tr coord-seq)
648 adejneka 1.36 (call-next-method medium coord-seq closed filled))))
649 adejneka 1.9
650     (defmethod medium-draw-rectangle* :around ((medium basic-medium) left top right bottom filled)
651     (let ((tr (medium-transformation medium)))
652     (if (rectilinear-transformation-p tr)
653     (multiple-value-bind (left top right bottom)
654     (transform-rectangle* tr left top right bottom)
655     (call-next-method medium left top right bottom filled))
656     (medium-draw-polygon* medium (list left top
657     left bottom
658     right bottom
659     right top)
660     t filled))))
661    
662 rouanet 1.14 (defmethod medium-draw-rectangles* :around ((medium basic-medium) position-seq filled)
663     (let ((tr (medium-transformation medium)))
664     (if (rectilinear-transformation-p tr)
665     (loop for (left top right bottom) on position-seq by #'cddddr
666 adejneka 1.31 ;; point-seq can be a vector! --GB
667 rouanet 1.14 nconcing (multiple-value-list
668     (transform-rectangle* tr left top right bottom)) into position-seq
669     finally (call-next-method medium position-seq filled))
670 adejneka 1.31 (map-repeated-sequence nil 4
671     (lambda (left top right bottom)
672     (medium-draw-polygon* medium (list left top
673     left bottom
674     right bottom
675     right top)
676     t filled))
677     position-seq))))
678 rouanet 1.14
679 adejneka 1.9 (defmethod medium-draw-ellipse* :around ((medium basic-medium) center-x center-y
680     radius-1-dx radius-1-dy radius-2-dx radius-2-dy
681     start-angle end-angle filled)
682     (let* ((ellipse (make-elliptical-arc* center-x center-y
683     radius-1-dx radius-1-dy
684     radius-2-dx radius-2-dy
685     :start-angle start-angle
686     :end-angle end-angle))
687     (transformed-ellipse (transform-region (medium-transformation medium)
688     ellipse))
689     (start-angle (ellipse-start-angle transformed-ellipse))
690     (end-angle (ellipse-end-angle transformed-ellipse)))
691     (multiple-value-bind (center-x center-y) (ellipse-center-point* transformed-ellipse)
692     (multiple-value-bind (radius-1-dx radius-1-dy radius-2-dx radius-2-dy)
693     (ellipse-radii transformed-ellipse)
694     (call-next-method medium center-x center-y
695     radius-1-dx radius-1-dy
696     radius-2-dx radius-2-dy
697     start-angle end-angle filled)))))
698 brian 1.29
699     (defmethod medium-draw-circle* :around ((medium basic-medium) center-x center-y
700 gilbert 1.30 radius start-angle end-angle filled)
701 brian 1.29 (let* ((ellipse (make-elliptical-arc* center-x center-y
702     radius 0
703     0 radius
704     :start-angle start-angle
705     :end-angle end-angle))
706     (transformed-ellipse (transform-region (medium-transformation medium)
707     ellipse))
708     (start-angle (ellipse-start-angle transformed-ellipse))
709     (end-angle (ellipse-end-angle transformed-ellipse)))
710     (multiple-value-bind (center-x center-y) (ellipse-center-point* transformed-ellipse)
711     (call-next-method medium center-x center-y radius start-angle end-angle filled))))
712 adejneka 1.9
713     (defmethod medium-draw-text* :around ((medium basic-medium) string x y
714     start end
715     align-x align-y
716     toward-x toward-y transform-glyphs)
717     ;;!!! FIX ME!
718 rouanet 1.14 (let ((tr (medium-transformation medium)))
719     (with-transformed-position (tr x y)
720     (call-next-method medium string x y
721     start end
722     align-x align-y
723     toward-x toward-y transform-glyphs))))
724    
725     (defmethod medium-draw-glyph :around ((medium basic-medium) element x y
726     align-x align-y toward-x toward-y
727     transform-glyphs)
728     (let ((tr (medium-transformation medium)))
729     (with-transformed-position (tr x y)
730 rouanet 1.16 (call-next-method medium element x y
731     align-x align-y toward-x toward-y
732     transform-glyphs))))
733 rouanet 1.22
734     (defmethod medium-copy-area :around ((from-drawable basic-medium)
735     from-x from-y width height
736     to-drawable to-x to-y)
737     (with-transformed-position ((medium-transformation from-drawable)
738     from-x from-y)
739     (call-next-method from-drawable from-x from-y width height
740     to-drawable to-x to-y)))
741    
742     (defmethod medium-copy-area :around (from-drawable from-x from-y width height
743     (to-drawable basic-medium)
744     to-x to-y)
745     (with-transformed-position ((medium-transformation to-drawable)
746     to-x to-y)
747     (call-next-method from-drawable from-x from-y width height
748     to-drawable to-x to-y)))
749 rouanet 1.13
750 rouanet 1.18 ;;; Fall-through Methods For Multiple Objects Drawing Functions
751    
752     (defmethod medium-draw-points* ((medium basic-medium) coord-seq)
753     (let ((tr (invert-transformation (medium-transformation medium))))
754     (with-transformed-positions (tr coord-seq)
755 moore 1.45 (do-sequence ((x y) coord-seq)
756     (medium-draw-point* medium x y)))))
757 rouanet 1.18
758     (defmethod medium-draw-lines* ((medium basic-medium) position-seq)
759     (let ((tr (invert-transformation (medium-transformation medium))))
760     (with-transformed-positions (tr position-seq)
761 moore 1.45 (do-sequence ((x1 y1 x2 y2) position-seq)
762     (medium-draw-line* medium x1 y1 x2 y2)))))
763 rouanet 1.18
764     (defmethod medium-draw-rectangles* ((medium basic-medium) coord-seq filled)
765     (let ((tr (invert-transformation (medium-transformation medium))))
766     (with-transformed-positions (tr coord-seq)
767 moore 1.45 (do-sequence ((x1 y1 x2 y2) coord-seq)
768     (medium-draw-rectangle* medium x1 y1 x2 y2 filled)))))
769 rouanet 1.18
770 rouanet 1.13
771     ;;; Other Medium-specific Output Functions
772    
773     (defmethod medium-finish-output ((medium basic-medium))
774     nil)
775    
776     (defmethod medium-force-output ((medium basic-medium))
777     nil)
778    
779     (defmethod medium-clear-area ((medium basic-medium) left top right bottom)
780     (draw-rectangle* medium left top right bottom :ink +background-ink+))
781    
782     (defmethod medium-beep ((medium basic-medium))
783     nil)
784 gilbert 1.24
785     ;;;;;;;;;
786    
787     (defmethod engraft-medium ((medium basic-medium) port sheet)
788 gilbert 1.30 (declare (ignore port))
789 gilbert 1.27 (setf (%medium-sheet medium) sheet)
790     #||
791     (medium-foreground medium) (medium-foreground sheet)
792     (medium-background medium) (medium-background sheet)
793     (medium-ink medium) (medium-ink sheet)
794     (medium-transformation medium) (medium-transformation sheet)
795     (medium-clipping-region medium) (medium-clipping-region sheet)
796     (medium-line-style medium) (medium-line-style sheet)
797     (medium-text-stle medium) (medium-text-stle sheet)
798     ||#
799     )
800 gilbert 1.24
801     (defmethod degraft-medium ((medium basic-medium) port sheet)
802 gilbert 1.30 (declare (ignore port sheet))
803 gilbert 1.24 (setf (%medium-sheet medium) nil))
804    
805     (defmethod allocate-medium ((port port) sheet)
806     (make-medium port sheet))
807    
808     (defmethod deallocate-medium ((port port) medium)
809     (declare (ignorable port medium))
810     nil)
811    
812     (defmethod port ((medium basic-medium))
813     (and (medium-sheet medium)
814     (port (medium-sheet medium))))
815    
816     (defmethod graft ((medium basic-medium))
817     (and (medium-sheet medium)
818     (graft (medium-sheet medium))))
819 gilbert 1.26
820 adejneka 1.39
821     (defmacro with-special-choices ((medium) &body body)
822     "Macro for optimizing drawing with graphical system dependant mechanisms."
823     (with-gensyms (fn)
824     `(flet ((,fn (,medium)
825     (declare (ignorable ,medium))
826     ,@body))
827     (declare (dynamic-extent #',fn))
828     (invoke-with-special-choices #',fn ,medium))))
829    
830     (defgeneric invoke-with-special-choices (continuation sheet))
831    
832     (defmethod invoke-with-special-choices (continuation (medium t))
833 brian 1.44 (funcall continuation medium))

  ViewVC Help
Powered by ViewVC 1.1.5