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

Contents of /mcclim/medium.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.18 - (show annotations)
Fri Sep 7 13:10:57 2001 UTC (12 years, 7 months ago) by rouanet
Branch: MAIN
Changes since 1.17: +20 -0 lines
Added fall-through methods for multiple objects drawing functions.

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

  ViewVC Help
Powered by ViewVC 1.1.5