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

Contents of /mcclim/medium.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17 - (show annotations)
Fri Aug 24 10:49:51 2001 UTC (12 years, 8 months ago) by strandh
Branch: MAIN
Changes since 1.16: +4 -4 lines
Added :before methods to (setf medium-text-style) and (setf
medium-line-style) that forward modifications to the graphics context
when it exists.  The idea is to avoid modifying the graphics context
as much as possible, since that turns out to be quite costly.  A
similar thing should be done for other medium components such as the
ink, clipping region, etc.

Modified function medium-gcontext to set the fields in the graphics
context having to do with line-style and text-style only when a new
graphics context is created.  Also fixed Julien's comment by adding a
semicolon so that it would indent properly.

The address-book example now displays faster, but not fast enough.
The problem is that replay-output-record always creates a new medium.
Doing so has two major consequences.  First, it slows down the
medium-gcontext function because there is never a graphics context
allocated so it has to be allocated and filled in for each call.
Second (worse) it does not deallocate the graphics contexts.  If we
are lucky, CLX will do that for us.  If not, we will eventually run
out of X resources.

The main time consumer in the address book example is now
port-lookup-mirror (around 10%).  The current method (a hash table in
the port) should be replaced by one in which the mirror is a field in
the mirrored sheet.

Fixed a spelling error in recent comments in the medium class and
signed the comments.

Started signing and dating my comments (as recommended by Norvig),
since I discovered I needed to know who had written a comment that was
not signed.  I used ISO date format to avoid international
misunderstandings.
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
573 ;;; Other Medium-specific Output Functions
574
575 (defmethod medium-finish-output ((medium basic-medium))
576 nil)
577
578 (defmethod medium-force-output ((medium basic-medium))
579 nil)
580
581 (defmethod medium-clear-area ((medium basic-medium) left top right bottom)
582 (draw-rectangle* medium left top right bottom :ink +background-ink+))
583
584 (defmethod medium-beep ((medium basic-medium))
585 nil)

  ViewVC Help
Powered by ViewVC 1.1.5