[clg] / examples / testcairo.lisp

;; This file contains the cairo C snippets translated to lisp 
;; See http://cairographics.org/samples/

#+sbcl(require :gtk)
#+sbcl(require :cairo)
#+(or cmu clisp)(asdf:oos 'asdf:load-op :gtk)
#+(or cmu clisp)(asdf:oos 'asdf:load-op :cairo)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (unless (pkg-config:pkg-exists-p "librsvg-2.0" :atleast-version "2.14.0")
    (warn "SVG tests disabled as the required version of librsvg is not available.")))

#?(pkg-config:pkg-exists-p "librsvg-2.0" :atleast-version "2.14.0")
#+sbcl(require :rsvg)
#+(or cmu clisp)(asdf:oos 'asdf:load-op :rsvg)

(defpackage "TESTCAIRO"
  (:use "COMMON-LISP" "GTK")
  (:export "CREATE-TESTS"))

(in-package "TESTCAIRO")

(declaim (inline deg-to-rad))
(defun deg-to-rad (deg)
  (* deg (/ pi 180.0)))

(declaim (inline rad-to-deg))
(defun rad-to-deg (rad)
  (/ (* rad 180.0) pi))


(defvar *snippets* ())


(defmacro define-snippet (name (cr) &body body)
  (let ((widget (make-symbol "WIDGET"))
	(window (make-symbol "WINDOW"))
	(event (make-symbol "EVENT")))
    `(let ((,window nil))
       (pushnew ',name *snippets*)
       (defun ,name ()
	 (if (not ,window)
	     (let ((,widget (make-instance 'drawing-area)))
	       (setq ,window
	        (make-instance 'window 
		 :width-request 300 :height-request 300 
		 :title ,(string-downcase name)
		 :visible t :child ,widget))
	       (signal-connect ,window 'destroy 
                #'(lambda () (setq ,window nil)))
	       (signal-connect ,widget 'expose-event
		#'(lambda (,event)
		    (declare (ignore ,event))
		    (gdk:with-cairo-context (,cr (widget-window ,widget))
		      (multiple-value-bind (width height) 
			  (widget-get-size-allocation ,widget)
			(cairo:scale ,cr width height))
		      (setf (cairo:line-width ,cr) 0.04)
		      ,@body)))
	       (widget-show-all ,window))
	   (widget-destroy ,window))))))


(defun arc-helper-lines (cr xc yc radius angle1 angle2)
  (cairo:set-source-color cr 1.0 0.2 0.2 0.6)
  (cairo:arc cr xc yc 0.05 0 (deg-to-rad 360.0))
  (cairo:fill cr)
  (setf (cairo:line-width cr) 0.03)
  (cairo:move-to cr xc yc)
  (cairo:rel-line-to cr (* radius (cos angle1)) (* radius (sin angle1)))
  (cairo:stroke cr)
  (cairo:move-to cr xc yc)
  (cairo:rel-line-to cr (* radius (cos angle2)) (* radius (sin angle2)))
  (cairo:stroke cr))

(define-snippet arc (cr)
  (let ((xc 0.5)
	(yc 0.5)
	(radius 0.4)
	(angle1 (deg-to-rad 45.0))
	(angle2 (deg-to-rad 180.0)))

    (cairo:with-context (cr)
      (setf (cairo:line-cap cr) :round)
      (cairo:arc cr xc yc radius angle1 angle2)
      (cairo:stroke cr))

    (arc-helper-lines cr xc yc radius angle1 angle2)))

(define-snippet arc-negative (cr)
  (let ((xc 0.5)
	(yc 0.5)
	(radius 0.4)
	(angle1 (deg-to-rad 45.0))
	(angle2 (deg-to-rad 180.0)))

    (cairo:with-context (cr)
      (setf (cairo:line-cap cr) :round)
      (cairo:arc-negative cr xc yc radius angle1 angle2)
      (cairo:stroke cr))

    (arc-helper-lines cr xc yc radius angle1 angle2)))


(define-snippet clip (cr)
  (cairo:circle cr 0.5 0.5 0.3)
  (cairo:clip cr)

  (cairo:new-path cr) ; current path is not consumed by cairo:clip
  (cairo:rectangle cr 0 0 1 1)
  (cairo:fill cr)
  (cairo:set-source-color cr 0.0 1.0 0.0)
  (cairo:move-to cr 0.0 0.0)
  (cairo:line-to cr 1.0 1.0)
  (cairo:move-to cr 1.0 0.0)
  (cairo:line-to cr 0.0 1.0)
  (cairo:stroke cr))


(define-snippet clip-image (cr)
  (cairo:circle cr 0.5 0.5 0.3)
  (cairo:clip cr)
  (cairo:new-path cr)

  (let ((image (make-instance 'cairo:image-surface 
		:filename #p"clg:examples;romedalen.png")))
	       
    (let ((width (cairo:surface-width image))
	  (height (cairo:surface-height image)))
      (cairo:scale cr (/ 1.0 width) (/ 1.0 height)))

    (cairo:set-source-surface cr image 0 0)
    (cairo:paint cr)))

(define-snippet clip-rectangle (cr)
  (cairo:new-path cr)
  (cairo:move-to cr 0.25 0.25)
  (cairo:line-to cr 0.25 0.75)
  (cairo:line-to cr 0.75 0.75)
  (cairo:line-to cr 0.75 0.25)
  (cairo:line-to cr 0.25 0.25)
  (cairo:close-path cr)

  (cairo:clip cr)

  (cairo:move-to cr 0.0 0.0)
  (cairo:line-to cr 1.0 1.0)
  (cairo:stroke cr))


(defun %curve-rectangle (cr x0 y0 width height radius)
  (unless (and (zerop width) (zerop height))
    (let ((x1 (+ x0 width))
	  (y1 (+ y0 height)))
      (cond
       ((and (< (* 0.5 width) radius) (< (* 0.5 height) radius))
	(cairo:move-to cr x0 (* 0.5 (+ y0 y1)))
	(cairo:curve-to cr x0 y0 x0 y0 (* 0.5 (+ x0 x1)) y0)
	(cairo:curve-to cr x1 y0 x1 y0 x1 (* 0.5 (+ y0 y1)))
	(cairo:curve-to cr x1 y1 x1 y1 (* 0.5 (+ x0 x1)) y1)
	(cairo:curve-to cr x0 y1 x0 y1 x0 (* 0.5 (+ y0 y1))))
       ((< (* 0.5 width) radius)
	(cairo:move-to  cr x0 (+ y0 radius))
	(cairo:curve-to cr x0 y0 x0 y0 (* 0.5 (+ x0 x1)) y0)
	(cairo:curve-to cr x1 y0 x1 y0 x1 (+ y0 radius))
	(cairo:line-to cr x1  (- y1 radius))
	(cairo:curve-to cr x1 y1 x1 y1 (* 0.5 (+ x0 x1)) y1)
	(cairo:curve-to cr x0 y1 x0 y1 x0 (- y1 radius)))
       ((< (* 0.5 height) radius)
	(cairo:move-to cr x0 (* 0.5 (+ y0 y1)))
	(cairo:curve-to cr x0  y0 x0  y0 (+ x0 radius) y0)
	(cairo:line-to cr (- x1 radius) y0)
	(cairo:curve-to cr x1 y0 x1 y0 x1 (* 0.5 (+ y0 y1)))
	(cairo:curve-to cr x1 y1 x1 y1 (- x1 radius) y1)
	(cairo:line-to cr (+ x0 radius) y1)
	(cairo:curve-to cr x0 y1 x0 y1 x0 (* 0.5 (+ y0 y1))))
       (t
	(cairo:move-to cr x0 (+ y0 radius))
	(cairo:curve-to cr x0 y0 x0 y0 (+ x0 radius) y0)
	(cairo:line-to cr (- x1 radius) y0)
	(cairo:curve-to cr x1 y0 x1 y0 x1 (+ y0 radius))
	(cairo:line-to cr x1 (- y1 radius))
	(cairo:curve-to cr x1 y1 x1 y1 (- x1 radius) y1)
	(cairo:line-to cr (+ x0 radius) y1)
	(cairo:curve-to cr x0 y1 x0 y1 x0 (- y1 radius))))
      (cairo:close-path cr))))

(define-snippet curve-rectangle (cr)
  (let ((x0 0.1)
	(y0 0.1)
	(width 0.8)
	(height 0.8)
	(radius 0.4))
    (%curve-rectangle cr x0 y0 width height radius)
    (cairo:set-source-color cr 0.5 0.5 1.0)
    (cairo:fill cr t)
    (cairo:set-source-color cr 0.5 0.0 0.0 0.5)
    (cairo:stroke cr)))


(define-snippet curve-to (cr)
  (let ((x 0.1) (y 0.5)
	(x1 0.4) (y1 0.9)
	(x2 0.6) (y2 0.1)
	(x3 0.9) (y3 0.5))

    (cairo:move-to cr x y)
    (cairo:curve-to cr x1 y1 x2 y2 x3 y3)

    (cairo:stroke cr)

    (cairo:set-source-color cr 1.0 0.2 0.2 0.6)
    (setf (cairo:line-width cr) 0.03)
    (cairo:move-to cr x y)
    (cairo:line-to cr x1 y1)
    (cairo:move-to cr x2 y2)
    (cairo:line-to cr x3 y3)
    (cairo:stroke cr)))


(define-snippet dash (cr)
  (let ((dashes #(0.20 0.05 0.05 0.05))
	(offset -0.2))
    (cairo:set-dash cr dashes offset)
    (cairo:move-to cr 0.5 0.1)
    (cairo:line-to cr 0.9 0.9)
    (cairo:rel-line-to cr -0.4 0.0)
    (cairo:curve-to cr 0.2 0.9 0.2 0.5 0.5 0.5)
    (cairo:stroke cr)))


(defun fill-and-stroke-common (cr)
  (cairo:move-to cr 0.5 0.1)
  (cairo:line-to cr 0.9 0.9)
  (cairo:rel-line-to cr -0.4 0.0)
  (cairo:curve-to cr 0.2 0.9 0.2 0.5 0.5 0.5)
  (cairo:close-path cr))
 

(define-snippet fill-and-stroke2 (cr)
  (fill-and-stroke-common cr)
  (cairo:move-to cr 0.25 0.1)
  (cairo:rel-line-to cr 0.2 0.2)
  (cairo:rel-line-to cr -0.2 0.2)
  (cairo:rel-line-to cr -0.2 -0.2)
  (cairo:close-path cr)

  (cairo:set-source-color cr 0.0 0.0 1.0)
  (cairo:fill cr t)
  (cairo:set-source-color cr 0.0 0.0 0.0)
  (cairo:stroke cr))


(define-snippet fill-and-stroke (cr)
  (fill-and-stroke-common cr)

  (cairo:set-source-color cr 0.0 0.0 1.0)
  (cairo:fill cr t)
  (cairo:set-source-color cr 0.0 0.0 0.0)
  (cairo:stroke cr))


(define-snippet fill-style (cr)
  (cairo:scale cr (/ 256.0) (/ 256.0))
  (setf (cairo:line-width cr) 6)
  (cairo:rectangle cr 12 12 232 70)
  (cairo:new-sub-path cr)
  (cairo:arc cr 64 64 40 0 (* 2 pi))
  (cairo:new-sub-path cr)
  (cairo:arc-negative cr 192 64 40 0 (* -2 pi))

  (setf (cairo:fill-rule cr) :even-odd)
  (cairo:set-source-color cr 0 0.7 0)
  (cairo:fill cr t)
  (cairo:set-source-color cr 0 0 0)
  (cairo:stroke cr)

  (cairo:translate cr 0 128)
  (cairo:rectangle cr 12 12 232 70)
  (cairo:new-sub-path cr)
  (cairo:arc cr 64 64 40 0 (* 2 pi))
  (cairo:new-sub-path cr)
  (cairo:arc-negative cr 192 64 40 0 (* -2 pi))

  (setf (cairo:fill-rule cr) :winding)
  (cairo:set-source-color cr 0 0 0.9)
  (cairo:fill cr t)
  (cairo:set-source-color cr 0 0 0)
  (cairo:stroke cr))


(define-snippet gradient (cr)
  (let ((pattern (cairo:pattern-create-linear 0.0 0.0 0.0 1.0)))
    (cairo:pattern-add-color-stop pattern 1.0 0.0 0.0 0.0 1.0)
    (cairo:pattern-add-color-stop pattern 0.0 1.0 1.0 1.0 1.0)
    (cairo:rectangle cr 0.0 0.0 1.0 1.0)
    (setf (cairo:source cr) pattern)
    (cairo:fill cr))
  (let ((pattern (cairo:pattern-create-radial 0.45 0.4 0.1 0.4 0.4 0.5)))
    (cairo:pattern-add-color-stop pattern 0.0 1.0 1.0 1.0 1.0)
    (cairo:pattern-add-color-stop pattern 1.0 0.0 0.0 0.0 1.0)
    (setf (cairo:source cr) pattern)
    (cairo:circle cr 0.5 0.5 0.3)
    (cairo:fill cr)))


(define-snippet image (cr)
  (let ((image (make-instance 'cairo:image-surface 
		:filename #p"clg:examples;romedalen.png")))
    (cairo:translate cr 0.5 0.5)
    (cairo:rotate cr (deg-to-rad 45.0))
    (let ((width (cairo:surface-width image))
	  (height (cairo:surface-height image)))
      (cairo:scale cr (/ 1.0 width) (/ 1.0 height))
      (cairo:translate cr (* -0.5 width) (* -0.5 height)))
    (cairo:set-source-surface cr image 0 0)
    (cairo:paint cr)))

    
(define-snippet image-pattern (cr)
  (let* ((image (make-instance 'cairo:image-surface
		 :filename #p"clg:examples;romedalen.png"))
	 (pattern (cairo:pattern-create-for-surface image)))
    (setf (cairo:pattern-extend pattern) :repeat)    
    (cairo:translate cr 0.5 0.5)
    (cairo:rotate cr (deg-to-rad 45.0))
    (cairo:scale cr (/ 1.0 (sqrt 2.0)) (/ 1.0 (sqrt 2.0)))  
    (cairo:translate cr -0.5 -0.5)
    (let ((width (cairo:surface-width image))
	  (height (cairo:surface-height image))
	  (matrix (make-instance 'cairo:matrix)))
      (cairo:matrix-init-scale matrix (* 5 width) (* 5 height))
      (setf (cairo:pattern-matrix pattern) matrix))
    (setf (cairo:source cr) pattern)
    (cairo:rectangle cr 0.0 0.0 1.0 1.0)
    (cairo:fill cr)))


#?(pkg-config:pkg-exists-p "librsvg-2.0" :atleast-version "2.13.93")
(progn
(defun snippet-set-bg-svg (cr filename)
  (let ((handle (make-instance 'rsvg:handle :filename filename)))
    (cairo:with-context (cr)
      (with-slots (rsvg:width rsvg:height) handle
        (cairo:scale cr (/ 1.0 rsvg:width) (/ 1.0 rsvg:height))
	(rsvg:render-cairo handle cr)))))

(define-snippet librsvg (cr)
  (snippet-set-bg-svg cr "clg:examples;home.svg"))


(defmacro define-operator-snippet (name operator)
  `(define-snippet ,name (cr)
     (snippet-set-bg-svg cr "clg:examples;freedesktop.svg")
     (setf (cairo:operator cr) ,operator)
     
     (cairo:set-source-color cr 1.0 0.0 0.0 0.5)
     (cairo:rectangle cr 0.2 0.2 0.5 0.5)
     (cairo:fill cr)
     
     (cairo:set-source-color cr 0.0 1.0 0.0)
     (cairo:rectangle cr 0.4 0.4 0.4 0.4)
     (cairo:fill cr)
       
     (cairo:set-source-color cr 0.0 0.0 1.0)
     (cairo:rectangle cr 0.6 0.6 0.3 0.3)
     (cairo:fill cr)))

(define-operator-snippet operator-add :add)
(define-operator-snippet operator-atop :atop)
(define-operator-snippet operator-atop-reverse :dest-atop)
(define-operator-snippet operator-in :in)
(define-operator-snippet operator-in-reverse :dest-in)
(define-operator-snippet operator-out :out)
(define-operator-snippet operator-out-reverse :dest-out)
(define-operator-snippet operator-over :over)
(define-operator-snippet operator-over-reverse :dest-over)
(define-operator-snippet operator-saturate :saturate)
(define-operator-snippet operator-xor :xor)
)

      
(define-snippet path (cr)
  (cairo:move-to cr 0.5 0.1)
  (cairo:line-to cr 0.9 0.9)
  (cairo:rel-line-to cr -0.4 0.0)
  (cairo:curve-to cr 0.2 0.9 0.2 0.5 0.5 0.5)
  (cairo:stroke cr))


(define-snippet set-line-cap (cr)
  (setf (cairo:line-width cr) 0.12)
  (setf (cairo:line-cap cr) :butt)
  (cairo:move-to cr 0.25 0.2)
  (cairo:line-to cr 0.25 0.8)
  (cairo:stroke cr)
  (setf (cairo:line-cap cr) :round)
  (cairo:move-to cr 0.5 0.2)
  (cairo:line-to cr 0.5 0.8)
  (cairo:stroke cr)
  (setf (cairo:line-cap cr) :square)
  (cairo:move-to cr 0.75 0.2)
  (cairo:line-to cr 0.75 0.8)
  (cairo:stroke cr)

  ;; draw helping lines
  (cairo:set-source-color cr 1.0 0.2 0.2)
  (setf (cairo:line-width cr) 0.01)
  (cairo:move-to cr 0.25 0.2)
  (cairo:line-to cr 0.25 0.8)
  (cairo:move-to cr 0.5 0.2) 
  (cairo:line-to cr 0.5 0.8)
  (cairo:move-to cr 0.75 0.2)
  (cairo:line-to cr 0.75 0.8)
  (cairo:stroke cr))


(define-snippet set-line-join (cr)
  (setf (cairo:line-width cr) 0.16)
  (cairo:move-to cr 0.3 0.33)
  (cairo:rel-line-to cr 0.2 -0.2)
  (cairo:rel-line-to cr 0.2 0.2)
  (setf (cairo:line-join cr) :miter) ; default
  (cairo:stroke cr)

  (cairo:move-to cr 0.3 0.63)
  (cairo:rel-line-to cr 0.2 -0.2)
  (cairo:rel-line-to cr 0.2 0.2)
  (setf (cairo:line-join cr) :bevel)
  (cairo:stroke cr)
		
  (cairo:move-to cr 0.3 0.93)
  (cairo:rel-line-to cr 0.2 -0.2)
  (cairo:rel-line-to cr 0.2 0.2)
  (setf (cairo:line-join cr) :round)
  (cairo:stroke cr))


(define-snippet text (cr)
   (cairo:select-font-face cr "Sans" :normal :bold)
;;   ;(setf (cairo:font-size cr) 0.35)
   (cairo:set-font-size cr 0.35)

   (cairo:move-to cr 0.04 0.53)
   (cairo:show-text cr "Hello")

  (cairo:move-to cr 0.27 0.65)
  (cairo:text-path cr "void")
  (cairo:set-source-color cr 0.5 0.5 1.0)
  (cairo:fill cr t)

  (cairo:set-source-color cr 0.0 0.0 0.0)
  (setf (cairo:line-width cr) 0.01)
  (cairo:stroke cr)

  ;; draw helping lines
  (cairo:set-source-color cr 1.0 0.2 0.2  0.6)
  (cairo:arc cr 0.04 0.53 0.02 0 (deg-to-rad 360.0))
  (cairo:arc cr 0.27 0.65 0.02 0 (deg-to-rad 360.0))
  (cairo:fill cr))


(define-snippet text-align-center (cr)
  (let ((text "cairo"))
    (cairo:select-font-face cr "Sans" :normal :normal)
    (cairo:set-font-size cr 0.2)

    (let* ((extents (cairo:text-extents cr text))
	   (x (- 0.5 (+ (/ (cairo:text-extents-width extents) 2) (cairo:text-extents-x-bearing extents))))
	   (y (- 0.5 (+ (/ (cairo:text-extents-height extents) 2) (cairo:text-extents-y-bearing extents)))))
      (cairo:move-to cr x y)
      (cairo:show-text cr text)

      ;; draw helping lines
      (cairo:set-source-color cr 1.0 0.2 0.2 0.6)
      (cairo:circle cr x y 0.05)
      (cairo:fill cr)
      (cairo:move-to cr 0.5 0.0)
      (cairo:rel-line-to cr 0.0 1.0)
      (cairo:move-to cr 0.0 0.5)
      (cairo:rel-line-to cr 1.0 0.0)
      (cairo:stroke cr))))

(define-snippet text-extents (cr)
  (let ((text "cairo"))
    (cairo:select-font-face cr "Sans" :normal :normal)
    (cairo:set-font-size cr 0.4)

    (let* ((extents (cairo:text-extents cr text))
	   (x 0.1)
	   (y 0.6))
      (cairo:move-to cr x y)
      (cairo:show-text cr text)

      ;; draw helping lines
      (cairo:set-source-color cr 1.0 0.2 0.2 0.6)
      (cairo:circle cr x y 0.05)
      (cairo:fill cr)
      (cairo:move-to cr x y)
      (cairo:rel-line-to cr 0 (- (cairo:text-extents-height extents)))
      (cairo:rel-line-to cr (cairo:text-extents-width extents) 0)
      (cairo:rel-line-to cr 
       (cairo:text-extents-x-bearing extents)
       (- (cairo:text-extents-y-bearing extents)))
      (cairo:stroke cr))))


(defun create-tests ()
;;   (rc-parse "clg:examples;testgtkrc2")
;;   (rc-parse "clg:examples;testgtkrc")

  (let* ((main-window (make-instance 'window
		       :title "testcairo.lisp" :name "main-window"
		       :default-width 200 :default-height 400
		       :allow-grow t :allow-shrink nil))
	 (scrolled-window (make-instance 'scrolled-window
			   :hscrollbar-policy :automatic 
			   :vscrollbar-policy :automatic
			   :border-width 10))
	 (close-button (make-instance 'button 
		        :stock "gtk-close" :can-default t
			:signal (list 'clicked #'widget-destroy 
			         :object main-window))))

    (let ((icon (gdk:pixbuf-load #p"clg:examples;gtk.png")))
      (setf 
       (window-icon main-window) 
       (gdk:pixbuf-add-alpha icon t 254 254 252)))

    ;; Main box
    (make-instance 'v-box
     :parent main-window
     :child-args '(:expand nil)
     :child (list (make-instance 'label 
		   :label (format nil "Cairo ~A" (cairo:version-string)))
		  :fill nil)
     :child (list (make-instance 'label :label (clg-version)) :fill nil)
     :child (list (make-instance 'label 			  
		   :label #-cmu
		          (format nil "~A ~A" 
			   (lisp-implementation-type)
			   #-clisp
			   (lisp-implementation-version)
			   #+clisp
			   (let ((version (lisp-implementation-version)))
			     (subseq version 0 (position #\sp version))))
		          ;; The version string in CMUCL is far too long
		          #+cmu(lisp-implementation-type))
		  :fill nil)
     :child (list scrolled-window :expand t)
     :child (make-instance 'h-separator)
     :child (make-instance 'v-box 
	     :homogeneous nil :spacing 10 :border-width 10 
	     :child close-button))

    (let ((content-box 
	   (make-instance 'v-box
	    :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
	    :children (mapcar #'(lambda (snippet)
				  (create-button (string-downcase snippet) snippet))
			      (setq *snippets* (sort *snippets* #'string<))))))
      (scrolled-window-add-with-viewport scrolled-window content-box))
    
    (widget-grab-focus close-button)
    (widget-show-all main-window)
    main-window))


(clg-init)
(rsvg:init)

;; We need to turn off floating point exceptions, because Cairo is
;; presumably using internal code which generates NaNs in some cases.
;; Thanks to Christophe Rhodes for pointing this out.
#+sbcl(sb-int:set-floating-point-modes :traps nil) 
#+cmu(ext:set-floating-point-modes :traps nil)

(within-main-loop (create-tests))
Commit	Line	Data
1ed0a2c5	1	;; This file contains the cairo C snippets translated to lisp
	2	;; See http://cairographics.org/samples/
	3
	4	#+sbcl(require :gtk)
1ed0a2c5	5	#+sbcl(require :cairo)
f86d1eb7	6	#+(or cmu clisp)(asdf:oos 'asdf:load-op :gtk)
f86d1eb7	7	#+(or cmu clisp)(asdf:oos 'asdf:load-op :cairo)
c4f672a3	8
c4f672a3	9	(eval-when (:compile-toplevel :load-toplevel :execute)
c36ffea1	10	(unless (pkg-config:pkg-exists-p "librsvg-2.0" :atleast-version "2.14.0")
c4f672a3	11	(warn "SVG tests disabled as the required version of librsvg is not available.")))
c4f672a3	12
c36ffea1	13	#?(pkg-config:pkg-exists-p "librsvg-2.0" :atleast-version "2.14.0")
f86d1eb7	14	#+sbcl(require :rsvg)
f86d1eb7	15	#+(or cmu clisp)(asdf:oos 'asdf:load-op :rsvg)
1ed0a2c5	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)
f7f58f90	25	(* deg (/ pi 180.0)))
1ed0a2c5	26
	27	(declaim (inline rad-to-deg))
	28	(defun rad-to-deg (rad)
f7f58f90	29	(/ (* rad 180.0) pi))
1ed0a2c5	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"))
57c6905f	38	(event (make-symbol "EVENT")))
1ed0a2c5	39	`(let ((,window nil))
890d2504	40	(pushnew ',name snippets)
1ed0a2c5	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
57c6905f	52	#'(lambda (,event)
57c6905f	53	(declare (ignore ,event))
df2a8909	54	(gdk:with-cairo-context (,cr (widget-window ,widget))
1ed0a2c5	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)
f7f58f90	67	(cairo:set-source-color cr 1.0 0.2 0.2 0.6)
f7f58f90	68	(cairo:arc cr xc yc 0.05 0 (deg-to-rad 360.0))
1ed0a2c5	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)
f7f58f90	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)
1ed0a2c5	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
108fea9b	127	(let ((image (make-instance 'cairo:image-surface
	128	:filename #p"clg:examples;romedalen.png")))
	129
1ed0a2c5	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
f7f58f90	148	(cairo:move-to cr 0.0 0.0)
f7f58f90	149	(cairo:line-to cr 1.0 1.0)
1ed0a2c5	150	(cairo:stroke cr))
	151
	152
f86d1eb7	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
890d2504	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))
f86d1eb7	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)))
1ed0a2c5	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
f7f58f90	214	(cairo:set-source-color cr 1.0 0.2 0.2 0.6)
1ed0a2c5	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
f7f58f90	250	(cairo:set-source-color cr 0.0 0.0 1.0)
1ed0a2c5	251	(cairo:fill cr t)
f7f58f90	252	(cairo:set-source-color cr 0.0 0.0 0.0)
1ed0a2c5	253	(cairo:stroke cr))
	254
	255
	256	(define-snippet fill-and-stroke (cr)
	257	(fill-and-stroke-common cr)
	258
f7f58f90	259	(cairo:set-source-color cr 0.0 0.0 1.0)
1ed0a2c5	260	(cairo:fill cr t)
f7f58f90	261	(cairo:set-source-color cr 0.0 0.0 0.0)
1ed0a2c5	262	(cairo:stroke cr))
	263
	264
c1e76b2d	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
1ed0a2c5	295	(define-snippet gradient (cr)
1ed0a2c5	296	(let ((pattern (cairo:pattern-create-linear 0.0 0.0 0.0 1.0)))
f7f58f90	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)
1ed0a2c5	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)))
f7f58f90	303	(cairo:pattern-add-color-stop pattern 0.0 1.0 1.0 1.0 1.0)
f7f58f90	304	(cairo:pattern-add-color-stop pattern 1.0 0.0 0.0 0.0 1.0)
1ed0a2c5	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)
108fea9b	311	(let ((image (make-instance 'cairo:image-surface
108fea9b	312	:filename #p"clg:examples;romedalen.png")))
1ed0a2c5	313	(cairo:translate cr 0.5 0.5)
f7f58f90	314	(cairo:rotate cr (deg-to-rad 45.0))
1ed0a2c5	315	(let ((width (cairo:surface-width image))
1ed0a2c5	316	(height (cairo:surface-height image)))
c1e76b2d	317	(cairo:scale cr (/ 1.0 width) (/ 1.0 height))
1ed0a2c5	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)
108fea9b	324	(let* ((image (make-instance 'cairo:image-surface
108fea9b	325	:filename #p"clg:examples;romedalen.png"))
1ed0a2c5	326	(pattern (cairo:pattern-create-for-surface image)))
	327	(setf (cairo:pattern-extend pattern) :repeat)
	328	(cairo:translate cr 0.5 0.5)
f7f58f90	329	(cairo:rotate cr (deg-to-rad 45.0))
f7f58f90	330	(cairo:scale cr (/ 1.0 (sqrt 2.0)) (/ 1.0 (sqrt 2.0)))
1ed0a2c5	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
f86d1eb7	342	#?(pkg-config:pkg-exists-p "librsvg-2.0" :atleast-version "2.13.93")
f86d1eb7	343	(progn
890d2504	344	(defun snippet-set-bg-svg (cr filename)
	345	(let ((handle (make-instance 'rsvg:handle :filename filename)))
	346	(cairo:with-context (cr)
9fdca80d	347	(with-slots (rsvg:width rsvg:height) handle
c4f672a3	348	(cairo:scale cr (/ 1.0 rsvg:width) (/ 1.0 rsvg:height))
9fdca80d	349	(rsvg:render-cairo handle cr)))))
890d2504	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)
c4f672a3	367
890d2504	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)
c4f672a3	383	)
1ed0a2c5	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
1ed0a2c5	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
f7f58f90	411	(cairo:set-source-color cr 1.0 0.2 0.2)
1ed0a2c5	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")
f7f58f90	454	(cairo:set-source-color cr 0.5 0.5 1.0)
1ed0a2c5	455	(cairo:fill cr t)
1ed0a2c5	456
f7f58f90	457	(cairo:set-source-color cr 0.0 0.0 0.0)
1ed0a2c5	458	(setf (cairo:line-width cr) 0.01)
	459	(cairo:stroke cr)
	460
	461	;; draw helping lines
f7f58f90	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))
1ed0a2c5	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
f86d1eb7	526	:stock "gtk-close" :can-default t
1ed0a2c5	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)
ec284c3d	539	:child (list (make-instance 'label
	540	:label (format nil "Cairo ~A" (cairo:version-string)))
	541	:fill nil)
1ed0a2c5	542	:child (list (make-instance 'label :label (clg-version)) :fill nil)
1ed0a2c5	543	:child (list (make-instance 'label
f86d1eb7	544	:label #-cmu
ec284c3d	545	(format nil "~A ~A"
f86d1eb7	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))))
1ed0a2c5	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))
890d2504	566	(setq snippets (sort snippets #'string<))))))
1ed0a2c5	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)
f86d1eb7	575	(rsvg:init)
890d2504	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
ddcb3b7d	583	(within-main-loop (create-tests))