;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The interpreter (setf (get 'moveto 'prescript) #'(lambda (envstack x y) (with-slots (position transformation path) (car envstack) (let ((p (transform-point (make-point x y) transformation))) (setf position p) (setf path (cons (list p) path)))))) (setf (get 'scale 'prescript) #'(lambda (envstack sx sy) (with-slots (transformation) (car envstack) (setf transformation (compose-transformations transformation (make-scaling-transformation sx sy)))))) (setf (get 'translate 'prescript) #'(lambda (envstack tx ty) (with-slots (transformation) (car envstack) (setf transformation (compose-transformations transformation (make-translation-transformation tx ty)))))) (setf (get 'rotate 'prescript) #'(lambda (envstack angle) (with-slots (transformation) (car envstack) (setf transformation (compose-transformations transformation (make-rotation-transformation angle)))))) (setf (get 'newpath 'prescript) #'(lambda (envstack) (with-slots (path) (car envstack) (setf path (new-path))))) (setf (get 'lineto 'prescript) #'(lambda (envstack x y) (with-slots (position transformation path) (car envstack) (let ((p (transform-point (make-point x y) transformation))) (setf path (add-element path (make-lineseg p))) (setf position p))))) (setf (get 'stroke 'prescript) #'(lambda (envstack) (with-slots (path) (car envstack) (stroke-path path)))) (setf (get 'gsave 'prescript) #'(lambda (envstack &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)))))