| 1 | ;; This file contains the cairo C snippets translated to lisp |
| 2 | ;; See http://cairographics.org/samples/ |
| 3 | |
| 4 | #+sbcl(require :gtk) |
| 5 | #+sbcl(require :cairo) |
| 6 | #+(or cmu clisp)(asdf:oos 'asdf:load-op :gtk) |
| 7 | #+(or cmu clisp)(asdf:oos 'asdf:load-op :cairo) |
| 8 | |
| 9 | (eval-when (:compile-toplevel :load-toplevel :execute) |
| 10 | (unless (pkg-config:pkg-exists-p "librsvg-2.0" :atleast-version "2.14.0") |
| 11 | (warn "SVG tests disabled as the required version of librsvg is not available."))) |
| 12 | |
| 13 | #?(pkg-config:pkg-exists-p "librsvg-2.0" :atleast-version "2.14.0") |
| 14 | #+sbcl(require :rsvg) |
| 15 | #+(or cmu clisp)(asdf:oos 'asdf:load-op :rsvg) |
| 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.0))) |
| 26 | |
| 27 | (declaim (inline rad-to-deg)) |
| 28 | (defun rad-to-deg (rad) |
| 29 | (/ (* rad 180.0) 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")) |
| 38 | (event (make-symbol "EVENT"))) |
| 39 | `(let ((,window nil)) |
| 40 | (pushnew ',name *snippets*) |
| 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 |
| 52 | #'(lambda (,event) |
| 53 | (declare (ignore ,event)) |
| 54 | (gdk:with-cairo-context (,cr (widget-window ,widget)) |
| 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 0.2 0.2 0.6) |
| 68 | (cairo:arc cr xc yc 0.05 0 (deg-to-rad 360.0)) |
| 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.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) |
| 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 (make-instance 'cairo:image-surface |
| 128 | :filename #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 0.0) |
| 149 | (cairo:line-to cr 1.0 1.0) |
| 150 | (cairo:stroke cr)) |
| 151 | |
| 152 | |
| 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 | |
| 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)) |
| 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))) |
| 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 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 0.0 1.0) |
| 251 | (cairo:fill cr t) |
| 252 | (cairo:set-source-color cr 0.0 0.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 0.0 1.0) |
| 260 | (cairo:fill cr t) |
| 261 | (cairo:set-source-color cr 0.0 0.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 0.0 0.0 1.0) |
| 268 | (cairo:pattern-add-color-stop pattern 0.0 1.0 1.0 1.0 1.0) |
| 269 | (cairo:rectangle cr 0.0 0.0 1.0 1.0) |
| 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.0 1.0 1.0 1.0 1.0) |
| 274 | (cairo:pattern-add-color-stop pattern 1.0 0.0 0.0 0.0 1.0) |
| 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 (make-instance 'cairo:image-surface |
| 282 | :filename #p"clg:examples;romedalen.png"))) |
| 283 | (cairo:translate cr 0.5 0.5) |
| 284 | (cairo:rotate cr (deg-to-rad 45.0)) |
| 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 (make-instance 'cairo:image-surface |
| 295 | :filename #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.0)) |
| 300 | (cairo:scale cr (/ 1.0 (sqrt 2.0)) (/ 1.0 (sqrt 2.0))) |
| 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 | |
| 312 | #?(pkg-config:pkg-exists-p "librsvg-2.0" :atleast-version "2.13.93") |
| 313 | (progn |
| 314 | (defun snippet-set-bg-svg (cr filename) |
| 315 | (let ((handle (make-instance 'rsvg:handle :filename filename))) |
| 316 | (cairo:with-context (cr) |
| 317 | (with-slots (rsvg:width rsvg:height) handle |
| 318 | (cairo:scale cr (/ 1.0 rsvg:width) (/ 1.0 rsvg:height)) |
| 319 | (rsvg:render-cairo handle cr))))) |
| 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) |
| 337 | |
| 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) |
| 353 | ) |
| 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 | |
| 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 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.0) |
| 425 | (cairo:fill cr t) |
| 426 | |
| 427 | (cairo:set-source-color cr 0.0 0.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 0.2 0.2 0.6) |
| 433 | (cairo:arc cr 0.04 0.53 0.02 0 (deg-to-rad 360.0)) |
| 434 | (cairo:arc cr 0.27 0.65 0.02 0 (deg-to-rad 360.0)) |
| 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 |
| 496 | :stock "gtk-close" :can-default t |
| 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 |
| 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)))) |
| 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)) |
| 534 | (setq *snippets* (sort *snippets* #'string<)))))) |
| 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) |
| 543 | (rsvg:init) |
| 544 | |
| 545 | ;; We need to turn off floating point exceptions, because Cairo is |
| 546 | ;; presumably using internal code which generates NaNs in some cases. |
| 547 | ;; Thanks to Christophe Rhodes for pointing this out. |
| 548 | #+sbcl(sb-int:set-floating-point-modes :traps nil) |
| 549 | #+cmu(ext:set-floating-point-modes :traps nil) |
| 550 | |
| 551 | (within-main-loop (create-tests)) |