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

Contents of /mcclim/medium.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5