;;;; canvas-language.lisp  -- a drawing api for canvas instances

(in-package #:wheelwork)

(defvar *current-canvas* nil)
(defvar *current-pen-color* '(0 0 0 255))
(defvar *current-pen-width* 1)
(defvar *current-pen-position* '(0 0))
(defvar *saved-state* nil)

(defmacro with-current-pen-state ( &body body)
  "Saves the current pen state (color width position) so that it can
   be restored from using (restore-pen-state) from within the BODY.
   After BODY executes the state is restored to whatever it was
   before WITH-CURRENT-PEN-STATE was evaluated."
  `(let 
       ((*saved-state*
          (list *current-pen-width*
                *current-pen-position*
                *current-pen-color*)))
     ,@body))

(defmacro with-pen ((&key position (color nil color-supplied-p) width) &body body)
  "Like WITH-CURRENT-PEN-STATE, but lets you set the state of the pen
  EXECUTION BODY.  After BODY executes, the state is restored to
  whatever it was before WITH-PEN-STATE was evaluated."
  `(let ((*current-pen-position* ,(if position nil '*current-pen-position*))
         (*current-pen-color* ,(if color-supplied-p nil '*current-pen-color*))
         (*current-pen-width* ,(if width nil '*current-pen-width*)))
     ,(when position
        `(move-to ,@position))
     ,(when color-supplied-p
        `(canvas-pen-color ,color))
     ,(when width
        `(canvas-pen-width ,width))
     (with-current-pen-state
       ,@body)))

(defmacro with-pen-color (list-or-fn &body body)
  "Temporarily bind pen color to the value of LIST-OR-FN and execute BODY."
  `(let ((*current-pen-color* nil))
     (canvas-pen-color ,list-or-fn)
     ,@body))


(defmacro with-canvas (canvas &body body)
  "Perform drawing commands in BODY using the value of CANVAS as the
   target of any drawing operations."
  `(let ((*current-canvas* ,canvas)
         (*current-pen-width* 1)
         (*current-pen-position* (list 0 0))
         (*current-pen-color* (list 0 0 0 255)))
     (with-current-pen-state 
       ,@body)))

(defun restore-pen ()
  "Restore the state of the pan (width position color) as previously
saved by WITH-PEN-STATE"
  (destructuring-bind (pw pp pc) *saved-state*
    (setf *current-pen-width* pw
          *current-pen-position* pp
          *current-pen-color* pc)))


(defun colfix (c)
  (round (clamp 0 c 255)))

(defun canvas-pen-color (&optional newpen)
  "Set the pens color in the current context. NEWPEN, if supplied, can be one of:

  NIL - set the color to black.
 
  A list of four unsigned 8 bit integers that looks like (R G B A).
 
  A function (or symbol naming a function) that accepts the
  coordinates X Y of the pixel being drawn and returns a list as in
  the above case.

  All RGBA component values obtained from a pen (either from the
  return of a functional pen or as members of a list value) are
  clamped between 0 and 255."
  (setf *current-pen-color* 
        (etypecase newpen
          (null nil)
          ((or symbol function)
           (lambda (x y)
             (mapcar #'colfix (funcall newpen x y))))
          (list
           (mapcar #'colfix newpen)))))

(defun canvas-pen-width (n)
  (setf *current-pen-width* (round n)))

(defun can-fill-canvas-at-p (x y)
  (with-slots (pixel-width pixel-height) *current-canvas*
    (and (< -1 x pixel-width)
         (< -1 y pixel-height))))

(defun rel-to-current-pos (path)
  (destructuring-bind (cx cy) *current-pen-position* 
    (loop for (x y) in path collect (list (+ cx x) (+ cy y)))))

(defun move-to (x y)
  (setf *current-pen-position* (list x y)))

(defun move-rel (dx dy)
  (setf *current-pen-position*
        (mapcar #'+ *current-pen-position* (list dx dy))))

(defun apply-pen-at (x y)
  (let ((w
          (max 0 (floor (* 0.5 *current-pen-width*)))))
    (destructuring-bind
        (cr cg cb ca)
        (etypecase *current-pen-color*
          (null (list 0 0 0 255))
          (list *current-pen-color*)
          (function (funcall *current-pen-color* x y))) 
      (with-grid-rect (rx ry) ((- x w) (- y w) (+ x w) (+ y w))
        (when (can-fill-canvas-at-p rx ry) 
          (with-pixel (r g b a) (pixel *current-canvas* rx ry)
            (setf r cr g cg b cb a ca)))))))

(defun stroke-to (ex ey)
  (destructuring-bind (sx sy) *current-pen-position* 
    (with-grid-line (x y) (sx sy) (ex ey)
      (apply-pen-at x y)))
  (setf *current-pen-position* (list ex ey)))

(defun stroke-rel (dx dy)
  (apply #'stroke-to (mapcar #'+ *current-pen-position* (list dx dy))))

(defun stroke-path (path)
  (with-grid-path (x y) (path) (apply-pen-at x y))
  (setf *current-pen-position* (copy-list (first (last path)))))

(defun stroke-rel-path (path)
  (stroke-path
   (cons *current-pen-position*
         (rel-to-current-pos path))))

(defun fill-path (path)
  (let ((*current-pen-width* 1)) 
    (with-grid-path (x y) (path :interiorp t)
      (apply-pen-at x y))))

(defun fill-rel-path (path)
  (fill-path
   (cons *current-pen-position*
         (rel-to-current-pos path))))

(defun stroke-rect (left bottom right top)
  (stroke-path (list (list left bottom)
                     (list left top)
                     (list right top)
                     (list right bottom)
                     (list left bottom))))

(defun stroke-rel-rect (dx dy)
  (destructuring-bind (sx sy) *current-pen-position*
    (let ((left
            (if (plusp dx) sx (+ sx dx)))
          (right
            (if (plusp dx) (+ sx dx) sx))
          (bottom
            (if (plusp dy) sy (+ sy dy)))
          (top
            (if (plusp dy) (+ sy dy) sy)))
      (stroke-rect left bottom right top))))

(defun fill-rect (left bottom right top)
  (let ((*current-pen-width* 1))
    (with-grid-rect (x y) (left bottom right top)
      (apply-pen-at x y)))
  (setf *current-pen-position* (list left bottom)))

(defun fill-rel-rect (dx dy)
  (destructuring-bind (sx sy) *current-pen-position*
    (let ((left
            (if (plusp dx) sx (+ sx dx)))
          (right
            (if (plusp dx) (+ sx dx) sx))
          (bottom
            (if (plusp dy) sy (+ sy dy)))
          (top
            (if (plusp dy) (+ sy dy) sy)))
      (fill-rect left bottom right top))))

(defun stroke-bezier (control-pts &optional (curve-samples 10))
  (let (path)
    (with-grid-bezier (x y) (control-pts :count curve-samples)
      (push (list x y) path))
    (stroke-path (reverse path))))

(defun stroke-rel-bezier (rel-control-points &optional (curve-samples 10))
  (stroke-bezier (cons *current-pen-position*
                       (rel-to-current-pos rel-control-points))
                 curve-samples))

(defun fill-bezier (control-pts &optional (curve-samples 10))
  (let (path)
    (with-grid-bezier (x y) (control-pts :count curve-samples)
      (push (list x y) path))
    (fill-path (reverse path))))

(defun fill-rel-bezier (rel-control-points &optional (curve-samples 10))
  (fill-bezier (cons *current-pen-position*
                     (rel-to-current-pos rel-control-points))
               curve-samples))