path: root/src/canvas-language.lisp

;;;; 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 ( &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 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, 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."
  (with-gensyms (newpos) 
    `(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
          `(let ((,newpos ,position))  (apply 'move-pen-to ,newpos)))
       ,(when color-supplied-p
          `(canvas-pen-color ,color))
       ,(when width
          `(canvas-pen-width ,width))
       (with-current-pen
         ,@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 
       ,@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)
  "Set the cavnas pen width. This is approximately how many pixels
wide a line drawn with the pen will be.  If N is not a positive
integer."
  (setf *current-pen-width* 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-pen-to (x y)
  "Sets the pen's position without drawing. "
  (setf *current-pen-position* (list x y)))

(defun move-pen-rel (dx dy)
  "Moves the current pen by dx dy."
  (setf *current-pen-position*
        (mapcar #'+ *current-pen-position* (list dx dy))))

(defun apply-pen-at (x y)
  "Draws the pen onto the canvas at the location X Y. If the pen width
is 1 the just one pixel is drawn. If 2 then 4 are drawn, and so on. "
  (let ((w
          (max 0 (1- *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 y (+ 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)
  "Draw a line from the current pen position 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)
  "Draw a line from the current pen position to a distance DX DY away."
  (apply #'stroke-to (mapcar #'+ *current-pen-position* (list dx dy))))

(defun stroke-path (path)
  "Draw a path. PATH is a list of (X Y) points. The pen is moved to
the first point and then each point is connnected. At last, the pen's
position is set to the last point. "
  (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)
  "Draw a path starting at the current point. PATH is a list of DX DY
values, each of which is relative to the current position of the PEN.

If you are looking for a function where each subsequent point moves
the pen relative to its antecedent, look at STROKE-STEPS"
  (stroke-path
   (cons *current-pen-position*
         (rel-to-current-pos path))))

(defun steps-to-concrete-points (steps)
  (loop
    with (cx cy) = *current-pen-position*
    for (dx dy) in steps
    do (incf cx dx)
       (incf cy dy)
    collect (list cx cy)))

(defun stroke-steps (steps)
  "STEPS is a list of (dx dy) steps. The pen starts at the current
positoin and draws a path, each step on the path moves the pen dx dy
from its then current location."
  (stroke-path
   (cons *current-pen-position*
         (steps-to-concrete-points steps))))



(defun fill-path (path)
  "Draws path as a closed polygon (implicitly connecting the first and
last points in PATH)."
  (let ((*current-pen-width* 1)) 
    (with-grid-path (x y) (path :interiorp t)
      (apply-pen-at x y))))

(defun fill-steps (steps)
  "Like STROKE-STEPS but implicitly connects the first and last points
  to be drawn and fills the resulting polygon in with the current pen."
  (fill-path
   (cons *current-pen-position*
         (steps-to-concrete-points steps))))

(defun fill-rel-path (path)
  "See STROKE-REL-PATH."
  (fill-path
   (cons *current-pen-position*
         (rel-to-current-pos path))))

(defun stroke-rect (left bottom right top)
  "Draws a rectangle."
  (stroke-path (list (list left bottom)
                     (list left top)
                     (list right top)
                     (list right bottom)
                     (list left bottom))))

(defun stroke-rel-rect (dx dy)
  "Draws a rectangle relative to the current position."
  (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)
  "Fills in a rectangle."
  (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-region (region)
  (with-slots (left bottom right top) region
    (fill-rect left bottom right top)))


(defun fill-rel-rect (dx dy)
  "Fills in a rectangle relative to current position."
  (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))
  "Draws a bezier curve with control points CONTROL-PTS. CURVE-SAMPLES
is the number of points on the 'real bezier curve' that will be
connected by straight lines to form an approximate curve. Use a higher
value for smoother looking curves."
  (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))
  "Like STROKE-BEZIER but REL-CONTROL-POINTS are (DX DY) that
represent the position of control points relative to the current pen
position."
  (stroke-bezier (cons *current-pen-position*
                       (rel-to-current-pos rel-control-points))
                 curve-samples))

(defun fill-bezier (control-pts &optional (curve-samples 10))
  "Like STROKE-BEZIER but will implicitly connect the first and last
curve sample points and fill in the resulting polygon."
  (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))
  "Like STROKE-REL-BEZIER and FILL-BEZIER."
  (fill-bezier (cons *current-pen-position*
                     (rel-to-current-pos rel-control-points))
               curve-samples))