;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Additional support (defmacro defprescript (name arglist &body body) `(setf (get ',name 'prescript) #'(lambda (envstack ,@arglist) (with-slots (position transformation path) (car envstack) ,@body)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The interpreter (defprescript moveto (x y) (let ((p (transform-point (make-point x y) transformation))) (setf position p) (setf path (cons (list p) path)))) (defprescript scale (sx sy) (setf transformation (compose-transformations transformation (make-scaling-transformation sx sy)))) (defprescript translate (tx ty) (setf transformation (compose-transformations transformation (make-translation-transformation tx ty)))) (defprescript rotate (angle) (setf transformation (compose-transformations transformation (make-rotation-transformation angle)))) (defprescript newpath () (setf path (new-path))) (defprescript lineto (x y) (let ((p (transform-point (make-point x y) transformation))) (setf path (add-element path (make-lineseg p))) (setf position p))) (defprescript stroke () (stroke-path path)) (defprescript gsave (&rest commands) (let ((newenvstack (cons (copy-env (car envstack)) envstack))) (loop for command in commands do (apply (get (car command) 'prescript) newenvstack (cdr command))))) (defun prescript-interpreter (commands) (let ((envstack (list (make-initial-env)))) (loop for command in commands do (apply (get (car command) 'prescript) envstack (cdr command)))))