(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)
(:html
(:head
(:title "Polygon Subdivision")
(:script :type "text/javascript" (str (ps
(defvar *cp-radius* 7)
(defvar *points* '())
(defvar *dragging* nil)
(defvar *grid-size* 40)
(defvar *snap-tol* 10)
(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)))))
result))
(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)
,lst
(flet ((,c () (progn ,@body)))
(,name (,c) (1- ,n)))))))
(macrolet ((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 '()))
,@body
result))))
(subdivision chaikin4
(push-point 0)
(push-weighted 0 (1 1))
(loop for i from 1 to (- n 3) do
(push-weighted i (3 1))
(push-weighted i (1 3)))
(push-weighted (- n 2) (1 1))
(push-point (1- n)))
(subdivision chaikin8
(push-point 0)
(push-weighted 0 (1 1))
(cond
((= n 4)
(push-weighted 1 (1 1)))
((= n 5)
(push-weighted 1 (3 1))
(push-weighted 1 (3 10 3))
(push-weighted 2 (1 3)))
((> n 5)
(push-weighted 1 (3 1))
(push-weighted 1 (3 11 2))
(loop for i from 2 to (- n 5) do
(push-weighted i (1 1))
(push-weighted i (1 6 1)))
(push-weighted (- n 4) (1 1))
(push-weighted (- n 4) (2 11 3))
(push-weighted (- n 3) (1 3))))
(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))
(when (chain document (get-element-by-id "grid") checked)
(setf (@ ctx stroke-style) "grey"
(@ ctx line-width) 1)
(loop for i from 1 to (1- (/ 480 *grid-size*)) do
(draw-polyline ctx (list (list 0 (* i *grid-size*)) (list 640 (* i *grid-size*)))))
(loop for i from 1 to (1- (/ 640 *grid-size*)) do
(draw-polyline ctx (list (list (* i *grid-size*) 0) (list (* i *grid-size*) 480)))))
(when (and (chain document (get-element-by-id "controlpoly") checked)
(> (length *points*) 0))
(setf (@ ctx stroke-style) "red"
(@ ctx line-width) 2)
(draw-polyline ctx *points*))
(when (> (length *points*) 2)
(let ((n (chain document (get-element-by-id "subdivision")
selected-index))
curve)
(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) "blue"
(@ ctx line-width) 3)
(draw-polyline ctx curve)))
(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 snap-point (point)
(if (chain document (get-element-by-id "grid") checked)
(let ((close (list (* (round (elt point 0) *grid-size*) *grid-size*)
(* (round (elt point 1) *grid-size*) *grid-size*))))
(if (< (point-distance point close) *snap-tol*)
close
point))
point))
(defun cp-drag (event)
(let ((p (coordinates event)))
(setf (elt *points* *dragging*) (snap-point p))
(redraw)))
(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 (snap-point (coordinates event))))
(loop for i from 0 below (length *points*)
when (< (point-distance p (elt *points* i)) *cp-radius*) do
(return-from canvas-clicked (start-drag i)))
(chain *points* (push p))
(redraw)))
(defun remove-last ()
(chain *points* (pop))
(redraw))
(defun reset ()
(setf *points* '())
(redraw))
(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))
(redraw)))))))
(: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.")
(:br)
(:input :type "checkbox" :id "controlpoly" :checked "checked"
:onclick (ps (redraw)) "Show control polygon")
(:input :type "checkbox" :id "grid" :checked "checked"
:onclick (ps (redraw)) "Show grid")
(: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 (remove-last)) "Remove last")
(:button :onclick (ps (reset)) "Reset")))))