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