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