# Ramarren/cl-geometry

Fetching contributors…
Cannot retrieve contributors at this time
90 lines (75 sloc) 2.77 KB
 (in-package :2d-geometry) ;;;; This file implements basic functions operating on points. A point is any object with methods (x ;;;; object) (y object). (defclass point () ((x :reader x :initarg :x :initform 0) (y :reader y :initarg :y :initform 0)) (:documentation "A point on a plane, with cartesian coordinates.")) (defmethod print-object ((object point) stream) (print-unreadable-object (object stream :type t) (format stream "~a,~a" (x object) (y object)))) (defun make-point (x y &optional (point-type 'point)) "Create a new point like object." (make-instance point-type :x x :y y)) (defun point-equal-p (point1 point2) "Checks if two points are geometrically equal." (and (= (x point1)(x point2)) (= (y point1)(y point2)))) (defun coords-to-points (&rest coord-list) "Coordinate list (x1 y1 x2 y2 ... xn yn) to point list" (assert (zerop (mod (length coord-list) 2))) (iterate (for (x y . nil) on coord-list by #'cddr) (collect (make-point x y)))) (defun left-p (a b c) "Is c to the left of the oriented line defined by a->b?" (> (area-triangle-vertices (x a)(y a)(x b)(y b) (x c)(y c)) 0)) (defun left-on-p (a b c) "Is c to the left or on the oriented line defined by a->b?" (>= (area-triangle-vertices (x a)(y a)(x b)(y b) (x c)(y c)) 0)) (defun colinear-p (a b c) "Is c on the line defined by a->b?" (zerop (area-triangle-vertices (x a)(y a)(x b)(y b) (x c)(y c)))) (defun between-p (a b c) "Is c colinear with a->b and lies between them?" (when (colinear-p a b c) (if (= (y a)(y b)) (or (and (>= (x c)(x a)) (<= (x c)(x b))) (and (>= (x c)(x b)) (<= (x c)(x a)))) (or (and (>= (y c)(y a)) (<= (y c)(y b))) (and (>= (y c)(y b)) (<= (y c)(y a))))))) (defun xor (p q) "Exlusive or logical operation." (if (or (and p q) (and (not p)(not q))) nil t)) (defun intersect-proper-p (a b c d) "Do segments a->b and c->d intersect?" (unless (or (colinear-p a b c) (colinear-p a b d) (colinear-p c d a) (colinear-p c d b)) (and (xor (left-p a b c) (left-p a b d)) (xor (left-p c d a) (left-p c d b))))) (defun intersect-p (a b c d) "Do segments a->b and c->d intersect?" (if (intersect-proper-p a b c d) t (or (between-p a b c) (between-p a b d) (between-p c d a) (between-p c d b)))) (defun point-sort-fun (point1 point2) "Order points by increasing x then y." (if (= (x point1)(x point2)) (if (= (y point1)(y point2)) (if (typep point1 'event-endpoint) (eql (direction point1) 'right)) (< (y point1)(y point2))) (< (x point1)(x point2))))