chiark
/
gitweb
/
~mdw
/
clg
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Added functions to copy paths
[clg]
/
cairo
/
cairo.lisp
diff --git
a/cairo/cairo.lisp
b/cairo/cairo.lisp
index 993d0f1792cb286df9f8ddcef00c7c79291a4593..b743c776a555f397d2086877f8e8ca315e2da1a1 100644
(file)
--- a/
cairo/cairo.lisp
+++ b/
cairo/cairo.lisp
@@
-20,7
+20,7
@@
;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
;; 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
1 2007-02-19 14:37:52
espen Exp $
+;; $Id: cairo.lisp,v 1.1
7 2007-10-19 10:12:25
espen Exp $
(in-package "CAIRO")
(in-package "CAIRO")
@@
-40,7
+40,7
@@
(define-enum-type status
(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 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-slant :normal :ita
l
ic :oblique)
(define-enum-type font-weight :normal :bold)
(define-enum-type operator
(define-enum-type font-weight :normal :bold)
(define-enum-type operator
@@
-58,7
+58,7
@@
(define-enum-type hint-metrics :default :off :on)
(define-enum-type surface-type
image-surface pdf-surface ps-surface xlib-surface xcb-surface
glitz-surface quartz-surface win32-surface beos-surface
(define-enum-type surface-type
image-surface pdf-surface ps-surface xlib-surface xcb-surface
glitz-surface quartz-surface win32-surface beos-surface
- directfb-surface)
+ directfb-surface
svg-surface os2-surface
)
(defclass surface-class (proxy-class)
())
(defclass surface-class (proxy-class)
())
@@
-206,7
+206,7
@@
(defclass image-surface (surface)
(stride
:allocation :virtual
:getter "cairo_image_surface_get_stride"
(stride
:allocation :virtual
:getter "cairo_image_surface_get_stride"
- :reader surface-
height
+ :reader surface-
stride
:type int))
(:metaclass surface-class))
:type int))
(:metaclass surface-class))
@@
-326,11
+326,12
@@
(defclass context (ref-counted-object)
(:unref %destroy))
(:unref %destroy))
-;; (defclass path (proxy)
-;; ()
-;; (:metaclass proxy-class))
-
- )
+ (defclass path (struct)
+ ((status :allocation :alien :type status)
+ (data :allocation :alien :type pointer)
+ (length :allocation :alien :type int))
+ (:metaclass proxy-class)
+ (:unref %path-destroy)))
;;; Cairo context
;;; Cairo context
@@
-453,6
+454,19
@@
(defbinding show-page () nil
;;; Paths
;;; Paths
+(defbinding %path-destroy () nil
+ (location pointer))
+
+(defbinding copy-path () path
+ (cr context))
+
+(defbinding copy-path-flat () path
+ (cr context))
+
+(defbinding append-path () nil
+ (cr context)
+ (path path))
+
(defbinding get-current-point () nil
(cr context)
(x double-float :out)
(defbinding get-current-point () nil
(cr context)
(x double-float :out)
@@
-470,9
+484,9
@@
(defbinding close-path () nil
(defmacro defpath (name args &optional relative-p)
(flet ((def (name type)
(defmacro defpath (name args &optional relative-p)
(flet ((def (name type)
- `(progn
- ,(when (eq type 'optimized-double-float)
- `(declaim (
ftype (function (context ,@(loop repeat (length args) collect 'double-float)))
,(first name))))
+ `(progn
+ ,(when (eq type 'optimized-double-float)
+ `(declaim (
inline
,(first name))))
(defbinding ,name () nil
(cr context)
,@(mapcar #'(lambda (arg) (list arg type)) args)))))
(defbinding ,name () nil
(cr context)
,@(mapcar #'(lambda (arg) (list arg type)) args)))))
@@
-498,8
+512,13
@@
(defpath line-to (x y) t)
(defpath move-to (x y) t)
(defpath rectangle (x y width height))
(defpath move-to (x y) t)
(defpath rectangle (x y width height))
-(defun circle (cr x y radius)
- (arc cr x y radius 0.0 (* pi 2)))
+(defun circle (cr x y radius &optional negative-p)
+ (move-to cr radius 0.0d0)
+ (if negative-p
+ (arc-negative cr x y radius (* pi 2) 0.0d0)
+ (arc cr x y radius 0.0d0 (* pi 2)))
+ (close-path cr))
+
(defbinding glyph-path (cr glyphs) nil
(cr context)
(defbinding glyph-path (cr glyphs) nil
(cr context)
@@
-572,11
+591,13
@@
(defbinding scale (cr sx &optional (sy sx)) nil
(defun scale-to-device (cr &optional keep-rotation-p)
(if keep-rotation-p
(defun scale-to-device (cr &optional keep-rotation-p)
(if keep-rotation-p
- (multiple-value-call #'scale cr (device-to-user-distance cr 1.0))
- (multiple-value-bind (x y)
- (multiple-value-call #'user-to-device cr (get-current-point cr))
-; (identity-matrix cr)
- (setf (matrix cr) (matrix-init-identity))
+ (multiple-value-bind (dx dy) (device-to-user-distance cr 1.0 0.0)
+ (scale cr (sqrt (+ (* dx dx) (* dy dy)))))
+ (multiple-value-bind (x y)
+ (with-context (cr)
+ (move-to cr 0.0 0.0)
+ (multiple-value-call #'user-to-device cr (get-current-point cr)))
+ (identity-matrix cr)
(translate cr x y))))
(defbinding rotate () nil
(translate cr x y))))
(defbinding rotate () nil
@@
-825,6
+846,11
@@
(define-callback stream-write-func status
:success)
:success)
+(defmacro with-surface ((surface cr) &body body)
+ `(let ((,cr (make-instance 'context :target ,surface)))
+ ,@body))
+
+
;; Image Surface
;; Should data be automatically freed when the surface is GCed?
;; Image Surface
;; Should data be automatically freed when the surface is GCed?
@@
-976,12
+1002,18
@@
(defbinding matrix-init () nil
(defbinding matrix-init-identity (&optional (matrix (make-instance 'matrix))) nil
(matrix matrix :in/return))
(defbinding matrix-init-identity (&optional (matrix (make-instance 'matrix))) nil
(matrix matrix :in/return))
+(defun identity-matrix-p (matrix)
+ (with-slots (xx yx xy yy x0 y0) matrix
+ (and
+ (= xx 1.0d0) (= yx 0.0d0) (= xy 0.0d0)
+ (= yy 1.0d0) (= x0 0.0d0) (= y0 0.0d0))))
+
(defbinding matrix-init-translate () nil
(matrix matrix :in/return)
(tx double-float)
(ty double-float))
(defbinding matrix-init-translate () nil
(matrix matrix :in/return)
(tx double-float)
(ty double-float))
-(defbinding matrix-init-scale () nil
+(defbinding matrix-init-scale (
matrix sx &optional (sy sx)
) nil
(matrix matrix :in/return)
(sx double-float)
(sy double-float))
(matrix matrix :in/return)
(sx double-float)
(sy double-float))
@@
-995,7
+1027,7
@@
(defbinding matrix-translate () nil
(tx double-float)
(ty double-float))
(tx double-float)
(ty double-float))
-(defbinding matrix-scale () nil
+(defbinding matrix-scale (
matrix sx &optional (sy sx)
) nil
(matrix matrix :in/return)
(sx double-float)
(sy double-float))
(matrix matrix :in/return)
(sx double-float)
(sy double-float))
@@
-1012,15
+1044,12
@@
(defbinding matrix-multiply () nil
(a matrix)
(b matrix))
(a matrix)
(b matrix))
-(defbinding matrix-transform-distance () nil
- (matrix matrix
:in/return
)
- (dx double-float)
- (dy double-float))
+(defbinding matrix-transform-distance (
matrix dx &optional (dy dx)
) nil
+ (matrix matrix)
+ (dx double-float
:in/out
)
+ (dy double-float
:in/out
))
(defbinding matrix-transform-point () nil
(defbinding matrix-transform-point () nil
- (matrix matrix :in/return)
- (x double-float)
- (y double-float))
-
-
-
+ (matrix matrix)
+ (x double-float :in/out)
+ (y double-float :in/out))