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

Contents of /mcclim/medium.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.23 - (show annotations)
Thu Feb 7 00:15:12 2002 UTC (12 years, 2 months ago) by gilbert
Branch: MAIN
Changes since 1.22: +11 -8 lines
TEXT-STYLE-COMPONENTS
    implemented.

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

  ViewVC Help
Powered by ViewVC 1.1.5