chiark - git - mdw - clg/blob - examples/testcairo.lisp

   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 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
 295 (define-snippet gradient (cr)
 296   (let ((pattern (cairo:pattern-create-linear 0.0 0.0 0.0 1.0)))
 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)
 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)))
 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)
 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)
 311   (let ((image (make-instance 'cairo:image-surface
 312                 :filename #p"clg:examples;romedalen.png")))
 313     (cairo:translate cr 0.5 0.5)
 314     (cairo:rotate cr (deg-to-rad 45.0))
 315     (let ((width (cairo:surface-width image))
 316           (height (cairo:surface-height image)))
 317       (cairo:scale cr (/ 1.0 width) (/ 1.0 height))
 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)
 324   (let* ((image (make-instance 'cairo:image-surface
 325                  :filename #p"clg:examples;romedalen.png"))
 326          (pattern (cairo:pattern-create-for-surface image)))
 327     (setf (cairo:pattern-extend pattern) :repeat)
 328     (cairo:translate cr 0.5 0.5)
 329     (cairo:rotate cr (deg-to-rad 45.0))
 330     (cairo:scale cr (/ 1.0 (sqrt 2.0)) (/ 1.0 (sqrt 2.0)))
 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
 342 #?(pkg-config:pkg-exists-p "librsvg-2.0" :atleast-version "2.13.93")
 343 (progn
 344 (defun snippet-set-bg-svg (cr filename)
 345   (let ((handle (make-instance 'rsvg:handle :filename filename)))
 346     (cairo:with-context (cr)
 347       (with-slots (rsvg:width rsvg:height) handle
 348         (cairo:scale cr (/ 1.0 rsvg:width) (/ 1.0 rsvg:height))
 349         (rsvg:render-cairo handle cr)))))
 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)
 367
 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)
 383 )
 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
 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
 411   (cairo:set-source-color cr 1.0 0.2 0.2)
 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")
 454   (cairo:set-source-color cr 0.5 0.5 1.0)
 455   (cairo:fill cr t)
 456
 457   (cairo:set-source-color cr 0.0 0.0 0.0)
 458   (setf (cairo:line-width cr) 0.01)
 459   (cairo:stroke cr)
 460
 461   ;; draw helping lines
 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))
 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
 526                         :stock "gtk-close" :can-default t
 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)
 539      :child (list (make-instance 'label
 540                    :label (format nil "Cairo ~A" (cairo:version-string)))
 541                   :fill nil)
 542      :child (list (make-instance 'label :label (clg-version)) :fill nil)
 543      :child (list (make-instance 'label
 544                    :label #-cmu
 545                           (format nil "~A ~A"
 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))))
 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))
 566                               (setq *snippets* (sort *snippets* #'string<))))))
 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)
 575 (rsvg:init)
 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
 583 (within-main-loop (create-tests))