Epicycles demo using ParenScript

epicycles.paren

(defvar *canvas-name* "myCanvas")
(defvar *canvas-style* "border:1px solid #000000;")
(defvar *canvas-width* 400)
(defvar *canvas-height* 400)

(defun create-canvas ()
  ((@ document write)
   (ps-html ((:canvas :id *canvas-name*
		      :width *canvas-width*
		      :height *canvas-height*
		      :style *canvas-style*))))
  (chain document (get-element-by-id *canvas-name*)))

(defvar *canvas* (create-canvas))
(defvar *ctx* (chain *canvas* (get-context "2d")))

(defmacro on-canvas (&body body)
  (flet ((convert (sexp)
	   (if (eq 'setprop (car sexp))
	       `(setf (@ *ctx* ,(cadr sexp)) ,(caddr sexp))
	       `(chain *ctx* ,sexp))))
    `(progn ,@(mapcar #'convert body))))


(defvar *t* 0)

(defun update ()
  (incf *t* (/ (* 2 pi) 180))
  (when (>= *t* (* 2 pi)) (setf *t* (- *t* (* 2 pi))))
  t)

(defvar *precoord* '())
(defvar *maxpoints* 180)

(defun add-shift-left (array object)
  (let ((len (length array)))
    (dotimes (i (1- len))
      (setf (elt array i) (elt array (1+ i))))
    (setf (elt array (1- len)) object)
    t))

(defun draw ()
  (let* ((r1 185)
	 (r2 15)
	 (w1 1)
	 (w2 -4)
	 (x1 (+ 200 (* r1 (cos (* w1 *t*)))))
	 (y1 (- 200 (* r1 (sin (* w1 *t*)))))
	 (x2 (+ x1 (* r2 (cos (* w2 *t*)))))
	 (y2 (- y1 (* r2 (sin (* w2 *t*))))))
    (if (< (length *precoord*) *maxpoints*)
	(setf *precoord* (append *precoord* (create x x2 :y y2)))
	(add-shift-left *precoord* (create x x2 :y y2)))
    (on-canvas
     (clear-rect 0 0 400 400)
     (fill-text *t* 10 10)
     (setprop line-width 1)
     (setprop stroke-style "black")
     (begin-path)
     (move-to 200 200)
     (line-to x1 y1)
     (move-to x1 y1)
     (line-to x2 y2)
     (stroke)
     (setprop stroke-style "red")
     (begin-path)
     (arc 200 200 r1 0 (* 2 pi))
     (stroke)
     (setprop stroke-style "green")
     (begin-path)
     (arc x1 y1 r2 0 (* 2 pi))
     (stroke)
     (setprop fill-style "red")
     (begin-path)
     (arc x1 y1 5 0 (* 2 pi))
     (fill)
     (setprop fill-style "green")
     (begin-path)
     (arc x2 y2 5 0 (* 2 pi))
     (fill))
    (when (> (length *precoord*) 1)
      (let ((startcoord (elt *precoord* 0)))
	(on-canvas
	 (setprop line-width 2)
	 (begin-path)
	 (move-to (@ startcoord x) (@ startcoord y)))
	(dolist (coord *precoord*)
	  (on-canvas
	   (line-to (@ coord x) (@ coord y))))
	(on-canvas (stroke))))
    t))


;;; Set a loop
(defvar *fps* 30)


(set-interval
 (lambda ()
   (update)
   (draw)
   t)
 (/ 1000 *fps*))