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

Contents of /mcclim/medium.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.42 - (show annotations)
Sat Aug 3 08:28:47 2002 UTC (11 years, 8 months ago) by moore
Branch: MAIN
Changes since 1.41: +6 -2 lines
Make the pointer documentation window more pretty.  Add a
describe-presentation command in order to have some command bound to
the super modifier.

Move coordinates into the device-event class.  Supply coordinates for
key events.

Add make-load-form methods for named-color and standard-text-style.
This, plus some strategic eval-when (:compile-toplevel ...), allows us
to remove the defparameter/defconstant hack for CMUCL (and SBCL too,
though I haven't tested that and didn't do the work).

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

  ViewVC Help
Powered by ViewVC 1.1.5