Coursera Programming Languages homework 7 in Common Lisp using multimethods/multiple dispatch.

hw7.lisp

;;;; hw7.lisp

;;; USAGE:
;;;
;;; Use the functions listed under the heading CONSTRUCTORS to create
;;; expressions.  The CONSTRUCTORS, EVAL-PROG and PREPROCESS-PROG are
;;; the public interface.  All other functions should be considered
;;; private.  Symbols (not strings) are used to represent variables.
;;;
;;; CL-USER> (load "hw7.lisp")
;;; CL-USER> (in-package :hw7)
;;; #<PACKAGE "HW7">
;;; HW7> (-let 'x (line 1.0 2.0)
;;;            (-intersect (vertical-line 5.0) (-var 'x)))
;;; #<-LET X #<LINE 1.0 2.0 {10045D80A3}> #<-INTERSECT #<VERTICAL-LINE 5.0 {10045D8103}> #<-VAR X {10045D8163}> {10045D81B3}> {10045D8203}>
;;;
;;; HW7> (eval-prog (preprocess-prog *) nil)
;;; #<POINT 5.0 7.0 {100646E573}>

;;; NOTES:
;;;
;;; The OO Lisp code looks a lot like the SML code, rather than the Ruby code.
;;;
;;; e.g.
;;; (defmethod intersect ((v1 vertical-line) (v2 vertical-line))
;;;   (if (real-close (x v1) (x v2))
;;;      v1             ;; same line
;;;      (nopoints)))   ;; parallel lines
;;;
;;; looks like the SML pattern
;;; (VerticalLine x1, VerticalLine x2)
;;;
;;; And,
;;; (defmethod intersect (e1 e2)
;;;   (format t "bad call to intersect: only for shape values~%"))
;;; looks like the SML wildcard pattern.

;;; Pattern matching and multiple dispatch look quite similar.

(defpackage #:hw7
  (:use #:cl))

(in-package #:hw7)

(defgeneric eval-prog (e env))
(defgeneric preprocess-prog (e))

(defgeneric intersect (e1 e2))
(defgeneric shift (dx dy e))
(defgeneric intersect-with-segment-as-line-result (e seg))

(defclass geometry-expression () nil)
(defclass geometry-value (geometry-expression) nil)

(defmethod eval-prog ((e geometry-expression) env)
  e)

(defmethod preprocess-prog ((e geometry-expression))
  e)

;;; NOPOINTS

(defclass nopoints (geometry-value) nil)

(defmethod shift (dx dy (e nopoints))
  e)

;;; POINT

(defclass point (geometry-value)
  ((x :initarg :x :reader x)
   (y :initarg :y :reader y)))

(defmethod print-object ((obj point) stream)
  (print-unreadable-object (obj stream :type t :identity t)
    (format stream "~d ~d" (x obj) (y obj))))

(defmethod shift (dx dy (e point))
  (point (+ dx (x e))
         (+ dy (y e))))

;;; LINE

(defclass line (geometry-value)
  ((m :initarg :m :reader m)
   (b :initarg :b :reader b)))

(defmethod print-object ((obj line) stream)
  (print-unreadable-object (obj stream :type t :identity t)
    (format stream "~d ~d" (m obj) (b obj))))

(defmethod shift (dx dy (e line))
  (line (m e) (+ (b e) dy (* -1 (m e) dx))))

;;; VERTICAL-LINE

(defclass vertical-line (geometry-value)
  ((x :initarg :x :reader x)))

(defmethod print-object ((obj vertical-line) stream)
  (print-unreadable-object (obj stream :type t :identity t)
    (format stream "~d" (x obj))))

(defmethod shift (dx dy (e vertical-line))
  (vertical-line (+ dx (x e))))

;;; LINE-SEGMENT

(defclass line-segment (geometry-value)
  ((x1 :initarg :x1 :reader x1)
   (y1 :initarg :y1 :reader y1)
   (x2 :initarg :x2 :reader x2)
   (y2 :initarg :y2 :reader y2)))

(defmethod print-object ((obj line-segment) stream)
  (print-unreadable-object (obj stream :type t :identity t)
    (format stream "~d ~d ~d ~d" (x1 obj) (y1 obj) (x2 obj) (y2 obj))))

(defmethod shift (dx dy (e line-segment))
  (line-segment (+ (x1 e) dx) (+ (y1 e) dy) (+ (x2 e) dx) (+ (y2 e) dy)))

(defmethod preprocess-prog ((e line-segment))
  (with-slots (x1 y1 x2 y2) e
    (if (real-close-point x1 y1 x2 y2)
        (point x1 y1)
        (if (or (> x1 x2)
                (and (real-close x1 x2)
                     (> y1 y2)))
            (line-segment x2 y2 x1 y1)
            e))))

;;; VAR

(defclass -var (geometry-expression)
  ((s :initarg :s)))

(defmethod print-object ((obj -var) stream)
  (print-unreadable-object (obj stream :type t :identity t)
    (format stream "~S" (slot-value obj 's))))

(defmethod eval-prog ((e -var) env)
  (let ((pr (assoc (slot-value e 's) env)))
    (if (null pr)
        (error (format nil "Variable \"~s\" not found" (slot-value e 's)))
        (cdr pr))))

;;; LET

(defclass -let (geometry-expression)
  ((s  :initarg :s)
   (e1 :initarg :e1)
   (e2 :initarg :e2)))

(defmethod print-object ((obj -let) stream)
  (print-unreadable-object (obj stream :type t :identity t)
    (with-slots (s e1 e2) obj
      (format stream "~S ~S ~S" s e1 e2))))

(defmethod preprocess-prog ((e -let))
  (with-slots (s e1 e2) e
    (-let s (preprocess-prog e1) (preprocess-prog e2))))

(defmethod eval-prog ((e -let) env)
  (with-slots (s e1 e2) e
    (let ((e1-val (eval-prog e1 env)))
      (eval-prog e2 (cons (cons s e1-val) env)))))

;;; INTERSECT

(defclass -intersect (geometry-expression)
  ((e1 :initarg :e1)
   (e2 :initarg :e2)))

(defmethod print-object ((obj -intersect) stream)
  (print-unreadable-object (obj stream :type t :identity t)
    (with-slots (e1 e2) obj
      (format stream "~S ~S" e1 e2))))

(defmethod preprocess-prog ((e -intersect))
  (with-slots (e1 e2) e
    (-intersect (preprocess-prog e1) (preprocess-prog e2))))

(defmethod eval-prog ((e -intersect) env)
  (with-slots (e1 e2) e
    (intersect (eval-prog e1 env)
               (eval-prog e2 env))))

;;; SHIFT

(defclass -shift (geometry-expression)
  ((dx :initarg :dx)
   (dy :initarg :dy)
   (e  :initarg :e)))

(defmethod print-object ((obj -shift) stream)
  (print-unreadable-object (obj stream :type t :identity t)
    (with-slots (dx dy e) obj
      (format stream "~d ~d ~S" dx dy e))))

(defmethod preprocess-prog ((e -shift))
  (with-slots (dx dy e) e
    (-shift dx dy (preprocess-prog e))))

(defmethod eval-prog ((e -shift) env)
  (with-slots (dx dy e) e
    (shift dx dy (eval-prog e env))))

;;; CONSTRUCTORS

(defun nopoints ()
  (make-instance 'nopoints))

(defun point (x y)
  (make-instance 'point :x x :y y))

(defun line (m b)
  (make-instance 'line :m m :b b))

(defun vertical-line (x)
  (make-instance 'vertical-line :x x))

(defun line-segment (x1 y1 x2 y2)
  (make-instance 'line-segment :x1 x1 :y1 y1 :x2 x2 :y2 y2))

(defun -var (s)
  (make-instance '-var :s s))

(defun -let (s e1 e2)
  (make-instance '-let :s s :e1 e1 :e2 e2))

(defun -intersect (e1 e2)
  (make-instance '-intersect :e1 e1 :e2 e2))

(defun -shift (dx dy e)
  (make-instance '-shift :dx dx :dy dy :e e))

;;; HELPER FUNCTIONS

(defparameter *epsilon* 0.00001)

(defun in-between (v end1 end2)
  (or (and (<= (- end1 *epsilon*) v)
           (<= v (+ end2 *epsilon*)))
      (and (<= (- end2 *epsilon*) v)
           (<= v (+ end1 *epsilon*)))))

(defun real-close (a b)
  (< (abs (- a b)) *epsilon*))

(defun real-close-point (x1 y1 x2 y2)
  (and (real-close x1 x2)
       (real-close y1 y2)))

(defun two-points-to-line (x1 y1 x2 y2)
  (if (real-close x1 x2)
      (vertical-line x1)
      (let* ((m (/ (- y2 y1) (- x2 x1)))
             (b (- y1 (* m x1))))
        (line m b))))

;;; INTERSECT

(defmethod intersect ((e1 nopoints) e2)
  "5 cases"
  e1)

(defmethod intersect (e1 (e2 nopoints))
  "4 additional cases"
  e2)

(defmethod intersect ((p1 point) (p2 point))
  (if (real-close-point (x p1) (y p1) (x p2) (y p2))
      p1
      (nopoints)))

(defmethod intersect ((p point) (l line))
  (if (real-close (y p) (+ (* (m l) (x p)) (b l)))
      p
      (nopoints)))

(defmethod intersect ((p point) (v vertical-line))
  (if (real-close (x p) (x v))
      p
      (nopoints)))

(defmethod intersect ((p point) (seg line-segment))
  (intersect seg p))

(defmethod intersect ((l line) (p point))
  (intersect p l))

(defmethod intersect ((l1 line) (l2 line))
  (with-slots ((m1 m) (b1 b)) l1
    (with-slots ((m2 m) (b2 b)) l2
      (if (real-close m1 m2)
          (if (real-close b1 b2)
              l1          ;; same line
              (nopoints)) ;; parallel lines
          (let* ((x (/ (- b2 b1) (- m1 m2)))
                 (y (+ b1 (* x m1))))
            (point x y)))))) ;; one-point intersection

(defmethod intersect ((l line) (v vertical-line))
  (point (x v) (+ (b l) (* (m l) (x v)))))

(defmethod intersect ((l line) (seg line-segment))
    (intersect seg l))

(defmethod intersect ((v vertical-line) (p point))
  (intersect p v))

(defmethod intersect ((v vertical-line) (l line))
  (intersect l v))

(defmethod intersect ((v1 vertical-line) (v2 vertical-line))
  (if (real-close (x v1) (x v2))
      v1            ;; same line
      (nopoints)))  ;; parallel lines

(defmethod intersect ((v vertical-line) (seg line-segment))
  (intersect seg v))

(defmethod intersect ((seg line-segment) e)
  (with-slots (x1 y1 x2 y2) seg
    (let ((line-result (intersect (two-points-to-line x1 y1 x2 y2) e)))
      (intersect-with-segment-as-line-result line-result seg))))

(defmethod intersect (e1 e2)
    (format t "bad call to intersect: only for shape values~%"))

(defmethod intersect-with-segment-as-line-result ((e nopoints) (seg line-segment))
  e)

(defmethod intersect-with-segment-as-line-result ((e point) (seg line-segment))
  (with-slots (x1 y1 x2 y2) seg
    (if (and (in-between (x e) x1 x2)
             (in-between (y e) y1 y2))
        e
        (nopoints))))

(defmethod intersect-with-segment-as-line-result ((e line) (seg line-segment))
  seg)

(defmethod intersect-with-segment-as-line-result ((e vertical-line) (seg line-segment))
  seg)

(defmethod intersect-with-segment-as-line-result ((seg line-segment) (seg2 line-segment))
  (with-slots ((x1start x1) (y1start y1) (x1end x2) (y1end y2)) seg
    (with-slots ((x2start x1) (y2start y1) (x2end x2) (y2end y2)) seg2
      (let ((s (list x1start y1start x1end y1end))
            (s2 (list x2start y2start x2end y2end)))
        (if (real-close x1start x1end)
            ;; the segments are on a vertical line
            ;; let segment A start at or below start of segment B
            (destructuring-bind
                  (aXstart aYstart aXend aYend bXstart bYstart bXend bYend)
                (if (< y1start y2start)
                    (nconc s s2)
                    (nconc s2 s))
              (declare (ignore aXstart aYstart bXend))
              (cond ((real-close aYend bYstart) (point aXend aYend)) ; just touching
                    ((< aYend bYstart) (nopoints)) ; disjoint
                    ((> aYend bYend) (line-segment bXstart bYstart bXstart bYend)) ; B inside A
                    (t (line-segment bXstart bYstart aXend aYend)))) ; overlapping

            ;; the segments are on a (non-vertical) line
            ;; let segment A start at or to the left of start of segment B
            (destructuring-bind
                  (aXstart aYstart aXend aYend bXstart bYstart bXend bYend)
                (if (< x1start x2start)
                    (nconc s s2)
                    (nconc s2 s))
              (declare (ignore aXstart aYstart aYend))
              (cond ((real-close aXend bXstart) (point aXend bXstart)) ; just touching
                    ((< aXend bXstart) (nopoints)) ; disjoint
                    ((> aXend bXend) (line-segment bXstart bYstart bXend bYend)) ; B inside A
                    (t (line-segment bXstart bYstart bXend bYend))))))))) ; overlapping

(defmethod intersect-with-segment-as-line-result (e1 e2)
  (format t "bad result from intersecting with a line~%"))