vectometry/box.lisp

   1 ;;;; box.lisp
   2
   3 (in-package #:vecto-geometry)
   4
   5 (defclass box ()
   6   ((xmin
   7     :initarg :xmin
   8     :accessor xmin)
   9    (ymin
  10     :initarg :ymin
  11     :accessor ymin)
  12    (xmax
  13     :initarg :xmax
  14     :accessor xmax)
  15    (ymax
  16     :initarg :ymax
  17     :accessor ymax)))
  18
  19
  20 (defmethod initialize-instance :before ((box box) &key
  21                                         xmin ymin xmax ymax)
  22   (assert (<= xmin xmax))
  23   (assert (<= ymin ymax)))
  24
  25 (defmethod xmin ((point point))
  26   (x point))
  27
  28 (defmethod xmax ((point point))
  29   (x point))
  30
  31 (defmethod ymin ((point point))
  32   (y point))
  33
  34 (defmethod ymax ((point point))
  35   (y point))
  36
  37 (defmethod print-object ((object box) stream)
  38   (print-unreadable-object (object stream :type t)
  39     (format stream "~A,~A ~A,~A"
  40             (xmin object)
  41             (ymin object)
  42             (xmax object)
  43             (ymax object))))
  44
  45 (defun box (xmin ymin xmax ymax)
  46   (make-instance 'box
  47                  :xmin xmin
  48                  :ymin ymin
  49                  :xmax xmax
  50                  :ymax ymax))
  51
  52 (defun point-box (a b)
  53   "Creates the smallest box that contains the points A and B."
  54   (box (min (x a) (x b)) (min (y a) (y b))
  55        (max (x a) (x b)) (max (y a) (y b))))
  56
  57 (defun origin-box (point)
  58   "Creates a bounding box that includes both the origin and POINT."
  59   (point-box *origin* point))
  60
  61 (defun bbox-box (bbox)
  62   "Creates a box from the BBOX vector."
  63   (box (aref bbox 0)
  64        (aref bbox 1)
  65        (aref bbox 2)
  66        (aref bbox 3)))
  67
  68 (defgeneric minpoint (box)
  69   (:method ((box box))
  70     (point (xmin box) (ymin box))))
  71
  72 (defgeneric maxpoint (box)
  73   (:method ((box box))
  74     (point (xmax box) (ymax box))))
  75
  76 (defgeneric centerpoint (box)
  77   (:method ((box box))
  78     (midpoint (minpoint box) (maxpoint box))))
  79
  80 (defgeneric width (object)
  81   (:method (object)
  82     (- (xmax object) (xmin object))))
  83
  84 (defgeneric height (object)
  85   (:method (object)
  86     (- (ymax object) (ymin object))))
  87
  88 (defgeneric area (box)
  89   (:method ((box box))
  90     (* (width box) (height box))))
  91
  92 (defgeneric emptyp (box)
  93   (:method ((box box))
  94     ;; A little more efficient than (zerop (area box))
  95     (or (= (xmax box) (xmin box))
  96         (= (ymax box) (ymin box)))))
  97
  98 (defun contract (box amount)
  99   (let ((p (point amount amount)))
 100     (point-box (add (minpoint box) p)
 101                (sub (maxpoint box) p))))
 102
 103 (defun expand (box amount)
 104   (contract box (- amount)))
 105
 106 (defun %point-box-add (point box)
 107   (point-box (add (minpoint box) point)
 108              (add (maxpoint box) point)))
 109
 110 (defmethod add/2 ((point point) (box box))
 111   (%point-box-add point box))
 112
 113 (defmethod add/2 ((box box) (point point))
 114   (%point-box-add point box))
 115
 116 (defun %point-box-mul (point box)
 117   (point-box (mul (minpoint box) point)
 118              (mul (maxpoint box) point)))
 119
 120 (defmethod mul ((point point) (box box))
 121   (%point-box-mul point box))
 122
 123 (defmethod mul ((box box) (point point))
 124   (%point-box-mul point box))
 125
 126 (defmethod sub ((box box) (point point))
 127   (point-box (sub (minpoint box) point)
 128              (sub (maxpoint box) point)))
 129
 130 (defmethod div ((box box) (point point))
 131   (point-box (div (minpoint box) point)
 132              (div (maxpoint box) point)))
 133
 134 (defmethod eqv ((a box) (b box))
 135   (and (= (xmin a) (xmin b))
 136        (= (xmax a) (xmax b))
 137        (= (ymin a) (ymin b))
 138        (= (ymax a) (ymax b))))
 139
 140
 141 (defgeneric displace (box point)
 142   (:method ((box box) point)
 143     (point-box (add (minpoint box) point)
 144                (add (maxpoint box) point))))
 145
 146 (defmethod scale ((box box) (scaler number))
 147   (point-box (scale (minpoint box) scaler)
 148              (scale (maxpoint box) scaler)))
 149
 150 (defgeneric bounding-box-delegate (object)
 151   (:documentation
 152    "An object that provides the bounding box for some other object."))
 153
 154 (defgeneric bounding-box (object)
 155   (:method (object)
 156     (bounding-box (bounding-box-delegate object)))
 157   (:method ((box box))
 158     box)
 159   (:method ((point point))
 160     (point-box point point))
 161   (:method ((objects sequence))
 162     (reduce #'combine (map 'vector #'bounding-box objects))))
 163
 164 (defun transpose (box)
 165   (point-box (minpoint box)
 166              (point (ymax box) (xmax box))))
 167
 168 (defun containsp (box point)
 169   (and (<= (xmin box) (x point) (xmax box))
 170        (<= (ymin box) (y point) (ymax box))))
 171
 172 ;;; TODO:
 173 ;;;
 174 ;;;  overlapsp box box
 175 ;;;  containsp box point
 176 ;;;