X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/1dea177e44bef96e14991417c97fa0ee9643fb4b..279277515c62b8e1e47bc7c2b1867638013ada5a:/examples/testcairo.lisp diff --git a/examples/testcairo.lisp b/examples/testcairo.lisp index b135ef6..41b7230 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.13.93") + (warn "SVG tests disabled as the required version of librsvg is not available."))) + +#?(pkg-config:pkg-exists-p "librsvg-2.0" :atleast-version "2.13.93") #+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") @@ -45,7 +51,7 @@ (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)) @@ -144,53 +150,54 @@ (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) @@ -302,11 +309,13 @@ (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)) + (cairo:scale cr (/ 1.0 rsvg:width) (/ 1.0 rsvg:height)) (rsvg:render-cairo handle cr))))) (define-snippet librsvg (cr) @@ -325,7 +334,7 @@ (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-reverse :dest-over) (define-operator-snippet operator-saturate :saturate) (define-operator-snippet operator-xor :xor) +) @@ -483,7 +493,7 @@ :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 @@ :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) @@ -525,6 +540,7 @@ (clg-init) +#?(pkg-config:pkg-exists-p "librsvg-2.0" :atleast-version "2.13.93") (rsvg:init) ;; We need to turn off floating point exceptions, because Cairo is