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

Contents of /mcclim/medium.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.27 - (hide annotations)
Sat Feb 16 02:27:54 2002 UTC (12 years, 2 months ago) by gilbert
Branch: MAIN
Changes since 1.26: +11 -8 lines
ENGRAFT-MEDIUM

    Elided copying of graphics options from the sheet's medium into
    the newly grafted medium. Still not sure, what to do here.

    The spec says:

        The default method on BASIC-medium will set medium-sheet on
        medium to point to the sheet, and will set up the medium state
                                               ^^^^^^^^^^^^^^^^^^^^^^^
        (foreground ink, background ink, and so forth) from the
        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
        defaults gotten from sheet. Each implementation may specialize
        ^^^^^^^^^^^^^^^^^^^^^^^^^^^
        this generic function in order to set up such things as
        per-medium ink caches, and so forth.

    Now there is a ENGRAFT-MEDIUM :after method on panes in
    panes.lisp, which essentially implements this functionallity.
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     (in-package :CLIM-INTERNALS)
21    
22     ;;; MEDIUM class
23    
24 gilbert 1.24 (defclass medium () ())
25    
26     (defclass basic-medium (medium)
27     ((foreground :initarg :foreground
28     :initform +black+
29     :accessor medium-foreground)
30 mikemac 1.1 (background :initarg :background
31 gilbert 1.24 :initform +white+
32     :accessor medium-background)
33 mikemac 1.1 (ink :initarg :ink
34 gilbert 1.24 :initform +foreground-ink+
35     :accessor medium-ink)
36 boninfan 1.11 (transformation :type transformation
37 gilbert 1.24 :initarg :transformation
38     :initform +identity-transformation+
39     :accessor medium-transformation)
40 boninfan 1.11 (clipping-region :type region
41 gilbert 1.24 :initarg :clipping-region
42     :initform +everywhere+
43     :documentation "Clipping region in the SHEET coordinates.")
44 strandh 1.17 ;; always use this slot through its accessor, since there may
45     ;; be secondary methods on it -RS 2001-08-23
46 mikemac 1.1 (line-style :initarg :line-style
47 gilbert 1.24 :initform (make-line-style)
48     :accessor medium-line-style)
49 strandh 1.17 ;; always use this slot through its accessor, since there may
50     ;; be secondary methods on it -RS 2001-08-23
51 mikemac 1.1 (text-style :initarg :text-style
52 gilbert 1.24 :initform (make-text-style :fix :roman :normal)
53     :accessor medium-text-style)
54 mikemac 1.1 (default-text-style :initarg :default-text-style
55 gilbert 1.24 :initform (make-text-style :fix :roman :normal)
56     :accessor medium-default-text-style)
57 mikemac 1.1 (sheet :initarg :sheet
58 gilbert 1.24 :initform nil ; this means that medium is not linked to a sheet
59     :reader medium-sheet
60 gilbert 1.25 :writer (setf %medium-sheet) ))
61     (:documentation "The basic class, on which all CLIM mediums are built.") )
62 gilbert 1.24
63     (defclass ungrafted-medium (basic-medium) ())
64 mikemac 1.1
65 gilbert 1.24 (defmethod mediump ((x medium))
66     t)
67    
68     (defmethod mediump ((x medium))
69     nil)
70 adejneka 1.10
71     (defmethod initialize-instance :after ((medium medium) &rest args)
72 rouanet 1.13 (declare (ignore args))
73 adejneka 1.10 ;; Initial CLIPPING-REGION is in coordinates, given by initial
74     ;; TRANSFORMATION, but we store it in SHEET's coords.
75 rouanet 1.20 (with-slots (clipping-region) medium
76     (setf clipping-region (transform-region (medium-transformation medium)
77     clipping-region))))
78 adejneka 1.10
79     (defmethod medium-clipping-region ((medium medium))
80     (untransform-region (medium-transformation medium)
81     (slot-value medium 'clipping-region)))
82    
83     (defmethod (setf medium-clipping-region) (region (medium medium))
84     (setf (slot-value medium 'clipping-region)
85     (transform-region (medium-transformation medium)
86     region)))
87 mikemac 1.1
88 rouanet 1.20 (defmethod (setf medium-clipping-region) :after (region (medium medium))
89     (declare (ignore region))
90     (let ((sheet (medium-sheet medium)))
91     (when sheet
92     (invalidate-cached-regions sheet))))
93    
94     (defmethod (setf medium-transformation) :after (transformation (medium medium))
95     (declare (ignore transformation))
96     (let ((sheet (medium-sheet medium)))
97     (when sheet
98     (invalidate-cached-transformations sheet))))
99    
100 mikemac 1.1 (defmethod medium-merged-text-style ((medium medium))
101     (merge-text-styles (medium-text-style medium) (medium-default-text-style medium)))
102    
103 gilbert 1.24 ;; with-sheet-medium moved to output.lisp. --GB
104     ;; with-sheet-medium-bound moved to output.lisp. --GB
105 mikemac 1.1
106 cvs 1.7 (defmacro with-pixmap-medium ((medium pixmap) &body body)
107     (let ((old-medium (gensym))
108     (old-pixmap (gensym)))
109     `(let* ((,old-medium (pixmap-medium ,pixmap))
110     (,medium (or ,old-medium (make-medium (port ,pixmap) ,pixmap)))
111     (,old-pixmap (medium-sheet ,medium)))
112     (setf (pixmap-medium ,pixmap) ,medium)
113 gilbert 1.26 (setf (%medium-sheet ,medium) ,pixmap) ;is medium a basic medium? --GB
114 cvs 1.7 (unwind-protect
115     (progn
116     ,@body)
117     (setf (pixmap-medium ,pixmap) ,old-medium)
118     (setf (medium-sheet ,medium) ,old-pixmap)))))
119 boninfan 1.11
120 rouanet 1.20 ;;; Medium Device functions
121 boninfan 1.11
122 rouanet 1.20 (defmethod medium-device-transformation ((medium medium))
123     (sheet-device-transformation (medium-sheet medium)))
124 boninfan 1.11
125 rouanet 1.20 (defmethod medium-device-region ((medium medium))
126     (sheet-device-region (medium-sheet medium)))
127 cvs 1.7
128 mikemac 1.1
129     ;;; Text-Style class
130    
131     (eval-when (eval load compile)
132    
133 cvs 1.4 (defclass text-style ()
134 gilbert 1.23 ())
135    
136 gilbert 1.24 (defmethod text-style-p ((x text-style))
137     (declare (ignorable x))
138     t)
139    
140     (defmethod text-style-p ((x t))
141     (declare (ignorable x))
142     nil)
143 gilbert 1.23
144     (defclass standard-text-style (text-style)
145 cvs 1.4 ((family :initarg :text-family
146     :initform :fix
147     :reader text-style-family)
148     (face :initarg :text-face
149     :initform :roman
150     :reader text-style-face)
151     (size :initarg :text-size
152     :initform :normal
153 gilbert 1.23 :reader text-style-size)))
154 cvs 1.4
155     (defun family-key (family)
156     (ecase family
157     ((nil) 0)
158 cvs 1.5 ((:fix :fixed) 1)
159 cvs 1.4 ((:serif) 2)
160     ((:sans-serif) 3)))
161    
162     (defun face-key (face)
163     (if (equal face '(:bold :italic))
164     4
165     (ecase face
166     ((nil) 0)
167     ((:roman) 1)
168     ((:bold) 2)
169 cvs 1.5 ((:italic) 3))))
170 cvs 1.4
171     (defun size-key (size)
172     (if (numberp size)
173     (+ 10 (round (* 256 size)))
174     (ecase size
175     ((nil) 0)
176     ((:tiny) 1)
177     ((:very-small) 2)
178     ((:small) 3)
179     ((:normal) 4)
180     ((:large) 5)
181     ((:very-large) 6)
182     ((:huge) 7)
183     ((:smaller 8))
184     ((:larger 9)))))
185    
186     (defun text-style-key (family face size)
187     (+ (* 256 (size-key size))
188     (* 16 (face-key face))
189     (family-key family)))
190    
191     (defvar *text-style-hash-table* (make-hash-table :test #'eql))
192    
193     (defun make-text-style (family face size)
194     (let ((key (text-style-key family face size)))
195     (declare (type fixnum key))
196     (or (gethash key *text-style-hash-table*)
197     (setf (gethash key *text-style-hash-table*)
198     (make-instance 'standard-text-style
199     :text-family family
200     :text-face face
201     :text-size size)))))
202 cvs 1.7 ) ; end eval-when
203 mikemac 1.1
204 gilbert 1.24 (defmethod print-object ((self text-style) stream)
205     (print-unreadable-object (self stream :type t :identity nil)
206     (format stream "~{~S~^ ~}" (multiple-value-list (text-style-components self)))))
207    
208 mikemac 1.1 (defconstant *default-text-style* (make-text-style :fix :roman :normal))
209    
210     (defconstant *smaller-sizes* '(:huge :very-large :large :normal
211     :small :very-small :tiny :tiny))
212    
213 gilbert 1.24 (defconstant *font-scaling-factor* 4/3)
214     (defconstant *font-min-size* 6)
215     (defconstant *font-max-size* 48)
216    
217 mikemac 1.1 (defun find-smaller-size (size)
218     (if (numberp size)
219 gilbert 1.24 (max (round (/ size *font-scaling-factor*)) *font-min-size*)
220 mikemac 1.1 (cadr (member size *smaller-sizes*))))
221    
222     (defconstant *larger-sizes* '(:tiny :very-small :small :normal
223     :large :very-large :huge :huge))
224    
225     (defun find-larger-size (size)
226     (if (numberp size)
227 gilbert 1.24 (min (round (* size *font-scaling-factor*)) *font-max-size*)
228 mikemac 1.1 (cadr (member size *larger-sizes*))))
229    
230 gilbert 1.23 (defmethod text-style-components ((text-style standard-text-style))
231     (values (text-style-family text-style)
232     (text-style-face text-style)
233     (text-style-size text-style)))
234 cvs 1.7
235     ;;; Device-Font-Text-Style class
236    
237     (defclass device-font-text-style (text-style)
238     ())
239    
240     (defun device-font-text-style-p (s)
241     (typep s 'device-font-text-style))
242    
243     (defun make-device-font-text-style (display-device device-font-name)
244     (port-make-font-text-style (port display-device) device-font-name))
245    
246 adejneka 1.8 ;;; Text-style utilities
247 cvs 1.7
248 mikemac 1.1 (defun merge-text-styles (s1 s2)
249 cvs 1.7 (if (and (not (device-font-text-style-p s1))
250     (not (device-font-text-style-p s2)))
251     (let ((new-style (make-text-style (or (text-style-family s1)
252     (text-style-family s2))
253     (or (text-style-face s1)
254     (text-style-face s2))
255     (or (text-style-size s1)
256     (text-style-size s2)))))
257     (with-slots (size) new-style
258     (case size
259     (:smaller
260     (setq size (find-smaller-size (text-style-size s2))))
261     (:larger
262     (setq size (find-larger-size (text-style-size s2))))))
263     new-style)
264     s1))
265 mikemac 1.1
266     (defmethod invoke-with-text-style ((sheet sheet) continuation text-style)
267     (invoke-with-text-style (sheet-medium sheet) continuation text-style))
268    
269     (defmethod invoke-with-text-style ((medium medium) continuation text-style)
270     (let ((old-style (medium-text-style medium)))
271 strandh 1.15 (setf (medium-text-style medium)
272 mikemac 1.1 (merge-text-styles text-style (medium-merged-text-style medium)))
273     (unwind-protect
274     (funcall continuation)
275 strandh 1.15 (setf (medium-text-style medium) old-style))))
276 mikemac 1.1
277     (defun parse-text-style (style)
278     (if (text-style-p style)
279     style
280     (let ((family nil)
281     (face nil)
282     (size nil))
283     (loop for item in style
284     do (cond
285     ((member item '(fix :serif :sans-serif))
286     (setq family item))
287     ((or (member item '(:roman :bold :italic))
288     (listp item))
289     (setq face item))
290     ((or (member item '(:tiny :very-small :small :normal
291     :large :very-large :huge))
292     (numberp item))
293     (setq size item))))
294     (make-text-style family face size))))
295    
296     (defmacro with-text-style ((medium text-style) &body body)
297 adejneka 1.8 (declare (type symbol medium))
298     (when (eq medium t)
299     (setq medium '*standard-output*))
300 mikemac 1.1 `(flet ((continuation ()
301     ,@body))
302 cvs 1.3 #-clisp (declare (dynamic-extent #'continuation))
303 mikemac 1.1 (invoke-with-text-style ,medium #'continuation (parse-text-style ,text-style))))
304    
305     (defmacro with-text-family ((medium family) &body body)
306 adejneka 1.8 (declare (type symbol medium))
307     (when (eq medium t)
308     (setq medium '*standard-output*))
309 mikemac 1.1 `(flet ((continuation ()
310     ,@body))
311 cvs 1.3 #-clisp (declare (dynamic-extent #'continuation))
312 mikemac 1.1 (invoke-with-text-style ,medium #'continuation (make-text-style ,family nil nil))))
313    
314     (defmacro with-text-face ((medium face) &body body)
315 adejneka 1.8 (declare (type symbol medium))
316     (when (eq medium t)
317     (setq medium '*standard-output*))
318 mikemac 1.1 `(flet ((continuation ()
319     ,@body))
320 cvs 1.3 #-clisp (declare (dynamic-extent #'continuation))
321 adejneka 1.8 (invoke-with-text-style ,medium
322     #'continuation (make-text-style nil ,face nil))))
323 mikemac 1.1
324     (defmacro with-text-size ((medium size) &body body)
325 adejneka 1.8 (declare (type symbol medium))
326     (when (eq medium t)
327     (setq medium '*standard-output*))
328 mikemac 1.1 `(flet ((continuation ()
329     ,@body))
330 cvs 1.3 #-clisp (declare (dynamic-extent #'continuation))
331 mikemac 1.1 (invoke-with-text-style ,medium #'continuation (make-text-style nil nil ,size))))
332    
333    
334     ;;; Line-Style class
335    
336     (defclass line-style ()
337 gilbert 1.24 ())
338    
339     (defclass standard-line-style (line-style)
340     ((unit :initarg :line-unit
341     :initform :normal
342     :reader line-style-unit
343     :type (member :normal :point :coordinate))
344     (thickness :initarg :line-thickness
345     :initform 1
346     :reader line-style-thickness
347     :type real)
348 mikemac 1.1 (joint-shape :initarg :line-joint-shape
349     :initform :miter
350 gilbert 1.24 :reader line-style-joint-shape
351     :type (member :miter :bevel :round :none))
352     (cap-shape :initarg :line-cap-shape
353     :initform :butt
354     :reader line-style-cap-shape
355     :type (member :butt :squere :round :no-end-point))
356     (dashes :initarg :line-dashes
357     :initform nil
358     :reader line-style-dashes
359     :type (or (member t nil)
360     sequence)) ))
361    
362     (defmethod line-style-p ((x line-style))
363     (declare (ignorable x))
364     t)
365 mikemac 1.1
366 gilbert 1.24 (defmethod line-style-p ((x t))
367     (declare (ignorable x))
368     nil)
369 mikemac 1.1
370     (defun make-line-style (&key (unit :normal) (thickness 1)
371     (joint-shape :miter) (cap-shape :butt)
372     (dashes nil))
373     (make-instance 'standard-line-style
374     :line-unit unit
375     :line-thickness thickness
376     :line-joint-shape joint-shape
377     :line-cap-shape cap-shape
378     :line-dashes dashes))
379    
380 gilbert 1.24 (defmethod print-object ((self standard-line-style) stream)
381     (print-unreadable-object (self stream :type t :identity nil)
382     (format stream "~{~S ~S~^ ~}"
383     (mapcan (lambda (slot)
384     (when (slot-boundp self slot)
385     (list
386     (intern (symbol-name slot) :keyword)
387     (slot-value self slot))))
388     '(unit thickness joint-shape cap-shape dashes)))))
389 mikemac 1.1
390    
391     ;;; Misc ops
392    
393     (defmacro with-output-buffered ((medium &optional (buffer-p t)) &body body)
394 adejneka 1.8 (declare (type symbol medium))
395     (when (eq medium t)
396     (setq medium '*standard-output*))
397 mikemac 1.1 (let ((old-buffer (gensym)))
398     `(let ((,old-buffer (medium-buffering-output-p ,medium)))
399     (setf (medium-buffering-output-p ,medium) ,buffer-p)
400     (unwind-protect
401     (progn
402     ,@body)
403     (setf (medium-buffering-output-p ,medium) ,old-buffer)))))
404 adejneka 1.9
405    
406     ;;; BASIC-MEDIUM class
407    
408     (defmacro with-transformed-position ((transformation x y) &body body)
409     `(multiple-value-bind (,x ,y) (transform-position ,transformation ,x ,y)
410     ,@body))
411    
412     (defmacro with-transformed-distance ((transformation dx dy) &body body)
413     `(multiple-value-bind (,dx ,dy) (transform-distance ,transformation ,dx ,dy)
414     ,@body))
415    
416     (defmacro with-transformed-positions ((transformation coord-seq) &body body)
417     `(let ((,coord-seq (transform-positions ,transformation ,coord-seq)))
418     ,@body))
419    
420 rouanet 1.21
421     ;;; Pixmaps
422    
423     (defmethod medium-copy-area ((from-drawable basic-medium) from-x from-y width height
424     to-drawable to-x to-y)
425     (declare (ignore from-x from-y width height to-drawable to-x to-y))
426 rouanet 1.22 (error "MEDIUM-COPY-AREA is not implemented for basic MEDIUMs"))
427 rouanet 1.21
428     (defmethod medium-copy-area (from-drawable from-x from-y width height
429     (to-drawable basic-medium) to-x to-y)
430     (declare (ignore from-drawable from-x from-y width height to-x to-y))
431 rouanet 1.22 (error "MEDIUM-COPY-AREA is not implemented for basic MEDIUMs"))
432 rouanet 1.21
433    
434     ;;; Medium-specific Drawing Functions
435 adejneka 1.9
436     (defmethod medium-draw-point* :around ((medium basic-medium) x y)
437     (let ((tr (medium-transformation medium)))
438     (with-transformed-position (tr x y)
439     (call-next-method medium x y))))
440    
441     (defmethod medium-draw-points* :around ((medium basic-medium) coord-seq)
442     (let ((tr (medium-transformation medium)))
443     (with-transformed-positions (tr coord-seq)
444     (call-next-method medium coord-seq))))
445    
446     (defmethod medium-draw-line* :around ((medium basic-medium) x1 y1 x2 y2)
447     (let ((tr (medium-transformation medium)))
448     (with-transformed-position (tr x1 y1)
449     (with-transformed-position (tr x2 y2)
450     (call-next-method medium x1 y1 x2 y2)))))
451    
452     (defmethod medium-draw-lines* :around ((medium basic-medium) coord-seq)
453     (let ((tr (medium-transformation medium)))
454     (with-transformed-positions (tr coord-seq)
455     (call-next-method medium coord-seq))))
456    
457     (defmethod medium-draw-polygon* :around ((medium basic-medium) coord-seq closed filled)
458     (let ((tr (medium-transformation medium)))
459     (with-transformed-positions (tr coord-seq)
460     (call-next-method medium coord-seq closed filled))))
461    
462     (defmethod medium-draw-rectangle* :around ((medium basic-medium) left top right bottom filled)
463     (let ((tr (medium-transformation medium)))
464     (if (rectilinear-transformation-p tr)
465     (multiple-value-bind (left top right bottom)
466     (transform-rectangle* tr left top right bottom)
467     (call-next-method medium left top right bottom filled))
468     (medium-draw-polygon* medium (list left top
469     left bottom
470     right bottom
471     right top)
472     t filled))))
473    
474 rouanet 1.14 (defmethod medium-draw-rectangles* :around ((medium basic-medium) position-seq filled)
475     (let ((tr (medium-transformation medium)))
476     (if (rectilinear-transformation-p tr)
477     (loop for (left top right bottom) on position-seq by #'cddddr
478     nconcing (multiple-value-list
479     (transform-rectangle* tr left top right bottom)) into position-seq
480     finally (call-next-method medium position-seq filled))
481     (loop for (left top right bottom) on position-seq by #'cddddr
482     do (medium-draw-polygon* medium (list left top
483     left bottom
484     right bottom
485     right top)
486     t filled)))))
487    
488    
489 adejneka 1.9 (defmethod medium-draw-ellipse* :around ((medium basic-medium) center-x center-y
490     radius-1-dx radius-1-dy radius-2-dx radius-2-dy
491     start-angle end-angle filled)
492     (let* ((ellipse (make-elliptical-arc* center-x center-y
493     radius-1-dx radius-1-dy
494     radius-2-dx radius-2-dy
495     :start-angle start-angle
496     :end-angle end-angle))
497     (transformed-ellipse (transform-region (medium-transformation medium)
498     ellipse))
499     (start-angle (ellipse-start-angle transformed-ellipse))
500     (end-angle (ellipse-end-angle transformed-ellipse)))
501     (multiple-value-bind (center-x center-y) (ellipse-center-point* transformed-ellipse)
502     (multiple-value-bind (radius-1-dx radius-1-dy radius-2-dx radius-2-dy)
503     (ellipse-radii transformed-ellipse)
504     (call-next-method medium center-x center-y
505     radius-1-dx radius-1-dy
506     radius-2-dx radius-2-dy
507     start-angle end-angle filled)))))
508    
509     (defmethod medium-draw-text* :around ((medium basic-medium) string x y
510     start end
511     align-x align-y
512     toward-x toward-y transform-glyphs)
513     ;;!!! FIX ME!
514 rouanet 1.14 (let ((tr (medium-transformation medium)))
515     (with-transformed-position (tr x y)
516     (call-next-method medium string x y
517     start end
518     align-x align-y
519     toward-x toward-y transform-glyphs))))
520    
521     (defmethod medium-draw-glyph :around ((medium basic-medium) element x y
522     align-x align-y toward-x toward-y
523     transform-glyphs)
524     (let ((tr (medium-transformation medium)))
525     (with-transformed-position (tr x y)
526 rouanet 1.16 (call-next-method medium element x y
527     align-x align-y toward-x toward-y
528     transform-glyphs))))
529 rouanet 1.22
530     (defmethod medium-copy-area :around ((from-drawable basic-medium)
531     from-x from-y width height
532     to-drawable to-x to-y)
533     (with-transformed-position ((medium-transformation from-drawable)
534     from-x from-y)
535     (call-next-method from-drawable from-x from-y width height
536     to-drawable to-x to-y)))
537    
538     (defmethod medium-copy-area :around (from-drawable from-x from-y width height
539     (to-drawable basic-medium)
540     to-x to-y)
541     (with-transformed-position ((medium-transformation to-drawable)
542     to-x to-y)
543     (call-next-method from-drawable from-x from-y width height
544     to-drawable to-x to-y)))
545 rouanet 1.13
546 rouanet 1.18 ;;; Fall-through Methods For Multiple Objects Drawing Functions
547    
548     (defmethod medium-draw-points* ((medium basic-medium) coord-seq)
549 gilbert 1.24 ;; WRONG!
550 rouanet 1.18 (let ((tr (invert-transformation (medium-transformation medium))))
551     (with-transformed-positions (tr coord-seq)
552     (loop for (x y) on coord-seq by #'cddr
553     do (medium-draw-point* medium x y)))))
554    
555     (defmethod medium-draw-lines* ((medium basic-medium) position-seq)
556 gilbert 1.24 ;; WRONG!
557 rouanet 1.18 (let ((tr (invert-transformation (medium-transformation medium))))
558     (with-transformed-positions (tr position-seq)
559     (loop for (x1 y1 x2 y2) on position-seq by #'cddddr
560     do (medium-draw-line* medium x1 y1 x2 y2)))))
561    
562     (defmethod medium-draw-rectangles* ((medium basic-medium) coord-seq filled)
563 gilbert 1.24 ;; WRONG!
564 rouanet 1.18 (let ((tr (invert-transformation (medium-transformation medium))))
565     (with-transformed-positions (tr coord-seq)
566     (loop for (x1 y1 x2 y2) on coord-seq by #'cddddr
567     do (medium-draw-rectangle* medium x1 y1 x2 y2 filled)))))
568    
569 rouanet 1.13
570     ;;; Other Medium-specific Output Functions
571    
572     (defmethod medium-finish-output ((medium basic-medium))
573     nil)
574    
575     (defmethod medium-force-output ((medium basic-medium))
576     nil)
577    
578     (defmethod medium-clear-area ((medium basic-medium) left top right bottom)
579     (draw-rectangle* medium left top right bottom :ink +background-ink+))
580    
581     (defmethod medium-beep ((medium basic-medium))
582     nil)
583 gilbert 1.24
584     ;;;;;;;;;
585    
586     (defmethod engraft-medium ((medium basic-medium) port sheet)
587 gilbert 1.27 (setf (%medium-sheet medium) sheet)
588     #||
589     (medium-foreground medium) (medium-foreground sheet)
590     (medium-background medium) (medium-background sheet)
591     (medium-ink medium) (medium-ink sheet)
592     (medium-transformation medium) (medium-transformation sheet)
593     (medium-clipping-region medium) (medium-clipping-region sheet)
594     (medium-line-style medium) (medium-line-style sheet)
595     (medium-text-stle medium) (medium-text-stle sheet)
596     ||#
597     )
598 gilbert 1.24
599     (defmethod degraft-medium ((medium basic-medium) port sheet)
600     (setf (%medium-sheet medium) nil))
601    
602     (defmethod allocate-medium ((port port) sheet)
603     (make-medium port sheet))
604    
605     (defmethod deallocate-medium ((port port) medium)
606     (declare (ignorable port medium))
607     nil)
608    
609     (defmethod port ((medium basic-medium))
610     (and (medium-sheet medium)
611     (port (medium-sheet medium))))
612    
613     (defmethod graft ((medium basic-medium))
614     (and (medium-sheet medium)
615     (graft (medium-sheet medium))))
616 gilbert 1.26

  ViewVC Help
Powered by ViewVC 1.1.5