diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml new file mode 100644 index 0000000..dced535 --- /dev/null +++ b/.github/workflows/main.yml @@ -0,0 +1,35 @@ +name: main + +on: + push: + branches: [ master ] + pull_request: + branches: [ master ] + +jobs: + test: + runs-on: ubuntu-latest + steps: + - name: Check out anatevka + uses: actions/checkout@v2 + with: + path: anatevka + - name: Initialize Lisp + run: | + sudo apt install sbcl + curl -o /tmp/quicklisp.lisp "http://beta.quicklisp.org/quicklisp.lisp" + sbcl --noinform --non-interactive \ + --load /tmp/quicklisp.lisp \ + --eval '(quicklisp-quickstart:install)' + WD=$(pwd | xargs dirname) + echo >> ~/.sbclrc + echo '#-quicklisp(let ((i(merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname))))(when(probe-file i)(load i)))' >> ~/.sbclrc + echo "#+quicklisp(push \"${WD}/\" ql:*local-project-directories*)" >> ~/.sbclrc + rm -f /tmp/quicklisp.lisp + - name: Run the test suite + run: | + # run the tests via the Makefile + cd anatevka + sbcl --version + sbcl --noinform --non-interactive --eval '(ql:quickload "anatevka-tests")' + make test diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..07c6629 --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +*.fasl +.DS_Store +*~ diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 index 0000000..3702b62 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,7 @@ +Copyright © 2022 Eric Peterson, Peter Karalekas, and contributors + +Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the “Software”), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. \ No newline at end of file diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..e9ea880 --- /dev/null +++ b/Makefile @@ -0,0 +1,61 @@ +SBCL_BIN=sbcl +SBCL_WORKSPACE?=2048 +SBCL_OPTIONS=--noinform --no-userinit --no-sysinit --non-interactive +SBCL=$(SBCL_BIN) --dynamic-space-size $(SBCL_WORKSPACE) $(SBCL_OPTIONS) + +# tell me where Quicklisp is +ifeq ($(HOME), /github/home) + # when running on GitHub Actions, use Docker filesystem location + QUICKLISP_HOME=/root/quicklisp +else + QUICKLISP_HOME=$(HOME)/quicklisp +endif +QUICKLISP_SETUP=$(QUICKLISP_HOME)/setup.lisp + +# tell me where local projects are +ifeq ($(HOME), /github/home) + # when running on GitHub Actions, use Docker filesystem location + QUICKLISP_PROJECTS=/src +else + QUICKLISP_PROJECTS=../ +endif + +QUICKLISP=$(SBCL) --load $(QUICKLISP_SETUP) \ + --eval '(push (truename ".") asdf:*central-registry*)' \ + --eval "(push (truename \"$(QUICKLISP_PROJECTS)\") ql:*local-project-directories*)" + +.PHONY: test +test: + $(QUICKLISP) \ + --eval "(ql:quickload :anatevka-tests)" \ + --eval "(asdf:test-system :anatevka)" + +### +### clean targets, borrowed from QVM +### + +# Clean the executables +clean: + rm -f qvm qvm-ng build-output.log system-index.txt + +# Clean the Lisp cache, reindex local projects. +clean-cache: + @echo "Deleting $(LISP_CACHE)" + $(QUICKLISP) \ + --eval "(ql:register-local-projects)" + rm -rf "$(LISP_CACHE)" + +clean-qvm-cache: + @echo "Deleting $(QVM_LISP_CACHE)" + $(QUICKLISP) \ + --eval "(ql:register-local-projects)" + rm -rf $(QVM_LISP_CACHE) + +clean-quicklisp: + @echo "Cleaning up old projects in Quicklisp" + $(QUICKLISP) \ + --eval '(ql-dist:clean (ql-dist:dist "quicklisp"))' + +cleanall: clean clean-cache clean-quicklisp + @echo "All cleaned and reindexed." + diff --git a/README.md b/README.md new file mode 100644 index 0000000..db2c29e --- /dev/null +++ b/README.md @@ -0,0 +1,123 @@ +# `anatevka` + +`anatevka` is a Common Lisp package which houses [a distributed variant of Edmonds's blossom algorithm](https://arxiv.org/abs/2210.14277) for producing minimum-weight perfect matchings, written in [`aether`](https://github.com/dtqec/aether)'s application layer. + +## Overview + +`anatevka` contains an executable description of a distributed solver for minimum-weight perfect matchings on graphs. +The solver is written on top of [`aether`](https://github.com/dtqec/aether), so that one can simulate the algorithm running on large networks and infer the performance characteristics of such scenarios. +The package is also implemented _extensibly_, so as to allow application-specific behaviors to be written into packages derived from this one. + +The original motivation for the development of this package was [Fowler's program](https://arxiv.org/abs/1307.1740) for using a distributed solver for minimum-weight perfect matching to perform quantum error correction. +This package provides the first implementation of the core distributed solver, incompletely described by Fowler. + +## Installation + +`anatevka` is a Lisp package which relies on other Lisp packages. You'll need to: + +1. Install a Lisp environment. + [Some convenient instructions](https://github.com/quil-lang/qvm/blob/master/doc/lisp-setup.md) for this can be found as part of the QVM Lisp package. +2. This also depends on [`aether`](https://github.com/dtqec/aether), another Eigenware package. + Install this software somewhere locally, where ASDF can find it, perhaps using [QuickLisp](http://quicklisp.org/). + +## Example + +In this section we consider an example instantiation of the solver inside of an `aether` simulation. +To abbreviate the code examples, we assume we have imported the `anatevka` package. + +The behavior of the solver is guided by three classes: + +1. A `dryad` class which implements the interface in `dryad-api.lisp`. + The `dryad` is responsible for creating the worker nodes which embody graph vertices and managing edge discovery. + We provide an example implementation in `dryad.lisp` for a centralized `dryad` managing a fully-connected, weighted graph. +2. A `blossom-node` class which enacts the individual steps in the blossom algorithm. + We provide a stock implementation in `node.lisp`; users need only provide a subclass if they want to deviate from the standard behavior of the algorithm. +3. An `id` class which is used to uniquely tag the vertices in the graph and from which the edge weight between any two vertices can be computed via `anatevka::vertex-vertex-distance`. + The repository provides no such stock class; we will implement a version below with static edge weights. + +In our example, we will use the stock `dryad` and `blossom-node` implementations, which leaves only the `id` class to define. +The following definition provides eight valid `demo-id` instances and a function which computes the edge weights between them: + +```lisp +(defstruct demo-id + "A wrapper for a vertex ID used in the Mathematica blossom demo." + (value nil :type (integer 1 8))) + +(defmethod anatevka::vertex-vertex-distance ((id-v demo-id) (id-w demo-id)) + (let ((v (demo-id-value id-v)) + (w (demo-id-value id-w))) + ;; index into the following weighted adjacency matrix + (aref #2A(( 0 40 52 50 46 70 36 46) + (40 0 34 54 28 64 20 6) + (52 34 0 28 34 24 2 30) + (50 54 28 0 42 18 36 8) + (46 28 34 42 0 14 80 22) + (70 64 24 18 14 0 22 64) + (36 20 2 36 80 22 0 80) + (46 6 30 8 22 64 80 0)) + (1- v) (1- w)))) +``` + +**Note:** Given the example adjacency matrix provided, one possible minumum-weight perfect matching consists of the pairs (1, 2), (3, 7), (4, 8), and (5, 6), which altogether has weight 64. + +Having established the class which carries the graph definition, we wrap a solver in a simulation and invoke the simulation to extract a minimum-weight perfect matching: + +```lisp +(let* ((simulation (make-simulation)) + ;; aether requires us to bind `*local-courier*' before spawning processes. + (*local-courier* (make-courier :processing-clock-rate 300)) + ;; The edges discovered by the algorithm will be announced on this address. + (match-address (register)) + ;; This process manages graph discovery. + (dryad (spawn-process 'dryad + :process-clock-rate 20 + :debug? t + :match-address match-address))) + ;; Set up the core simulation components: the network host and the dryad. + (simulation-add-event simulation + (make-event :callback *local-courier* :time 0)) + (simulation-add-event simulation (make-event :callback dryad :time 0)) + ;; Prime the dryad with messages to spawn workers for the eight vertices. + (loop :for j :from 1 :to 8 + :for id := (make-demo-id :value j) + :do (send-message (process-public-address dryad) + (anatevka::make-message-sow :id id))) + ;; Run simulation until maximally matched (i.e., until the dryad terminates). + (simulation-run simulation :canary (canary-process dryad)) + ;; Read out the match edges from the `match-address' mailbox. + (labels ((drain-match-address (&optional acc) + (receive-message (match-address message) + (message-reap + (drain-match-address (list* (message-reap-ids message) acc))) + (otherwise + acc)))) + + ;; Calculate the weight of the matching. + (loop :for (left right) :in (drain-match-address) + :do (format t "~d --~02d-- ~d~%" + (demo-id-value left) + (vertex-vertex-distance left right) + (demo-id-value right)) + :sum (anatevka::vertex-vertex-distance left right)))) +``` + +which prints + +``` +8 -- 8-- 4 +7 -- 2-- 3 +6 --14-- 5 +2 --40-- 1 +``` + +and emits the return value `64`. + +## License + +`anatevka` is made available under the MIT license. +See `LICENSE.md` in the source tree for more information. + +## See also + ++ [ArXiv preprint](https://arxiv.org/abs/2210.14277) ++ [GitHub repository](https://github.com/dtqec/anatevka) diff --git a/VERSION.txt b/VERSION.txt new file mode 100644 index 0000000..ce9a6f1 --- /dev/null +++ b/VERSION.txt @@ -0,0 +1 @@ +"1.0.0" diff --git a/anatevka-tests.asd b/anatevka-tests.asd new file mode 100644 index 0000000..cb83517 --- /dev/null +++ b/anatevka-tests.asd @@ -0,0 +1,27 @@ +;;;; anatevka-tests.asd + +(asdf:defsystem #:anatevka-tests + :description "Regression tests for Anatevka." + :author "Eric Peterson , Peter Karalekas " + :depends-on (#:anatevka + #:fiasco + #:uiop + #:closer-mop + ) + :perform (asdf:test-op (o s) + (uiop:symbol-call ':anatevka-tests + '#:run-anatevka-tests)) + :pathname "tests/" + :serial t + :components ((:file "package") + (:file "suite") + (:file "node") + (:module "operations" + :serial t + :components ((:file "graft") + (:file "augment") + (:file "expand") + (:file "contract") + (:file "multireweight") + (:file "reweight"))) + (:file "blossom"))) diff --git a/anatevka.asd b/anatevka.asd new file mode 100644 index 0000000..531e2b6 --- /dev/null +++ b/anatevka.asd @@ -0,0 +1,34 @@ +;;;; anatevka.asd +;;;; +;;;; Author: Eric Peterson, Peter Karalekas + +(asdf:defsystem #:anatevka + :description "A distributed blossom algorithm for minimum-weight perfect matching." + :author "Eric Peterson , Peter Karalekas " + :version (:read-file-form "VERSION.txt") + :pathname "src/" + :depends-on (#:alexandria + (:version #:aether "1.1.0") + ) + :in-order-to ((asdf:test-op (asdf:test-op #:anatevka-tests))) + :around-compile (lambda (compile) + (let (#+sbcl(sb-ext:*derive-function-types* t)) + (funcall compile))) + :serial t + :components ((:file "package") + (:file "utilities") + (:file "logger") + (:file "dryad-api") + (:file "node") + (:file "supervisor") + (:file "lock") + (:module "operations" + :serial t + :components ((:file "scan") + (:file "graft") + (:file "augment") + (:file "expand") + (:file "contract") + (:file "multireweight") + (:file "reweight"))) + (:file "dryad"))) diff --git a/src/dryad-api.lisp b/src/dryad-api.lisp new file mode 100644 index 0000000..2f29635 --- /dev/null +++ b/src/dryad-api.lisp @@ -0,0 +1,43 @@ +;;;; dryad-api.lisp +;;;; +;;;; Specifies the message types used to communicate with the DRYAD. +;;;; See dryad.lisp and matchmaker.lisp for information on the participants. + +(in-package #:anatevka) + +;;; messages between the dryad and the external world + +(defstruct (message-sow (:include message)) + "Instructs a `DRYAD' to inject a new vertex with the indicated id." + (id nil :type t)) + +(defstruct (message-reap (:include message)) + "Reported by a `DRYAD' to its `MATCH-ADDRESS' with a pair of IDs that participate in the calculated matching." + (ids nil :type list)) + +;;; messages between the dryad and its managed blossoms + +(defstruct (message-discover (:include message)) + "Sent from a blossom process to a `DRYAD' to query for a list of other blossom processes to which it should send PINGs." + (address nil :type address) + (id nil :type t) + (internal-weight nil :type real) ; NOTE: a little surprised that this isn't (REAL 0) + (repeat? nil :type boolean)) + +(defstruct (message-discovery (:include message)) + "The response to a DISCOVER message. + +CHANNELS-TO-TRY: The addresses to send PINGs to." + (channels-to-try nil :type list)) + +(defstruct (message-wilt (:include message)) + "An instruction to a `BLOSSOM-NODE' to cease operation as a process.") + +(defstruct (message-sprout (:include message)) + "Whenever a vertex participates in an augmentation, we are guaranteed that it has been assigned a match (possibly after any parent blossom undergoes expansion). Upon augmentation, it sends this message to the DRYAD to indicate that it no longer need consider this vertex to be \"live\"." + (address nil :type address)) + +;; NOTE: This message is essentially unused in the reference implementation, but it can be useful when implementing an online solver. +(defstruct (message-wilting (:include message)) + "When a `BLOSSOM-NODE' wilts, it notifies its parent `DRYAD' to remove it from consideration." + (address nil :type address)) diff --git a/src/dryad.lisp b/src/dryad.lisp new file mode 100644 index 0000000..fc0e4d7 --- /dev/null +++ b/src/dryad.lisp @@ -0,0 +1,172 @@ +;;;; dryad.lisp +;;;; +;;;; These processes are responsible for farming the blossoms participating in +;;;; the matching computation. They perform three services: +;;;; +;;;; (1) They spawn a blossom process for each vertex in the problem graph. +;;;; (2) When a blossom vertex needs a list of vertices to PING, they provide a +;;;; list of relevant addresses. +;;;; (3) When a blossom vertex reaches a stable match, it plucks the blossoms +;;;; from the computation and records those edges. + +(in-package #:anatevka) + +;;; +;;; definition of the DRYAD data structure +;;; + +(defparameter *dryad-default-clock-rate* 10) + +(defclass dryad (process-lockable) + ((process-clock-rate + :initform *dryad-default-clock-rate*) + (match-address + :accessor dryad-match-address + :initarg :match-address + :type address + :documentation "The `ADDRESS' to which the `DRYAD' will send REAP messages.") + ;; local state + (ids + :accessor dryad-ids + :initform (make-hash-table :hash-function #'hash-address :test #'address=) + :type hash-table + :documentation "A map ADDRESS -> ID which records the id of a `BLOSSOM-NODE' instance.") + (sprouted? + :accessor dryad-sprouted? + :initform (make-hash-table :hash-function #'hash-address :test #'address=) + :type hash-table + :documentation "A map ADDRESS -> BOOLEAN which records whether a `BLOSSOM-NODE' has begun participating in matches.")) + (:documentation "PROCESS responsible for the injection and ejection of nodes from the blossom algorithm.")) + +;;; +;;; passive DRYAD message handlers +;;; + +(define-message-handler handler-message-sow + ((dryad dryad) (message message-sow) now) + "Adjoin a new node to the problem graph. + +NOTE: In the basic implementation, these messages must be waiting for the DRYAD on launch." + (let* ((node-id (message-sow-id message)) + (node-process (spawn-process 'blossom-node + :dryad (process-public-address dryad) + :id node-id)) + (node-address (process-public-address node-process))) + (schedule node-process now) + (setf (gethash node-address (dryad-ids dryad)) node-id + (gethash node-address (dryad-sprouted? dryad)) nil))) + +(define-message-handler handler-message-discover + ((dryad dryad) (message message-discover) now) + "Handles a DISCOVER message, sent by a BLOSSOM-NODE which expects a list of other BLOSSOM-NODE addresses to which it should send PINGs." + (let ((channels + (loop :for address :being :the :hash-keys :of (dryad-ids dryad) + :unless (address= address (message-discover-address message)) + :collect address))) + (send-message (message-reply-channel message) + (make-message-discovery :channels-to-try channels)))) + +(define-message-handler handler-message-sprout + ((dryad dryad) (message message-sprout) now) + "Handles a SPROUT message, indicating that a BLOSSOM-NODE has been matched (for the first time)." + (with-slots (address) message + (when (gethash address (dryad-ids dryad)) + (setf (gethash address (dryad-sprouted? dryad)) t)))) + +(define-rpc-handler handler-message-wilting + ((dryad dryad) (message message-wilting) now) + "Handles a wilting message, indicating that a BLOSSOM-NODE is dying." + (with-slots (address) message + (let ((id (gethash address (dryad-ids dryad)))) + (remhash address (dryad-ids dryad)) + (remhash address (dryad-sprouted? dryad)) + id))) + +;;; +;;; install the handlers into the dispatch table +;;; + +(define-message-dispatch dryad + (message-sow 'handler-message-sow) + (message-sprout 'handler-message-sprout) + (message-discover 'handler-message-discover) + (message-wilting 'handler-message-wilting)) + +;;; +;;; DRYAD command definitions +;;; + +(define-process-upkeep ((dryad dryad) now) (START) + "Start listening for ripe sprouted pairs." + (process-continuation dryad `(SPROUTS-LOOP))) + +(define-process-upkeep ((dryad dryad) now) (SPROUTS-LOOP) + "Loop over sprouted nodes, looking for ripe pairs." + ;; if not everyone is sprouted, hold off + (when (loop :for sprouted? :in (a:hash-table-values (dryad-sprouted? dryad)) + :always (not sprouted?)) + (process-continuation dryad `(SPROUTS-LOOP)) + (finish-with-scheduling)) + (let ((addresses (a:hash-table-keys (dryad-sprouted? dryad)))) + (flet ((payload-constructor () + (make-message-values :reply-channel (register) + :values '(match-edge)))) + (with-replies (replies) (send-message-batch #'payload-constructor addresses) + ;; make sure everyone has a match. any that doesn't is in a blossom + ;; which needs to be expanded. + (loop :for address :in addresses + :for reply :in replies + :when (null (first reply)) + :do (process-continuation dryad + `(SEND-EXPAND ,address) + `(SPROUTS-LOOP)) + (finish-with-scheduling)) + ;; all clear! + (let ((emitted-addresses nil) + (pairs nil)) + (dolist (reply replies) + (let* ((left-address (blossom-edge-source-vertex (first reply))) + (right-address (blossom-edge-target-vertex (first reply))) + (left-member (member left-address emitted-addresses :test #'address=)) + (right-member (member right-address emitted-addresses :test #'address=)) + (ids (list (gethash left-address (dryad-ids dryad)) + (gethash right-address (dryad-ids dryad))))) + (cond + ((and left-member right-member) + nil) + ((and (not left-member) (not right-member)) + (push left-address emitted-addresses) + (push right-address emitted-addresses) + (push ids pairs)) + (t + (error "Two distinct match edges laid claim to the same vertex."))))) + (assert (= (length pairs) (/ (length addresses) 2))) + (dolist (pair pairs) + (send-message (dryad-match-address dryad) + (make-message-reap :ids pair))) + (process-continuation dryad `(WIND-DOWN))))))) + +(define-process-upkeep ((dryad dryad) now) (SEND-EXPAND sprout) + "Directs SPROUT to perform blossom expansion." + (unless (process-lockable-aborting? dryad) + ;; if we directly send the sprout a blossom-expand message, it will + ;; automatically forward that up to its topmost blossom parent, which'll + ;; then pop. this isn't always desirable: we only want to expand those + ;; blossoms which aren't participating in a tree. so, instead, we + ;; calculate the topmost blossom separately, send it a VALUES query, + ;; and directly expand it if appropriate. + (sync-rpc (make-message-blossom-parent) + (topmost sprout) + (sync-rpc (make-message-values :values '(children parent)) + ((children parent) topmost) + (when (or children parent) + (log-entry :entry-type 'aborting-dryad-expansion + :reason 'tree-structure)) + (unless (or children parent) + (sync-rpc (make-message-expand) + (expand-reply topmost) + nil)))))) + +(define-process-upkeep ((dryad dryad) now) (WIND-DOWN &optional (counter 50)) + (unless (zerop counter) + (process-continuation dryad `(WIND-DOWN ,(1- counter))))) diff --git a/src/lock.lisp b/src/lock.lisp new file mode 100644 index 0000000..5cc4d36 --- /dev/null +++ b/src/lock.lisp @@ -0,0 +1,59 @@ +;;;; lock.lisp +;;;; +;;;; Specialized blossom behavior for locking. + +(in-package #:anatevka) + +;;; +;;; blossom-node command definitions +;;; + +(defmethod process-lockable-targets ((node blossom-node)) + (mapcar #'blossom-edge-target-node (union (blossom-node-petals node) + (blossom-node-children node)))) + +(define-process-upkeep ((node blossom-node) now) + (aether::%FINISH-UNLOCK) + (setf (blossom-node-pingable node) ':ALL) + (setf (blossom-node-held-by-roots node) nil) + (when (process-lockable-done-signal node) ; signal := destroy? && ! aborting? + (setf (blossom-node-parent node) nil + (blossom-node-children node) nil + (blossom-node-positive? node) t)) + (schedule* (call-next-method))) + +;;; +;;; blossom-node handlers +;;; + +(define-message-handler handle-message-lock + ((node blossom-node) (message message-lock) now) + "Prepares a BLOSSOM-NODE to be locked." + (when (blossom-node-wilting node) + (send-message (message-reply-channel message) + (make-message-rpc-done :result nil)) + (finish-with-scheduling)) + (unless (process-lockable-locked? node) + (setf (blossom-node-pingable node) ':NONE)) + (schedule* (call-next-method))) + +;;; +;;; supervisor command definitions +;;; + +(define-process-upkeep ((supervisor supervisor) now) + (BROADCAST-UNLOCK &key destroy? &allow-other-keys) + "Cleans up after BROADCAST-LOCK." + (with-slots (aborting? done-signal downward-rx-latches downward-tx-latches upward-tx-latch) supervisor + (setf done-signal (and destroy? (not aborting?))) + (send-message-batch (a:curry #'make-message-unlock :result done-signal) + downward-tx-latches + :replies? nil) + (with-replies (replies) downward-rx-latches + ;; NOTE: the setting of `aborting?' to NIL was removed because it clobbers + ;; the supervisor's notion of being aborted for other reasons, and + ;; confuses `HALT' + (setf downward-tx-latches nil + downward-rx-latches nil) + (when upward-tx-latch + (send-message upward-tx-latch (make-message-rpc-done :result t)))))) diff --git a/src/logger.lisp b/src/logger.lisp new file mode 100644 index 0000000..e7ca93f --- /dev/null +++ b/src/logger.lisp @@ -0,0 +1,105 @@ +;;;; logger.lisp +;;;; +;;;; Structured logging and log processing. + +(in-package #:anatevka) + +;;; +;;; pretty-printing mechanisms +;;; + +(defmethod print-log-entry (entry + (source-type (eql 'SUPERVISOR)) + (entry-type (eql 'GOT-RECOMMENDATION)) + &optional (stream *standard-output*)) + (format stream "~5f: SUPERVISOR ~a got recommendation ~a (~a; ~{~a~^ ~}) from root: ~a~%" + (getf entry ':time) + (getf entry ':source) + (getf entry ':recommendation) + (getf entry ':weight) + (getf entry ':edges) + (getf entry ':source-root))) + +(defmethod print-log-entry (entry + (source-type (eql 'SUPERVISOR)) + (entry-type (eql 'SUCCESS)) + &optional (stream *standard-output*)) + (format stream "~5f: SUPERVISOR ~a closing.~%" + (getf entry ':time) (getf entry ':source))) + +(defmethod print-log-entry (entry + (source-type (eql 'BLOSSOM-NODE)) + (entry-type (eql 'SET-UP-BLOSSOM)) + &optional (stream *standard-output*)) + "Log entry for when a blossom node finishes setting itself up." + (format stream "~5f: BLOSSOM ~a completed setting up (peduncle: ~a; match: ~a; children: ~{~a~^ ~}; parent: ~a; petals: ~{~a~^ ~}; pistil: ~a)~%" + (getf entry ':time) + (getf entry ':source) + (getf entry ':peduncle-edge) + (getf entry ':match-edge) + (getf entry ':children) + (getf entry ':parent) + (getf entry ':petals) + (getf entry ':pistil))) + +(defmethod print-log-entry (entry + (source-type (eql 'DRYAD)) + (entry-type (eql 'HANDLING-SOW)) + &optional (stream *standard-output*)) + (format stream "~5f: Spawning blossom ~a at ~a.~%" + (getf entry ':time) + (getf entry ':address) + (getf entry ':id))) + +;;; +;;; filtering routines +;;; + +(defun successful-supervisors (entries) + "Collects addresses of supervisors which either complete successfully or fail to complete at all." + (loop :for entry :in entries + :when (and (eql 'SUPERVISOR (getf entry ':source-type)) + (eql 'SUCCESS (getf entry ':entry-type)) + (eql T (getf entry ':success))) + :collect (getf entry ':source) :into positive-addresses + :when (and (eql 'SUPERVISOR (getf entry ':source-type)) + (eql 'GOT-RECOMMENDATION (getf entry ':entry-type)) + (eql ':HOLD (getf entry ':recommendation)) + (address= + (blossom-edge-source-node (first (getf entry ':edges))) + (blossom-edge-target-node (first (getf entry ':edges))))) + :collect (getf entry ':source) :into self-held-addresses + :when (and (eql 'SUPERVISOR (getf entry ':source-type)) + (eql 'COMMAND (getf entry ':entry-type)) + (eql ':START (getf entry ':command))) + :collect (getf entry ':source) :into start-addresses + :when (and (eql 'SUPERVISOR (getf entry ':source-type)) + (eql 'SUCCESS (getf entry ':entry-type))) + :collect (getf entry ':source) :into done-addresses + :finally (return (union (set-difference positive-addresses + self-held-addresses + :test #'address=) + (set-difference start-addresses + done-addresses + :test #'address=))))) + +(defun reduce-log (log) + "Trims log messages to only ones of primary interest." + (let (entries + (successful-addresses (successful-supervisors (logger-entries log)))) + (dolist (entry (reverse (logger-entries log)) (reverse entries)) + (cond + ((and (eql 'SUPERVISOR (getf entry ':source-type)) + (eql 'GOT-RECOMMENDATION (getf entry ':entry-type)) + (member (getf entry ':source) successful-addresses :test #'address=)) + (push entry entries)) + ((or (and (eql 'SUPERVISOR (getf entry ':source-type)) + (eql 'SUCCESS (getf entry ':entry-type)) + (member (getf entry ':source) successful-addresses :test #'address=)) + (and (eql 'SUPERVISOR (getf entry ':source-type)) + (eql 'REWINDING (getf entry ':entry-type))) + (and (eql 'SUPERVISOR (getf entry ':source-type)) + (eql 'MULTIREWEIGHTING (getf entry ':entry-type))) + (and (eql 'message-wilt (type-of (getf entry ':payload)))) + (and (eql 'HANDLING-SOW (getf entry ':entry-type)))) + (push entry entries)))))) diff --git a/src/node.lisp b/src/node.lisp new file mode 100644 index 0000000..c310efa --- /dev/null +++ b/src/node.lisp @@ -0,0 +1,469 @@ +;;;; matchmaker.lisp +;;;; +;;;; This implements the fundamental computational actor in a distributed +;;;; modification of Edmonds's minimum-weight perfect matching algorithm. + +(in-package #:anatevka) + +;;; some useful enumeratives + +(deftype ping-type () + '(member :ALL :SOFT :NONE)) + +;;; +;;; BLOSSOM-NODE definition. +;;; +;;; BLOSSOM-NODEs participate in two different trees: +;;; (1) There is a _forest_ structure built up from alternating chains of +;;; unmatched and matched edges, rooted at an unmatched vertex. This tree +;;; structure is stored in the PARENT and CHILDREN slots. +;;; (2) A node can also represent a (possibly iteratively) contracted +;;; subgraph. These contractions are injected so as to move the overall +;;; graph structure towards being bipartite. Such a contracted subgraph +;;; is commonly referred to as a "blossom", though we also use the word to +;;; refer to bare vertices. This tree structure (where a BLOSSOM carries +;;; pointers to the vertices of which it's a contraction, with the +;;; guarantee that no vertices are ever shared among different blossoms in +;;; this way) is stored in the PISTIL and PETALS slots. +;;; +;;; It also tracks a small amount of miscellaneous blossom algorithm state info. +;;; + +(defparameter *blossom-node-clock-rate* 50 + "Determines the number of actions a blossom process takes per unit of simulation time. This is used to initialize (PROCESS-CLOCK-RATE BLOSSOM), offset so that it catches the eye.") + +(defclass blossom-node (process-lockable) + (;; process-related slots, including overrides + (process-clock-rate + :initform *blossom-node-clock-rate* + :documentation "Number of blossom actions per unit of simulation time. Overrides the parent slot provided by PROCESS.") + ;; the dryad is our parent process. it also keeps track of "neighboring" + ;; vertices (i.e., the graph structure of the problem we're trying to solve), + ;; we retain its address so that we can ask it for a list of active neighbors. + (dryad + :accessor blossom-node-dryad + :initform nil + :initarg :dryad + :type (or null address) + :documentation "The address of the host DRYAD.") + ;; most of the process's state is maintained in its data stack, but there are + ;; also globals that are useful to track separately, as they govern how the + ;; process responds to (or mutes) incoming messages. + (pingable + :accessor blossom-node-pingable + :initform ':ALL + :type ping-type + :documentation "Used by message handler guards to determine whether this process is currently servicing PING requests. SOFT-PINGs are serviced when set to :SOFT or :ALL, PINGs are serviced when set to :ALL, nothing is serviced when set to :NONE.") + (wilting + :accessor blossom-node-wilting + :initform nil + :initarg :wilting + :type boolean + :documentation "If T, BLOSSOM-NODE has lost the will to live.") + (paused? + :accessor blossom-node-paused? + :initform nil + :initarg :paused? + :type boolean + :documentation "If T, do not start a new scan.") + ;; the remaining slots encode the "data" of the blossom algorithm's state: + ;; its tree structures, any reweightings, and so on. (it does not capture + ;; all of the "execution" state of the algorithm: that is captured in frames + ;; on the process's data stack.) + (id + :accessor blossom-node-id + :initarg :id + :documentation "Internal name for this blossom node. Used by VERTEX-VERTEX-DISTANCE to the edge weight in the graph.") + (match-edge + :accessor blossom-node-match-edge + :initarg :match-edge + :initform nil + :type (or null blossom-edge) + :documentation "If this vertex is matched, point to the match.") + (internal-weight + :accessor blossom-node-internal-weight + :initarg :internal-weight + :initform 0 + :type real + :documentation "The dual weight y_v in the algorithm.") + (pistil + :accessor blossom-node-pistil + :initform nil + :initarg :pistil + :type (or null address) + :documentation "(Immediate) blossom that this vertex belongs to.") + (petals + :accessor blossom-node-petals + :initform nil + :initarg :petals + :type list + :documentation "List of BLOSSOM-EDGEs. Runs through nodes in this blossom in cyclic order.") + (parent + :accessor blossom-node-parent + :initform nil + :initarg :parent + :type (or null blossom-edge) + :documentation "If this blossom is part of a nontrivial tree, point to parent.") + (children + :accessor blossom-node-children + :initform nil + :initarg :children + :type list + :documentation "If this blossom is part of a tree, these are its children.") + (positive? + :accessor blossom-node-positive? + :initform t + :initarg :positive? + :type boolean + :documentation "Parity of distance from root, as in C_2.") + (held-by-roots + :accessor blossom-node-held-by-roots + :initform nil + :initarg :held-by-roots + :type list + :documentation "LIST of `BLOSSOM-NODE' roots who are causing us to `HOLD'.")) + (:documentation "Embodies a blossom in the blossom algorithm.")) + +;;; +;;; basic utilities for BLOSSOM-NODE instances +;;; + +(defmethod print-object ((object blossom-node) stream) + (print-unreadable-object (object stream :type t :identity nil) + (format stream ":ID ~a :ADDRESS ~a" + (blossom-node-id object) + (process-public-address object)))) + +(defun vertex? (node) + "Is NODE a VERTEX? (That is: does it have blossom children that it's contracting?)" + (check-type node blossom-node) + (not (blossom-node-petals node))) + +(defgeneric vertex-vertex-distance (id-v id-w) + (:documentation "Returns the distance between the blossom vertex with ID given by ID-V and that with ID given by ID-W.")) + +;;; +;;; the BLOSSOM-EDGE structure, which describes a (directed) edge from one +;;; (possibly contracted) vertex to another, and associated utilities. +;;; + +(defstruct (blossom-edge (:constructor %make-blossom-edge)) + "Represents a directed edge between two blossoms X and Y, as connected by vertices A, B. + +[X: ... A--]--[->B ... :Y]" + (source-node nil :type (or null address)) + (source-vertex nil :type (or null address)) + (target-node nil :type (or null address)) + (target-vertex nil :type (or null address))) + +(defun make-blossom-edge (&key (source-node nil source-node-p) + source-vertex + target-vertex + (target-node nil target-node-p)) + (%make-blossom-edge :source-node (if source-node-p source-node source-vertex) + :source-vertex source-vertex + :target-vertex target-vertex + :target-node (if target-node-p target-node target-vertex))) + +(defmethod print-object ((object blossom-edge) stream) + (print-unreadable-object (object stream :type nil :identity nil) + (if (and (blossom-edge-source-node object) + (blossom-edge-source-vertex object) + (address= (blossom-edge-source-node object) + (blossom-edge-source-vertex object))) + (format stream "~a-" + (blossom-edge-source-vertex object)) + (format stream "[~a: ~a--]" + (blossom-edge-source-node object) + (blossom-edge-source-vertex object))) + (format stream "--") + (if (and (blossom-edge-target-vertex object) + (blossom-edge-target-node object) + (address= (blossom-edge-target-vertex object) + (blossom-edge-target-node object))) + (format stream "->~a" + (blossom-edge-target-vertex object)) + (format stream "[->~a :~a]" + (blossom-edge-target-vertex object) + (blossom-edge-target-node object))))) + +(defun edge= (x y) + (check-type x blossom-edge) + (check-type y blossom-edge) + (and (address= (blossom-edge-source-node x) (blossom-edge-source-node y)) + (address= (blossom-edge-source-vertex x) (blossom-edge-source-vertex y)) + (address= (blossom-edge-target-vertex x) (blossom-edge-target-vertex y)) + (address= (blossom-edge-target-node x) (blossom-edge-target-node y)))) + +(defun reverse-blossom-edge (edge) + "(Nondestructively) reverses the directionality of EDGE." + (make-blossom-edge :source-node (blossom-edge-target-node edge) + :source-vertex (blossom-edge-target-vertex edge) + :target-vertex (blossom-edge-source-vertex edge) + :target-node (blossom-edge-source-node edge))) + +(defun reverse-blossom-edges (edges &optional acc) + "(Nondestructively) reverses the directionality of a path of EDGEs." + (unless edges + (return-from reverse-blossom-edges acc)) + (let ((first (first edges)) + (rest (rest edges))) + (push (reverse-blossom-edge first) acc) + (reverse-blossom-edges rest acc))) + +(defun find-even-arm (cycle start end &key + (key #'identity) + (test #'eql) + (rev #'reverse) + reversed?) + "Given an odd-length list of items, stored as `CYCLE', in which `START' and `END' appear, finds the even-length path connecting `START' and (just before) `END'. To find this path, we make use of the `KEY' and `TEST' keyword arguments as inputs to the `POSITION' function. Returns a VALUES triple: the even-length subpath, a boolean indicating whether the path proceeds in an opposite direction from that natural orientation of `CYCLE' (i.e., if it proceeds from END to START), and the full cycle rotated to begin just after `END' and potentially reversed to match the orientation of the subpath. If reversal is necessary, we use the function specified by the `REV' keyword argument to reverse the `CYCLE' and recurse to find the reverse paths. + +For instance, + + (find-even-arm (list 1 2 3 4 5 6 7) 5 3) + +evalutes to + + (5 4) + T + (3 2 1 7 6 5 4) ." + (let* ((length (length cycle)) + (doubled (append cycle cycle)) + (left (position start doubled :key key :test test)) + (right (position end doubled :key key :test test :start left))) + (cond + ((evenp (- right left)) + (values (subseq doubled left right) + reversed? + (nconc (subseq doubled right (+ left length)) + (subseq doubled left right)))) + (t + (assert (null reversed?) () "cha cha real slow") + (find-even-arm (funcall rev cycle) + start end + :key key :test test :rev rev :reversed? T))))) + +;;; +;;; message definitions for BLOSSOM-NODE +;;; + +(defstruct (message-broadcast-pingability (:include message)) + "Sent from a `SUPERVISOR' to a tree to change its pingability to `PING-TYPE'." + (ping-type nil :type ping-type)) + +(defstruct (message-set (:include message)) + "Causes a remote SETF (on the BLOSSOM-NODE object). The nth slot is set to the nth value." + (slots nil :type list) + (values nil :type list)) + +(defstruct (message-push (:include message)) + "Causes a remote PUSH (on the BLOSSOM-NODE object). The VALUE is pushed to the head of SLOT." + (slot nil :type symbol) + (value nil :type t)) + +(defstruct (message-values (:include message)) + "Replies with slot-values (on the BLOSSOM-NODE object)." + (values nil :type list)) + +(defstruct (message-id-query (:include message)) + "Replies with the minimum ID at this macrovertex." + ) + +;;; +;;; message handlers for BLOSSOM-NODE +;;; + +(defgeneric min-id (x y) + (:documentation "Computes the smaller of two IDs.") + (:method ((x real) (y real)) + (min x y)) + (:method ((x string) (y string)) + (if (string< x y) x y))) + +(define-message-subordinate handle-message-id-query + ((node blossom-node) (message message-id-query) now) + "Replies with the minimum ID at this macrovertex." + (cond + ((null (blossom-node-petals node)) + (send-message (message-reply-channel message) + (make-message-rpc-done :result (blossom-node-id node)))) + (t + ;; NOTE: this could be a broadcast call if aether subordinates subclassed that + (with-replies (replies) + (send-message-batch #'make-message-id-query + (mapcar #'blossom-edge-target-node + (blossom-node-petals node))) + (send-message (message-reply-channel message) + (make-message-rpc-done + :result (reduce #'min-id (rest replies)))))))) + +;; When locked, a tree delays any replies to PING messages, lest a PONG reply be +;; calculated while the tree is in a dirty state. This on its own is too +;; limiting: a tree must also be able to send and receive PINGs in order to +;; check that its proposed operation is still sane / has produced sane results. +;; We enable this by changing the tree's pingability, and thus permitting the +;; tree to respond to a safe subset (or to all) of PING requests. + +(define-broadcast-handler handle-message-broadcast-pingability + ((node blossom-node) (message message-broadcast-pingability) now) + "Changes the pingability of `NODE' (and children / petals) to `PING-TYPE'." + (with-slots (ping-type) message + (log-entry :entry-type 'changing-pingability + :old-pingability (blossom-node-pingable node) + :new-pingability ping-type) + (setf (blossom-node-pingable node) ping-type) + (push-broadcast-frame :targets (mapcar #'blossom-edge-target-node + (union (blossom-node-petals node) + (blossom-node-children node)))))) + +;; rather than separately implement a plethora of micromessages that serve as +;; accessors, we provide a handful of messages which serve as generic setters +;; and getters on the receiver. +;; +;; NOTE GH-140: these are probably pretty easy to abuse. perhaps it would be +;; better to implement the micromessages after all. + +(define-rpc-handler handle-message-set + ((node blossom-node) (message message-set) now) + "Handles a remote SETF request." + (with-slots (slots values reply-channel) message + (loop :for slot :in slots + :for value :in values + :do (setf (slot-value node slot) value)) + (values))) + +(define-rpc-handler handle-message-push + ((node blossom-node) (message message-push) now) + "Handles a remote PUSH request." + (with-slots (slot value reply-channel) message + (push value (slot-value node slot)) + (values))) + +(define-rpc-handler handle-message-values + ((node blossom-node) (message message-values) now) + "Handles a remote request for data." + (with-slots (values reply-channel) message + (loop :for value :in values + :collect (slot-value node value)))) + +;; the SPROUT-ON-BLOSSOM and WILT messages pertain to the blossom lifecycle with +;; regards to the owning dryad. after originally initializing the blossom, the +;; dryad is interested in when the blossom begins participating in matches +;; (before which it's certainly unable to be considered "done") and, conversely, +;; in the ability to inform a blossom that it's been removed from participating +;; and should halt its process. + +(define-message-handler handle-message-sprout-on-blossom + ((node blossom-node) (message message-sprout) now) + "Handles a request that a root node (perhaps not a vertex) alert the DRYAD that it has sprouted." + (cond + ((blossom-node-petals node) + (let* ((first-child (first (blossom-node-petals node))) + (peduncle-node (blossom-edge-source-node first-child))) + (send-message peduncle-node message))) + (t + (send-message (blossom-node-dryad node) + (make-message-sprout :address (process-public-address node)))))) + +(define-message-handler handle-message-wilt + ((node blossom-node) (message message-wilt) now) + ;; sanity check: are we actually allowed to wilt? + (when (or (blossom-node-parent node) + (blossom-node-pistil node) + (blossom-node-children node) + (blossom-node-petals node) + (null (blossom-node-match-edge node))) + (error "Caught wilt message, but not decoupled from tree.")) + (send-message (blossom-node-dryad node) + (make-message-wilting :reply-channel (message-reply-channel message) + :address (process-public-address node))) + (setf (blossom-node-wilting node) t)) + +;;; +;;; blossom message dispatch table +;;; + +;; NOTE: the ordering of this table _mostly_ doesn't matter. its only really +;; important feature is that LOCK-REQUEST gets handled with high priority. +(define-message-dispatch blossom-node + (message-soft-adjoin-root 'handle-message-adjoin-root + (typep (blossom-node-pistil blossom-node) + '(or null address))) + (message-adjoin-root 'handle-message-adjoin-root + (and (eql ':ALL (blossom-node-pingable blossom-node)) + (typep (blossom-node-pistil blossom-node) + '(or null address)))) + + (message-lock 'handle-message-lock) + + (message-broadcast-reweight 'handle-message-broadcast-reweight + (process-lockable-locked? blossom-node)) + + (message-percolate 'handle-message-percolate) + + (message-soft-scan 'handle-message-scan + (not (eql ':NONE (blossom-node-pingable blossom-node)))) + (message-scan 'handle-message-scan + (eql ':ALL (blossom-node-pingable blossom-node))) + + (message-broadcast-pingability 'handle-message-broadcast-pingability) + + (message-convergecast-collect-roots 'handle-message-convergecast-collect-roots) + + (message-set 'handle-message-set) + (message-push 'handle-message-push) + (message-values 'handle-message-values) + + (message-root-path 'handle-message-root-path) + (message-attach-parent 'handle-message-attach-parent) + (message-convert-child-to-petal 'handle-message-convert-child-to-petal) + (message-reattach-cycle-child 'handle-message-reattach-cycle-child) + (message-set-up-blossom 'handle-message-set-up-blossom) + + (message-expand 'handle-message-expand) + (message-blossom-parent 'handle-message-blossom-parent + (typep (blossom-node-pistil blossom-node) + '(or null address))) + (message-replace-child 'handle-message-replace-child) + + (message-soft-ping 'handle-message-ping + (not (eql ':NONE (blossom-node-pingable blossom-node)))) + + (message-ping 'handle-message-ping + (eql ':ALL (blossom-node-pingable blossom-node))) + + (message-wilt 'handle-message-wilt) + + (message-sprout 'handle-message-sprout-on-blossom) + + (message-id-query 'handle-message-id-query)) + +;;; +;;; basic command definitions for BLOSSOM-NODE +;;; + +(define-process-upkeep ((node blossom-node) now) (START) + "Blossom nodes represent (contracted subgraphs of) vertex(es). The START command drops the blossom node into an infinite loop, SCAN-LOOP, which enacts the basic behavior." + (process-continuation node `(SCAN-LOOP))) + +(define-process-upkeep ((node blossom-node) now) (SCAN-LOOP &optional repeat?) + "If we're out of things to do & unmatched, consider starting a SCAN. If REPEAT? is set, then this is _not_ our first time trying to SCAN to find something to do, and the previous attempt(s) resulted in no action." + (unless (blossom-node-wilting node) + (process-continuation node `(SCAN-LOOP)) + (unless (or (process-lockable-locked? node) + (blossom-node-parent node) + (blossom-node-pistil node) + (blossom-node-match-edge node) + (blossom-node-paused? node)) + ;; doing this manual command injection rather than sending a message is a + ;; stopgap against sending multiple SCAN messages, which looks gross / wrong. + (let ((scan-message (make-message-scan + :local-root (process-public-address node) + :weight 0 + :repeat? repeat?))) + + (process-continuation node `(START-SCAN ,scan-message)))))) + +(define-process-upkeep ((node blossom-node) now) (IDLE) + (unless (blossom-node-wilting node) + (process-continuation node `(IDLE)))) diff --git a/src/operations/augment.lisp b/src/operations/augment.lisp new file mode 100644 index 0000000..386d923 --- /dev/null +++ b/src/operations/augment.lisp @@ -0,0 +1,114 @@ +;;;; operations/augment.lisp +;;;; +;;;; An AUGMENT action enlarges a matching by introducing two new nodes to it. +;;;; Recall that the blossom forest is populated by trees which are built out of +;;;; and unmatched root node and that all other nodes in the tree are matched to +;;;; other nodes in the tree (cf. GRAFT). So, a prototypical pair of trees +;;;; might look like this: +;;;; +;;;; A --> B ==> C +;;;; +;;;; E ==> F +;;;; ^ +;;;; / +;;;; D +;;;; \ +;;;; v +;;;; G ==> H +;;;; +;;;; where A, ..., H are nodes, --> and ==> indicate a parent/child relationship, +;;;; and == indicates a match between its endpoints. An AUGMENT is triggered by +;;;; a weightless edge C ~~ F. Tracing the paths from C and from F to their +;;;; respective roots, we have +;;;; +;;;; D --> E ==> F ~~ C <== B <-- A . +;;;; +;;;; AUGMENTATION "reverses" which edges in this chain are matches, as in +;;;; +;;;; D === E F == C B === A, +;;;; +;;;; and it destroys all of the parent/child relationships within the tree, so +;;;; that any other nonparticipating branches in the tree are reduced to their +;;;; constituent barbells: +;;;; +;;;; G == H. +;;;; +;;;; Critically, AUGMENT is only considered for edges between nodes which are +;;;; both "positive" (i.e., of even height) in their respective trees, so that +;;;; the path to their respective roots has the indicated alternating pattern. + +(in-package #:anatevka) + +;;; +;;; supervisor command definitions +;;; + +(define-process-upkeep ((supervisor supervisor) now) (START-AUGMENT pong) + "Sets up the augmentation procedure." + (with-slots (edges source-root target-root) pong + (let* ((edge (first edges)) + (targets (list source-root target-root))) + ;; set up script + (process-continuation supervisor + `(BROADCAST-LOCK ,targets) + `(CHECK-ROOTS ,targets) + `(BROADCAST-PINGABILITY ,targets :SOFT) + `(CHECK-PONG ,pong) + `(AUGMENT ,edge) + `(AUGMENT ,(reverse-blossom-edge edge)) + `(BROADCAST-UNLOCK :destroy? ,T) + `(HALT))))) + +(define-process-upkeep ((supervisor supervisor) now) (AUGMENT edge) + "Perform an augmentation along a given edge." + (unless (process-lockable-aborting? supervisor) + (log-entry :entry-type 'augment + :from (blossom-edge-source-node edge) + :to (blossom-edge-target-node edge)) + (sync-rpc (make-message-percolate :traversal-edge edge) + (percolate-result (blossom-edge-target-node edge)) + nil))) + +;;; +;;; message definitions +;;; + +(defstruct (message-percolate (:include message)) + "Sent from a SUPERVISOR to a tree (and then internally to a tree) to cause a path augmentation." + (traversal-edge nil :type blossom-edge)) + +;;; +;;; message handlers +;;; + +(define-message-handler handle-message-percolate + ((node blossom-node) (message message-percolate) now) + "Performs a step in the path augmentation process." + (with-slots (traversal-edge reply-channel) message + ;; does the previous node expect me to link to it? + (let ((back-linking? + (or (null (blossom-node-parent node)) + (and (blossom-node-match-edge node) + (address= + (blossom-edge-target-node (blossom-node-parent node)) + (blossom-edge-target-node (blossom-node-match-edge node))))))) + (cond + ;; if we're the top node... + ((null (blossom-node-parent node)) + ;; tie us off + (setf (blossom-node-match-edge node) (reverse-blossom-edge traversal-edge)) + ;; sprout this root node + (send-message (process-public-address node) + (make-message-sprout :address (process-public-address node))) + ;; and announce the completion + (send-message reply-channel (make-message-rpc-done))) + ;; otherwise, we have a parent and we propagate upward + (t + (setf (blossom-node-match-edge node) + (if back-linking? + (reverse-blossom-edge traversal-edge) + (copy-blossom-edge (blossom-node-parent node)))) + (send-message (blossom-edge-target-node (blossom-node-parent node)) + (make-message-percolate + :reply-channel reply-channel + :traversal-edge (copy-blossom-edge (blossom-node-parent node))))))))) diff --git a/src/operations/contract.lisp b/src/operations/contract.lisp new file mode 100644 index 0000000..c7b2b2d --- /dev/null +++ b/src/operations/contract.lisp @@ -0,0 +1,392 @@ +;;;; operations/contract.lisp +;;;; +;;;; In the case that the endpoints of a weightless edge both belong to the same +;;;; tree, it is inappropriate to perform an augmentation: since the paths from +;;;; these nodes to their "respective roots" both end in the same place, one +;;;; cannot assign both of two possible new matches to the root. Instead, the +;;;; appropriate action is to contract this subgraph into a single vertex. This +;;;; has the effect that any _later_ augmentation path in which this contracted +;;;; vertex participates can be lifted to an augmentation path through the +;;;; original graph: such a subgraph always contains an odd number of nodes, +;;;; hence between any pair of nodes there is a path with an even number of +;;;; edges, given either by following the original cycle of edges clockwise +;;;; or counterclockwise. +;;;; +;;;; As an example, consider the following partial tree and its weightless edge: +;;;; +;;;; B ==> C +;;;; ^ ~ +;;;; / ~ +;;;; ==> A 0 +;;;; \ ~ +;;;; v ~ +;;;; D ==> E +;;;; +;;;; By tracing a path from C and from E to their root, one produces a cycle of +;;;; odd length in which C ~~ E and (the beginnings of) their paths to the root +;;;; participate: [A, B, C, E, D]. CONTRACT replaces this by one node: +;;;; +;;;; [ BLOSSOM ] +;;;; [ B ==> C ] +;;;; [ ^ ~ ] +;;;; [ / ~ ] +;;;; ==> [ A 0 ] +;;;; [ \ ~ ] +;;;; [ v ~ ] +;;;; [ D ==> E ] +;;;; +;;;; See EXPAND for a demonstration of the value of this tree operation. +;;;; +;;;; This operation is made complicated by having to track the tree structure +;;;; "around" the subgraph to be contracted: for instance, any other children +;;;; connected to vertices which are going to be contracted but which themselves +;;;; do not participate in the contraction. + +(in-package #:anatevka) + +;;; +;;; supervisor data frame +;;; + +(defstruct data-frame-contract + "Data frame associated to a SUPERVISOR process enacting CONTRACT. + +PONG: The PONG that this processes received at its START. + +PATH: The cycle of blossom child edges to install into this blossom. + +PEDUNCLE-EDGE: The edge leading from the root of this subtree out of the graph. + +FRESH-BLOSSOM: The address of the newly contracted blossom. + +PETAL-CHILD-EDGES: The list of child edges attached to the blossoms in the subtree which will become children of the newly contracted blossom." + (pong nil :type message-pong) + (path nil :type list) + (peduncle-edge nil :type (or null blossom-edge)) + (fresh-blossom nil :type address) + (petal-child-edges nil :type list) + ;; here's a surprising bug: BROADCAST-LOCK maintains a LIFO stack of locks. + ;; since we lock the blossom petals before forming and locking the new blossom, + ;; this means that the fresh blossom gets freed to act before its originally- + ;; locked root does. if the fresh blossom immediately emits a scan directive, + ;; then the locked root will never get around to fulfilling its unlock. so, we + ;; stow the fresh lock here to release last. + (stowed-rx-latch nil :type (or null address)) + (stowed-tx-latch nil :type (or null address))) + +;;; +;;; supervisor command definitions +;;; + +(define-process-upkeep ((supervisor supervisor) now) (START-CONTRACT pong) + "Begins the CONTRACT routine, sets up the stack frames." + (with-slots (source-root) pong + (let ((targets (list source-root))) + ;; set up script + (process-continuation supervisor + `(BROADCAST-LOCK ,targets) + `(CHECK-ROOTS ,targets) + `(BROADCAST-PINGABILITY ,targets :SOFT) + `(CHECK-PONG ,pong) + `(BROADCAST-PINGABILITY ,targets :NONE) + `(START-INNER-CONTRACT) + `(BROADCAST-UNLOCK) + `(HALT))))) + +(define-process-upkeep ((supervisor supervisor) now) (START-INNER-CONTRACT) + "Begins the critical section of the CONTRACT routine." + (unless (process-lockable-aborting? supervisor) + (let* ((supervisor-frame (peek (process-data-stack supervisor))) + (fresh-blossom (spawn-process (supervisor-node-class supervisor) + :id (gensym "BLOSSOM") + ;; prevent SCANs + :paused? t + :debug? (process-debug? supervisor)))) + (schedule fresh-blossom now) + (push (make-data-frame-contract + :fresh-blossom (process-public-address fresh-blossom) + :pong (data-frame-supervisor-pong supervisor-frame)) + (process-data-stack supervisor)) + (process-continuation supervisor + `(BROADCAST-LOCK ,(list (process-public-address fresh-blossom))) + `(STOW-LOCK) + `(COMPUTE-BLOSSOM-PATHS) + `(HANDLE-PISTIL) + `(HANDLE-PETALS) + `(HANDLE-BLOSSOM-SUB-CHILDREN) + `(HANDLE-NEW-BLOSSOM) + `(BROADCAST-UNLOCK) ; NOTE: double-calling BROADCAST-UNLOCK makes + `(RELEASE-STOWED-LOCK))))) ; the second one a NOP. + +(define-process-upkeep ((supervisor supervisor) now) (STOW-LOCK) + (with-slots (downward-rx-latches downward-tx-latches) supervisor + (with-slots (stowed-rx-latch stowed-tx-latch) (peek (process-data-stack supervisor)) + (setf stowed-rx-latch (pop downward-rx-latches) + stowed-tx-latch (pop downward-tx-latches))))) + +(define-process-upkeep ((supervisor supervisor) now) (RELEASE-STOWED-LOCK) + (with-slots (downward-rx-latches downward-tx-latches) supervisor + (with-slots (stowed-rx-latch stowed-tx-latch) (pop (process-data-stack supervisor)) + (push stowed-rx-latch downward-rx-latches) + (push stowed-tx-latch downward-tx-latches) + (process-continuation supervisor `(BROADCAST-UNLOCK))))) + +(define-process-upkeep ((supervisor supervisor) now) (COMPUTE-BLOSSOM-PATHS) + "This command computes the cycle which will constitute the fresh blossom. + + G <-- root --> G + | | + F F + | <-- peduncle edge --> | + [ C ] [C~~~] + [ / \ ] [| ~] + [B D] <-- fresh blossom --> [B ~] + [| |] [| ~] + [A ~ E] [A~~~] + +Both above tree diagrams are valid arrangments that would trigger this operation, but we will concern ourselves with the left one. + + (1) A `CONTRACT' 0 is recommended between A and E, so the first thing we do is determine the two paths from the root G to the nodes A and E: + + G -> A : (NIL G -> F F -> C C -> B B -> A) + G -> E : (NIL G -> F F -> C C -> D D -> E) + + (2) Then, we want to trim everything higher in the tree than the first edge shared by the two root paths, so that we know what constitutes the cycle of edges in the fresh blossom we're about to create. + + tail A : (F -> C C -> B B -> A) + tail E : (F -> C C -> D D -> E) + + (3) Then, we trim the first entry off of the tails, and we call that the peduncle as long as it non-null (it would be null if the tree root was C instead of F). This becomes the match and parent of the fresh blossom. + + peduncle edge : F -> C + trimmed tail A : (C -> B B -> A) + trimmed tail E : (C -> D D -> E) + + (4) Finally, we combine the two trimmed tails (one of which is reversed) and the edge that suggested the contract blossom operation, to build the cycle. + + blossom cycle : (C -> B B -> A A -> E E -> D D -> C)" + (let* ((frame (peek (process-data-stack supervisor))) + (edge (car (message-pong-edges (data-frame-contract-pong frame)))) + (originating-node (blossom-edge-source-node edge)) + (recipient-node (blossom-edge-target-node edge)) + (rx-channels nil)) + ;; (1a) get chain from originating blossom node through to the root + (push (send-message originating-node + (make-message-root-path :reply-channel (register))) + rx-channels) + ;; (1b) get chain from recipient blossom node through to the root + (push (send-message recipient-node + (make-message-root-path :reply-channel (register))) + rx-channels) + (with-replies (root-paths) rx-channels + ;; (2) prune shared ancestor edges above the peduncle + (destructuring-bind (originating-tail recipient-tail) + (latest-common-head (second root-paths) (first root-paths) + :key #'blossom-edge-target-node + :test #'address=) + ;; (3) trim the peduncle from the tails, if present + (cond + ;; (3a) when both tails have a non-null first entry + ;; this happens in both of the above tree diagrams + ((and (first originating-tail) (first recipient-tail) + (address= (blossom-edge-target-node (first originating-tail)) + (blossom-edge-target-node (first recipient-tail)))) + (setf (data-frame-contract-peduncle-edge frame) + (or (first originating-tail) (first recipient-tail)) + originating-tail (rest originating-tail) + recipient-tail (rest recipient-tail))) + ;; (3b) when both tails have a null first entry + ;; this happens when there is no peduncle edge, meaning that + ;; the fresh blossom cycle includes the root of the tree + ((and (null (first originating-tail)) + (null (first recipient-tail))) + (setf originating-tail (rest originating-tail) + recipient-tail (rest recipient-tail)))) + ;; (4) finally, combine the peduncle-free tails to produce + ;; the list of edges that makes up the fresh blossom cycle + (setf (data-frame-contract-path frame) + (append originating-tail + (list (copy-blossom-edge edge)) + (reverse-blossom-edges recipient-tail))))))) + +(define-process-upkeep ((supervisor supervisor) now) (HANDLE-PISTIL) + "Tell the source of the peduncle edge that the fresh blossom is its child. + + G <-- root --> G + | | + F F + | <-- peduncle edge --> | + [ C ] [C~~~] + [ / \ ] [| ~] + [B D] <-- fresh blossom (H) --> [B ~] + [| |] [| ~] + [A ~ E] [A~~~] + +If we have a non-null peduncle edge (F -> C above), then we need to tell its source node (F) that it has a new child -- the fresh blossom (which we will call H). So, we send F a `message-attach-parent' message, which iterates through F's existing child relationships, and whichever one matches the peduncle edge has its target node updated from C to H:C, meaning that the target has node H and vertex C." + (let ((frame (peek (process-data-stack supervisor)))) + (with-slots (peduncle-edge fresh-blossom) frame + (when peduncle-edge + (sync-rpc (make-message-attach-parent :fresh-blossom fresh-blossom + :peduncle-edge peduncle-edge) + (attach-result (blossom-edge-source-node peduncle-edge)) + nil))))) + +(define-process-upkeep ((supervisor supervisor) now) (HANDLE-PETALS) + "Tell the blossom's petals what's up." + (with-slots (path fresh-blossom petal-child-edges) (peek (process-data-stack supervisor)) + (let ((children (mapcar #'blossom-edge-target-node path))) + (flet ((payload-constructor () + (make-message-convert-child-to-petal :fresh-blossom fresh-blossom))) + (with-replies (petal-replies) + (send-message-batch #'payload-constructor children) + (setf petal-child-edges + (remove-if (lambda (x) + (member (blossom-edge-target-node x) + (mapcar #'blossom-edge-target-node path) + :test #'address=)) + (apply #'append petal-child-edges petal-replies)))))))) + +(define-process-upkeep ((supervisor supervisor) now) (HANDLE-BLOSSOM-SUB-CHILDREN) + "Tell all the other children what's up." + (with-slots (fresh-blossom petal-child-edges) (peek (process-data-stack supervisor)) + (let ((petal-children (mapcar #'blossom-edge-target-node petal-child-edges))) + (flet ((payload-constructor () + (make-message-reattach-cycle-child :fresh-blossom fresh-blossom))) + (with-replies (replies) + (send-message-batch #'payload-constructor petal-children) + nil))))) + +(define-process-upkeep ((supervisor supervisor) now) (HANDLE-NEW-BLOSSOM) + "Tell the blossom itself what's up." + (let ((frame (peek (process-data-stack supervisor)))) + (with-slots (fresh-blossom peduncle-edge path petal-child-edges) frame + (sync-rpc (make-message-set-up-blossom + :peduncle-edge peduncle-edge + :petals path + :petal-children petal-child-edges) + (set-up-result fresh-blossom) + nil)))) + +;;; +;;; message definitions +;;; + +(defstruct (message-root-path (:include message)) + "Calculates the path from a node through to the root of its containing tree." + (path nil :type list)) + +(defstruct (message-attach-parent (:include message)) + "Sent from a SUPERVISOR to a BLOSSOM-NODE to install a new PARENT." + (fresh-blossom nil :type address) + (peduncle-edge nil :type (or null blossom-edge))) + +(defstruct (message-convert-child-to-petal (:include message)) + "Sent from a SUPERVISOR to a BLOSSOM-NODE to install a new CHILD." + (fresh-blossom nil :type address)) + +(defstruct (message-reattach-cycle-child (:include message)) + "Sent from a SUPERVISOR to a BLOSSOM-NODE to transfer responsibility for a petal-child." + (fresh-blossom nil :type address)) + +(defstruct (message-set-up-blossom (:include message)) + "Sent from a SUPERVISOR to a newly formed contracting BLOSSOM to set up its slots." + (peduncle-edge nil :type (or null blossom-edge)) + (petals nil :type list) + (petal-children nil :type list)) + +;;; +;;; message handlers +;;; + +(define-message-handler handle-message-root-path + ((node blossom-node) (message message-root-path) now) + "Calculates the path from a blossom through to the tree root (consisting only of toplevel blossoms)." + (with-slots (path reply-channel) message + (cond + ((and (blossom-node-pistil node) + (typep (blossom-node-pistil node) 'blossom-edge)) + (send-message reply-channel (make-message-rts))) + ((blossom-node-pistil node) + (send-message (blossom-node-pistil node) message)) + ((blossom-node-parent node) + (push (reverse-blossom-edge (blossom-node-parent node)) path) + (send-message (blossom-edge-target-node (blossom-node-parent node)) message)) + (t + (send-message reply-channel + (make-message-rpc-done :result path)))))) + +(define-rpc-handler handle-message-attach-parent + ((node blossom-node) (message message-attach-parent) now) + "Attaches a fresh blossom to an existing parent." + (with-slots (peduncle-edge reply-channel fresh-blossom) message + (assert (not (null peduncle-edge))) + (assert (not (null (blossom-node-children node)))) + (let (did-work-p) + (dolist (child-edge (blossom-node-children node)) + (when (address= (blossom-edge-target-node child-edge) + (blossom-edge-target-node peduncle-edge)) + (setf (blossom-edge-target-node child-edge) fresh-blossom + did-work-p t))) + (assert did-work-p)) + (setf (blossom-node-match-edge node) + (copy-blossom-edge peduncle-edge) + (blossom-edge-target-node (blossom-node-match-edge node)) + fresh-blossom) + nil)) + +(define-rpc-handler handle-message-convert-child-to-petal + ((node blossom-node) (message message-convert-child-to-petal) now) + "Attaches an old child to a new blossom as a petal." + (with-slots (reply-channel fresh-blossom) message + (prog1 (blossom-node-children node) + (setf (blossom-node-positive? node) t + (blossom-node-parent node) nil + (blossom-node-pistil node) fresh-blossom + (blossom-node-match-edge node) nil + (blossom-node-children node) nil)))) + +(define-rpc-handler handle-message-reattach-cycle-child + ((node blossom-node) (message message-reattach-cycle-child) now) + "Attaches an old child to a new blossom as a (non-blossom-)child." + (with-slots (reply-channel fresh-blossom) message + (setf (blossom-edge-target-node (blossom-node-parent node)) + fresh-blossom) + nil)) + +;; NOTE: this message is really hefty. you could cut it down somewhat by making +;; the fresh blossom responsible for setting _itself_ up. this would also +;; alleviate the obnoxious problem with locking/spawning timing. +(define-rpc-handler handle-message-set-up-blossom + ((node blossom-node) (message message-set-up-blossom) now) + "Sets up a new contracting blossom's slots." + (with-slots (peduncle-edge petals petal-children reply-channel) message + (loop :for petal-child :in petal-children + :for fresh-edge := (copy-blossom-edge petal-child) + :do (setf (blossom-edge-source-node fresh-edge) + (process-public-address node)) + :collect fresh-edge :into fresh-edges + :finally (setf petal-children fresh-edges)) + ;; if we have a peduncle edge, then the fresh blossom should have both a + ;; match and a parent (which are identical). we build these edges by + ;; reversing the peduncle edge, and then setting the source node of the + ;; newly-created reversed edge to be the fresh blossom + (when peduncle-edge + (let ((match-and-parent-edge (reverse-blossom-edge peduncle-edge))) + (setf (blossom-edge-source-node match-and-parent-edge) + (process-public-address node) + (blossom-node-match-edge node) + match-and-parent-edge + (blossom-node-parent node) + (copy-blossom-edge match-and-parent-edge)))) + (setf (blossom-node-petals node) petals + (blossom-node-children node) petal-children + ;; lastly, unpause our new blossom so that it can SCAN + (blossom-node-paused? node) nil) + (log-entry :entry-type 'SET-UP-BLOSSOM + :peduncle-edge peduncle-edge + :match-edge (blossom-node-match-edge node) + :children (blossom-node-children node) + :parent (blossom-node-parent node) + :petals (blossom-node-petals node) + :pistil (blossom-node-pistil node)) + nil)) diff --git a/src/operations/expand.lisp b/src/operations/expand.lisp new file mode 100644 index 0000000..971eb62 --- /dev/null +++ b/src/operations/expand.lisp @@ -0,0 +1,391 @@ +;;;; operations/expand.lisp +;;;; +;;;; EXPAND un-contracts a contracted node manufactured by CONTRACT. Consider +;;;; the earlier example: +;;;; +;;;; [ BLOSSOM ] +;;;; [ B ==> C ] +;;;; [ ^ ~ ] +;;;; [ / ~ ] +;;;; ==> [ A 0 ] +;;;; [ \ ~ ] +;;;; [ v ~ ] +;;;; [ D ==> E ] +;;;; +;;;; Suppose that a future AUGMENT directive involves a vertex participating in +;;;; this contracted subgraph. This changes the original matched edge entering +;;;; BLOSSOM at A to some other edge BLOSSOM == F for an external vertex F. The +;;;; duty of EXPAND-BLOSSOM is to modify the matches within this contracted sub- +;;;; graph to be consistent with this new match. Depending on which internal +;;;; vertex the new match edge BLOSSOM == F is actually attached, we have the +;;;; cases: +;;;; +;;;; to A: F == A (i.e., the empty path) , +;;;; to B: F == B -- C == E -- D == A , +;;;; to C: F == C -- B == A , +;;;; to D: F == D -- E == C -- B == A , +;;;; to E: F == E -- D == A . +;;;; +;;;; These show that an alternating chain can always be drawn through the +;;;; contracted graph, no matter which vertex is targeted. Additionally, any +;;;; vertices not appearing in the above trees themselves participate in pre- +;;;; existing matches, hence contribute inert matches after blossom dissolution. +;;;; +;;;; Aside from this major goal, this operation is again made complicated by +;;;; having to retain the tree structure "around" an expanding blossom: for +;;;; instance, any child edges attached to this blossom have to be re-attached +;;;; to the appropriate internal node. +;;;; +;;;; NOTE: This extension of the augmentation chain through the blossom as +;;;; described above _need not_ happen when AUGMENT happens. Instead, it +;;;; can be arbitrarily deferred. EXPAND's job is to finally make good on +;;;; such a deferral. + +(in-package #:anatevka) + +;;; +;;; supervisor command definitions +;;; + +(define-process-upkeep ((supervisor supervisor) now) (START-EXPAND pong) + "Sets up the expand procedure." + (with-slots (source-root) pong + (let ((targets (list source-root)) + (blossom (blossom-edge-source-node (car (message-pong-edges pong))))) + (process-continuation supervisor + `(BROADCAST-LOCK ,targets) + `(CHECK-ROOTS ,targets) + `(CHECK-INNER-BLOSSOM ,blossom ,source-root) + `(EXPAND-INNER-BLOSSOM ,blossom) + `(BROADCAST-UNLOCK) + `(HALT))))) + +(define-process-upkeep ((supervisor supervisor) now) (CHECK-INNER-BLOSSOM blossom source-root) + "When a supervisor is in charge of blossom expansion, we know that the blossom to be expanded is necessarily an inner blossom. Why? Because outer blossoms don't get an expand recommendation from the tree, and barbell blossoms are expanded by the dryad. However, as is common in this distributed algorithm, there are many opportunities for information to go stale, and so before we tell the blossom to expand itself, we double check that it is, in fact, an inner blossom, by checking its `internal-weight', `positive?', and `pistil' slots, as well as making sure that its root is as the supervisor expected, which ensures that everything is a-OK." + (unless (process-lockable-aborting? supervisor) + (sync-rpc (make-message-values :values '(internal-weight pistil positive?)) + ((internal-weight pistil positive?) blossom) + (sync-rpc (make-message-root-path) + (root-path-result blossom) + (when (or (/= 0 internal-weight) pistil positive? + (not (address= source-root + (blossom-edge-source-node (first root-path-result))))) + (setf (process-lockable-aborting? supervisor) t)))))) + +(define-process-upkeep ((supervisor supervisor) now) (EXPAND-INNER-BLOSSOM blossom) + "Blossom expansion is handled by the blossom itself. This instruction just triggers the expansion routine remotely and waits for it to complete." + (unless (process-lockable-aborting? supervisor) + (sync-rpc (make-message-expand) + (expand-result blossom) + (declare (ignore expand-result)) + nil))) + +;;; +;;; data frames +;;; + +;;; +;;; message definitions +;;; + +(defstruct (message-expand (:include message)) + "Sent from a SUPERVISOR to a BLOSSOM to cause it to pop.") + +(defstruct (message-blossom-parent (:include message)) + "Calculates the highest blossom parent which contains the recipient and which is contained in STOP-BEFORE." + (stop-before nil :type (or null address))) + +(defstruct (message-replace-child (:include message)) + "Replaces any child edges attaching to OLD-CHILD with edges attaching to NEW-CHILD instead." + (old-child nil :type address) + (new-child nil :type address)) + +;;; +;;; message handlers +;;; + +(define-message-handler handle-message-expand + ((node blossom-node) (message message-expand) now) + "Starts the procedure for popping a contracting blossom." + (cond + ((blossom-node-pistil node) + (send-message (blossom-node-pistil node) message)) + ((null (blossom-node-petals node)) + (send-message (message-reply-channel message) + (make-message-rpc-done))) + (t + (log-entry :entry-type 'expanding-blossom + :blossom node + :petals (blossom-node-petals node) + :match-edge (blossom-node-match-edge node)) + (process-continuation node `(EXPAND-BLOSSOM ,(message-reply-channel message)))))) + +(define-message-handler handle-message-blossom-parent + ((node blossom-node) (message message-blossom-parent) now) + "Calculates the topmost blossom which contains NODE, subject to the possible limitation that we not exceed STOP-BEFORE." + (with-slots (reply-channel stop-before) message + (cond + ((and (not (null stop-before)) + (or (null (blossom-node-pistil node)) + (and (blossom-node-pistil node) + (typep (blossom-node-pistil node) 'blossom-edge)))) + (error "Bad BLOSSOM-PARENT request.")) + ((or (null (blossom-node-pistil node)) + (and (blossom-node-pistil node) + (typep (blossom-node-pistil node) 'blossom-edge)) + (and stop-before + (address= stop-before (blossom-node-pistil node)))) + (send-message reply-channel + (make-message-rpc-done :result (process-public-address node)))) + (t + (send-message (blossom-node-pistil node) message))))) + +(define-rpc-handler handle-message-replace-child + ((node blossom-node) (message message-replace-child) now) + "Replaces a child edge targeting a given node by an edge targeting another node." + (with-slots (reply-channel old-child new-child) message + (dolist (child-edge (blossom-node-children node)) + (when (address= old-child (blossom-edge-target-node child-edge)) + (setf (blossom-edge-target-node child-edge) + new-child))) + nil)) + +;;; +;;; blossom-node command definitions +;;; + +;;; NOTE: at present, EXPAND is the odd operation out in that it is handled in +;;; the blossom commands rather than in the SUPERVISOR commands or in the +;;; message handlers. nonetheless, see the SUPERVISOR documentation for +;;; a description of what's happening here. + +(define-process-upkeep ((node blossom-node) now) (EXPAND-BLOSSOM reply-channel) + "Sets up the EXPAND stack frame." + ;; NOTE: because sync-receive does some implicit coroutine junk, performing + ;; operations after it executes conditionally + not repeating ourselves + ;; requires us to do some unpleasant juggling with the local #'FINALIZE. + ;; this is potentially fragile, and at any rate it's a smell i'd want to + ;; eliminate in the ultimate form of the DSL. + ;; + ;; it doesn't make sense to expand unmatched blossoms (but the dryad might try) + (unless (blossom-node-match-edge node) + (log-entry :entry-type 'aborting-expand-blossom + :reason 'mateless-blossom + :blossom node) + (send-message reply-channel (make-message-rpc-done)) + (finish-with-scheduling)) + (labels ((finalize (matched-node root-node) + ;; determines path from `root-node' to `matched-node', so + ;; should `:key' on `source-node' of the `petals' + (multiple-value-bind (path reversed? full-path) + (find-even-arm (blossom-node-petals node) + root-node matched-node + :key #'blossom-edge-source-node + :test #'address= + :rev #'reverse-blossom-edges) + (declare (ignore reversed?)) + ;; set up the blossom expansion script + (process-continuation node + ;; we drop the first edge of `full-path' because that + ;; edge has `matched-node' as it's source + `(EXPAND-BLOSSOM-ADD-CYCLE-MATCHES ,(rest full-path)) + `(EXPAND-BLOSSOM-BUILD-TREE-PATH ,path 0) + `(EXPAND-BLOSSOM-ATTACH-PARENT ,root-node) + `(EXPAND-BLOSSOM-ATTACH-MATCH ,matched-node ,root-node) + `(EXTINGUISH-BLOSSOM ,reply-channel))))) + ;; determine the which vertex is matched external to the blossom + (sync-rpc (make-message-blossom-parent + :stop-before (process-public-address node)) + (matched-node (blossom-edge-source-vertex (blossom-node-match-edge node))) + (cond + ((blossom-node-parent node) + ;; determine which vertex is attached to the blossom's parent + (sync-rpc (make-message-blossom-parent + :stop-before (process-public-address node)) + (root-node (blossom-edge-source-vertex (blossom-node-parent node))) + (finalize matched-node root-node))) + (t + (finalize matched-node matched-node)))))) + +(define-process-upkeep ((node blossom-node) now) (EXPAND-BLOSSOM-BUILD-TREE-PATH path index) + "This command walks the path from `root-node'->`matched-node', establishing all the parent and child relationships and setting `positive?' accordingly. The parent/child relationship between the blossom's parent and `root-node' is established separatedly in `EXPAND-BLOSSOM-ATTACH-PARENT'. The parent/child relationship between the blossom's match and `matched-node', as well as the `positive?' setting of `matched-node', is implemented separately in the `EXPAND-BLOSSOM-ATTACH-MATCH' command. + + root root + | | + b0 (NIL) b0 + / \ / \ + / \ v \ + b1 b4 (T) b1 b4 + | | | | + | B | becomes | B | + | | v | + b2---b3 (NIL) b2---b3 + // // + // // + a a + +In the above example, `path' would be (`b0-->b1', `b1-->b2'), and so we build the parent/child relationships `b0-->b1' and `b1-->b2', and we set `positive?' of (b0, b1, b2) to be (NIL, T, NIL)." + (unless (endp path) + (let ((edge (pop path))) + (process-continuation node `(EXPAND-BLOSSOM-BUILD-TREE-PATH ,path ,(1+ index))) + ;; source `positive?' should be NIL, bc it's the parent of its match + (sync-rpc (make-message-set :slots (if (evenp index) + '(children positive?) + '(children)) + :values (if (evenp index) + `((,(copy-blossom-edge edge)) + ,nil) + `((,(copy-blossom-edge edge))))) + (set-result (blossom-edge-source-node edge)) + ;; target `positive?' should be T, bc it's the child of its match + (sync-rpc (make-message-set :slots (if (evenp index) + '(parent positive?) + '(parent)) + :values (if (evenp index) + `(,(reverse-blossom-edge edge) + ,t) + `(,(reverse-blossom-edge edge)))) + (set-result (blossom-edge-target-node edge)) + nil))))) + +(define-process-upkeep ((node blossom-node) now) (EXPAND-BLOSSOM-ADD-CYCLE-MATCHES full-path) + "This command detaches all of the blossom children from their `pistil' (except for the `matched-node', which is handled separately in the command `EXPAND-BLOSSOM-ATTACH-MATCH'). In addition, it establishes all the `match-edge' relationships in the cycle, both in the alternating tree and for lone barbells. + + root root + | | + b0 b0 + / \ // + / \ // + b1 b4 b1 b4 + | | || + | B | becomes || + | | || + b2---b3 b2 b3 + // // + // // + a a + +In the above example, `full-path' would originally be (`b2-->b3', `b3-->b4', `b4-->b0', `b0-->b1', `b1-->b2'), but the first entry is trimmed in the calling command, and then we drop two more every iteration, so the edges that are actually considered in this command are `b3-->b4' and `b0-->b1', which are exactly the edges that should be matched. Additionally, that list of edges contains all the vertices that do not participate in the `a==>b2' matched edge, so we are confident that everybody is ridden of their blossom parent." + ;; NOTE: This command also handles incrementing the `internal-weight's of all + ;; the blossom's children by the blossom's `internal-weight'. However, + ;; this functionality has not been thoroughly tested. + + ;; we jump two edges each time, because a single node can't have two matches + (loop :for edge :in full-path :by #'cddr + :for source-rx := (register) + :for target-rx := (register) + ;; drop `pistil' and establish `match-edge' + :do (send-message (blossom-edge-source-node edge) + (make-message-set :reply-channel source-rx + :slots '(pistil match-edge positive?) + :values `(,nil ,(copy-blossom-edge edge) ,t))) + (send-message (blossom-edge-target-node edge) + (make-message-set :reply-channel target-rx + :slots '(pistil match-edge positive?) + :values `(,nil ,(reverse-blossom-edge edge) ,t))) + :nconc (list source-rx target-rx) :into rx-channels + :finally (with-replies (replies) rx-channels + nil))) + +(define-process-upkeep ((node blossom-node) now) (EXPAND-BLOSSOM-ATTACH-PARENT root-node) + "This command takes the blossom's parent relationship and pushes it onto the petal node that is the source vertex of the relationship. This should be performed whenever the blossom has a parent, even if `root-node' is equal to `matched-node'. + +Here are two example configurations: + + r ---> [b0 ] r ---> [b0 ] ===> a + [| \ ] [| \ ] + [| \ ] [| \ ] + [| b1] <--- blossom B ---> [| b1] + [| / ] [| / ] + [| / ] [| / ] + a <=== [b2 ] [b2 ] + +left diagram: right diagram: + `parent-edge' is `B:b0--->r' `parent-edge' is `B:b0--->r' + `root-node' is b0 `root-node' is b0 + `matched-node' is b2 `matched-node' is b0 + +Note that in the right diagram, b0 is both the `root-node' and the `matched-node', because it is the vertex attached to both r and a." + (when (blossom-node-parent node) + (let ((parent-edge (copy-blossom-edge (blossom-node-parent node)))) + ;; here, we set the source-node of `parent-edge' to equal `root-node' + ;; which in our above example is b0. thus, `parent-edge' is now `b0--->r' + (setf (blossom-edge-source-node parent-edge) root-node) + ;; then, we tell b0 that `parent-edge' should be its parent + (sync-rpc (make-message-set :slots '(parent positive?) + :values `(,parent-edge ,nil)) + (set-result root-node) + ;; then, we tell r to replace it child relationship `r-->b0:B' + ;; with the relationship `r--->b0' via `message-replace-child' + (sync-rpc (make-message-replace-child + :old-child (process-public-address node) + :new-child root-node) + (replace-result (blossom-edge-target-node parent-edge)) + nil))))) + +(define-process-upkeep ((node blossom-node) now) (EXPAND-BLOSSOM-ATTACH-MATCH matched-node root-node) + "This command takes the blossom's match relationship and pushes it onto the petal vertex that is the source vertex of the relationship. + + r ---> [b0 ] r ---> [b0 ] ===> a + [| \ ] [| \ ] + [| \ ] [| \ ] + [| b1] <--- blossom B ---> [| b1] + [| / ] [| / ] + [| / ] [| / ] + a <=== [b2 ] [b2 ] + +left diagram: right diagram: + `edge' is `B:b2===>a' `edge' is `B:b0===>a' + `root-node' is b0 `root-node' is b0 + `matched-node' is b2 `matched-node' is b0 + +In the right diagram, b0 is both the `root-node' and the `matched-node', because it is the vertex attached to both r and a. For the follow-on comments below, we will use the left diagram labels." + (let* ((edge (copy-blossom-edge (blossom-node-match-edge node))) + (rx-channels nil)) + ;; here we change `edge' from `B:b2===>a' to `b2===>a' + (setf (blossom-edge-source-node edge) matched-node) + ;; then, we tell b2 that its new `match-edge' is `edge', that it has no + ;; `pistil' anymore, and that it is a negative/odd/inner node + (push (send-message matched-node + (make-message-set + :reply-channel (register) + :slots '(match-edge pistil positive?) + :values `(,(copy-blossom-edge edge) + ,nil + ,(or (not (blossom-node-parent node)) + (and + (address= matched-node root-node) + (address= (blossom-edge-target-node (blossom-node-parent node)) + (blossom-edge-target-node edge))))))) + rx-channels) + ;; then, we tell a that its `match-edge' is `edge' in reverse + (push (send-message (blossom-edge-target-node edge) + (make-message-set :reply-channel (register) + :slots '(match-edge) + :values `(,(reverse-blossom-edge edge)))) + rx-channels) + ;; if B has no children, we're done + (when (blossom-node-children node) + ;; then, if B has a child (in our picture this is true: it's a) + ;; we tell b2 that it needs the child relationship `b2--->a' + (push (send-message matched-node + (make-message-set :reply-channel (register) + :slots '(children) + :values `((,(copy-blossom-edge edge))))) + rx-channels) + ;; finally, we tell a that `a--->b2' should be its parent + (push (send-message (blossom-edge-target-node edge) + (make-message-set :reply-channel (register) + :slots '(parent) + :values `(,(reverse-blossom-edge edge)))) + rx-channels)) + ;; await replies + (with-replies (replies) rx-channels + nil))) + +(define-process-upkeep ((node blossom-node) now) (EXTINGUISH-BLOSSOM reply-channel) + "Tell this blossom process to die." + ;; NOTE: There's no data frame to pop. + (when reply-channel + (send-message reply-channel (make-message-rpc-done))) + (setf (blossom-node-wilting node) t)) diff --git a/src/operations/graft.lisp b/src/operations/graft.lisp new file mode 100644 index 0000000..e265953 --- /dev/null +++ b/src/operations/graft.lisp @@ -0,0 +1,107 @@ +;;;; operations/graft.lisp +;;;; +;;;; If a tree has a weightless edge which targets a matched pair which does not +;;;; participate in any tree, then this matched pair can be subsumed into the +;;;; tree as a child (and petal-child). For example, if the unmatched node A +;;;; (thought of as a tree with only one node) has a weightless edge to B, and +;;;; B is already matched to C but otherwise is not currently participating in +;;;; the blossom algorithm +;;;; +;;;; A ~~0~~ B === C +;;;; +;;;; then A's tree can be extended as in +;;;; +;;;; A --0-> B ==> C . +;;;; +;;;; It's important to note that a barbell can be grafted onto a bare vertex, +;;;; which would make the bare vertex the root of a new alternating tree, but +;;;; it can also be grafted further down an existing alternating tree, at any +;;;; positive/outer/even node. For example, +;;;; +;;;; A --> B ==> C ~~~ D === E becomes A --> B ==> C --> D ==> E . + +(in-package #:anatevka) + +;;; +;;; supervisor command definitions +;;; + +(define-process-upkeep ((supervisor supervisor) now) (START-GRAFT pong) + "Set up the checks for the graft procedure." + (with-slots (source-root edges) pong + ;; set up script + (let* (;; this is the directed edge that corresponds to the barbell + (neg-pos-edge (first edges)) + (negative-child (blossom-edge-source-node neg-pos-edge)) + (positive-child (blossom-edge-target-node neg-pos-edge)) + ;; this is the recommended edge, that will do the attaching + (parent-neg-edge (second edges)) + ;; the `source-root' is the root of the tree that recommended + ;; this action, which may or may not be equal to `graft-parent' + (targets (remove-duplicates + (list source-root negative-child positive-child) + :test #'address=))) + (process-continuation supervisor `(HALT)) + ;; check that there are three nodes and that they form a chain + (unless (and (= 3 (length targets)) + (address= negative-child + (blossom-edge-target-node parent-neg-edge))) + (setf (process-lockable-aborting? supervisor) t) + (finish-with-scheduling)) + (process-continuation supervisor + `(BROADCAST-LOCK ,targets) + `(CHECK-ROOTS (,source-root)) + `(BROADCAST-PINGABILITY ,targets :SOFT) + `(CHECK-PONG ,pong) + `(INNER-GRAFT ,pong) + `(BROADCAST-UNLOCK))))) + +(define-process-upkeep ((supervisor supervisor) now) (INNER-GRAFT pong) + "Actually perform the graft procedure." + (unless (process-lockable-aborting? supervisor) + (with-slots (source-root edges) pong + (let* (;; this is the directed edge that corresponds to the barbell + (neg-pos-edge (first edges)) + (pos-neg-edge (reverse-blossom-edge neg-pos-edge)) + (negative-child (blossom-edge-source-node neg-pos-edge)) + (positive-child (blossom-edge-target-node neg-pos-edge)) + ;; this is the recommended edge, that will do the attaching + (parent-neg-edge (second edges)) + (neg-parent-edge (reverse-blossom-edge parent-neg-edge)) + ;; this is the node that we want to attach our barbell to + (graft-parent (blossom-edge-source-node parent-neg-edge))) + (process-continuation supervisor + ;; the `negative-child's parent is the `graft-parent' + `(INSTALL-PARENT ,negative-child ,neg-parent-edge) + ;; the `positive-child's parent is the `negative-child' + `(INSTALL-PARENT ,positive-child ,pos-neg-edge) + ;; the `graft-parent's child is the `negative-child' + `(INSTALL-CHILD ,graft-parent ,parent-neg-edge) + ;; the `negative-child's child is the `positive-child' + `(INSTALL-CHILD ,negative-child ,neg-pos-edge) + `(INSTALL-POSITIVITY ,negative-child ,nil) + `(INSTALL-POSITIVITY ,positive-child ,t)))))) + +(define-process-upkeep ((supervisor supervisor) now) + (INSTALL-PARENT target edge) + "Sets a target's parent." + (unless (process-lockable-aborting? supervisor) + (sync-rpc (make-message-set :slots '(parent) :values `(,edge)) + (set-result target) + nil))) + +(define-process-upkeep ((supervisor supervisor) now) + (INSTALL-CHILD target edge) + "Appends a child to a target." + (unless (process-lockable-aborting? supervisor) + (sync-rpc (make-message-push :slot 'children :value edge) + (push-result target) + nil))) + +(define-process-upkeep ((supervisor supervisor) now) + (INSTALL-POSITIVITY target positive?) + "Sets a target's POSITIVE? field." + (unless (process-lockable-aborting? supervisor) + (sync-rpc (make-message-set :slots '(positive?) :values `(,positive?)) + (set-result target) + nil))) diff --git a/src/operations/multireweight.lisp b/src/operations/multireweight.lisp new file mode 100644 index 0000000..83469ee --- /dev/null +++ b/src/operations/multireweight.lisp @@ -0,0 +1,209 @@ +;;;; operations/multireweight.lisp +;;;; +;;;; It's possible for a pair (or more of trees to form where they each have a +;;;; nonpositive node of high weight and they each have a positive node sitting +;;;; on its boundary, so that they send each other mutual `HOLD' messages when +;;;; performing a `SCAN'. This leads to deadlock (GH-143), unless the mutually- +;;;; blocked trees coordinate to perform a simultaneous reweight. This is +;;;; implemented by the `MULTIREWEIGHT' procedure. +;;;; +;;;; Here's an example deadlocked forest configuration that requires a +;;;; simultaneous reweight to break: +;;;; +;;;; ^ +;;;; / \ +;;;; / \ +;;;; A E==F +;;;; /|\ ^ / +;;;; / v \|/ +;;;; C==B D +;;;; \ / +;;;; \ / +;;;; v +;;;; +;;;; We mean to indicate that the negative nodes E and B have weight d(E, B)/2, +;;;; which the positive nodes A, C, D, F are unweighted. Neither tree can +;;;; reweight individually: if A grows, then the edge A--E will become negative, +;;;; and similarly if D grows then the edge D--B will become negative. However, +;;;; if they coordinate, then A and D can acquire weight as B and E lose it. + +(in-package #:anatevka) + +(defun address-union (list1 list2) + "Helper function for computing the union of two `LIST's of `ADDRESS'es." + (union list1 list2 :test #'address=)) + +;;; +;;; supervisor data frame +;;; + +(defstruct data-frame-multireweight + "Data frame associated to a `SUPERVISOR' process enacting `MULTIREWEIGHT'. + +`HOLD-CLUSTER': The aggregated set of mutually held roots, for which deadlock can only be broken via `MULTIREWEIGHT'. + +`INTERNAL-PONG': The unified `message-pong' among the different roots in this `HOLD-CLUSTER', where all the roots in the cluster are treated as part of the same tree. Ultimately serves to measure the amount by which to `MULTIREWEIGHT'." + (hold-cluster nil :type list) + (internal-pong nil :type (or null message-pong))) + +;;; +;;; supervisor command definitions +;;; + +(define-process-upkeep ((supervisor supervisor) now) (START-MULTIREWEIGHT pong) + "Sets up the multireweight procedure. + +1. Collect the mutually held roots for the `HOLD-CLUSTER' +2. Lock the `HOLD-CLUSTER' and check the rootiness of each root. +3. Change the pingability of the cluster to `:SOFT'. +4. Scan the `HOLD-CLUSTER' for the best external rec to use for reweighting. +5. Reweight the `HOLD-CLUSTER' according to the recommendation. +6. Check to see if the `HOLD-CLUSTER' should be rewound, and do so if need be. +7. Unlock the targets and tear down transient state." + ;; NOTE: we couldn't call MAKE-PONG even if we wanted to, since we don't have + ;; access to the underlying node's Lisp object (or its type). + (push (make-data-frame-multireweight :internal-pong nil) + (process-data-stack supervisor)) + (with-slots (root-bucket source-root) pong + (setf root-bucket (remove-duplicates root-bucket :test #'address=)) + (process-continuation supervisor + `(CONVERGECAST-COLLECT-ROOTS ,(list source-root) ,root-bucket) + `(CHECK-PRIORITY ,source-root) + `(START-INNER-MULTIREWEIGHT) + `(FINISH-MULTIREWEIGHT) + `(HALT)))) + +(define-process-upkeep ((supervisor supervisor) now) + (CONVERGECAST-COLLECT-ROOTS cluster roots) + "Recursively collects the `HELD-BY-ROOTS' values of `ROOTS' to determine the set of roots that are participating in this `HOLD' cluster (meaning that they are mutually held by each other), starting with a base `CLUSTER' of just the `SOURCE-ROOT'. If any replies are NIL, we abort." + (with-slots (hold-cluster) (peek (process-data-stack supervisor)) + (flet ((payload-constructor () + (make-message-convergecast-collect-roots :hold-cluster cluster))) + (with-replies (replies :returned? returned?) + (send-message-batch #'payload-constructor roots) + (when (some #'null replies) + (log-entry :entry-type 'aborting-multireweight + :reason 'root-collection-failed + :hold-cluster cluster + :held-by-roots roots) + (setf (process-lockable-aborting? supervisor) t) + (finish-with-scheduling)) + (setf hold-cluster (reduce #'address-union (list* cluster replies))))))) + +(define-process-upkeep ((supervisor supervisor) now) (CHECK-PRIORITY original-root) + "Confirm that, of the roots in the hold cluster, we have priority to act. Namely, we have priority when our `ORIGINAL-ROOT' carries the minimum ID of all the roots in the cluster." + (with-slots (hold-cluster) (peek (process-data-stack supervisor)) + ;; don't bother _multi_reweighting if we're in a cluster of 1. + (when (endp (rest hold-cluster)) + (log-entry :entry-type 'aborting-multireweight + :reason 'cluster-of-one + :hold-cluster hold-cluster) + (setf (process-lockable-aborting? supervisor) t) + (finish-with-futures)) + (sync-rpc (make-message-id-query) + (original-id original-root) + (with-replies (replies) + (send-message-batch #'make-message-id-query hold-cluster) + (let ((cluster-id (reduce #'min-id replies))) + (unless (equalp original-id (min-id original-id cluster-id)) + (setf (process-lockable-aborting? supervisor) t))))))) + +(define-process-upkeep ((supervisor supervisor) now) (START-INNER-MULTIREWEIGHT) + "This is the start of the \"critical segment\", where it begins to be impossible to rewind partway through the modifications we're about to make." + (with-slots (hold-cluster) (peek (process-data-stack supervisor)) + (cond + ((not (process-lockable-aborting? supervisor)) + (process-continuation supervisor + `(BROADCAST-LOCK ,hold-cluster) + `(CHECK-ROOTS ,hold-cluster) + `(BROADCAST-PINGABILITY ,hold-cluster :SOFT) + `(MULTIREWEIGHT-BROADCAST-SCAN ,hold-cluster) + `(BROADCAST-PINGABILITY ,hold-cluster :NONE) + `(MULTIREWEIGHT-BROADCAST-REWEIGHT ,hold-cluster) + `(BROADCAST-PINGABILITY ,hold-cluster :SOFT) + `(MULTIREWEIGHT-CHECK-REWINDING ,hold-cluster) + `(BROADCAST-UNLOCK))) ; don't destroy trees + (t + (log-entry :entry-type 'aborting-multireweight + :reason 'previously-aborted + :hold-cluster hold-cluster) + nil)))) + +(define-process-upkeep ((supervisor supervisor) now) + (MULTIREWEIGHT-BROADCAST-SCAN roots) + "Now that we know the full `HOLD-CLUSTER', we `SCAN' each, and aggregate the results in order to make a reweighting decision." + (unless (process-lockable-aborting? supervisor) + (with-slots (internal-pong) (peek (process-data-stack supervisor)) + (flet ((payload-constructor () + (make-message-soft-scan :weight 0 :internal-roots roots :repeat? t))) + (with-replies (replies + :returned? returned? + :message-type message-pong + :message-unpacker identity) + (send-message-batch #'payload-constructor roots) + (loop :for reply :in replies :unless (null reply) + :do (assert (not (minusp (message-pong-weight reply)))) + (setf internal-pong + (unify-pongs internal-pong reply)))))))) + +(define-process-upkeep ((supervisor supervisor) now) + (MULTIREWEIGHT-BROADCAST-REWEIGHT roots) + "Having aggregated coordinated advice, we now enact it by sending individual reweight instructions to all the `ROOTS'. This is achieved via the `BROADCAST-REWEIGHT' command." + (unless (process-lockable-aborting? supervisor) + (with-slots (internal-pong) (peek (process-data-stack supervisor)) + (let ((amount (message-pong-weight internal-pong))) + (log-entry :entry-type 'multireweighting + :recommendation (message-pong-recommendation internal-pong) + :amount amount + :roots roots) + (process-continuation supervisor `(BROADCAST-REWEIGHT ,roots ,amount)))))) + +(define-process-upkeep ((supervisor supervisor) now) + (MULTIREWEIGHT-CHECK-REWINDING roots) + "Just as when we're reweighting, now we have to check to make sure we didn't create any negative-weight edges. We do so by pushing the `CHECK-REWINDING' command onto the command stack." + (unless (process-lockable-aborting? supervisor) + (with-slots (internal-pong) (peek (process-data-stack supervisor)) + (process-continuation supervisor `(CHECK-REWINDING ,roots ,internal-pong 0))))) + +(define-process-upkeep ((supervisor supervisor) now) (FINISH-MULTIREWEIGHT) + "Clean up after the local state of the multireweight operation." + (pop (process-data-stack supervisor))) + +;;; +;;; message definitions +;;; + +(defstruct (message-convergecast-collect-roots (:include message)) + "Sent from a `SUPERVISOR' to a tree to collect a cluster of roots that are mutually held by each other. The `HOLD-CLUSTER' is the current `LIST' of `BLOSSOM-NODE' roots that are known to be mutually held up." + (hold-cluster nil :type list)) + +;;; +;;; message handlers +;;; + + +(define-convergecast-handler handle-message-convergecast-collect-roots + ((node blossom-node) (message message-convergecast-collect-roots) now) + "Check to see if we're held. If not, `RETURN-FROM-CAST' and send back up a NIL. If we are held, add ourselves to the `HOLD-CLUSTER'. Additionally, if we are held by `NEW-ROOTS' that aren't currently in the cluster, forward this message along to them to continue gathering roots. Finally, send the aggregated cluster back to the sender." + (with-slots (hold-cluster reply-channel) message + ;; If we're not held, abort the convergecast. + (when (endp (blossom-node-held-by-roots node)) + (return-from-cast nil 'root-not-held)) + ;; Otherwise, see if we've grown the cluster and/or encountered new roots. + (with-slots (held-by-roots) node + (let* ((new-cluster (list* (process-public-address node) hold-cluster)) + (new-roots (set-difference held-by-roots new-cluster :test #'address=))) + ;; If any reply is NIL or triggers a `RETURNED?' we want to abort the + ;; whole operation, which we accomplish by sending back a NIL. + (flet ((null-address-union (input replies) + (when (some #'null replies) + (return-from null-address-union nil)) + (reduce #'address-union (list* input replies)))) + ;; If we are held by `NEW-ROOTS', this will forward the convergecast + ;; along to them, aggregating results into `HOLD-CLUSTER'. Otherwise, + ;; if `NEW-ROOTS' is NIL it will just send back the `NEW-CLUSTER'. + (setf hold-cluster new-cluster) + (push-convergecast-frame :handle-rts? t + :func #'null-address-union + :input new-cluster + :targets new-roots)))))) diff --git a/src/operations/reweight.lisp b/src/operations/reweight.lisp new file mode 100644 index 0000000..75ee0d1 --- /dev/null +++ b/src/operations/reweight.lisp @@ -0,0 +1,217 @@ +;;;; operations/reweight.lisp +;;;; +;;;; If no weightless edge is available, then a blossom tree will modify its +;;;; internal weights so as to produce one. One thinks of the internal weight +;;;; assigned to a (positive) node as a kind of "scanning radius": starting with +;;;; the graph +;;;; +;;;; [A +0] --2-- [B +0] +;;;; +;;;; with two unweighted vertices separated by an edge of weight 2, B might +;;;; reweight by 2, depicted like +;;;; +;;;; ^^^^ +;;;; / \ +;;;; / \ +;;;; / \ +;;;; [A +0] --0-- < [B +2] > +;;;; \ / +;;;; \ / +;;;; \ / +;;;; vvvv +;;;; +;;;; so that A sits at the 'edge' of its newly enlarged radius and the edge +;;;; connecting them can be used to perform some other blossom tree operation. +;;;; +;;;; If the tree which is reweighting is more complex, the reweighting value is +;;;; applied by alternatingly increasing and decreasing the weight. For example, +;;;; if we begin with the tree +;;;; +;;;; ^^^^ ^^^^ +;;;; / \ / \ +;;;; / \ / \ +;;;; < [A +1] > --0--> < [B +1] > ==0==> [C +0] +;;;; \ / \ / +;;;; \ / \ / +;;;; vvvv vvvv +;;;; +;;;; and then reweight by 1, the effect is +;;;; +;;;; ^^^^ +;;;; / \ ^^^^ +;;;; / \ / \ +;;;; / \ / \ +;;;; < [A +2] > --0--> [B +0] ==0==> < [C +1] > +;;;; \ / \ / +;;;; \ / \ / +;;;; \ / vvvv +;;;; vvvv +;;;; +;;;; Critically, the reweighting operation changes the weights of those edges +;;;; _external_ to the tree, but all of the edges _internal_ to the tree remain +;;;; weightless because of the alternation. + +(in-package #:anatevka) + +;;; +;;; supervisor command definitions +;;; + +(define-process-upkeep ((supervisor supervisor) now) (START-REWEIGHT pong) + "Sets up the reweight procedure. + +1. Lock the targets. +2. Change their pingability to `:SOFT'. +3. Check for a weightless edge. Abort if found. +4. Change the pingability of the targets to `:NONE'. +5. Reweight the `source-root' by the `weight' of the `pong'. +6. Change the pingability of the targets to `:SOFT'. +7. Check if reweighting the `source-root' resulted in a negative-weight edge. + a. If so, and this is the second time we've been here, rewind fully. + b. Otherwise, if so, rewind the reweighting by half and go back to (7). +8. Unlock the targets. +" + (with-slots (source-root target-root weight) pong + ;; the contents of `targets' depend on the recommendation. it always + ;; includes the `source-root', and additionally + ;; - `AUGMENT': the `target-root' + ;; - `GRAFT': the barbell + ;; - `EXPAND' or `CONTRACT': nothing + (let ((targets (remove-duplicates (list source-root target-root) + :test #'address=))) + (process-continuation supervisor + `(BROADCAST-LOCK ,targets) + `(CHECK-ROOTS (,source-root)) + `(BROADCAST-PINGABILITY ,targets :SOFT) + `(CHECK-REWEIGHT ,pong) + ;; it bugs me a bit having to switch this back & forth + `(BROADCAST-PINGABILITY ,targets :NONE) + `(BROADCAST-REWEIGHT (,source-root) ,weight) + `(BROADCAST-PINGABILITY ,targets :SOFT) + `(CHECK-REWINDING (,source-root) ,pong 0) + `(BROADCAST-UNLOCK) + `(HALT))))) + +(define-process-upkeep ((supervisor supervisor) now) (CHECK-REWEIGHT pong) + "Because `CHECK-PONG' doesn't do a global check, we potentially can end up with a reweighting when we shouldn't. This fixes that by making sure that there are no lower-weight recommendations available before we begin reweighting." + (unless (process-lockable-aborting? supervisor) + (with-slots (source-root weight) pong + (let ((listen-channel (register))) + (send-message source-root (make-message-soft-scan + :reply-channel listen-channel + :local-root source-root + :weight 0 + :repeat? t)) + (sync-receive (listen-channel pong-message) + (message-pong + (unregister listen-channel) + (when (< (message-pong-weight pong-message) weight) + (setf (process-lockable-aborting? supervisor) t)))))))) + +(define-process-upkeep ((supervisor supervisor) now) + (BROADCAST-REWEIGHT roots weight) + "Instruct some `ROOTS' to reweight their trees by `WEIGHT'." + (unless (process-lockable-aborting? supervisor) + (flet ((payload-constructor () + (make-message-broadcast-reweight :weight weight))) + (with-replies (replies) (send-message-batch #'payload-constructor roots) + nil)))) + +(define-process-upkeep ((supervisor supervisor) now) + (CHECK-REWINDING roots original-pong carry) + "Instruct a set of `ROOTS' to ensure that their reweighting has not resulted in an erroneous global state. If they have, then we want to rewind the reweighting, by using the `BROADCAST-REWEIGHT' command." + (unless (process-lockable-aborting? supervisor) + ;; NOTE: we couldn't call MAKE-PONG even if we wanted to, since we don't + ;; have access to the underlying node's Lisp object (or its type). + (let ((rewinding-pong nil) + (original-amount (message-pong-weight original-pong))) + (flet ((payload-constructor () + (make-message-soft-scan :weight 0 :repeat? t))) + (with-replies (replies + :returned? returned? + :message-type message-pong + :message-unpacker identity) + (send-message-batch #'payload-constructor roots) + (loop :for reply :in replies :unless (null reply) + :do (setf rewinding-pong (unify-pongs rewinding-pong reply))) + ;; The `maximum-rewinding' variable tracks how much is left to + ;; potentially rewind from the initial recommendation reweighting. + (let ((maximum-rewinding (- original-amount carry)) + (minimum-weight-edge (message-pong-weight rewinding-pong))) + (log-entry :entry-type 'check-rewinding-details + :original-amount original-amount + :carry carry + :minimum-weight-edge minimum-weight-edge + :rewinding-pong rewinding-pong) + (when (minusp minimum-weight-edge) + ;; When we encounter a negative-weight edge, this means that + ;; our reweighting operation happened at the same time as another + ;; nearby reweighting operation. We could fully backtrack and + ;; deweight by the original recommendation, but this can result + ;; in livelock scenarios when the state of the problem graph is + ;; sufficiently symmetric. Fortunately, the `minimum-weight-edge' + ;; value that we get back from our soft-scan check gives us some + ;; useful information -- it is bounded above by the value of the + ;; smallest simultaneous reweight in the local area. If we instead + ;; backtrack by half that amount, we allow nearby alternating trees + ;; to grow heavier (and thus closer to one another), while still + ;; maintaining the validity of nearby modified edge weights, + ;; thus breaking the symmetries of the problem graph and avoiding + ;; livelock induced by repeated reweighting and rewinding. + ;; However, we don't want to halve indefinitely, so we only do + ;; that for the first round of rewinding. + (let ((rewinding-amount minimum-weight-edge)) + ;; If it is our first try, attempt to compromise with a nearby + ;; simultaneous reweighter by using half the overlap weight. + (when (zerop carry) + (setf rewinding-amount (/ rewinding-amount 2))) + (let ((new-carry (- carry rewinding-amount))) + (log-entry :entry-type 'rewinding + :roots roots + :amount rewinding-amount + :overall new-carry + :recommendation original-amount) + ;; If the rewinding amount is such that we are not fully + ;; backtracking, check ourselves again and respond accordingly. + (when (< (- rewinding-amount) maximum-rewinding) + (process-continuation supervisor + `(BROADCAST-PINGABILITY ,roots :SOFT) + `(CHECK-REWINDING ,roots ,original-pong ,new-carry))) + ;; If we get a rewinding of larger magnitude than the initial + ;; recommendation, then we should not do that. In fact, the + ;; cumulative rewinding should be carried from rewinding to + ;; rewinding so that it doesn't cause problems. + (when (> (- rewinding-amount) maximum-rewinding) + (setf rewinding-amount (- maximum-rewinding))) + ;; Finally, add the commands for actually doing the rewind. + (process-continuation supervisor + `(BROADCAST-PINGABILITY ,roots :NONE) + `(BROADCAST-REWEIGHT ,roots ,rewinding-amount))))))))))) + +;;; +;;; message definitions +;;; + +(defstruct (message-broadcast-reweight (:include message)) + "Sent from a `SUPERVISOR' to a tree to reweight its top-level nodes by `WEIGHT'." + (weight nil :type real)) + +;;; +;;; message handlers +;;; + +(define-broadcast-handler handle-message-broadcast-reweight + ((node blossom-node) (message message-broadcast-reweight) now) + "Increments the `INTERNAL-WEIGHT' of `NODE' by the `WEIGHT' of the `MESSAGE', and then instructs `NODE's children to reweight themselves by the additive inverse of `WEIGHT'." + (with-slots (weight) message + (with-slots (internal-weight) node + (incf internal-weight weight) + (log-entry :entry-type 'reweight-details + :amount weight + :new-internal-weight internal-weight) + (when (minusp internal-weight) + (log-entry :entry-type 'negative-internal-weight + :internal-weight internal-weight)) + (setf weight (- weight)) + (push-broadcast-frame :targets (mapcar #'blossom-edge-target-node + (blossom-node-children node)))))) diff --git a/src/operations/scan.lisp b/src/operations/scan.lisp new file mode 100644 index 0000000..823e4f6 --- /dev/null +++ b/src/operations/scan.lisp @@ -0,0 +1,559 @@ +;;;; operations/scan.lisp +;;;; +;;;; Commands related to scanning. +;;;; +;;;; a SCAN is the procedure internal to a blossom tree which queries its +;;;; children and its neighbors in order to calculate a suggested 'next step' +;;;; for the blossom algorithm. a legal 'next step' is required to have a +;;;; 'minimality' property in the following senses: +;;;; +;;;; (1) each proposed operation on the tree corresponds to an edge in the graph. +;;;; (2) an operation which modifies the structure of a tree can only be +;;;; performed along an edge whose 'adjusted weight' is zero. +;;;; (3) a tree can also change its 'internal weights', which has the effect of +;;;; (properly) decreasing the adjusted weights of all edges that might +;;;; propose operations. +;;;; (4) it is illegal (and signals a failure of correctness of the algorithm) +;;;; for a proposing edge to have negative adjusted weight. +;;;; +;;;; taking these in concert, the goal of SCAN is to walk over all participating +;;;; edges, extract from them their proposed operations, and discern which +;;;; proposal minimally adjusts the internal weights, so as not to violate (4). +;;;; +;;;; to adhere to locality properties, this calculation is spread out over the +;;;; tree: each node forwards SCAN directives to its children and sends PINGs +;;;; out to its own neighbors, aggregating the replies by retaining the proposal +;;;; which minimally adjusts the internal weights. + +(in-package #:anatevka) + +;;; +;;; message definitions +;;; + +(defstruct (message-ping (:include message)) + "Broadcast from one vertex to another, to probe its weight and its position in its tree. Expects as a reply a PONG message. Includes as part of its payload some information about the tree structure at the originator, so that the receiver can generate an appropriate recommendation." + (root nil :type (or null address)) + (blossom nil :type (or null address)) + (id nil :type t) + (weight nil :type real) + (internal-roots nil :type list)) + +(defstruct (message-soft-ping (:include message-ping)) + "The same as a PING, but with the signaled intent that it _will not_ be used to advocate for a fresh tree operation, only to check the consistency of the state.") + +(defstruct (message-pong (:include message)) + "A reply to a PING message, which contains the adjusted edge weight and its proposed tree operation. + +Most of the slots are self-explanatory. As an exception, ROOT-BUCKET aggregates values of TARGET-ROOT when two PONGs are merged by UNIFY-PONG." + (weight 0 :type real) + (edges nil :type list) + (source-root nil :type (or null address)) + (target-root nil :type (or null address)) + (recommendation ':pass :type keyword) + (source-id nil :type t) + (root-bucket nil :type list)) + +(defstruct (message-adjoin-root (:include message)) + "A capsule used to move a PING around inside its target tree, which is done in order to accrue information (viz., the target blossom, root, and blossom weight) used to construct the reply PONG." + (match-edge nil :type (or null blossom-edge)) + (ping nil :type message-ping) + (pong nil :type message-pong) + (positive? nil :type boolean)) + +(defstruct (message-soft-adjoin-root (:include message-adjoin-root)) + "The same as an ADJOIN-ROOT, but with the signaled intent that it _will not_ be used to advocate for a fresh tree operation, only to check the consistency of the state.") + +(defstruct (message-scan (:include message)) + "Broadcast internally to a tree, like activation down a the length of a neuron, to spur its vertices to send out PING messages to their neighbors." + (local-root nil :type (or null address)) + (local-blossom nil :type (or null address)) + (weight nil :type real) + (internal-roots nil :type list) + (repeat? nil :type boolean)) + +(defstruct (message-soft-scan (:include message-scan)) + "The same as a SCAN, but it generates soft PINGs.") + +(defmethod print-object ((pong message-pong) stream) + "Convenience printing for PONGs." + (print-unreadable-object (pong stream :type t :identity nil) + (format stream "@~a " (message-reply-channel pong)) + (format stream "RECOMMENDATION=~a " (message-pong-recommendation pong)) + (format stream "WEIGHT=~a " (message-pong-weight pong)) + (format stream "EDGES=~a " (message-pong-edges pong)) + (format stream "SOURCE-ID=~a " (message-pong-source-id pong)) + (format stream "SOURCE-ROOT=~a " (message-pong-source-root pong)) + (format stream "TARGET-ROOT=~a " (message-pong-target-root pong)) + (format stream "ROOT-BUCKET=~a " (message-pong-root-bucket pong)) + (format stream "~a" (aether::message-message-id pong)))) + +;;; +;;; message operations +;;; + +(defmethod make-pong ((node blossom-node) &rest initargs) + "Wrapper for generating a pong message of the appropriate type for `NODE'." + (apply #'make-message-pong initargs)) + +(defmethod make-supervisor ((node blossom-node) &rest initargs) + "Wrapper for generating a supervisor of the appropriate type for `NODE'." + (apply #'spawn-process 'supervisor initargs)) + +(defmethod unify-pongs (x (y message-pong) &key internal-root-set) + "Given two PONGs proposing two operations, selects the more immediate of the two. + +Returns a VALUES pair of the unified PONG message as well as a boolean indicating whether the default clause was triggered, for other method handlers to decide whether a preceding handler has made a decision that they are then overriding, or if there's no danger of overriding an intentional decision. + +When INTERNAL-ROOT-SET is supplied, discard HOLD recommendations which emanate from the indicated root addresses." + ;; IMPORTANT NOTE: Textbook descriptions of the forest version of the blossom + ;; algorithm may give the impression that _all_ operations proposed by + ;; nonpositive nodes should be ignored, including those in foreign trees. + ;; This is not so: the reweighting operation must consider all foreign + ;; nodes, regardless of their positivity. + (check-type internal-root-set list) + (when (null x) + (return-from unify-pongs + y)) + (with-slots ((x-rec recommendation) (x-weight weight) (x-root target-root)) x + (with-slots ((y-rec recommendation) (y-weight weight) (y-root target-root)) y + (cond + ;; drop `PASS'es + ((eql ':pass x-rec) + y) + ((eql ':pass y-rec) + x) + ;; drop internal `HOLD's + ((and (eql ':hold x-rec) + (member x-root internal-root-set :test #'address=)) + y) + ((and (eql ':hold y-rec) + (member y-root internal-root-set :test #'address=)) + x) + ;; prefer non-zero `AUGMENT's (which become `REWEIGHT's) to other + ;; equal-weight recommendations to avoid rewinding livelock scenarios + ((and (eql ':augment x-rec) + (not (zerop x-weight)) + (eql x-weight y-weight)) + x) + ((and (eql ':augment y-rec) + (not (zerop y-weight)) + (eql x-weight y-weight)) + y) + ;; if we're both (`HOLD' 0)ing, aggregate the target root set + ((and (eql ':hold x-rec) (zerop x-weight) + (eql ':hold y-rec) (zerop y-weight)) + (initialize-and-return ((pong (copy-message-pong x))) + (setf (message-pong-root-bucket pong) + (remove-duplicates (union (message-pong-root-bucket x) + (message-pong-root-bucket y)) + :test #'address=)))) + ;; (`HOLD' 0) is an expensive operation: either we idle or we have to + ;; coordinate across multiple trees. prefer easier actions. + ((and (eql ':hold x-rec) + (zerop x-weight) (zerop y-weight)) + y) + ((and (eql ':hold y-rec) + (zerop x-weight) (zerop y-weight)) + x) + ;; finally, prefer lighter pongs to heavier ones + ((< x-weight y-weight) + (values x t)) + (t + (values y t)))))) + +(defun pong= (stale-pong replica-pong) + "Checks whether two PONGs recommend the same operation." + (and (every (lambda (fs) + (destructuring-bind (f g) fs + (funcall f + (funcall g stale-pong) + (funcall g replica-pong)))) + `((,#'eql ,#'message-pong-recommendation) + (,#'= ,#'message-pong-weight) + (,#'eql ,(a:compose #'aether::address-channel #'message-pong-source-root)) + (,#'eql ,(a:compose #'aether::address-channel #'message-pong-target-root)) + (,#'= ,(a:compose #'length #'message-pong-edges)))) + (loop :for stale-edge :in (message-pong-edges stale-pong) + :for replica-edge :in (message-pong-edges replica-pong) + :always (every (lambda (fs) + (destructuring-bind (f g) fs + (funcall f + (funcall g stale-edge) + (funcall g replica-edge)))) + `((,#'eql ,(a:compose #'aether::address-channel #'blossom-edge-source-vertex)) + (,#'eql ,(a:compose #'aether::address-channel #'blossom-edge-target-vertex)) + (,#'eql ,(a:compose #'aether::address-channel #'blossom-edge-source-node)) + (,#'eql ,(a:compose #'aether::address-channel #'blossom-edge-target-node))))))) + +;;; +;;; blossom-node data frame +;;; + +(defstruct data-frame-scan + "Data frame associated to a SCAN procedure running on a BLOSSOM process." + (pong nil :type message-pong) + (soft? nil :type boolean) + (local-root nil :type address) + (local-blossom nil :type address) + (local-weight nil :type (or null real)) + (vertices nil :type list) + (children nil :type list) + (petals nil :type list) + (weight nil :type real) + (internal-roots nil :type list) + (repeat? nil :type boolean)) + +;;; +;;; blossom-node command definitions +;;; + +(define-process-upkeep ((node blossom-node) now) (START-SCAN scan-message) + "Sets up the scanning procedure stack frames." + ;; if the node is wilting, we don't want it to start a scan, because it's + ;; going to reach out to the dryad to get a list of addresses to ping, but + ;; the dryad will have already excised this node from its lookup table + (when (blossom-node-wilting node) + ;; but, if this scan was initiated by someone other than this node, + ;; we don't want them to sit around waiting forever, so let them know + (a:when-let ((reply-channel (message-reply-channel scan-message))) + ;; we can't use FINISH-SCAN without setting up the data frame, + ;; so we elect to send the message directly from START-SCAN + (send-message reply-channel (make-pong node))) + (finish-with-scheduling)) + ;; load data frame + (let* ((local-root (or (slot-value scan-message 'local-root) + (process-public-address node))) + (local-blossom (if (and (blossom-node-pistil node) + (slot-value scan-message 'local-blossom)) + (slot-value scan-message 'local-blossom) + (process-public-address node))) + (soft? (typep scan-message 'message-soft-scan)) + (weight (if (blossom-node-pistil node) + (- (slot-value scan-message 'weight) + (blossom-node-internal-weight node)) + (- (blossom-node-internal-weight node)))) + ;; if we're a negative topmost blossom node, then we initialize the + ;; pong with an EXPAND recommendation, as this is the only operation + ;; that we can sponsor. + (pong (if (and (null (blossom-node-pistil node)) + (not (blossom-node-positive? node)) + (blossom-node-petals node)) + (make-pong node :recommendation ':expand + :weight (blossom-node-internal-weight node) + :edges (list (make-blossom-edge + :source-node local-blossom + :source-vertex (process-public-address node))) + :source-root local-root + :target-root local-root) + (make-pong node :target-root local-root))) + ;; if we're a positive node, then we should forward the scan to both + ;; our tree children and our blossom children (petals). if we're a + ;; negative node, we forward just to our tree children. + (forwarding-addresses (mapcar #'blossom-edge-target-node + (if (blossom-node-positive? node) + (union (blossom-node-petals node) + (blossom-node-children node)) + (blossom-node-children node)))) + (internal-roots (or (message-scan-internal-roots scan-message) + (list local-root))) + (repeat? (slot-value scan-message 'repeat?))) + (log-entry :entry-type 'starting-scan + :deweight weight) + (push (make-data-frame-scan :local-root local-root + :local-blossom local-blossom + :weight weight + :pong pong + :soft? soft? + :internal-roots internal-roots + :repeat? repeat?) + (process-data-stack node)) + ;; load (most of) script + (process-continuation node + `(CONTACT-DRYAD) + `(FORWARD-SCAN ,forwarding-addresses) + `(FINISH-SCAN ,(message-reply-channel scan-message))))) + +(define-process-upkeep ((node blossom-node) now) (CONTACT-DRYAD) + "Request from the dryad responsible for this node a list of candidate node neighbors with which to coordinate for this node's next operation. Defers the actual processing of that list to PROCESS-ADDRESSES." + (unless (or (blossom-node-petals node) + (not (blossom-node-positive? node))) + (with-slots (weight repeat?) (peek (process-data-stack node)) + (sync-rpc (make-message-discover + :id (blossom-node-id node) + :address (process-public-address node) + ;; negated bc `weight' is negated above in `START-SCAN' let block + :internal-weight (- weight) + :repeat? repeat?) + (discovery-message (blossom-node-dryad node) + :message-type message-discovery :message-unpacker identity + :returned? returned?) + (cond + ((and returned? (blossom-node-wilting node)) + nil) + (returned? + (error "Live node got an RTS during dryad communication.")) + (t + (process-continuation node `(PROCESS-ADDRESSES ,discovery-message)))))))) + +(define-process-upkeep ((node blossom-node) now) (PROCESS-ADDRESSES discovery-message) + "Performs postprocessing, if any, on the list of candidate neighbor nodes received from the dryad, then sets up the PING command to start communicating with them." + (with-slots (channels-to-try) discovery-message + (process-continuation node `(PING ,channels-to-try)))) + +(define-process-upkeep ((node blossom-node) now) (FORWARD-SCAN addresses) + "Sends a SCAN message to each of the children tabulated in ADDRESSES." + (with-slots (local-root local-blossom weight pong soft? internal-roots repeat?) + (peek (process-data-stack node)) + (unless (blossom-node-wilting node) + (flet ((payload-constructor () + (cond + (soft? + (make-message-soft-scan + :local-root local-root + :local-blossom local-blossom + :weight weight + :internal-roots internal-roots + :repeat? repeat?)) + (t + (make-message-scan + :local-root local-root + :local-blossom local-blossom + :weight weight + :internal-roots internal-roots + :repeat? repeat?))))) + (with-replies (replies + :returned? returned? + :message-type message-pong + :message-unpacker identity) + (send-message-batch #'payload-constructor addresses) + (loop :for reply :in replies + :unless (null reply) + :do (setf pong (unify-pongs pong reply :internal-root-set internal-roots)))))))) + +(define-process-upkeep ((node blossom-node) now) (PING vertices) + "Sends a PING message to any neighboring vertices as previously provided by the DISCOVER query sent to the dryad. + +NOTE: this command is only installed when NODE is a vertex." + (with-slots (local-root weight soft? pong local-blossom internal-roots) + (peek (process-data-stack node)) + (unless (blossom-node-wilting node) + (flet ((payload-constructor () + (cond + (soft? + (make-message-soft-ping + :root local-root + :blossom local-blossom + :weight weight + :id (blossom-node-id node) + :internal-roots internal-roots)) + (t + (make-message-ping + :root local-root + :blossom local-blossom + :weight weight + :id (blossom-node-id node) + :internal-roots internal-roots))))) + (with-replies (replies + :returned? returned? + :message-type message-pong + :message-unpacker identity) + (send-message-batch #'payload-constructor vertices) + (loop :for vertex :in vertices + :for reply :in replies + :unless (null reply) + :do (when (vertex? node) + (let ((edge (car (last (message-pong-edges reply))))) + (setf (blossom-edge-source-vertex edge) (process-public-address node) + (blossom-edge-source-node edge) local-blossom))) + (setf pong (unify-pongs reply pong :internal-root-set internal-roots)))))))) + +(define-process-upkeep ((node blossom-node) now) (FINISH-SCAN reply-channel) + "Finalize the SCAN procedure's stack frames. this includes forwarding the result to a parent if one instigated the SCAN procedure, or spawning a new SUPERVISOR process to handle the result if this SCAN was spontaneous." + (with-slots (pong) (pop (process-data-stack node)) + (with-slots (recommendation root-bucket) pong + (cond + (reply-channel + (log-entry :entry-type 'pong-throw) + (if (blossom-node-wilting node) + (send-message reply-channel (make-pong node)) + (send-message reply-channel pong))) + ((not (or + ;; if we're passing, no need to spawn a supervisor + (eql ':pass recommendation) + ;; If we're to `HOLD', and we're childless, spawning a supervisor + ;; will just be a waste of time, due to the fact that there is no + ;; way anyone else will be held up by us. + (and (eql ':hold recommendation) + (endp (blossom-node-children node))) + ;; we might have been interrupted and are no longer fit to suggest + ;; actions for anyone. + (blossom-node-wilting node) + (blossom-node-parent node) + (blossom-node-pistil node) + (blossom-node-match-edge node))) + ;; Pause ourselves, as we're about to spawn a supervisor. + ;; NB: It is the responsibility of the supervisor to unpause us. + (setf (blossom-node-paused? node) t) + + ;; If we're to `HOLD', set our `HELD-BY-ROOTS' slot to equal the + ;; root-bucket of the pong, so that the `MULTIREWEIGHT' operation + ;; can use it. + (setf (blossom-node-held-by-roots node) root-bucket) + + (when (eql 'SCAN-LOOP (first (first (process-command-stack node)))) + (setf (first (process-command-stack node)) + `(SCAN-LOOP nil))) + (let ((supervisor (make-supervisor node + :node-class (type-of node) + :debug? (process-debug? node)))) + (log-entry :entry-type 'spawn-supervisor + :pong pong + :address (process-public-address supervisor)) + (push pong (process-data-stack supervisor)) + (schedule supervisor now))) + (t + (when (eql 'SCAN-LOOP (first (first (process-command-stack node)))) + (setf (first (process-command-stack node)) + `(SCAN-LOOP t)))))))) + +;;; +;;; message handlers +;;; + +;;; in the SCAN / PING / ADJOIN-ROOT / PONG family of messages, the expected +;;; message propagation sequence is: +;;; (1) a tree sends SCAN commands down to all participating vertices. +;;; (2) each SCAN at a vertex generates PING commands out to all its neighboring +;;; vertices, including those in foreign trees. +;;; (3) each PING received is wrapped in an ADJOIN-ROOT, which forwards the PING +;;; up the receiving tree to its root. +;;; (4) the root generates a PONG in reply. +;;; (5) the PONGs are (associatively) aggregated up the originating tree. + +;;; NOTE: the current convention is that the SCAN is responsible for accumulating +;;; the weight adjustments on the source side, then the PING handler adds +;;; the actual edge weight, and the ADJOIN-ROOT handler accumulates the +;;; weight adjustments on the recipient side. i think this is the only sane +;;; arrangement for a source that is ignorant of the recipient's ID. + +(define-message-handler handle-message-ping + ((node blossom-node) (message message-ping) now) + "Begins the process of responding to a PING message: starts an ADJOIN-ROOT sequence." + (with-slots (weight id recipient-child reply-channel root) message + (let* ((total-weight (+ weight + (vertex-vertex-distance (blossom-node-id node) id))) + (edges (list (make-blossom-edge + :target-node nil + :target-vertex (process-public-address node)))) + (pong (make-pong node + :weight total-weight + :edges edges + :source-root root + :source-id id))) + (log-entry :entry-type 'handle-ping + :ping-type (type-of message) + :pingability (blossom-node-pingable node) + :vv-distance (vertex-vertex-distance (blossom-node-id node) id) + :old-weight weight + :new-weight total-weight) + (send-message (process-public-address node) + (funcall (if (typep message 'message-soft-ping) + #'make-message-soft-adjoin-root + #'make-message-adjoin-root) + :reply-channel reply-channel + :ping message + :pong pong))))) + +(define-message-handler handle-message-adjoin-root + ((node blossom-node) (message message-adjoin-root) now) + "The workhorse of responding to a PING message: walks up the blossom contractions, then up the maximally-contracted tree, ultimately resulting in a PONG. + +This handler is responsible for actually assigning a recommended-next-move for the blossom algorithm, which makes up the bulk of the function body." + (let* ((ping (message-adjoin-root-ping message)) + (pong (message-adjoin-root-pong message)) + (last-edge (first (message-pong-edges pong)))) + ;; if we haven't yet started crawling up parent instead of pistil... + (unless (blossom-edge-target-node last-edge) + ;; ... include these internal weights + (log-entry :entry-type 'DECF-WEIGHT + :old-value (message-pong-weight pong) + :delta (blossom-node-internal-weight node)) + (decf (message-pong-weight pong) + (blossom-node-internal-weight node))) + ;; if we haven't yet made it to toplevel... + (when (blossom-node-pistil node) + ;; ... keep throwing up pistil. + (send-message (blossom-node-pistil node) message) + (finish-with-scheduling)) + ;; otherwise, record the first toplevel node we see as our parent blossom. + ;; CRITICALLY, this does NOT prematurely return. + (unless (blossom-edge-target-node last-edge) + (setf (blossom-edge-target-node last-edge) (process-public-address node) + (message-adjoin-root-positive? message) (blossom-node-positive? node) + (message-adjoin-root-match-edge message) (blossom-node-match-edge node))) + ;; if there's more parents to climb through, do so. + (when (blossom-node-parent node) + (send-message (blossom-edge-target-node (blossom-node-parent node)) + message) + (finish-with-scheduling)) + ;; otherwise, we're at the root. + (let ((target-root (process-public-address node)) + (recommendation (recommend node ping pong message))) + (setf (message-pong-target-root pong) target-root + (message-pong-recommendation pong) recommendation) + (send-message (message-reply-channel message) pong)))) + +(defgeneric recommend (node ping pong adjoin-root) + (:documentation "Computes an action to propose as part of a PONG.") + (:method ((node blossom-node) ping pong adjoin-root) + (let ((last-edge (first (message-pong-edges pong))) + (source-root (message-pong-source-root pong)) + (target-root (process-public-address node)) + (internal-roots (message-ping-internal-roots ping)) + (match-edge (message-adjoin-root-match-edge adjoin-root))) + (cond + ((or (and match-edge + (address= (slot-value ping 'blossom) + (blossom-edge-target-node match-edge))) + (address= (slot-value ping 'blossom) + (blossom-edge-target-node last-edge))) + ':pass) + ((not (message-adjoin-root-positive? adjoin-root)) + (push target-root + (message-pong-root-bucket pong)) + ':hold) + ((and (not (address= target-root source-root)) + (blossom-node-match-edge node)) + (push (copy-blossom-edge (blossom-node-match-edge node)) + (message-pong-edges pong)) + ':graft) + ((not (address= target-root source-root)) + ;; When we're MULTIREWEIGHTING, an inter-tree AUGMENT should + ;; result in a reweighting of half the inter-tree distance. + ;; We do this here (rather than further down the line) so that + ;; it can stand on equal footing with other recommendations as + ;; it is being compared as part of the `unify-pongs' procedure. + ;; This is somewhat analogous to CONTRACT-BLOSSOM (see below). + (when (and internal-roots + (member source-root internal-roots :test #'address=) + (member target-root internal-roots :test #'address=)) + (setf (message-pong-weight pong) + (/ (message-pong-weight pong) 2))) + ':augment) + ((address= target-root source-root) + (setf (message-pong-weight pong) + (/ (message-pong-weight pong) 2)) + ':contract) + (t + (error "Unknown blossom case.")))))) + +(define-message-handler handle-message-scan + ((node blossom-node) (message message-scan) now) + "Begins a scanning process." + (when (blossom-node-wilting node) + (when (message-reply-channel message) + (send-message (message-reply-channel message) + (make-pong node))) + (finish-with-scheduling)) + (process-continuation node `(START-SCAN ,message))) diff --git a/src/package.lisp b/src/package.lisp new file mode 100644 index 0000000..2a74fbf --- /dev/null +++ b/src/package.lisp @@ -0,0 +1,68 @@ +;;;; package.lisp + +#-(or sbcl ecl ccl) +(rename-package :alexandria :alexandria '(:a)) + +(defpackage #:anatevka + (:use #:cl) + (:use #:aether) + + #+(or sbcl ecl ccl) + (:local-nicknames (:a :alexandria)) + + ;; symbols for export + + ;; matchmaker.lisp + (:export + #:blossom-node ; CLASS + #:make-blossom-edge ; FUNCTION + ) + + ;; utilities.lisp + (:export + #:with-with ; MACRO + ) + + ;; node.lisp + (:export + #:min-id ; GENERIC + ) + + ;; dryad.lisp / dryad-api.lisp + (:export + #:dryad ; CLASS + #:*dryad-default-clock-rate* ; PARAMETER + #:dryad-match-address ; ACCESSOR + #:dryad-ids ; ACCESSOR + #:dryad-sprouted? ; ACCESSOR + #:vertex-vertex-distance ; GENERIC FUNCTION + + ;; messages + #:message-sow ; TYPE + #:message-reap ; TYPE + #:message-discover ; TYPE + #:message-discovery ; TYPE + #:message-wilt ; TYPE + #:message-sprout ; TYPE + #:message-wilting ; TYPE + + #:make-message-sow ; FUNCTION + #:make-message-reap ; FUNCTION + #:make-message-discover ; FUNCTION + #:make-message-discovery ; FUNCTION + #:make-message-wilt ; FUNCTION + #:make-message-sprout ; FUNCTION + #:make-message-wilting ; FUNCTION + + #:message-sow-id ; ACCESSOR + #:message-sow-event? ; ACCESSOR + #:message-reap-ids ; ACCESSOR + #:message-discover-address ; ACCESSOR + #:message-discover-id ; ACCESSOR + #:message-discover-internal-weight ; ACCESSOR + #:message-discover-repeat? ; ACCESSOR + #:message-discovery-channels-to-try ; ACCESSOR + #:message-discovery-future-distance ; ACCESSOR + #:message-sprout-address ; ACCESSOR + #:message-wilting-address ; ACCESSOR + )) diff --git a/src/supervisor.lisp b/src/supervisor.lisp new file mode 100644 index 0000000..da67e58 --- /dev/null +++ b/src/supervisor.lisp @@ -0,0 +1,189 @@ +;;;; supervisor.lisp +;;;; +;;;; At the completion of a BLOSSOM-NODE's SCAN started via SCAN-LOOP, it is +;;;; left holding a minimal proposed action for the blossom to take. In order to +;;;; actually enact that action, it spawns a `SUPERVISOR' to take the reins and +;;;; submits to a passive role in the procedure from then on. Accordingly, +;;;; (almost) all of the logic in performing blossom algorithm operations is +;;;; bound up in the procedure definitions for SUPERVISORs. +;;;; +;;;; The operations on the blossom trees---the meat of the "manipulation" phase +;;;; of the algorithm, once the decision-making is through---is spurred by +;;;; messages sent from a `SUPERVISOR', which functions as a coordinating +;;;; process. +;;;; +;;;; The `AUGMENT', `GRAFT', and `REWEIGHT' operations are sufficient to solve +;;;; the minimum-weight perfect matching problem for bipartite weighted graphs. +;;;; In the non-bipartite case, however, it is possible to apply these +;;;; operations and reach a nonoptimal dead end. The two operations +;;;; `CONTRACT' and `EXPAND' provide the remaining tools to, respectively, +;;;; reduce the nonbipartite case to the bipartite case and to port a bipartite +;;;; solution to a solution for the original graph. + +(in-package #:anatevka) + +(defclass supervisor (process-lockable) + ((process-clock-rate :initform *blossom-node-clock-rate*) + (node-class + :documentation "The class identifier who spawned this SUPERVISOR." + :accessor supervisor-node-class + :initform 'blossom-node + :initarg :node-class + :type symbol)) + (:documentation "A companion process responsible for coordinating a tree operation.")) + +(define-message-dispatch supervisor + ;; nothing. supervisors are bull-headed. + ) + +;;; +;;; supervisor data frame +;;; + +(defstruct data-frame-supervisor + "Data frame associated to the basic functioning on a SUPERVISOR process. + +PONG: The PONG that this process received at its START." + (pong nil :type message-pong)) + +;;; +;;; supervisor command definitions +;;; + +(defgeneric supervisor-command-from-recommendation (recommendation) + (:documentation "Converts a PONG recommendation to a supervisor procedure jump point.") + (:method (recommendation) + (error "Recommendation ~a has no associated jump point." recommendation)) + (:method ((recommendation (eql ':AUGMENT))) + 'START-AUGMENT) + (:method ((recommendation (eql ':GRAFT))) + 'START-GRAFT) + (:method ((recommendation (eql ':CONTRACT))) + 'START-CONTRACT) + (:method ((recommendation (eql ':EXPAND))) + 'START-EXPAND) + (:method ((recommendation (eql ':HOLD))) + 'START-MULTIREWEIGHT)) + +(define-process-upkeep ((supervisor supervisor) now) (START) + "Set up initial state: the stack frame and which procedure to branch on." + (let ((pong (pop (process-data-stack supervisor)))) + (with-slots (edges weight source-root target-root recommendation) pong + (log-entry :entry-type 'got-recommendation + :source-root source-root + :recommendation recommendation + :weight weight + :edges edges) + (let ((frame (make-data-frame-supervisor :pong pong))) + (push frame (process-data-stack supervisor)) + (cond + ;; If we get an invalid-weight recommendation, we use `CHECK-PONG' + ;; to make sure it is not a result of stale commands or messages. + ;; If the recommendation is cancelled, great. Otherwise, we follow up + ;; with `ENSURE-ABORTING' which crashes the algorithm if `CHECK-PONG' + ;; doesn't cause this supervisor to abort. + ((minusp weight) + (log-entry :entry-type 'invalid-recommendation :weight weight) + (process-continuation supervisor + `(CHECK-PONG ,pong) + `(ENSURE-ABORTING ,pong) + `(HALT))) + ((zerop weight) + (let ((jump-point (supervisor-command-from-recommendation recommendation))) + (process-continuation supervisor `(,jump-point ,pong)))) + ;; reweighting case + ((plusp weight) + (process-continuation supervisor `(START-REWEIGHT ,pong))) + (t + (error "Unknown error when unpacking recommendation of weight ~a" weight))))))) + +(define-process-upkeep ((supervisor supervisor) now) (HALT) + "Stop the current `SUPERVISOR' and announce whether it's been a success. Additionally, unpause the `SOURCE-ROOT' so that it can start scanning again." + (with-slots (pong) (pop (process-data-stack supervisor)) + (with-slots (source-root) pong + (sync-rpc (make-message-set :slots '(paused?) :values `(,nil)) + ;; set `returned?' to handle RTSes gracefully as we + ;; (intentionally) don't have an aborting? guard + (set-result source-root :returned? returned?) + (log-entry :entry-type 'success + :success (not (process-lockable-aborting? supervisor))) + (process-die))))) + +;;; +;;; sanity checks +;;; + +(define-process-upkeep ((supervisor supervisor) now) (CHECK-ROOTS roots) + "Ensure that these nodes are still actually unmatched roots." + (unless (process-lockable-aborting? supervisor) + (flet ((payload-constructor () + (make-message-values :values '(parent pistil match-edge)))) + (with-replies (values-lists) (send-message-batch #'payload-constructor roots) + (loop :for (parent pistil match-edge) :in values-lists + :do (when (or parent pistil match-edge) + (setf (process-lockable-aborting? supervisor) t))))))) + +(define-process-upkeep ((supervisor supervisor) now) (CHECK-PONG stale-pong) + "Ensure that two locked trees still agree that this is a responsible weightless operation." + (unless (process-lockable-aborting? supervisor) + (with-slots (target-vertex source-node) + (car (last (message-pong-edges stale-pong))) + ;; compute the local weight, blossom, root at the near vertex + (sync-rpc (make-message-soft-adjoin-root + ;; NOTE: this hard-coded pong type is OK, because it's never + ;; going to be fed to `UNIFY-PONGS'. + :pong (make-message-pong :source-root (aether::make-address) + :weight 0 + :edges (list (make-blossom-edge))) + :ping (make-message-soft-ping :weight 0 + :blossom (aether::make-address))) + (local-pong + (blossom-edge-source-vertex + (car (last (message-pong-edges stale-pong)))) + :message-type message-pong :message-unpacker identity) + (log-entry :entry-type 'local-pong-recommendation + :recommendation (message-pong-recommendation local-pong)) + ;; send a ping to the far vertex with this local weight + (let ((local-blossom (blossom-edge-target-node + (car (last (message-pong-edges local-pong))))) + (local-root (message-pong-target-root local-pong))) + (sync-rpc (make-message-soft-ping :weight (message-pong-weight local-pong) + :root local-root + :blossom local-blossom + :id (message-pong-source-id stale-pong)) + (replica-pong target-vertex + :returned? returned? :message-type message-pong :message-unpacker identity) + (when returned? + (setf (process-lockable-aborting? supervisor) t) + (finish-with-scheduling)) + (setf (blossom-edge-source-node + (car (last (message-pong-edges replica-pong)))) + local-blossom + (blossom-edge-source-vertex + (car (last (message-pong-edges replica-pong)))) + (blossom-edge-source-vertex + (car (last (message-pong-edges stale-pong))))) + (process-continuation supervisor + `(EVALUATE-CHECK-PONG ,stale-pong ,local-pong + ,replica-pong)))))))) + +(define-process-upkeep ((supervisor supervisor) now) + (EVALUATE-CHECK-PONG stale-pong local-pong replica-pong) + "CHECK-PONG results in a refreshed REPLICA-PONG, which we're to compare against STALE-PONG and LOCAL-PONG, aborting if they differ in a way that indicates stale information." + (setf (process-lockable-aborting? supervisor) + (not (pong= stale-pong replica-pong)))) + +(define-process-upkeep ((supervisor supervisor) now) (ENSURE-ABORTING pong) + "This command is used upon encountering a negatively-weighted edge rec, to cause the algorithm to crash if the recommendation doesn't resolve itself." + (unless (process-lockable-aborting? supervisor) + (with-slots (weight) pong + (error "Running CHECK-PONG didn't fix a negative-weight edge: ~a" pong)))) + +(define-process-upkeep ((supervisor supervisor) now) + (BROADCAST-PINGABILITY targets new-type) + "Instruct the trees rooted at `TARGETS' to change their pingability to `NEW-TYPE'." + (unless (process-lockable-aborting? supervisor) + (flet ((payload-constructor () + (make-message-broadcast-pingability :ping-type new-type))) + (with-replies (replies) (send-message-batch #'payload-constructor targets) + nil)))) diff --git a/src/utilities.lisp b/src/utilities.lisp new file mode 100644 index 0000000..114df16 --- /dev/null +++ b/src/utilities.lisp @@ -0,0 +1,94 @@ +;;;; utilities.lisp +;;;; +;;;; Common, package-wide utilities. + +(in-package #:anatevka) + +(defun vnth (index array) + "Like NTH, but for vectors." + (aref array index)) + +(defun array-from-fn (length fn &rest array-initargs) + "Initializes an array of a particular LENGTH (and with possible other ARRAY-INITARGS) by evaluating (FN J) for each position 0 <= J < LENGTH and storing the result at (AREF ARRAY J)." + (initialize-and-return ((array (apply #'make-array length array-initargs))) + (dotimes (j length) + (setf (aref array j) (funcall fn j))))) + +(defun discard-args (fn) + "Converts NIL -> B' to A' -> B' by discarding the input." + (lambda (&rest args) + (declare (ignore args)) + (funcall fn))) + +(defun pick-the-other (thing option1 option2) + "Selects the \"other\" item from a pair." + (cond + ((eql thing option1) + option2) + ((eql thing option2) + option1) + (t + (error "~a is neither ~a nor ~a" thing option1 option2)))) + +(defun latest-common-head (l r &key + prev ; XXX: could be more robust + (test #'equalp) + key) + "Given a pair of lists + + (A1 A2 ... An A(n+1) ... Am) and + (A1 A2 ... An B(n+1) ... Bl), + +computes the pair + + ((An A(n+1) ... Am) (An B(n+1) ... Bl))." + (unless (and l r) + ;; if we reach this unless block, it is because one of the tails + ;; that constitutes the fresh blossom cycle entirely contains the + ;; other one. but, we still need to hold onto the `prev` value + (return-from latest-common-head + (list (list* (car prev) l) (list* (cdr prev) r)))) + (let* ((fl (first l)) + (fr (first r)) + (tfl (if key (funcall key fl) fl)) + (tfr (if key (funcall key fr) fr))) + (cond + ((funcall test tfl tfr) + (latest-common-head (rest l) (rest r) + :prev (cons fl fr) + :test test + :key key)) + (t + (list (list* (car prev) l) (list* (cdr prev) r)))))) + +(defun -> (obj &rest slots) + "Analogous to the C expression obj->slot1->slot2->...->slotn." + (if slots + (a:when-let ((obj-prime (slot-value obj (first slots)))) + (apply #'-> obj-prime (rest slots))) + obj)) + +(defun (setf ->) (value obj &rest slots) + "Analogous to the C expression obj->slot1->slot2->...->slotn = value." + (cond + ((endp slots) + (setf obj value)) + ((endp (rest slots)) + (setf (slot-value obj (first slots)) value)) + (t + (apply #'(setf ->) value (slot-value obj (first slots)) (rest slots))))) + +(defmacro with-with ((&rest with-designators) &body body) + "Permits the chaining of context macros via WITH-DESIGNATORS." + (loop :with output := `(progn ,@body) + :for (head args) :in (reverse with-designators) + :do (setf output `(,head ,args ,output)) + :finally (return output))) + +(defun make-bool (val) + "Turns a generalized boolean into a boolean." + (not (not val))) + +(defun pick-randomly (list) + "Picks uniformly randomly from a noncircular list." + (nth (random (length list)) list)) diff --git a/tests/blossom.lisp b/tests/blossom.lisp new file mode 100644 index 0000000..c3d29ea --- /dev/null +++ b/tests/blossom.lisp @@ -0,0 +1,405 @@ +;;;; tests/blossom.lisp +;;;; +;;;; This file implements a framework for testing the correctness of the blossom +;;;; algorithm. The heart of the framework is the macro `DEFINE-BLOSSOM-TEST', +;;;; which takes a problem graph and collection of minimum-weight perfect +;;;; matchings (MWPMs) that are valid solutions to the problem, and builds a +;;;; unit test on top of fiasco's DEFTEST framework. +;;;; +;;;; To aid in understanding the various unit tests, each one has a docstring +;;;; that shows the problem graph, and the various solutions. An example of this +;;;; is the following, with the problem graph on the left, separated from the +;;;; solutions by the => symbol (which are themselves separated by || symbols). +;;;; To more clearly differentiate between the different edges that compose each +;;;; matching, we use o, O, and * to each represent nodes of different matches. +;;;; For some graphs, we also use the + symbol as a visual aid for intersecting +;;;; edges and 'corners' of edges. +;;;; +;;;; o - o o - o o O o - o +;;;; | | | | +;;;; o - o => O * || o O || O - O +;;;; | | | | +;;;; o - o O * * - * * - * +;;;; +;;;; To make test-writing as natural as possible, problem graph coordinates are +;;;; laid out on a standard Manhattan/taxicab lattice (i.e. square lattice with +;;;; one unit between each node). +;;;; +;;;; NOTE: This is the only file in anatevka where we refer to concepts in +;;;; quantum error correction. This testing framework is used heavily in +;;;; the sequel package to anatevka where we build a distributed online +;;;; decoder for the surface code, and we haven't yet gone through the +;;;; effort of generalizing it. + +(in-package #:anatevka-tests) + +(defconstant +default-border+ 0) +(defconstant +default-dryad-clock-rate+ 10) +(defconstant +default-iterations+ 10) +(defconstant +default-timeout+ 1000) +(defconstant +default-timestep+ 5) + +;; these utilities get used in the macro code which defines this part of the +;; test suite, so have to be available at compile-time. +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun manhattan-distance (a b) + (loop :for aa :in a + :for bb :in b + :sum (abs (- aa bb)))) + (defun match-weight (match) + (apply #'manhattan-distance match)) + (defun matching-weight (matching) + (reduce '+ (mapcar #'match-weight matching)))) + +(defun shift-coordinates (x y offset) + "Given INTEGER coordinates `X' and `Y', apply an INTEGER `OFFSET' to `X', and then shift them to the 'surface code coordinate system' of the surface code. In the surface code, each flavor of stabilizer occupies its own lattice (thus we will only care about one of the two for the blossom algorithm). One such lattice has 'origin' at (1, 0), and every other stabilizer is 2 units away in the x or y direction." + (list (1+ (* 2 (+ x offset))) (* 2 y))) + +(defun sow-spacelike-graph (dryad coordinates + &key offset) + "Given a LIST of spacelike `COORDINATES', sow them into the `DRYAD'. Before sowing, apply the INTEGER `OFFSET' and shift the coordinates to the surface code coordinate system using `SHIFT-COORDINATES'." + (loop :for (x y) :in coordinates + ;; apply offset and shift to 'lattice coordinate system' + :for (shifted-x shifted-y) := (shift-coordinates x y offset) + :for id := (make-grid-location :x shifted-x :y shifted-y) + :do (send-message (process-public-address dryad) + (make-message-sow :id id)))) + +(defun coordinate< (a b) + "Determines if coordinate `A' should go before coordinate `B', where both are LISTs in the form (X0 Y0) where X0 and Y0 are both INTEGERs. First compares by closeness to origin, and then by X0." + (let* ((time-a (if (caddr a) (caddr a) 0)) + (time-b (if (caddr b) (caddr b) 0)) + (distance-to-origin-a (+ (car a) (cadr a))) + (distance-to-origin-b (+ (car b) (cadr b)))) + (cond + ((< time-a time-b) + t) + ;; if you're closer to origin, you come first + ((and (= time-a time-b) + (< distance-to-origin-a distance-to-origin-b)) + t) + ;; break ties by comparing X0 + ((and (= time-a time-b) + (= distance-to-origin-a distance-to-origin-b)) + (< (car a) (car b))) + (t + nil)))) + +(defun sort-match (match) + "Given a `MATCH', which is a LIST of the form ((X0 Y0) (X1 Y1)) where X0, Y0, X1, and Y1 are INTEGERs, sort its two coordinates using the `COORDINATE<' predicate." + (sort match #'coordinate<)) + +(defun unshift-coordinates (x y offset) + "The opposite action of SHIFT-COORDINATES -- bring us back to the original Manhattan/taxicab lattice." + (check-type x integer) + (check-type y integer) + (check-type offset integer) + (assert (oddp x)) + (assert (evenp y)) + (list (- (/ (1- x) 2) offset) (/ y 2))) + +(defun unpack-match (reap-message offset) + "Given a message `REAP-MESSAGE' of type message-reap, unpack the match it contains as a LIST, unshifting the coordinates from the surface code coordinate system, and unapplying the `OFFSET'." + (destructuring-bind (id-a id-b) (anatevka::message-reap-ids reap-message) + (let* ((location-a id-a) + (location-b id-b) + (a-x (grid-location-x location-a)) + (a-y (grid-location-y location-a)) + (b-x (grid-location-x location-b)) + (b-y (grid-location-y location-b)) + (match (list (unshift-coordinates a-x a-y offset) + (unshift-coordinates b-x b-y offset)))) + (sort-match match)))) + +(defun contains-coordinate? (matching coordinate) + "Returns T if the `MATCHING', which is a LIST in the form ((X0 Y0) (X1 Y1)) where X0, Y0, X1, Y1 are all INTEGERs, contains the `COORDINATE', which is a LIST of INTEGERs in the form (X0 Y0)." + (flet ((match-contains-coordinate? (match) + (or (equal coordinate (car match)) + (equal coordinate (cadr match))))) + (some #'identity (mapcar #'match-contains-coordinate? matching)))) + +(defun perfect-matching? (matching coordinates) + "Returns T if the `MATCHING', which is a LIST in the form ((X0 Y0) (X1 Y1)) where X0, Y0, X1, Y1 are all INTEGERs, contains all of the `COORDINATES', each of which is a LIST of INTEGERs in the form (X0 Y0). Uses the `CONTAINS-COORDINATE?' function to do this.." + (every #'identity + (loop :for coordinate :in coordinates + :collect (contains-coordinate? matching coordinate)))) + +(defun await-matching (simulation match-address + &key coordinates offset timeout timestep) + "Run the `SIMULATION' and listen on the `MATCH-ADDRESS' for a series of reap messages that contain the matching produced by the blossom algorithm. The simulation runs, checking the channel every `TIMESTEP' steps, until it received a perfect matching (determined using the LIST of `COORDINATES'), or until hitting the `TIMEOUT' (an INTEGER). Each message is unpacked (using the `OFFSET') into a LIST of LISTs, and pushed onto the MATCHING (also a LIST), which is returned at the end, along with the time it took to complete." + (initialize-and-return ((final-time) (matching)) + (loop :with time := 0 + :do (when (or (perfect-matching? matching coordinates) + ;; break out if taking too long + (>= time timeout)) + (setf final-time time) + (return t)) + (incf time timestep) + (simulation-run simulation :canary (canary-until time)) + (receive-message (match-address reap-message) + (message-reap + (push (unpack-match reap-message offset) matching)))))) + +(defun match< (a b) + "Determines if match `A' should go before match `B', where both are LISTs in the form ((X0 Y0) (X1 Y1)) where X0, Y0, X1, and Y1 are all INTEGERs. First compares by closeness to origin, and then by X0." + (let* ((distance-to-origin-a (+ (caar a) (cadar a))) + (distance-to-origin-b (+ (caar b) (cadar b)))) + (cond + ;; if you're closer to origin, you come first + ((< distance-to-origin-a distance-to-origin-b) + t) + ;; break ties by comparing X0 + ((= distance-to-origin-a distance-to-origin-b) + (< (caar a) (caar b))) + (t + nil)))) + +(defun sort-matching (matching) + "Given a `MATCHING', which is a LIST in the form ((X0 Y0) (X1 Y1)) where X0, Y0, X1, Y1 are all INTEGERs, sort it using the `MATCH<' predicate." + (sort (copy-list matching) #'match<)) + +(defun one-of (matching &rest correct-matchings) + "Given a `MATCHING' and a &REST LIST of `CORRECT-MATCHINGS', return T if `MATCHING' is one of the `CORRECT-MATCHINGS'." + (notevery #'null + (loop :for correct-matching :in correct-matchings + :for sorted-correct-matching := (sort-matching correct-matching) + :for sorted-matching := (sort-matching matching) + :collect (equal sorted-matching sorted-correct-matching)))) + +(defmacro define-blossom-test (test-name coordinates + (&key (border +default-border+) + (debug? nil) + (dryad-clock-rate +default-dryad-clock-rate+) + (iterations +default-iterations+) + (timeout +default-timeout+) + (timestep +default-timestep+)) &body body) + "Used to define a blossom algorithm unit test named `TEST-NAME'. The LIST of `COORDINATES' represents the problem graph to be fed to the blossom algorithm. + +There are also a collection of optional keyword arguments that allow individual tests to be customized. The `DEBUG?' and `DRYAD-CLOCK-RATE' parameters set the process debug flag and the process clock rate, respectively, of the DRYAD in the algorithm. The `ITERATIONS' parameter determines how many times the test will be run. The `BORDER' parameter offsets the coordinates. The `TIMEOUT' parameter determines how long the test can run before it is considered a failure. The `TIMESTEP' parameter designates how many clock cycles to run between each RECEIVE-MESSAGE call. + +Finally, the `BODY' contains optional declarations and a docstring, and then is followed by a series of LISTs, each of which represents a valid solution (i.e. minimum-weight perfect matching) for the problem graph. The `BODY' needs to contain at least one valid solution so that it can determine the correct minimum weight to check as part of the test. Test-writers can optionally provide additional solutions, but they currently do not play a part in the success or failure of a test. + +NOTE: This macro automatically rescales the pairs in `COORDINATES' to reside at measurement qubit locations in a suitably large instance of the surface code." + (multiple-value-bind (solutions decls docstring) + (alexandria:parse-body body :documentation t) + (assert (apply #'= (mapcar #'matching-weight solutions)) + () + "Solutions differ in weight.") + (let ((solution-weight (matching-weight (first solutions)))) + `(deftest ,test-name () + ,@(when docstring (list docstring)) + ,@(when decls decls) + (loop + :for i :below ,iterations + :with times + :do (with-courier () + (let* ((channel (register)) + (dryad (spawn-process 'dryad + :process-clock-rate ,dryad-clock-rate + :match-address channel + :debug? ,debug?))) + (with-simulation (simulation (*local-courier* dryad)) + (anatevka::reset-logger) + (when (= 0 (mod i 50)) + (sb-ext:gc :full t)) + (sow-spacelike-graph dryad ',coordinates + :offset ,border) + (multiple-value-bind (matching time) + (await-matching simulation channel + :coordinates ',coordinates + :offset ,border + :timeout ,timeout + :timestep ,timestep) + (push time times) + (unless matching + (error "No matching produced.")) + (unless (one-of matching + ,@(loop :for correct-matching :in solutions + :collect `',correct-matching)) + (unless (perfect-matching? matching ',coordinates) + (error "Found an imperfect matching: ~A" matching)) + (when (< (matching-weight matching) ,solution-weight) + (error "Found better perfect matching: ~A has weight ~A<~A" + matching + (matching-weight matching) + ,solution-weight)) + (format t "~%Found perfect matching not in solutions: ~A~%" + matching)) + (is (= ,solution-weight (matching-weight matching))))))) + :finally + ;; print out run-time statistics + (format t "~%runs: ~A~%mean: ~$~%std : ~$~%min : ~d~%max : ~d~%" + (length times) + (alexandria:mean times) + (alexandria:standard-deviation times) + (reduce #'min times) + (reduce #'max times))))))) + +(define-blossom-test test-blossom-bulk-pair ((0 0) (0 1)) + (:border 1) + "A pair of events in the bulk: + + o o + | => | + o o +" + (((0 0) (0 1)))) + +(define-blossom-test test-blossom-bulk-rectangle ((0 0) (0 1) (2 0) (2 1)) + (:border 1) + "A rectangle of events in the bulk: + + o - - o o O + | | => | | + o - - o o O +" + (((0 0) (0 1)) ((2 0) (2 1)))) + +(define-blossom-test test-blossom-bulk-square ((0 0) (0 1) (1 0) (1 1)) + (:border 1) + "A square of events in the bulk: + + o - o o O o - o + | | => | | || + o - o o O O - O +" + (((0 0) (0 1)) ((1 0) (1 1))) + (((0 0) (1 0)) ((0 1) (1 1)))) + +(define-blossom-test test-blossom-bulk-square-tiling ((0 0) (0 1) (0 2) + (1 0) (1 1) (1 2)) + (:border 1) + "A square tiling of events in the bulk: + + o - o o - o o O o - o + | | | | + o - o => O * || o O || O - O + | | | | + o - o O * * - * * - * +" + (((0 0) (0 1)) ((1 0) (1 1)) ((0 2) (1 2))) + (((0 0) (1 0)) ((0 1) (0 2)) ((1 1) (1 2))) + (((0 0) (1 0)) ((0 1) (1 1)) ((0 2) (1 2)))) + +(define-blossom-test test-blossom-bulk-tbone ((0 0) (0 1) (0 2) + (2 1) (3 1) (4 1)) + (:border 2) + "A 'T-bone' configuration of events in the bulk: + + o o o 0 - - + | | | | + o - - o - o - o => O - - O * - * || o O * - * || o 0 * - * + | | | | + o o O - - o +" + (((0 0) (0 2)) ((0 1) (2 1)) ((3 1) (4 1))) + (((0 0) (2 1)) ((0 1) (0 2)) ((3 1) (4 1))) + (((0 0) (0 1)) ((0 2) (2 1)) ((3 1) (4 1)))) + +(define-blossom-test test-blossom-bulk-bowtie ((0 0) (0 2) (1 1) + (2 1) (3 0) (3 2)) + (:border 1) + "A 'bowtie' configuration of events (>-<) in the bulk: + + o - + + - o o * + | | | | + o - o => + O - O + + | | | | + o - + + - o o * +" + (((0 0) (0 2)) ((1 1) (2 1)) ((3 0) (3 2)))) + +(define-blossom-test test-blossom-bulk-snake ((0 0) (2 0) (2 1) (4 1)) + (:border 1) + "A snaking set of four events in the bulk: + + o - - o O - - O + | => + o - - o o - - o +" + (((0 0) (2 0)) ((2 1) (4 1)))) + +(define-blossom-test test-blossom-bulk-hexagon ((0 1) (1 0) (2 1) + (0 2) (1 3) (2 2)) + (:border 1) + "A regular hexagon of events in the bulk: + + o o O O + | | | | + o - + - o o - + * o + - O o + * + | | | => | || | || | | | + o - + - o O - + * o + - * o + * + | | | | + o O * O +" + (((0 1) (1 0)) ((0 2) (1 3)) ((2 1) (2 2))) + (((0 1) (0 2)) ((1 0) (2 1)) ((1 3) (2 2))) + (((0 1) (0 2)) ((1 0) (1 3)) ((2 1) (2 2)))) + +(define-blossom-test test-blossom-bulk-pentagon ((0 0) (1 1) (2 0) + (0 2) (2 2) (1 3)) + (:border 2) + "A regular right pentagon of events (plus a central one, forming a star) in the bulk: + + o + | + o - + - o + | | | + + - o - + => + | | | + o - + - o + + o o - + + - o o o o + | | | | | | + o - + - o o - + o o + - o o - + o o + - o o + o + | || | || | || | || | || | | | + o o o + - o + + o - + + o + + | | | | | | + o - + - o o - + - o o - + - o o o o + o o o +" + (((0 0) (2 0)) ((0 2) (2 2)) ((1 1) (1 3))) + (((0 0) (2 0)) ((0 2) (1 1)) ((1 3) (2 2))) + (((0 0) (2 0)) ((0 2) (1 3)) ((1 1) (2 2))) + (((0 0) (1 1)) ((0 2) (1 3)) ((2 0) (2 2))) + (((0 0) (0 2)) ((1 1) (2 0)) ((1 3) (2 2))) + (((0 0) (0 2)) ((1 1) (1 3)) ((2 0) (2 2)))) + +(define-blossom-test test-blossom-bulk-triangle-tiling ((0 1) (1 0) (2 1) + (3 0) (4 1) (5 0)) + (:border 2) + "A trianglular tiling of events in the bulk: + + o - + - o - + - o o - + 0 - + * + | | | | => | | | + o - + - o - + - o o 0 + - * +" + (((0 1) (1 0)) ((2 1) (3 0)) ((4 1) (5 0))) + (((0 1) (2 1)) ((1 0) (3 0)) ((4 1) (5 0))) + (((0 1) (1 0)) ((2 1) (4 1)) ((3 0) (5 0)))) + +(define-blossom-test test-blossom-bulk-diamond ((0 1) (1 0) (1 2) (2 1)) + (:border 1) + "A diamond configuration of events in the bulk: + + o 0 0 o + | | | | + o - + - o => o - + - o || o - + - 0 || o - + - 0 + | | | | + o 0 o 0 +" + (((0 1) (2 1)) ((1 0) (1 2))) + (((0 1) (1 0)) ((1 2) (2 1))) + (((0 1) (1 2)) ((1 0) (2 1)))) + +(define-blossom-test test-blossom-long-chain + ((0 0) (1 0) (2 0) (3 0) (4 0) (5 0) (6 0) (7 0) (8 0) (9 0)) + () + "A long linear chain of an even number of evenly spaced blossoms: + +b - o - o - o - o - o - o - o - o - o - o - b + + => + +b o - o o - o o - o o - o o - o b +" + (((0 0) (1 0)) ((2 0) (3 0)) ((4 0) (5 0)) ((6 0) (7 0)) ((8 0) (9 0)))) diff --git a/tests/node.lisp b/tests/node.lisp new file mode 100644 index 0000000..f27a327 --- /dev/null +++ b/tests/node.lisp @@ -0,0 +1,324 @@ +;;;; tests/matchmaker.lisp + +(in-package #:anatevka-tests) + +;;; +;;; utility data structure +;;; + +(defstruct grid-location + "A plane coordinate." + x + y) + +(defmethod min-id ((x grid-location) (y grid-location)) + (cond + ((< (grid-location-x x) (grid-location-x y)) + x) + ((and (= (grid-location-x x) (grid-location-x y)) + (< (grid-location-y x) (grid-location-y y))) + x) + (t + y))) + +(defmethod vertex-vertex-distance ((space-v grid-location) (space-w grid-location)) + (+ (abs (- (grid-location-x space-v) (grid-location-x space-w))) + (abs (- (grid-location-y space-v) (grid-location-y space-w))))) + +;;; +;;; utility tests +;;; + +(deftest test-unify-pongs () + (let* ((augment-0 (anatevka::make-message-pong + :weight 0 + :recommendation ':augment)) + (augment-pos (anatevka::make-message-pong + :weight 1 + :recommendation ':augment)) + (augment-neg (anatevka::make-message-pong + :weight -1 + :recommendation ':augment)) + (contract-0 (anatevka::make-message-pong + :weight 0 + :recommendation ':contract)) + (hold-0 (anatevka::make-message-pong + :weight 0 + :recommendation ':hold)) + (graft-0 (anatevka::make-message-pong + :weight 0 + :recommendation ':graft)) + (zero-weighters (list augment-0 graft-0 contract-0))) + ;; non-zero AUGMENTs have higher precedence than equal-weight ops + (is (every #'identity + (loop :for rec :in (list ':graft ':expand ':contract) + :collect (let ((pong (anatevka::make-message-pong + :weight (anatevka::message-pong-weight + augment-pos) + :recommendation rec))) + (eql ':augment + (anatevka::message-pong-recommendation + (anatevka::unify-pongs augment-pos pong))))))) + ;; HOLD 0 has lower precedence than other zero-weight ops + (is (every #'identity + (loop :for pong :in zero-weighters + :collect (not (eql ':hold + (anatevka::message-pong-recommendation + (anatevka::unify-pongs hold-0 pong))))))) + ;; negative-weight operations (other than PASS, internal HOLD) take precedence + (is (every #'identity + (loop :for pong :in zero-weighters + :collect (= -1 + (anatevka::message-pong-weight + (anatevka::unify-pongs augment-neg pong)))))))) + +(deftest test-find-even-arm () + (let ((test-cases '((;; source-index - target-index is even, positive + (5 3 (1 2 3 4 5 6 7)) . + ((5 4) T (3 2 1 7 6 5 4))) + (;; source-index - target-index is even, negative + (3 5 (1 2 3 4 5 6 7)) . + ((3 4) NIL (5 6 7 1 2 3 4))) + (;; source-index - target-index is odd, positive + (5 2 (1 2 3 4 5 6 7)) . + ((5 6 7 1) NIL (2 3 4 5 6 7 1))) + (;; source-index - target-index is odd, negative + (2 5 (1 2 3 4 5 6 7)) . + ((2 1 7 6) T (5 4 3 2 1 7 6))) + (;; edge case + (3 3 (1 2 3 4 5 6 7)) . + (() NIL (3 4 5 6 7 1 2)))))) + (loop :for ((source target list) . (arm reversed? full)) :in test-cases + :do (multiple-value-bind (real-arm really-reversed? real-full) + (anatevka::find-even-arm list source target) + (is (equalp real-arm arm)) + (is (eql reversed? really-reversed?)) + (is (equalp full real-full)))))) + +(deftest test-find-even-arm-reversal () + "Test that the `:key' and `:rev' keywords do what they are supposed to." + (let ((cycle '((1 2) (2 3) (3 4) (4 5) (5 1))) + (path '((2 1) (1 5) (5 4) (4 3))) + (reversed? T) + (full-path '((3 2) (2 1) (1 5) (5 4) (4 3)))) + (multiple-value-bind (real-path real-reversed? real-full-path) + (anatevka::find-even-arm cycle 2 3 + :key #'car + :rev (lambda (x) + (mapcar #'reverse (reverse x)))) + (is (equalp real-path path)) + (is (equalp real-reversed? reversed?)) + (is (equalp real-full-path full-path))))) + +;;; +;;; a fixed test of the blossom algorithm outside of the context of a dryad +;;; + +(defstruct mma-id + "A wrapper for a vertex ID used in the Mathematica blossom demo." + (value nil :type (integer 1 8))) + +(defmethod anatevka::vertex-vertex-distance ((id-v mma-id) (id-w mma-id)) + (let ((v (mma-id-value id-v)) + (w (mma-id-value id-w))) + (aref #2A(( 0 40 52 50 46 70 36 46) + (40 0 34 54 28 64 20 6) + (52 34 0 28 34 24 2 30) + (50 54 28 0 42 18 36 8) + (46 28 34 42 0 14 80 22) + (70 64 24 18 14 0 22 64) + (36 20 2 36 80 22 0 80) + (46 6 30 8 22 64 80 0)) + (1- v) (1- w)))) +;; NOTE: a perfect matching for this table has weight 64: +;; 1 -- 2, 3 -- 7, 4 -- 8, 5 -- 6 + +(deftest test-weighted-blossom-results-against-mathematica () + "This integration test duplicates the input used by the Mathematica demo of the weighted blossom algorithm for 8 vertices and random seed 4, then applies our own algorithm." + (let* ((*local-courier* (make-courier :processing-clock-rate 300)) + (match-address (register)) + (dryad (spawn-process 'dryad + :process-clock-rate 20 + :debug? t + :match-address match-address)) + (simulation (make-simulation))) + (simulation-add-event simulation + (make-event :callback *local-courier* :time 0)) + (simulation-add-event simulation (make-event :callback dryad :time 0)) + ;; set up simulation components + (loop :for j :from 1 :to 8 + :for id := (make-mma-id :value j) + :do (send-message (process-public-address dryad) + (anatevka::make-message-sow :id id))) + ;; run simulation until maximally matched (i.e., the dryad terminates) + (simulation-run simulation :canary (canary-process dryad)) + (labels ((drain-match-address (&optional acc) + (receive-message (match-address message) + (message-reap + (drain-match-address (list* (message-reap-ids message) acc))) + (otherwise + acc)))) + + ;; make sure the matching is of the predicted minimal weight + (is (= 64 (loop :for (left right) :in (drain-match-address) + :sum (anatevka::vertex-vertex-distance left right))))))) + +;;; +;;; macrology for setting up blossom state +;;; + +(defmacro blossom-let ((tree-name &rest global-options) + (&rest node-definitions) + &body body) + "Helper macro for defining a family of `BLOSSOM-NODE's to be organized into a tree. Each entry of `NODE-DEFINITIONS' is a `LET'-like binding: + + (NODE-NAME OPTIONAL-NODE-CLASS . KEYWORD ARGUMENTS FOR MAKE-INSTANCE 'NODE-CLASS) , + +where NODE-CLASS is replaced by OPTIONAL-NODE-CLASS if supplied or by BLOSSOM-NODE if omitted. Additionally, GLOBAL-OPTIONS are appended to the keyword arguments passed to MAKE-INSTANCE. + +Finally, all of the nodes constructed by this BLOSSOM-LET are stashed in the place indicated by TREE-NAME. This is convenient for use with `TREE-EQUALP' and with `SIMULATE-ADD-TREE'." + (let (addresses augmented-node-definitions) + ;; precompute addresses for the nodes + (loop :for (symbol-name . rest) :in node-definitions + :collect `(,symbol-name (register + :channel ',(gensym + (format nil "TEST-BLOSSOM-~A" + symbol-name)))) + :into addresses-result + :finally (setf addresses addresses-result)) + ;; process node-definition symbols into addresses + (loop :for (symbol-name . initargs) :in node-definitions + :for class-name := (if (keywordp (first initargs)) + 'blossom-node + (first initargs)) + :for chopped-args := (if (keywordp (first initargs)) + initargs + (rest initargs)) + :collect `(,symbol-name (spawn-process ',class-name + :process-key ,symbol-name + ,@chopped-args + ,@global-options + :debug? t)) :into result + :finally (setf augmented-node-definitions result)) + `(let ,addresses + (declare (ignorable ,@(mapcar #'first node-definitions))) + (let ,augmented-node-definitions + (let ((,tree-name (list ,@(mapcar #'first node-definitions)))) + (setf ,@(loop :for (name . rest) :in node-definitions + :nconc (list `(process-command-stack ,name) + '(list '(anatevka::IDLE))))) + ,@body))))) + +(defun simulate-add-tree (simulation tree &key (start-time 0)) + "BLOSSOM-LET binds a place that knows about all the nodes it's constructed, called the \"tree\". SIMULATE-ADD-TREE takes the contents of this place and adds it to a SIMULATION object." + (dolist (node tree) + (simulation-add-event simulation (make-event :callback node :time start-time)))) + +(defun simulate-until-dead (simulation process &key (start-time 0) timeout) + "Runs SIMULATION until PROCESS exhausts its command queue." + ;; NOTE: Rather than waiting on the command queue, we could check whether the + ;; process's public address is still registered (cf., the PROCESS-DIE handler + ;; in DEFINE-OBJECT-HANDLER PROCESS). + (simulation-run simulation + :canary (funcall #'canary-any + (canary-process process) + (if timeout + (canary-until timeout) + (constantly nil)))) + (values simulation (aether::simulation-horizon simulation))) + +(defun tree-equalp (left-nodes right-nodes) + "Checks that two trees of BLOSSOM-NODEs agree structurally, up to renaming of addresses. Expects to receive the nodes of the two trees in the same order in both arguments." + (let ((dictionary (make-hash-table :hash-function #'anatevka::hash-address :test #'address=))) + (labels ((translated-edge= (l r) + (let ((accessors (list #'anatevka::blossom-edge-source-node + #'anatevka::blossom-edge-source-vertex + #'anatevka::blossom-edge-target-vertex + #'anatevka::blossom-edge-target-node))) + (every #'address= + (mapcar (lambda (f) (gethash (funcall f l) dictionary)) + accessors) + (mapcar (lambda (f) (funcall f r)) accessors)))) + (test (left-value right-value) + (typecase left-value + (list + (and (listp right-value) + (= (length left-value) (length right-value)) + (or (endp left-value) + (and (typep (first left-value) 'anatevka::blossom-edge) + (every #'translated-edge= left-value right-value)) + (and (typep (first left-value) 'aether::address) + (every #'address= left-value right-value))))) + (anatevka::blossom-edge + (and (typep right-value 'anatevka::blossom-edge) + (translated-edge= left-value right-value))) + (anatevka::address + (address= (gethash left-value dictionary left-value) + right-value)) + (otherwise + (equalp left-value right-value))))) + (loop :for left :in left-nodes + :for right :in right-nodes + :do (setf (gethash (process-public-address left) dictionary) + (process-public-address right))) + (anatevka::initialize-and-return ((test-result t)) + (loop :for left :in left-nodes + :for right :in right-nodes + :do (loop :for slot :in (mapcar #'closer-mop:slot-definition-name + (closer-mop:class-direct-slots + (class-of left))) + :for left-value := (slot-value left slot) + :for right-value := (slot-value right slot) + :unless (test left-value right-value) + :do (format t "~&left (~a) ~a: ~a~%right (~a) ~a: ~a~%" + left slot left-value + right slot right-value) + (setf test-result nil))))))) + +(defun vv-edge (source-vertex target-vertex) + "Helper constructor for making a BLOSSOM-EDGE between two vertices." + (anatevka::make-blossom-edge + :source-vertex (if (typep source-vertex 'address) + source-vertex + (process-public-address source-vertex)) + :target-vertex (if (typep target-vertex 'address) + target-vertex + (process-public-address target-vertex)))) + +(defun bb-edge (source-node source-vertex target-vertex target-node) + "Helper constructor for making a BLOSSOM-EDGE between two nodes of the form: + + source-node:source-vertex -> target-vertex:target-node +" + (make-blossom-edge + :source-node (if (typep source-node 'address) + source-node + (process-public-address source-node)) + :source-vertex (if (typep source-vertex 'address) + source-vertex + (process-public-address source-vertex)) + ;; these can be null in an expand recommendation + :target-vertex (if (or (typep target-vertex 'address) + (null target-vertex)) + target-vertex + (process-public-address target-vertex)) + :target-node (if (or (typep target-node 'address) + (null target-node)) + target-node + (process-public-address target-node)))) + +(defun supervisor (simulation &rest pong-initargs) + "Helper constructor for a SUPERVISOR primed to run a bespoke PONG." + (initialize-and-return + ((supervisor (spawn-process 'anatevka::supervisor :debug? t))) + (simulation-add-event simulation (make-event :callback supervisor :time 0)) + (push (apply #'anatevka::make-message-pong + (append pong-initargs + (list :weight 0))) + (process-data-stack supervisor)))) + +(defun id (&optional + (x 0) + (y 0)) + "Helper constructor for throwaway IDs." + (make-grid-location :x x :y y)) diff --git a/tests/operations/augment.lisp b/tests/operations/augment.lisp new file mode 100644 index 0000000..7a0aba5 --- /dev/null +++ b/tests/operations/augment.lisp @@ -0,0 +1,100 @@ +;;;; tests/operations/augment.lisp +;;;; +;;;; Unit tests for the `AUGMENT' supervisor action. + +(in-package #:anatevka-tests) + +(deftest test-supervisor-augment-sapling-sapling () + "Checks the transformation + ++ + + + +A ~~~ B --> A === B" + (with-with ((with-courier ()) + (with-simulation (simulation (*local-courier*)))) + (let ((dryad-address (register))) + (blossom-let (original-tree :dryad dryad-address) + ((A :id (id 0) :internal-weight 2 :paused? T) + (B :id (id 2))) + (let ((supervisor (supervisor simulation + :edges (list (vv-edge A B)) + :source-root (process-public-address A) + :target-root (process-public-address B) + :recommendation ':augment + :source-id (id 0)))) + (simulate-add-tree simulation original-tree) + (simulate-until-dead simulation supervisor) + (blossom-let (target-tree :dryad dryad-address) + ((left :id (id 0) :match-edge (vv-edge left right) + :internal-weight 2) + (right :id (id 2) :match-edge (vv-edge right left))) + (is (tree-equalp original-tree target-tree)))))))) + +(deftest test-supervisor-augment-sapling-treetop () + "Checks the transformation + ++ + - + + + + + +A ~~~ B --> C ==> D --> A === B C === D" + (with-with ((with-courier ()) + (with-simulation (simulation (*local-courier*)))) + (let ((dryad-address (register))) + (blossom-let (original-tree :dryad dryad-address) + ((A :id (id 0) :internal-weight 2 :paused? T) + (B :id (id 2) + :children (list (vv-edge B C))) + (C :id (id 4) :internal-weight 2 + :match-edge (vv-edge C D) :parent (vv-edge C B) + :children (list (vv-edge C D)) :positive? nil) + (D :id (id 6) + :match-edge (vv-edge D C) :parent (vv-edge D C))) + (let ((supervisor (supervisor simulation + :edges (list (vv-edge A B)) + :source-root (process-public-address A) + :target-root (process-public-address B) + :recommendation ':augment + :source-id (id 0)))) + (simulate-add-tree simulation original-tree) + (simulate-until-dead simulation supervisor) + (blossom-let (target-tree :dryad dryad-address) + ((A :id (id 0) :match-edge (vv-edge A B) :internal-weight 2) + (B :id (id 2) :match-edge (vv-edge B A)) + (C :id (id 4) :match-edge (vv-edge C D) :internal-weight 2) + (D :id (id 6) :match-edge (vv-edge D C))) + (is (tree-equalp original-tree target-tree)))))))) + +(deftest test-supervisor-augment-sapling-duff () + "Checks the transformation + ++ + - + + + + + +A ~~~ D <== C <-- B --> A === D C === B" + (with-with ((with-courier ()) + (with-simulation (simulation (*local-courier*)))) + (let ((dryad-address (register))) + (blossom-let (original-tree :dryad dryad-address) + ((A :id (id 0) + :internal-weight 2 + :paused? T) + (B :id (id 6) + :children (list (vv-edge B C))) + (C :id (id 4) + :internal-weight 2 + :children (list (vv-edge C D)) + :parent (vv-edge C B) + :match-edge (vv-edge C D) + :positive? nil) + (D :id (id 2) + :match-edge (vv-edge D C) + :parent (vv-edge D C))) + (let ((supervisor (supervisor simulation + :edges (list (vv-edge A D)) + :source-root (process-public-address A) + :target-root (process-public-address B) + :recommendation ':augment + :source-id (id 0)))) + (simulate-add-tree simulation original-tree) + (simulate-until-dead simulation supervisor) + (blossom-let (target-tree :dryad dryad-address) + ((A :id (id 0) :match-edge (vv-edge A D) :internal-weight 2) + (B :id (id 6) :match-edge (vv-edge B C)) + (C :id (id 4) :match-edge (vv-edge C B) :internal-weight 2) + (D :id (id 2) :match-edge (vv-edge D A))) + (is (tree-equalp original-tree target-tree)))))))) diff --git a/tests/operations/contract.lisp b/tests/operations/contract.lisp new file mode 100644 index 0000000..202ac78 --- /dev/null +++ b/tests/operations/contract.lisp @@ -0,0 +1,337 @@ +;;;; tests/operations/contract.lisp +;;;; +;;;; Unit tests for the `CONTRACT' supervisor action. + +(in-package #:anatevka-tests) + +(deftest test-supervisor-contract-3-blossom-minimal () + "Checks the transformation + + - + + - + BLOSSOM + A --> B ==> C --> [A --- B --- C] + [\-----------/] +" + (with-with ((with-courier ()) + (with-simulation (simulation (*local-courier*))) + (with-address-dereferencing ())) + (let ((dryad-address (register))) + (blossom-let (original-tree :dryad dryad-address) + ((A :id (id 0) :children (list (vv-edge A B)) + :internal-weight 2 :paused? T) + (B :id (id 2) :parent (vv-edge B A) :children (list (vv-edge B C)) + :match-edge (vv-edge B C) + :positive? nil) + (C :id (id 4) :parent (vv-edge C B) :internal-weight 2 + :match-edge (vv-edge C B))) + (let ((supervisor (supervisor simulation + :recommendation ':contract + :edges (list (vv-edge A C)) + :source-root (process-public-address A) + :target-root (process-public-address A) + :source-id (id 0)))) + (simulate-add-tree simulation original-tree) + (simulate-until-dead simulation supervisor) + (let* ((finished-blossom (dereference (slot-value A 'anatevka::pistil))) + (finished-tree (list* finished-blossom original-tree))) + (blossom-let (target-tree :dryad dryad-address) + ((BLOSSOM :id (slot-value finished-blossom 'anatevka::id) + :dryad nil + :petals (list (vv-edge A C) + (vv-edge C B) + (vv-edge B A))) + (A :id (id 0) :pistil BLOSSOM :internal-weight 2) + (B :id (id 2) :pistil BLOSSOM) + (C :id (id 4) :pistil BLOSSOM :internal-weight 2)) + (is (tree-equalp finished-tree target-tree))))))))) + +(deftest test-supervisor-contract-3-blossom-duff () + "Checks the transformation + + + + + - + - + + - BLOSSOM + A --> B ==> C --> D ==> E --> A --> B ==> [C --- D --- E] + [\-----------/] +" + (with-with ((with-courier ()) + (with-simulation (simulation (*local-courier*))) + (with-address-dereferencing ())) + (let ((dryad-address (register))) + (blossom-let (original-tree :dryad dryad-address) + ((A :id (id 0) :children (list (vv-edge A B)) + :internal-weight 2 :paused? T) + (B :id (id 2) :parent (vv-edge B A) :children (list (vv-edge B C)) + :match-edge (vv-edge B C) :positive? nil) + (C :id (id 4) :parent (vv-edge C B) :children (list (vv-edge C D)) + :match-edge (vv-edge C B) :internal-weight 2) + (D :id (id 6) :parent (vv-edge D C) :children (list (vv-edge D E)) + :match-edge (vv-edge D E) :positive? nil) + (E :id (id 8) :parent (vv-edge E D) :internal-weight 2 + :match-edge (vv-edge E D))) + (let ((supervisor (supervisor simulation + :recommendation ':contract + :edges (list (vv-edge C E)) + :source-root (process-public-address A) + :target-root (process-public-address A) + :source-id (slot-value C 'anatevka::id)))) + (simulate-add-tree simulation original-tree) + (simulate-until-dead simulation supervisor) + (let* ((finished-blossom (dereference (slot-value C 'anatevka::pistil))) + (finished-tree (list* finished-blossom original-tree))) + (blossom-let (target-tree :dryad dryad-address) + ((BLOSSOM :id (slot-value finished-blossom 'anatevka::id) + :dryad nil + :petals (list (vv-edge C E) + (vv-edge E D) + (vv-edge D C)) + :match-edge (bb-edge BLOSSOM C B B) + :parent (bb-edge BLOSSOM C B B)) + (A :id (id 0) :children (list (vv-edge A B)) :internal-weight 2) + (B :id (id 2) :parent (vv-edge B A) + :children (list (bb-edge B B C BLOSSOM)) + :match-edge (bb-edge B B C BLOSSOM) + :positive? nil) + (C :id (id 4) :pistil BLOSSOM :internal-weight 2) + (D :id (id 6) :pistil BLOSSOM) + (E :id (id 8) :pistil BLOSSOM :internal-weight 2)) + (is (tree-equalp finished-tree target-tree))))))))) + +(deftest test-supervisor-contract-3-blossom-treetop () + "Checks the transformation + + + + + - + - + BLOSSOM - + + A --> B ==> C --> D ==> E --> [A --- B --- C] --> D ==> E + [\-----------/] +" + (with-with ((with-courier ()) + (with-simulation (simulation (*local-courier*))) + (with-address-dereferencing ())) + (let ((dryad-address (register))) + (blossom-let (original-tree :dryad dryad-address) + ((A :id (id 0) :children (list (vv-edge A B)) + :internal-weight 2 :paused? T) + (B :id (id 2) :parent (vv-edge B A) :children (list (vv-edge B C)) + :match-edge (vv-edge B C) :positive? nil) + (C :id (id 4) :parent (vv-edge C B) :children (list (vv-edge C D)) + :match-edge (vv-edge C B) :internal-weight 2) + (D :id (id 6) :parent (vv-edge D C) :children (list (vv-edge D E)) + :match-edge (vv-edge D E) :positive? nil) + (E :id (id 8) :parent (vv-edge E D) :internal-weight 2 + :match-edge (vv-edge E D))) + (let ((supervisor (supervisor simulation + :recommendation ':contract + :edges (list (vv-edge A C)) + :source-root (process-public-address A) + :target-root (process-public-address A) + :source-id (slot-value A 'anatevka::id)))) + (simulate-add-tree simulation original-tree) + (simulate-until-dead simulation supervisor) + (let* ((finished-blossom (dereference + (slot-value A 'anatevka::pistil))) + (finished-tree (list* finished-blossom original-tree))) + (blossom-let (target-tree :dryad dryad-address) + ((BLOSSOM :id (slot-value finished-blossom 'anatevka::id) + :dryad nil + :petals (list (vv-edge A C) + (vv-edge C B) + (vv-edge B A)) + :children (list (bb-edge BLOSSOM C D D))) + (A :id (id 0) :pistil BLOSSOM :internal-weight 2) + (B :id (id 2) :pistil BLOSSOM) + (C :id (id 4) :pistil BLOSSOM :internal-weight 2) + (D :id (id 6) :positive? nil :match-edge (vv-edge D E) + :parent (bb-edge D D C BLOSSOM) + :children (list (vv-edge D E))) + (E :id (id 8) :parent (vv-edge E D) :match-edge (vv-edge E D) + :internal-weight 2)) + (is (tree-equalp finished-tree target-tree))))))))) + +(deftest test-supervisor-contract-5-blossom-minimal () + "Checks the transformation + + + + - + BLOSSOM + B ==> C [B --- C] + ^ [| |] + | [| |] ++ A --> [A |] + | [| |] + v [| |] + D ==> E [D --- E] + - + +" + (with-with ((with-courier ()) + (with-simulation (simulation (*local-courier*))) + (with-address-dereferencing ())) + (let ((dryad-address (register))) + (blossom-let (original-tree :dryad dryad-address) + ((A :id (id 0 2) :children (list (vv-edge A B)) + :internal-weight 2 :paused? T) + (B :id (id 0 4) :parent (vv-edge B A) :children (list (vv-edge B C)) + :match-edge (vv-edge B C) :positive? nil) + (C :id (id 2 4) :parent (vv-edge C B) :match-edge (vv-edge C B) + :internal-weight 2) + (D :id (id 0 0) :parent (vv-edge D A) :children (list (vv-edge D E)) + :match-edge (vv-edge D E) :positive? nil) + (E :id (id 2 0) :parent (vv-edge E D) :internal-weight 2 + :match-edge (vv-edge E D))) + (let ((supervisor (supervisor simulation + :recommendation ':contract + :edges (list (vv-edge C E)) + :source-root (process-public-address A) + :target-root (process-public-address A) + :source-id (slot-value C 'anatevka::id)))) + (simulate-add-tree simulation original-tree) + (simulate-until-dead simulation supervisor) + (let* ((finished-blossom (dereference + (slot-value A 'anatevka::pistil))) + (finished-tree (list* finished-blossom original-tree))) + (blossom-let (target-tree :dryad dryad-address) + ((BLOSSOM :id (slot-value finished-blossom 'anatevka::id) + :dryad nil + :petals (list (vv-edge A B) + (vv-edge B C) + (vv-edge C E) + (vv-edge E D) + (vv-edge D A))) + (A :id (id 0 2) :pistil BLOSSOM :internal-weight 2) + (B :id (id 0 4) :pistil BLOSSOM) + (C :id (id 2 4) :pistil BLOSSOM :internal-weight 2) + (D :id (id 0 0) :pistil BLOSSOM) + (E :id (id 2 0) :pistil BLOSSOM :internal-weight 2)) + (is (tree-equalp finished-tree target-tree))))))))) + +(deftest test-supervisor-contract-5-blossom-duff () + "Checks the transformation + + + + - + BLOSSOM + D ==> E [D --- E] + ^ [| |] + + - | + - [| |] + A --> B ==> C + --> A --> B ==> [C |] + | [| |] + v [| |] + G ==> F [G --- F] + - + +" + (with-with ((with-courier ()) + (with-simulation (simulation (*local-courier*))) + (with-address-dereferencing ())) + (let ((dryad-address (register))) + (blossom-let (original-tree :dryad dryad-address) + ((A :id (id 0 2) :children (list (vv-edge A B)) + :internal-weight 2 :paused? T) + (B :id (id 2 2) :parent (vv-edge B A) :match-edge (vv-edge B C) + :positive? nil :children (list (vv-edge B C))) + (C :id (id 4 2) :parent (vv-edge C B) :match-edge (vv-edge C B) + :children (list (vv-edge C D) (vv-edge C G)) + :internal-weight 2) + (D :id (id 4 4) :parent (vv-edge D C) :children (list (vv-edge D E)) + :match-edge (vv-edge D E) :positive? nil) + (E :id (id 6 4) :parent (vv-edge E D) :match-edge (vv-edge E D) + :internal-weight 2) + (F :id (id 6 0) :parent (vv-edge F G) :match-edge (vv-edge F G) + :internal-weight 2) + (G :id (id 4 0) :parent (vv-edge G C) :children (list (vv-edge G F)) + :match-edge (vv-edge G F) :positive? nil)) + (let ((supervisor (supervisor simulation + :recommendation ':contract + :edges (list (vv-edge E F)) + :source-root (process-public-address A) + :target-root (process-public-address A) + :source-id (slot-value E 'anatevka::id)))) + (simulate-add-tree simulation original-tree) + (simulate-until-dead simulation supervisor) + (let* ((finished-blossom (dereference + (slot-value E 'anatevka::pistil))) + (finished-tree (list* finished-blossom original-tree))) + (blossom-let (target-tree :dryad dryad-address) + ((BLOSSOM :id (slot-value finished-blossom 'anatevka::id) + :dryad nil + :parent (bb-edge BLOSSOM C B B) + :match-edge (bb-edge BLOSSOM C B B) + :petals (list (vv-edge C D) + (vv-edge D E) + (vv-edge E F) + (vv-edge F G) + (vv-edge G C))) + (A :id (id 0 2) :children (list (vv-edge A B)) :internal-weight 2) + (B :id (id 2 2) :parent (vv-edge B A) + :match-edge (bb-edge B B C BLOSSOM) + :positive? nil + :children (list (bb-edge B B C BLOSSOM))) + (C :id (id 4 2) :pistil BLOSSOM :internal-weight 2) + (D :id (id 4 4) :pistil BLOSSOM) + (E :id (id 6 4) :pistil BLOSSOM :internal-weight 2) + (F :id (id 6 0) :pistil BLOSSOM :internal-weight 2) + (G :id (id 4 0) :pistil BLOSSOM)) + (is (tree-equalp finished-tree target-tree))))))))) + +(deftest test-supervisor-contract-5-blossom-treetop () + "Checks the transformation + + + + - + BLOSSOM + B ==> C [B --- C] + ^ [| |] + | [| |] ++ A --> [A |] + | [| |] + v [| |] + D ==> E --> F ==> G [D --- E] --> F ==> G + - + - + - + +" + (with-with ((with-courier ()) + (with-simulation (simulation (*local-courier*))) + (with-address-dereferencing ())) + (let ((dryad-address (register))) + (blossom-let (original-tree :dryad dryad-address) + ((A :id (id 0 2) :children (list (vv-edge A B)) + :internal-weight 2 :paused? T) + (B :id (id 0 4) :parent (vv-edge B A) :children (list (vv-edge B C)) + :match-edge (vv-edge B C) :positive? nil) + (C :id (id 2 4) :parent (vv-edge C B) :match-edge (vv-edge C B) + :internal-weight 2) + (D :id (id 0 0) :parent (vv-edge D A) :children (list (vv-edge D E)) + :match-edge (vv-edge D E) :positive? nil) + (E :id (id 2 0) :parent (vv-edge E D) :internal-weight 2 + :match-edge (vv-edge E D) :children (list (vv-edge E F))) + (F :id (id 4 0) :parent (vv-edge F E) :children (list (vv-edge F G)) + :match-edge (vv-edge F G) :positive? nil) + (G :id (id 6 0) :parent (vv-edge G F) :internal-weight 2 + :match-edge (vv-edge G F))) + (let ((supervisor (supervisor simulation + :recommendation ':contract + :edges (list (vv-edge C E)) + :source-root (process-public-address A) + :target-root (process-public-address A) + :source-id (slot-value C 'anatevka::id)))) + (simulate-add-tree simulation original-tree) + (simulate-until-dead simulation supervisor) + (let* ((finished-blossom (dereference + (slot-value A 'anatevka::pistil))) + (finished-tree (list* finished-blossom original-tree))) + (blossom-let (target-tree :dryad dryad-address) + ((BLOSSOM :id (slot-value finished-blossom 'anatevka::id) + :dryad nil + :children (list (bb-edge BLOSSOM E F F)) + :petals (list (vv-edge A B) + (vv-edge B C) + (vv-edge C E) + (vv-edge E D) + (vv-edge D A))) + (A :id (id 0 2) :pistil BLOSSOM :internal-weight 2) + (B :id (id 0 4) :pistil BLOSSOM) + (C :id (id 2 4) :pistil BLOSSOM :internal-weight 2) + (D :id (id 0 0) :pistil BLOSSOM) + (E :id (id 2 0) :pistil BLOSSOM :internal-weight 2) + (F :id (id 4 0) :parent (bb-edge F F E BLOSSOM) + :match-edge (vv-edge F G) + :positive? nil + :children (list (vv-edge F G))) + (G :id (id 6 0) :parent (vv-edge G F) + :internal-weight 2 + :match-edge (vv-edge G F))) + (is (tree-equalp finished-tree target-tree))))))))) diff --git a/tests/operations/expand.lisp b/tests/operations/expand.lisp new file mode 100644 index 0000000..da604d6 --- /dev/null +++ b/tests/operations/expand.lisp @@ -0,0 +1,365 @@ +;;;; tests/operations/expand.lisp +;;;; +;;;; Unit tests for the `EXPAND' supervisor action. +;;;; +;;;; NOTE: Supervisors expand inner blossoms only -- dryads handle barbells. + +(in-package #:anatevka-tests) + +(deftest test-supervisor-expand-inner-3-blossom-match/=parent () + "Checks the transformation + + - + BLOSSOM + - + + [ D] ==> E D ==> E + [ / |] --> ^ + [ / |] | + A --> [B --- C] A --> B ==> C + + + - + +" + (with-with ((with-courier ()) + (with-simulation (simulation (*local-courier*)))) + (let ((dryad-address (register))) + (blossom-let (original-tree :dryad dryad-address) + ((A :id (id 0) :children (list (bb-edge A A B BLOSSOM)) + :paused? T) + (B :id (id 2) :pistil BLOSSOM + :positive? nil :internal-weight 2) + (C :id (id 4) :pistil BLOSSOM + :positive? nil) + (D :id (id 4 2) :pistil BLOSSOM + :positive? nil :internal-weight 2) + (E :id (id 6 2) + :parent (bb-edge E E D BLOSSOM) + :match-edge (bb-edge E E D BLOSSOM)) + (BLOSSOM :id 'blossom + :petals (list (vv-edge B C) + (vv-edge C D) + (vv-edge D B)) + :parent (bb-edge BLOSSOM B A A) + :match-edge (bb-edge BLOSSOM D E E) + :positive? nil + :children (list (bb-edge BLOSSOM D E E)))) + (let ((supervisor (supervisor simulation + :edges (list (bb-edge BLOSSOM BLOSSOM + nil nil)) + :source-root (process-public-address A) + :target-root (process-public-address A) + :recommendation ':expand + :source-id (id 0)))) + (simulate-add-tree simulation original-tree) + (simulate-until-dead simulation supervisor) + (blossom-let (target-tree :dryad dryad-address) + ((A :id (id 0) + :children (list (vv-edge A B))) + (B :id (id 2) :internal-weight 2 :positive? nil + :parent (vv-edge B A) :match-edge (vv-edge B C) + :children (list (vv-edge B C))) + (C :id (id 4) + :parent (vv-edge C B) :match-edge (vv-edge C B) + :children (list (vv-edge C D))) + (D :id (id 4 2) :internal-weight 2 :positive? nil + :parent (vv-edge D C) :match-edge (vv-edge D E) + :children (list (vv-edge D E))) + (E :id (id 6 2) + :parent (vv-edge E D) :match-edge (vv-edge E D)) + (BLOSSOM :id 'blossom :dryad dryad-address + :petals (list (vv-edge B C) + (vv-edge C D) + (vv-edge D B)) + :parent (bb-edge BLOSSOM B A A) + :match-edge (bb-edge BLOSSOM D E E) + :positive? nil + :children (list (bb-edge BLOSSOM D E E)) + :wilting T)) + (is (tree-equalp original-tree target-tree)))))))) + +(deftest test-supervisor-expand-inner-3-blossom-match=parent () + "Checks the transformation (! means match in vertical direction) + + - + BLOSSOM + [ D] D + + [ / |] ! + [ / |] + - ! + A --> [B --- C] --> A --> B C + + + ! ! + v v + E E + + + +" + (with-with ((with-courier ()) + (with-simulation (simulation (*local-courier*)))) + (let ((dryad-address (register))) + (blossom-let (original-tree :dryad dryad-address) + ((A :id (id 0 2) + :children (list (bb-edge A A B BLOSSOM)) + :paused? T) + (B :id (id 2 2) :pistil BLOSSOM + :positive? nil :internal-weight 2) + (C :id (id 4 2) :pistil BLOSSOM + :positive? nil) + (D :id (id 4 4) :pistil BLOSSOM + :positive? nil :internal-weight 2) + (E :id (id 2 0) + :parent (bb-edge E E B BLOSSOM) + :match-edge (bb-edge E E B BLOSSOM)) + (BLOSSOM :id 'blossom + :petals (list (vv-edge B C) + (vv-edge C D) + (vv-edge D B)) + :parent (bb-edge BLOSSOM B A A) + :match-edge (bb-edge BLOSSOM B E E) + :positive? nil + :children (list (bb-edge BLOSSOM B E E)))) + (let ((supervisor (supervisor simulation + :edges (list (bb-edge BLOSSOM BLOSSOM + nil nil)) + :source-root (process-public-address A) + :target-root (process-public-address A) + :recommendation ':expand + :source-id (id 0 2)))) + (simulate-add-tree simulation original-tree) + (simulate-until-dead simulation supervisor) + (blossom-let (target-tree :dryad dryad-address) + ;; A --> B ==> E + ;; C === D + ((A :id (id 0 2) + :children (list (vv-edge A B))) + (B :id (id 2 2) :internal-weight 2 :positive? nil + :match-edge (vv-edge B E) + :parent (vv-edge B A) :children (list (vv-edge B E))) + (C :id (id 4 2) + :match-edge (vv-edge C D)) + (D :id (id 4 4) :internal-weight 2 + :match-edge (vv-edge D C)) + (E :id (id 2 0) + :match-edge (vv-edge E B) + :parent (vv-edge E B)) + (BLOSSOM :id 'blossom + :petals (list (vv-edge B C) + (vv-edge C D) + (vv-edge D B)) + :parent (bb-edge BLOSSOM B A A) + :match-edge (bb-edge BLOSSOM B E E) + :positive? nil + :children (list (bb-edge BLOSSOM B E E)) + :wilting T)) + (is (tree-equalp original-tree target-tree)))))))) + +(deftest test-supervisor-expand-inner-5-blossom-match/=parent () + "Checks the transformation (! means match in vertical direction) + + - + BLOSSOM + + - + + [F --- E] ==> G F ---> E ==> G + [| |] ^ + + [| |] ! + A --> [B |] --> A --> B + [| |] + - + [| |] + [C --- D] + C === D + +" + (with-with ((with-courier ()) + (with-simulation (simulation (*local-courier*)))) + (let ((dryad-address (register))) + (blossom-let (original-tree :dryad dryad-address) + ((A :id (id 0 2) + :children (list (bb-edge A A B BLOSSOM)) + :paused? T) + (B :id (id 2 2) :pistil BLOSSOM :positive? nil :internal-weight 2) + (C :id (id 2 0) :pistil BLOSSOM :positive? nil) + (D :id (id 4 0) :pistil BLOSSOM :positive? nil :internal-weight 2) + (E :id (id 4 4) :pistil BLOSSOM :positive? nil :internal-weight 2) + (F :id (id 2 4) :pistil BLOSSOM :positive? nil) + (G :id (id 6 4) + :parent (bb-edge G G E BLOSSOM) + :match-edge (bb-edge G G E BLOSSOM)) + (BLOSSOM :id 'blossom + :petals (list (vv-edge B C) + (vv-edge C D) + (vv-edge D E) + (vv-edge E F) + (vv-edge F B)) + :parent (bb-edge BLOSSOM B A A) + :match-edge (bb-edge BLOSSOM E G G) + :positive? nil + :children (list (bb-edge BLOSSOM E G G)))) + (let ((supervisor (supervisor simulation + :edges (list (bb-edge BLOSSOM BLOSSOM + nil nil)) + :source-root (process-public-address A) + :target-root (process-public-address A) + :recommendation ':expand + :source-id (id 0 2)))) + (simulate-add-tree simulation original-tree) + (simulate-until-dead simulation supervisor) + ;; A --> B ==> F --> E ==> G + ;; C === D + (blossom-let (target-tree :dryad dryad-address) + ((A :id (id 0 2) :children (list (vv-edge A B))) + (B :id (id 2 2) :match-edge (vv-edge B F) + :parent (vv-edge B A) :children (list (vv-edge B F)) + :internal-weight 2 :positive? nil) + (C :id (id 2 0) :match-edge (vv-edge C D)) + (D :id (id 4 0) :match-edge (vv-edge D C) + :internal-weight 2) + (E :id (id 4 4) :match-edge (vv-edge E G) + :parent (vv-edge E F) :children (list (vv-edge E G)) + :internal-weight 2 :positive? nil) + (F :id (id 2 4) :match-edge (vv-edge F B) + :parent (vv-edge F B) :children (list (vv-edge F E))) + (G :id (id 6 4) :match-edge (vv-edge G E) + :parent (vv-edge G E)) + (BLOSSOM :id 'blossom + :petals (list (vv-edge B C) + (vv-edge C D) + (vv-edge D E) + (vv-edge E F) + (vv-edge F B)) + :parent (bb-edge BLOSSOM B A A) + :match-edge (bb-edge BLOSSOM E G G) + :positive? nil + :children (list (bb-edge BLOSSOM E G G)) + :wilting T)) + (is (tree-equalp original-tree target-tree)))))))) + +(deftest test-supervisor-expand-inner-5-blossom-match=parent () + "Checks the transformation (! means match in vertical direction) + + - + BLOSSOM + + + [F --- E] F === E + [| |] + [| |] + [| D] --> D + + [| |] ! + [| |] + - ! + A --> [B --- C] A --> B C + + + ! ! + v v + G + G + +" + (with-with ((with-courier ()) + (with-simulation (simulation (*local-courier*)))) + (let ((dryad-address (register))) + (blossom-let (original-tree :dryad dryad-address) + ((A :id (id 0 2) + :children (list (bb-edge A A B BLOSSOM)) + :paused? T) + (B :id (id 2 2) :pistil BLOSSOM :positive? nil :internal-weight 2) + (C :id (id 4 2) :pistil BLOSSOM :positive? nil) + (D :id (id 4 4) :pistil BLOSSOM :positive? nil :internal-weight 2) + (E :id (id 4 6) :pistil BLOSSOM :positive? nil) + (F :id (id 2 6) :pistil BLOSSOM :positive? nil :internal-weight 2) + (G :id (id 2 0) + :parent (bb-edge G G B BLOSSOM) + :match-edge (bb-edge G G B BLOSSOM)) + (BLOSSOM :id 'blossom + :petals (list (vv-edge B C) + (vv-edge C D) + (vv-edge D E) + (vv-edge E F) + (vv-edge F B)) + :parent (bb-edge BLOSSOM B A A) + :match-edge (bb-edge BLOSSOM B G G) + :positive? nil + :children (list (bb-edge BLOSSOM B G G)))) + (let ((supervisor (supervisor simulation + :edges (list (bb-edge BLOSSOM BLOSSOM + nil nil)) + :source-root (process-public-address A) + :target-root (process-public-address A) + :recommendation ':expand + :source-id (id 0 2)))) + (simulate-add-tree simulation original-tree) + (simulate-until-dead simulation supervisor) + ;; A --> B ==> G + ;; C === D + ;; F === E + (blossom-let (target-tree :dryad dryad-address) + ((A :id (id 0 2) + :children (list (vv-edge A B))) + (B :id (id 2 2) :match-edge (vv-edge B G) :internal-weight 2 + :parent (vv-edge B A) :children (list (vv-edge B G)) + :positive? nil) + (C :id (id 4 2) :match-edge (vv-edge C D)) + (D :id (id 4 4) :match-edge (vv-edge D C) :internal-weight 2) + (E :id (id 4 6) :match-edge (vv-edge E F)) + (F :id (id 2 6) :match-edge (vv-edge F E) :internal-weight 2) + (G :id (id 2 0) :match-edge (vv-edge G B) + :parent (vv-edge G B)) + (BLOSSOM :id 'blossom + :petals (list (vv-edge B C) + (vv-edge C D) + (vv-edge D E) + (vv-edge E F) + (vv-edge F B)) + :parent (bb-edge BLOSSOM B A A) + :match-edge (bb-edge BLOSSOM B G G) + :positive? nil + :children (list (bb-edge BLOSSOM B G G)) + :wilting T)) + (is (tree-equalp original-tree target-tree)))))))) + +(deftest test-supervisor-expand-blossom-blossom-barbell () + "Checks the transformation (! means match in vertical direction) + + BLOSSOM1 BLOSSOM2 BLOSSOM2 +[A --- B] === [D --- E] A B === [D --- E] +[| / ] [| / ] ! [| / ] +[| / ] [| / ] --> ! [| / ] +[| / ] [| / ] ! [| / ] +[C ] [F ] C [F ] +" + (with-with ((with-courier ()) + (with-simulation (simulation (*local-courier*)))) + (let ((dryad-address (register))) + (blossom-let (original-tree :dryad dryad-address + :positive? nil) + ((A :id (id 0 0) :pistil BLOSSOM1) + (B :id (id 2 0) :pistil BLOSSOM1 :internal-weight 2) + (C :id (id 0 2) :pistil BLOSSOM1 :internal-weight 2) + (D :id (id 4 0) :pistil BLOSSOM2) + (E :id (id 6 0) :pistil BLOSSOM2 :internal-weight 2) + (F :id (id 4 2) :pistil BLOSSOM2 :internal-weight 2) + (BLOSSOM1 :id 'blossom1 + :petals (list (vv-edge A B) + (vv-edge B C) + (vv-edge C A)) + :match-edge (bb-edge BLOSSOM1 B D BLOSSOM2) + :positive? t) + (BLOSSOM2 :id 'blossom2 + :petals (list (vv-edge D E) + (vv-edge E F) + (vv-edge F D)) + :match-edge (bb-edge BLOSSOM2 D B BLOSSOM1) + :positive? t)) + (send-message (process-public-address BLOSSOM1) + (anatevka::make-message-expand)) + (simulate-add-tree simulation original-tree) + (simulate-until-dead simulation BLOSSOM1) + (blossom-let (target-tree :dryad dryad-address) + ((A :id (id 0 0) :positive? t + :match-edge (vv-edge A C)) + (B :id (id 2 0) :positive? t :internal-weight 2 + :match-edge (bb-edge B B D BLOSSOM2)) + (C :id (id 0 2) :positive? t :internal-weight 2 + :match-edge (vv-edge C A)) + (D :id (id 4 0) :pistil BLOSSOM2 :positive? nil) + (E :id (id 6 0) :pistil BLOSSOM2 :positive? nil :internal-weight 2) + (F :id (id 4 2) :pistil BLOSSOM2 :positive? nil :internal-weight 2) + (BLOSSOM1 :id 'blossom1 + :petals (list (vv-edge A B) + (vv-edge B C) + (vv-edge C A)) + :match-edge (bb-edge BLOSSOM1 B D BLOSSOM2) + :positive? t + :wilting t) + (BLOSSOM2 :id 'blossom2 + :petals (list (vv-edge D E) + (vv-edge E F) + (vv-edge F D)) + :match-edge (bb-edge BLOSSOM2 D B B) + :positive? t)) + (is (tree-equalp original-tree target-tree))))))) diff --git a/tests/operations/graft.lisp b/tests/operations/graft.lisp new file mode 100644 index 0000000..969883c --- /dev/null +++ b/tests/operations/graft.lisp @@ -0,0 +1,39 @@ +;;;; tests/operations/graft.lisp +;;;; +;;;; Unit tests for the `GRAFT' supervisor action. + +(in-package #:anatevka-tests) + +(deftest test-supervisor-graft-sapling () + "Checks the transformation + ++ + + + - + +A ~~~ B == C --> A --> B ==> C" + (with-with ((with-courier ()) + (with-simulation (simulation (*local-courier*)))) + (blossom-let (original-tree) + ((sapling :id (id 0) :internal-weight 2 :paused? T) + (left-node :id (id 2) :match-edge (vv-edge left-node right-node)) + (right-node :id (id 4) :internal-weight 2 + :match-edge (vv-edge right-node left-node))) + (let ((supervisor (supervisor simulation + :edges (list (vv-edge left-node right-node) + (vv-edge sapling left-node)) + :source-root (process-public-address sapling) + :target-root (process-public-address left-node) + :recommendation ':graft + :source-id (id 0)))) + (simulate-add-tree simulation original-tree) + (simulate-until-dead simulation supervisor) + (blossom-let (target-tree) + ((root :id (id 0) :internal-weight 2 + :children (list (vv-edge root inner-node))) + (inner-node :id (id 2) + :match-edge (vv-edge inner-node outer-node) + :parent (vv-edge inner-node root) + :children (list (vv-edge inner-node outer-node)) + :positive? nil) + (outer-node :id (id 4) :internal-weight 2 + :match-edge (vv-edge outer-node inner-node) + :parent (vv-edge outer-node inner-node))) + (is (tree-equalp original-tree target-tree))))))) diff --git a/tests/operations/multireweight.lisp b/tests/operations/multireweight.lisp new file mode 100644 index 0000000..82c88cf --- /dev/null +++ b/tests/operations/multireweight.lisp @@ -0,0 +1,1277 @@ +;;;; tests/operations/multireweight.lisp +;;;; +;;;; Unit tests for the `MULTIREWEIGHT' supervisor action. + +(in-package #:anatevka-tests) + +(deftest test-supervisor-multireweight-interlock-aligned () + "Checks the transformation + + 0 0 4 2 2 2 + + + - + + - + A D <==== E <-- A D <==== E <-- + ^ | --> ^ | + ! | ! | + == B <---- C F == B <---- C F + - + + - + + + 4 0 0 2 2 2 + +d(B, D) = 4 and d(C, E) = 4 +" + (with-with ((with-courier ()) + (with-simulation (simulation (*local-courier*))) + (with-address-dereferencing ())) + (let* ((dryad (spawn-process 'dryad :match-address (register) + :debug? t)) + (dryad-address (process-public-address dryad))) + (blossom-let (original-tree :dryad dryad-address) + ((A :id (id 0 2) + :match-edge (vv-edge A B) + :parent (vv-edge A B)) + (B :id (id 2 0) + :children (list (vv-edge B A)) + :internal-weight 4 + :match-edge (vv-edge B A) + :parent (vv-edge B C) + :positive? nil) + (C :id (id 6 0) + :children (list (vv-edge C B)) + :held-by-roots (list F) + :paused? T) + (D :id (id 4 2) + :match-edge (vv-edge D E) + :parent (vv-edge D E)) + (E :id (id 8 2) + :children (list (vv-edge E D)) + :internal-weight 4 + :match-edge (vv-edge E D) + :parent (vv-edge E F) + :positive? nil) + (F :id (id 10 0) + :children (list (vv-edge F E)) + :held-by-roots (list C))) + (let ((supervisor (supervisor simulation + :recommendation ':hold + :weight 0 + :edges (list (vv-edge B D)) + :source-root (process-public-address C) + :target-root (process-public-address F) + :source-id (slot-value B 'anatevka::id) + :root-bucket (list (process-public-address F))))) + (simulate-add-tree simulation original-tree) + + ;; fill the dryad and add it to the simulation + (dolist (node original-tree) + (let* ((id (slot-value node 'anatevka::id)) + (address (process-public-address node))) + (setf (gethash address (anatevka::dryad-ids dryad)) id + (gethash address (anatevka::dryad-sprouted? dryad)) nil))) + (simulation-add-event simulation (make-event :callback dryad)) + + (simulate-until-dead simulation supervisor) + (blossom-let (target-tree :dryad dryad-address) + ((A :id (id 0 2) + :match-edge (vv-edge A B) + :parent (vv-edge A B) + :internal-weight 2) + (B :id (id 2 0) + :children (list (vv-edge B A)) + :internal-weight 2 + :match-edge (vv-edge B A) + :parent (vv-edge B C) + :positive? nil) + (C :id (id 6 0) + :children (list (vv-edge C B)) + :internal-weight 2) + (D :id (id 4 2) + :internal-weight 2 + :match-edge (vv-edge D E) + :parent (vv-edge D E)) + (E :id (id 8 2) + :children (list (vv-edge E D)) + :internal-weight 2 + :match-edge (vv-edge E D) + :parent (vv-edge E F) + :positive? nil) + (F :id (id 10 0) + :internal-weight 2 + :children (list (vv-edge F E)))) + (is (tree-equalp original-tree target-tree)))))))) + +(deftest test-supervisor-multireweight-interlock-mirrored () + "Checks the transformation + + 0 0 4 2 2 2 + + + - + + - + A D <==== E <-- A D <==== E <-- + | | --> | | + | | | | + --> B ====> C F --> B ====> C F + - + + - + + + 4 0 0 2 2 2 + +d(B, D) = 4 and d(C, E) = 4 +" + (with-with ((with-courier ()) + (with-simulation (simulation (*local-courier*))) + (with-address-dereferencing ())) + (let* ((dryad (spawn-process 'dryad :match-address (register) + :debug? t)) + (dryad-address (process-public-address dryad))) + (blossom-let (original-tree :dryad dryad-address) + ((A :id (id 0 2) + :children (list (vv-edge A B)) + :held-by-roots (list F) + :paused? T) + (B :id (id 2 0) + :children (list (vv-edge B C)) + :internal-weight 4 + :match-edge (vv-edge B C) + :parent (vv-edge B A) + :positive? nil) + (C :id (id 6 0) + :match-edge (vv-edge C B) + :parent (vv-edge C B)) + (D :id (id 4 2) + :match-edge (vv-edge D E) + :parent (vv-edge D E)) + (E :id (id 8 2) + :children (list (vv-edge E D)) + :internal-weight 4 + :match-edge (vv-edge E D) + :parent (vv-edge E F) + :positive? nil) + (F :id (id 10 0) + :children (list (vv-edge F E)) + :held-by-roots (list A))) + (let ((supervisor (supervisor simulation + :recommendation ':hold + :weight 0 + :edges (list (vv-edge C E)) + :source-root (process-public-address A) + :target-root (process-public-address F) + :source-id (slot-value C 'anatevka::id) + :root-bucket (list (process-public-address F))))) + (simulate-add-tree simulation original-tree) + + ;; fill the dryad and add it to the simulation + (dolist (node original-tree) + (let* ((id (slot-value node 'anatevka::id)) + (address (process-public-address node))) + (setf (gethash address (anatevka::dryad-ids dryad)) id + (gethash address (anatevka::dryad-sprouted? dryad)) nil))) + (simulation-add-event simulation (make-event :callback dryad)) + + (simulate-until-dead simulation supervisor) + (blossom-let (target-tree :dryad dryad-address) + ((A :id (id 0 2) + :children (list (vv-edge A B)) + :internal-weight 2) + (B :id (id 2 0) + :children (list (vv-edge B C)) + :internal-weight 2 + :match-edge (vv-edge B C) + :parent (vv-edge B A) + :positive? nil) + (C :id (id 6 0) + :internal-weight 2 + :match-edge (vv-edge C B) + :parent (vv-edge C B)) + (D :id (id 4 2) + :internal-weight 2 + :match-edge (vv-edge D E) + :parent (vv-edge D E)) + (E :id (id 8 2) + :children (list (vv-edge E D)) + :internal-weight 2 + :match-edge (vv-edge E D) + :parent (vv-edge E F) + :positive? nil) + (F :id (id 10 0) + :internal-weight 2 + :children (list (vv-edge F E)))) + (is (tree-equalp original-tree target-tree)))))))) + +(deftest test-supervisor-multireweight-outerlock-aligned () + "Checks the transformation + + 0 0 4 2 2 2 + + + - + + - + A D --> E == A D --> E == + | ^ | ! --> | ^ | ! + | ! | v | ! | v + --> B == C F --> B == C F + - + + - + + + 4 0 0 2 2 2 + +d(C, D) = 4 +" + (with-with ((with-courier ()) + (with-simulation (simulation (*local-courier*))) + (with-address-dereferencing ())) + (let* ((dryad (spawn-process 'dryad :match-address (register) + :debug? t)) + (dryad-address (process-public-address dryad))) + (blossom-let (original-tree :dryad dryad-address) + ((A :id (id 0 2) + :children (list (vv-edge A B)) + :held-by-roots (list C) + :paused? T) + (B :id (id 2 0) + :children (list (vv-edge B D)) + :internal-weight 4 + :match-edge (vv-edge B D) + :parent (vv-edge B A) + :positive? nil) + (C :id (id 6 0) + :children (list (vv-edge C E)) + :held-by-roots (list A)) + (D :id (id 4 2) + :match-edge (vv-edge D B) + :parent (vv-edge D B)) + (E :id (id 8 2) + :children (list (vv-edge E F)) + :internal-weight 4 + :match-edge (vv-edge E F) + :parent (vv-edge E C) + :positive? nil) + (F :id (id 10 0) + :match-edge (vv-edge F E) + :parent (vv-edge F E))) + (let ((supervisor (supervisor simulation + :recommendation ':hold + :weight 0 + :edges (list (vv-edge B C)) + :source-root (process-public-address A) + :target-root (process-public-address C) + :source-id (slot-value B 'anatevka::id) + :root-bucket (list (process-public-address C))))) + (simulate-add-tree simulation original-tree) + + ;; fill the dryad and add it to the simulation + (dolist (node original-tree) + (let* ((id (slot-value node 'anatevka::id)) + (address (process-public-address node))) + (setf (gethash address (anatevka::dryad-ids dryad)) id + (gethash address (anatevka::dryad-sprouted? dryad)) nil))) + (simulation-add-event simulation (make-event :callback dryad)) + + (simulate-until-dead simulation supervisor) + (blossom-let (target-tree :dryad dryad-address) + ((A :id (id 0 2) + :children (list (vv-edge A B)) + :internal-weight 2) + (B :id (id 2 0) + :children (list (vv-edge B D)) + :internal-weight 2 + :match-edge (vv-edge B D) + :parent (vv-edge B A) + :positive? nil) + (C :id (id 6 0) + :children (list (vv-edge C E)) + :internal-weight 2) + (D :id (id 4 2) + :internal-weight 2 + :match-edge (vv-edge D B) + :parent (vv-edge D B)) + (E :id (id 8 2) + :children (list (vv-edge E F)) + :internal-weight 2 + :match-edge (vv-edge E F) + :parent (vv-edge E C) + :positive? nil) + (F :id (id 10 0) + :internal-weight 2 + :match-edge (vv-edge F E) + :parent (vv-edge F E))) + (is (tree-equalp original-tree target-tree)))))))) + +(deftest test-supervisor-multireweight-outerlock-mirrored () + "Checks the transformation + + 0 0 4 2 2 2 + + + - + + - + A D == E <-- A D == E <-- + | ^ ! | --> | ^ ! | + | ! V | | ! v | + --> B == C F --> B == C F + - + + - + + + 4 0 0 2 2 2 + +d(C, D) = 4 +" + (with-with ((with-courier ()) + (with-simulation (simulation (*local-courier*))) + (with-address-dereferencing ())) + (let* ((dryad (spawn-process 'dryad :match-address (register) + :debug? t)) + (dryad-address (process-public-address dryad))) + (blossom-let (original-tree :dryad dryad-address) + ((A :id (id 0 2) + :children (list (vv-edge A B)) + :held-by-roots (list F) + :paused? T) + (B :id (id 2 0) + :children (list (vv-edge B D)) + :internal-weight 4 + :match-edge (vv-edge B D) + :parent (vv-edge B A) + :positive? nil) + (C :id (id 6 0) + :match-edge (vv-edge C E) + :parent (vv-edge C E)) + (D :id (id 4 2) + :match-edge (vv-edge D B) + :parent (vv-edge D B)) + (E :id (id 8 2) + :children (list (vv-edge E C)) + :internal-weight 4 + :match-edge (vv-edge E C) + :parent (vv-edge E F) + :positive? nil) + (F :id (id 10 0) + :children (list (vv-edge F E)) + :held-by-roots (list A))) + (let ((supervisor (supervisor simulation + :recommendation ':hold + :weight 0 + :edges (list (vv-edge D E)) + :source-root (process-public-address A) + :target-root (process-public-address F) + :source-id (slot-value D 'anatevka::id) + :root-bucket (list (process-public-address F))))) + (simulate-add-tree simulation original-tree) + + ;; fill the dryad and add it to the simulation + (dolist (node original-tree) + (let* ((id (slot-value node 'anatevka::id)) + (address (process-public-address node))) + (setf (gethash address (anatevka::dryad-ids dryad)) id + (gethash address (anatevka::dryad-sprouted? dryad)) nil))) + (simulation-add-event simulation (make-event :callback dryad)) + + (simulate-until-dead simulation supervisor) + (blossom-let (target-tree :dryad dryad-address) + ((A :id (id 0 2) + :children (list (vv-edge A B)) + :internal-weight 2) + (B :id (id 2 0) + :children (list (vv-edge B D)) + :internal-weight 2 + :match-edge (vv-edge B D) + :parent (vv-edge B A) + :positive? nil) + (C :id (id 6 0) + :internal-weight 2 + :match-edge (vv-edge C E) + :parent (vv-edge C E)) + (D :id (id 4 2) + :internal-weight 2 + :match-edge (vv-edge D B) + :parent (vv-edge D B)) + (E :id (id 8 2) + :children (list (vv-edge E C)) + :internal-weight 2 + :match-edge (vv-edge E C) + :parent (vv-edge E F) + :positive? nil) + (F :id (id 10 0) + :children (list (vv-edge F E)) + :internal-weight 2)) + (is (tree-equalp original-tree target-tree)))))))) + +(deftest test-supervisor-multireweight-full-external-rec () + "Checks the transformation + + 0 0 4 1 1 3 + + + - + + - + A D <==== E <-- A D <==== E <-- + | | --> | | + | | | | + --> B ====> C F G --> B ====> C F G + - + + + - + + + + 4 0 0 0 3 1 1 0 + +d(B, D) = 4 and d(C, E) = 4 and d(F, G) = 1 + +The point of this test is to show that when the best recommendation in the +local area is not in the `root-set' of the `MULTIREWEIGHT' operation, we +should reweight all deadlocked trees by the full weight of that recommendation +rather than half of its weight (like we do for inter-tree recommendations). +" + (with-with ((with-courier ()) + (with-simulation (simulation (*local-courier*))) + (with-address-dereferencing ())) + (let* ((dryad (spawn-process 'dryad :match-address (register) + :debug? t)) + (dryad-address (process-public-address dryad))) + (blossom-let (original-tree :dryad dryad-address) + ((A :id (id 0 2) + :children (list (vv-edge A B)) + :held-by-roots (list F) + :paused? T) + (B :id (id 2 0) + :children (list (vv-edge B C)) + :internal-weight 4 + :match-edge (vv-edge B C) + :parent (vv-edge B A) + :positive? nil) + (C :id (id 6 0) + :match-edge (vv-edge C B) + :parent (vv-edge C B)) + (D :id (id 4 2) + :match-edge (vv-edge D E) + :parent (vv-edge D E)) + (E :id (id 8 2) + :children (list (vv-edge E D)) + :internal-weight 4 + :match-edge (vv-edge E D) + :parent (vv-edge E F) + :positive? nil) + (F :id (id 10 0) + :children (list (vv-edge F E)) + :held-by-roots (list A)) + (G :id (id 11 0))) + (let ((supervisor (supervisor simulation + :recommendation ':hold + :weight 0 + :edges (list (vv-edge C E)) + :source-root (process-public-address A) + :target-root (process-public-address F) + :source-id (slot-value C 'anatevka::id) + :root-bucket (list (process-public-address F))))) + (simulate-add-tree simulation original-tree) + + ;; fill the dryad and add it to the simulation + (dolist (node original-tree) + (let* ((id (slot-value node 'anatevka::id)) + (address (process-public-address node)) + (sprouted? (not (null (anatevka::blossom-node-match-edge node))))) + (setf (gethash address (anatevka::dryad-ids dryad)) id + (gethash address (anatevka::dryad-sprouted? dryad)) sprouted?))) + (simulation-add-event simulation (make-event :callback dryad)) + + (simulate-until-dead simulation supervisor) + (blossom-let (target-tree :dryad dryad-address) + ((A :id (id 0 2) + :children (list (vv-edge A B)) + :internal-weight 1) + (B :id (id 2 0) + :children (list (vv-edge B C)) + :internal-weight 3 + :match-edge (vv-edge B C) + :parent (vv-edge B A) + :positive? nil) + (C :id (id 6 0) + :internal-weight 1 + :match-edge (vv-edge C B) + :parent (vv-edge C B)) + (D :id (id 4 2) + :internal-weight 1 + :match-edge (vv-edge D E) + :parent (vv-edge D E)) + (E :id (id 8 2) + :children (list (vv-edge E D)) + :internal-weight 3 + :match-edge (vv-edge E D) + :parent (vv-edge E F) + :positive? nil) + (F :id (id 10 0) + :internal-weight 1 + :children (list (vv-edge F E))) + (G :id (id 11 0))) + (is (tree-equalp original-tree target-tree)))))))) + +(deftest test-supervisor-multireweight-contract-wins () + "Checks the transformation + + 1 1 4 2 2 3 + + + - + + - + A D --> E == A D --> E == + | ^ | ! | ^ | ! + | ! | ! --> | ! | ! + | ! | ! | ! | ! + | ! | v | ! | v + --> B == C F --> B == C F + - + + - + + + 4 1 1 3 2 2 + +d(C, D) = 6 - 1 - 1 = 4, A = (2, 4) + +The point of this test is to show that when the best recommendation is +`CONTRACT', we cannot actually ignore it. We can see that there are two weight-1 +blossom-contraction operations available, but the only inter-tree operation is +an `AUGMENT' of distance 4. Inter-tree augmentation weights are halved, so the +effective weight is 2, but that is still higher than the `CONTRACT' weight. +Previously, the augmentation would have won because we were discarding blossom +contraction recommendations as if they were as inconsequential as internal +`HOLD's. However, they actually indicate real distance constraints, namely, the +distance between pairs of outer nodes in the same tree. Therefore, we cannot +reweight by 2, even though that is what the `AUGMENT' recommends, because our +`CONTRACT' tells us that would result in a negative-weight edge. +" + (with-with ((with-courier ()) + (with-simulation (simulation (*local-courier*))) + (with-address-dereferencing ())) + (let* ((dryad (spawn-process 'dryad :match-address (register) + :debug? t)) + (dryad-address (process-public-address dryad))) + (blossom-let (original-tree :dryad dryad-address) + ((A :id (id 2 4) + :internal-weight 1 + :children (list (vv-edge A B)) + :held-by-roots (list C) + :paused? T) + (B :id (id 4 0) + :children (list (vv-edge B D)) + :internal-weight 5 + :match-edge (vv-edge B D) + :parent (vv-edge B A) + :positive? nil) + (C :id (id 10 0) + :internal-weight 1 + :children (list (vv-edge C E)) + :held-by-roots (list A)) + (D :id (id 6 4) + :internal-weight 1 + :match-edge (vv-edge D B) + :parent (vv-edge D B)) + (E :id (id 12 4) + :children (list (vv-edge E F)) + :internal-weight 5 + :match-edge (vv-edge E F) + :parent (vv-edge E C) + :positive? nil) + (F :id (id 14 0) + :internal-weight 1 + :match-edge (vv-edge F E) + :parent (vv-edge F E))) + (let ((supervisor (supervisor simulation + :recommendation ':hold + :weight 0 + :edges (list (vv-edge B C)) + :source-root (process-public-address A) + :target-root (process-public-address C) + :source-id (slot-value A 'anatevka::id) + :root-bucket (list (process-public-address C))))) + (simulate-add-tree simulation original-tree) + + ;; fill the dryad and add it to the simulation + (dolist (node original-tree) + (let* ((id (slot-value node 'anatevka::id)) + (address (process-public-address node))) + (setf (gethash address (anatevka::dryad-ids dryad)) id + (gethash address (anatevka::dryad-sprouted? dryad)) nil))) + (simulation-add-event simulation (make-event :callback dryad)) + + (simulate-until-dead simulation supervisor) + (blossom-let (target-tree :dryad dryad-address) + ((A :id (id 2 4) + :internal-weight 2 + :children (list (vv-edge A B))) + (B :id (id 4 0) + :children (list (vv-edge B D)) + :internal-weight 4 + :match-edge (vv-edge B D) + :parent (vv-edge B A) + :positive? nil) + (C :id (id 10 0) + :internal-weight 2 + :children (list (vv-edge C E))) + (D :id (id 6 4) + :internal-weight 2 + :match-edge (vv-edge D B) + :parent (vv-edge D B)) + (E :id (id 12 4) + :children (list (vv-edge E F)) + :internal-weight 4 + :match-edge (vv-edge E F) + :parent (vv-edge E C) + :positive? nil) + (F :id (id 14 0) + :internal-weight 2 + :match-edge (vv-edge F E) + :parent (vv-edge F E))) + (is (tree-equalp original-tree target-tree)))))))) + +(deftest test-supervisor-multireweight-simultaneous-aggregation () + "Checks the transformation + + 0 0 4 2 2 2 + + + - + + - + A D <==== E <-- A D <==== E <-- + ^ | --> ^ | + ! | ! | + == B <---- C F == B <---- C F + - + + - + + + 4 0 0 2 2 2 + +d(B, D) = 4 and d(C, E) = 4 + +The point of this is to show that simultaneous root-set aggregation in multireweighting won't cause deadlock like it used to. +" + (with-with ((with-courier ()) + (with-simulation (simulation (*local-courier*))) + (with-address-dereferencing ())) + (let* ((dryad (spawn-process 'dryad :match-address (register) + :debug? t)) + (dryad-address (process-public-address dryad))) + (blossom-let (original-tree :dryad dryad-address) + ((A :id (id 0 2) + :match-edge (vv-edge A B) + :parent (vv-edge A B)) + (B :id (id 2 0) + :children (list (vv-edge B A)) + :internal-weight 4 + :match-edge (vv-edge B A) + :parent (vv-edge B C) + :positive? nil) + (C :id (id 6 0) + :children (list (vv-edge C B)) + :held-by-roots (list F) + :paused? T) + (D :id (id 4 2) + :match-edge (vv-edge D E) + :parent (vv-edge D E)) + (E :id (id 8 2) + :children (list (vv-edge E D)) + :internal-weight 4 + :match-edge (vv-edge E D) + :parent (vv-edge E F) + :positive? nil) + (F :id (id 10 0) + :children (list (vv-edge F E)) + :held-by-roots (list C) + :paused? T)) + (let ((supervisor-left (supervisor simulation + :recommendation ':hold + :weight 0 + :edges (list (vv-edge D B)) + :source-root (process-public-address F) + :target-root (process-public-address C) + :source-id (slot-value D 'anatevka::id) + :root-bucket (list + (process-public-address C)))) + (supervisor-right (supervisor simulation + :recommendation ':hold + :weight 0 + :edges (list (vv-edge B D)) + :source-root (process-public-address C) + :target-root (process-public-address F) + :source-id (slot-value B 'anatevka::id) + :root-bucket (list (process-public-address F))))) + (simulate-add-tree simulation original-tree) + + ;; fill the dryad and add it to the simulation + (dolist (node original-tree) + (let* ((id (slot-value node 'anatevka::id)) + (address (process-public-address node)) + (sprouted? (not (null (anatevka::blossom-node-match-edge node))))) + (setf (gethash address (anatevka::dryad-ids dryad)) id + (gethash address (anatevka::dryad-sprouted? dryad)) sprouted?))) + (simulation-add-event simulation (make-event :callback dryad)) + + (simulate-until-dead simulation supervisor-left) + (simulate-until-dead simulation supervisor-right) + (blossom-let (target-tree :dryad dryad-address) + ((A :id (id 0 2) + :match-edge (vv-edge A B) + :parent (vv-edge A B) + :internal-weight 2) + (B :id (id 2 0) + :children (list (vv-edge B A)) + :internal-weight 2 + :match-edge (vv-edge B A) + :parent (vv-edge B C) + :positive? nil) + (C :id (id 6 0) + :children (list (vv-edge C B)) + :internal-weight 2) + (D :id (id 4 2) + :internal-weight 2 + :match-edge (vv-edge D E) + :parent (vv-edge D E)) + (E :id (id 8 2) + :children (list (vv-edge E D)) + :internal-weight 2 + :match-edge (vv-edge E D) + :parent (vv-edge E F) + :positive? nil) + (F :id (id 10 0) + :internal-weight 2 + :children (list (vv-edge F E)))) + (is (tree-equalp original-tree target-tree)))))))) + +(deftest test-supervisor-multireweight-simultaneous-rewind-halfway () + "Checks the transformation + + 0 2 0 0 2 0 1 1 1 1 1 1 + + - + + - + + - + + - + + A -> B => C J <= K <- L A -> B => C J <= K <- L + --> + D -> E => F G <= H <- I D -> E => F G <= H <- I + + - + + - + + - + + - + + 0 2 0 0 2 0 1 1 1 1 1 1 + +d(B, D), d(F, G), d(H, J) = 2 + +The point of this is to show that simultaneous reweighting and rewinding during multireweighting won't cause a negative-weight edge (all roots in the root-set are rewound) and for inter-root-set distances > 1 the algorithm will progress. +" + (with-with ((with-courier ()) + (with-simulation (simulation (*local-courier*))) + (with-address-dereferencing ())) + (let* ((dryad (spawn-process 'dryad :match-address (register) + :debug? t)) + (dryad-address (process-public-address dryad))) + (blossom-let (original-tree :dryad dryad-address) + ((A :id (id 0 2) + :children (list (vv-edge A B)) + :held-by-roots (list D) + :paused? T) + (B :id (id 2 2) + :children (list (vv-edge B C)) + :internal-weight 2 + :match-edge (vv-edge B C) + :parent (vv-edge B A) + :positive? nil) + (C :id (id 4 2) + :match-edge (vv-edge C B) + :parent (vv-edge C B)) + (D :id (id 2 0) + :children (list (vv-edge D E)) + :held-by-roots (list A)) + (E :id (id 4 0) + :children (list (vv-edge E F)) + :internal-weight 2 + :match-edge (vv-edge E F) + :parent (vv-edge E D) + :positive? nil) + (F :id (id 6 0) + :match-edge (vv-edge F E) + :parent (vv-edge F E)) + (G :id (id 8 0) + :match-edge (vv-edge G H) + :parent (vv-edge G H)) + (H :id (id 10 0) + :children (list (vv-edge H G)) + :internal-weight 2 + :match-edge (vv-edge H G) + :parent (vv-edge H I) + :positive? nil) + (I :id (id 12 0) + :children (list (vv-edge I H)) + :held-by-roots (list L) + :paused? T) + (J :id (id 10 2) + :match-edge (vv-edge J K) + :parent (vv-edge J K)) + (K :id (id 12 2) + :children (list (vv-edge K J)) + :internal-weight 2 + :match-edge (vv-edge K J) + :parent (vv-edge K L) + :positive? nil) + (L :id (id 14 2) + :children (list (vv-edge L K)) + :held-by-roots (list I))) + + (let ((supervisor-left (supervisor simulation + :recommendation ':hold + :weight 0 + :edges (list (vv-edge B D)) + :source-root (process-public-address A) + :target-root (process-public-address D) + :source-id (slot-value B 'anatevka::id) + :root-bucket (list + (process-public-address D)))) + (supervisor-right (supervisor simulation + :recommendation ':hold + :weight 0 + :edges (list (vv-edge I K)) + :source-root (process-public-address I) + :target-root (process-public-address L) + :source-id (slot-value I 'anatevka::id) + :root-bucket (list (process-public-address L))))) + (simulate-add-tree simulation original-tree) + + ;; fill the dryad and add it to the simulation + (dolist (node original-tree) + (let* ((id (slot-value node 'anatevka::id)) + (address (process-public-address node)) + (sprouted? (not (null (anatevka::blossom-node-match-edge node))))) + (setf (gethash address (anatevka::dryad-ids dryad)) id + (gethash address (anatevka::dryad-sprouted? dryad)) sprouted?))) + (simulation-add-event simulation (make-event :callback dryad)) + + (simulate-until-dead simulation supervisor-left) + (simulate-until-dead simulation supervisor-right) + (blossom-let (target-tree :dryad dryad-address) + ((A :id (id 0 2) + :internal-weight 1 + :children (list (vv-edge A B))) + (B :id (id 2 2) + :children (list (vv-edge B C)) + :internal-weight 1 + :match-edge (vv-edge B C) + :parent (vv-edge B A) + :positive? nil) + (C :id (id 4 2) + :internal-weight 1 + :match-edge (vv-edge C B) + :parent (vv-edge C B)) + (D :id (id 2 0) + :internal-weight 1 + :children (list (vv-edge D E))) + (E :id (id 4 0) + :children (list (vv-edge E F)) + :internal-weight 1 + :match-edge (vv-edge E F) + :parent (vv-edge E D) + :positive? nil) + (F :id (id 6 0) + :internal-weight 1 + :match-edge (vv-edge F E) + :parent (vv-edge F E)) + (G :id (id 8 0) + :internal-weight 1 + :match-edge (vv-edge G H) + :parent (vv-edge G H)) + (H :id (id 10 0) + :children (list (vv-edge H G)) + :internal-weight 1 + :match-edge (vv-edge H G) + :parent (vv-edge H I) + :positive? nil) + (I :id (id 12 0) + :internal-weight 1 + :children (list (vv-edge I H))) + (J :id (id 10 2) + :internal-weight 1 + :match-edge (vv-edge J K) + :parent (vv-edge J K)) + (K :id (id 12 2) + :children (list (vv-edge K J)) + :internal-weight 1 + :match-edge (vv-edge K J) + :parent (vv-edge K L) + :positive? nil) + (L :id (id 14 2) + :internal-weight 1 + :children (list (vv-edge L K)))) + (is (tree-equalp original-tree target-tree)))))))) + +(deftest test-supervisor-multireweight-simultaneous-rewind-non-integer () + "Checks the transformation + + 0 1 0 0 1 0 0.5 0.5 0.5 0.5 0.5 0.5 + + - + + - + + - + + - + + A -> B => C J <= K <- L A -> B => C J <= K <- L + --> + D -> E => F G <= H <- I D -> E => F G <= H <- I + + - + + - + + - + + - + + 0 1 0 0 1 0 0.5 0.5 0.5 0.5 0.5 0.5 + +d(B, D), d(F, G), d(H, J) = 1 + +The point of this is to show that simultaneous reweighting and rewinding during multireweighting will still ensure progress even if the inter-root-set distance is 1 (or smaller) by using non-integer rewinds. +" + (with-with ((with-courier ()) + (with-simulation (simulation (*local-courier*))) + (with-address-dereferencing ())) + (let* ((dryad (spawn-process 'dryad :match-address (register) + :debug? t)) + (dryad-address (process-public-address dryad))) + (blossom-let (original-tree :dryad dryad-address) + ((A :id (id 0 1) + :children (list (vv-edge A B)) + :held-by-roots (list D) + :paused? T) + (B :id (id 1 1) + :children (list (vv-edge B C)) + :internal-weight 1 + :match-edge (vv-edge B C) + :parent (vv-edge B A) + :positive? nil) + (C :id (id 2 1) + :match-edge (vv-edge C B) + :parent (vv-edge C B)) + (D :id (id 1 0) + :children (list (vv-edge D E)) + :held-by-roots (list A)) + (E :id (id 2 0) + :children (list (vv-edge E F)) + :internal-weight 1 + :match-edge (vv-edge E F) + :parent (vv-edge E D) + :positive? nil) + (F :id (id 3 0) + :match-edge (vv-edge F E) + :parent (vv-edge F E)) + (G :id (id 4 0) + :match-edge (vv-edge G H) + :parent (vv-edge G H)) + (H :id (id 5 0) + :children (list (vv-edge H G)) + :internal-weight 1 + :match-edge (vv-edge H G) + :parent (vv-edge H I) + :positive? nil) + (I :id (id 6 0) + :children (list (vv-edge I H)) + :held-by-roots (list L) + :paused? T) + (J :id (id 5 1) + :match-edge (vv-edge J K) + :parent (vv-edge J K)) + (K :id (id 6 1) + :children (list (vv-edge K J)) + :internal-weight 1 + :match-edge (vv-edge K J) + :parent (vv-edge K L) + :positive? nil) + (L :id (id 7 1) + :children (list (vv-edge L K)) + :held-by-roots (list I))) + + (let ((supervisor-left (supervisor simulation + :recommendation ':hold + :weight 0 + :edges (list (vv-edge B D)) + :source-root (process-public-address A) + :target-root (process-public-address D) + :source-id (slot-value B 'anatevka::id) + :root-bucket (list + (process-public-address D)))) + (supervisor-right (supervisor simulation + :recommendation ':hold + :weight 0 + :edges (list (vv-edge I K)) + :source-root (process-public-address I) + :target-root (process-public-address L) + :source-id (slot-value I 'anatevka::id) + :root-bucket (list (process-public-address L))))) + (simulate-add-tree simulation original-tree) + + ;; fill the dryad and add it to the simulation + (dolist (node original-tree) + (let* ((id (slot-value node 'anatevka::id)) + (address (process-public-address node)) + (sprouted? (not (null (anatevka::blossom-node-match-edge node))))) + (setf (gethash address (anatevka::dryad-ids dryad)) id + (gethash address (anatevka::dryad-sprouted? dryad)) sprouted?))) + (simulation-add-event simulation (make-event :callback dryad)) + + (simulate-until-dead simulation supervisor-left) + (simulate-until-dead simulation supervisor-right) + (blossom-let (target-tree :dryad dryad-address) + ((A :id (id 0 1) + :internal-weight 0.5 + :children (list (vv-edge A B))) + (B :id (id 1 1) + :internal-weight 0.5 + :children (list (vv-edge B C)) + :match-edge (vv-edge B C) + :parent (vv-edge B A) + :positive? nil) + (C :id (id 2 1) + :internal-weight 0.5 + :match-edge (vv-edge C B) + :parent (vv-edge C B)) + (D :id (id 1 0) + :internal-weight 0.5 + :children (list (vv-edge D E))) + (E :id (id 2 0) + :internal-weight 0.5 + :children (list (vv-edge E F)) + :match-edge (vv-edge E F) + :parent (vv-edge E D) + :positive? nil) + (F :id (id 3 0) + :internal-weight 0.5 + :match-edge (vv-edge F E) + :parent (vv-edge F E)) + (G :id (id 4 0) + :internal-weight 0.5 + :match-edge (vv-edge G H) + :parent (vv-edge G H)) + (H :id (id 5 0) + :internal-weight 0.5 + :children (list (vv-edge H G)) + :match-edge (vv-edge H G) + :parent (vv-edge H I) + :positive? nil) + (I :id (id 6 0) + :internal-weight 0.5 + :children (list (vv-edge I H))) + (J :id (id 5 1) + :internal-weight 0.5 + :match-edge (vv-edge J K) + :parent (vv-edge J K)) + (K :id (id 6 1) + :internal-weight 0.5 + :children (list (vv-edge K J)) + :match-edge (vv-edge K J) + :parent (vv-edge K L) + :positive? nil) + (L :id (id 7 1) + :internal-weight 0.5 + :children (list (vv-edge L K))) + (BOUNDARY :id (id -1 0) + :match-edge (vv-edge B A) + :parent (vv-edge B A))) + (is (tree-equalp original-tree target-tree)))))))) + +(deftest test-supervisor-multireweight-simultaneous-staircase () + "Checks the transformation + + 0 2 0 2 0 2 + + - + + - + + A -> B => C A -> B => C + + D -> E => F D -> E => F + + - + + - + + 0 2 0 2 0 2 + --> + G <= H <- I G <= H <- I + + - + + - + + 0 2 0 2 0 2 + + J <= K <- L J <= K <- L + + - + + - + + 0 2 0 2 0 2 + +d(B, D), d(E, G), d(F, H), d(I, K) = 2 + +The point of this is to show that we can successfully gather a root set of size greater than two, and even if two supervisors attempt to gather it simultaneously, one will always prevail." + (with-with ((with-courier ()) + (with-simulation (simulation (*local-courier*))) + (with-address-dereferencing ())) + (let* ((dryad (spawn-process 'dryad :match-address (register) + :debug? t)) + (dryad-address (process-public-address dryad))) + (blossom-let (original-tree :dryad dryad-address) + ((A :id (id 0 6) + :children (list (vv-edge A B)) + :held-by-roots (list D) + :paused? T) + (B :id (id 2 6) + :children (list (vv-edge B C)) + :internal-weight 2 + :match-edge (vv-edge B C) + :parent (vv-edge B A) + :positive? nil) + (C :id (id 4 6) + :match-edge (vv-edge C B) + :parent (vv-edge C B)) + (D :id (id 2 4) + :children (list (vv-edge D E)) + :held-by-roots (list A I)) + (E :id (id 4 4) + :children (list (vv-edge E F)) + :internal-weight 2 + :match-edge (vv-edge E F) + :parent (vv-edge E D) + :positive? nil) + (F :id (id 6 4) + :match-edge (vv-edge F E) + :parent (vv-edge F E)) + (G :id (id 4 2) + :match-edge (vv-edge G H) + :parent (vv-edge G H)) + (H :id (id 6 2) + :children (list (vv-edge H G)) + :internal-weight 2 + :match-edge (vv-edge H G) + :parent (vv-edge H I) + :positive? nil) + (I :id (id 8 2) + :children (list (vv-edge I H)) + :held-by-roots (list D L)) + (J :id (id 6 0) + :match-edge (vv-edge J K) + :parent (vv-edge J K)) + (K :id (id 8 0) + :children (list (vv-edge K J)) + :internal-weight 2 + :match-edge (vv-edge K J) + :parent (vv-edge K L) + :positive? nil) + (L :id (id 10 0) + :children (list (vv-edge L K)) + :held-by-roots (list I) + :paused? T)) + + (let ((supervisor-left (supervisor simulation + :recommendation ':hold + :weight 0 + :edges (list (vv-edge B D)) + :source-root (process-public-address A) + :target-root (process-public-address D) + :source-id (slot-value B 'anatevka::id) + :root-bucket (list + (process-public-address D)))) + (supervisor-right (supervisor simulation + :recommendation ':hold + :weight 0 + :edges (list (vv-edge K I)) + :source-root (process-public-address L) + :target-root (process-public-address I) + :source-id (slot-value K 'anatevka::id) + :root-bucket (list (process-public-address I))))) + (simulate-add-tree simulation original-tree) + + ;; fill the dryad and add it to the simulation + (dolist (node original-tree) + (let* ((id (slot-value node 'anatevka::id)) + (address (process-public-address node)) + (sprouted? (not (null (anatevka::blossom-node-match-edge node))))) + (setf (gethash address (anatevka::dryad-ids dryad)) id + (gethash address (anatevka::dryad-sprouted? dryad)) sprouted?))) + (simulation-add-event simulation (make-event :callback dryad)) + + (simulate-until-dead simulation supervisor-left) + (simulate-until-dead simulation supervisor-right) + (blossom-let (target-tree :dryad dryad-address) + ((A :id (id 0 6) + :internal-weight 2 + :children (list (vv-edge A B))) + (B :id (id 2 6) + :children (list (vv-edge B C)) + :match-edge (vv-edge B C) + :parent (vv-edge B A) + :positive? nil) + (C :id (id 4 6) + :internal-weight 2 + :match-edge (vv-edge C B) + :parent (vv-edge C B)) + (D :id (id 2 4) + :internal-weight 2 + :children (list (vv-edge D E))) + (E :id (id 4 4) + :children (list (vv-edge E F)) + :match-edge (vv-edge E F) + :parent (vv-edge E D) + :positive? nil) + (F :id (id 6 4) + :internal-weight 2 + :match-edge (vv-edge F E) + :parent (vv-edge F E)) + (G :id (id 4 2) + :internal-weight 2 + :match-edge (vv-edge G H) + :parent (vv-edge G H)) + (H :id (id 6 2) + :children (list (vv-edge H G)) + :match-edge (vv-edge H G) + :parent (vv-edge H I) + :positive? nil) + (I :id (id 8 2) + :internal-weight 2 + :children (list (vv-edge I H))) + (J :id (id 6 0) + :internal-weight 2 + :match-edge (vv-edge J K) + :parent (vv-edge J K)) + (K :id (id 8 0) + :children (list (vv-edge K J)) + :match-edge (vv-edge K J) + :parent (vv-edge K L) + :positive? nil) + (L :id (id 10 0) + :internal-weight 2 + :children (list (vv-edge L K)))) + (is (tree-equalp original-tree target-tree)))))))) + +(deftest test-supervisor-multireweight-lower-priority () + "Check that when F receives a multireweight proposal in + + 0 0 4 2 2 2 + + + - + + - + A D <==== E <-- A D <==== E <-- + ^ | --> ^ | + ! | ! | + == B <---- C F == B <---- C F + - + + - + + + 4 0 0 2 2 2 + +d(B, D) = 4 and d(C, E) = 4, + +it declines to take action because C has priority. +" + (with-with ((with-courier ()) + (with-simulation (simulation (*local-courier*))) + (with-address-dereferencing ())) + (let* ((dryad (spawn-process 'dryad :match-address (register) + :debug? t)) + (dryad-address (process-public-address dryad))) + (blossom-let (original-tree :dryad dryad-address) + ((A :id (id 0 2) + :match-edge (vv-edge A B) + :parent (vv-edge A B)) + (B :id (id 2 0) + :children (list (vv-edge B A)) + :internal-weight 4 + :match-edge (vv-edge B A) + :parent (vv-edge B C) + :positive? nil) + (C :id (id 6 0) + :children (list (vv-edge C B)) + :held-by-roots (list F)) + (D :id (id 4 2) + :match-edge (vv-edge D E) + :parent (vv-edge D E)) + (E :id (id 8 2) + :children (list (vv-edge E D)) + :internal-weight 4 + :match-edge (vv-edge E D) + :parent (vv-edge E F) + :positive? nil) + (F :id (id 10 0) + :children (list (vv-edge F E)) + :held-by-roots (list C) + :paused? T)) + (let ((supervisor (supervisor simulation + :recommendation ':hold + :weight 0 + :edges (list (vv-edge D B)) + :source-root (process-public-address F) + :target-root (process-public-address C) + :source-id (slot-value D 'anatevka::id) + :root-bucket (list (process-public-address C))))) + (simulate-add-tree simulation original-tree) + + ;; fill the dryad and add it to the simulation + (dolist (node original-tree) + (let* ((id (slot-value node 'anatevka::id)) + (address (process-public-address node))) + (setf (gethash address (anatevka::dryad-ids dryad)) id + (gethash address (anatevka::dryad-sprouted? dryad)) nil))) + (simulation-add-event simulation (make-event :callback dryad)) + + (simulate-until-dead simulation supervisor) + (blossom-let (target-tree :dryad dryad-address) + ((AA :id (id 0 2) + :match-edge (vv-edge AA BB) + :parent (vv-edge AA BB)) + (BB :id (id 2 0) + :children (list (vv-edge BB AA)) + :internal-weight 4 + :match-edge (vv-edge BB AA) + :parent (vv-edge BB CC) + :positive? nil) + (CC :id (id 6 0) + :children (list (vv-edge CC BB)) + :held-by-roots (list (process-public-address F))) + (DD :id (id 4 2) + :match-edge (vv-edge DD EE) + :parent (vv-edge DD EE)) + (EE :id (id 8 2) + :children (list (vv-edge EE DD)) + :internal-weight 4 + :match-edge (vv-edge EE DD) + :parent (vv-edge EE FF) + :positive? nil) + (FF :id (id 10 0) + :children (list (vv-edge FF EE)) + :held-by-roots (list (process-public-address C)))) + (is (tree-equalp original-tree target-tree)))))))) diff --git a/tests/operations/reweight.lisp b/tests/operations/reweight.lisp new file mode 100644 index 0000000..a242169 --- /dev/null +++ b/tests/operations/reweight.lisp @@ -0,0 +1,188 @@ +;;;; tests/operations/reweight.lisp +;;;; +;;;; Unit tests for the `REWEIGHT' supervisor action. + +(in-package #:anatevka-tests) + +(deftest test-supervisor-reweight-successfully () + "Checks the transformation + + A <== B <-- C D --> E ==> F --> A <== B <-- C D --> E ==> F + + - + + - + + - + + - + + 0 2 0 0 2 0 2 0 2 0 2 0 + +d(C, D) = 2 +" + (with-with ((with-courier ()) + (with-simulation (simulation (*local-courier*))) + (with-address-dereferencing ())) + (let* ((dryad (spawn-process 'dryad :match-address (register) + :debug? t)) + (dryad-address (process-public-address dryad))) + (blossom-let (original-tree :dryad dryad-address) + ((A :id (id 0 0) + :match-edge (vv-edge A B) + :parent (vv-edge A B)) + (B :id (id 2 0) + :children (list (vv-edge B A)) + :internal-weight 2 + :parent (vv-edge B C) + :match-edge (vv-edge B A) + :positive? nil) + (C :id (id 4 0) + :children (list (vv-edge C B)) + :paused? T) + (D :id (id 6 0) + :children (list (vv-edge D E))) + (E :id (id 8 0) + :children (list (vv-edge E F)) + :internal-weight 2 + :match-edge (vv-edge E F) + :parent (vv-edge E D) + :positive? nil) + (F :id (id 10 0) + :match-edge (vv-edge F E) + :parent (vv-edge F E))) + (let ((supervisor (supervisor simulation + :recommendation ':augment + :weight 2 + :edges (list (vv-edge C D)) + :source-root (process-public-address C) + :target-root (process-public-address D) + :source-id (slot-value C 'anatevka::id)))) + (simulate-add-tree simulation original-tree) + + ;; fill the dryad and add it to the simulation + (dolist (node original-tree) + (let* ((id (slot-value node 'anatevka::id)) + (address (process-public-address node)) + (sprouted? (not (null (anatevka::blossom-node-match-edge node))))) + (setf (gethash address (anatevka::dryad-ids dryad)) id + (gethash address (anatevka::dryad-sprouted? dryad)) sprouted?))) + (simulation-add-event simulation (make-event :callback dryad)) + + (simulate-until-dead simulation supervisor) + (blossom-let (target-tree :dryad dryad-address) + ((A :id (id 0 0) + :internal-weight 2 + :match-edge (vv-edge A B) + :parent (vv-edge A B)) + (B :id (id 2 0) + :children (list (vv-edge B A)) + :parent (vv-edge B C) + :match-edge (vv-edge B A) + :positive? nil) + (C :id (id 4 0) + :internal-weight 2 + :children (list (vv-edge C B))) + (D :id (id 6 0) + :children (list (vv-edge D E))) + (E :id (id 8 0) + :children (list (vv-edge E F)) + :internal-weight 2 + :match-edge (vv-edge E F) + :parent (vv-edge E D) + :positive? nil) + (F :id (id 10 0) + :match-edge (vv-edge F E) + :parent (vv-edge F E))) + (is (tree-equalp original-tree target-tree)))))))) + +(deftest test-supervisor-reweight-rewind-simultaneous () + "Checks the transformation + + A <== B <-- C D --> E ==> F --> A <== B <-- C D --> E ==> F + + - + + - + + - + + - + + 0 2 0 0 2 0 1 1 1 1 1 1 + +d(C, D) = 2 + +The point of this test is to show that we can break livelock induced by +repeated reweighting and rewinding. +" + (with-with ((with-courier ()) + (with-simulation (simulation (*local-courier*))) + (with-address-dereferencing ())) + (let* ((dryad (spawn-process 'dryad :match-address (register) + :debug? t)) + (dryad-address (process-public-address dryad))) + (blossom-let (original-tree :dryad dryad-address) + ((A :id (id 0 0) + :match-edge (vv-edge A B) + :parent (vv-edge A B)) + (B :id (id 2 0) + :children (list (vv-edge B A)) + :internal-weight 2 + :parent (vv-edge B C) + :match-edge (vv-edge B A) + :positive? nil) + (C :id (id 4 0) + :children (list (vv-edge C B)) + :paused? T) + (D :id (id 6 0) + :children (list (vv-edge D E)) + :paused? T) + (E :id (id 8 0) + :internal-weight 2 + :children (list (vv-edge E F)) + :match-edge (vv-edge E F) + :parent (vv-edge E D) + :positive? nil) + (F :id (id 10 0) + :match-edge (vv-edge F E) + :parent (vv-edge F E))) + (let ((supervisor-left (supervisor simulation + :recommendation ':contract + :weight 2 + :edges (list (vv-edge C A)) + :source-root (process-public-address C) + :target-root (process-public-address C) + :source-id (slot-value C 'anatevka::id))) + (supervisor-right (supervisor simulation + :recommendation ':contract + :weight 2 + :edges (list (vv-edge D F)) + :source-root (process-public-address D) + :target-root (process-public-address D) + :source-id (slot-value D 'anatevka::id)))) + (simulate-add-tree simulation original-tree) + + ;; fill the dryad and add it to the simulation + (dolist (node original-tree) + (let* ((id (slot-value node 'anatevka::id)) + (address (process-public-address node)) + (sprouted? (not (null (anatevka::blossom-node-match-edge node))))) + (setf (gethash address (anatevka::dryad-ids dryad)) id + (gethash address (anatevka::dryad-sprouted? dryad)) sprouted?))) + (simulation-add-event simulation (make-event :callback dryad)) + + (simulate-until-dead simulation supervisor-left) + (simulate-until-dead simulation supervisor-right) + (blossom-let (target-tree :dryad dryad-address) + ((A :id (id 0 0) + :internal-weight 1 + :match-edge (vv-edge A B) + :parent (vv-edge A B)) + (B :id (id 2 0) + :children (list (vv-edge B A)) + :internal-weight 1 + :parent (vv-edge B C) + :match-edge (vv-edge B A) + :positive? nil) + (C :id (id 4 0) + :internal-weight 1 + :children (list (vv-edge C B))) + (D :id (id 6 0) + :internal-weight 1 + :children (list (vv-edge D E))) + (E :id (id 8 0) + :internal-weight 1 + :children (list (vv-edge E F)) + :match-edge (vv-edge E F) + :parent (vv-edge E D) + :positive? nil) + (F :id (id 10 0) + :internal-weight 1 + :match-edge (vv-edge F E) + :parent (vv-edge F E))) + (is (tree-equalp original-tree target-tree)))))))) diff --git a/tests/package.lisp b/tests/package.lisp new file mode 100644 index 0000000..8aa88c1 --- /dev/null +++ b/tests/package.lisp @@ -0,0 +1,6 @@ +;;;; tests/package.lisp + +(fiasco:define-test-package #:anatevka-tests + (:use #:anatevka) + (:use #:aether) + ) diff --git a/tests/suite.lisp b/tests/suite.lisp new file mode 100644 index 0000000..e619dc4 --- /dev/null +++ b/tests/suite.lisp @@ -0,0 +1,20 @@ +;;;; tests/suite.lisp + +(in-package #:anatevka-tests) + +(defun run-anatevka-tests (&key (verbose nil) (headless nil)) + "Run all Anatevka tests. If VERBOSE is T, print out lots of test info. If HEADLESS is T, disable interactive debugging and quit on completion." + ;; Bug in Fiasco commit fe89c0e924c22c667cc11c6fc6e79419fc7c1a8b + (setf fiasco::*test-run-standard-output* (make-broadcast-stream *standard-output*)) + (cond + ((null headless) + (run-package-tests :package ':anatevka-tests + :verbose verbose + :describe-failures t + :interactive t)) + (t + (let ((successp (run-package-tests :package ':anatevka-tests + :verbose t + :describe-failures t + :interactive nil))) + (uiop:quit (if successp 0 1))))))