Paul Sexton avatar Paul Sexton committed c17bb73

First commit.

Comments (0)

Files changed (2)

+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; coding: utf-8-unix -*- ;;;;;;;;80
+
+(asdf:defsystem bsp-2d
+    :name "bsp-2d"
+    :version "1.0.0"
+    :author "Paul Sexton"
+    :description "Binary space partitioning for 2-dimensional cartesian spaces."
+    :serial t
+    :components ((:file "bsp"))
+    :depends-on ("iterate"
+                 "alexandria"
+                 "closer-mop"
+                 "defstar"
+                 "cartesian"))
+
+
+;;;; bsp-2d.asd ends here ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; -*- Mode: Lisp; coding: utf-8-unix -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(cl:defpackage :bsp-2d
+  (:nicknames :bsp2d :bsp)
+  (:use :cl :cartesian :alexandria :iterate :defstar)
+  (:export #:split
+           #:split-recursive
+           #:split-random))
+
+(in-package :bsp)
+
+
+;;;; Utilities ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(defun* greatest ((fn function) (seq sequence))
+  "FN is a function that accepts a single argument and returns a numerical
+value. Return the element in SEQ for which (FN element) returns the highest
+number."
+  (let ((results (iterate (for item in-sequence seq)
+                   (collect (funcall fn item)))))
+    (cond
+      (results
+       (elt seq (position (apply #'max results) results)))
+      (t nil))))
+
+
+(defun* least ((fn function) (seq sequence))
+  "FN is a function that accepts a single argument and returns a numerical
+value. Return the element in SEQ for which (FN element) returns the lowest
+number."
+  (let ((results (iterate (for item in-sequence seq)
+                   (collect (funcall fn item)))))
+    (cond
+      (results
+       (elt seq (position (apply #'min results) results)))
+      (t nil))))
+
+
+
+;;;; Types ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(deftype =axis= () `(member :x :y))
+
+
+;;;; 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)
+   (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-min-coord ((box box) axis)
+  (case axis
+    (:x (box-minx box))
+    (:y (box-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))
+    (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))))
+
+
+(defun boxes-at (boxes x y)
+  (remove-if-not (lambda (box) (in-box? box x y))
+                 boxes))
+
+
+(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))
+
+
+(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 (box)
+  (cons box
+        (cond
+          ((box-children box)
+           (flatten (mapcar #'all-box-children (box-children box))))
+          (t
+           nil))))
+
+
+;;;; 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)
+   (portal-boxa :initform nil :initarg :boxa :accessor portal-boxa)
+   (portal-boxb :initform nil :initarg :boxb :accessor portal-boxb)))
+
+
+(defmethod initialize-instance :after ((portal portal) &key)
+  (push portal *portals*))
+
+
+(defmethod print-object ((portal portal) strm)
+  (print-unreadable-object (portal strm :type t)
+    (with-slots (portal-minx portal-miny portal-maxx portal-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
+              portal-boxa
+              (case portal-axis
+                (:x "<->")
+                (:y "||")
+                (otherwise (error "Axis must be one of :X or :Y")))
+              portal-boxb))))
+
+
+(defmethod portal-at? ((p portal) x y)
+  (and (<= (portal-minx p) x (portal-maxx p))
+       (<= (portal-miny p) y (portal-maxy p))))
+
+
+(defun all-portals (boxes)
+  (remove-duplicates (apply #'append (mapcar #'box-portals boxes))))
+
+
+(defmethod box-portals ((box box))
+  (remove-if-not (lambda (p) (or (eql (portal-boxa p) box)
+                            (eql (portal-boxb p) box)))
+                 *portals*))
+
+
+(defun* split ((box box) (axis =axis=) (coord fixnum)
+               &key (portals? nil) (gap? nil))
+  "Returns: a list of the newly created child boxes."
+  (let ((boxa nil) (boxb nil))
+    (case axis
+      (:x
+       ;; 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)))
+       ;; 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 (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)))
+       (setf (box-children box) (list boxa boxb))))
+    ;; Deal with portals
+    (when (and portals? gap?)
+      ;; Make a new portal connecting boxa to boxb. The portal spans the entire
+      ;; "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))
+        (:y
+         (make-instance 'portal :miny coord
+                                :maxy coord
+                                :minx (box-minx box)
+                                :maxx (box-maxx box)
+                                :axis axis :boxa boxa
+                                :boxb boxb))))))
+
+
+(defun split-random (box axis &key gap? (min-dim 0) (portals? nil))
+  (let* ((minc (box-min-coord box axis))
+         (maxc (box-max-coord box axis))
+         (coord 0)
+         (allowed-coord-min (max (1- min-dim) (1+ minc)))
+         (allowed-coord-max (min (if gap? (1- maxc) maxc)
+                                 (- maxc min-dim (if gap? 1 0)))))
+    (cond
+      ((>= allowed-coord-max allowed-coord-min)
+       (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?))
+      (t
+       box))))
+
+
+(defun split-recursive-aux (box &key (min-area 0) (min-dim 3) (gap? nil)
+                                     (portals? nil))
+  (cond
+    ((<= (box-area box) (* 2 min-area))
+     box)
+    ((<= (min (box-xdim box) (box-ydim 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?)
+     (iterate
+       (for child in (box-children box))
+       (split-recursive-aux child :min-area min-area :min-dim min-dim
+                                  :gap? gap? :portals? portals?))
+     box)))
+
+
+(defun split-recursive (box &key (min-area 0) (min-dim 3) (gap? nil)
+                                 (portals? nil))
+  (setf *portals* nil)
+  (split-recursive-aux box :min-area min-area :min-dim min-dim
+                       :gap? gap? :portals? portals?)
+  (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
+      (setf finished? t)
+      (iterate
+        (for portal in *portals*)
+        (with-slots (portal-boxa portal-boxb) portal
+          (when (box-children portal-boxa)
+            (if (finalise-portal-for-box portal portal-boxa)
+                (setf finished? nil)))
+          (when (box-children portal-boxb)
+            (if (finalise-portal-for-box portal portal-boxb)
+                (setf finished? nil)))))
+      (until finished?))
+    (iterate
+      (for portal in *portals*)
+      (let ((boxa (portal-boxa portal))
+            (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))))
+          (: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))))))
+    (iterate
+      (for portal in *portals*)
+      (pushnew (portal-boxa portal) (box-neighbours (portal-boxb portal)))
+      (pushnew (portal-boxb portal) (box-neighbours (portal-boxa portal))))))
+
+
+(defun finalise-portal-for-box (portal box)
+  (when (box-children box)
+    (iterate
+      (for child in (box-children box))
+      (when (box-touches-area? child
+                               (portal-minx portal) (portal-miny portal)
+                               (portal-maxx portal) (portal-maxy portal))
+        (case (portal-axis portal)
+          (:x
+           (setf (portal-miny portal) (box-miny child)
+                 (portal-maxy portal) (box-maxy child)))
+          (:y
+           (setf (portal-minx portal) (box-minx child)
+                 (portal-maxx portal) (box-maxx child))))
+        (replace-box-in-portal portal box child)
+        (return t))
+      (finally (return nil)))))
+
+
+
+(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)))
+        (portals *portals*))
+    (flet ((default-coord-printer (x y)
+             (declare (ignorable x y))
+             " "))
+      (iterate
+        (for y from miny to maxy)
+        (iterate
+          (with match = nil)
+          (for x from minx to maxx)
+          (cond
+            ((and coord-test
+                  (funcall coord-test x y))
+             (format t "~A" (funcall (or coord-printer #'default-coord-printer)
+                                     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))))))
+          (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))
+                                    32 126))
+                  box))))
+    boxes))
+
+
+(defun test (x y)
+  (setf *portals* nil)
+  (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)))))
+
+
+
+;;;; bsp.lisp ends here ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.