;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Additional support (defmacro with-transformed-point ((x y p) &body body) `(let ((,p (transform-point (make-point ,x ,y) transformation))) ,@body)) (defmacro with-current-env (envstack &body body) (let ((e (gensym))) `(let ((,e (car ,envstack))) (with-slots (position transformation path) ,e ,@body)))) (defmacro aif (test then &optional else) `(let ((it ,test)) (if it ,then ,else))) (defparameter *expanders* '()) (defmacro defprescript (name arglist &body body) `(aif (assoc ',name *expanders*) (setf (cdr it) '(,arglist ,@body)) (push '(,name ,arglist ,@body) *expanders*))) (defprescript moveto (x y) (with-transformed-point (x y p) (setf position p) (setf path (initialize-path path p)))) (defmacro modify-transformation (arg) `(setf transformation (compose-transformations transformation ,arg))) (defprescript scale (sx sy) (modify-transformation (make-scaling-transformation sx sy))) (defprescript translate (tx ty) (modify-transformation (make-translation-transformation tx ty))) (defprescript rotate (angle) (modify-transformation (make-rotation-transformation angle))) (defprescript newpath () (setf path (new-path))) (defprescript lineto (x y) (with-transformed-point (x y p) (setf path (add-element path (make-lineseg p))) (setf position p))) (defprescript stroke () (stroke-path path)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The macro prescript (defmacro prescript (&body body) (let ((envstack (gensym))) `(let ((,envstack (list (make-initial-env)))) (labels ,(mapcar #'(lambda (expander) (let ((name (car expander)) (arglist (cadr expander)) (body (cddr expander))) `(,name ,arglist (with-current-env ,envstack ,@body)))) *expanders*) (macrolet ((gsave (&body body) `(progn (push (copy-env (car ,',envstack)) ,',envstack) (unwind-protect (progn ,@body) (pop ,',envstack))))) ,@body (values))))))