(defclass pt () ((x :reader x :initarg :x :type rational) (y :reader y :initarg :y :type rational)) (:documentation "A rational point in the Cartesian plane.")) (defmethod make-pt ((x rational) (y rational)) (make-instance 'pt :x x :y y)) (defgeneric math-equal-p (o1 o2) (:documentation "Whether two pts, or two lines, are equal.")) (defmethod math-equal-p ((p1 pt) (p2 pt)) (and (= (x p1) (x p2)) (= (y p1) (y p2)))) (defmethod print-object ((p pt) s) (format s "(~S,~S)" (x p) (y p))) (defclass line () ((a :reader a :initarg :a :type rational) (b :reader b :initarg :b :type rational) (c :reader c :initarg :c :type rational)) (:documentation "A rational line ax + by + c = 0 in the Cartesian plane. It is an error if a and b are 0 simultaneously.")) (defmethod print-object ((l line) s) (format s "[~S*x + ~S*y + ~S = 0]" (a l) (b l) (c l))) (defmethod degeneratep ((l line)) (and (zerop (a l)) (zerop (b l)))) (defmethod math-equal-p ((l1 line) (l2 line)) (assert (not (degeneratep l1)) (l1) "Degenerate line l1 = ~S." l1) (assert (not (degeneratep l2)) (l2) "Degenerate line l2 = ~S." l2) (with-slots ((a1 a) (b1 b) (c1 c)) l1 (with-slots ((a2 a) (b2 b) (c2 c)) l2 (if (zerop a1) (if (zerop a2) (= (/ c1 b1) (/ c2 b2)) nil) (if (zerop a2) nil (and (= (/ b1 a1) (/ b2 a2)) (= (/ c1 a1) (/ c2 a2)))))))) (defmethod line-on-two-pts ((p1 pt) (p2 pt)) "Returns the line passing through the two points." (assert (not (math-equal-p p1 p2)) (p1 p2) "Inputs are equal.") (with-slots ((x1 x) (y1 y)) p1 (with-slots ((x2 x) (y2 y)) p2 (if (= x1 x2) (make-instance 'line :a 1 :b 0 :c (- x1)) ;; x - x1 = 0 (let* ((m (/ (- y2 y1) (- x2 x1))) ;; m*x - y + c = 0 (c (+ (* (- m) x1) y1))) (make-instance 'line :a m :b -1 :c c)))))) (defmethod intersect ((l1 line) (l2 line)) "Returns the point of intersection of the two lines. Returns nil if they're parallel, equal, or degenerate." (with-slots ((a1 a) (b1 b) (c1 c)) l1 (with-slots ((a2 a) (b2 b) (c2 c)) l2 (let ((det (- (* a1 b2) (* a2 b1)))) (if (zerop det) ;; parallel, equal or degenerate nil (let ((k1 (/ (+ (* b2 c1) (* (- b1) c2)) det)) (k2 (/ (+ (* (- a2) c1) (* a1 c2)) det))) (make-pt (- k1) (- k2)))))))) (defun all-intersections (line-lyst) "Returns a list of the intersection pts of all pairs of lines in line-lyst. Automatically removes duplicate points." (let ((ans '())) (do ((lyst0 line-lyst (rest lyst0))) ((endp lyst0) (remove-duplicates ans :test #'math-equal-p)) (do ((lyst1 (rest lyst0) (rest lyst1))) ((endp lyst1)) (let ((p (intersect (first lyst0) (first lyst1)))) (when p (push p ans))))))) (defmethod on-p ((p pt) (l line)) (zerop (+ (* (x p) (a l)) (* (y p) (b l)) (c l)))) (defmethod on-two-p ((p0 pt) (p1 pt) (p2 pt) (l line)) "Whether exactly two of the points are on the line." (let ((ct 0)) (when (on-p p0 l) (incf ct)) (when (on-p p1 l) (incf ct)) (when (on-p p2 l) (incf ct)) (= ct 2))) (defun all-triangles (pt-lyst line-lyst) "Returns a list of all triples of pts in pt-lyst for which there are three lines in line-lyst with each line containing two of the points. It is an error if either input list contains duplicates." (let ((ll (remove-duplicates line-lyst :test #'math-equal-p)) (ans '())) (do ((pp0 pt-lyst (rest pp0))) ((endp pp0) ans) (do ((pp1 (rest pp0) (rest pp1))) ((endp pp1)) (do ((pp2 (rest pp1) (rest pp2))) ((endp pp2)) (let ((p0 (first pp0)) (p1 (first pp1)) (p2 (first pp2))) (when (= 3 (count-if #'(lambda (l) (on-two-p p0 p1 p2 l)) ll)) (push (list p0 p1 p2) ans)))))))) (defun buss-test () (let ((p0 (make-pt 0 0)) (p5 (make-pt 1 1)) (p8 (make-pt 2 2)) (p10 (make-pt 3 3)) (p9 (make-pt 4 2)) (p6 (make-pt 5 1)) (p1 (make-pt 6 0))) (let ((line-lyst (list (line-on-two-pts p0 p1) (line-on-two-pts p0 p6) (line-on-two-pts p0 p9) (line-on-two-pts p0 p10) (line-on-two-pts p1 p5) (line-on-two-pts p1 p8) (line-on-two-pts p1 p10)))) (let ((triangle-lyst (all-triangles (all-intersections line-lyst) line-lyst))) (format t "Found ~D triangles." (length triangle-lyst)) triangle-lyst))))