;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 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)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The macro prescript (defmacro prescript (&body body) (let ((envstack (gensym))) `(let ((,envstack (list (make-initial-env)))) (labels ((moveto (x y) (with-current-env ,envstack (with-transformed-point (x y p) (setf position p) (setf path (initialize-path path p))))) (scale (sx sy) (with-current-env ,envstack (setf transformation (compose-transformations transformation (make-scaling-transformation sx sy))))) (translate (tx ty) (with-current-env ,envstack (setf transformation (compose-transformations transformation (make-translation-transformation tx ty))))) (rotate (angle) (with-current-env ,envstack (setf transformation (compose-transformations transformation (make-rotation-transformation angle))))) (newpath () (with-current-env ,envstack (setf path (new-path)))) (lineto (x y) (with-current-env ,envstack (with-transformed-point (x y p) (setf path (add-element path (make-lineseg p))) (setf position p)))) (stroke () (with-current-env ,envstack (stroke-path path)))) (macrolet ((gsave (&body body) `(progn (push (copy-env (car ,',envstack)) ,',envstack) (unwind-protect (progn ,@body) (pop ,',envstack))))) ,@body (values))))))