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