Initial checkin

diff --git a/cairo/cairo.asd b/cairo/cairo.asd
new file mode 100644 (file)
index 0000000..d7bada9
--- /dev/null
+++ b/cairo/cairo.asd
@@ -0,0 +1,18 @@
+;;; -*- Mode: lisp -*-
+
+(defpackage "CAIRO-SYSTEM"
+  (:use "COMMON-LISP" "ASDF" "PKG-CONFIG"))
+
+
+(in-package "CAIRO-SYSTEM")
+
+(pkg-exists-p "cairo" :atleast-version "1.0.2")
+
+
+(defsystem cairo
+    :depends-on (glib)
+    :components ((:library "libcairo" 
+                 :libdir #.(pkg-variable "cairo" "libdir"))
+                (:file "defpackage")
+                (:file "cairo" :depends-on ("defpackage" "libcairo"))
+                (:file "export" :depends-on ("cairo"))))

diff --git a/cairo/cairo.lisp b/cairo/cairo.lisp
new file mode 100644 (file)
index 0000000..acff762
--- /dev/null
+++ b/cairo/cairo.lisp
@@ -0,0 +1,832 @@
+;; Common Lisp bindings for Cairo
+;; Copyright 2005 Espen S. Johnsen <espen@users.sf.net>
+;;
+;; Permission is hereby granted, free of charge, to any person obtaining
+;; a copy of this software and associated documentation files (the
+;; "Software"), to deal in the Software without restriction, including
+;; without limitation the rights to use, copy, modify, merge, publish,
+;; distribute, sublicense, and/or sell copies of the Software, and to
+;; permit persons to whom the Software is furnished to do so, subject to
+;; the following conditions:
+;;
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+;;
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+;; $Id: cairo.lisp,v 1.1 2005/11/10 08:50:45 espen Exp $
+
+(in-package "CAIRO")
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (define-enum-type surface-format :argb32 :rgb24 :a8 :a1)
+
+  (define-enum-type status
+    :success :no-memory :invalid-restore :invalid-pop-group
+    :no-current-point :invalid-matrix :invalid-status :null-pointer
+    :invalid-string :invalid-path-data :read-error :write-error
+    :surface-finished :surface-type-mismatch :pattern-type-mismatch
+    :invalid-content :invalid-format :invalid-visual :file-not-found
+    :invalid-dash)
+
+  (define-enum-type fill-rule :winding :even-odd)
+  (define-enum-type line-cap :butt :round :square)
+  (define-enum-type line-join :miter :round :bevel)    
+  (define-enum-type font-slant :normal :itaic :oblique)
+  (define-enum-type font-weight :normal :bold)
+
+  (define-enum-type operator
+   :clear :source :over :in :out :atop :dest :dest-over 
+   :dest-in :dest-out :dest-atop :xor :add :saturate)
+
+  (define-enum-type antialias :default :none :gray :subpixel)
+  (define-enum-type extend :none :repeat :reflect)
+  (define-enum-type filter :fast :good :best :nearest :bilinear :gaussian)
+  (define-enum-type subpixel-order :default :rgb :bgr :vrgb :vbgr)
+  (define-enum-type hint-style :default :none :slight :medium :full)
+  (define-enum-type hint-metrics :default :off :on)
+
+  (defclass glyph (proxy)
+    ((index 
+      :allocation :alien 
+      :initarg :index 
+      :accessor glyph-index 
+      :type unsigned-long)
+     (x     
+      :allocation :alien 
+      :initarg :x 
+      :accessor glyph-x 
+      :type double-float)
+     (y     
+      :allocation :alien 
+      :initarg :y 
+      :accessor glyph-y
+      :type double-float))
+    (:metaclass struct-class))
+
+  (defclass font-face (proxy)
+    ()
+    (:metaclass proxy-class))
+
+  (defclass font-options (proxy)
+    ((antialias
+      :allocation :virtual 
+      :getter "font_options_get_antialias"
+      :setter "font_options_set_antialias"
+      :accessor font-options-antialias
+      :type antialias)
+     (subpixel-order
+      :allocation :virtual 
+      :getter "font_options_get_subpixel_order"
+      :setter "font_options_set_subpixel_order"
+      :accessor font-options-subpixel-order
+      :type subpixel-order)
+     (hint-style
+      :allocation :virtual 
+      :getter "font_options_get_hint_style"
+      :setter "font_options_set_hint_style"
+      :accessor font-options-hint-style
+      :type hint-style)
+     (hint-metrics
+      :allocation :virtual 
+      :getter "font_options_get_hint_metrics"
+      :setter "font_options_set_hint_metrics"
+      :accessor font-options-hint-metrics
+      :type hint-metrics))
+    (:metaclass proxy-class))
+
+  (defclass scaled-font (proxy)
+    ()
+    (:metaclass proxy-class))
+
+  (defclass matrix (struct)
+    ((xx :allocation :alien :initarg :xx :initform 1.0
+        :accessor matrix-xx :type double-float)
+     (yx :allocation :alien  :initarg :yx :initform 0.0
+        :accessor matrix-yx :type double-float)
+     (xy :allocation :alien  :initarg :xy :initform 1.0
+        :accessor matrix-xy :type double-float)
+     (yy :allocation :alien  :initarg :yy :initform 0.0
+        :accessor matrix-yy :type double-float)
+     (x0 :allocation :alien  :initarg :x0 :initform 0.0
+        :accessor matrix-x0 :type double-float)
+     (y0 :allocation :alien  :initarg :y0 :initform 0.0
+        :accessor matrix-y0 :type double-float))
+    (:metaclass struct-class))
+
+
+  (defclass text-extents (struct)
+    ((x-bearing :allocation :alien :reader text-extents-x-bearing :type double-float)
+     (y-bearing :allocation :alien :reader text-extents-y-bearing :type double-float)
+     (width :allocation :alien :reader text-extents-width :type double-float)
+     (height :allocation :alien :reader text-extents-height :type double-float)
+     (x-advance :allocation :alien :reader text-extents-x-advance :type double-float)
+     (y-advance :allocation :alien :reader text-extents-y-advance :type double-float))
+    (:metaclass struct-class))
+
+  (defclass pattern (proxy)
+    ((extend
+      :allocation :virtual 
+      :getter "cairo_pattern_get_extend"
+      :setter "cairo_pattern_set_extend"
+      :accessor pattern-extend
+      :type extend)
+     (filter
+      :allocation :virtual 
+      :getter "cairo_pattern_get_filter"
+      :setter "cairo_pattern_set_filter"
+      :accessor pattern-filter
+      :type filter)
+     (matrix
+      :allocation :virtual 
+      :getter "cairo_pattern_get_matrix"
+      :setter "cairo_pattern_set_matrix"
+      :accessor pattern-matrix
+      :type matrix))
+    (:metaclass proxy-class))
+
+  (defclass context (proxy)
+    ((target
+      :allocation :virtual 
+      :getter "cairo_get_target"
+      :reader target
+      :type surface)
+     (source
+      :allocation :virtual 
+      :getter "cairo_get_source"
+      :setter "cairo_set_source"
+      :accessor source
+      :type pattern)
+     (antialias
+      :allocation :virtual 
+      :getter "cairo_get_antialias"
+      :setter "cairo_set_antialias"
+      :accessor antialias
+      :type antialias)
+     (tolerance
+      :allocation :virtual 
+      :getter "cairo_get_tolerance"
+      :setter "cairo_set_tolerance"
+      :accessor tolerance
+      :type double-float)
+     (fill-rule
+      :allocation :virtual 
+      :getter "cairo_get_fill_rule"
+      :setter "cairo_set_fill_rule"
+      :accessor fill-rule
+      :type fill-rule)
+     (line-width
+      :allocation :virtual 
+      :getter "cairo_get_line_width"
+      :setter "cairo_set_line_width"
+      :accessor line-width
+      :type double-float)
+     (line-cap
+      :allocation :virtual 
+      :getter "cairo_get_line_cap"
+      :setter "cairo_set_line_cap"
+      :accessor line-cap
+      :type line-cap)
+     (line-join
+      :allocation :virtual 
+      :getter "cairo_get_line_join"
+      :setter "cairo_set_line_join"
+      :accessor line-join
+      :type line-join)
+     (miter-limit
+      :allocation :virtual 
+      :getter "cairo_get_miter_limit"
+      :setter "cairo_set_miter_limit"
+      :accessor miter-limit
+      :type double-float)
+     (font-matrix
+      :allocation :virtual 
+      :getter "cairo_get_font_matrix"
+      :setter "cairo_set_font_matrix"
+      :accessor font-matrix
+      :type matrix)
+     (font-options
+      :allocation :virtual 
+      :getter "cairo_get_font_options"
+      :setter "cairo_set_font_options"
+      :accessor font-options
+      :type font-options)
+     (font-face
+      :allocation :virtual 
+      :getter "cairo_get_font_face"
+      :setter "cairo_set_font_face"
+      :accessor font-face
+      :type font-face)
+     (operator
+      :allocation :virtual 
+      :getter "cairo_get_operator"
+      :setter "cairo_set_operator"
+      :accessor operator
+      :type operator)
+     (matrix
+      :allocation :virtual 
+      :getter matrix
+      :setter "cairo_set_matrix"
+      :writer (setf matrix)
+      :type matrix)
+     )
+    (:metaclass proxy-class))
+
+  (defclass surface (proxy)
+    ()
+    (:metaclass proxy-class))
+
+  (defclass image-surface (surface)
+    ((width
+      :allocation :virtual 
+      :getter "cairo_image_surface_get_width"
+      :reader surface-width
+      :type int)
+     (height
+      :allocation :virtual 
+      :getter "cairo_image_surface_get_height"
+      :reader surface-height
+      :type int))
+    (:metaclass proxy-class))
+
+;;   (defclass path (proxy)
+;;     ()
+;;     (:metaclass proxy-class))
+
+)
+
+
+;;; Cairo context
+
+(defbinding %reference () nil
+  (location pointer))
+
+(defbinding %destroy () nil
+  (location pointer))
+
+(defmethod reference-foreign ((class (eql (find-class 'context))) location)
+  (%reference location))
+
+(defmethod unreference-foreign ((class (eql (find-class 'context))) location)
+  (%destroy location))
+
+(defbinding (save-context "cairo_save") () nil
+  (cr context))
+
+(defbinding (restore-context "cairo_restore") () nil
+  (cr context))
+
+(defmacro with-context ((cr) &body body)
+  (let ((context (make-symbol "CONTEXT")))
+    `(let ((,context ,cr))
+       (save-context ,context)
+       (unwind-protect
+          (progn ,@body)
+        (restore-context ,context)))))
+
+(defbinding status () status
+  (cr context))
+
+(defbinding (set-source-color "cairo_set_source_rgba") (cr red green blue &optional (alpha 1.0)) nil
+  (cr context)
+  (red double-float)
+  (green double-float)
+  (blue double-float)
+  (alpha double-float))
+
+(defbinding set-source-surface () nil
+  (cr context)
+  (surface surface)
+  (x double-float)
+  (y double-float))
+
+(defbinding set-dash (cr dashes &optional (offset 0.0)) nil
+  (cr context)
+  (dashes (vector double-float))
+  ((length dashes) int)
+  (offset double-float))
+
+(defbinding (paint "cairo_paint_with_alpha") (cr &optional (alpha 1.0)) nil
+  (cr context)
+  (alpha double-float))
+
+(defbinding mask () nil
+  (cr context)
+  (pattern pattern))
+
+(defbinding mask-surface () nil
+  (cr context)
+  (surface surface)
+  (surface-x double-float)
+  (surface-y double-float))
+
+(defmacro defoperator (name &optional clip-p)
+  (let ((iname (intern (format nil "%~A" name)))
+       (pname (intern (format nil "%~A-PRESERVE" name))))
+    `(progn
+       (defbinding ,iname () nil
+        (cr context))
+       (defbinding ,pname () nil
+        (cr context))
+       (defun ,name (cr &optional preserve)
+        (if preserve
+            (,pname cr)
+          (,iname cr)))
+       ,(unless clip-p
+         (let ((tname (intern (format nil "IN~A-P" name)))
+               (ename (intern (format nil "~A-EXTENTS" name))))
+           `(progn
+              (defbinding ,tname () boolean
+                (cr context)
+                (x double-float)
+                (y double-float))
+              (defbinding ,ename () boolean
+                (cr context)
+                (x1 double-float :out)
+                (y1 double-float :out)
+                (x2 double-float :out)
+                (y2 double-float :out))))))))
+
+(defoperator clip t)
+(defoperator stroke)
+(defoperator fill)
+
+(defbinding reset-clip () nil
+  (cr context))
+
+(defbinding copy-page () nil
+  (cr context))
+
+(defbinding show-page () nil
+  (cr context))
+
+
+;;; Paths
+
+(defbinding get-current-point () nil
+  (cr context)
+  (x double-float :out)
+  (y double-float :out))
+
+(defbinding new-path () nil
+  (cr context))
+
+(defbinding close-path () nil
+  (cr context))
+
+(defbinding arc () nil
+  (cr context)
+  (xc double-float)
+  (yc double-float)
+  (radius double-float)
+  (angle1 double-float)
+  (angle2 double-float))
+
+(defbinding arc-negative () nil
+  (cr context)
+  (xc double-float)
+  (yc double-float)
+  (radius double-float)
+  (angle1 double-float)
+  (angle2 double-float))
+
+(defun circle (cr x y radius)
+  (arc cr x y radius 0.0 (* pi 2)))
+
+(defmacro defpath (name &rest args)
+  (let ((relname (intern (format nil "REL-~A" name))))
+    `(progn
+       (defbinding ,name () nil
+        (cr context)
+        ,@args)
+       (defbinding ,relname () nil
+        (cr context)
+        ,@args))))
+
+(defpath curve-to
+  (x1 double-float)
+  (y1 double-float)
+  (x2 double-float)
+  (y2 double-float)
+  (x3 double-float)
+  (y3 double-float))
+
+(defpath line-to
+  (x double-float)
+  (y double-float))
+
+(defpath move-to
+  (x double-float)
+  (y double-float))
+
+(defbinding rectangle () nil
+  (cr context)
+  (x double-float)
+  (y double-float)
+  (width double-float)
+  (height double-float))
+
+(defbinding glyph-path (cr glyphs) nil
+  (cr context)
+  (glyphs (vector glyph))
+  ((length glyphs) int))
+
+(defbinding text-path () nil
+  (cr context)
+  (text string))
+
+
+
+;;; Patterns
+
+(defbinding (pattern-add-color-stop "cairo_pattern_add_color_stop_rgba")
+    (pattern offset red green blue &optional (alpha 1.0)) nil
+  (pattern pattern)
+  (offset double-float)
+  (red double-float)
+  (green double-float)
+  (blue double-float)
+  (alpha double-float))
+
+(defbinding (pattern-create "cairo_pattern_create_rgba")
+    (red green blue &optional (alpha 1.0)) pattern   
+  (red double-float)
+  (green double-float)
+  (blue double-float)
+  (alpha double-float))
+
+(defbinding pattern-create-for-surface () pattern
+  (surface surface))
+
+(defbinding pattern-create-linear () pattern
+  (x0 double-float)
+  (y0 double-float)
+  (x1 double-float)
+  (y1 double-float))
+
+(defbinding pattern-create-radial () pattern
+  (cx0 double-float)
+  (cy0 double-float)
+  (radius0 double-float)
+  (cx1 double-float)
+  (cy1 double-float)
+  (radius1 double-float))
+
+(defbinding %pattern-reference () nil
+  (location pointer))
+
+(defbinding %pattern-destroy () nil
+  (location pointer))
+
+(defmethod reference-foreign ((class (eql (find-class 'pattern))) location)
+  (%pattern-reference location))
+
+(defmethod unreference-foreign ((class (eql (find-class 'pattern))) location)
+  (%pattern-destroy location))
+
+(defbinding pattern-status () status
+  (pattern pattern))
+
+
+
+;;; Transformations
+
+(defbinding translate () nil
+  (cr context)
+  (tx double-float)
+  (ty double-float))
+
+(defbinding scale () nil
+  (cr context)
+  (sx double-float)
+  (sy double-float))
+
+(defbinding rotate () nil
+  (cr context)
+  (angle double-float))
+
+(defbinding transform () nil
+  (cr context)
+  (matrix matrix))
+
+(defbinding (matrix "cairo_get_matrix") () nil
+  (cr context)
+  ((make-instance 'matrix) matrix :return))
+
+(defbinding identity-matrix () nil
+  (cr context))
+
+(defbinding user-to-device () nil
+  (cr context)
+  (x double-float :in-out)
+  (y double-float :in-out))
+
+(defbinding user-to-device-distance () nil
+  (cr context)
+  (dx double-float :in-out)
+  (dy double-float :in-out))
+
+(defbinding device-to-user () nil
+  (cr context)
+  (x double-float :in-out)
+  (y double-float :in-out))
+
+(defbinding device-to-user-distance () nil
+  (cr context)
+  (dx double-float :in-out)
+  (dy double-float :in-out))
+
+
+;;; Text
+
+(defbinding select-font-face () nil
+  (cr context)
+  (family string)
+  (slant font-slant)
+  (weight font-weight))
+
+(defbinding set-font-size () nil
+  (cr context)
+  (size double-float))
+
+(defbinding show-text () nil
+  (cr context)
+  (text string))
+
+(defbinding show-glyphs () nil
+  (cr context)
+  (glyphs (vector glyph))
+  ((length glyphs) int))
+
+(defbinding font-extents () boolean
+  (cr context))
+
+(defbinding text-extents (cr text &optional (extents (make-instance 'text-extents))) nil
+  (cr context)
+  (text string)
+  (extents text-extents :return))
+
+(defbinding glyph-extents (cr glyphs &optional (extents (make-instance 'text-extents))) nil
+  (cr context)
+  (glyphs (vector glyph))
+  ((length glyphs) int)
+  (extents text-extents :return))
+
+
+;;; Fonts
+
+(defbinding %font-face-reference () nil
+  (location pointer))
+
+(defbinding %font-face-destroy () nil
+  (location pointer))
+
+(defmethod reference-foreign ((class (eql (find-class 'font-face))) location)
+  (%font-face-reference location))
+
+(defmethod unreference-foreign ((class (eql (find-class 'font-face))) location)
+  (%font-face-destroy location))
+
+(defbinding font-face-status () status
+  (font-face font-face))
+
+
+
+;;; Scaled Fonts
+
+(defbinding %scaled-font-reference () nil
+  (location pointer))
+
+(defbinding %scaled-font-destroy () nil
+  (location pointer))
+
+(defmethod reference-foreign ((class (eql (find-class 'scaled-font))) location)
+  (%scaled-font-reference location))
+
+(defmethod unreference-foreign ((class (eql (find-class 'scaled-font))) location)
+  (%scaled-font-destroy location))
+
+(defbinding scaled-font-status () status
+  (scaled-font scaled-font))
+
+(defbinding scaled-font-extents (scaled-font &optional (extents (make-instance 'text-extents))) nil
+  (scaled-font scaled-font)
+  (extents text-extents :return))
+
+(defbinding scaled-font-glyph-extents (scaled-font glyphs &optional (extents (make-instance 'text-extents))) nil
+  (scaled-font scaled-font)
+  (glyphs (vector glyph))
+  ((length glyphs) int)
+  (extents text-extents :return))
+
+(defbinding %scaled-font-create () pointer
+  (font-face font-face)
+  (font-matrix matrix)
+  (ctm matrix)
+  (options font-options))
+
+(defmethod initialize-instance ((scaled-font scaled-font) &key font-face font-matrix cmt options)
+  (setf
+   (slot-value scaled-font 'location)
+   (%scaled-font-create font-face font-matrix cmt options))
+  (call-next-method))
+
+
+
+;;; Font Options
+
+
+(defbinding %font-options-copy () nil
+  (location pointer))
+
+(defbinding %font-options-destroy () nil
+  (location pointer))
+
+(defmethod reference-foreign ((class (eql (find-class 'font-options))) location)
+  (%font-options-reference location))
+
+(defmethod unreference-foreign ((class (eql (find-class 'font-options))) location)
+  (%font-options-destroy location))
+
+(defbinding font-options-status () status
+  (font-options font-options))
+
+(defbinding %font-options-create () pointer)
+
+(defmethod initialize-instance ((font-options font-options) &rest initargs)
+  (declare (ignore initargs))
+  (setf (slot-value font-options 'location) (%font-options-create))
+  (call-next-method))
+
+(defbinding font-options-merge () nil
+  (options1 font-options :return)
+  (options2 font-options))
+
+(defbinding font-options-hash () unsigned-int
+  (options font-options))
+
+(defbinding font-options-equal-p () boolean
+  (options1 font-options)
+  (options2 font-options))
+
+
+
+;;; Surfaces
+
+(defbinding %surface-reference () nil
+  (location pointer))
+
+(defbinding %surface-destroy () nil
+  (location pointer))
+
+(defmethod reference-foreign ((class (eql (find-class 'surface))) location)
+  (%surface-reference location))
+
+(defmethod unreference-foreign ((class (eql (find-class 'surface))) location)
+  (%surface-destroy location))
+
+(defbinding surface-create-similar () surface
+  (other surface)
+  (format surface-format )
+  (width int)
+  (height int))
+
+(defbinding surface-finish () nil
+  (surface surface))
+
+(defbinding surface-flush () nil
+  (surface surface))
+
+(defbinding surface-get-font-options () nil
+  (surface surface)
+  ((make-instance 'font-options) font-options :return))
+
+(defbinding surface-set-device-offset () nil
+  (surface surface)
+  (x-offset double-float)
+  (y-offset double-float))
+
+(defbinding surface-status () status
+  (surface surface))
+
+(defbinding %surface-mark-dirty () nil
+  (surface surface))
+
+(defbinding %surface-mark-dirty-rectangle () nil
+  (surface surface)
+  (x int)
+  (y int)
+  (width int)
+  (height int))
+
+(defun surface-mark-dirty (surface &optional x y width height)
+  (if x
+      (%surface-mark-dirty-rectangle surface x y width height)
+    (%surface-mark-dirty surface)))
+
+
+
+;; Image Surface
+
+;; Should data be automatically freed when the surface is GCed?
+(defmethod initialize-instance ((surface image-surface) 
+                               &key width height stride format data)
+  (setf 
+   (slot-value surface 'location)
+   (if (not data)
+       (%image-surface-create format width height)
+     (%image-surface-create-for-data data format width height 
+      (or 
+       stride
+       (let ((element-size (cdr (assoc format '((:argb32 . 4) (:rgb24 . 4) (:a8 . 1) (:a1 1/8))))))
+        (ceiling (* width element-size)))))))
+  (call-next-method))
+
+
+(defbinding %image-surface-create () image-surface
+  (format surface-format)
+  (width int)
+  (hegit int))
+
+(defbinding %image-surface-create-for-data () image-surface
+  (data pointer)
+  (format surface-format)
+  (width int)
+  (hegit int)
+  (stride int))
+
+
+
+;;; PNG Surface
+
+(defbinding image-surface-create-from-png (filename) image-surface
+  ((truename filename) pathname))
+
+
+
+
+;;; Matrices
+
+(defbinding matrix-init () nil
+  (matrix matrix :return)
+  (xx double-float) (yx double-float) 
+  (xy double-float) (yy double-float) 
+  (x0 double-float) (y0 double-float))
+
+(defbinding matrix-init-identity () nil
+  (matrix matrix :return))
+
+(defbinding matrix-init-translate () nil
+  (matrix matrix :return)
+  (tx double-float)
+  (ty double-float))
+
+(defbinding matrix-init-scale () nil
+  (matrix matrix :return)
+  (sx double-float)
+  (sy double-float))
+
+(defbinding matrix-init-rotate () nil
+  (matrix matrix :return)
+  (radians double-float))
+
+(defbinding matrix-translate () nil
+  (matrix matrix :return)
+  (tx double-float)
+  (ty double-float))
+
+(defbinding matrix-scale () nil
+  (matrix matrix :return)
+  (sx double-float)
+  (sy double-float))
+
+(defbinding matrix-rotate () nil
+  (matrix matrix :return)
+  (radians double-float))
+
+(defbinding matrix-invert () nil
+  (matrix matrix :return))
+
+(defbinding matrix-multiply () nil
+  (result matrix :out)
+  (a matrix)
+  (b matrix))
+
+(defbinding matrix-transform-distance () nil
+  (matrix matrix :return)
+  (dx double-float)
+  (dy double-float))
+
+(defbinding matrix-transform-point () nil
+  (matrix matrix :return)
+  (x double-float)
+  (y double-float))
+
+
+

diff --git a/cairo/defpackage.lisp b/cairo/defpackage.lisp
new file mode 100644 (file)
index 0000000..631beb7
--- /dev/null
+++ b/cairo/defpackage.lisp
@@ -0,0 +1,4 @@
+(defpackage "CAIRO"
+  (:use "COMMON-LISP" "GLIB" "AUTOEXPORT")
+  (:shadow "FILL"))
+

diff --git a/cairo/export.lisp b/cairo/export.lisp
new file mode 100644 (file)
index 0000000..d3e084f
--- /dev/null
+++ b/cairo/export.lisp
@@ -0,0 +1,18 @@
+(in-package "CAIRO")
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defexport defoperator (name &optional clip-p)
+    (if clip-p
+       name
+      (let ((tname (intern (format nil "IN~A-P" name)))
+           (ename (intern (format nil "~A-EXTENTS" name))))
+       (list name tname ename))))
+
+  (defexport defpath (name &rest args)
+    (declare (ignore args))
+    (list name (intern (format nil "REL-~A" name)))))
+
+
+;;; Autogenerating exported symbols
+(export-from-file #p"clg:cairo;cairo.lisp")
+  
\ No newline at end of file

diff --git a/examples/freedesktop.svg b/examples/freedesktop.svg
new file mode 100644 (file)
index 0000000..aef3899
--- /dev/null
+++ b/examples/freedesktop.svg
@@ -0,0 +1,45 @@
+<?xml version="1.0" encoding="UTF-8" standalone="no"?>
+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.0//EN"
+"http://www.w3.org/TR/2001/REC-SVG-20010904/DTD/svg10.dtd">
+<!-- Created with Inkscape (http://www.inkscape.org/) -->
+<svg
+   xmlns="http://www.w3.org/2000/svg"
+   xmlns:xlink="http://www.w3.org/1999/xlink"
+   version="1.0"
+   x="0.0000000"
+   y="0.0000000"
+   width="111.60000"
+   height="96.112503"
+   id="svg968">
+  <defs
+     id="defs970" />
+  <g
+     transform="translate(14.09647,16.85030)"
+     style="fill:#ffffff;stroke:#3b80ae;stroke-width:2.4588001;"
+     id="g862">
+    <g
+       id="g864">
+      <path
+         d="M 85.277000,40.796000 C 87.335000,48.680000 82.610000,56.738000 74.726000,58.795000 L 27.143000,71.210000 C 19.259000,73.267000 11.200000,68.543000 9.1430000,60.658000 L 1.6950000,32.108000 C -0.36200000,24.224000 4.3620000,16.166000 12.246000,14.109000 L 59.830000,1.6950000 C 67.714000,-0.36200000 75.772000,4.3620000 77.829000,12.246000 L 85.278000,40.796000 L 85.277000,40.796000 z "
+         style="stroke:#bababa;"
+         id="path866" />
+      <path
+         d="M 80.444000,39.778000 C 82.193000,47.632000 78.628000,53.399000 70.940000,55.225000 L 28.704000,66.245000 C 21.135000,68.641000 14.615000,65.064000 12.866000,57.409000 L 6.5300000,33.127000 C 4.7810000,24.982000 7.2390000,20.238000 16.033000,17.680000 L 58.270000,6.6610000 C 66.414000,4.8350000 72.359000,8.0240000 74.108000,15.496000 L 80.444000,39.778000 L 80.444000,39.778000 z "
+         style="fill:#3b80ae;stroke:none;"
+         id="path868" />
+    </g>
+    <path
+       d="M 45.542000,51.793000 L 24.104000,31.102000 L 62.204000,26.709000 L 45.542000,51.793000 z "
+       style="opacity:0.49999997;fill:none;stroke:#ffffff;"
+       id="path871" />
+    <path
+       d="M 72.325000,28.769000 C 72.730000,30.319000 71.800000,31.905000 70.250000,32.310000 L 57.919000,35.527000 C 56.368000,35.931000 54.782000,35.002000 54.377000,33.451000 L 52.082000,24.650000 C 51.677000,23.099000 52.606000,21.513000 54.158000,21.108000 L 66.488000,17.891000 C 68.039000,17.486000 69.625000,18.416000 70.030000,19.967000 L 72.325000,28.768000 L 72.325000,28.769000 z "
+       id="path873" />
+    <path
+       d="M 36.510000,33.625000 C 37.006000,35.525000 35.865000,37.469000 33.965000,37.965000 L 18.853000,41.908000 C 16.952000,42.404000 15.008000,41.264000 14.513000,39.364000 L 11.699000,28.578000 C 11.203000,26.677000 12.343000,24.734000 14.243000,24.238000 L 29.356000,20.296000 C 31.257000,19.800000 33.201000,20.939000 33.696000,22.840000 L 36.510000,33.626000 L 36.510000,33.625000 z "
+       id="path875" />
+    <path
+       d="M 52.493000,53.208000 C 52.771000,54.273000 52.133000,55.362000 51.068000,55.640000 L 42.600000,57.848000 C 41.536000,58.125000 40.447000,57.488000 40.169000,56.422000 L 38.592000,50.379000 C 38.315000,49.315000 38.952000,48.226000 40.017000,47.947000 L 48.485000,45.738000 C 49.549000,45.461000 50.639000,46.099000 50.916000,47.164000 L 52.493000,53.207000 L 52.493000,53.208000 z "
+       id="path877" />
+  </g>
+</svg>

diff --git a/examples/home.svg b/examples/home.svg
new file mode 100644 (file)
index 0000000..1e6e9ef
--- /dev/null
+++ b/examples/home.svg
@@ -0,0 +1,172 @@
+<?xml version="1.0" standalone="no"?>
+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 20010904//EN"
+"http://www.w3.org/TR/2001/REC-SVG-20010904/DTD/svg10.dtd">
+<svg
+   style="fill:#000000;fill-opacity:0.5;stroke:none"
+   width="595.275591"
+   height="841.889764"
+   id="svg32"
+   sodipodi:docbase="/home/mira/"
+   sodipodi:docname="/home/mira/HOME.SVG"
+   xmlns="http://www.w3.org/2000/svg"
+   xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd"
+   xmlns:xlink="http://www.w3.org/1999/xlink">
+  <defs
+     id="defs34">
+    <linearGradient
+       id="linearGradient60">
+      <stop
+         style="stop-color:#fffa00;stop-opacity:1;"
+         offset="0.000000"
+         id="stop61" />
+      <stop
+         style="stop-color:#ffffff;stop-opacity:1;"
+         offset="1.000000"
+         id="stop62" />
+    </linearGradient>
+    <linearGradient
+       id="linearGradient57">
+      <stop
+         style="stop-color:#b55f07;stop-opacity:1;"
+         offset="0.000000"
+         id="stop58" />
+      <stop
+         style="stop-color:#ffba00;stop-opacity:1;"
+         offset="1.000000"
+         id="stop59" />
+    </linearGradient>
+    <linearGradient
+       id="linearGradient129">
+      <stop
+         style="stop-color:#ffffff;stop-opacity:0.803922;"
+         offset="0.000000"
+         id="stop130" />
+      <stop
+         style="stop-color:#000000;stop-opacity:0;"
+         offset="1.000000"
+         id="stop131" />
+    </linearGradient>
+    <linearGradient
+       xlink:href="#linearGradient129"
+       id="linearGradient132"
+       x1="0.29393"
+       y1="0.125996"
+       x2="0.85623"
+       y2="1.0028" />
+    <linearGradient
+       xlink:href="#linearGradient129"
+       id="linearGradient142"
+       x1="0.877848"
+       y1="0.382857"
+       x2="0.014196"
+       y2="0.388571" />
+    <linearGradient
+       xlink:href="#linearGradient129"
+       id="linearGradient48"
+       x1="1.45453"
+       y1="0.508571"
+       x2="0.0661232"
+       y2="0.542857" />
+    <linearGradient
+       x1="0.493086"
+       y1="0.428571"
+       x2="0.57144"
+       y2="0.514286"
+       xlink:href="#linearGradient129"
+       id="linearGradient49" />
+    <linearGradient
+       x1="0.450624"
+       y1="0.428571"
+       x2="0.407689"
+       y2="0.474286"
+       xlink:href="#linearGradient129"
+       id="linearGradient50" />
+    <linearGradient
+       xlink:href="#linearGradient57"
+       id="linearGradient53"
+       x1="-0.0101793"
+       y1="0.611429"
+       x2="0.631844"
+       y2="0.6" />
+    <linearGradient
+       xlink:href="#linearGradient129"
+       id="linearGradient54"
+       x1="1.09466"
+       y1="0.125"
+       x2="0.413062"
+       y2="0.8125" />
+    <linearGradient
+       xlink:href="#linearGradient60"
+       id="linearGradient59"
+       x1="0.0823339"
+       y1="0.125714"
+       x2="0.724897"
+       y2="0.891429" />
+  </defs>
+  <sodipodi:namedview
+     id="base" />
+  <path
+     style="fill:#ffed44; fill-opacity:1; fill-rule:evenodd; stroke:none; stroke-opacity:1; stroke-width:1px; stroke-linejoin:miter; stroke-linecap:butt; "
+     id="path19"
+     d="M 98.6818 379.556 C 101.447 395.138 84.4659 397.304 82.3 403.801 C 97.6078 414.826 57.854 431.626 65.2632 436.565 C 70.5236 441.168 148.734 472.689 161.588 473.915 C 240.299 489.097 403.639 478.246 433.526 464.086 C 469.341 443.926 487.452 441.74 493.153 431.978 C 489.778 423.883 458.119 408.779 464.978 402.491 C 459.263 395.348 434.63 396.088 440.077 380.867 C 422.813 375.934 436.705 380.835 424.351 371.693 C 419.735 370.539 418.532 360.553 413.866 360.553 C 371.778 332.301 166.405 341.551 122.927 365.141 C 116.725 377.474 105.928 377.141 98.6818 379.556 z "
+     sodipodi:nodetypes="cccccccccccc"
+     transform="translate(5.27831,-15.4344)" />
+  <rect
+     style="stroke:#8484ff; fill:none; fill-opacity:1; fill-rule:evenodd; stroke-opacity:1; stroke-width:1px; stroke-linejoin:miter; stroke-linecap:butt; "
+     id="rect322"
+     x="64.935965"
+     y="48.972789"
+     width="433.132119"
+     height="433.133400"
+     rx="0.000000"
+     ry="0.000000" />
+  <path
+     style="fill:#000000; fill-opacity:0.226601; fill-rule:evenodd; stroke:none; stroke-opacity:1; stroke-width:1px; stroke-linejoin:miter; stroke-linecap:butt; "
+     id="path20"
+     d="M 225.111 407.241 C 228.073 419.986 212.055 451.321 217.613 456.879 C 281.229 443.591 300.561 434.871 335.561 459.827 C 339.593 453.779 374.563 408.648 366.277 404.293 C 353.465 400.361 276.113 399.27 225.111 407.241 z "
+     sodipodi:nodetypes="ccccc"
+     transform="matrix(2.12227,0,0,0.789554,-343.775,81.6276)" />
+  <path
+     style="fill:url(#linearGradient59); fill-opacity:1; fill-rule:evenodd; stroke:#000000; stroke-opacity:1; stroke-width:14.5pt; stroke-linejoin:miter; stroke-linecap:butt; "
+     id="path12"
+     d="M 139.308 203.944 C 139.308 201.575 233.721 127.785 287.618 89.0777 C 340.114 127.448 429.823 199.485 428.59 203.184 C 427.653 210.677 428.798 374.969 428.283 383.488 C 415.177 382.832 337.394 381.715 313.611 381.522 C 313.968 371.038 315.048 273.863 315.048 269.785 C 314.282 268.254 258.781 267.567 249.267 268.877 C 249.469 274.22 245.964 373.813 246.117 384.143 C 231.965 384.007 150.448 384.799 140.619 384.799 C 138.95 383.964 139.308 210.497 139.308 203.944 z "
+     sodipodi:nodetypes="cccccccccc"
+     transform="translate(0,13.5963)" />
+  <path
+     style="fill:#000000; fill-opacity:1; fill-rule:evenodd; stroke:#000000; stroke-opacity:1; stroke-width:1px; stroke-linejoin:miter; stroke-linecap:butt; "
+     d="M 309.679 156.109 C 309.679 168.769 298.083 179.044 283.795 179.044 C 269.508 179.044 257.912 168.769 257.912 156.109 C 257.912 143.45 269.508 133.175 283.795 133.175 C 298.083 133.175 309.679 143.45 309.679 156.109 z "
+     id="path16"
+     transform="translate(0,14.9069)" />
+  <path
+     style="fill:#a1282e; fill-opacity:1; fill-rule:evenodd; stroke:none; stroke-opacity:1; stroke-width:1px; stroke-linejoin:miter; stroke-linecap:butt; "
+     id="path14"
+     d="M 72.3299 188.884 C 87.562 179.955 240.512 75.6699 253.51 69.0917 C 264.238 78.2487 396.189 209.005 404.353 216.036 C 410.737 211.966 404.443 203.725 408.287 194.647 C 401.148 185.404 264.361 56.8171 255.8 47.4144 C 244.34 55.045 78.1907 159.083 68.6151 166.448 C 74.0568 172.658 67.755 182.607 72.3299 188.884 z "
+     sodipodi:nodetypes="ccccccc"
+     transform="matrix(1.05933,-0.0878478,0.0876177,1.06211,13.6183,42.8198)" />
+  <path
+     style="fill:url(#linearGradient53); fill-opacity:1; fill-rule:evenodd; stroke:none; stroke-opacity:1; stroke-width:1px; stroke-linejoin:miter; stroke-linecap:butt; "
+     id="path52"
+     d="M 314.921 282.031 C 312.822 291.009 314.806 370.492 311.972 393.099 C 297.149 394.161 258.567 395.719 247.1 392.116 C 247.009 376.947 246.785 292.175 248.083 282.03 C 260.599 283.408 308.18 281.048 314.921 282.031 z "
+     sodipodi:nodetypes="ccccc"
+     transform="matrix(0.88331,0,0,1.06005,31.4699,-13.415)" />
+  <path
+     transform="translate(-2.94871,2.94871)"
+     style="fill:none; fill-opacity:1; fill-rule:evenodd; stroke:#ffc200; stroke-opacity:1; stroke-width:5.6pt; stroke-linejoin:miter; stroke-linecap:butt; "
+     d="M 312.464 168.751 C 312.464 182.179 300.574 193.078 285.925 193.078 C 271.276 193.078 259.387 182.179 259.387 168.751 C 259.387 155.322 271.276 144.424 285.925 144.424 C 300.574 144.424 312.464 155.322 312.464 168.751 z "
+     id="path56" />
+  <path
+     sodipodi:type="arc"
+     style="fill:none;fill-opacity:1;fill-rule:evenodd;stroke:url(#linearGradient54);stroke-opacity:1;stroke-width:5pt;stroke-linejoin:miter;stroke-linecap:butt;"
+     id="path63"
+     cx="283.795469"
+     cy="171.289836"
+     rx="28.504240"
+     ry="24.572621"
+     transform="matrix(0.942528,0,0,0.973333,15.3273,3.39476)" />
+  <path
+     style="fill:url(#linearGradient132);fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-opacity:1;stroke-width:1px;stroke-linejoin:miter;stroke-linecap:butt;"
+     id="path64"
+     d="M 99.4081 237.963 C 109.883 231.977 120.469 220.777 132.251 216.85 C 129.812 253.364 130.29 237.086 129.905 262.595 C 170.232 247.472 239.132 165.447 257.756 175.797 C 307.535 207.834 333.293 221.542 356.286 240.31 C 386.728 243.837 435.162 238.56 436.047 218.023 C 443.49 221.244 447.659 227.348 461.852 235.617 C 461.383 227.759 462.036 219.197 460.679 209.813 C 440.956 193.304 300.875 82.9514 285.909 69.0578 C 263.711 84.8091 128.039 190.672 99.4081 210.986 C 100.258 218.929 99.4081 227.159 99.4081 237.963 z "
+     sodipodi:nodetypes="ccccccccccc"
+     transform="translate(2.63912,-0.000394997)" />
+</svg>

diff --git a/examples/romedalen.png b/examples/romedalen.png
new file mode 100644 (file)
index 0000000..0c41eb0
Binary files /dev/null and b/examples/romedalen.png differ

diff --git a/examples/testcairo.lisp b/examples/testcairo.lisp
new file mode 100644 (file)
index 0000000..131cfed
--- /dev/null
+++ b/examples/testcairo.lisp
@@ -0,0 +1,583 @@
+;; This file contains the cairo C snippets translated to lisp 
+;; 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)
+
+;;#+sbcl(require :rsvg)
+;;#+cmu(asdf:oos 'asdf:load-op :avg-cairo)
+
+(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)))
+
+(declaim (inline rad-to-deg))
+(defun rad-to-deg (rad)
+  (/ (* rad 180) pi))
+
+
+(defvar *snippets* ())
+
+
+(defmacro define-snippet (name (cr) &body body)
+  (let ((widget (make-symbol "WIDGET"))
+       (window (make-symbol "WINDOW"))
+       (pointer (make-symbol "POINTER")))
+    `(let ((,window nil))
+       (setq *snippets* (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 (,pointer)
+                   (declare (ignore ,pointer))
+                   (let ((,cr (gdk:cairo-create (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.2 0.2 0.6)
+  (cairo:arc cr xc yc 0.05 0 (deg-to-rad 360))
+  (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 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: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 (cairo:image-surface-create-from-png 
+               #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)
+  (cairo:line-to cr 1 1)
+  (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)))))
+
+
+
+(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.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 1)
+  (cairo:fill cr t)
+  (cairo:set-source-color cr 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: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 1)
+    (cairo:pattern-add-color-stop pattern 0 1 1 1 1)
+    (cairo:rectangle cr 0 0 1 1)
+    (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)
+    (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")))
+    (cairo:translate cr 0.5 0.5)
+    (cairo:rotate cr (deg-to-rad 45))
+    (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 (cairo:image-surface-create-from-png 
+                #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: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)))
+
+
+;; (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)))))
+
+;; (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)
+       
+       (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)
+
+      
+
+(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))
+
+
+;; (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: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.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)
+  (cairo:fill cr t)
+
+  (cairo:set-source-color cr 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: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 
+                       :label "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 (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))
+                         ;; 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))
+                             (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)

diff --git a/rsvg/defpackage.lisp b/rsvg/defpackage.lisp
new file mode 100644 (file)
index 0000000..afe70a5
--- /dev/null
+++ b/rsvg/defpackage.lisp
@@ -0,0 +1,3 @@
+(defpackage "RSVG"
+  (:use "COMMON-LISP" "GLIB" "AUTOEXPORT"))
+

diff --git a/rsvg/export.lisp b/rsvg/export.lisp
new file mode 100644 (file)
index 0000000..f5b1400
--- /dev/null
+++ b/rsvg/export.lisp
@@ -0,0 +1,4 @@
+(in-package "RSVG")
+
+;;; Autogenerating exported symbols
+(export-from-file #p"clg:rsvg;rsvg.lisp")

diff --git a/rsvg/rsvg.asd b/rsvg/rsvg.asd
new file mode 100644 (file)
index 0000000..db9785a
--- /dev/null
+++ b/rsvg/rsvg.asd
@@ -0,0 +1,18 @@
+;;; -*- Mode: lisp -*-
+
+(defpackage "RSVG-SYSTEM"
+  (:use "COMMON-LISP" "ASDF" "PKG-CONFIG"))
+
+
+(in-package "RSVG-SYSTEM")
+
+(pkg-exists-p "librsvg-2.0" :atleast-version "2.13.2")
+
+
+(defsystem rsvg
+    :depends-on (glib gdk cairo)
+    :components ((:library "librsvg-2" 
+                 :libdir #.(pkg-variable "librsvg-2.0" "libdir"))
+                (:file "defpackage")
+                (:file "rsvg" :depends-on ("defpackage" "librsvg-2"))
+                (:file "export" :depends-on ("rsvg"))))

diff --git a/rsvg/rsvg.lisp b/rsvg/rsvg.lisp
new file mode 100644 (file)
index 0000000..ec811ea
--- /dev/null
+++ b/rsvg/rsvg.lisp
@@ -0,0 +1,138 @@
+;; Common Lisp bindings for librsvg
+;; Copyright 2005 Espen S. Johnsen <espen@users.sf.net>
+;;
+;; Permission is hereby granted, free of charge, to any person obtaining
+;; a copy of this software and associated documentation files (the
+;; "Software"), to deal in the Software without restriction, including
+;; without limitation the rights to use, copy, modify, merge, publish,
+;; distribute, sublicense, and/or sell copies of the Software, and to
+;; permit persons to whom the Software is furnished to do so, subject to
+;; the following conditions:
+;;
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+;;
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+;; $Id: rsvg.lisp,v 1.1 2005/11/10 08:53:24 espen Exp $
+
+(in-package "RSVG")
+
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  
+  (defclass dimension-data (struct)
+    ((width
+      :allocation :alien 
+      :initarg :width
+      :accessor dimension-data-width
+      :type int)
+     (height
+      :allocation :alien 
+      :initarg :height
+      :accessor dimension-data-height
+      :type int)
+     (em
+      :allocation :alien 
+      :initarg :em
+      :accessor dimension-data-em
+      :type double-float)
+     (ex
+      :allocation :alien 
+      :initarg :ex
+      :accessor dimension-data-ex
+      :type double-float))
+    (:metaclass struct-class))
+
+
+  (defclass handle (proxy)
+    ((base-uri
+      :allocation :virtual 
+      :getter "rsvg_handle_get_base_uri"
+      :setter "rsvg_handle_set_base_uri"
+      :accessor handle-base-uri
+      :type string)
+     (dimensions
+      :allocation :virtual 
+      :getter handle-get-dimensions
+      :reader handle-dimensions
+      :type dimension-data)
+     (title
+      :allocation :virtual 
+      :getter "rsvg_handle_get_title"
+      :reader handle-title
+      :type string)
+     (description
+      :allocation :virtual 
+      :getter "rsvg_handle_get_desc"
+      :reader handle-description
+      :type string)
+     (metadata
+      :allocation :virtual 
+      :getter "rsvg_handle_get_metadata"
+      :reader handle-metadata
+      :type string))
+    (:metaclass proxy-class))
+
+)
+
+(defbinding init () nil)
+(defbinding term () nil)
+
+(defbinding set-default-dpi () nil
+  (dpi-x double-float)
+  (dpi-y double-float))
+
+(defbinding handle-set-dpi () nil
+  (handle handle)
+  (dpi-x double-float)
+  (dpi-y double-float))
+
+
+(defbinding handle-get-dimensions (handle &optional (dimensions (make-instance 'dimension-data))) nil
+  (handle handle)
+  (dimensions dimension-data :return))
+
+
+
+(defbinding handle-close () boolean
+  (handle handle)
+  (nil gerror :out))
+
+(defbinding %handle-new () pointer)
+
+(defbinding %handle-new-from-file () pointer
+  (filename pathname)
+  (nil gerror :out))
+
+(defmethod initialize-instance ((handle handle) &key filename)
+  (multiple-value-bind (location gerror)
+      (cond 
+       (filename (%handle-new-from-file filename))
+       (t (%handle-new)))
+    (if gerror 
+       (signal-gerror gerror)
+      (setf (slot-value handle 'location) location)))
+  (call-next-method))
+
+
+(defbinding %handle-free () nil
+  (location pointer))
+
+(defmethod unreference-foreign ((class (eql (find-class 'handle))) location)
+  (%handle-free location))
+
+
+
+
+;;; Cairo interface
+
+(defbinding cairo-render () nil
+  (cr cairo:context)
+  (handle handle))
\ No newline at end of file