From 8fea03e10541bd971c95586162bb727efc8a0d65 Mon Sep 17 00:00:00 2001 From: Eric Peterson Date: Sun, 21 Dec 2025 10:54:49 -0800 Subject: [PATCH 1/2] add 8-way routing --- aether.asd | 3 +- src/network/ordinal.lisp | 77 ++++++++++++++++++++++++++++++++++++++++ src/package.lisp | 1 + tests/network.lisp | 17 +++++++++ 4 files changed, 97 insertions(+), 1 deletion(-) create mode 100644 src/network/ordinal.lisp diff --git a/aether.asd b/aether.asd index b952691..7ff693b 100644 --- a/aether.asd +++ b/aether.asd @@ -32,7 +32,8 @@ (:module "network" :serial t :components ((:file "gridded") - (:file "quadtree"))) + (:file "quadtree") + (:file "ordinal"))) (:module "process" :serial t :components ((:file "process") diff --git a/src/network/ordinal.lisp b/src/network/ordinal.lisp new file mode 100644 index 0000000..15f53bd --- /dev/null +++ b/src/network/ordinal.lisp @@ -0,0 +1,77 @@ +;;;; network/ordinary.lisp +;;;; +;;;; A stock example for a diagonal-nearest-neighbor networked family of couriers in a square grid. +;;;; +;;;; Compared to courier-gridded, this raises the vertex degree of a courier from 4 to 8, but for +;;;; two nodes (x0, y0) and (x1, y1), it reduces the hop distance from |x0 - x1| + |y0 - y1| to +;;;; max(|x0 - x1|, |y0 - y1|). + +(in-package #:aether) + +(defstruct ordinal-neighbors + "A structure for storing the neighbors of a courier participating in a grid." + left + right + up + down + left-up + left-down + right-up + right-down) + +(defstruct (courier-ordinal (:include courier) (:constructor %make-courier-ordinal)) + "A `COURIER' instance networked to other couriers in a grid. + +NOTE: Expects `ID' to be a list and `NEIGHBORS' to be a `ORDINAL-NEIGHBORS'.") + +(defun make-courier-ordinal (&rest initargs) + (initialize-and-return ((courier (apply #'%make-courier-ordinal initargs))) + (unless (getf initargs ':neighbors) + (setf (courier-neighbors courier) (make-ordinal-neighbors))))) + +(defmethod courier-courier->route ((processing-courier courier-ordinal) destination-courier-id) + (with-slots (left right up down left-down right-down left-up right-up) + (courier-neighbors processing-courier) + (destructuring-bind (dx dy) destination-courier-id + (destructuring-bind (px py) (courier-id processing-courier) + (cond + ((and (< dx px) (< dy py)) left-down) + ((and (> dx px) (< dy py)) right-down) + ((and (< dx px) (> dy py)) left-up) + ((and (> dx px) (> dy py)) right-up) + ((and (< dx px) (= dy py)) left) + ((and (> dx px) (= dy py)) right) + ((and (= dx px) (< dy py)) down) + ((and (= dx px) (> dy py)) up) + (t + (warn "Requested to route a message that's already at its destination.") + processing-courier)))))) + +(defun make-courier-ordinal-grid (size-i size-j) + "Constructs a (size-i x size-j) grid of COURIER-GRIDDED instances." + (initialize-and-return ((courier-list) + (grid (make-array (list size-i size-j)))) + (dotimes (i size-i) + (dotimes (j size-j) + (let ((courier (make-courier-ordinal :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))) + (right (and (< (1+ i) size-i) (aref grid (1+ i) j))) + (down (and (<= 0 (1- j)) (aref grid i (1- j)))) + (up (and (< (1+ j) size-j) (aref grid i (1+ j)))) + (left-down (and (<= 0 (1- i)) (<= 0 (1- j)) (aref grid (1- i) (1- j)))) + (left-up (and (<= 0 (1- i)) (< (1+ j) size-j) (aref grid (1- i) (1+ j)))) + (right-down (and (< (1+ i) size-i) (<= 0 (1- j)) (aref grid (1+ i) (1- j)))) + (right-up (and (< (1+ i) size-i) (< (1+ j) size-j) (aref grid (1+ i) (1+ j))))) + (let ((neighbors (courier-neighbors (aref grid i j)))) + (setf (ordinal-neighbors-left neighbors) left + (ordinal-neighbors-right neighbors) right + (ordinal-neighbors-up neighbors) up + (ordinal-neighbors-down neighbors) down + (ordinal-neighbors-left-up neighbors) left-up + (ordinal-neighbors-left-down neighbors) left-down + (ordinal-neighbors-right-up neighbors) right-up + (ordinal-neighbors-right-down neighbors) right-down))))))) diff --git a/src/package.lisp b/src/package.lisp index 37e5d81..d7fe786 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -122,6 +122,7 @@ (:export #:make-courier-grid ; FUNCTION #:make-courier-quadtree ; FUNCTION + #:make-courier-ordinal-grid ; FUNCTION ) ;; process/ diff --git a/tests/network.lisp b/tests/network.lisp index e1b1e14..519b9e8 100644 --- a/tests/network.lisp +++ b/tests/network.lisp @@ -88,3 +88,20 @@ (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))))) + +(deftest test-courier-ordinal () + "Check in an example that COURIER-GRID routing takes |x0 - x1| + |y0 - y1| hops, while COURIER-ORDINAL routing takes max(|x0 - x1|, |y0 - y1|) hops." + (let ((width 3) + (x0 0) + (y0 2) + (x1 2) + (y1 1) + (aether::*courier-processing-clock-rate* 1)) + (is (= (+ (abs (- x0 x1)) (abs (- y0 y1))) + (compute-routing-time width width + :sender-x x0 :sender-y y0 :receiver-x x1 :receiver-y y1 + :courier-constructor #'make-courier-grid))) + (is (= (max (abs (- x0 x1)) (abs (- y0 y1))) + (compute-routing-time width width + :sender-x x0 :sender-y y0 :receiver-x x1 :receiver-y y1 + :courier-constructor #'make-courier-ordinal-grid))))) From 890ea1e5f0e8b023b8e1d2dda6270624c24cf253 Mon Sep 17 00:00:00 2001 From: Eric Peterson Date: Sun, 28 Dec 2025 22:26:20 -0800 Subject: [PATCH 2/2] typo --- src/network/ordinal.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/network/ordinal.lisp b/src/network/ordinal.lisp index 15f53bd..84a050c 100644 --- a/src/network/ordinal.lisp +++ b/src/network/ordinal.lisp @@ -1,4 +1,4 @@ -;;;; network/ordinary.lisp +;;;; network/ordinal.lisp ;;;; ;;;; A stock example for a diagonal-nearest-neighbor networked family of couriers in a square grid. ;;;;