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

Contents of /mcclim/clx-medium.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.25 - (show annotations)
Mon Oct 29 19:57:12 2001 UTC (12 years, 5 months ago) by mikemac
Branch: MAIN
CVS Tags: HEAD
Changes since 1.24: +0 -0 lines
FILE REMOVED
restructure directory layout
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com)
4 ;;; (c) copyright 2000 by
5 ;;; Iban Hatchondo (hatchond@emi.u-bordeaux.fr)
6 ;;; Julien Boninfante (boninfan@emi.u-bordeaux.fr)
7 ;;; Robert Strandh (strandh@labri.u-bordeaux.fr)
8 ;;; (c) copyright 2001 by Arnaud Rouanet (rouanet@emi.u-bordeaux.fr)
9
10 ;;; This library is free software; you can redistribute it and/or
11 ;;; modify it under the terms of the GNU Library General Public
12 ;;; License as published by the Free Software Foundation; either
13 ;;; version 2 of the License, or (at your option) any later version.
14 ;;;
15 ;;; This library is distributed in the hope that it will be useful,
16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 ;;; Library General Public License for more details.
19 ;;;
20 ;;; You should have received a copy of the GNU Library General Public
21 ;;; License along with this library; if not, write to the
22 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;;; Boston, MA 02111-1307 USA.
24
25 (in-package :CLIM-INTERNALS)
26
27 ;;; CLX-MEDIUM class
28
29 (defclass clx-medium (basic-medium)
30 ((gc :initform nil)
31 )
32 )
33
34
35 ;;; secondary methods for changing text styles and line styles
36
37 (defmethod (setf medium-text-style) :before (text-style (medium clx-medium))
38 (with-slots (gc) medium
39 (when gc
40 (let ((old-text-style (medium-text-style medium)))
41 (unless (eq text-style old-text-style)
42 (setf (xlib:gcontext-font gc)
43 (text-style-to-X-font (port medium) (medium-text-style medium))))))))
44
45 (defmethod (setf medium-line-style) :before (line-style (medium clx-medium))
46 (with-slots (gc) medium
47 (when gc
48 (let ((old-line-style (medium-line-style medium)))
49 (unless (eql (line-style-thickness line-style)
50 (line-style-thickness old-line-style))
51 ;; this is kind of false, since the :unit should be taken
52 ;; into account -RS 2001-08-24
53 (setf (xlib:gcontext-line-width gc)
54 (line-style-thickness line-style)))
55 (unless (eq (line-style-cap-shape line-style)
56 (line-style-cap-shape old-line-style))
57 (setf (xlib:gcontext-cap-style gc)
58 (line-style-cap-shape line-style)))
59 (unless (eq (line-style-joint-shape line-style)
60 (line-style-joint-shape old-line-style))
61 (setf (xlib:gcontext-join-style gc)
62 (line-style-joint-shape line-style)))
63 ;; we could do better here by comparing elements of the vector
64 ;; -RS 2001-08-24
65 (unless (eq (line-style-dashes line-style)
66 (line-style-dashes old-line-style))
67 (setf (xlib:gcontext-line-style gc)
68 (if (line-style-dashes line-style) :dash :solid)
69 (xlib:gcontext-dashes gc)
70 (case (line-style-dashes line-style)
71 ((t nil) 3)
72 (otherwise (line-style-dashes line-style)))))))))
73
74
75 (defgeneric medium-gcontext (medium ink))
76
77 (defmethod medium-gcontext ((medium clx-medium) (ink color))
78 (let* ((port (port medium))
79 (mirror (port-lookup-mirror port (medium-sheet medium)))
80 (line-style (medium-line-style medium)))
81 (with-slots (gc) medium
82 (unless gc
83 (setq gc (xlib:create-gcontext :drawable mirror))
84 ;; this is kind of false, since the :unit should be taken
85 ;; into account -RS 2001-08-24
86 (setf (xlib:gcontext-line-width gc) (line-style-thickness line-style)
87 (xlib:gcontext-cap-style gc) (line-style-cap-shape line-style)
88 (xlib:gcontext-join-style gc) (line-style-joint-shape line-style))
89 (let ((dashes (line-style-dashes line-style)))
90 (unless (null dashes)
91 (setf (xlib:gcontext-line-style gc) :dash
92 (xlib:gcontext-dashes gc) (if (eq dashes t) 3 dashes)))))
93 (setf (xlib:gcontext-font gc) (text-style-to-X-font port (medium-text-style medium))
94 (xlib:gcontext-foreground gc) (X-pixel port ink)
95 (xlib:gcontext-background gc) (X-pixel port (medium-background medium)))
96 (let ((clipping-region (medium-device-region medium)))
97 (unless (region-equal clipping-region +nowhere+)
98 (setf (xlib:gcontext-clip-mask gc :yx-banded)
99 (clipping-region->rect-seq clipping-region))))
100 gc)))
101
102 (defmethod medium-gcontext ((medium clx-medium) (ink (eql +foreground-ink+)))
103 (medium-gcontext medium (medium-foreground medium)))
104
105 (defmethod medium-gcontext ((medium clx-medium) (ink (eql +background-ink+)))
106 (medium-gcontext medium (medium-background medium)))
107
108 (defmethod medium-gcontext ((medium clx-medium) (ink (eql +flipping-ink+)))
109 (let ((gc (medium-gcontext medium (medium-background medium))))
110 (setf (xlib:gcontext-background gc)
111 (X-pixel (port medium) (medium-foreground medium)))
112 gc))
113
114 (defun clipping-region->rect-seq (clipping-region)
115 (loop for region in (nreverse (region-set-regions clipping-region
116 :normalize :x-banding))
117 as rectangle = (bounding-rectangle region)
118 nconcing (list (round (rectangle-min-x rectangle))
119 (round (rectangle-min-y rectangle))
120 (round (rectangle-width rectangle))
121 (round (rectangle-height rectangle)))))
122
123 (defmacro with-CLX-graphics ((medium) &body body)
124 `(let* ((port (port ,medium))
125 (mirror (port-lookup-mirror port (medium-sheet ,medium)))
126 (line-style (medium-line-style ,medium))
127 (ink (medium-ink ,medium))
128 (gc (medium-gcontext ,medium ink)))
129 line-style ink
130 (unwind-protect
131 (progn ,@body)
132 #+ignore(xlib:free-gcontext gc))))
133
134
135 ;;; Pixmaps
136
137 (defmethod medium-copy-area ((from-drawable clx-medium) from-x from-y width height
138 (to-drawable clx-medium) to-x to-y)
139 (xlib:copy-area (sheet-direct-mirror (medium-sheet from-drawable))
140 (medium-gcontext from-drawable +background-ink+)
141 from-x from-y width height
142 (sheet-direct-mirror (medium-sheet to-drawable))
143 to-x to-y))
144
145 (defmethod medium-copy-area ((from-drawable clx-medium) from-x from-y width height
146 (to-drawable pixmap) to-x to-y)
147 (xlib:copy-area (sheet-direct-mirror (medium-sheet from-drawable))
148 (medium-gcontext from-drawable +background-ink+)
149 from-x from-y width height
150 (pixmap-mirror to-drawable)
151 to-x to-y))
152
153 (defmethod medium-copy-area ((from-drawable pixmap) from-x from-y width height
154 (to-drawable clx-medium) to-x to-y)
155 (xlib:copy-area (pixmap-mirror from-drawable)
156 (medium-gcontext to-drawable +background-ink+)
157 from-x from-y width height
158 (sheet-direct-mirror (medium-sheet to-drawable))
159 to-x to-y))
160
161 (defmethod medium-copy-area ((from-drawable pixmap) from-x from-y width height
162 (to-drawable pixmap) to-x to-y)
163 (xlib:copy-area (pixmap-mirror from-drawable)
164 (medium-gcontext from-drawable +background-ink+) ; FIXME!!!!!
165 from-x from-y width height
166 (pixmap-mirror to-drawable)
167 to-x to-y))
168
169
170 ;;; Medium-specific Drawing Functions
171
172 (defmethod medium-draw-point* ((medium clx-medium) x y)
173 (with-transformed-position ((sheet-native-transformation (medium-sheet medium))
174 x y)
175 (with-CLX-graphics (medium)
176 (if (< (line-style-thickness line-style) 2)
177 (xlib:draw-point mirror gc (round x) (round y))
178 (let* ((radius (round (line-style-thickness line-style) 2))
179 (diameter (* radius 2)))
180 (xlib:draw-arc mirror gc
181 (round (- x radius)) (round (- y radius))
182 diameter diameter
183 0 (* 2 pi)
184 t))))))
185
186 (defmethod medium-draw-points* ((medium clx-medium) coord-seq)
187 (with-transformed-positions ((sheet-native-transformation (medium-sheet medium))
188 coord-seq)
189 (setq coord-seq (mapcar #'round coord-seq))
190 (with-CLX-graphics (medium)
191 (if (< (line-style-thickness line-style) 2)
192 (xlib:draw-points mirror gc coord-seq)
193 (loop with radius = (round (line-style-thickness line-style) 2)
194 with diameter = (* radius 2)
195 for (x y) on coord-seq by #'cddr
196 nconcing (list (round (- x radius)) (round (- y radius))
197 diameter diameter
198 0 (* 2 pi)) into arcs
199 finally (xlib:draw-arcs mirror gc arcs t))))))
200
201 (defmethod medium-draw-line* ((medium clx-medium) x1 y1 x2 y2)
202 (let ((tr (sheet-native-transformation (medium-sheet medium))))
203 (with-transformed-position (tr x1 y1)
204 (with-transformed-position (tr x2 y2)
205 (with-CLX-graphics (medium)
206 (xlib:draw-line mirror gc (round x1) (round y1) (round x2) (round y2)))))))
207
208 (defmethod medium-draw-lines* ((medium clx-medium) coord-seq)
209 (with-transformed-positions ((sheet-native-transformation (medium-sheet medium))
210 coord-seq)
211 (with-CLX-graphics (medium)
212 (let ((points (apply #'vector (mapcar #'round coord-seq))))
213 (xlib:draw-segments mirror gc points)))))
214
215 (defmethod medium-draw-polygon* ((medium clx-medium) coord-seq closed filled)
216 (assert (evenp (length coord-seq)))
217 (with-transformed-positions ((sheet-native-transformation (medium-sheet medium))
218 coord-seq)
219 (setq coord-seq (mapcar #'round coord-seq))
220 (with-CLX-graphics (medium)
221 (xlib:draw-lines mirror gc
222 (if closed
223 (append coord-seq (list (first coord-seq)
224 (second coord-seq)))
225 coord-seq)
226 :fill-p filled))))
227
228 (defmethod medium-draw-rectangle* ((medium clx-medium) left top right bottom filled)
229 (let ((tr (sheet-native-transformation (medium-sheet medium))))
230 (with-transformed-position (tr left top)
231 (with-transformed-position (tr right bottom)
232 (with-CLX-graphics (medium)
233 (if (< right left)
234 (rotatef left right))
235 (if (< bottom top)
236 (rotatef top bottom))
237 (xlib:draw-rectangle mirror gc
238 (round left) (round top)
239 (round (- right left)) (round (- bottom top))
240 filled))))))
241
242 (defmethod medium-draw-rectangles* ((medium clx-medium) position-seq filled)
243 (assert (evenp (length position-seq)))
244 (with-transformed-positions ((sheet-native-transformation (medium-sheet medium))
245 position-seq)
246 (with-CLX-graphics (medium)
247 (loop for (left top right bottom) on position-seq by #'cddddr
248 nconcing (list (round left) (round top)
249 (round (- right left)) (round (- bottom top))) into points
250 finally (xlib:draw-rectangles mirror gc points filled)))))
251
252 (defmethod medium-draw-ellipse* ((medium clx-medium) center-x center-y
253 radius-1-dx radius-1-dy radius-2-dx radius-2-dy
254 start-angle end-angle filled)
255 (unless (or (= radius-2-dx radius-1-dy 0) (= radius-1-dx radius-2-dy 0))
256 (error "MEDIUM-DRAW-ELLIPSE* not yet implemented for non axis-aligned ellipses."))
257 (with-transformed-position ((sheet-native-transformation (medium-sheet medium))
258 center-x center-y)
259 (with-CLX-graphics (medium)
260 (let ((radius-dx (abs (+ radius-1-dx radius-2-dx)))
261 (radius-dy (abs (+ radius-1-dy radius-2-dy))))
262 (xlib:draw-arc mirror gc
263 (round (- center-x radius-dx)) (round (- center-y radius-dy))
264 (round (* radius-dx 2)) (round (* radius-dy 2))
265 start-angle (- end-angle start-angle)
266 filled)))))
267
268 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
269 ;;;
270 ;;; Methods for text styles
271
272 (defmethod text-style-ascent (text-style (medium clx-medium))
273 (let ((font (text-style-to-X-font (port medium) text-style)))
274 (xlib:font-ascent font)))
275
276 (defmethod text-style-descent (text-style (medium clx-medium))
277 (let ((font (text-style-to-X-font (port medium) text-style)))
278 (xlib:font-descent font)))
279
280 (defmethod text-style-height (text-style (medium clx-medium))
281 (let ((font (text-style-to-X-font (port medium) text-style)))
282 (+ (xlib:font-ascent font) (xlib:font-descent font))))
283
284 (defmethod text-style-width (text-style (medium clx-medium))
285 (xlib:char-width (text-style-to-X-font (port medium) text-style) (char-code #\m)))
286
287 (defun translate (src src-start src-end afont dst dst-start)
288 ;; This is for replacing the clx-translate-default-function
289 ;; who does'nt know about accentated characters because
290 ;; of a call to cl:graphic-char-p that return nil with accentated characters.
291 ;; For further informations, on a clx-translate-function, see the clx-man.
292 (declare (type sequence src)
293 (type xlib:array-index src-start src-end dst-start)
294 (type (or null xlib:font) afont)
295 (type vector dst))
296 (declare (xlib::clx-values integer
297 (or null integer xlib:font)
298 (or null integer)))
299 (let ((min-char-index (xlib:font-min-char afont))
300 (max-char-index (xlib:font-max-char afont)))
301 afont
302 (if (stringp src)
303 (do ((i src-start (xlib::index+ i 1))
304 (j dst-start (xlib::index+ j 1))
305 (char))
306 ((xlib::index>= i src-end)
307 i)
308 (declare (type xlib:array-index i j))
309 (setq char (xlib:char->card8 (char src i)))
310 (if (or (< char min-char-index) (> char max-char-index))
311 (return i)
312 (setf (aref dst j) char)))
313 (do ((i src-start (xlib::index+ i 1))
314 (j dst-start (xlib::index+ j 1))
315 (elt))
316 ((xlib::index>= i src-end)
317 i)
318 (declare (type xlib:array-index i j))
319 (setq elt (elt src i))
320 (when (characterp elt) (setq elt (xlib:char->card8 elt)))
321 (if (or (not (integerp elt))
322 (< elt min-char-index)
323 (> elt max-char-index))
324 (return i)
325 (setf (aref dst j) elt))))))
326
327 (defmethod text-size ((medium clx-medium) string &key text-style (start 0) end)
328 (when (characterp string)
329 (setf string (make-string 1 :initial-element string)))
330 (unless end (setf end (length string)))
331 (unless text-style (setf text-style (medium-text-style medium)))
332 (if (= start end)
333 (values 0 0 0 0 0)
334 (let ((gctxt (medium-gcontext medium (medium-ink medium)))
335 (position-newline (position #\newline string :start start)))
336 (if position-newline
337 (multiple-value-bind (width ascent descent left right
338 font-ascent font-descent direction
339 first-not-done)
340 (xlib:text-extents gctxt string
341 :start start :end position-newline
342 :translate #'translate)
343 (declare (ignorable left right
344 font-ascent font-descent
345 direction first-not-done))
346 (multiple-value-bind (w h x y baseline)
347 (text-size medium string :text-style text-style
348 :start (1+ position-newline) :end end)
349 (values (max w width) (+ ascent descent h)
350 x (+ ascent descent y) (+ ascent descent baseline))))
351 (multiple-value-bind (width ascent descent left right
352 font-ascent font-descent direction
353 first-not-done)
354 (xlib:text-extents gctxt string
355 :start start :end position-newline
356 :translate #'translate)
357 (declare (ignorable left right
358 font-ascent font-descent
359 direction first-not-done))
360 (values width (+ ascent descent) width 0 ascent))))))
361
362 (defmethod medium-draw-text* ((medium clx-medium) string x y
363 start end
364 align-x align-y
365 toward-x toward-y transform-glyphs)
366 (declare (ignore toward-x toward-y transform-glyphs))
367 (with-transformed-position ((sheet-native-transformation (medium-sheet medium))
368 x y)
369 (with-CLX-graphics (medium)
370 (when (characterp string)
371 (setq string (make-string 1 :initial-element string)))
372 (when (null end) (setq end (length string)))
373 (multiple-value-bind (text-width text-height x-cursor y-cursor baseline)
374 (text-size medium string :start start :end end)
375 (declare (ignore x-cursor y-cursor))
376 (unless (and (eq align-x :left) (eq align-y :baseline))
377 (setq x (- x (ecase align-x
378 (:left 0)
379 (:center (round text-width 2))
380 (:right text-width))))
381 (setq y (ecase align-y
382 (:top (+ y baseline))
383 (:center (+ y baseline (- (floor text-height 2))))
384 (:baseline y)
385 (:bottom (+ y baseline (- text-height)))))))
386 (xlib:draw-glyphs mirror gc (round x) (round y) string
387 :start start :end end
388 :translate #'translate))))
389
390 (defmethod medium-buffering-output-p ((medium clx-medium))
391 t)
392
393 (defmethod (setf medium-buffering-output-p) (buffer-p (medium clx-medium))
394 buffer-p)
395
396 (defmethod medium-draw-glyph ((medium clx-medium) element x y
397 align-x align-y toward-x toward-y
398 transform-glyphs)
399 (declare (ignore toward-x toward-y transform-glyphs align-x align-y))
400 (with-transformed-position ((sheet-native-transformation (medium-sheet medium))
401 x y)
402 (with-CLX-graphics (medium)
403 (xlib:draw-glyph mirror gc (round x) (round y) element
404 :translate #'translate))))
405
406
407 ;;; Other Medium-specific Output Functions
408
409 (defmethod medium-finish-output ((medium clx-medium))
410 (xlib:display-finish-output (clx-port-display (port medium))))
411
412 (defmethod medium-force-output ((medium clx-medium))
413 (xlib:display-force-output (clx-port-display (port medium))))
414
415 (defmethod medium-clear-area ((medium clx-medium) left top right bottom)
416 (xlib:clear-area (port-lookup-mirror (port medium) (medium-sheet medium))
417 :x (round left) :y (round top)
418 :width (round (- right left)) :height (round (- bottom top))))
419
420 (defmethod medium-beep ((medium clx-medium))
421 (xlib:bell (clx-port-display (port medium))))
422
423 ;;;;
424
425 (defmethod invoke-with-special-choices (continuation (sheet clx-medium))
426 ;; CLX-MEDIUM right here? --GB
427 (with-double-buffering (sheet)
428 (funcall continuation sheet)))

  ViewVC Help
Powered by ViewVC 1.1.5