;;;; 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-color-function* nil)

(defvar *current-pen-width* 1)

(defvar *current-pen-position* '(0 0))



(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))
         (*current-pen-color-function* nil))
     ,@body))

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

(defun canvas-pen-color (r g b a)
  (setf *current-pen-color* (mapcar #'colfix (list r g b a))))

(defun canvas-pen-color-function (&optional fn)
  (setf *current-pen-color-function*
        (when fn
         (lambda (x y)
           (mapcar #'colfix (funcall fn x y))))))

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

(defmacro with-pen-color ((r g b a) &body body)
  `(let ((ww::*current-pen-color* nil))
     (canvas-pen-color ,r ,g ,b ,a)
     ,@body))

(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)
        (if *current-pen-color-function*
            (funcall *current-pen-color-function* x y)
            *current-pen-color*) 
      (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 (+ sx sy)))
          (top
            (if (plusp dy) (+ sy dy) sy)))
      (stroke-rect left right bottom 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 (+ sx sy)))
          (top
            (if (plusp dy) (+ sy dy) sy)))
      (fill-rect left right bottom 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 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))