vectometry/point.lisp

   1 ;;;; point.lisp
   2
   3 (in-package #:vecto-geometry)
   4
   5 (defclass point ()
   6   ((x
   7     :initarg :x
   8     :accessor x)
   9    (y
  10     :initarg :y
  11     :accessor y)))
  12
  13 (defmethod print-object ((point point) stream)
  14   (print-unreadable-object (point stream :type t)
  15     (format stream "~A,~A" (x point) (y point))))
  16
  17 (defun point (x y)
  18   (make-instance 'point :x x :y y))
  19
  20 (defun coordinates (point)
  21   (values (x point) (y point)))
  22
  23 (defun xpoint (x)
  24   (point x 0))
  25
  26 (defun ypoint (y)
  27   (point 0 y))
  28
  29 (defun apoint (angle distance)
  30   (point (* distance (cos angle))
  31          (* distance (sin angle))))
  32
  33 (defgeneric midpoint (a b)
  34   (:method (a b)
  35     (point (/ (+ (x a) (x b)) 2)
  36            (/ (+ (y a) (y b)) 2))))
  37
  38 (defgeneric eqv (a b)
  39   (:method (a b)
  40     (and (= (x a) (x b))
  41          (= (y a) (y b)))))
  42
  43 (defgeneric add (a b &rest args)
  44   (:method (a b &rest args)
  45     (if args
  46         (reduce #'add/2 args :initial-value (add/2 a b))
  47         (add/2 a b))))
  48
  49 (macrolet ((define-point-op (name operation)
  50              `(defgeneric ,name (a b)
  51                (:method ((a point) (b point))
  52                  (point (,operation (x a) (x b))
  53                         (,operation (y a) (y b)))))))
  54   (define-point-op add/2 +)
  55   (define-point-op sub -)
  56   (define-point-op mul *)
  57   (define-point-op div /))
  58
  59 (defgeneric neg (object)
  60   (:method ((point point))
  61     (point (- (x point))
  62            (- (y point)))))
  63
  64 (defgeneric distance (p1 p2)
  65   (:method ((p1 point) (p2 point))
  66     (let ((diff (sub p1 p2)))
  67       (sqrt (+ (* (x diff) (x diff))
  68                (* (y diff) (y diff)))))))
  69
  70 (defgeneric abs* (object)
  71   (:method ((point point))
  72     (point (abs (x point))
  73            (abs (y point)))))
  74
  75 (defgeneric angle (p1 p2)
  76   (:method ((p1 point) (p2 point))
  77     (let* ((diff (sub p2 p1))
  78            (x (x diff))
  79            (y (y diff)))
  80       (if (zerop x)
  81           (if (plusp y)
  82               (/ pi 2)
  83               (* 3 (/ pi 2)))
  84           (atan y x)))))
  85
  86 (defgeneric scale (object scalar)
  87   (:method ((point point) scalar)
  88     (point (* (x point) scalar)
  89            (* (y point) scalar))))
  90
  91
  92 (defvar *origin* (point 0 0))