1ed0a2c5 |
1 | ;; This file contains the cairo C snippets translated to lisp |
2 | ;; See http://cairographics.org/samples/ |
3 | |
4 | #+sbcl(require :gtk) |
1ed0a2c5 |
5 | #+sbcl(require :cairo) |
f86d1eb7 |
6 | #+(or cmu clisp)(asdf:oos 'asdf:load-op :gtk) |
7 | #+(or cmu clisp)(asdf:oos 'asdf:load-op :cairo) |
c4f672a3 |
8 | |
9 | (eval-when (:compile-toplevel :load-toplevel :execute) |
f86d1eb7 |
10 | (unless (pkg-config:pkg-exists-p "librsvg-2.0" :atleast-version "2.13.93") |
c4f672a3 |
11 | (warn "SVG tests disabled as the required version of librsvg is not available."))) |
12 | |
f86d1eb7 |
13 | #?(pkg-config:pkg-exists-p "librsvg-2.0" :atleast-version "2.13.93") |
14 | #+sbcl(require :rsvg) |
15 | #+(or cmu clisp)(asdf:oos 'asdf:load-op :rsvg) |
1ed0a2c5 |
16 | |
17 | (defpackage "TESTCAIRO" |
18 | (:use "COMMON-LISP" "GTK") |
19 | (:export "CREATE-TESTS")) |
20 | |
21 | (in-package "TESTCAIRO") |
22 | |
23 | (declaim (inline deg-to-rad)) |
24 | (defun deg-to-rad (deg) |
25 | (* deg (/ pi 180))) |
26 | |
27 | (declaim (inline rad-to-deg)) |
28 | (defun rad-to-deg (rad) |
29 | (/ (* rad 180) pi)) |
30 | |
31 | |
32 | (defvar *snippets* ()) |
33 | |
34 | |
35 | (defmacro define-snippet (name (cr) &body body) |
36 | (let ((widget (make-symbol "WIDGET")) |
37 | (window (make-symbol "WINDOW")) |
57c6905f |
38 | (event (make-symbol "EVENT"))) |
1ed0a2c5 |
39 | `(let ((,window nil)) |
890d2504 |
40 | (pushnew ',name *snippets*) |
1ed0a2c5 |
41 | (defun ,name () |
42 | (if (not ,window) |
43 | (let ((,widget (make-instance 'drawing-area))) |
44 | (setq ,window |
45 | (make-instance 'window |
46 | :width-request 300 :height-request 300 |
47 | :title ,(string-downcase name) |
48 | :visible t :child ,widget)) |
49 | (signal-connect ,window 'destroy |
50 | #'(lambda () (setq ,window nil))) |
51 | (signal-connect ,widget 'expose-event |
57c6905f |
52 | #'(lambda (,event) |
53 | (declare (ignore ,event)) |
df2a8909 |
54 | (gdk:with-cairo-context (,cr (widget-window ,widget)) |
1ed0a2c5 |
55 | (multiple-value-bind (width height) |
56 | (widget-get-size-allocation ,widget) |
57 | (cairo:scale ,cr width height)) |
58 | (setf (cairo:line-width ,cr) 0.04) |
59 | ,@body))) |
60 | (widget-show-all ,window)) |
61 | (widget-destroy ,window)))))) |
62 | |
63 | |
64 | |
65 | |
66 | (defun arc-helper-lines (cr xc yc radius angle1 angle2) |
67 | (cairo:set-source-color cr 1 0.2 0.2 0.6) |
68 | (cairo:arc cr xc yc 0.05 0 (deg-to-rad 360)) |
69 | (cairo:fill cr) |
70 | (setf (cairo:line-width cr) 0.03) |
71 | (cairo:move-to cr xc yc) |
72 | (cairo:rel-line-to cr (* radius (cos angle1)) (* radius (sin angle1))) |
73 | (cairo:stroke cr) |
74 | (cairo:move-to cr xc yc) |
75 | (cairo:rel-line-to cr (* radius (cos angle2)) (* radius (sin angle2))) |
76 | (cairo:stroke cr)) |
77 | |
78 | (define-snippet arc (cr) |
79 | (let ((xc 0.5) |
80 | (yc 0.5) |
81 | (radius 0.4) |
82 | (angle1 (deg-to-rad 45.0)) |
83 | (angle2 (deg-to-rad 180.0))) |
84 | |
85 | (cairo:with-context (cr) |
86 | (setf (cairo:line-cap cr) :round) |
87 | (cairo:arc cr xc yc radius angle1 angle2) |
88 | (cairo:stroke cr)) |
89 | |
90 | (arc-helper-lines cr xc yc radius angle1 angle2))) |
91 | |
92 | (define-snippet arc-negative (cr) |
93 | (let ((xc 0.5) |
94 | (yc 0.5) |
95 | (radius 0.4) |
96 | (angle1 (deg-to-rad 45.0)) |
97 | (angle2 (deg-to-rad 180.0))) |
98 | |
99 | (cairo:with-context (cr) |
100 | (setf (cairo:line-cap cr) :round) |
101 | (cairo:arc-negative cr xc yc radius angle1 angle2) |
102 | (cairo:stroke cr)) |
103 | |
104 | (arc-helper-lines cr xc yc radius angle1 angle2))) |
105 | |
106 | |
107 | (define-snippet clip (cr) |
108 | (cairo:circle cr 0.5 0.5 0.3) |
109 | (cairo:clip cr) |
110 | |
111 | (cairo:new-path cr) ; current path is not consumed by cairo:clip |
112 | (cairo:rectangle cr 0 0 1 1) |
113 | (cairo:fill cr) |
114 | (cairo:set-source-color cr 0 1 0) |
115 | (cairo:move-to cr 0 0) |
116 | (cairo:line-to cr 1 1) |
117 | (cairo:move-to cr 1 0) |
118 | (cairo:line-to cr 0 1) |
119 | (cairo:stroke cr)) |
120 | |
121 | |
122 | (define-snippet clip-image (cr) |
123 | (cairo:circle cr 0.5 0.5 0.3) |
124 | (cairo:clip cr) |
125 | (cairo:new-path cr) |
126 | |
127 | (let ((image (cairo:image-surface-create-from-png |
128 | #p"clg:examples;romedalen.png"))) |
129 | |
130 | (let ((width (cairo:surface-width image)) |
131 | (height (cairo:surface-height image))) |
132 | (cairo:scale cr (/ 1.0 width) (/ 1.0 height))) |
133 | |
134 | (cairo:set-source-surface cr image 0 0) |
135 | (cairo:paint cr))) |
136 | |
137 | (define-snippet clip-rectangle (cr) |
138 | (cairo:new-path cr) |
139 | (cairo:move-to cr 0.25 0.25) |
140 | (cairo:line-to cr 0.25 0.75) |
141 | (cairo:line-to cr 0.75 0.75) |
142 | (cairo:line-to cr 0.75 0.25) |
143 | (cairo:line-to cr 0.25 0.25) |
144 | (cairo:close-path cr) |
145 | |
146 | (cairo:clip cr) |
147 | |
148 | (cairo:move-to cr 0 0) |
149 | (cairo:line-to cr 1 1) |
150 | (cairo:stroke cr)) |
151 | |
152 | |
f86d1eb7 |
153 | (defun %curve-rectangle (cr x0 y0 width height radius) |
154 | (unless (and (zerop width) (zerop height)) |
155 | (let ((x1 (+ x0 width)) |
156 | (y1 (+ y0 height))) |
157 | (cond |
158 | ((and (< (* 0.5 width) radius) (< (* 0.5 height) radius)) |
159 | (cairo:move-to cr x0 (* 0.5 (+ y0 y1))) |
160 | (cairo:curve-to cr x0 y0 x0 y0 (* 0.5 (+ x0 x1)) y0) |
161 | (cairo:curve-to cr x1 y0 x1 y0 x1 (* 0.5 (+ y0 y1))) |
162 | (cairo:curve-to cr x1 y1 x1 y1 (* 0.5 (+ x0 x1)) y1) |
163 | (cairo:curve-to cr x0 y1 x0 y1 x0 (* 0.5 (+ y0 y1)))) |
164 | ((< (* 0.5 width) radius) |
165 | (cairo:move-to cr x0 (+ y0 radius)) |
166 | (cairo:curve-to cr x0 y0 x0 y0 (* 0.5 (+ x0 x1)) y0) |
167 | (cairo:curve-to cr x1 y0 x1 y0 x1 (+ y0 radius)) |
168 | (cairo:line-to cr x1 (- y1 radius)) |
169 | (cairo:curve-to cr x1 y1 x1 y1 (* 0.5 (+ x0 x1)) y1) |
170 | (cairo:curve-to cr x0 y1 x0 y1 x0 (- y1 radius))) |
171 | ((< (* 0.5 height) radius) |
172 | (cairo:move-to cr x0 (* 0.5 (+ y0 y1))) |
173 | (cairo:curve-to cr x0 y0 x0 y0 (+ x0 radius) y0) |
174 | (cairo:line-to cr (- x1 radius) y0) |
175 | (cairo:curve-to cr x1 y0 x1 y0 x1 (* 0.5 (+ y0 y1))) |
176 | (cairo:curve-to cr x1 y1 x1 y1 (- x1 radius) y1) |
177 | (cairo:line-to cr (+ x0 radius) y1) |
178 | (cairo:curve-to cr x0 y1 x0 y1 x0 (* 0.5 (+ y0 y1)))) |
179 | (t |
180 | (cairo:move-to cr x0 (+ y0 radius)) |
181 | (cairo:curve-to cr x0 y0 x0 y0 (+ x0 radius) y0) |
182 | (cairo:line-to cr (- x1 radius) y0) |
183 | (cairo:curve-to cr x1 y0 x1 y0 x1 (+ y0 radius)) |
184 | (cairo:line-to cr x1 (- y1 radius)) |
185 | (cairo:curve-to cr x1 y1 x1 y1 (- x1 radius) y1) |
186 | (cairo:line-to cr (+ x0 radius) y1) |
187 | (cairo:curve-to cr x0 y1 x0 y1 x0 (- y1 radius)))) |
188 | (cairo:close-path cr)))) |
189 | |
890d2504 |
190 | (define-snippet curve-rectangle (cr) |
191 | (let ((x0 0.1) |
192 | (y0 0.1) |
193 | (width 0.8) |
194 | (height 0.8) |
195 | (radius 0.4)) |
f86d1eb7 |
196 | (%curve-rectangle cr x0 y0 width height radius) |
197 | (cairo:set-source-color cr 0.5 0.5 1.0) |
198 | (cairo:fill cr t) |
199 | (cairo:set-source-color cr 0.5 0.0 0.0 0.5) |
200 | (cairo:stroke cr))) |
1ed0a2c5 |
201 | |
202 | |
203 | (define-snippet curve-to (cr) |
204 | (let ((x 0.1) (y 0.5) |
205 | (x1 0.4) (y1 0.9) |
206 | (x2 0.6) (y2 0.1) |
207 | (x3 0.9) (y3 0.5)) |
208 | |
209 | (cairo:move-to cr x y) |
210 | (cairo:curve-to cr x1 y1 x2 y2 x3 y3) |
211 | |
212 | (cairo:stroke cr) |
213 | |
214 | (cairo:set-source-color cr 1 0.2 0.2 0.6) |
215 | (setf (cairo:line-width cr) 0.03) |
216 | (cairo:move-to cr x y) |
217 | (cairo:line-to cr x1 y1) |
218 | (cairo:move-to cr x2 y2) |
219 | (cairo:line-to cr x3 y3) |
220 | (cairo:stroke cr))) |
221 | |
222 | |
223 | (define-snippet dash (cr) |
224 | (let ((dashes #(0.20 0.05 0.05 0.05)) |
225 | (offset -0.2)) |
226 | (cairo:set-dash cr dashes offset) |
227 | (cairo:move-to cr 0.5 0.1) |
228 | (cairo:line-to cr 0.9 0.9) |
229 | (cairo:rel-line-to cr -0.4 0.0) |
230 | (cairo:curve-to cr 0.2 0.9 0.2 0.5 0.5 0.5) |
231 | (cairo:stroke cr))) |
232 | |
233 | |
234 | (defun fill-and-stroke-common (cr) |
235 | (cairo:move-to cr 0.5 0.1) |
236 | (cairo:line-to cr 0.9 0.9) |
237 | (cairo:rel-line-to cr -0.4 0.0) |
238 | (cairo:curve-to cr 0.2 0.9 0.2 0.5 0.5 0.5) |
239 | (cairo:close-path cr)) |
240 | |
241 | |
242 | (define-snippet fill-and-stroke2 (cr) |
243 | (fill-and-stroke-common cr) |
244 | (cairo:move-to cr 0.25 0.1) |
245 | (cairo:rel-line-to cr 0.2 0.2) |
246 | (cairo:rel-line-to cr -0.2 0.2) |
247 | (cairo:rel-line-to cr -0.2 -0.2) |
248 | (cairo:close-path cr) |
249 | |
250 | (cairo:set-source-color cr 0 0 1) |
251 | (cairo:fill cr t) |
252 | (cairo:set-source-color cr 0 0 0) |
253 | (cairo:stroke cr)) |
254 | |
255 | |
256 | (define-snippet fill-and-stroke (cr) |
257 | (fill-and-stroke-common cr) |
258 | |
259 | (cairo:set-source-color cr 0 0 1) |
260 | (cairo:fill cr t) |
261 | (cairo:set-source-color cr 0 0 0) |
262 | (cairo:stroke cr)) |
263 | |
264 | |
265 | (define-snippet gradient (cr) |
266 | (let ((pattern (cairo:pattern-create-linear 0.0 0.0 0.0 1.0))) |
267 | (cairo:pattern-add-color-stop pattern 1 0 0 0 1) |
268 | (cairo:pattern-add-color-stop pattern 0 1 1 1 1) |
269 | (cairo:rectangle cr 0 0 1 1) |
270 | (setf (cairo:source cr) pattern) |
271 | (cairo:fill cr)) |
272 | (let ((pattern (cairo:pattern-create-radial 0.45 0.4 0.1 0.4 0.4 0.5))) |
273 | (cairo:pattern-add-color-stop pattern 0 1 1 1 1) |
274 | (cairo:pattern-add-color-stop pattern 1 0 0 0 1) |
275 | (setf (cairo:source cr) pattern) |
276 | (cairo:circle cr 0.5 0.5 0.3) |
277 | (cairo:fill cr))) |
278 | |
279 | |
280 | (define-snippet image (cr) |
281 | (let ((image (cairo:image-surface-create-from-png |
282 | #p"clg:examples;romedalen.png"))) |
283 | (cairo:translate cr 0.5 0.5) |
284 | (cairo:rotate cr (deg-to-rad 45)) |
285 | (let ((width (cairo:surface-width image)) |
286 | (height (cairo:surface-height image))) |
287 | (cairo:scale cr (/ 1.0 width) (/ 1.0 height)) |
288 | (cairo:translate cr (* -0.5 width) (* -0.5 height))) |
289 | (cairo:set-source-surface cr image 0 0) |
290 | (cairo:paint cr))) |
291 | |
292 | |
293 | (define-snippet image-pattern (cr) |
294 | (let* ((image (cairo:image-surface-create-from-png |
295 | #p"clg:examples;romedalen.png")) |
296 | (pattern (cairo:pattern-create-for-surface image))) |
297 | (setf (cairo:pattern-extend pattern) :repeat) |
298 | (cairo:translate cr 0.5 0.5) |
299 | (cairo:rotate cr (deg-to-rad 45)) |
300 | (cairo:scale cr (/ 1.0 (sqrt 2)) (/ 1.0 (sqrt 2))) |
301 | (cairo:translate cr -0.5 -0.5) |
302 | (let ((width (cairo:surface-width image)) |
303 | (height (cairo:surface-height image)) |
304 | (matrix (make-instance 'cairo:matrix))) |
305 | (cairo:matrix-init-scale matrix (* 5 width) (* 5 height)) |
306 | (setf (cairo:pattern-matrix pattern) matrix)) |
307 | (setf (cairo:source cr) pattern) |
308 | (cairo:rectangle cr 0.0 0.0 1.0 1.0) |
309 | (cairo:fill cr))) |
310 | |
311 | |
f86d1eb7 |
312 | #?(pkg-config:pkg-exists-p "librsvg-2.0" :atleast-version "2.13.93") |
313 | (progn |
890d2504 |
314 | (defun snippet-set-bg-svg (cr filename) |
315 | (let ((handle (make-instance 'rsvg:handle :filename filename))) |
316 | (cairo:with-context (cr) |
9fdca80d |
317 | (with-slots (rsvg:width rsvg:height) handle |
c4f672a3 |
318 | (cairo:scale cr (/ 1.0 rsvg:width) (/ 1.0 rsvg:height)) |
9fdca80d |
319 | (rsvg:render-cairo handle cr))))) |
890d2504 |
320 | |
321 | (define-snippet librsvg (cr) |
322 | (snippet-set-bg-svg cr "clg:examples;home.svg")) |
323 | |
324 | |
325 | (defmacro define-operator-snippet (name operator) |
326 | `(define-snippet ,name (cr) |
327 | (snippet-set-bg-svg cr "clg:examples;freedesktop.svg") |
328 | (setf (cairo:operator cr) ,operator) |
329 | |
330 | (cairo:set-source-color cr 1.0 0.0 0.0 0.5) |
331 | (cairo:rectangle cr 0.2 0.2 0.5 0.5) |
332 | (cairo:fill cr) |
333 | |
334 | (cairo:set-source-color cr 0.0 1.0 0.0) |
335 | (cairo:rectangle cr 0.4 0.4 0.4 0.4) |
336 | (cairo:fill cr) |
c4f672a3 |
337 | |
890d2504 |
338 | (cairo:set-source-color cr 0.0 0.0 1.0) |
339 | (cairo:rectangle cr 0.6 0.6 0.3 0.3) |
340 | (cairo:fill cr))) |
341 | |
342 | (define-operator-snippet operator-add :add) |
343 | (define-operator-snippet operator-atop :atop) |
344 | (define-operator-snippet operator-atop-reverse :dest-atop) |
345 | (define-operator-snippet operator-in :in) |
346 | (define-operator-snippet operator-in-reverse :dest-in) |
347 | (define-operator-snippet operator-out :out) |
348 | (define-operator-snippet operator-out-reverse :dest-out) |
349 | (define-operator-snippet operator-over :over) |
350 | (define-operator-snippet operator-over-reverse :dest-over) |
351 | (define-operator-snippet operator-saturate :saturate) |
352 | (define-operator-snippet operator-xor :xor) |
c4f672a3 |
353 | ) |
1ed0a2c5 |
354 | |
355 | |
356 | |
357 | (define-snippet path (cr) |
358 | (cairo:move-to cr 0.5 0.1) |
359 | (cairo:line-to cr 0.9 0.9) |
360 | (cairo:rel-line-to cr -0.4 0.0) |
361 | (cairo:curve-to cr 0.2 0.9 0.2 0.5 0.5 0.5) |
362 | (cairo:stroke cr)) |
363 | |
364 | |
1ed0a2c5 |
365 | (define-snippet set-line-cap (cr) |
366 | (setf (cairo:line-width cr) 0.12) |
367 | (setf (cairo:line-cap cr) :butt) |
368 | (cairo:move-to cr 0.25 0.2) |
369 | (cairo:line-to cr 0.25 0.8) |
370 | (cairo:stroke cr) |
371 | (setf (cairo:line-cap cr) :round) |
372 | (cairo:move-to cr 0.5 0.2) |
373 | (cairo:line-to cr 0.5 0.8) |
374 | (cairo:stroke cr) |
375 | (setf (cairo:line-cap cr) :square) |
376 | (cairo:move-to cr 0.75 0.2) |
377 | (cairo:line-to cr 0.75 0.8) |
378 | (cairo:stroke cr) |
379 | |
380 | ;; draw helping lines |
381 | (cairo:set-source-color cr 1 0.2 0.2) |
382 | (setf (cairo:line-width cr) 0.01) |
383 | (cairo:move-to cr 0.25 0.2) |
384 | (cairo:line-to cr 0.25 0.8) |
385 | (cairo:move-to cr 0.5 0.2) |
386 | (cairo:line-to cr 0.5 0.8) |
387 | (cairo:move-to cr 0.75 0.2) |
388 | (cairo:line-to cr 0.75 0.8) |
389 | (cairo:stroke cr)) |
390 | |
391 | |
392 | (define-snippet set-line-join (cr) |
393 | (setf (cairo:line-width cr) 0.16) |
394 | (cairo:move-to cr 0.3 0.33) |
395 | (cairo:rel-line-to cr 0.2 -0.2) |
396 | (cairo:rel-line-to cr 0.2 0.2) |
397 | (setf (cairo:line-join cr) :miter) ; default |
398 | (cairo:stroke cr) |
399 | |
400 | (cairo:move-to cr 0.3 0.63) |
401 | (cairo:rel-line-to cr 0.2 -0.2) |
402 | (cairo:rel-line-to cr 0.2 0.2) |
403 | (setf (cairo:line-join cr) :bevel) |
404 | (cairo:stroke cr) |
405 | |
406 | (cairo:move-to cr 0.3 0.93) |
407 | (cairo:rel-line-to cr 0.2 -0.2) |
408 | (cairo:rel-line-to cr 0.2 0.2) |
409 | (setf (cairo:line-join cr) :round) |
410 | (cairo:stroke cr)) |
411 | |
412 | |
413 | |
414 | (define-snippet text (cr) |
415 | (cairo:select-font-face cr "Sans" :normal :bold) |
416 | ;; ;(setf (cairo:font-size cr) 0.35) |
417 | (cairo:set-font-size cr 0.35) |
418 | |
419 | (cairo:move-to cr 0.04 0.53) |
420 | (cairo:show-text cr "Hello") |
421 | |
422 | (cairo:move-to cr 0.27 0.65) |
423 | (cairo:text-path cr "void") |
424 | (cairo:set-source-color cr 0.5 0.5 1) |
425 | (cairo:fill cr t) |
426 | |
427 | (cairo:set-source-color cr 0 0 0) |
428 | (setf (cairo:line-width cr) 0.01) |
429 | (cairo:stroke cr) |
430 | |
431 | ;; draw helping lines |
432 | (cairo:set-source-color cr 1 0.2 0.2 0.6) |
433 | (cairo:arc cr 0.04 0.53 0.02 0 (deg-to-rad 360)) |
434 | (cairo:arc cr 0.27 0.65 0.02 0 (deg-to-rad 360)) |
435 | (cairo:fill cr)) |
436 | |
437 | |
438 | (define-snippet text-align-center (cr) |
439 | (let ((text "cairo")) |
440 | (cairo:select-font-face cr "Sans" :normal :normal) |
441 | (cairo:set-font-size cr 0.2) |
442 | |
443 | (let* ((extents (cairo:text-extents cr text)) |
444 | (x (- 0.5 (+ (/ (cairo:text-extents-width extents) 2) (cairo:text-extents-x-bearing extents)))) |
445 | (y (- 0.5 (+ (/ (cairo:text-extents-height extents) 2) (cairo:text-extents-y-bearing extents))))) |
446 | (cairo:move-to cr x y) |
447 | (cairo:show-text cr text) |
448 | |
449 | ;; draw helping lines |
450 | (cairo:set-source-color cr 1.0 0.2 0.2 0.6) |
451 | (cairo:circle cr x y 0.05) |
452 | (cairo:fill cr) |
453 | (cairo:move-to cr 0.5 0.0) |
454 | (cairo:rel-line-to cr 0.0 1.0) |
455 | (cairo:move-to cr 0.0 0.5) |
456 | (cairo:rel-line-to cr 1.0 0.0) |
457 | (cairo:stroke cr)))) |
458 | |
459 | (define-snippet text-extents (cr) |
460 | (let ((text "cairo")) |
461 | (cairo:select-font-face cr "Sans" :normal :normal) |
462 | (cairo:set-font-size cr 0.4) |
463 | |
464 | (let* ((extents (cairo:text-extents cr text)) |
465 | (x 0.1) |
466 | (y 0.6)) |
467 | (cairo:move-to cr x y) |
468 | (cairo:show-text cr text) |
469 | |
470 | ;; draw helping lines |
471 | (cairo:set-source-color cr 1.0 0.2 0.2 0.6) |
472 | (cairo:circle cr x y 0.05) |
473 | (cairo:fill cr) |
474 | (cairo:move-to cr x y) |
475 | (cairo:rel-line-to cr 0 (- (cairo:text-extents-height extents))) |
476 | (cairo:rel-line-to cr (cairo:text-extents-width extents) 0) |
477 | (cairo:rel-line-to cr |
478 | (cairo:text-extents-x-bearing extents) |
479 | (- (cairo:text-extents-y-bearing extents))) |
480 | (cairo:stroke cr)))) |
481 | |
482 | |
483 | (defun create-tests () |
484 | ;; (rc-parse "clg:examples;testgtkrc2") |
485 | ;; (rc-parse "clg:examples;testgtkrc") |
486 | |
487 | (let* ((main-window (make-instance 'window |
488 | :title "testcairo.lisp" :name "main-window" |
489 | :default-width 200 :default-height 400 |
490 | :allow-grow t :allow-shrink nil)) |
491 | (scrolled-window (make-instance 'scrolled-window |
492 | :hscrollbar-policy :automatic |
493 | :vscrollbar-policy :automatic |
494 | :border-width 10)) |
495 | (close-button (make-instance 'button |
f86d1eb7 |
496 | :stock "gtk-close" :can-default t |
1ed0a2c5 |
497 | :signal (list 'clicked #'widget-destroy |
498 | :object main-window)))) |
499 | |
500 | (let ((icon (gdk:pixbuf-load #p"clg:examples;gtk.png"))) |
501 | (setf |
502 | (window-icon main-window) |
503 | (gdk:pixbuf-add-alpha icon t 254 254 252))) |
504 | |
505 | ;; Main box |
506 | (make-instance 'v-box |
507 | :parent main-window |
508 | :child-args '(:expand nil) |
509 | :child (list (make-instance 'label :label (gtk-version)) :fill nil) |
510 | :child (list (make-instance 'label :label (clg-version)) :fill nil) |
511 | :child (list (make-instance 'label |
f86d1eb7 |
512 | :label #-cmu |
513 | (format nil "~A (~A)" |
514 | (lisp-implementation-type) |
515 | #-clisp |
516 | (lisp-implementation-version) |
517 | #+clisp |
518 | (let ((version (lisp-implementation-version))) |
519 | (subseq version 0 (position #\sp version)))) |
1ed0a2c5 |
520 | ;; The version string in CMUCL is far too long |
521 | #+cmu(lisp-implementation-type)) |
522 | :fill nil) |
523 | :child (list scrolled-window :expand t) |
524 | :child (make-instance 'h-separator) |
525 | :child (make-instance 'v-box |
526 | :homogeneous nil :spacing 10 :border-width 10 |
527 | :child close-button)) |
528 | |
529 | (let ((content-box |
530 | (make-instance 'v-box |
531 | :focus-vadjustment (scrolled-window-vadjustment scrolled-window) |
532 | :children (mapcar #'(lambda (snippet) |
533 | (create-button (string-downcase snippet) snippet)) |
890d2504 |
534 | (setq *snippets* (sort *snippets* #'string<)))))) |
1ed0a2c5 |
535 | (scrolled-window-add-with-viewport scrolled-window content-box)) |
536 | |
537 | (widget-grab-focus close-button) |
538 | (widget-show-all main-window) |
539 | main-window)) |
540 | |
541 | |
542 | (clg-init) |
f86d1eb7 |
543 | #?(pkg-config:pkg-exists-p "librsvg-2.0" :atleast-version "2.13.93") |
544 | (rsvg:init) |
890d2504 |
545 | |
546 | ;; We need to turn off floating point exceptions, because Cairo is |
547 | ;; presumably using internal code which generates NaNs in some cases. |
548 | ;; Thanks to Christophe Rhodes for pointing this out. |
549 | #+sbcl(sb-int:set-floating-point-modes :traps nil) |
550 | #+cmu(ext:set-floating-point-modes :traps nil) |
551 | |
552 | (create-tests) |