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 #+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)