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

Contents of /mcclim/medium.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.61 - (show annotations)
Sun Dec 24 14:27:43 2006 UTC (7 years, 3 months ago) by dlichteblau
Branch: MAIN
CVS Tags: mcclim-0-9-4, McCLIM-0-9-4
Changes since 1.60: +21 -10 lines
Enable support for extended text styles using strings for family and face,
as already implemented in CLIM-CLX.  Teach Gtkairo do the same.

Add an API for font listing (implemented in CLX and Gtkairo, plus a
trivial fallback implementation for other backends) and a font selection
dialog as an example.

	* Doc/mcclim.texi: New chapter "Fonts and Extended Text Styles"

	* Examples/font-selector.lisp: New file.

	* Examples/demodemo.lisp: Added a button for the font selector.

	* mcclim.asd (CLIM-EXAMPLES): Added font-selector.lisp.

	* package.lisp (CLIM-EXTENSIONS): Export new symbols font-family
	font-face port-all-font-families font-family-name font-family-port
	font-family-all-faces font-face-name font-face-family
	font-face-all-sizes font-face-scalable-p font-face-text-style.

	* medium.lisp (MAKE-TEXT-STYLE, TEXT-STYLE-EQUALP): Allow strings
	for family and face.  (MAKE-TEXT-STYLE-1): New helper function.

	* ports.lisp (FONT-FAMILY, FONT-FACE): New classes.
	(port-all-font-families font-family-name font-family-port
	font-family-all-faces font-face-name font-face-family
	font-face-all-sizes font-face-scalable-p font-face-text-style):
	New generic functions and default methods.

	* Backends/CLX/port.lisp (FONT-FAMILIES): New slot in the port.
	(CLX-FONT-FAMILY, CLX-FONT-FACE): New classes.
	(port-all-font-families font-family-name font-family-port
	font-family-all-faces font-face-name font-face-family
	font-face-all-sizes font-face-scalable-p font-face-text-style):
	New methods. (SPLIT-FONT-NAME, RELOAD-FONT-TABLE,
	MAKE-UNFRIEDLY-NAME): New helper functions.

	* Backends/gtkairo/pango.lisp (MAKE-FONT-DESCRIPTION): Support
	strings for family and face.
	(PANGO-FONT-FAMILY, PANGO-FONT-FACE): New classes.
	(port-all-font-families font-family-name font-family-port
	font-family-all-faces font-face-name font-face-family
	font-face-all-sizes font-face-scalable-p font-face-text-style):
	New methods. (INVOKE-LISTER, pango-font-family-list-faces,
	pango-font-face-list-sizes): New helper functions.

	* Backends/gtkairo/port.lisp (GLOBAL-PANGO-CONTEXT): New slot in
	the port.  ((INITIALIZE-INSTANCE GTKAIRO-PORT)): Set the pango
	context.

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

  ViewVC Help
Powered by ViewVC 1.1.5