;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; X11 routines (defparameter *dpy* nil) (defparameter *win* nil) (defparameter *gctxt* nil) (defun get-environment-variable (string) (cdr (assoc string ext:*environment-list* :test #'string=))) (defun parse-display-variable (s) (let* ((colon (position #\: s)) (dot (position #\. s :start colon)) (host-name (if (zerop colon) "localhost" (subseq s 0 colon))) (display-number (parse-integer s :start (1+ colon) :end dot))) (values host-name display-number))) (defun open-window () (multiple-value-bind (host display) (parse-display-variable (get-environment-variable "DISPLAY")) (let* ((dpy (xlib:open-display host :display display)) (screen (xlib:display-default-screen dpy)) (black (xlib:screen-black-pixel screen)) (white (xlib:screen-white-pixel screen)) (win (xlib:create-window :parent (xlib:screen-root screen) :background white :x 0 :y 0 :width 500 :height 500)) (gcontext (xlib:create-gcontext :drawable win :background white :foreground black))) (xlib:map-window win) (xlib:display-force-output dpy) (setf *dpy* dpy *win* win *gctxt* gcontext)))) (defun draw-line (x1 y1 x2 y2) (xlib:draw-line *win* *gctxt* (round x1) (round y1) (round x2) (round y2)) (xlib:display-force-output *dpy*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Point (defclass point () ((x :initarg :x) (y :initarg :y))) (defun make-point (x y) (make-instance 'point :x x :y y)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Transformation (defclass transformation () ((mxx :initarg :mxx) (mxy :initarg :mxy) (myx :initarg :myx) (myy :initarg :myy) (tx :initarg :tx) (ty :initarg :ty))) (defun get-transformation (transformation) (with-slots (mxx mxy myx myy tx ty) transformation (values mxx mxy myx myy tx ty))) (defun make-transformation (mxx mxy myx myy tx ty) (make-instance 'transformation :mxx mxx :mxy mxy :myx myx :myy myy :tx tx :ty ty)) (defun make-translation-transformation (tx ty) (make-transformation 1 0 0 1 tx ty)) (defun make-rotation-transformation (angle) (let ((radians (* angle #.(/ pi 180)))) (let ((s (sin radians)) (c (cos radians))) (make-transformation c (- s) s c 0 0)))) (defun make-scaling-transformation (sx sy) (make-transformation sx 0 0 sy 0 0)) (defun compose-transformations (t1 t2) (multiple-value-bind (mxx1 mxy1 myx1 myy1 tx1 ty1) (get-transformation t1) (multiple-value-bind (mxx2 mxy2 myx2 myy2 tx2 ty2) (get-transformation t2) (make-transformation (+ (* mxx1 mxx2) (* mxy1 myx2)) (+ (* mxx1 mxy2) (* mxy1 myy2)) (+ (* myx1 mxx2) (* myy1 myx2)) (+ (* myx1 mxy2) (* myy1 myy2)) (+ (* mxx1 tx2) (* mxy1 ty2) tx1) (+ (* myx1 tx2) (* myy1 ty2) ty1))))) (defun transform-point (point transformation) (with-slots (mxx mxy myx myy tx ty) transformation (with-slots (x y) point (make-point (+ (* mxx x) (* mxy y) tx) (+ (* myx x) (* myy y) ty))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Path ;;; A path is a list of subpaths. Each valid subpath contains ;;; a list of elements (line- , curve-, and arc segments) with the ;;; last element being a point, the origin of the subpath. ;;; create an uninitialized path (defun new-path () '()) ;;; initialize a path with a point (defun initialize-path (path point) (cons (list point) path)) ;;; add an element to an initialized path (defun add-element (path element) (assert (car path)) (cons (cons element (car path)) (cdr path))) (defgeneric stroke-one (point segment)) (defun stroke-subpath (subpath) (reduce #'stroke-one (cdr subpath) :initial-value (car subpath))) (defun stroke-path (path) (mapc #'stroke-subpath (reverse (mapcar #'reverse path)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Line segment (defclass lineseg () ((point :initarg :point))) (defun make-lineseg (point) (make-instance 'lineseg :point point)) (defmethod stroke-one (point (seg lineseg)) (let ((p2 (slot-value seg 'point))) (draw-line (slot-value point 'x) (slot-value point 'y) (slot-value p2 'x) (slot-value p2 'y)) p2)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Arc segment ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Curve segment ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Environement (defclass env () ((position :initarg :position) (transformation :initarg :transformation) (path :initform (new-path) :initarg :path))) (defun make-initial-env () (make-instance 'env :position (make-point 0 0) :transformation (make-transformation 1 0 0 -1 0 500))) (defun copy-env (env) (with-slots (position transformation path) env (make-instance 'env :position position :transformation transformation :path path)))