--- /dev/null
+;;; -*- 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"))))
--- /dev/null
+;; 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))
+
+
+
--- /dev/null
+(defpackage "CAIRO"
+ (:use "COMMON-LISP" "GLIB" "AUTOEXPORT")
+ (:shadow "FILL"))
+
--- /dev/null
+(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
--- /dev/null
+<?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>
--- /dev/null
+<?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>
--- /dev/null
+;; 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)
--- /dev/null
+(defpackage "RSVG"
+ (:use "COMMON-LISP" "GLIB" "AUTOEXPORT"))
+
--- /dev/null
+(in-package "RSVG")
+
+;;; Autogenerating exported symbols
+(export-from-file #p"clg:rsvg;rsvg.lisp")
--- /dev/null
+;;; -*- 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"))))
--- /dev/null
+;; 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
~mdw / clg / commitdiff
