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 85% rename from src/network.lisp rename to src/network/gridded.lisp index 47f835e..be27ead 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) @@ -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))) diff --git a/src/network/quadtree.lisp b/src/network/quadtree.lisp new file mode 100644 index 0000000..708403a --- /dev/null +++ b/src/network/quadtree.lisp @@ -0,0 +1,174 @@ +;;;; 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) + +(defstruct (rectangle) + "Tracks the domain of a quadtree subrouter." + (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) + "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. + +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)) + ;; 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) + ((= 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)))))) + + ;; 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) + ;; 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)))))) + +(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) 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/ 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)))))