1. Paul Sexton
  2. cl-bsp-2d

Commits

Paul Sexton  committed 94a834d

Box and portal classes now inherit from cartesian:rectangle.
If split is called on a user-created subclass of box, all created boxes will
be of that same subclass.
A user-created portal subclass can also be specified as a keyword argument.
Added dependency on cl-randomist library.

  • Participants
  • Parent commits c17bb73
  • Branches default

Comments (0)

Files changed (2)

File bsp-2d.asd

View file
  • Ignore whitespace
     :components ((:file "bsp"))
     :depends-on ("iterate"
                  "alexandria"
-                 "closer-mop"
                  "defstar"
+                 "randomist"
                  "cartesian"))
 
 

File bsp.lisp

View file
  • Ignore whitespace
 
 (cl:defpackage :bsp-2d
   (:nicknames :bsp2d :bsp)
-  (:use :cl :cartesian :alexandria :iterate :defstar)
-  (:export #:split
+  (:use :cl :cartesian :alexandria :iterate :defstar :randomist)
+  (:shadowing-import-from :randomist #:shuffle)
+  (:export #:box
+           #:box-parent
+           #:box-children
+           #:all-box-parents
+           #:all-box-children
+           #:box-and-children
+           #:box-area
+           #:box-xdim
+           #:box-ydim
+           #:box-neighbours
+           #:box-portals
+           #:box-min-coord
+           #:box-max-coord
+           #:print-boxes
+           #:portal
+           #:portal-axis
+           #:portal-boxa
+           #:portal-boxb
+           #:portal-other-box
+           #:all-portals
+           #:split
            #:split-recursive
            #:split-random))
 
 (in-package :bsp)
 
 
+;;;; Generic functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(defgeneric box-xdim (box))
+(defgeneric box-ydim (box))
+(defgeneric box-min-coord (box axis))
+(defgeneric box-max-coord (box axis))
+(defgeneric box-area (box))
+(defgeneric box-longest-axis (box &optional default-axis))
+(defgeneric in-box? (box x y))
+(defgeneric box-overlaps-area? (box minx miny maxx maxy))
+(defgeneric box-touches-area? (box minx miny maxx maxy))
+(defgeneric portal-at? (portal x y))
+(defgeneric box-portals (box))
+(defgeneric box-adjacent-to-portal? (box portal))
+
+
 ;;;; Utilities ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 
 ;;;; Box class ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 
-(defclass box ()
-  ((box-minx :initform 0 :type fixnum :initarg :minx :accessor box-minx)
-   (box-maxx :initform 0 :type fixnum :initarg :maxx :accessor box-maxx)
-   (box-miny :initform 0 :type fixnum :initarg :miny :accessor box-miny)
-   (box-maxy :initform 0 :type fixnum :initarg :maxy :accessor box-maxy)
-   (box-parent :initform nil :initarg :parent :accessor box-parent)
+(defclass box (rectangle)
+  ((box-parent :initform nil :initarg :parent :accessor box-parent)
    (box-children :initform nil :initarg :children :accessor box-children)
    (box-neighbours :initform nil :accessor box-neighbours)))
 
 
-(defmethod print-object ((box box) strm)
-  (print-unreadable-object (box strm :type t)
-    (with-slots (box-minx box-miny box-maxx box-maxy) box
-      (format strm "(~D,~D)-(~D,~D)" box-minx box-miny
-              box-maxx box-maxy))))
-
-
-(defmethod box-xdim ((box box))
-  (+ 1 (- (box-maxx box) (box-minx box))))
-
-
-(defmethod box-ydim ((box box))
-  (+ 1 (- (box-maxy box) (box-miny box))))
+(defmethod box-xdim ((box box)) (rect-xdim box))
+(defmethod box-ydim ((box box)) (rect-ydim box))
+(defmethod box-area ((box box)) (rect-area box))
+(defmethod in-box? ((box box) x y) (in-rectangle? box x y))
 
 
 (defmethod box-min-coord ((box box) axis)
   (case axis
-    (:x (box-minx box))
-    (:y (box-miny box))
+    (:x (rect-minx box))
+    (:y (rect-miny box))
     (otherwise (error "Argument `axis' must be :X or :Y"))))
 
 
 (defmethod box-max-coord ((box box) axis)
   (case axis
-    (:x (box-maxx box))
-    (:y (box-maxy box))
+    (:x (rect-maxx box))
+    (:y (rect-maxy box))
     (otherwise (error "Argument `axis' must be :X or :Y"))))
 
 
-(defmethod box-area ((box box))
-  (* (box-xdim box) (box-ydim box)))
-
-
-(defmethod box-longest-axis ((box box))
-  (if (> (box-xdim box) (box-ydim box))
-      :x :y))
-
-
-(defmethod in-box? ((box box) x y)
-  (and (<= (box-minx box) x (box-maxx box))
-       (<= (box-miny box) y (box-maxy box))))
+(defmethod box-longest-axis ((box box) &optional (default-axis nil))
+  (or (rect-longest-axis box)
+      default-axis))
 
 
 (defun boxes-at (boxes x y)
-  (remove-if-not (lambda (box) (in-box? box x y))
-                 boxes))
-
+  (rectangles-at boxes x y))
 
 (defmethod box-overlaps-area? ((box box) minx miny maxx maxy)
-  (areas-overlap? (box-minx box) (box-miny box) (box-maxx box) (box-maxy box)
-		  minx miny maxx maxy))
+  (rect-overlaps-area? box minx miny maxx maxy))
+(defmethod box-touches-area? ((box box) minx miny maxx maxy)
+  (rect-touches-area? box minx miny maxx maxy))
 
 
-(defmethod box-touches-area? ((box box) minx miny maxx maxy)
-  (and (areas-overlap? (box-minx box) (box-miny box)
-                       (box-maxx box) (box-maxy box)
-                       (1- minx) (1- miny) (1+ maxx) (1+ maxy))
-       (not (areas-overlap? (box-minx box) (box-miny box)
-                            (box-maxx box) (box-maxy box)
-                            minx miny maxx maxy))))
-
-
-(defmethod box-adjacent-to-portal? ((box box) (portal portal))
-  (box-touches-area? box (portal-minx portal) (portal-miny portal)
-                     (portal-maxx portal) (portal-maxy portal)))
+(defun all-box-children-aux (box)
+  (cond
+    ((null box)
+     nil)
+    ((null (box-children box))
+     (list box))
+    (t
+     (apply #'append (list box)
+            (mapcar #'all-box-children-aux (box-children box))))))
 
 
 (defun all-box-children (box)
-  (cons box
-        (cond
-          ((box-children box)
-           (flatten (mapcar #'all-box-children (box-children box))))
-          (t
-           nil))))
+  "Returns a list containing all the direct and indirect children of `box'."
+  (cdr (all-box-children-aux box)))
+
+
+(defun box-and-children (box)
+  "Returns a list containing BOX and all its direct and indirect children."
+  (cons box (all-box-children box)))
+
+
+(defun all-box-parents-aux (parent)
+  (cond
+    ((null parent)
+     nil)
+    (t
+     (cons parent (all-box-parents-aux (box-parent parent))))))
+
+
+(defun all-box-parents (box)
+  (all-box-parents-aux (box-parent box)))
 
 
 ;;;; Portal class ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defvar *portals* nil)
 
-(defclass portal ()
-  ((portal-minx :initform 0 :initarg :minx :type fixnum :accessor portal-minx)
-   (portal-maxx :initform 0 :initarg :maxx :type fixnum :accessor portal-maxx)
-   (portal-miny :initform 0 :initarg :miny :type fixnum :accessor portal-miny)
-   (portal-maxy :initform 0 :initarg :maxy :type fixnum :accessor portal-maxy)
-   (portal-axis :initform :x :type =axis= :initarg :axis :accessor portal-axis)
+(defclass portal (rectangle)
+  ((portal-axis :initform :x :type =axis= :initarg :axis :accessor portal-axis)
    (portal-boxa :initform nil :initarg :boxa :accessor portal-boxa)
    (portal-boxb :initform nil :initarg :boxb :accessor portal-boxb)))
 
 
 
 (defmethod print-object ((portal portal) strm)
-  (print-unreadable-object (portal strm :type t)
-    (with-slots (portal-minx portal-miny portal-maxx portal-maxy
+  (print-unreadable-object (portal strm :type t :identity t)
+    (with-slots (rect-minx rect-miny rect-maxx rect-maxy
                  portal-axis portal-boxa portal-boxb) portal
-      (format strm "(~D,~D)-(~D,~D) ~S ~A ~S" portal-minx portal-miny
-              portal-maxx portal-maxy
+      (format strm "(~D,~D)-(~D,~D) ~S ~A ~S" rect-minx rect-miny
+              rect-maxx rect-maxy
               portal-boxa
               (case portal-axis
                 (:x "<->")
 
 
 (defmethod portal-at? ((p portal) x y)
-  (and (<= (portal-minx p) x (portal-maxx p))
-       (<= (portal-miny p) y (portal-maxy p))))
+  (in-rectangle? p x y))
 
 
-(defun all-portals (boxes)
-  (remove-duplicates (apply #'append (mapcar #'box-portals boxes))))
+(defun all-portals (&optional boxes)
+  (cond
+    (boxes
+     (remove-duplicates (apply #'append (mapcar #'box-portals boxes))))
+    (t
+     *portals*)))
 
 
 (defmethod box-portals ((box box))
                  *portals*))
 
 
+(defun replace-box-in-portal (portal oldbox newbox)
+  (if (eql oldbox (portal-boxa portal))
+      (setf (portal-boxa portal) newbox))
+  (if (eql oldbox (portal-boxb portal))
+      (setf (portal-boxb portal) newbox)))
+
+
+
+(defmethod portal-other-box ((portal portal) (box box))
+  (cond
+    ((eql (portal-boxa portal) box)
+     (portal-boxb portal))
+    ((eql (portal-boxb portal) box)
+     (portal-boxa portal))
+    (t
+     (error "Portal ~A does not point to box ~A" portal box))))
+
+
+(defmethod (setf portal-other-box) (value (portal portal) (box box))
+  (cond
+    ((eql (portal-boxa portal) box)
+     (setf (portal-boxb portal) value))
+    ((eql (portal-boxb portal) box)
+     (setf (portal-boxa portal) value))
+    (t
+     (error "Portal ~A does not point to box ~A" portal box))))
+
+
+;;;; Binary space partitioning ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
 (defun* split ((box box) (axis =axis=) (coord fixnum)
-               &key (portals? nil) (gap? nil))
+               &key (portals? nil) (gap? nil) (portal-class 'portal))
   "Returns: a list of the newly created child boxes."
   (let ((boxa nil) (boxb nil))
     (case axis
        ;; Check that box is wide enough to be split, and that coord is within
        ;; the interval (minx, maxx)
        (assert (>= (box-xdim box) (+ 2 (if gap? 1 0))))
-       (assert (< (box-minx box) coord (box-maxx box)))
+       (assert (< (rect-minx box) coord (rect-maxx box)))
        ;; Make 2 child boxes. The left box will have x-coordinates
        ;; minx ... coord-1. The right box will have coordinates coord...maxx if
        ;; gap? is false, or coord+1...maxx if gap is true.
-       (setf boxa (make-instance 'box :parent box :miny (box-miny box)
-                                      :maxy (box-maxy box)
-                                      :minx (box-minx box)
-                                      :maxx (1- coord))
-             boxb (make-instance 'box :parent box :miny (box-miny box)
-                                      :maxy (box-maxy box)
-                                      :minx (if gap? (1+ coord) coord)
-                                      :maxx (box-maxx box)))
+       (setf boxa (make-instance (class-of box)
+                                 :parent box :miny (rect-miny box)
+                                 :maxy (rect-maxy box)
+                                 :minx (rect-minx box)
+                                 :maxx (1- coord))
+             boxb (make-instance (class-of box)
+                                 :parent box :miny (rect-miny box)
+                                 :maxy (rect-maxy box)
+                                 :minx (if gap? (1+ coord) coord)
+                                 :maxx (rect-maxx box)))
        (setf (box-children box) (list boxa boxb)))
       (:y
        (assert (>= (box-ydim box) (+ 2 (if gap? 1 0))))
-       (assert (< (box-miny box) coord (box-maxy box)))
-       (setf boxa (make-instance 'box :parent box :minx (box-minx box)
-                                      :maxx (box-maxx box)
-                                      :miny (box-miny box)
-                                      :maxy (1- coord))
-             boxb (make-instance 'box :parent box :minx (box-minx box)
-                                      :maxx (box-maxx box)
-                                      :miny (if gap? (1+ coord) coord)
-                                      :maxy (box-maxy box)))
+       (assert (< (rect-miny box) coord (rect-maxy box)))
+       (setf boxa (make-instance (class-of box)
+                                 :parent box :minx (rect-minx box)
+                                 :maxx (rect-maxx box)
+                                 :miny (rect-miny box)
+                                 :maxy (1- coord))
+             boxb (make-instance (class-of box)
+                                 :parent box :minx (rect-minx box)
+                                 :maxx (rect-maxx box)
+                                 :miny (if gap? (1+ coord) coord)
+                                 :maxy (rect-maxy box)))
        (setf (box-children box) (list boxa boxb))))
     ;; Deal with portals
     (when (and portals? gap?)
       ;; "gap".
       (case axis
         (:x
-         (make-instance 'portal :minx coord
-                                :maxx coord
-                                :miny (box-miny box)
-                                :maxy (box-maxy box)
-                                :axis axis :boxa boxa
-                                :boxb boxb))
+         (make-instance portal-class :minx coord
+                                     :maxx coord
+                                     :miny (rect-miny box)
+                                     :maxy (rect-maxy box)
+                                     :axis axis :boxa boxa
+                                     :boxb boxb))
         (:y
-         (make-instance 'portal :miny coord
-                                :maxy coord
-                                :minx (box-minx box)
-                                :maxx (box-maxx box)
-                                :axis axis :boxa boxa
-                                :boxb boxb))))))
+         (make-instance portal-class :miny coord
+                                     :maxy coord
+                                     :minx (rect-minx box)
+                                     :maxx (rect-maxx box)
+                                     :axis axis :boxa boxa
+                                     :boxb boxb))))))
 
 
-(defun split-random (box axis &key gap? (min-dim 0) (portals? nil))
+(defun split-random (box axis &key gap? (min-dim 0) (portals? nil)
+                                   (portal-class 'portal))
   (let* ((minc (box-min-coord box axis))
          (maxc (box-max-coord box axis))
          (coord 0)
        (setf coord (clamp (round (+ minc 1 (* 1/4 (- maxc minc))
                                     (random (round (* 1/2 (- maxc minc))))))
                           allowed-coord-min allowed-coord-max))
-       (split box axis coord :portals? portals? :gap? gap?))
+       (split box axis coord :portals? portals?
+                             :portal-class portal-class :gap? gap?))
       (t
        box))))
 
 
 (defun split-recursive-aux (box &key (min-area 0) (min-dim 3) (gap? nil)
-                                     (portals? nil))
+                                     (portals? nil) (portal-class 'portal))
   (cond
     ((<= (box-area box) (* 2 min-area))
      box)
          (+ (* 2 min-dim) (if gap? 1 0)))
      box)
     (t
-     (split-random box (box-longest-axis box) :gap? gap? :min-dim min-dim
-                                              :portals? portals?)
+     (split-random box (box-longest-axis box (random-argument :x :y))
+                   :gap? gap? :min-dim min-dim
+                   :portals? portals?
+                   :portal-class portal-class)
      (iterate
        (for child in (box-children box))
        (split-recursive-aux child :min-area min-area :min-dim min-dim
-                                  :gap? gap? :portals? portals?))
+                                  :gap? gap? :portals? portals?
+                                  :portal-class portal-class))
      box)))
 
 
 (defun split-recursive (box &key (min-area 0) (min-dim 3) (gap? nil)
-                                 (portals? nil))
+                                 (portals? nil) (portal-class 'portal))
   (setf *portals* nil)
   (split-recursive-aux box :min-area min-area :min-dim min-dim
-                       :gap? gap? :portals? portals?)
+                       :gap? gap? :portals? portals?
+                       :portal-class portal-class)
   (when portals?
     (finalise-portals))
   box)
 
 
-(defun replace-box-in-portal (portal oldbox newbox)
-  (if (eql oldbox (portal-boxa portal))
-      (setf (portal-boxa portal) newbox))
-  (if (eql oldbox (portal-boxb portal))
-      (setf (portal-boxb portal) newbox)))
-
-
 (defun finalise-portals ()
   (let ((finished? t))
     (iterate
             (boxb (portal-boxb portal)))
         (case (portal-axis portal)
           (:x
-           (setf (portal-miny portal) (max (box-miny boxa) (box-miny boxb))
-                 (portal-maxy portal) (min (box-maxy boxa) (box-maxy boxb))))
+           (setf (rect-miny portal) (max (rect-miny boxa) (rect-miny boxb))
+                 (rect-maxy portal) (min (rect-maxy boxa) (rect-maxy boxb))))
           (:y
-           (setf (portal-minx portal) (max (box-minx boxa) (box-minx boxb))
-                 (portal-maxx portal) (min (box-maxx boxa) (box-maxx boxb)))))
-        (assert (and (<= (portal-minx portal) (portal-maxx portal))
-                     (<= (portal-miny portal) (portal-maxy portal))))))
+           (setf (rect-minx portal) (max (rect-minx boxa) (rect-minx boxb))
+                 (rect-maxx portal) (min (rect-maxx boxa) (rect-maxx boxb)))))
+        (assert (and (<= (rect-minx portal) (rect-maxx portal))
+                     (<= (rect-miny portal) (rect-maxy portal))))))
     (iterate
       (for portal in *portals*)
       (pushnew (portal-boxa portal) (box-neighbours (portal-boxb portal)))
     (iterate
       (for child in (box-children box))
       (when (box-touches-area? child
-                               (portal-minx portal) (portal-miny portal)
-                               (portal-maxx portal) (portal-maxy portal))
+                               (rect-minx portal) (rect-miny portal)
+                               (rect-maxx portal) (rect-maxy portal))
         (case (portal-axis portal)
           (:x
-           (setf (portal-miny portal) (box-miny child)
-                 (portal-maxy portal) (box-maxy child)))
+           (setf (rect-miny portal) (rect-miny child)
+                 (rect-maxy portal) (rect-maxy child)))
           (:y
-           (setf (portal-minx portal) (box-minx child)
-                 (portal-maxx portal) (box-maxx child))))
+           (setf (rect-minx portal) (rect-minx child)
+                 (rect-maxx portal) (rect-maxx child))))
         (replace-box-in-portal portal box child)
         (return t))
       (finally (return nil)))))
 
 
+(defmethod box-adjacent-to-portal? ((box box) (portal portal))
+  (rectangles-touch? box portal))
+
+
 
 (defun print-boxes (boxes &key (coord-test nil) (coord-printer nil)
                                (list-boxes? nil))
   "COORD-TEST : if this is given, it must be a predicate that takes X and Y
 arguments. It should return true if the point X,Y should be printed by
 COORD-PRINTER rather than by PRINT-BOXES."
-  (let ((minx (box-minx (least #'box-minx boxes)))
-        (miny (box-miny (least #'box-miny boxes)))
-        (maxx (box-maxx (greatest #'box-maxx boxes)))
-        (maxy (box-maxy (greatest #'box-maxy boxes)))
+  (let ((minx (rect-minx (least #'rect-minx boxes)))
+        (miny (rect-miny (least #'rect-miny boxes)))
+        (maxx (rect-maxx (greatest #'rect-maxx boxes)))
+        (maxy (rect-maxy (greatest #'rect-maxy boxes)))
         (portals *portals*))
     (flet ((default-coord-printer (x y)
              (declare (ignorable x y))
             (t
              (setf match (least #'box-area (boxes-at boxes x y)))
              (if-let (portal (find-if (lambda (p) (portal-at? p x y)) portals))
-                (format t "~C" (case (portal-axis portal)
-                                 (:x #\-) (:y #\|)))
-                ;; else
-                (format t "~C"
-                        (code-char
-                         (clamp (+ 32 (if match (1+ (position match boxes)) 0))
-                                32 126))))))
+                     (format t "~C" (case (portal-axis portal)
+                                      (:x #\-) (:y #\|)))
+                     ;; else
+                     (format t "~C"
+                             (code-char
+                              (clamp (+ 32 (if match
+                                               (1+ (position match boxes))
+                                               0))
+                                     32 126))))))
           (finally (fresh-line))))
       (when list-boxes?
         (iterate
           (for box in boxes)
           (format t "\"~C\" = box: ~A~%"
-                  (code-char (clamp (+ 32 (if box (1+ (position box boxes)) 0))
+                  (code-char (clamp (+ 32 (if box
+                                              (1+ (position box boxes))
+                                              0))
                                     32 126))
                   box))))
     boxes))
   (let ((box (make-instance 'box :minx 0 :miny 0 :maxx x :maxy y)))
     (split-recursive box :min-area 10 :min-dim 4 :portals? t :gap? t)
     (finalise-portals)
-    (print-boxes (remove-if #'box-children (all-box-children box)))))
+    (print-boxes (remove-if #'box-children (box-and-children box)))
+    (box-and-children box)))