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