;; 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)
-;;#+sbcl(require :rsvg)
-;;#+cmu(asdf:oos 'asdf:load-op :avg-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")
(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* ())
(defmacro define-snippet (name (cr) &body body)
(let ((widget (make-symbol "WIDGET"))
(window (make-symbol "WINDOW"))
- (pointer (make-symbol "POINTER")))
+ (event (make-symbol "EVENT")))
`(let ((,window nil))
- (setq *snippets* (pushnew ',name *snippets*))
+ (pushnew ',name *snippets*)
(defun ,name ()
(if (not ,window)
(let ((,widget (make-instance 'drawing-area)))
(signal-connect ,window 'destroy
#'(lambda () (setq ,window nil)))
(signal-connect ,widget 'expose-event
- #'(lambda (,pointer)
- (declare (ignore ,pointer))
- (let ((,cr (gdk:cairo-create (widget-window ,widget))))
+ #'(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))
(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)
(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))
(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))
-;; (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)))))
-
+(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)
(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)
(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)))
(let ((image (cairo:image-surface-create-from-png
#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))
(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))
(cairo:fill cr)))
-;; (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)))))
+#?(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"))
+(define-snippet librsvg (cr)
+ (snippet-set-bg-svg cr "clg:examples;home.svg"))
-(defmacro define-operator-snippet (operator)
- (let ((name (intern (format nil "OPERATOR-~A" 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)
-
- (cairo:set-source-color cr 0.0 1.0 0.0)
- (cairo:rectangle cr 0.4 0.4 0.4 0.4)
- (cairo:fill)
+(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))))
-
-;; (define-operator-snippet :add)
-;; (define-operator-snippet :atop)
-;; (define-operator-snippet :atop-reverse)
-;; (define-operator-snippet :in)
-;; (define-operator-snippet :in-reverse)
-;; (define-operator-snippet :out)
-;; (define-operator-snippet :out-reverse)
-;; (define-operator-snippet :over)
-;; (define-operator-snippet :over-reverse)
-;; (define-operator-snippet :saturate)
-;; (define-operator-snippet :xor)
+ (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)
+)
(cairo:stroke cr))
-;; (let ((path))
-;; (define-snippet pattern-fill (cr)
-;; (let ((spikes 10)
-;; (text "KAPOW!"))
-;; (unless path
-;; (let ((x-fuzz 0.08)
-;; (y-fuzz 0.08)
-;; (x-inner-radius 0.3)
-;; (y-inner-radius 0.2)
-;; (x-outer-radius 0.45)
-;; (y-outer-radius 0.35))
-;; (setq path (make-array (* 2 spikes)))
-;; (loop
-;; for i from 0 below (* 2 spikes)
-;; do (multiple-value-bind (x-radius y-radius)
-;; (if (evenp i)
-;; (values x-inner-radius y-inner-radius)
-;; (values x-outer-radius y-outer-radius))
-;; (setf
-;; (svref path i)
-;; (cons
-;; (+ 0.5 (* (cos (* pi (/ i spikes))) x-radius)
-;; (* (random 1.0) x-fuzz))
-;; (+ 0.5 (* (sin (* pi (/ i spikes))) y-radius)
-;; (* (random 1.0) y-fuzz))))))))
-
-;; (setf (cairo:line-width cr) 0.01)
-;; (cairo:move-to cr (car (svref path 0)) (cdr (svref path 0)))
-;; (loop
-;; for i from 1 below (* 2 spikes)
-;; do (cairo:line-to cr (car (svref path i)) (cdr (svref path i))))
-;; (cairo:close-path cr)
-;; (cairo:stroke cr)
-;; (cairo:move-to cr
-;; (car (svref path (1- spikes))) (cdr (svref path (1- spikes))))
-
-;; (cairo:select-font-face cr "Sans" :normal :bold)
-;; (time (cairo:text-path cr text))
-;; (cairo:set-source-color cr 1.0 1.0 0.5)
-;; (cairo:fill cr)
-
-;; (cairo:set-font-size cr 0.2)
-;; (let* ((extents (cairo:text-extents cr text))
-;; (x (- 0.5 (+ (* 0.5 (cairo:text-extents-width extents)) (cairo:text-extents-x-bearing extents))))
-;; (y (- 0.5 (+ (* 0.5 (cairo:text-extents-height extents)) (cairo:text-extents-y-bearing extents)))))
-
-;; (cairo:move-to cr x y)
-;; (cairo:text-path cr text)
-;; (cairo:set-source-color cr 0 0 0)
-;; (cairo:stroke cr)))))
-
-
-
(define-snippet set-line-cap (cr)
(setf (cairo:line-width cr) 0.12)
(setf (cairo:line-cap cr) :butt)
(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)
(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))
: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))))
: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)
:focus-vadjustment (scrolled-window-vadjustment scrolled-window)
:children (mapcar #'(lambda (snippet)
(create-button (string-downcase snippet) snippet))
- (sort *snippets* #'string<)))))
+ (setq *snippets* (sort *snippets* #'string<))))))
(scrolled-window-add-with-viewport scrolled-window content-box))
(widget-grab-focus close-button)
(clg-init)
-;;(rsvg: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
+;; 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)
+
+(create-tests)
~mdw / clg / blobdiff