;;; Polygon subdivision test using generated JavaScript
;;; Peter Salvi, 2011.04.03.

(in-package #:cl-user)

(defpackage #:subdivision
  (:use #:common-lisp #:cl-who #:parenscript))

(in-package #:subdivision)

(with-open-file (s "subdivision.html" :direction :output :if-exists :supersede)
  (with-html-output (s nil :prologue t :indent t)
      (:title "Polygon Subdivision")
      (:script :type "text/javascript" (str (ps 

;;; JavaScript
(defvar *cp-radius* 3)
(defvar *points* '())
(defvar *dragging* nil)

(defun vplus (p q)
  (list (+ (elt p 0) (elt q 0))
        (+ (elt p 1) (elt q 1))))

(defun vminus (p q)
  (list (- (elt p 0) (elt q 0))
        (- (elt p 1) (elt q 1))))

(defun vscale (p x)
  (list (* (elt p 0) x) (* (elt p 1) x)))

(defun vlength (p)
  (sqrt (+ (* (elt p 0) (elt p 0))
           (* (elt p 1) (elt p 1)))))

(defun point-distance (p q)
  (vlength (vminus p q)))

(defun affine-combination (lst)
  "LST is of the format (((X0 Y0) W0) ((X1 Y1) W1) ...), where Wi are weights."
  (let ((wsum (loop for pw in lst sum (elt pw 1)))
        (result '(0 0)))
    (loop for pw in lst do
      (setf result (vplus result (vscale (elt pw 0) (/ (elt pw 1) wsum)))))

(defun draw-polyline (ctx lst)
  (chain ctx (begin-path))
  (let ((p0 (elt lst 0)))
    (chain ctx (move-to (elt p0 0) (elt p0 1))))
  (loop for i from 1 below (length lst) do
       (chain ctx (line-to (elt (elt lst i) 0) (elt (elt lst i) 1))))
  (chain ctx (stroke)))

(defmacro defsubdivision (name (lst) &body body)
  (let ((n (ps-gensym "n"))
        (c (ps-gensym)))
    `(defun ,name (,lst ,n)
       (if (= ,n 0)
           (flet ((,c () (progn ,@body)))
             (,name (,c) (1- ,n)))))))

(macrolet ; these macros are not `safe', but they make everything much simpler
    ((push-weighted (index (&rest weights))
       `(let* ((start ,index)
               (weighted (list ,@(loop for i upfrom 0 and w in weights collect
                                   `(list (elt lst (+ start ,i)) ,w)))))
          (chain result (push (affine-combination weighted)))))
     (push-point (index)
       `(chain result (push (elt lst ,index))))
     (subdivision (name &body body)
       `(defsubdivision ,name (lst)
          (let ((n (length lst))
                (result '()))

  (subdivision chaikin4
    (push-point 0)
    (loop for i from 1 below (1- n) do
      (push-weighted (1- i) (1 3))
      (push-weighted i (3 1)))
    (push-point (1- n)))

  (subdivision chaikin8
    (push-point 0)
    (loop for i from 1 below (1- n) do
      (push-weighted (1- i) (1 1))
      (push-weighted (1- i) (1 6 1)))
    (push-weighted (- n 2) (1 1))
    (push-point (1- n)))

  (subdivision four-point
    (when (< n 4)
      (return lst))
    (push-point 0)
    (push-weighted 0 (5 15 -5 1))
    (loop for i from 1 below (- n 2) do
      (push-point i)
      (push-weighted (1- i) (-1 9 9 -1)))
    (push-point (- n 2))
    (push-weighted (- n 4) (1 -5 15 5))
    (push-point (- n 1))))

(defun redraw ()
  (let ((canvas (chain document (get-element-by-id "canvas"))))
    (when (@ canvas get-context)
      (let ((ctx (chain canvas (get-context "2d"))))
        (chain ctx (clear-rect 0 0 640 480))
        ;; Control polygon
        (when (and (chain document (get-element-by-id "controlpoly") checked)
                   (> (length *points*) 0))
          (setf (@ ctx stroke-style) "red")
          (draw-polyline ctx *points*))
        ;; Subdivided polygon
        (when (> (length *points*) 1)
          (let ((n (chain document (get-element-by-id "subdivision")
            (case (chain document (get-element-by-id "type") selected-index)
              (0 (setf curve (chaikin4 *points* n)))
              (1 (setf curve (chaikin8 *points* n)))
              (2 (setf curve (four-point *points* n))))
            (setf (@ ctx stroke-style) "black")
            (draw-polyline ctx curve)))
        ;; Control points
        (setf (@ ctx fill-style) "red")
        (loop for p in *points* do
          (chain ctx (begin-path))
          (chain ctx (arc (elt p 0) (elt p 1) *cp-radius* 0 (* 2 PI) t))
          (chain ctx (close-path))
          (chain ctx (fill)))))))

(defun coordinates (event)
  (let ((canvas (chain document (get-element-by-id "canvas")))
        (x (@ event page-x))
        (y (@ event page-y)))
    (when (and (not x) (not y))
      (setf x (+ (@ event client-x)
                 (@ document body scroll-left)
                 (@ document document-element scroll-left))
            y (+ (@ event client-y)
                 (@ document body scroll-top)
                 (@ document document-element scroll-top))))
    (list (- x (@ canvas offset-left))
          (- y (@ canvas offset-top)))))

(defun cp-drag (event)
  (let ((p (coordinates event)))
    (setf (elt *points* *dragging*) p)

(defun stop-drag (event)
  (setf *dragging* nil)
  (let ((canvas (chain document (get-element-by-id "canvas"))))
    (chain canvas (remove-event-listener "mousemove" #'cp-drag f))))

(defun start-drag (event)
  (let ((p (coordinates event))
        (cp-index -1))
    (loop for i from 0 below (length *points*)
      when (< (point-distance p (elt *points* i)) (* 2 *cp-radius*)) do
        (setf cp-index i))
    (when (>= cp-index 0)
      (setf *dragging* cp-index)
      (let ((canvas (chain document (get-element-by-id "canvas"))))
        (chain canvas (add-event-listener "mousemove" #'cp-drag f))))))

(defun canvas-clicked (event)
  (let ((p (coordinates event)))
    (loop for i from 0 below (length *points*)
      when (< (point-distance p (elt *points* i)) *cp-radius*) do
        (return (start-drag i)))
    (chain *points* (push p))

(defun reset ()
  (setf *points* '())

(defun init ()
  (let ((canvas (chain document (get-element-by-id "canvas"))))
    (chain canvas (add-event-listener "click" #'canvas-clicked f))
    (chain canvas (add-event-listener "mousedown" #'start-drag f))
    (chain canvas (add-event-listener "mouseup" #'stop-drag f))))))))

;;; HTML
     (:body :onload (ps (init))
      (:h1 "Polygon Subdivision")
      (:noscript "You need JavaScript to view this page.")
      (:canvas :id "canvas" :width "640" :height "480"
               :style "border-style: dashed"
               "Sorry - your browser does not support canvas widgets.")
      (:input :type "checkbox" :id "controlpoly" :checked "checked"
        :onclick (ps (redraw)) "Show control polygon")
      (:select :id "type" :onchange (ps (redraw))
        (:option "Chaikin[1/4]")
        (:option "Chaikin[1/8]")
        (:option "Four-point"))
      (:select :id "subdivision" :onchange (ps (redraw))
        (loop for i from 0 to 7 do
          (htm (:option (fmt "~d" i)))))
      (:button :onclick (ps (reset)) "Reset")))))