?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Moved AIMAGE drawing routines into McCLIM.
[closure-html.git] / src / renderer / x11.lisp
blob300718f0c37cf1e5cce1d06606c27c0af8a4166e
1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: WS/X11; -*-
2 ;;; ---------------------------------------------------------------------------
3 ;;; Title: X11 specific stuff
4 ;;; Created: 1998-11-11
5 ;;; Author: Gilbert Baumann <gilbert@base-engineering.com>
6 ;;; License: MIT style (see below)
7 ;;; ---------------------------------------------------------------------------
8 ;;; (c) copyright 1998,1999 by Gilbert Baumann
9
10 ;;; Permission is hereby granted, free of charge, to any person obtaining
11 ;;; a copy of this software and associated documentation files (the
12 ;;; "Software"), to deal in the Software without restriction, including
13 ;;; without limitation the rights to use, copy, modify, merge, publish,
14 ;;; distribute, sublicense, and/or sell copies of the Software, and to
15 ;;; permit persons to whom the Software is furnished to do so, subject to
16 ;;; the following conditions:
17 ;;;
18 ;;; The above copyright notice and this permission notice shall be
19 ;;; included in all copies or substantial portions of the Software.
20 ;;;
21 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
22 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
23 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
24 ;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
25 ;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
26 ;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
27 ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
28
29 ;;; Changes
30
31 ;;; 1999-08-11 GB REAL-BITS-PER-RGB - new function
32 ;;; PIXEL-TRANSLATOR-CODE uses it.
33
34 (in-package :WS/X11)
35
36 ;;;; --------------------------------------------------------------------------
37 ;;;; Pixel translation
38 ;;;;
39
40 (defparameter *dither-threshold* 4)
41 (defparameter *code-optimization*
42 '#.cl-user:+optimize-very-fast-trusted+)
43
44 (defvar *dither-map*
45 '#2A((0 192 48 240 12 204 60 252)
46 (128 64 176 112 140 76 188 124)
47 (32 224 16 208 44 236 28 220)
48 (160 96 144 80 172 108 156 92)
49 (8 200 56 248 4 196 52 244)
50 (136 72 184 120 132 68 180 116)
51 (40 232 24 216 36 228 20 212)
52 (168 104 152 88 164 100 148 84)))
53
54 (defun colormap-plist (colormap)
55 (cdr (assoc colormap
56 (getf (xlib:display-plist (xlib:colormap-display colormap))
57 'colormap-plisten)
58 :test #'xlib:colormap-equal)))
59
60 (defun (setf colormap-plist) (value colormap)
61 (let ((x (assoc colormap
62 (getf (xlib:display-plist (xlib:colormap-display colormap))
63 'colormap-plisten)
64 :test #'xlib:colormap-equal)))
65 (if x
66 (setf (cdr x) value)
67 (push (cons colormap value)
68 (getf (xlib:display-plist (xlib:colormap-display colormap))
69 'colormap-plisten)))))
70
71 ;; static color is merkwürdig, denn es
72 ;; hat red/green/blue masken
73
74 (defun real-bits-per-rgb (vi)
75 (let ((n (min (logcount (xlib:visual-info-red-mask vi))
76 (logcount (xlib:visual-info-green-mask vi))
77 (logcount (xlib:visual-info-blue-mask vi)))))
78 (cond ((zerop n)
79 (xlib:visual-info-bits-per-rgb vi))
80 (t
81 n))))
82
83 (defun pixel-translator-code (colormap)
84 (or (getf (colormap-plist colormap) 'pixel-translator-code)
85 (setf (getf (colormap-plist colormap) 'pixel-translator-code)
86 (let ((vi (xlib:colormap-visual-info colormap)))
87 (case (xlib:visual-info-class vi)
88 ((:static-gray)
89 (cond ((<= (real-bits-per-rgb vi) *dither-threshold*)
90 ;;(warn "Static gray dithered")
91 (static-gray-ditherer colormap))
92 (t
93 ;;(warn "Static gray")
94 (static-gray-translator colormap))))
95 ((:true-color)
96 (cond ((<= (real-bits-per-rgb vi) *dither-threshold*)
97 ;;(warn "True color dithered")
98 (true-color-ditherer colormap))
99 (t
100 ;;(warn "True color")
101 (true-color-translator colormap))))
102 ((:pseudo-color)
103 ;; (warn "Pseudo color")
104 ;; XXX -- we need a better guess for the size of the cube
105 (or
106 (rgb-cube-ditherer colormap)
107 (fallback-b/w-ditherer colormap)))
108 (otherwise
109 (warn "Weird visual class -- falling back to black and white dithering.")
110 (fallback-b/w-ditherer colormap)) )) )))
111
112 (defun pixel-translator (colormap)
113 (or (getf (colormap-plist colormap) 'pixel-translator)
114 (setf (getf (colormap-plist colormap) 'pixel-translator)
115 (compile nil (pixel-translator-code colormap)))))
116
117 (defun component-deposition-expr (component-expr dest-byte ramp linearp
118 &optional (shifted-p nil))
119 (let ((value-map (if linearp
120 `(lambda (x) (dpb x (byte ,(byte-size dest-byte)
121 ,(byte-position dest-byte))
122 0))
123 `(lambda (x) (aref (the ,(type-of ramp) ',ramp) x)))))
124 (let ((n (byte-size dest-byte)))
125 (assert (<= n 8))
126 `(the (unsigned-byte ,(+ (byte-position dest-byte) (byte-size dest-byte)))
127 (,value-map ,(if shifted-p
128 component-expr
129 `(the (unsigned-byte ,n)
130 (ldb (byte ,n ,(- 8 n))
131 ,component-expr))))))))
132
133 (defun static-gray-translator (colormap)
134 (let ((gray-byte (visual-info-gray-byte (xlib:colormap-visual-info colormap))))
135 (multiple-value-bind (ramp linearp) (allocate-gray-ramp colormap)
136 `(lambda (x y sample)
137 (declare (ignore x y)
138 (type (unsigned-byte 24) sample)
139 ,*code-optimization*)
140 ,(component-deposition-expr '(luminance sample) gray-byte ramp linearp)))))
141
142 (defun static-gray-ditherer (colormap)
143 (let* ((gray-byte (visual-info-gray-byte (xlib:colormap-visual-info colormap)))
144 (n (ash 1 (byte-size gray-byte))))
145 (multiple-value-bind (ramp linearp) (allocate-gray-ramp colormap)
146 `(lambda (x y sample)
147 (declare (type (unsigned-byte 24) sample)
148 ,*code-optimization*)
149 ,(component-deposition-expr `(the (integer 0 (,n))
150 (,(generic-ditherer n) x y (luminance sample)))
151 gray-byte
152 ramp linearp
153 t)))))
154
155 (defun identity-mapping-p (vector)
156 (dotimes (i (length vector) t)
157 (unless (eql (aref vector i) i)
158 (return nil))))
159
160 (defun luminance (sample)
161 (declare (type (unsigned-byte 24) sample))
162 (floor (the (unsigned-byte 18)
163 (+ (* 307 (the (unsigned-byte 8) (ldb (byte 8 0) sample))) ;red
164 (* 599 (the (unsigned-byte 8) (ldb (byte 8 8) sample))) ;green
165 (* 118 (the (unsigned-byte 8) (ldb (byte 8 16) sample))))) ;blue
166 1024))
167
168 (define-compiler-macro luminance (sample)
169 `((lambda (sample)
170 (the (unsigned-byte 8)
171 (floor (the (unsigned-byte 18)
172 (+ (* 307 (the (unsigned-byte 8) (ldb (byte 8 0) sample))) ;red
173 (* 599 (the (unsigned-byte 8) (ldb (byte 8 8) sample))) ;green
174 (* 118 (the (unsigned-byte 8) (ldb (byte 8 16) sample))))) ;blue
175 1024)))
176 ,sample))
177
178 (defun generic-ditherer (m)
179 `(lambda (x y s)
180 (multiple-value-bind (c0 delta)
181 (floor (the (integer 0 ,(* (1- m) 255)) (* ,(1- m) s)) 255)
182 (declare (type (unsigned-byte 8) delta)
183 (type (integer 0 (,m)) c0))
184 (if (<= (the (unsigned-byte 8) delta)
185 (the (unsigned-byte 8)
186 (aref *dither-map*
187 (logand x #x7)
188 (logand y #x7))))
189 c0
190 (+ c0 1)))))
191
192 (defun true-color-translator (colormap)
193 (multiple-value-bind (red-ramp red-linear) (allocate-component-ramp colormap :red)
194 (multiple-value-bind (green-ramp green-linear) (allocate-component-ramp colormap :green)
195 (multiple-value-bind (blue-ramp blue-linear) (allocate-component-ramp colormap :blue)
196 `(lambda (x y sample)
197 (declare (ignore x y)
198 (type (unsigned-byte 24) sample)
199 ,*code-optimization*)
200 (logior ,(component-deposition-expr
201 '(the (unsigned-byte 8) (ldb (byte 8 0) sample))
202 (mask->byte
203 (xlib:visual-info-red-mask
204 (xlib:colormap-visual-info colormap)))
205 red-ramp
206 red-linear)
207 ,(component-deposition-expr
208 '(the (unsigned-byte 8) (ldb (byte 8 8) sample))
209 (mask->byte
210 (xlib:visual-info-green-mask
211 (xlib:colormap-visual-info colormap)))
212 green-ramp
213 green-linear)
214 ,(component-deposition-expr
215 '(the (unsigned-byte 8) (ldb (byte 8 16) sample))
216 (mask->byte
217 (xlib:visual-info-blue-mask
218 (xlib:colormap-visual-info colormap)))
219 blue-ramp
220 blue-linear)))))))
221
222 (defun allocate-component-ramp (colormap component)
223 (let ((byte (mask->byte
224 (ecase component
225 (:red (xlib:visual-info-red-mask (xlib:colormap-visual-info colormap)))
226 (:green (xlib:visual-info-green-mask (xlib:colormap-visual-info colormap)))
227 (:blue (xlib:visual-info-blue-mask (xlib:colormap-visual-info colormap)))))))
228 (let ((res (make-array (ash 1 (byte-size byte)) :element-type '(unsigned-byte 32)))
229 (linearp t))
230 (dotimes (i (ash 1 (byte-size byte)))
231 (let ((color (case component
232 (:red (xlib:make-color :red (/ i (1- (ash 1 (byte-size byte)))) :green 0 :blue 0))
233 (:green (xlib:make-color :green (/ i (1- (ash 1 (byte-size byte)))) :red 0 :blue 0))
234 (:blue (xlib:make-color :blue (/ i (1- (ash 1 (byte-size byte)))) :red 0 :green 0)))))
235 (let ((pixel (xlib:alloc-color colormap color))
236 (naiv (dpb i byte 0)))
237 (when (/= naiv pixel)
238 (setf linearp nil))
239 (setf (aref res i) pixel))))
240 (values
241 res
242 linearp))))
243
244 (defun allocate-gray-ramp (colormap)
245 (let ((byte (visual-info-gray-byte (xlib:colormap-visual-info colormap))))
246 (let ((linearp t)
247 (res (make-array (ash 1 (byte-size byte)) :element-type '(unsigned-byte 32))))
248 (dotimes (i (ash 1 (byte-size byte)))
249 (let ((color (xlib:make-color :red (/ i (1- (ash 1 (byte-size byte))))
250 :green (/ i (1- (ash 1 (byte-size byte))))
251 :blue (/ i (1- (ash 1 (byte-size byte)))) )))
252 (let ((pixel (xlib:alloc-color colormap color))
253 (naiv (dpb i byte 0)))
254 (when (/= naiv pixel)
255 (setf linearp nil))
256 (setf (aref res i) pixel))))
257 (values res linearp))))
258
259 (defun visual-info-gray-byte (vi)
260 (let ((m (integer-length (1- (xlib:visual-info-colormap-entries vi))))
261 (n (xlib:visual-info-bits-per-rgb vi)))
262 (byte n (- m n))))
263
264 (defun true-color-ditherer (colormap)
265 (multiple-value-bind (red-ramp red-linear) (allocate-component-ramp colormap :red)
266 (multiple-value-bind (green-ramp green-linear) (allocate-component-ramp colormap :green)
267 (multiple-value-bind (blue-ramp blue-linear) (allocate-component-ramp colormap :blue)
268 (let ((rm (xlib:visual-info-red-mask (xlib:colormap-visual-info colormap)))
269 (gm (xlib:visual-info-green-mask (xlib:colormap-visual-info colormap)))
270 (bm (xlib:visual-info-blue-mask (xlib:colormap-visual-info colormap))))
271 (let ((nr (ash 1 (byte-size (mask->byte rm))))
272 (nb (ash 1 (byte-size (mask->byte bm))))
273 (ng (ash 1(byte-size (mask->byte gm)))))
274 `(lambda (x y sample)
275 (declare (type (unsigned-byte 24) sample)
276 ,*code-optimization*)
277 (logior ,(component-deposition-expr
278 `(the (integer 0 (,nr))
279 (,(generic-ditherer nr) x y (ldb (byte 8 0) sample)))
280 (mask->byte rm)
281 red-ramp
282 red-linear
283 t)
284 ,(component-deposition-expr
285 `(the (integer 0 (,ng))
286 (,(generic-ditherer ng) x y (ldb (byte 8 8) sample)))
287 (mask->byte gm)
288 green-ramp
289 green-linear
290 t)
291 ,(component-deposition-expr
292 `(the (integer 0 (,nb))
293 (,(generic-ditherer nb) x y (ldb (byte 8 16) sample)))
294 (mask->byte bm)
295 blue-ramp
296 blue-linear
297 t)))))))))
298
299
300 (defparameter *colormap-niceness-max* 20
301 "When allocating many colors, maximum number of colors to leave free for other applications.
302 see *COLORMAP-NICENESS-RATIO*.")
303
304 (defparameter *colormap-niceness-ratio* 1/10
305 "When allocating many colors, ratio of available colors to leave free for other applications.
306 see *COLORMAP-NICENESS-MAX*.")
307
308 #||
309 (defun allocate-rgb-cube (colormap)
310 "Allocates a RGB cube using the colormap 'colormap';
311 Returns NIL, if not enough colors could be allocated.
312 On success returns a three dimensional array of the allocated pixel values."
313 (let* ((pixels (allocate-all-available-pixels colormap))
314 (m (length pixels)))
315 ;; Be nice to our neighbor and leave some colors available.
316 (let ((nice (min m *colormap-niceness-max*
317 (floor (* m *colormap-niceness-ratio*)))))
318 (xlib:free-colors colormap (subseq pixels (- (length pixels) nice)))
319 (setf pixels (butlast pixels nice))
320 (setf m (length pixels))
321 (let ((d (floor (expt m 1/3))))
322 (cond ((< d 2)
323 ;; no useful RGB cube to allocate
324 (xlib:free-colors colormap pixels)
325 nil)
326 (t
327 (let ((needed (expt d 3))
328 (cube (make-array (list d d d) :element-type '(unsigned-byte 32) :initial-element 0)))
329 ;; return what we don't need
330 (xlib:free-colors colormap (subseq pixels needed))
331 (setf pixels (subseq pixels 0 needed))
332 ;; now actually allocate the cube
333 (dotimes (red d)
334 (dotimes (green d)
335 (dotimes (blue d)
336 (let ((pixel (pop pixels)))
337 (xlib:store-color colormap pixel
338 (xlib:make-color :red (/ red (1- d))
339 :green (/ green (1- d))
340 :blue (/ blue (1- d))))
341 (setf (aref cube red green blue) pixel)))))
342 cube)) )))))
343 ||#
344
345 (defun color-difference (c1 c2)
346 (+ (expt (- (xlib:color-red c1) (xlib:color-red c2)) 2)
347 (expt (- (xlib:color-green c1) (xlib:color-green c2)) 2)
348 (expt (- (xlib:color-blue c1) (xlib:color-blue c2)) 2)))
349
350 (defun allocate-rgb-cube (colormap)
351 ;; We'd better grab the server, so nobody else can choose to
352 ;; allocate colors we have.
353 (let* ((my (allocate-all-available-pixels colormap))
354 (their (set-difference (loop for i from 0 below (xlib:visual-info-colormap-entries
355 (xlib:colormap-visual-info colormap))
356 collect i)
357 my))
358 (their-colors
359 (mapcar #'list (xlib:query-colors colormap their)
360 their)))
361 (unwind-protect
362 (progn
363 ;; Now for each desired color value find the best match
364 (let* ((d 6)
365 (cube (make-array (list d d d)))
366 nice)
367 (dotimes (red d)
368 (dotimes (green d)
369 (dotimes (blue d)
370 (let ((needed (xlib:make-color :red (/ red (1- d))
371 :green (/ green (1- d))
372 :blue (/ blue (1- d)))))
373 (let ((best-match (first their-colors))
374 (best-delta (color-difference needed (first (first their-colors)))))
375 (dolist (x their-colors)
376 (let ((delta (color-difference (first x) needed)))
377 (when (< delta best-delta)
378 (setf best-match x
379 best-delta delta))))
380 (setf (aref cube red green blue) (list best-match best-delta needed)))))))
381 ;; Be nice to our neighbor and leave some colors available.
382 (setf nice (min (length my)
383 *colormap-niceness-max*
384 (floor (* (length my) *colormap-niceness-ratio*))))
385 (xlib:free-colors colormap (subseq my (- (length my) nice)))
386 (setf my (butlast my nice))
387 (warn "We have ~D colors on our own!" (length my))
388 ;; Then pick the m worst matches and replace them by private colors
389 (dotimes (k (length my))
390 (let ((worst-delta (second (aref cube 0 0 0)))
391 (worst-index (list 0 0 0)))
392 (dotimes (red d)
393 (dotimes (green d)
394 (dotimes (blue d)
395 (when (> (second (aref cube red green blue))
396 worst-delta)
397 (setf worst-index (list red green blue)
398 worst-delta (second (aref cube red green blue)))))))
399 (destructuring-bind (bm bd nd) (apply #'aref cube worst-index)
400 (setf (apply #'aref cube worst-index)
401 (list (list nd (elt my k))
402 0
403 nd)))))
404 ;;
405 (let ((res (make-array (list d d d) :element-type '(unsigned-byte 32) :initial-element 0)))
406 (dotimes (r d)
407 (dotimes (g d)
408 (dotimes (b d)
409 (setf (aref res r g b)
410 (cond ((member (second (first (aref cube r g b))) my)
411 (xlib:store-color colormap
412 (second (first (aref cube r g b)))
413 (first (first (aref cube r g b))))
414 (second (first (aref cube r g b))))
415 (t
416 ;; We need to allocate them never the less
417 (xlib:alloc-color colormap (first (first (aref cube r g b))))))))))
418 (setq my nil)
419 res)))
420 (xlib:free-colors colormap my) )))
421
422 (defun number-of-available-colors (colormap)
423 ;; This does a silly search to find the number of available colors
424 ;; in the color map 'colormap'.
425 (let ((x 0)) ;number of colors to allocate
426 (loop
427 for i
428 from (ceiling (log (xlib:visual-info-colormap-entries (xlib:colormap-visual-info colormap))
429 2))
430 downto 0
431 do (let ((d (expt 2 i)))
432 (let ((pixels nil))
433 (unwind-protect
434 (progn
435 (setf pixels (ignore-errors (xlib:alloc-color-cells colormap (+ x d))))
436 (when (not (null pixels))
437 (incf x d)))
438 (when (not (null pixels))
439 (xlib:free-colors colormap pixels))))))
440 x))
441
442 (defun allocate-all-available-pixels (colormap)
443 "Given a colormap allocate all available color cells; returns a list of allocated pixels."
444 (let ((pixels nil))
445 (loop for i
446 from (ceiling (log (xlib:visual-info-colormap-entries (xlib:colormap-visual-info colormap))
447 2))
448 downto 0
449 do
450 (setf pixels (append pixels (ignore-errors (xlib:alloc-color-cells colormap (expt 2 i))))))
451 pixels))
452
453 (defun rgb-cube-ditherer (colormap)
454 "Returns an RGB cube ditherer; If there are not enough available colors NIL is returned."
455 (let ((cube (allocate-rgb-cube colormap)))
456 (and cube
457 `(lambda (x y sample)
458 (declare (type (unsigned-byte 16) x y)
459 (type (unsigned-byte 24) sample)
460 ,*code-optimization*)
461 (aref (the ,(type-of cube) ',cube)
462 (,(generic-ditherer (array-dimension cube 0)) x y (ldb (byte 8 0) sample))
463 (,(generic-ditherer (array-dimension cube 1)) x y (ldb (byte 8 8) sample))
464 (,(generic-ditherer (array-dimension cube 2)) x y (ldb (byte 8 16) sample)))))))
465
466 (defun fallback-b/w-ditherer (colormap)
467 (let ((black (xlib:alloc-color colormap (xlib:make-color :red 0 :blue 0 :green 0)))
468 (white (xlib:alloc-color colormap (xlib:make-color :red 1 :blue 1 :green 1))))
469 `(lambda (x y sample)
470 (declare (type (unsigned-byte 24) sample)
471 ,*code-optimization*)
472 (if (zerop (,(generic-ditherer 2) x y (luminance sample)))
473 ,black
474 ,white)) ))
475
476 (defun mask->byte (mask)
477 (let ((h (integer-length mask)))
478 (let ((l (integer-length (logxor mask (1- (ash 1 h))))))
479 (byte (- h l) l))))
480
481 ;;;; ==========================================================================================
482
483 (defun ximage-translator** (window)
484 (ximage-translator* (pixel-translator-code (xlib:window-colormap window))
485 (xlib:drawable-depth window)))
486
487 (defun ximage-translator* (tr depth)
488 `(lambda (aimage)
489 (declare (type imagelib:aimage aimage)
490 (:explain :calls)
491 ,*code-optimization*)
492 (let* ((width (imagelib:aimage-width aimage))
493 (height (imagelib:aimage-height aimage))
494 (idata (imagelib:aimage-data aimage))
495 (xdata (make-array (list height width) :element-type '(unsigned-byte ,depth)))
496 (ximage (xlib:create-image :width width
497 :height height
498 :depth ,depth
499 :data xdata)))
500 (declare (type fixnum width height)
501 (type (simple-array (unsigned-byte ,depth) (* *)) xdata)
502 (type (simple-array (unsigned-byte 32) (* *)) idata))
503 (do ((y (1- height) (- y 1)))
504 ((< y 0))
505 (do ((x (1- width) (- x 1)))
506 ((< x 0))
507 (setf (aref xdata (the (unsigned-byte 16) y) (the (unsigned-byte 16) x))
508 (,tr x y (ldb (byte 24 0)
509 (aref idata
510 (the (unsigned-byte 16) y)
511 (the (unsigned-byte 16) x)))))))
512 ximage)))
513
514 (defun ximage-translator* (tr depth)
515 `(lambda (aimage)
516 (declare (type imagelib:aimage aimage)
517 (:explain :calls)
518 ,*code-optimization*)
519 (let* ((width (imagelib:aimage-width aimage))
520 (height (imagelib:aimage-height aimage))
521 (idata (imagelib:aimage-data aimage))
522 (xdata (make-array (list height width) :element-type '(unsigned-byte ,depth)))
523 (ximage (xlib:create-image :width width
524 :height height
525 :depth ,depth
526 :data xdata)))
527 (declare (type fixnum width height)
528 (type (simple-array (unsigned-byte ,depth) (* *)) xdata)
529 (type (simple-array (unsigned-byte 32) (* *)) idata))
530 (let ((i (1- (* width height))))
531 (declare (type fixnum i))
532 (loop for y fixnum from (1- height) downto 0 do
533 (loop for x fixnum from (1- width) downto 0 do
534 (setf (row-major-aref (the (simple-array (unsigned-byte ,depth) (* *)) xdata)
535 (the fixnum i))
536 (,tr x y (the (unsigned-byte 24)
537 (ldb (byte 24 0)
538 (row-major-aref (the (simple-array (unsigned-byte 32) (* *)) idata)
539 (the fixnum i))))))
540 (decf i))))
541 ximage)))
542
543 (defun ximage-translator (window)
544 (or (getf (colormap-plist (xlib:window-colormap window)) 'ximage-translator)
545 (setf (getf (colormap-plist (xlib:window-colormap window)) 'ximage-translator)
546 (compile nil (ximage-translator** window)))))
547
548 ;;;; --------------------------------------------------------------------------
549 ;;;; colours
550 ;;;;
551
552 (defparameter *color-names*
553 '(("black" . "#000000")
554 ("green" . "#008000")
555 ("silver" . "#C0C0C0")
556 ("lime" . "#00FF00")
557 ("gray" . "#808080")
558 ("olive" . "#808000")
559 ("white" . "#FFFFFF")
560 ("yellow" . "#FFFF00")
561 ("maroon" . "#800000")
562 ("navy" . "#000080")
563 ("red" . "#FF0000")
564 ("blue" . "#0000FF")
565 ("purple" . "#800080")
566 ("teal" . "#008080")
567 ("fuchsia" . "#FF00FF")
568 ("aqua" . "#00FFFF")))
569
570 (defun parse-color (string)
571 "Attemps to parse a color."
572 ;; The color names defined by *color-names* are unterstood.
573 ;; Otherwise the syntax is '#rgb' or '#rrggbb'. None of the fancier
574 ;; X11 conventions are understood.
575 (setq string (or (cdr (assoc string *color-names* :test #'string-equal))
576 string))
577 (cond ((and (= (length string) 7)
578 (char= (char string 0) #\#))
579 (let ((r (maybe-parse-integer (subseq string 1 3) :radix 16))
580 (g (maybe-parse-integer (subseq string 3 5) :radix 16))
581 (b (maybe-parse-integer (subseq string 5 7) :radix 16)))
582 (and r g b
583 (xlib:make-color :red (/ r 255) :green (/ g 255) :blue (/ b 255)))))
584 ((and (= (length string) 4)
585 (char= (char string 0) #\#))
586 (let ((r (maybe-parse-integer (subseq string 1 2) :radix 16))
587 (g (maybe-parse-integer (subseq string 2 3) :radix 16))
588 (b (maybe-parse-integer (subseq string 3 4) :radix 16)))
589 (and r g b
590 (xlib:make-color :red (/ r 15) :green (/ g 15) :blue (/ b 15)))))))
591
592 (defun color->24-bit (color)
593 "Turns the string representation of a color into a 24-bit RGB-value."
594 (let ((color (or (ignore-errors
595 (or (parse-color color)
596 (parse-color (concatenate 'string "#" color))))
597 (progn
598 (warn "Color `~A' does not parse." color)
599 (xlib:make-color
600 :red .5 :green .5 :blue .5)))))
601 (let* ((r (min 255 (max 0 (round (* 255 (xlib:color-red color))))))
602 (g (min 255 (max 0 (round (* 255 (xlib:color-green color))))))
603 (b (min 255 (max 0 (round (* 255 (xlib:color-blue color))))))
604 (p (dpb r (byte 8 0)
605 (dpb g (byte 8 8)
606 (dpb b (byte 8 16)
607 0)))))
608 p)))
609
610 (defun color-cache (colormap)
611 "The `colormap's color cache for FIND-COLOR."
612 (or (getf (colormap-plist colormap) 'color-cache)
613 (setf (getf (colormap-plist colormap) 'color-cache)
614 (make-hash-table :test #'equal))))
615
616 (defun x11-find-color (window colorspec)
617 "Returns the X11 pixel value of the color given by the string `colorspec'
618 suitable for window `window'."
619 ;; We go through the pixel-translator to accommodate pseudo color
620 ;; screens. On those screen, it would harm to allocate new pixel
621 ;; values instead of using approximations from the rgb-cube.
622 ;; Generally there is no need to go thru' xlib:alloc-color.
623 (let ((cache (color-cache (xlib:window-colormap window))))
624 (or (gethash colorspec cache)
625 (setf (gethash colorspec cache)
626 (let ((p (color->24-bit colorspec)))
627 (funcall (pixel-translator (xlib:window-colormap window))
628 0 0 p) )))))
629
630 ;;;; ------------------------------------------------------------------------------------------
631 ;;;; Drawing Borders
632 ;;;;
633
634 ;;;; Border styles:
635
636 ;;;; none
637 ;;;; no border is drawn (regardless of the 'border-width' value)
638
639 ;;;; dotted
640 ;;;; the border is a dotted line drawn on top of the background of the
641 ;;;; element
642
643 ;;;; dashed
644 ;;;; the border is a dashed line drawn on top of the background of the
645 ;;;; element
646
647 ;;;; solid
648 ;;;; the border is a solid line
649
650 ;;;; double
651 ;;;; the border is a double line drawn on top of the background of the
652 ;;;; element. The sum of the two single lines and the space between
653 ;;;; equals the <border-width> value.
654
655 ;;;; groove
656 ;;;; a 3D groove is drawn in colors based on the <color> value.
657
658 ;;;; ridge
659 ;;;; a 3D ridge is drawn in colors based on the <color> value.
660
661 ;;;; inset
662 ;;;; a 3D inset is drawn in colors based on the <color> value.
663
664 ;;;; outset
665 ;;;; a 3D outset is drawn in colors based on the <color> value.
666
667 (defun draw-border (drawable gcontext
668 x0 y0 w h
669 ts tw tc
670 rs rw rc
671 bs bw bc
672 ls lw lc)
673 (let ((x0 x0)
674 (x1 (+ x0 lw))
675 (x2 (- (+ x0 w) rw))
676 (x3 (+ x0 w))
677 (y0 y0)
678 (y1 (+ y0 tw))
679 (y2 (- (+ y0 h) bw))
680 (y3 (+ y0 h)))
681 (draw-border-left drawable gcontext ls lc x0 x1 y0 y1 y2 y3)
682 (draw-border-right drawable gcontext rs rc x2 x3 y0 y1 y2 y3)
683 (draw-border-top drawable gcontext ts tc y0 y1 x0 x1 x2 x3)
684 (draw-border-bottom drawable gcontext bs bc y2 y3 x0 x1 x2 x3) ))
685
686 (defun draw-border-left (drawable gcontext style color x0 x1 y0 y1 y2 y3)
687 (ecase style
688 (:solid
689 (xlib:with-gcontext (gcontext :foreground (x11-find-color drawable color))
690 (xlib:draw-lines drawable gcontext (mapcar #'floor (list x0 y0 x1 y1 x1 y2 x0 y3)) :fill-p t) ))
691 (:inset
692 (draw-border-left drawable gcontext :solid (3d-dark-color color) x0 x1 y0 y1 y2 y3))
693 (:outset
694 (draw-border-left drawable gcontext :solid (3d-light-color color) x0 x1 y0 y1 y2 y3))
695 (:ridge
696 (draw-border-left drawable gcontext :outset color x0 (+ x0 (floor (- x1 x0) 2))
697 y0 (+ y0 (floor (- y1 y0) 2)) (+ y2 (floor (- y3 y2) 2)) y3)
698 (draw-border-left drawable gcontext :inset color (+ x0 (floor (- x1 x0) 2)) x1
699 (+ y0 (floor (- y1 y0) 2)) y1 y2 (+ y2 (ceiling (- y3 y2) 2))))
700 (:groove
701 (draw-border-left drawable gcontext :inset color x0 (+ x0 (floor (- x1 x0) 2))
702 y0 (+ y0 (floor (- y1 y0) 2)) (+ y2 (floor (- y3 y2) 2)) y3)
703 (draw-border-left drawable gcontext :outset color (+ x0 (floor (- x1 x0) 2)) x1
704 (+ y0 (floor (- y1 y0) 2)) y1 y2 (+ y2 (ceiling (- y3 y2) 2))))
705 (:double
706 (draw-border-left drawable gcontext :solid color x0 (+ x0 (ceiling (- x1 x0) 3))
707 y0 (+ y0 (ceiling (- y1 y0) 3)) (- y3 (ceiling (- y3 y2) 3)) y3)
708
709 (draw-border-left drawable gcontext :solid color (- x1 (floor (- x1 x0) 3)) x1
710 (- y1 (floor (- y1 y0) 3)) y1
711 y2 (+ y2 (floor (- y3 y2) 3))) )
712
713 (:dashed
714 (draw-dashed-line drawable gcontext
715 (floor (/ (+ x1 x0) 2))
716 (floor (/ (+ y0 y1) 2))
717 (floor (/ (+ x1 x0) 2))
718 (floor (/ (+ y2 y3) 2))
719 (abs (- x1 x0))))
720 (:dotted
721 (draw-dotted-line drawable gcontext
722 (floor (/ (+ x1 x0) 2))
723 (floor (/ (+ y0 y1) 2))
724 (floor (/ (+ x1 x0) 2))
725 (floor (/ (+ y2 y3) 2))
726 (abs (- x1 x0))))
727 ((:none))))
728
729 (defun draw-border-top (drawable gcontext style color y0 y1 x0 x1 x2 x3)
730 (ecase style
731 (:solid
732 (xlib:with-gcontext (gcontext :foreground (x11-find-color drawable color))
733 (xlib:draw-lines drawable gcontext (mapcar #'floor (list x0 y0 x1 y1 x2 y1 x3 y0)) :fill-p t) ))
734 (:inset
735 (draw-border-top drawable gcontext :solid (3d-dark-color color) y0 y1 x0 x1 x2 x3))
736 (:outset
737 (draw-border-top drawable gcontext :solid (3d-light-color color) y0 y1 x0 x1 x2 x3))
738 (:groove
739 (draw-border-top drawable gcontext :inset color y0 (+ y0 (floor (- y1 y0) 2))
740 x0 (+ x0 (floor (- x1 x0) 2)) (+ x2 (floor (- x3 x2) 2)) x3)
741 (draw-border-top drawable gcontext :outset color (+ y0 (floor (- y1 y0) 2)) y1
742 (+ x0 (floor (- x1 x0) 2)) x1 x2 (+ x2 (ceiling (- x3 x2) 2))))
743 (:ridge
744 (draw-border-top drawable gcontext :outset color y0 (+ y0 (floor (- y1 y0) 2))
745 x0 (+ x0 (floor (- x1 x0) 2)) (+ x2 (floor (- x3 x2) 2)) x3)
746 (draw-border-top drawable gcontext :inset color (+ y0 (floor (- y1 y0) 2)) y1
747 (+ x0 (floor (- x1 x0) 2)) x1 x2 (+ x2 (ceiling (- x3 x2) 2))) )
748 (:double
749 (draw-border-top drawable gcontext :solid color y0 (+ y0 (ceiling (- y1 y0) 3))
750 x0 (+ x0 (ceiling (- x1 x0) 3)) (- x3 (ceiling (- x3 x2) 3)) x3)
751
752 (draw-border-top drawable gcontext :solid color (- y1 (floor (- y1 y0) 3)) y1
753 (- x1 (floor (- x1 x0) 3)) x1
754 x2 (+ x2 (floor (- x3 x2) 3))) )
755 (:dotted
756 (draw-dotted-line drawable gcontext
757 (floor (/ (+ x0 x1) 2))
758 (floor (/ (+ y0 y1) 2))
759 (floor (/ (+ x2 x3) 2))
760 (floor (/ (+ y0 y1) 2))
761 (abs (- y1 y0))))
762
763 (:dashed
764 (draw-dashed-line drawable gcontext
765 (floor (/ (+ x0 x1) 2))
766 (floor (/ (+ y0 y1) 2))
767 (floor (/ (+ x2 x3) 2))
768 (floor (/ (+ y0 y1) 2))
769 (abs (- y1 y0))))
770
771 ((:none))))
772
773 (defun draw-border-right (drawable gcontext style color x2 x3 y0 y1 y2 y3)
774 (ecase style
775 (:solid
776 (xlib:with-gcontext (gcontext :foreground (x11-find-color drawable color))
777 (xlib:draw-lines drawable gcontext (mapcar #'floor (list x3 y0 x2 y1 x2 y2 x3 y3)) :fill-p t) ))
778 (:inset
779 (draw-border-right drawable gcontext :solid (3d-light-color color) x2 x3 y0 y1 y2 y3))
780 (:outset
781 (draw-border-right drawable gcontext :solid (3d-dark-color color) x2 x3 y0 y1 y2 y3))
782 (:ridge
783 (draw-border-right drawable gcontext :outset color (+ x2 (floor (- x3 x2) 2)) x3
784 y0 (+ y0 (floor (- y1 y0) 2)) (+ y2 (floor (- y3 y2) 2)) y3)
785 (draw-border-right drawable gcontext :inset color x2 (+ x2 (floor (- x3 x2) 2))
786 (+ y0 (floor (- y1 y0) 2)) y1 y2 (+ y2 (ceiling (- y3 y2) 2))))
787 (:groove
788 (draw-border-right drawable gcontext :inset color (+ x2 (floor (- x3 x2) 2)) x3
789 y0 (+ y0 (floor (- y1 y0) 2)) (+ y2 (floor (- y3 y2) 2)) y3)
790 (draw-border-right drawable gcontext :outset color x2 (+ x2 (floor (- x3 x2) 2))
791 (+ y0 (floor (- y1 y0) 2)) y1 y2 (+ y2 (ceiling (- y3 y2) 2))))
792 (:double
793 (draw-border-right drawable gcontext :solid color (- x3 (ceiling (- x3 x2) 3)) x3
794 y0 (+ y0 (ceiling (- y1 y0) 3)) (- y3 (ceiling (- y3 y2) 3)) y3)
795
796 (draw-border-right drawable gcontext :solid color x2 (+ x2 (floor (- x3 x2) 3))
797 (- y1 (floor (- y1 y0) 3)) y1
798 y2 (+ y2 (floor (- y3 y2) 3))) )
799
800 (:dashed
801 (draw-dashed-line drawable gcontext
802 (floor (/ (+ x2 x3) 2))
803 (floor (/ (+ y0 y1) 2))
804 (floor (/ (+ x2 x3) 2))
805 (floor (/ (+ y2 y3) 2))
806 (abs (- x2 x3))))
807 (:dotted
808 (draw-dotted-line drawable gcontext
809 (floor (/ (+ x2 x3) 2))
810 (floor (/ (+ y0 y1) 2))
811 (floor (/ (+ x2 x3) 2))
812 (floor (/ (+ y2 y3) 2))
813 (abs (- x2 x3))))
814
815 ((:none))))
816
817 (defun draw-border-bottom (drawable gcontext style color y2 y3 x0 x1 x2 x3)
818 (ecase style
819 (:solid
820 (xlib:with-gcontext (gcontext :foreground (x11-find-color drawable color))
821 (xlib:draw-lines drawable gcontext (mapcar #'floor (list x0 y3 x1 y2 x2 y2 x3 y3)) :fill-p t) ))
822 (:inset
823 (draw-border-bottom drawable gcontext :solid (3d-light-color color) y2 y3 x0 x1 x2 x3))
824 (:outset
825 (draw-border-bottom drawable gcontext :solid (3d-dark-color color) y2 y3 x0 x1 x2 x3))
826 (:ridge
827 (draw-border-bottom drawable gcontext :outset color (+ y2 (floor (- y3 y2) 2)) y3
828 x0 (+ x0 (floor (- x1 x0) 2)) (+ x2 (floor (- x3 x2) 2)) x3)
829 (draw-border-bottom drawable gcontext :inset color y2 (+ y2 (floor (- y3 y2) 2))
830 (+ x0 (floor (- x1 x0) 2)) x1 x2 (+ x2 (ceiling (- x3 x2) 2))))
831 (:groove
832 (draw-border-bottom drawable gcontext :inset color (+ y2 (floor (- y3 y2) 2)) y3
833 x0 (+ x0 (floor (- x1 x0) 2)) (+ x2 (floor (- x3 x2) 2)) x3)
834 (draw-border-bottom drawable gcontext :outset color y2 (+ y2 (floor (- y3 y2) 2))
835 (+ x0 (floor (- x1 x0) 2)) x1 x2 (+ x2 (ceiling (- x3 x2) 2))))
836 (:double
837 (draw-border-bottom drawable gcontext :solid color (- y3 (ceiling (- y3 y2) 3)) y3
838 x0 (+ x0 (ceiling (- x1 x0) 3)) (- x3 (ceiling (- x3 x2) 3)) x3)
839
840 (draw-border-bottom drawable gcontext :solid color y2 (+ y2 (floor (- y3 y2) 3))
841 (- x1 (floor (- x1 x0) 3)) x1
842 x2 (+ x2 (floor (- x3 x2) 3))) )
843
844 (:dotted
845 (draw-dotted-line drawable gcontext
846 (floor (/ (+ x0 x1) 2))
847 (floor (/ (+ y2 y3) 2))
848 (floor (/ (+ x2 x3) 2))
849 (floor (/ (+ y2 y3) 2))
850 (abs (- y2 y3))))
851
852 (:dashed
853 (draw-dashed-line drawable gcontext
854 (floor (/ (+ x0 x1) 2))
855 (floor (/ (+ y2 y3) 2))
856 (floor (/ (+ x2 x3) 2))
857 (floor (/ (+ y2 y3) 2))
858 (abs (- y2 y3))))
859
860 ((:none)) ))
861
862 (defun draw-dashed-line (drawable gcontext x1 y1 x2 y2 w)
863 (setf w (ceiling w))
864 (when (plusp w)
865 (setf (xlib:gcontext-line-width gcontext) w
866 (xlib:gcontext-cap-style gcontext) :butt
867 (xlib:gcontext-join-style gcontext) :round
868 (xlib:gcontext-line-style gcontext) :dash
869 (xlib:gcontext-dashes gcontext) (list (* 2 w) (* 2 w)))
870 (xlib:draw-line drawable gcontext x1 y1 x2 y2)
871 (setf (xlib:gcontext-line-width gcontext) 1
872 (xlib:gcontext-line-style gcontext) :solid)) )
873
874 (defun draw-dotted-line (drawable gcontext x1 y1 x2 y2 w)
875 (setf w (ceiling w))
876 (when (plusp w)
877 (setf (xlib:gcontext-line-width gcontext) w
878 (xlib:gcontext-cap-style gcontext) :round
879 (xlib:gcontext-join-style gcontext) :round
880 (xlib:gcontext-line-style gcontext) :dash
881 (xlib:gcontext-dashes gcontext) (list 1 (* 2 w)))
882 (xlib:draw-line drawable gcontext x1 y1 x2 y2)
883 (setf (xlib:gcontext-line-width gcontext) 1
884 ;;(xlib:gcontext-cap-style gcontext) :butt
885 ;;(xlib:gcontext-join-style gcontext) :butt
886 (xlib:gcontext-line-style gcontext) :solid) ))
887
888 (defun 3d-dark-color (x) x "#717171" "#444")
889 (defun 3d-light-color (x) x "#ebebeb" "#ccc")
890
891 (defun 3d-dark-color (x) x "#6e6e6e")
892 (defun 3d-light-color (x) x "#e8e8e8")
893
894 ;;;; --------------------------------------------------------------------------
895
896 ;;;; --------------------------------------------------------------------------
897
898 (defclass x11-device ()
899 ((font-database :initform nil)
900 (display :initarg :display)
901 (dpi :initarg :dpi :initform gui:*closure-dpi*)
902 (scale-font-desc-cache :initform (make-hash-table :test #'equal))))
903
904 (defmethod r2::device-dpi ((self x11-device))
905 (slot-value self 'dpi))
906
907 (defmethod r2::device-font-ascent ((self x11-device) font)
908 (xlib:font-ascent font))
909
910 (defmethod r2::device-font-descent ((self x11-device) font)
911 (xlib:font-descent font))
912
913 (defmethod r2::device-font-underline-position ((self x11-device) font)
914 (ceiling (xlib:font-descent font) 2) )
915
916 (defmethod r2::device-font-underline-thickness ((self x11-device) font)
917 (declare (ignore font))
918 1)
919
920 (defmethod r2::device-font-has-glyph-p ((self x11-device) font index)
921 (not (or (null (xlib:char-width font index))
922 (= 0
923 (xlib:char-width font index)
924 (xlib:char-ascent font index)
925 (xlib:char-descent font index)
926 (xlib:char-attributes font index)
927 (xlib:char-left-bearing font index)
928 (xlib:char-right-bearing font index)))))
929
930 (defmethod r2::device-font-glyph-width ((self x11-device) font index)
931 (xlib:char-width font index))
932
933 (defmethod r2::device-realize-font-desc ((self x11-device) font-desc)
934 (with-slots (display) self
935 (xlib:open-font display (r2::font-desc-ddp font-desc))))
936
937 #||
938 (defmethod r2::device-font-database ((self x11-device))
939 (cond ((slot-value self 'font-database))
940 (t
941 (setf (slot-value self 'font-database)
942 (x11-build-font-database self)))))
943
944 (defun x11-build-font-database (self)
945 (with-slots (display) self
946 (let ((res (r2::make-font-database
947 :cache (make-hash-table :test #'equal)
948 :device self)))
949 (dolist (fn (prog2
950 (progn
951 (format t "~&;; Querying font list ...")
952 (finish-output))
953 (tailor-font-list
954 (xlib:list-font-names display "-*-*-*-*-*-*-*-*-*-*-*-*-*-*"))
955 (progn (format t " done.") (finish-output))))
956 (let ((fd (parse-x11-font-name fn)))
957 (when fd
958 (r2::font-database-relate res fd))))
959 res)))
960 ||#
961
962 (defmethod r2::scale-font-desc ((device x11-device) fd size)
963 (labels ((hash-key (fd)
964 (list
965 (r2::font-desc-family fd)
966 (r2::font-desc-weight fd)
967 (r2::font-desc-style fd)
968 (r2::font-desc-charset fd))))
969 ;;Warum ist das wieder von 'dpi' abhängig?
970 (with-slots (scale-font-desc-cache) device
971 (or (gethash (list (hash-key fd) size) scale-font-desc-cache)
972 (progn
973 (setf (gethash (cons (hash-key fd) size) scale-font-desc-cache)
974 (cond ((zerop (r2::font-desc-size fd))
975 (let ((r (r2::copy-font-desc fd)))
976 (setf (r2::font-desc-ddp r)
977 (scale-x11-font-name (r2::font-desc-ddp r) size
978 (r2::device-dpi device)))
979 (setf (r2::font-desc-size r)
980 size)
981 r))
982 (t
983 fd))) ))) ) )
984
985 (defun scale-x11-font-name (font-name size dpi)
986 (let ((atts (cdr (css::split-by #\- font-name :nuke-empty-p nil))))
987 ;; 7 - size
988 ;; 8 - resx
989 ;; 9 - resy
990 (let ((*print-circle* nil))
991 (format nil "-~A-~A-~A-~A-~A-~A-~A-~A-~A-~A-~A-~A-~A-~A"
992 (nth 0 atts) (nth 1 atts) (nth 2 atts)
993 (nth 3 atts) (nth 4 atts) (nth 5 atts)
994 (round size) ;pixel size
995 "*" ;point size
996 dpi dpi
997 (nth 10 atts) "*" (nth 12 atts) (nth 13 atts)) ))) ; spc-avgWdth-rgstry-encoding
998
999 ;;; ---- Parsing X11 Font Names --------------------------------------------------------
1000
1001 (defun parse-x11-font-weight (str)
1002 (cdr (assoc str '(("bold" . 700) ("medium" . 400))
1003 :test #'string-equal)))
1004
1005 (defun parse-x11-font-slant (str)
1006 (cdr (assoc str '(("i" . :italic) ("o" . :oblique) ("r" . :normal))
1007 :test #'string-equal)))
1008
1009 (defun parse-x11-font-size (str resy)
1010 (ignore-errors (floor (* (parse-integer resy) (/ (parse-integer str) 720)))))
1011
1012 (defun charset-name-from-partial-x11-font-name (foundry family registry encoding)
1013 (declare (ignorable foundry family registry encoding))
1014 (cond ((string-equal registry "iso8859")
1015 (cond ((string-equal encoding "1") :iso-8859-1)
1016 ((string-equal encoding "2") :iso-8859-2)
1017 ((string-equal encoding "3") :iso-8859-3)
1018 ((string-equal encoding "4") :iso-8859-4)
1019 ((string-equal encoding "5") :iso-8859-5)
1020 ((string-equal encoding "6") :iso-8859-6)
1021 ((string-equal encoding "7") :iso-8859-7)
1022 ((string-equal encoding "8") :iso-8859-8)
1023 ((string-equal encoding "9") :iso-8859-9)))
1024 ((and (string-equal registry "iso10646")
1025 (string-equal encoding "1"))
1026 :iso-10646-1)
1027 ((and (string-equal registry "unicode")
1028 (string-equal encoding "1"))
1029 :iso-10646-1)
1030 ((and (string-equal registry "unicode")
1031 (string-equal encoding "2"))
1032 :iso-10646-1)
1033 ((and (string-equal registry "koi8")
1034 (string-equal encoding "r"))
1035 :koi8-r)
1036 ((and (string-equal registry "adobe")
1037 (string-equal encoding "symbol"))
1038 :adobe-symbol)
1039 ((and (string-equal family "symbol")
1040 (string-equal registry "adobe"))
1041 :adobe-symbol)
1042 ((and (string-equal registry "big5"))
1043 :big-5)
1044 (t
1045 nil)))
1046
1047 (defun parse-x11-font-name (font-name)
1048 ;; fndry-family-weight-slant-swidth-style-pixelsz-pointsz-resx-resy-spc-avgwidth-registry-encoding
1049 (setq font-name (remove (code-char 0) font-name))
1050 (let ((atts (cdr (css::split-by #\- font-name :nuke-empty-p nil))))
1051 (let* ((foundry (nth 0 atts))
1052 (family (nth 1 atts))
1053 (weight (parse-x11-font-weight (nth 2 atts)))
1054 (slant (parse-x11-font-slant (nth 3 atts)))
1055 (size (parse-x11-font-size (nth 7 atts) (nth 9 atts)))
1056 (registry (nth 12 atts))
1057 (encoding (nth 13 atts))
1058 (charset (charset-name-from-partial-x11-font-name foundry family registry encoding)) )
1059 (cond ((and weight slant size (ws/charset:find-charset charset))
1060 (r2::make-font-desc :family family
1061 :weight weight
1062 :style slant
1063 :size size
1064 :ddp font-name
1065 :charset (ws/charset:find-charset charset)))
1066 (t
1067 nil)))))
1068
1069
1070 #+NEW-CLX
1071 (let ((old-open-font (symbol-function 'xlib:open-font)))
1072 (defun xlib:open-font (display name)
1073 (maphash (lambda (key value)
1074 (when (and (xlib:font-p value)
1075 (string-equal (xlib:font-name value) name))
1076 (return-from xlib:open-font value)))
1077 (slot-value display 'xlib::hash-table))
1078 (funcall old-open-font display name)))
1079
1080 (defstruct (x11-font-name
1081 (:constructor make-x11-font-name*
1082 (fndry family weight slant swidth style
1083 pixelsz pointsz resx resy spc avgwidth
1084 registry encoding)))
1085 fndry
1086 family
1087 weight
1088 slant
1089 swidth
1090 style
1091 pixelsz
1092 pointsz
1093 resx
1094 resy
1095 spc
1096 avgwidth
1097 registry
1098 encoding)
1099
1100 (defun x11-font-name/scalable-p (font-name)
1101 (and (string= (x11-font-name-pixelsz font-name) "0")
1102 (string= (x11-font-name-pointsz font-name) "0")
1103 (string= (x11-font-name-avgwidth font-name) "0")))
1104
1105 (defun font-name-component-match-p (s1 s2)
1106 (or (eq s1 :wild) (eq s2 :wild) (string-equal s1 s2)))
1107
1108 (defun x11-font-names-match-p (fn1 fn2)
1109 (and (font-name-component-match-p (x11-font-name-fndry fn1) (x11-font-name-fndry fn2))
1110 (font-name-component-match-p (x11-font-name-family fn1) (x11-font-name-family fn2))
1111 (font-name-component-match-p (x11-font-name-weight fn1) (x11-font-name-weight fn2))
1112 (font-name-component-match-p (x11-font-name-slant fn1) (x11-font-name-slant fn2))
1113 (font-name-component-match-p (x11-font-name-swidth fn1) (x11-font-name-swidth fn2))
1114 (font-name-component-match-p (x11-font-name-style fn1) (x11-font-name-style fn2))
1115 (font-name-component-match-p (x11-font-name-pixelsz fn1) (x11-font-name-pixelsz fn2))
1116 (font-name-component-match-p (x11-font-name-pointsz fn1) (x11-font-name-pointsz fn2))
1117 (font-name-component-match-p (x11-font-name-resx fn1) (x11-font-name-resx fn2))
1118 (font-name-component-match-p (x11-font-name-resy fn1) (x11-font-name-resy fn2))
1119 (font-name-component-match-p (x11-font-name-spc fn1) (x11-font-name-spc fn2))
1120 (font-name-component-match-p (x11-font-name-avgwidth fn1) (x11-font-name-avgwidth fn2))
1121 (font-name-component-match-p (x11-font-name-registry fn1) (x11-font-name-registry fn2))
1122 (font-name-component-match-p (x11-font-name-encoding fn1) (x11-font-name-encoding fn2))))
1123
1124 (defun parse-x11-font-name/2 (font-name)
1125 (setq font-name (remove (code-char 0) font-name))
1126 (let ((atts (cdr (split-by #\- font-name :nuke-empty-p nil))))
1127 (apply #'make-x11-font-name* atts)))
1128
1129 (defun font-really-scalable-p (font all-fonts)
1130 (and (x11-font-name/scalable-p font)
1131 (let ((font* (copy-x11-font-name font)))
1132 (setf (x11-font-name-pixelsz font*) :wild
1133 (x11-font-name-pointsz font*) :wild
1134 (x11-font-name-avgwidth font*) :wild)
1135 (<= (count-if (lambda (x)
1136 (and (x11-font-names-match-p x font*)
1137 (not (x11-font-name/scalable-p x))))
1138 all-fonts)
1139 1))))
1140
1141 (defun tailor-font-list (font-list)
1142 (setq font-list (mapcar #'parse-x11-font-name/2 font-list))
1143 (mapcar #'unparse-font-name
1144 (remove-if-not (lambda (x)
1145 (if (not (x11-font-name/scalable-p x))
1146 t
1147 (let ((really? (font-really-scalable-p x font-list)))
1148 (if really?
1149 t
1150 (progn
1151 ;; (warn "Unscaling ~A." (unparse-font-name x))
1152 nil)))))
1153 font-list)))
1154
1155 (defun unparse-font-name (fn)
1156 (format nil "-~A-~A-~A-~A-~A-~A-~A-~A-~A-~A-~A-~A-~A-~A"
1157 (x11-font-name-fndry fn)
1158 (x11-font-name-family fn)
1159 (x11-font-name-weight fn)
1160 (x11-font-name-slant fn)
1161 (x11-font-name-swidth fn)
1162 (x11-font-name-style fn)
1163 (x11-font-name-pixelsz fn)
1164 (x11-font-name-pointsz fn)
1165 (x11-font-name-resx fn)
1166 (x11-font-name-resy fn)
1167 (x11-font-name-spc fn)
1168 (x11-font-name-avgwidth fn)
1169 (x11-font-name-registry fn)
1170 (x11-font-name-encoding fn)))
1171
1172
1173 ;;;
1174
1175 (defun fill-rectangle* (window gcontext x y width height color)
1176 (xlib:with-gcontext (gcontext :foreground (ws/x11::x11-find-color window color))
1177 (xlib:draw-rectangle window gcontext x y width height t)))
1178
1179 (defun fill-rectangle* (window gcontext x y width height color)
1180 "Fills a rectangle; `color' should be string as for FIND-COLOR."
1181 ;; I coded a first attempt to dither these rectangles, if appropriate.
1182 ;; This is a hack of course, we should better preallocate the needed
1183 ;; stipples and should not call the pixel translator. But I am too lazy
1184 ;; to modify the pixel translator generation code above to
1185 ;; generate code to setup stipple's for filling operations.
1186 (let* ((c (color->24-bit color))
1187 (tr (pixel-translator (xlib:window-colormap window)))
1188 (c0 )
1189 (c1 )
1190 (px (xlib:create-pixmap :drawable window
1191 :width 8 :height 8
1192 :depth 1))
1193 (gc1 (xlib:create-gcontext :drawable px :foreground 1))
1194 (gc0 (xlib:create-gcontext :drawable px :foreground 0)))
1195 (setf c0 (funcall tr 0 0 c))
1196 (dotimes (i 8)
1197 (dotimes (j 8)
1198 (let ((d (funcall tr i j c)))
1199 (cond ((/= d c0)
1200 (setf c1 d)
1201 (xlib:draw-point px gc1 i j))
1202 (t
1203 (xlib:draw-point px gc0 i j))))))
1204 (xlib:free-gcontext gc0)
1205 (xlib:free-gcontext gc1)
1206 (setf c1 (or c1 c0))
1207 (xlib:with-gcontext (gcontext :foreground c1
1208 :background c0
1209 :fill-style :opaque-stippled
1210 :stipple px)
1211 (xlib:draw-rectangle window gcontext x y width height t))
1212 (xlib:free-pixmap px)))
1213
1214
1215
1216
1217 ;;;;
1218
1219 #||
1220 (defun foo (display &aux font-list)
1221 (setf font-list
1222 (xlib:list-font-names display "-*-*-*-*-*-*-*-*-*-*-*-*-*-*"))
1223 (setq font-list (mapcar #'parse-x11-font-name/2 font-list))
1224 (remove-if-not (lambda (x)
1225 (if (not (x11-font-name/scalable-p x))
1226 t
1227 (let ((really? (font-really-scalable-p x font-list)))
1228 (if really?
1229 t
1230 (progn
1231 (warn "Unscaling ~A." (unparse-font-name x))
1232 nil)))))
1233 font-list))
1234
1235 (defun font-name-real-size (fn)
1236 (cond ((equal "0" (x11-font-name-pointsz fn))
1237 :scalable)
1238 (t
1239 (/ (* (parse-integer (x11-font-name-pointsz fn))
1240 (parse-integer (x11-font-name-resy fn))) 720))))
1241
1242 ||#
1243
1244 (defun fill-rectangle* (window gcontext x y width height color)
1245 "Fills a rectangle; `color' should be string as for FIND-COLOR."
1246 ;; I coded a first attempt to dither these rectangles, if appropriate.
1247 ;; This is a hack of course, we should better preallocate the needed
1248 ;; stipples and should not call the pixel translator. But I am too lazy
1249 ;; to modify the pixel translator generation code above to
1250 ;; generate code to setup stipple's for filling operations.
1251 (let* ((c (color->24-bit color))
1252 (tr (pixel-translator (xlib:window-colormap window)))
1253 (px (xlib:create-pixmap :drawable window
1254 :width 8 :height 8
1255 :depth (xlib:drawable-depth window)))
1256 (gc (xlib:create-gcontext :drawable px)))
1257 (dotimes (i 8)
1258 (dotimes (j 8)
1259 (let ((d (funcall tr i j c)))
1260 (setf (xlib:gcontext-foreground gc) d)
1261 (xlib:draw-point px gc i j))))
1262 (xlib:free-gcontext gc)
1263 (xlib:with-gcontext (gcontext :fill-style :tiled
1264 :tile px)
1265 (xlib:draw-rectangle window gcontext x y width height t))
1266 (xlib:free-pixmap px)))
1267
1268 (defun fill-polygon* (window gcontext point-seq color)
1269 (let* ((c (color->24-bit color))
1270 (tr (pixel-translator (xlib:window-colormap window)))
1271 (px (xlib:create-pixmap :drawable window
1272 :width 8 :height 8
1273 :depth (xlib:drawable-depth window)))
1274 (gc (xlib:create-gcontext :drawable px)))
1275 (dotimes (i 8)
1276 (dotimes (j 8)
1277 (let ((d (funcall tr i j c)))
1278 (setf (xlib:gcontext-foreground gc) d)
1279 (xlib:draw-point px gc i j))))
1280 (xlib:free-gcontext gc)
1281 (xlib:with-gcontext (gcontext :fill-style :tiled
1282 :tile px)
1283 (xlib:draw-lines window gcontext point-seq :fill-p t))
1284 (xlib:free-pixmap px)))
1285
1286 (defun compose-rgba (r g b &optional (a 0))
1287 (dpb r (byte 8 0)
1288 (dpb g (byte 8 8)
1289 (dpb b (byte 8 16)
1290 (dpb a (byte 8 24)
1291 0)))))
1292
1293 ;; This finally bases the color convertion on the above translator
1294 ;; code. Which is the best thing, we can do in a PseudoColor
1295 ;; environment.
1296
1297
1298 (defun parse-x11-color (string &aux sym r gb)
1299 ;; ### pff this really needs to be more robust.
1300 (cond ((and (= (length string) 4) (char= (char string 0) #\#))
1301 (clim:make-rgb-color
1302 (/ (parse-integer string :start 1 :end 2 :radix 16) #xF)
1303 (/ (parse-integer string :start 2 :end 3 :radix 16) #xF)
1304 (/ (parse-integer string :start 3 :end 4 :radix 16) #xF)))
1305 ((and (= (length string) 7) (char= (char string 0) #\#))
1306 (clim:make-rgb-color
1307 (/ (parse-integer string :start 1 :end 3 :radix 16) #xFF)
1308 (/ (parse-integer string :start 3 :end 5 :radix 16) #xFF)
1309 (/ (parse-integer string :start 5 :end 7 :radix 16) #xFF)))
1310 ((and (= (length string) 6) (every #'(lambda (x) (digit-char-p x 16)) string))
1311 (let ((r (parse-integer (subseq string 0 2) :radix 16))
1312 (g (parse-integer (subseq string 2 4) :radix 16))
1313 (b (parse-integer (subseq string 4 6) :radix 16)))
1314 (warn "Malformed color specifier: ~S" string)
1315 (and r g b
1316 (clim:make-rgb-color (/ r 255) (/ g 255) (/ b 255)))))
1317 ((and (= (length string) 13) (char= (char string 0) #\#))
1318 (clim:make-rgb-color
1319 (/ (parse-integer string :start 1 :end 5 :radix 16) #xFFFF)
1320 (/ (parse-integer string :start 5 :end 9 :radix 16) #xFFFF)
1321 (/ (parse-integer string :start 9 :end 13 :radix 16) #xFFFF)))
1322 ((and (setf sym (find-symbol (concatenate 'string "+" (string-upcase string) "+")
1323 (find-package :clim)))
1324 (boundp sym)
1325 (clim:colorp (symbol-value sym)))
1326 (symbol-value sym))
1327 (t
1328 (warn "Malformed color specifier: ~S" string)
1329 clim:+red+)))
1330
1331
1332 ; LocalWords: colormap RGB
HTML parser written in Common Lisp