From 99bcea7e292845d57af42fe64fa1b591b5a6d3d3 Mon Sep 17 00:00:00 2001 From: Eric Peterson Date: Sun, 2 Nov 2025 20:19:39 -0800 Subject: [PATCH 1/7] introduce quadtree network --- aether.asd | 5 +- src/{network.lisp => network/gridded.lisp} | 4 +- src/network/quadtree.lisp | 103 +++++++++++++++++++++ 3 files changed, 109 insertions(+), 3 deletions(-) rename src/{network.lisp => network/gridded.lisp} (95%) create mode 100644 src/network/quadtree.lisp diff --git a/aether.asd b/aether.asd index 20c5cf0..b952691 100644 --- a/aether.asd +++ b/aether.asd @@ -29,7 +29,10 @@ (:file "event") (:file "message") (:file "courier") - (:file "network") + (:module "network" + :serial t + :components ((:file "gridded") + (:file "quadtree"))) (:module "process" :serial t :components ((:file "process") diff --git a/src/network.lisp b/src/network/gridded.lisp similarity index 95% rename from src/network.lisp rename to src/network/gridded.lisp index 47f835e..a3ae6a9 100644 --- a/src/network.lisp +++ b/src/network/gridded.lisp @@ -1,6 +1,6 @@ -;;;; network.lisp +;;;; network/gridded.lisp ;;;; -;;;; A stock example for a networked family of couriers in a square grid. +;;;; A stock example for a nearest-neighbor networked family of couriers in a square grid. (in-package #:aether) diff --git a/src/network/quadtree.lisp b/src/network/quadtree.lisp new file mode 100644 index 0000000..d6de2fb --- /dev/null +++ b/src/network/quadtree.lisp @@ -0,0 +1,103 @@ +;;;; network/quadtree.lisp +;;;; +;;;; A stock example for a quadtree networked family of couriers in a square grid. + +(in-package #:aether) + +(defstruct (rectangle) + "" + (left 0 :type integer) + (right 0 :type integer) + (top 0 :type integer) + (bottom 0 :type integer)) + +(defun rectangles-meet? (rect1 rect2) + "Tests whether `RECT1' and `RECT2' intersect." + (when (or (eq ':otherwise rect1) (eq ':otherwise rect2)) + (return-from rectangles-meet? t)) + (not (or (< (rectangle-right rect2) (rectangle-left rect1)) + (< (rectangle-right rect1) (rectangle-left rect2)) + (< (rectangle-top rect2) (rectangle-bottom rect1)) + (< (rectangle-top rect1) (rectangle-bottom rect2))))) + +(defun rectangle-member? (rect point) + "Tests `POINT''s membership in `RECT'." + (when (eq ':otherwise rect) + (return-from rectangle-member? t)) + (destructuring-bind (x y) point + (and (<= (rectangle-left rect) x (rectangle-right rect)) + (<= (rectangle-bottom rect) y (rectangle-top rect))))) + +(defstruct (courier-quadtree (:include courier) (:constructor %make-courier-quadtree)) + "A `COURIER' instance networked to others along a quadtree." + (links nil :type list)) + +(defun make-courier-quadtree (size-x size-y) + (let ((rectangle (make-rectangle :left 0 :bottom 0 + :right (1- size-x) :top (1- size-y)))) + (make-courier-quadtree-rectangle rectangle nil))) + +(defun make-courier-quadtree-rectangle (rectangle parent) + "" + (with-slots ((max-x right) (max-y top) (min-x left) (min-y bottom)) rectangle + (assert (<= min-x max-x)) + (assert (<= min-y max-y)) + (let ((courier (%make-courier-quadtree :links `((:otherwise ,parent)))) + (half-width (floor (/ (- max-x min-x) 2))) + (half-height (floor (/ (- max-y min-y) 2))) + subrectangles + ;; NOTE: this is so that :otherwise has lowest precedence order. + ;; could also handle this as a slot on courier-quadtree, which might be nicer. + (leaf-courier-array (make-array `(,(1+ (- max-x min-x)) ,(1+ (- max-y min-y))))) + (flat-courier-list '())) + (unless (and (= max-x min-x) (= max-y min-y)) + (setf subrectangles + (list (make-rectangle :right (+ min-x half-width) + :top (+ min-y half-height) + :left min-x + :bottom min-y) + (make-rectangle :right + (+ min-x half-width) + :top max-y + :left min-x + :bottom (+ 1 min-y half-height)) + (make-rectangle :right max-x + :top (+ min-y half-height) + :left (+ 1 min-x half-width) + :bottom min-y) + (make-rectangle :right max-x + :top max-y + :left (+ 1 min-x half-width) + :bottom (+ 1 min-y half-height)))) + (setf subrectangles (remove-duplicates subrectangles :test #'equalp))) + + (dolist (sr subrectangles) + (with-slots ((submax-x right) (submax-y top) (submin-x left) (submin-y bottom)) sr + (multiple-value-bind (subcourier-array subcourier-list) + (make-courier-quadtree-rectangle + (make-rectangle :left submin-x :right submax-x + :bottom submin-y :top submax-y) + courier) + (push `(,sr ,(first subcourier-list)) (courier-quadtree-links courier)) + (setf flat-courier-list (nconc subcourier-list flat-courier-list)) + (dotimes (i (1+ (- submax-x submin-x))) + (dotimes (j (1+ (- submax-y submin-y))) + (setf (aref leaf-courier-array (+ submin-x i (- min-x)) (+ submin-y j (- min-y))) + (aref subcourier-array i j))))))) + + (push courier flat-courier-list) + ;; base case: poke ourselves into the array as a leaf + (unless subrectangles + (setf (aref leaf-courier-array 0 0) courier + (courier-id courier) `(,min-x ,min-y))) + (values leaf-courier-array flat-courier-list)))) + +(defmethod courier-courier->route ((processing-courier courier-quadtree) destination-courier-id) + "Routes according to a rectangle-membership-based routing table." + (loop :for (rect link) :in (courier-quadtree-links processing-courier) + :when (rectangle-member? rect destination-courier-id) + :do (return-from courier-courier->route link)) + (break) + (warn "Requested to route a message that's already at its destination: ~a vs ~a." + destination-courier-id (courier-quadtree-links processing-courier)) + processing-courier) From 03a933df6b7acf9688924f2e323d7dc47fde945f Mon Sep 17 00:00:00 2001 From: Eric Peterson Date: Mon, 3 Nov 2025 06:47:16 -0800 Subject: [PATCH 2/7] make-courier-grid matches new interface --- src/network/gridded.lisp | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/network/gridded.lisp b/src/network/gridded.lisp index a3ae6a9..be27ead 100644 --- a/src/network/gridded.lisp +++ b/src/network/gridded.lisp @@ -40,10 +40,13 @@ NOTE: Expects `ID' to be a list and `NEIGHBORS' to be a `GRID-NEIGHBORS'.") (defun make-courier-grid (size-i size-j) "Constructs a (size-i x size-j) grid of COURIER-GRIDDED instances." - (initialize-and-return ((grid (make-array (list size-i size-j)))) + (initialize-and-return ((courier-list) + (grid (make-array (list size-i size-j)))) (dotimes (i size-i) (dotimes (j size-j) - (setf (aref grid i j) (make-courier-gridded :id (list i j))))) + (let ((courier (make-courier-gridded :id (list i j)))) + (setf (aref grid i j) courier) + (push courier courier-list)))) (dotimes (i size-i) (dotimes (j size-j) (let ((left (and (<= 0 (1- i)) (aref grid (1- i) j))) From 45716bb30426637588aee6539ffb6ffeba2901a4 Mon Sep 17 00:00:00 2001 From: Eric Peterson Date: Mon, 3 Nov 2025 20:04:35 -0800 Subject: [PATCH 3/7] export quadtree constructor --- src/package.lisp | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/package.lisp b/src/package.lisp index a95fcc8..37e5d81 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -118,9 +118,10 @@ #:unregister ; FUNCTION ) - ;; network.lisp + ;; network/ (:export #:make-courier-grid ; FUNCTION + #:make-courier-quadtree ; FUNCTION ) ;; process/ From 54e317aacac7af4204eeb05581507a2f525aafbb Mon Sep 17 00:00:00 2001 From: Eric Peterson Date: Mon, 3 Nov 2025 20:04:50 -0800 Subject: [PATCH 4/7] fix subregion split logic --- src/network/quadtree.lisp | 61 ++++++++++++++++++++++++++------------- 1 file changed, 41 insertions(+), 20 deletions(-) diff --git a/src/network/quadtree.lisp b/src/network/quadtree.lisp index d6de2fb..d34016a 100644 --- a/src/network/quadtree.lisp +++ b/src/network/quadtree.lisp @@ -50,26 +50,47 @@ ;; could also handle this as a slot on courier-quadtree, which might be nicer. (leaf-courier-array (make-array `(,(1+ (- max-x min-x)) ,(1+ (- max-y min-y))))) (flat-courier-list '())) - (unless (and (= max-x min-x) (= max-y min-y)) - (setf subrectangles - (list (make-rectangle :right (+ min-x half-width) - :top (+ min-y half-height) - :left min-x - :bottom min-y) - (make-rectangle :right - (+ min-x half-width) - :top max-y - :left min-x - :bottom (+ 1 min-y half-height)) - (make-rectangle :right max-x - :top (+ min-y half-height) - :left (+ 1 min-x half-width) - :bottom min-y) - (make-rectangle :right max-x - :top max-y - :left (+ 1 min-x half-width) - :bottom (+ 1 min-y half-height)))) - (setf subrectangles (remove-duplicates subrectangles :test #'equalp))) + (cond + ((and (= max-x min-x) (= max-y min-y)) + nil) + ((= max-x min-x) + (setf subrectangles + (list (make-rectangle :right min-x + :top (+ min-y half-height) + :left min-x + :bottom min-y) + (make-rectangle :right min-x + :top max-y + :left min-x + :bottom (+ 1 min-y half-height))))) + ((= max-y min-y) + (setf subrectangles + (list (make-rectangle :right (+ min-x half-width) + :top min-y + :left min-x + :bottom min-y) + (make-rectangle :right max-x + :top min-y + :left (+ 1 min-x half-width) + :bottom min-y)))) + (t + (setf subrectangles + (list (make-rectangle :right (+ min-x half-width) + :top (+ min-y half-height) + :left min-x + :bottom min-y) + (make-rectangle :right (+ min-x half-width) + :top max-y + :left min-x + :bottom (+ 1 min-y half-height)) + (make-rectangle :right max-x + :top (+ min-y half-height) + :left (+ 1 min-x half-width) + :bottom min-y) + (make-rectangle :right max-x + :top max-y + :left (+ 1 min-x half-width) + :bottom (+ 1 min-y half-height)))))) (dolist (sr subrectangles) (with-slots ((submax-x right) (submax-y top) (submin-x left) (submin-y bottom)) sr From eaebbc635e8d80ab3f17d70f3d442c113071e937 Mon Sep 17 00:00:00 2001 From: Eric Peterson Date: Mon, 3 Nov 2025 20:18:34 -0800 Subject: [PATCH 5/7] docstrings --- src/network/quadtree.lisp | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/network/quadtree.lisp b/src/network/quadtree.lisp index d34016a..1807e33 100644 --- a/src/network/quadtree.lisp +++ b/src/network/quadtree.lisp @@ -5,7 +5,7 @@ (in-package #:aether) (defstruct (rectangle) - "" + "Tracks the domain of a quadtree subrouter." (left 0 :type integer) (right 0 :type integer) (top 0 :type integer) @@ -33,12 +33,15 @@ (links nil :type list)) (defun make-courier-quadtree (size-x size-y) + "Makes a whole quadtree apparatus stretching from (0, 0) to (size-x - 1, size-y - 1). + +Returns a VALUES pair: the 2d array of leaf routers (to use as the local courier for worker processes), then the list of *all* routers (to use to prime the simulator)." (let ((rectangle (make-rectangle :left 0 :bottom 0 :right (1- size-x) :top (1- size-y)))) (make-courier-quadtree-rectangle rectangle nil))) (defun make-courier-quadtree-rectangle (rectangle parent) - "" + "Makes one quadtree router and its children." (with-slots ((max-x right) (max-y top) (min-x left) (min-y bottom)) rectangle (assert (<= min-x max-x)) (assert (<= min-y max-y)) From 712847cd6108ea0a063dbf63866f087cebf51816 Mon Sep 17 00:00:00 2001 From: Peter Karalekas Date: Sun, 16 Nov 2025 00:13:47 -0800 Subject: [PATCH 6/7] Add a quadtree unit test based off ecp's snippet in the PR --- tests/network.lisp | 35 +++++++++++++++++++++++++++++++++++ 1 file changed, 35 insertions(+) diff --git a/tests/network.lisp b/tests/network.lisp index 4144aa9..e1b1e14 100644 --- a/tests/network.lisp +++ b/tests/network.lisp @@ -53,3 +53,38 @@ (try-til-exhausted (+ stopping-time time-step) (max pressure pressure-so-far))))))) (try-til-exhausted 0)))) + + +(defun compute-routing-time (size-x size-y + &key (courier-constructor #'make-courier-grid) + (receiver-x 0) + (receiver-y 0) + (sender-x nil sender-x-p) + (sender-y nil sender-y-p) + &aux (sender-x (if sender-x-p sender-x (1- size-x))) + (sender-y (if sender-y-p sender-y (1- size-y)))) + "For a leaf-courier grid of `SIZE-X' by `SIZE-Y' and network topology defined by `COURIER-CONSTRUCTOR', compute the amount of time required to send a message from an address bound to the courier at (`SENDER-X', `SENDER-Y') to an address bound to the courier at (`RECEIVER-X', `RECEIVER-Y')." + (multiple-value-bind (courier-grid courier-list) (funcall courier-constructor size-x size-y) + (with-simulation (simulation ()) + (dolist (courier courier-list) + (simulation-add-event simulation (make-event :callback courier))) + (let (receiver message) + (let ((*local-courier* (aref courier-grid receiver-x receiver-y))) + (setf receiver (register))) + (let ((*local-courier* (aref courier-grid sender-x sender-y))) + (setf message (make-message)) + (send-message receiver message)) + (let ((*local-courier* (aref courier-grid receiver-x receiver-y))) + (flet ((canary () + (receive-message (receiver msg :catch-rts? nil) + (message t)))) + (simulation-run simulation :canary #'canary) + (simulation-horizon simulation))))))) + +(deftest test-courier-quadtree () + "When communicating between the extreme bottom-left and top-right couriers, quadtree-based routing time is always less than or equal to grid-based routing time." + (dotimes (i 8) + (let* ((w (1+ i)) ; width/height are >= 1 + (t-grid (compute-routing-time w w :courier-constructor #'make-courier-grid)) + (t-quad (compute-routing-time w w :courier-constructor #'make-courier-quadtree))) + (is (<= t-quad t-grid))))) From 448d2e93d0be90559ba457ceb782091984e22deb Mon Sep 17 00:00:00 2001 From: Eric Peterson Date: Wed, 19 Nov 2025 20:32:57 -0800 Subject: [PATCH 7/7] docs --- src/network/quadtree.lisp | 71 ++++++++++++++++++++++++++++++++------- 1 file changed, 59 insertions(+), 12 deletions(-) diff --git a/src/network/quadtree.lisp b/src/network/quadtree.lisp index 1807e33..708403a 100644 --- a/src/network/quadtree.lisp +++ b/src/network/quadtree.lisp @@ -1,6 +1,35 @@ ;;;; network/quadtree.lisp ;;;; ;;;; A stock example for a quadtree networked family of couriers in a square grid. +;;;; +;;;; A typical family of quadtree routers looks like: +;;;; +;;;; +-+-+-+-+ +---+---+ +-------+ +;;;; /A/B/C/D/ / / / / / +;;;; +-+-+-+-+ / 1 / 2 / / / +;;;; /E/F/G/H/ / / / / / +;;;; +-+-+-+-+ +---+---+ / TOP / +;;;; /I/J/K/L/ / / / / / +;;;; +-+-+-+-+ / 3 / 4 / / / +;;;; /M/N/O/P/ / / / / / +;;;; +-+-+-+-+ +---+---+ +-------+ +;;;; +;;;; where each cell contains a router which is connected to the cell immediately above it in the +;;;; hierarchy (i.e., to the right) with which contains it and to all the cells immediately below it +;;;; in the hierarchy (i.e., to the left) which are contained by it. The finest-grained domains +;;;; (A, ..., P) with no downward links are referred to as 'leaves'. +;;;; +;;;; Message routing follows containments rather than spatial structure. For instance, a message +;;;; sent from A to P takes the following steps: +;;;; * Inspect A's routing table, which only has an upward connection. Follow it and deliver the +;;;; message to 1. +;;;; * Inspect 1's routing table, which has links to A, B, E, F, and upward. P is not contained in +;;;; any of the downward directions, so default to the upward direction. Follow it and deliver +;;;; the message to TOP. +;;;; * Inspect TOP's routing table, which has links to 1, 2, 3, and 4. P is contained in 4, so +;;;; deliver the message to 4. +;;;; * Inspect 4's routing table, which has has links to K, L, O, P, and an upward link back to TOP. +;;;; P is contained in P, so deliver the message to P. (in-package #:aether) @@ -41,18 +70,26 @@ Returns a VALUES pair: the 2d array of leaf routers (to use as the local courier (make-courier-quadtree-rectangle rectangle nil))) (defun make-courier-quadtree-rectangle (rectangle parent) - "Makes one quadtree router and its children." + "Makes one quadtree router and its children. + +Returns a VALUES pair: the 2d array of leaf routers (to use as the local courier for worker processes), then the list of *all* routers (to use to prime the simulator)." + ;; this actual routine is only responsible for generating the 'root' router. + ;; all the other routers in the tree are deferred to recursive calls. (with-slots ((max-x right) (max-y top) (min-x left) (min-y bottom)) rectangle (assert (<= min-x max-x)) (assert (<= min-y max-y)) - (let ((courier (%make-courier-quadtree :links `((:otherwise ,parent)))) - (half-width (floor (/ (- max-x min-x) 2))) - (half-height (floor (/ (- max-y min-y) 2))) - subrectangles - ;; NOTE: this is so that :otherwise has lowest precedence order. - ;; could also handle this as a slot on courier-quadtree, which might be nicer. - (leaf-courier-array (make-array `(,(1+ (- max-x min-x)) ,(1+ (- max-y min-y))))) - (flat-courier-list '())) + ;; the strategy is to divide RECTANGLE up into quarters, stored in SUBRECTANGLES. + ;; the relevant edge case is when RECTANGLE has width or height 1, in which case subdivision + ;; doesn't make sense. + (initialize-and-return + ((courier (%make-courier-quadtree :links `((:otherwise ,parent)))) + (half-width (floor (/ (- max-x min-x) 2))) + (half-height (floor (/ (- max-y min-y) 2))) + subrectangles + (flat-courier-list '()) + ;; NOTE: this is so that :otherwise has lowest precedence order. + ;; could also handle this as a slot on courier-quadtree, which might be nicer. + (leaf-courier-array (make-array `(,(1+ (- max-x min-x)) ,(1+ (- max-y min-y)))))) (cond ((and (= max-x min-x) (= max-y min-y)) nil) @@ -95,29 +132,39 @@ Returns a VALUES pair: the 2d array of leaf routers (to use as the local courier :left (+ 1 min-x half-width) :bottom (+ 1 min-y half-height)))))) + ;; having partitioned RECTANGLE into SUBRECTANGLES, we: + ;; * recursively build sub-quadtrees for each subrectangle. + ;; * stash the root of each sub-quadtree for the routing table at the router we're building. (dolist (sr subrectangles) (with-slots ((submax-x right) (submax-y top) (submin-x left) (submin-y bottom)) sr + ;; each of these calls generates the advertised VALUES pair: + ;; a 2D array of leaf routers and a flat list of all routers in the subtree. (multiple-value-bind (subcourier-array subcourier-list) (make-courier-quadtree-rectangle (make-rectangle :left submin-x :right submax-x :bottom submin-y :top submax-y) courier) + ;; stash the routing table entry (push `(,sr ,(first subcourier-list)) (courier-quadtree-links courier)) + ;; accrue onto the flat list of all routers (setf flat-courier-list (nconc subcourier-list flat-courier-list)) + ;; copy the 2D array of sub-leaf-routers into the relevant subarray of leaf routers (dotimes (i (1+ (- submax-x submin-x))) (dotimes (j (1+ (- submax-y submin-y))) (setf (aref leaf-courier-array (+ submin-x i (- min-x)) (+ submin-y j (- min-y))) (aref subcourier-array i j))))))) + ;; base case: we add the router we're constructing to the two data structures to return. + ;; we always belong in the flat list of all routers. (push courier flat-courier-list) - ;; base case: poke ourselves into the array as a leaf + ;; and, if we're a leaf (i.e., we have no subrectangles), we belong in the 2D array. (unless subrectangles (setf (aref leaf-courier-array 0 0) courier - (courier-id courier) `(,min-x ,min-y))) - (values leaf-courier-array flat-courier-list)))) + (courier-id courier) `(,min-x ,min-y)))))) (defmethod courier-courier->route ((processing-courier courier-quadtree) destination-courier-id) "Routes according to a rectangle-membership-based routing table." + (loop :for (rect link) :in (courier-quadtree-links processing-courier) :when (rectangle-member? rect destination-courier-id) :do (return-from courier-courier->route link))