(in-package :cl-cairo2)
;;;;
;;;;  Notes
;;;;
;;;;  image-surface-get-stride is not implemented, as I don't see how
;;;;    it would be used (ask if you need it).
;;;;
;;;;  functions that write to/read from streams are not implemented



;;;;
;;;;  class surface
;;;;

(defgeneric get-width (object)
  (:documentation "return the width of an object"))

(defgeneric get-height (object)
  (:documentation "return the height of an object"))

(defgeneric pixel-based-p (object)
  (:documentation "return t iff the object uses a pixel-based backend"))

(defclass surface () 
  ((pointer :initarg :pointer :initform nil)
   (width :initarg :width :reader get-width)
   (height :initarg :height :reader get-height)
   (pixel-based-p :initarg :pixel-based-p :reader pixel-based-p)))

(defmacro with-alive-surface ((surface pointer) &body body)
  "Execute body with pointer pointing to cairo surface, if nil,
  signal error."
  (let ((pointer-name pointer))
    `(with-slots ((,pointer-name pointer)) ,surface
       (if ,pointer-name
	   (progn ,@body)
	   (warn "surface is not alive")))))

(defmacro check-surface-pointer-status (pointer &body body)
  "Check status of surface after executing body."
  (let ((status (gensym)))
    `(multiple-value-prog1 (progn ,@body)
       (let ((,status 
	      (lookup-cairo-enum (cairo_surface_status ,pointer) table-status)))
	 (unless (eq ,status 'status-success)
	   (warn "function returned with status ~a." ,status))))))

(defmacro with-surface ((surface pointer) &body body)
  "Execute body with pointer pointing to surface, and check status."
  `(with-alive-surface (,surface ,pointer)
     (check-surface-pointer-status ,pointer
       ,@body)))

(defun new-surface-with-check (pointer width height &optional (pixel-based-p nil))
  "Check if the creation of new surface was successful, if so, return new class."
  (let ((surface (make-instance 'surface :width width :height height
				:pixel-based-p pixel-based-p)))
    (check-surface-pointer-status pointer
      (setf (slot-value surface 'pointer) pointer)
      ;; register finalizer
      (tg:finalize surface #'(lambda () (cairo_surface_destroy pointer)))
      ;; return surface
      surface)))

(defmethod destroy ((object surface))
  (with-alive-surface (object pointer)
    (cairo_surface_destroy pointer)
    (setf pointer nil))
  ;; deregister finalizer
  (tg:cancel-finalization object))

;;;;
;;;; Macros to create surfaces (that are written into files) and
;;;; direct creation of contexts for these surfaces.
;;;;

(defmacro define-create-surface (type)
  "Define the function create-<type>-surface."
  `(defun ,(prepend-intern "create-" type :replace-dash nil :suffix "-surface")
      (filename width height)
    (new-surface-with-check
     (,(prepend-intern "cairo_" type :replace-dash nil
		       :suffix "_surface_create")
       filename width height)
     width height)))

;;;;
;;;; PDF surface
;;;;

(define-create-surface pdf)

;;;;
;;;; PostScript surface
;;;;

(define-create-surface ps)

;;;;
;;;; SVG surface
;;;;

(define-create-surface svg)

;;;;
;;;;  image surface
;;;;

(defun create-image-surface (format width height)
  (new-surface-with-check
   (cairo_image_surface_create (lookup-enum format table-format)
			       width height)
   width height t))

(defun get-bytes-per-pixel (format)
  (case format
    (format-argb32 4)
    (format-rgb24 3)
    (format-a8 1)
    (otherwise (error (format nil "unknown format: ~a" format))))) ;todo: how does format-a1 fit in here?

(defun image-surface-get-data (surface)
  (with-surface (surface pointer)
    (let* ((width (image-surface-get-width surface))
           (height (image-surface-get-height surface))
           (bytes-per-pixel (get-bytes-per-pixel (image-surface-get-format surface)))
           (buffer (make-array (* width height bytes-per-pixel) :element-type '(unsigned-byte 8) :fill-pointer 0))
           (data (cairo_image_surface_get_data pointer)))
      (loop for i from 0 below (* width height bytes-per-pixel) do
         (vector-push-extend (cffi:mem-ref data :uint8 i) buffer))
      buffer)))


(defun image-surface-get-format (surface)
  (with-surface (surface pointer)
    (lookup-cairo-enum (cairo_image_surface_get_format pointer) table-format)))

(defun image-surface-get-width (surface)
  (with-surface (surface pointer)
    (cairo_image_surface_get_width pointer)))

(defun image-surface-get-height (surface)
  (with-surface (surface pointer)
    (cairo_image_surface_get_height pointer)))

;;;;
;;;;  PNG surfaces
;;;;

(defun image-surface-create-from-png (filename)
  (let ((surface 
	 (new-surface-with-check (cairo_image_surface_create_from_png filename)
				 0 0)))
    (with-slots (width height) surface
      (setf width (image-surface-get-width surface)
	    height (image-surface-get-height surface))
      surface)))

(defun surface-write-to-png (surface filename)
  (with-surface (surface pointer)
    (cairo_surface_write_to_png pointer filename)))