(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))))