(in-package :cl-cairo2)
;;;; Notes
;;;;
;;;; cairo-matrix-init is not defined, as we have a structure in lisp
;;;; with an appropriate constructor
;;;;
;;;; cairo_identity_matrix is reset-trans-matrix
;;;;
;;;; functions that manipulate transformation matrices have
;;;; trans-matrix instead of matrix in their name
;;;;
;;;; cairo_matrix_transform_distance and cairo_matrix_transform_point
;;;; are simply transform-distance and transform-point
;;;;
;;;; cairo_matrix_init is not defined, make-trans-matrix will give
;;;; you an identity matrix
;;;;
;;;; simple functions
;;;;
(define-many-with-default-context
(translate tx ty)
(scale sx sy)
(rotate angle))
(define-flexible (reset-trans-matrix pointer)
(cairo_identity_matrix pointer))
;;;;
;;;; transition matrix structure and helper functions/macros
;;;;
(defstruct trans-matrix
(xx 1d0 :type double-float)
(yx 0d0 :type double-float)
(xy 0d0 :type double-float)
(yy 1d0 :type double-float)
(x0 0d0 :type double-float)
(y0 0d0 :type double-float))
(defun trans-matrix-copy-in (pointer matrix)
"Copy matrix to a memory location."
(with-foreign-slots ((xx yx xy yy x0 y0) pointer cairo_matrix_t)
(setf xx (trans-matrix-xx matrix)
yx (trans-matrix-yx matrix)
xy (trans-matrix-xy matrix)
yy (trans-matrix-yy matrix)
x0 (trans-matrix-x0 matrix)
y0 (trans-matrix-y0 matrix))))
(defun trans-matrix-copy-out (pointer matrix)
"Copy contents of a memory location to a transition matrix."
(with-foreign-slots ((xx yx xy yy x0 y0) pointer cairo_matrix_t)
(setf (trans-matrix-xx matrix) xx
(trans-matrix-yx matrix) yx
(trans-matrix-xy matrix) xy
(trans-matrix-yy matrix) yy
(trans-matrix-x0 matrix) x0
(trans-matrix-y0 matrix) y0)))
(defmacro with-trans-matrix-in (matrix pointer &body body)
"Execute body with pointer pointing to a memory location with matrix."
`(with-foreign-pointer (,pointer (foreign-type-size 'cairo_matrix_t))
(trans-matrix-copy-in ,pointer ,matrix)
,@body))
(defmacro with-trans-matrix-out (pointer &body body)
"Execute body with pointer pointing to an uninitialized location,
then copy this to matrix and return the matrix."
(let ((matrix-name (gensym)))
`(with-foreign-pointer (,pointer (foreign-type-size 'cairo_matrix_t))
(let ((,matrix-name (make-trans-matrix)))
,@body
(trans-matrix-copy-out ,pointer ,matrix-name)
,matrix-name))))
(defmacro with-trans-matrix-in-out (matrix pointer &body body)
(let ((matrix-name (gensym)))
`(with-foreign-pointer (,pointer (foreign-type-size 'cairo_matrix_t))
(let ((,matrix-name (make-trans-matrix)))
(trans-matrix-copy-in ,pointer ,matrix)
,@body
(trans-matrix-copy-out ,pointer ,matrix-name)
,matrix-name))))
(defmacro with-x-y (&body body)
"Creates temporary variables on the stack with pointers xp and yp,
and copies x and y in/out before/after (respectively) the
execution of body."
`(with-foreign-objects ((xp :double) (yp :double))
(setf (mem-ref xp :double) (coerce x 'double-float)
(mem-ref yp :double) (coerce y 'double-float))
,@body
(values (mem-ref xp :double) (mem-ref yp :double))))
(defmacro define-with-x-y (name)
"Defines a function that is called with context, x and y, and
returns the latter two."
`(define-flexible (,name pointer x y)
(with-x-y
(,(prepend-intern "cairo_" name) pointer xp yp))))
;;;;
;;;; transformation and conversion functions
;;;;
(define-flexible (transform pointer matrix)
(with-trans-matrix-in matrix matrix-pointer
(cairo_transform pointer matrix-pointer)))
(define-flexible (set-trans-matrix pointer matrix)
(with-trans-matrix-in matrix matrix-pointer
(cairo_set_matrix pointer matrix-pointer)))
(define-flexible (get-trans-matrix pointer)
(with-trans-matrix-out matrix-pointer
(cairo_get_matrix pointer matrix-pointer)))
(define-with-x-y user-to-device)
(define-with-x-y user-to-device-distance)
(define-with-x-y device-to-user)
(define-with-x-y device-to-user-distance)
;;;;
;;;; transformations
;;;;
(defmacro define-matrix-init (name &rest args)
"Define a matrix initializer function with args, which returns the
new matrix."
`(defun ,(prepend-intern "trans-matrix-init-" name :replace-dash nil) ,args
(with-trans-matrix-out matrix-pointer
(,(prepend-intern "cairo_matrix_init_" name)
matrix-pointer
,@args))))
(define-matrix-init translate tx ty)
(define-matrix-init scale sx sy)
(define-matrix-init rotate radians)
(defmacro define-matrix-transformation (name &rest args)
"Define a matrix transformation function with matrix and args,
which returns the new matrix."
`(export
(defun ,(prepend-intern "trans-matrix-" name :replace-dash nil) (matrix ,@args)
(with-trans-matrix-in-out matrix matrix-pointer
(,(prepend-intern "cairo_matrix_" name)
matrix-pointer
,@args)))))
(define-matrix-transformation translate tx ty)
(define-matrix-transformation scale sx sy)
(define-matrix-transformation rotate radians)
(define-matrix-transformation invert)
(defun trans-matrix-multiply (a b)
(with-trans-matrix-in a a-pointer
(with-trans-matrix-in b b-pointer
(with-trans-matrix-out result-pointer
(cairo_matrix_multiply result-pointer
a-pointer
b-pointer)))))
(defun transform-distance (matrix x y)
(with-trans-matrix-in matrix matrix-pointer
(with-x-y
(cairo_matrix_transform_distance matrix-pointer xp yp))))
(defun transform-point (matrix x y)
(with-trans-matrix-in matrix matrix-pointer
(with-x-y
(cairo_matrix_transform_point matrix-pointer xp yp))))