X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/57c6905f20da19491b8f1384ad15f459313450f5..0bbf3105ee7496ce6748411458f2d22eb40479a9:/examples/testcairo.lisp diff --git a/examples/testcairo.lisp b/examples/testcairo.lisp index 31ce00d..9768b90 100644 --- a/examples/testcairo.lisp +++ b/examples/testcairo.lisp @@ -2,11 +2,17 @@ ;; See http://cairographics.org/samples/ #+sbcl(require :gtk) -#+cmu(asdf:oos 'asdf:load-op :gtk) #+sbcl(require :cairo) -#+cmu(asdf:oos 'asdf:load-op :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) -#+cmu(asdf:oos 'asdf:load-op :rsvg) +#+(or cmu clisp)(asdf:oos 'asdf:load-op :rsvg) (defpackage "TESTCAIRO" (:use "COMMON-LISP" "GTK") @@ -16,11 +22,11 @@ (in-package "TESTCAIRO") (declaim (inline deg-to-rad)) (defun deg-to-rad (deg) - (* deg (/ pi 180))) + (* deg (/ pi 180.0))) (declaim (inline rad-to-deg)) (defun rad-to-deg (rad) - (/ (* rad 180) pi)) + (/ (* rad 180.0) pi)) (defvar *snippets* ()) @@ -45,7 +51,7 @@ (defun ,name () (signal-connect ,widget 'expose-event #'(lambda (,event) (declare (ignore ,event)) - (let ((,cr (gdk:cairo-create (widget-window ,widget)))) + (gdk:with-cairo-context (,cr (widget-window ,widget)) (multiple-value-bind (width height) (widget-get-size-allocation ,widget) (cairo:scale ,cr width height)) @@ -58,8 +64,8 @@ (defun ,name () (defun arc-helper-lines (cr xc yc radius angle1 angle2) - (cairo:set-source-color cr 1 0.2 0.2 0.6) - (cairo:arc cr xc yc 0.05 0 (deg-to-rad 360)) + (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) @@ -105,11 +111,11 @@ (define-snippet 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 1 0) - (cairo:move-to cr 0 0) - (cairo:line-to cr 1 1) - (cairo:move-to cr 1 0) - (cairo:line-to cr 0 1) + (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)) @@ -118,9 +124,9 @@ (define-snippet clip-image (cr) (cairo:clip cr) (cairo:new-path cr) - (let ((image (cairo:image-surface-create-from-png - #p"clg:examples;romedalen.png"))) - + (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))) @@ -139,58 +145,59 @@ (define-snippet clip-rectangle (cr) (cairo:clip cr) - (cairo:move-to cr 0 0) - (cairo:line-to cr 1 1) + (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)) - (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) - - (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))))) - + (%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) @@ -204,7 +211,7 @@ (define-snippet curve-to (cr) (cairo:stroke cr) - (cairo:set-source-color cr 1 0.2 0.2 0.6) + (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) @@ -240,41 +247,41 @@ (define-snippet fill-and-stroke2 (cr) (cairo:rel-line-to cr -0.2 -0.2) (cairo:close-path cr) - (cairo:set-source-color cr 0 0 1) + (cairo:set-source-color cr 0.0 0.0 1.0) (cairo:fill cr t) - (cairo:set-source-color cr 0 0 0) + (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 1) + (cairo:set-source-color cr 0.0 0.0 1.0) (cairo:fill cr t) - (cairo:set-source-color cr 0 0 0) + (cairo:set-source-color cr 0.0 0.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 1) - (cairo:pattern-add-color-stop pattern 0 1 1 1 1) - (cairo:rectangle cr 0 0 1 1) + (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 1 1 1 1) - (cairo:pattern-add-color-stop pattern 1 0 0 0 1) + (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 (cairo:image-surface-create-from-png - #p"clg:examples;romedalen.png"))) + (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)) + (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)) @@ -284,13 +291,13 @@ (define-snippet image (cr) (define-snippet image-pattern (cr) - (let* ((image (cairo:image-surface-create-from-png - #p"clg:examples;romedalen.png")) + (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)) - (cairo:scale cr (/ 1.0 (sqrt 2)) (/ 1.0 (sqrt 2))) + (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)) @@ -302,12 +309,14 @@ (define-snippet image-pattern (cr) (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) (rsvg:handle-dimensions handle) - (cairo:scale cr (/ 1.0 rsvg:width) (/ 1.0 rsvg:height)) - (rsvg:cairo-render cr handle))))) + (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")) @@ -325,7 +334,7 @@ (defmacro define-operator-snippet (name operator) (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))) @@ -341,6 +350,7 @@ (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) +) @@ -368,7 +378,7 @@ (define-snippet set-line-cap (cr) (cairo:stroke cr) ;; draw helping lines - (cairo:set-source-color cr 1 0.2 0.2) + (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) @@ -411,17 +421,17 @@ (define-snippet text (cr) (cairo:move-to cr 0.27 0.65) (cairo:text-path cr "void") - (cairo:set-source-color cr 0.5 0.5 1) + (cairo:set-source-color cr 0.5 0.5 1.0) (cairo:fill cr t) - (cairo:set-source-color cr 0 0 0) + (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.2 0.2 0.6) - (cairo:arc cr 0.04 0.53 0.02 0 (deg-to-rad 360)) - (cairo:arc cr 0.27 0.65 0.02 0 (deg-to-rad 360)) + (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)) @@ -483,7 +493,7 @@ (defun create-tests () :vscrollbar-policy :automatic :border-width 10)) (close-button (make-instance 'button - :label "close" :can-default t + :stock "gtk-close" :can-default t :signal (list 'clicked #'widget-destroy :object main-window)))) @@ -499,9 +509,14 @@ (defun create-tests () :child (list (make-instance 'label :label (gtk-version)) :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) - (lisp-implementation-version)) + :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) @@ -533,4 +548,4 @@ (rsvg:init) #+sbcl(sb-int:set-floating-point-modes :traps nil) #+cmu(ext:set-floating-point-modes :traps nil) -(create-tests) +(within-main-loop (create-tests))