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

(in-package #:wheelwork)

(defvar *current-canvas* nil
  "Bound by with-canvas")
(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-canvas-state (&body body)
  `(let 
       ((*saved-state*
          (list *current-pen-width*
                *current-pen-position*
                *current-pen-color*)))
     ,@body))

(defmacro with-pen-color (list-or-fn &body body)
  `(let ((*current-pen-color* nil))
     (canvas-pen-color ,list-or-fn)
     ,@body))


(defmacro with-canvas (canvas &body body)
  `(let ((*current-canvas* ,canvas)
         (*current-pen-width* 1)
         (*current-pen-position* (list 0 0))
         (*current-pen-color* (list 0 0 0 255)))
     (with-canvas-state 
       ,@body)))


(defun restore-canvas-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)
  (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))