Skip to content

Instantly share code, notes, and snippets.

@khirbat
Last active April 2, 2016 19:12
  • Star 1 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
Star You must be signed in to star a gist
Save khirbat/e96ab89f75cb22a114d7 to your computer and use it in GitHub Desktop.
Coursera Programming Languages homework 7 in Common Lisp using multimethods/multiple dispatch.
;;;; 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~%"))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment