X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/c4f672a3a87428b02668e5e4ac70a418345e72ee..7d2f9e31f958431da7dc2ab4ce7091747ad96510:/examples/testcairo.lisp diff --git a/examples/testcairo.lisp b/examples/testcairo.lisp index 6e90316..9768b90 100644 --- a/examples/testcairo.lisp +++ b/examples/testcairo.lisp @@ -2,18 +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) - (if (pkg-config:pkg-exists-p "librsvg-2.0" :atleast-version "2.13.93" :error nil) - (push :rsvg *features*) + (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."))) - -#+(and sbcl rsvg)(require :rsvg) -#+(and cmu rsvg)(asdf:oos 'asdf:load-op :rsvg) +#?(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") @@ -23,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* ()) @@ -52,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)) @@ -65,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) @@ -112,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)) @@ -125,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))) @@ -146,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) @@ -211,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) @@ -247,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)) @@ -291,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)) @@ -309,7 +309,8 @@ (define-snippet image-pattern (cr) (cairo:fill cr))) -#+rsvg(progn +#?(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) @@ -377,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) @@ -420,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)) @@ -492,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)))) @@ -508,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) @@ -534,7 +540,7 @@ (defun create-tests () (clg-init) -#+rsvg(rsvg:init) +(rsvg:init) ;; We need to turn off floating point exceptions, because Cairo is ;; presumably using internal code which generates NaNs in some cases. @@ -542,4 +548,4 @@ (clg-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))