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) |
c36ffea1 |
10 | (unless (pkg-config:pkg-exists-p "librsvg-2.0" :atleast-version "2.14.0") |
c4f672a3 |
11 | (warn "SVG tests disabled as the required version of librsvg is not available."))) |
12 | |
c36ffea1 |
13 | #?(pkg-config:pkg-exists-p "librsvg-2.0" :atleast-version "2.14.0") |
f86d1eb7 |
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) |
f7f58f90 |
25 | (* deg (/ pi 180.0))) |
1ed0a2c5 |
26 | |
27 | (declaim (inline rad-to-deg)) |
28 | (defun rad-to-deg (rad) |
f7f58f90 |
29 | (/ (* rad 180.0) pi)) |
1ed0a2c5 |
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) |
f7f58f90 |
67 | (cairo:set-source-color cr 1.0 0.2 0.2 0.6) |
68 | (cairo:arc cr xc yc 0.05 0 (deg-to-rad 360.0)) |
1ed0a2c5 |
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) |
f7f58f90 |
114 | (cairo:set-source-color cr 0.0 1.0 0.0) |
115 | (cairo:move-to cr 0.0 0.0) |
116 | (cairo:line-to cr 1.0 1.0) |
117 | (cairo:move-to cr 1.0 0.0) |
118 | (cairo:line-to cr 0.0 1.0) |
1ed0a2c5 |
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 | |
108fea9b |
127 | (let ((image (make-instance 'cairo:image-surface |
128 | :filename #p"clg:examples;romedalen.png"))) |
129 | |
1ed0a2c5 |
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 | |
f7f58f90 |
148 | (cairo:move-to cr 0.0 0.0) |
149 | (cairo:line-to cr 1.0 1.0) |
1ed0a2c5 |
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 | |
f7f58f90 |
214 | (cairo:set-source-color cr 1.0 0.2 0.2 0.6) |
1ed0a2c5 |
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 | |
f7f58f90 |
250 | (cairo:set-source-color cr 0.0 0.0 1.0) |
1ed0a2c5 |
251 | (cairo:fill cr t) |
f7f58f90 |
252 | (cairo:set-source-color cr 0.0 0.0 0.0) |
1ed0a2c5 |
253 | (cairo:stroke cr)) |
254 | |
255 | |
256 | (define-snippet fill-and-stroke (cr) |
257 | (fill-and-stroke-common cr) |
258 | |
f7f58f90 |
259 | (cairo:set-source-color cr 0.0 0.0 1.0) |
1ed0a2c5 |
260 | (cairo:fill cr t) |
f7f58f90 |
261 | (cairo:set-source-color cr 0.0 0.0 0.0) |
1ed0a2c5 |
262 | (cairo:stroke cr)) |
263 | |
264 | |
c1e76b2d |
265 | (define-snippet fill-style (cr) |
266 | (cairo:scale cr (/ 256.0) (/ 256.0)) |
267 | (setf (cairo:line-width cr) 6) |
268 | (cairo:rectangle cr 12 12 232 70) |
269 | (cairo:new-sub-path cr) |
270 | (cairo:arc cr 64 64 40 0 (* 2 pi)) |
271 | (cairo:new-sub-path cr) |
272 | (cairo:arc-negative cr 192 64 40 0 (* -2 pi)) |
273 | |
274 | (setf (cairo:fill-rule cr) :even-odd) |
275 | (cairo:set-source-color cr 0 0.7 0) |
276 | (cairo:fill cr t) |
277 | (cairo:set-source-color cr 0 0 0) |
278 | (cairo:stroke cr) |
279 | |
280 | (cairo:translate cr 0 128) |
281 | (cairo:rectangle cr 12 12 232 70) |
282 | (cairo:new-sub-path cr) |
283 | (cairo:arc cr 64 64 40 0 (* 2 pi)) |
284 | (cairo:new-sub-path cr) |
285 | (cairo:arc-negative cr 192 64 40 0 (* -2 pi)) |
286 | |
287 | (setf (cairo:fill-rule cr) :winding) |
288 | (cairo:set-source-color cr 0 0 0.9) |
289 | (cairo:fill cr t) |
290 | (cairo:set-source-color cr 0 0 0) |
291 | (cairo:stroke cr)) |
292 | |
293 | |
294 | |
1ed0a2c5 |
295 | (define-snippet gradient (cr) |
296 | (let ((pattern (cairo:pattern-create-linear 0.0 0.0 0.0 1.0))) |
f7f58f90 |
297 | (cairo:pattern-add-color-stop pattern 1.0 0.0 0.0 0.0 1.0) |
298 | (cairo:pattern-add-color-stop pattern 0.0 1.0 1.0 1.0 1.0) |
299 | (cairo:rectangle cr 0.0 0.0 1.0 1.0) |
1ed0a2c5 |
300 | (setf (cairo:source cr) pattern) |
301 | (cairo:fill cr)) |
302 | (let ((pattern (cairo:pattern-create-radial 0.45 0.4 0.1 0.4 0.4 0.5))) |
f7f58f90 |
303 | (cairo:pattern-add-color-stop pattern 0.0 1.0 1.0 1.0 1.0) |
304 | (cairo:pattern-add-color-stop pattern 1.0 0.0 0.0 0.0 1.0) |
1ed0a2c5 |
305 | (setf (cairo:source cr) pattern) |
306 | (cairo:circle cr 0.5 0.5 0.3) |
307 | (cairo:fill cr))) |
308 | |
309 | |
310 | (define-snippet image (cr) |
108fea9b |
311 | (let ((image (make-instance 'cairo:image-surface |
312 | :filename #p"clg:examples;romedalen.png"))) |
1ed0a2c5 |
313 | (cairo:translate cr 0.5 0.5) |
f7f58f90 |
314 | (cairo:rotate cr (deg-to-rad 45.0)) |
1ed0a2c5 |
315 | (let ((width (cairo:surface-width image)) |
316 | (height (cairo:surface-height image))) |
c1e76b2d |
317 | (cairo:scale cr (/ 1.0 width) (/ 1.0 height)) |
1ed0a2c5 |
318 | (cairo:translate cr (* -0.5 width) (* -0.5 height))) |
319 | (cairo:set-source-surface cr image 0 0) |
320 | (cairo:paint cr))) |
321 | |
322 | |
323 | (define-snippet image-pattern (cr) |
108fea9b |
324 | (let* ((image (make-instance 'cairo:image-surface |
325 | :filename #p"clg:examples;romedalen.png")) |
1ed0a2c5 |
326 | (pattern (cairo:pattern-create-for-surface image))) |
327 | (setf (cairo:pattern-extend pattern) :repeat) |
328 | (cairo:translate cr 0.5 0.5) |
f7f58f90 |
329 | (cairo:rotate cr (deg-to-rad 45.0)) |
330 | (cairo:scale cr (/ 1.0 (sqrt 2.0)) (/ 1.0 (sqrt 2.0))) |
1ed0a2c5 |
331 | (cairo:translate cr -0.5 -0.5) |
332 | (let ((width (cairo:surface-width image)) |
333 | (height (cairo:surface-height image)) |
334 | (matrix (make-instance 'cairo:matrix))) |
335 | (cairo:matrix-init-scale matrix (* 5 width) (* 5 height)) |
336 | (setf (cairo:pattern-matrix pattern) matrix)) |
337 | (setf (cairo:source cr) pattern) |
338 | (cairo:rectangle cr 0.0 0.0 1.0 1.0) |
339 | (cairo:fill cr))) |
340 | |
341 | |
f86d1eb7 |
342 | #?(pkg-config:pkg-exists-p "librsvg-2.0" :atleast-version "2.13.93") |
343 | (progn |
890d2504 |
344 | (defun snippet-set-bg-svg (cr filename) |
345 | (let ((handle (make-instance 'rsvg:handle :filename filename))) |
346 | (cairo:with-context (cr) |
9fdca80d |
347 | (with-slots (rsvg:width rsvg:height) handle |
c4f672a3 |
348 | (cairo:scale cr (/ 1.0 rsvg:width) (/ 1.0 rsvg:height)) |
9fdca80d |
349 | (rsvg:render-cairo handle cr))))) |
890d2504 |
350 | |
351 | (define-snippet librsvg (cr) |
352 | (snippet-set-bg-svg cr "clg:examples;home.svg")) |
353 | |
354 | |
355 | (defmacro define-operator-snippet (name operator) |
356 | `(define-snippet ,name (cr) |
357 | (snippet-set-bg-svg cr "clg:examples;freedesktop.svg") |
358 | (setf (cairo:operator cr) ,operator) |
359 | |
360 | (cairo:set-source-color cr 1.0 0.0 0.0 0.5) |
361 | (cairo:rectangle cr 0.2 0.2 0.5 0.5) |
362 | (cairo:fill cr) |
363 | |
364 | (cairo:set-source-color cr 0.0 1.0 0.0) |
365 | (cairo:rectangle cr 0.4 0.4 0.4 0.4) |
366 | (cairo:fill cr) |
c4f672a3 |
367 | |
890d2504 |
368 | (cairo:set-source-color cr 0.0 0.0 1.0) |
369 | (cairo:rectangle cr 0.6 0.6 0.3 0.3) |
370 | (cairo:fill cr))) |
371 | |
372 | (define-operator-snippet operator-add :add) |
373 | (define-operator-snippet operator-atop :atop) |
374 | (define-operator-snippet operator-atop-reverse :dest-atop) |
375 | (define-operator-snippet operator-in :in) |
376 | (define-operator-snippet operator-in-reverse :dest-in) |
377 | (define-operator-snippet operator-out :out) |
378 | (define-operator-snippet operator-out-reverse :dest-out) |
379 | (define-operator-snippet operator-over :over) |
380 | (define-operator-snippet operator-over-reverse :dest-over) |
381 | (define-operator-snippet operator-saturate :saturate) |
382 | (define-operator-snippet operator-xor :xor) |
c4f672a3 |
383 | ) |
1ed0a2c5 |
384 | |
385 | |
386 | |
387 | (define-snippet path (cr) |
388 | (cairo:move-to cr 0.5 0.1) |
389 | (cairo:line-to cr 0.9 0.9) |
390 | (cairo:rel-line-to cr -0.4 0.0) |
391 | (cairo:curve-to cr 0.2 0.9 0.2 0.5 0.5 0.5) |
392 | (cairo:stroke cr)) |
393 | |
394 | |
1ed0a2c5 |
395 | (define-snippet set-line-cap (cr) |
396 | (setf (cairo:line-width cr) 0.12) |
397 | (setf (cairo:line-cap cr) :butt) |
398 | (cairo:move-to cr 0.25 0.2) |
399 | (cairo:line-to cr 0.25 0.8) |
400 | (cairo:stroke cr) |
401 | (setf (cairo:line-cap cr) :round) |
402 | (cairo:move-to cr 0.5 0.2) |
403 | (cairo:line-to cr 0.5 0.8) |
404 | (cairo:stroke cr) |
405 | (setf (cairo:line-cap cr) :square) |
406 | (cairo:move-to cr 0.75 0.2) |
407 | (cairo:line-to cr 0.75 0.8) |
408 | (cairo:stroke cr) |
409 | |
410 | ;; draw helping lines |
f7f58f90 |
411 | (cairo:set-source-color cr 1.0 0.2 0.2) |
1ed0a2c5 |
412 | (setf (cairo:line-width cr) 0.01) |
413 | (cairo:move-to cr 0.25 0.2) |
414 | (cairo:line-to cr 0.25 0.8) |
415 | (cairo:move-to cr 0.5 0.2) |
416 | (cairo:line-to cr 0.5 0.8) |
417 | (cairo:move-to cr 0.75 0.2) |
418 | (cairo:line-to cr 0.75 0.8) |
419 | (cairo:stroke cr)) |
420 | |
421 | |
422 | (define-snippet set-line-join (cr) |
423 | (setf (cairo:line-width cr) 0.16) |
424 | (cairo:move-to cr 0.3 0.33) |
425 | (cairo:rel-line-to cr 0.2 -0.2) |
426 | (cairo:rel-line-to cr 0.2 0.2) |
427 | (setf (cairo:line-join cr) :miter) ; default |
428 | (cairo:stroke cr) |
429 | |
430 | (cairo:move-to cr 0.3 0.63) |
431 | (cairo:rel-line-to cr 0.2 -0.2) |
432 | (cairo:rel-line-to cr 0.2 0.2) |
433 | (setf (cairo:line-join cr) :bevel) |
434 | (cairo:stroke cr) |
435 | |
436 | (cairo:move-to cr 0.3 0.93) |
437 | (cairo:rel-line-to cr 0.2 -0.2) |
438 | (cairo:rel-line-to cr 0.2 0.2) |
439 | (setf (cairo:line-join cr) :round) |
440 | (cairo:stroke cr)) |
441 | |
442 | |
443 | |
444 | (define-snippet text (cr) |
445 | (cairo:select-font-face cr "Sans" :normal :bold) |
446 | ;; ;(setf (cairo:font-size cr) 0.35) |
447 | (cairo:set-font-size cr 0.35) |
448 | |
449 | (cairo:move-to cr 0.04 0.53) |
450 | (cairo:show-text cr "Hello") |
451 | |
452 | (cairo:move-to cr 0.27 0.65) |
453 | (cairo:text-path cr "void") |
f7f58f90 |
454 | (cairo:set-source-color cr 0.5 0.5 1.0) |
1ed0a2c5 |
455 | (cairo:fill cr t) |
456 | |
f7f58f90 |
457 | (cairo:set-source-color cr 0.0 0.0 0.0) |
1ed0a2c5 |
458 | (setf (cairo:line-width cr) 0.01) |
459 | (cairo:stroke cr) |
460 | |
461 | ;; draw helping lines |
f7f58f90 |
462 | (cairo:set-source-color cr 1.0 0.2 0.2 0.6) |
463 | (cairo:arc cr 0.04 0.53 0.02 0 (deg-to-rad 360.0)) |
464 | (cairo:arc cr 0.27 0.65 0.02 0 (deg-to-rad 360.0)) |
1ed0a2c5 |
465 | (cairo:fill cr)) |
466 | |
467 | |
468 | (define-snippet text-align-center (cr) |
469 | (let ((text "cairo")) |
470 | (cairo:select-font-face cr "Sans" :normal :normal) |
471 | (cairo:set-font-size cr 0.2) |
472 | |
473 | (let* ((extents (cairo:text-extents cr text)) |
474 | (x (- 0.5 (+ (/ (cairo:text-extents-width extents) 2) (cairo:text-extents-x-bearing extents)))) |
475 | (y (- 0.5 (+ (/ (cairo:text-extents-height extents) 2) (cairo:text-extents-y-bearing extents))))) |
476 | (cairo:move-to cr x y) |
477 | (cairo:show-text cr text) |
478 | |
479 | ;; draw helping lines |
480 | (cairo:set-source-color cr 1.0 0.2 0.2 0.6) |
481 | (cairo:circle cr x y 0.05) |
482 | (cairo:fill cr) |
483 | (cairo:move-to cr 0.5 0.0) |
484 | (cairo:rel-line-to cr 0.0 1.0) |
485 | (cairo:move-to cr 0.0 0.5) |
486 | (cairo:rel-line-to cr 1.0 0.0) |
487 | (cairo:stroke cr)))) |
488 | |
489 | (define-snippet text-extents (cr) |
490 | (let ((text "cairo")) |
491 | (cairo:select-font-face cr "Sans" :normal :normal) |
492 | (cairo:set-font-size cr 0.4) |
493 | |
494 | (let* ((extents (cairo:text-extents cr text)) |
495 | (x 0.1) |
496 | (y 0.6)) |
497 | (cairo:move-to cr x y) |
498 | (cairo:show-text cr text) |
499 | |
500 | ;; draw helping lines |
501 | (cairo:set-source-color cr 1.0 0.2 0.2 0.6) |
502 | (cairo:circle cr x y 0.05) |
503 | (cairo:fill cr) |
504 | (cairo:move-to cr x y) |
505 | (cairo:rel-line-to cr 0 (- (cairo:text-extents-height extents))) |
506 | (cairo:rel-line-to cr (cairo:text-extents-width extents) 0) |
507 | (cairo:rel-line-to cr |
508 | (cairo:text-extents-x-bearing extents) |
509 | (- (cairo:text-extents-y-bearing extents))) |
510 | (cairo:stroke cr)))) |
511 | |
512 | |
513 | (defun create-tests () |
514 | ;; (rc-parse "clg:examples;testgtkrc2") |
515 | ;; (rc-parse "clg:examples;testgtkrc") |
516 | |
517 | (let* ((main-window (make-instance 'window |
518 | :title "testcairo.lisp" :name "main-window" |
519 | :default-width 200 :default-height 400 |
520 | :allow-grow t :allow-shrink nil)) |
521 | (scrolled-window (make-instance 'scrolled-window |
522 | :hscrollbar-policy :automatic |
523 | :vscrollbar-policy :automatic |
524 | :border-width 10)) |
525 | (close-button (make-instance 'button |
f86d1eb7 |
526 | :stock "gtk-close" :can-default t |
1ed0a2c5 |
527 | :signal (list 'clicked #'widget-destroy |
528 | :object main-window)))) |
529 | |
530 | (let ((icon (gdk:pixbuf-load #p"clg:examples;gtk.png"))) |
531 | (setf |
532 | (window-icon main-window) |
533 | (gdk:pixbuf-add-alpha icon t 254 254 252))) |
534 | |
535 | ;; Main box |
536 | (make-instance 'v-box |
537 | :parent main-window |
538 | :child-args '(:expand nil) |
ec284c3d |
539 | :child (list (make-instance 'label |
540 | :label (format nil "Cairo ~A" (cairo:version-string))) |
541 | :fill nil) |
1ed0a2c5 |
542 | :child (list (make-instance 'label :label (clg-version)) :fill nil) |
543 | :child (list (make-instance 'label |
f86d1eb7 |
544 | :label #-cmu |
ec284c3d |
545 | (format nil "~A ~A" |
f86d1eb7 |
546 | (lisp-implementation-type) |
547 | #-clisp |
548 | (lisp-implementation-version) |
549 | #+clisp |
550 | (let ((version (lisp-implementation-version))) |
551 | (subseq version 0 (position #\sp version)))) |
1ed0a2c5 |
552 | ;; The version string in CMUCL is far too long |
553 | #+cmu(lisp-implementation-type)) |
554 | :fill nil) |
555 | :child (list scrolled-window :expand t) |
556 | :child (make-instance 'h-separator) |
557 | :child (make-instance 'v-box |
558 | :homogeneous nil :spacing 10 :border-width 10 |
559 | :child close-button)) |
560 | |
561 | (let ((content-box |
562 | (make-instance 'v-box |
563 | :focus-vadjustment (scrolled-window-vadjustment scrolled-window) |
564 | :children (mapcar #'(lambda (snippet) |
565 | (create-button (string-downcase snippet) snippet)) |
890d2504 |
566 | (setq *snippets* (sort *snippets* #'string<)))))) |
1ed0a2c5 |
567 | (scrolled-window-add-with-viewport scrolled-window content-box)) |
568 | |
569 | (widget-grab-focus close-button) |
570 | (widget-show-all main-window) |
571 | main-window)) |
572 | |
573 | |
574 | (clg-init) |
f86d1eb7 |
575 | (rsvg:init) |
890d2504 |
576 | |
577 | ;; We need to turn off floating point exceptions, because Cairo is |
578 | ;; presumably using internal code which generates NaNs in some cases. |
579 | ;; Thanks to Christophe Rhodes for pointing this out. |
580 | #+sbcl(sb-int:set-floating-point-modes :traps nil) |
581 | #+cmu(ext:set-floating-point-modes :traps nil) |
582 | |
ddcb3b7d |
583 | (within-main-loop (create-tests)) |