server-session-connected avoids assert-lock of server-connected

This change makes `during` work "atomically" across a communications
delay, by ensuring that a retracted assertion matching the `during`'s
pattern triggers the "stop on" clause in the expansion of the
`during`.

Some discussion of the change exists in the Journal and in my
notebook.

examples/netstack/incremental-highlevel/main.rkt

@@ -86,6 +86,6 @@
                            counter)))
                 (send! (outbound (tcp-channel us them response)))
                 (for [(i 4)]
-                  (define buf (make-bytes 1024 (+ #x30 i)))
+                  (define buf (make-bytes 1024 (+ #x30 (modulo i 10))))
                   (send! (outbound (tcp-channel us them buf))))
                 (stop-facet (current-facet-id)))))))

imperative/.gitignore

@@ -0,0 +1,2 @@
+compiled/
+scratch/

imperative/HOWITWORKS.md

@@ -0,0 +1,575 @@
+# Efficient, Imperative Dataspaces for Conversational Concurrency
+
+Tony Garnock-Jones <tonyg@leastfixedpoint.com>  
+20 October 2018; revised 21 June 2019
+
+<p style="font-size:90%"><strong>Abstract.</strong> The dataspace
+  model of Conversational Concurrency [is great], but implementing it
+  efficiently has been difficult until now. Existing approaches use a
+  complex data structure that depends for its efficiency on
+  sophisticated run-time support. This paper presents a new approach
+  to implementation of the dataspace model that gives three benefits.
+  First, it avoids the complexity and run-time support requirements of
+  previous approaches, bringing dataspaces to a wider range of
+  environments. Second, it unlocks new types of conversational
+  interaction among concurrent components. Third, it dramatically
+  improves performance. Key to the new technique is a syntactic
+  treatment of assertions of interest, contrasting with the semantic
+  treatment of assertion sets used by the earlier approach.</p>
+
+## Constructing assertions
+
+Imagine a language for constructing data with embedded function calls
+and variable references. Imagine that it is a fragment of a larger
+language.
+
+    c ∈ assertions  C ::= e | x(c, ...)
+    v ∈ values      V ::= a | x(v, ...)
+    e ∈ expressions E ::= a | x | e e ...
+    x ∈ identifiers X
+    a ∈ atoms       A = numbers ∪ strings ∪ ...
+
+Here are some examples of assertions in `c`, along with suggested
+interpretations:
+
+    present("Alice")           Alice is present in the chat room
+    speak("Alice", "Hello!")   Alice says "Hello!"
+
+## Assertions of interest
+
+In the dataspace model, "subscriptions" go hand in hand with
+assertions of *interest* in subscribed-to data. The model includes two
+special constructors for discussing interests. The first, `observe`,
+is interpreted as a declaration of interest in assertions matching the
+pattern given as its sole argument. The second, `discard`, is
+interpreted as a "don't care" when part of a pattern within `observe`.
+
+    observe(present(discard()))         Interest in the presence of any user
+    observe(speak("Alice", discard()))  Interest in every time Alice speaks
+
+We extend the dataspace model with an additional special constructor
+which allows interested parties to declare the portions of matching
+assertions that they specifically wish to examine further: *capturing*
+positions. The `capture` constructor signals that the interested party
+will treat specially the corresponding portion of a matching
+assertion.[^capture-subpattern]
+
+    observe(present(capture()))         Interest in each present user
+    observe(speak("Alice", capture()))  Interest in the things Alice says
+
+  [^capture-subpattern]: The implemented system affords a single
+    argument to `capture` that restricts matches according to the
+    nested subpattern. What is written here as `capture()` corresponds
+    to `capture(discard())` in the full implementation. The pattern
+    language syntax is analogously extended.
+
+There is an important difference between `observe(present(discard()))`
+and `observe(present(capture()))`. The former declares that the
+interested party cares only about whether any user at all is present,
+while the latter declares an interest in the identities of the
+specific users that are present. Similarly, `observe(speak("Alice",
+discard()))` declares an interest in receiving a notification each
+time Alice speaks, but no interest in the *content* of each utterance,
+while `observe(speak("Alice", capture()))` declares interest in
+learning the things Alice says.
+
+To drive this point home, the following patterns both result in a
+notification event for each utterance by any user. The first results
+in notifications carrying the name of the speaker along with the
+content of their speech. The second results in notifications carrying
+only the name of the speaker.
+
+    observe(speak(capture(), capture()))  Interest in who says what
+    observe(speak(capture(), discard()))  Interest in who speaks
+
+## Patterns
+
+Imagine now an enriched version of our language that can construct
+patterns over data, including captures and "don't care" positions.
+
+    p ∈ patterns    P ::= e | x(p, ...) | $x | _
+
+Syntactic patterns can be translated into assertions of interest
+directly. Binding subpatterns `$x` are translated into `capture()`,
+and "don't care" patterns `_` into `discard()`.
+
+## Indexing assertions and patterns
+
+There are two kinds of change in a running dataspace model program.
+First, assertions can be added to and removed from the dataspace. When
+this happens, interested facets must be informed of relevant changes.
+Second, facets and their event handlers can be added to and removed
+from the dataspace. When this happens, new handlers must be informed
+of preexisting matching assertions.
+
+To efficiently respond to these two kinds of change, we maintain a
+special index. Every time an event handler within a facet is created,
+we augment the index using a data structure called a *skeleton*. Each
+skeleton contains information gleaned from static analysis of the
+pattern associated with the event handler. The index also records
+every assertion added to the dataspace, so as to correctly initialize
+event handlers added later.
+
+### Skeletons
+
+A skeleton is comprised of three pieces: a *shape*, describing the
+positions and arities of statically-known constructors in matching
+assertions; a *constant map*, which places restrictions on fields
+within constructors; and a *capture map*, which specifies locations of
+captured positions.
+
+Each time an assertion is added or removed, it is conceptually checked
+against each handler's skeleton. First, the overall shape is checked.
+If the assertion passes this check, the constant map is checked. If
+all the constants match, the capture map is used to prepare an
+argument vector, and the event handler's callback is invoked.
+
+    k ∈ skeletons   K   = S × [H×E] × [H]
+    s ∈ shapes      S ::= * | x(s, ...)
+    h ∈ paths       H   = [𝐍]
+
+Shapes retain only statically-known constructors and arities in a
+pattern:
+
+    shape :: P -> S
+    shape e          = *
+    shape x(p, ...)  = x(shape p, ...)
+    shape $x         = *
+    shape _          = *
+
+A constant map extracts all non-capturing, non-discard positions in a
+pattern. The expressions in the map are evaluated at the time the
+corresponding event handler is installed; that is, at facet creation
+time. They are not subsequently reevaluated; if any expression depends
+on a dataflow variable, and that variable changes, the entire handler
+is removed, reevaluated, and reinstalled.
+
+    constantmap :: P -> [(H, E)]
+    constantmap p  = cmap [] p
+      where
+        cmap :: H -> P -> [(H, E)]
+        cmap h e                 = [(h, e)]
+        cmap h x(p_0, ..., p_i)  = (cmap (h++[0]) p_0) ++
+                                   ... ++
+                                   (cmap (h++[i]) p_i)
+        cmap h $x                = []
+        cmap h _                 = []
+
+Finally, a capture map extracts all capturing positions in a pattern:
+
+    capturemap :: P -> [H]
+    capturemap p  = vmap [] p
+      where
+        vmap :: H -> P -> [H]
+        vmap h e                = []
+        vmap h x(p_0, ..., p_i) = (vmap (h++[0]) p_0) ++
+                                  ... +
+                                  (vmap (h++[i]) p_i)
+        vmap h $x               = [h]
+        vmap h _                = []
+
+### The index
+
+The index incorporates every active event handler and every active
+assertion in the dataspace.
+
+#### Overview and structures
+
+An index is a pair of a bag of all currently-asserted
+assertion-values, plus the root node of a trie-like structure.
+Information from each indexed event handler's skeleton's shape is laid
+out along edges connecting trie nodes.
+
+Every node contains a "continuation", which embodies information from
+a skeleton's constant map and capture map alongside handler callback
+functions and caches of currently-asserted values.
+
+           Index = Bag(V) × Node
+            Node = Continuation × (Selector ⟼ Class ⟼ Node)
+        Selector = 𝐍 × 𝐍		-- pop-count and index
+           Class = X × 𝐍		-- label and arity
+
+    Continuation = 𝒫(V) × ([H] ⟼ [V] ⟼ Leaf)
+            Leaf = 𝒫(V) × ([H] ⟼ Handler)
+
+         Handler = Bag([V]) × 𝒫(Callback)
+
+        Callback = EventType -> [V] -> V
+     EventType ::= "+" | "-" | "!"
+
+          Bag(τ) = τ ⟼ 𝐍		-- bag of τ values
+
+To use an index in the context of a single assertion—be it a new
+addition, a removal, or a message to be delivered—follow a path from
+the root `Node` of the index along `Selector`/`Class`-labelled edges,
+collecting `Continuations` as you go. This yields a complete set of
+event handlers that may match the assertion being considered. Further
+investigating each collected `Continuation` by analyzing its constant
+maps yields a set of matching `Leaf`s. Finally, each `Leaf` specifies
+a set of captured positions in the assertion to extract and pass to
+the contained callbacks.
+
+At every `Continuation`, `Leaf` and `Handler` object, the index
+maintains a set of currently-asserted values that conform to the
+constraints implied by the object's position in the overall index.
+
+Most of the components in an index are *mutable*: the `Bag(V)` in the
+root; the assertion-value cache set in each `Continuation` or `Leaf`
+object; the map from `Selector` to `Class` to `Node` within each
+`Node`; the map from path list to value-list to `Leaf` in each
+`Continuation`; the map from path list to `Handler` in each `Leaf`;
+and the `Bag([V])` in every `Handler`. This reflects the fact that the
+index directly reflects the current state of the dataspace it is
+indexing.
+
+#### Adding and removing event handlers
+
+Every event handler is a pair of a skeleton and a callback function.
+
+Adding or removing an event handler proceeds in two stages. First, the
+index is extended to incorporate a path computed from the skeleton's
+shape into the `Node`-based trie. Second, the capture map and callback
+are installed into or removed from the `Continuation` within the
+`Node` at the end of that path.
+
+Because (statically-known) shapes are finite and not particularly
+numerous in any given program, the implementation assumes that it is
+never necessary to remove shapes from the index. Instead, it limits
+itself to removal of handler functions, capture maps, and constant
+maps. This assumption will have to be revisited in future broker-like
+cases where handlers are dynamically installed.
+
+**Definition.** The `project` function extracts the subvalue at a
+  given path `h` from an overall value `v`.
+
+    project :: V -> H -> V
+    project v [] = v
+    project x(v_0, ..., v_i) (n:h) = project v_n h
+
+**Definition.** The `projectMany` function projects a sequence of
+  subvalues.
+
+    projectMany :: V -> [H] -> V
+    projectMany v [h_0, ...] = [project v h_0, ...]
+
+**Definition.** The `classof` function extracts the constructor label
+  `x` and its arity `i` from a value `v`, yielding `()` if `v` is not
+  a record.
+
+    classof :: V -> 1 + Class
+    classof a                = ()
+    classof x(v_0, ..., v_i) = (x,i)
+
+**Definition.** The `extend` procedure augments an index with shape
+  information `s`, by imperatively updating the index structure. It
+  returns the `Continuation` associated with the deepest `Node`
+  visited in the path described by `s`.
+
+    extend :: Node -> S -> Continuation
+    extend node s =
+        let (_, (cont, _)) = walk-node [] node 0 0 s
+        cont
+      where
+
+        walk-edge :: H -> Node -> 𝐍 -> 𝐍 -> [S] -> (𝐍,Node)
+        walk-edge h node n_pop n_index [] =
+          (n_pop + 1, node)
+        walk-edge h node n_pop n_index (s:shapes) =
+          let (n_pop', node') = walk-node h node n_pop n_index s
+          let n_index' = n_index + 1
+          let h' = (dropRight h 1) ++ [n_index']
+          walk-edge h' node' n_pop' n_index' shapes
+
+        walk-node :: H -> Node -> 𝐍 -> 𝐍 -> S -> (𝐍,Node)
+        walk-node h node n_pop n_index * =
+          (n_pop, node)
+        walk-node h node n_pop n_index x(s_0, ... s_i) =
+          let (cont, edges) = node
+          let selector = (n_pop,n_index)
+          let class = (x,i)
+          if selector not in edges then
+              edges[selector] := {}
+          let table = edges[selector]
+          if class not in table then
+              let (outercache, constmap) = cont
+              let innercache =
+                { v | v ∈ outercache,
+                      classof (project v h) = class }
+              table[class] := ((innercache, {}), {})
+          let node' = table[class]
+          walk-edge (h ++ [0]) node' 0 0 [s_0, ..., s_i]
+
+**Definition.** The `addHandler` procedure installs into an index an
+  event handler callback `f` expecting values matching and captured by
+  the given skeleton `k`. It then invokes `f` once for each distinct
+  sequence of captured values matching existing assertions in the
+  index.[^function-pointer-equality]
+
+    addHandler :: Index -> (S × [H×V] × [H]) -> Callback -> 1
+    addHandler index (s, constantMap, captureMap) f =
+      let (_, root) = index
+      let (cache, table) = extend root s
+      let constLocs = [h | (h,v) ∈ constantMap]
+      if constLocs not in table then
+          table[constLocs] := {}
+          for v in cache
+              let key = projectMany v constLocs
+              if key not in table[constLocs] then
+                  table[constLocs][key] := ({}, {})
+              let (leafcache, _leaftable) = table[constLocs][key]
+              leafcache += v
+      let constVals = [v | (h,v) ∈ constantMap]
+      if constVals not in table[constLocs] then
+          table[constLocs][constVals] := ({}, {})
+      let (leafcache, leaftable) = table[constLocs][constVals]
+      if captureMap not in leaftable then
+          let bag = empty_bag
+          for v in leafcache
+              bag[projectMany v captureMap] += 1
+          leaftable[captureMap] := (bag, {})
+      let (bag, f_table) = leaftable[captureMap]
+      f_table += f
+      for seq in bag
+          f "+" seq
+      ()
+
+  [^function-pointer-equality]: Because we store *sets* of function
+    values, we rely on the general availability of a closure
+    equivalence relation. Pointer-equality of closures (`eq?`)
+    suffices.
+
+**Definition.** The `removeHandler` procedure removes an event handler
+  from an index.
+
+    removeHandler :: Index -> (S × [H×V] × [H]) -> Callback -> 1
+    removeHandler index (s, constantMap, captureMap) f =
+      let (_, root) = index
+      let (cache, table) = extend root s
+      let constLocs = [h | (h,v) ∈ constantMap]
+      if constLocs not in table then
+          return
+      let constVals = [v | (h,v) ∈ constantMap]
+      if constVals not in table[constLocs] then
+          return
+      let (leafcache, leaftable) = table[constLocs][constVals]
+      if captureMap not in leaftable then
+          return
+      let (bag, f_table) = leaftable[captureMap]
+      if f not in f_table then
+          return
+      f_table -= f
+      if f_table = {} then
+          delete leaftable[captureMap]
+      if leafcache = {} and leaftable = {} then
+          delete table[constLocs][constVals]
+      if table[constLocs] = {} then
+          delete table[constLocs]
+
+#### Adding assertions, removing assertions and sending messages
+
+All three operations depend on a single traversal procedure,
+parameterized with different update procedures.
+
+**Definition.** The `modify` procedure traverses an index trie,
+  following the structure of `v` and updating cached assertion sets
+  according to the given update procedures. The update procedures act
+  by side-effect; in particular, the `m_handler` procedure may choose
+  to invoke the callback passed to it.
+
+    Operation = { AddAssertion, RemoveAssertion, SendMessage }
+
+    modify :: Node ->
+              Operation ->
+              V ->
+              (Continuation -> V -> 1) ->
+              (Leaf -> V -> 1) ->
+              (Handler -> [V] -> 1) ->
+              1
+    modify node operation v m_cont m_leaf m_handler =
+      walk-node node [outermost(v)]
+      where
+        walk-node :: Node -> [V] -> 1
+        walk-node (cont, edges) vs =
+          walk-cont cont
+          for sel@(n_pop, n_index) in edges
+              let vs' = dropLeft vs n_pop
+              let (x(v_0, ...) : _) = vs'
+              let v' = v_{n_index}
+              if classof v' in edges[sel] then
+                  walk-node edges[sel][classof v'] (v':vs')
+
+        walk-cont :: Continuation -> 1
+        walk-cont cont@(cache, table) =
+          m_cont cont v
+          for constLocs in table
+            let consts = projectMany v constLocs
+            if operation = AddAssertion and consts not in table[constLocs] then
+                table[constLocs][consts] := ({}, {})
+            if consts in table[constLocs] then
+                let leaf@(leafcache, leaftable) =
+                      table[constLocs][consts]
+                m_leaf leaf v
+                for captureMap in leaftable
+                    let handler = leaftable[captureMap]
+                    let vs = projectMany v captureMap
+                    m_handler handler vs
+                if operation = RemoveAssertion and leafcache = {} and leaftable = {} then
+                    delete table[constLocs][consts]
+                    if table[constLocs] = {} then
+                        delete table[constLocs]
+
+The `outermost` constructor applied to `v` at the top of `modify` is
+necessary because every path in the trie structure embodied in each
+`node` is a sequence of zero or more (move, check) pairs. Each "move"
+pops zero or more items from the stack and then pushes a sub-structure
+of the topmost stack element onto the stack; the "check" then examines
+the class of the new top element, abandoning the search if it does not
+match. Without some outermost constructor, there would be no possible
+"move", and the trie would have to be expressed as a single optional
+check followed by zero or more (move, check) pairs.
+
+**Definition.** The procedure `adjustAssertion` updates the copy-count
+  associated with `v` in the given index, invoking callbacks as a
+  side-effect if this changes the observable contents of the
+  dataspace.
+
+    adjustAssertion :: Index -> V -> 𝐍 -> 1
+    adjustAssertion (cache, root) v delta =
+        let was_present = v in cache
+        cache[v] += delta
+        let is_present = v in cache
+        if not was_present and is_present then
+            modify root AddAssertion v add_cont add_leaf add_handler
+        if was_present and not is_present then
+            modify root RemoveAssertion v del_cont del_leaf del_handler
+      where
+        add_cont (cache, _) v = cache += v
+        add_leaf (leafcache, _) v = leafcache += v
+        add_handler (bag, f_table) vs =
+          let was_present = vs in bag
+          bag[vs] += 1
+          if not was_present then
+              for f in f_table
+                  f "+" vs
+
+        del_cont (cache, _) v = cache -= v
+        del_leaf (leafcache, _) v = leafcache -= v
+        del_handler (bag, f_table) vs =
+          bag[vs] -= 1
+          if vs not in bag then
+              for f in f_table
+                  f "-" vs
+
+**Definition.** The procedures `addAssertion` and `removeAssertion`
+  install and remove an assertion `v` into the given index,
+  respectively.
+
+    addAssertion :: Index -> V -> 1
+    addAssertion index v = adjustAssertion index v 1
+
+    removeAssertion :: Index -> V -> 1
+    removeAssertion index v = adjustAssertion index v -1
+
+Care must be taken when applying entire *patches* to ensure that added
+assertions are processed before removed assertions; otherwise, actors
+will observe glitching in certain cases. For example, consider an
+endpoint with a wildcard subscription `[_]` and a separate endpoint
+asserting `[3]`. If a patch atomically replaces `[3]` with `[4]`, then
+if the removal is processed first, it will briefly appear to the `[_]`
+endpoint as if no assertions remain, whereas if the addition is
+processed first, no glitch will be detected.
+
+**Definition.** The procedure `sendMessage` delivers a message `v` to
+  event handlers in the given index.
+
+    sendMessage :: Index -> V -> 1
+    sendMessage (_, root) v =
+        modify root SendMessage v send_cont send_leaf send_handler
+      where
+        send_cont _ _ = ()
+        send_leaf _ _ = ()
+        send (_, f_table) vs =
+          for f in f_table
+              f "!" vs
+
+## Potential future optimizations
+
+### Static analysis of messages and assertions
+
+Static analysis of expressions under `(send! ...)` and `(assert ...)`
+could cut out even more structural overhead.
+
+For example, given interests
+
+    observe(message("actor1", capture()))
+    observe(message("actor2", capture()))
+
+and a message
+
+    :: message(x, y)
+
+static analysis could directly connect the sending site to a
+hash-table lookup with `x` as the key, and invocation of the resulting
+handlers with `y` as the argument. There would be no need to perform a
+lookup based on the `message` constructor at runtime.
+
+Similarly, given an interest
+
+    observe(present(capture()))
+
+and an assertion
+
+    present(user)
+
+static analysis could directly invoke handlers with `user` as the
+argument, without needing to at runtime find the set of handlers
+interested in the `present` constructor.
+
+---
+
+# TODO
+
+ - describe the cleanup function associated with a handler in the real implementation
+    - `relay.rkt` uses it. When an inner actor asserts interest in an
+      inbound assertion-set, the relay process pivots into the outer
+      dataspace's context, and adds a new endpoint that relays events
+      to the inner dataspace. The cleanup function attached to that
+      endpoint retracts (from the inner dataspace) any matching
+      assertions left over at the time the endpoint is removed.
+    - that appears to be it! Nowhere else in the code is a
+      `skeleton-interest` constructed with a non-`#f` cleanup
+      function.
+ - figure out and describe scoped assertions / visibility-restrictions
+    - (partial/sketchy answer:) It's to deal with the fact that
+      multiple endpoints may overlap. Within a single dataspace, an
+      assertion matching both endpoints will trigger each of them.
+      When relaying, the relay maintains an endpoint in the outer
+      space for each in the inner space. When both outer endpoints are
+      triggered, if they were to naively relay the matching assertion,
+      the problem isn't so much that they'd double up (because
+      dataspaces deduplicate!), the problem is that they don't have
+      enough information to reconstruct the triggering outer assertion
+      perfectly! So a visibility-restriction causes an assertion to
+      *only* trigger inner endpoints that capture *at most* the
+      captures of the outer endpoint. One of the outer endpoints will
+      trigger its "matching" inner endpoint, but not the inner
+      endpoint of the other endpoint, even though you might expect the
+      relayed assertion to do so.
+    - There's also a need for `(opaque-placeholder)`s to frustrate
+      constant-matching against literal `(discard)` in cases of
+      visibility restriction. See commit b4f1d36 and test case
+      `test/core/nesting-confusion-2.rkt`.
+    - HOWEVER see notes from 2019-06-18 in the googledoc Journal as
+      well as in my notebook. See also commit 5c514b7 from
+      imperative-syndicate and e806f4b from syndicate-js. The
+      opaque-placeholders make the distributed (= non-zero-latency)
+      case of visibility-restriction handling problematic in general,
+      though relaxing the constraint from exact match of captured
+      positions to at-most-match of captured positions allows at least
+      the `during` special case to work in a programmer-unsurprising
+      way.
+
+ - there's more to say about the implementation of the *dataspace*
+   itself, not just the index structures. For example, the care that
+   must be taken regarding `cleanup-changes` and abandoning work
+   during exception handling.

imperative/Makefile

@@ -0,0 +1,21 @@
+PACKAGENAME=imperative-syndicate
+COLLECTS=imperative-syndicate
+
+all: setup
+
+clean:
+	find . -name compiled -type d | xargs rm -rf
+
+setup:
+	raco setup $(COLLECTS)
+
+link:
+	raco pkg install --link -n $(PACKAGENAME) $$(pwd)
+
+unlink:
+	raco pkg remove $(PACKAGENAME)
+
+test: setup testonly
+
+testonly:
+	raco test -p $(PACKAGENAME)

imperative/README.md

@@ -0,0 +1,42 @@
+# New "Imperative" Syndicate Implementation
+
+This experimental reimplementation of Syndicate takes the
+language-level constructs of facets, endpoints, and fields to heart,
+and integrates knowledge of facets and endpoints into the dataspace
+implementation itself.
+
+It gains a *significant* performance advantage by doing so.
+
+Programs seem to be about *20x faster*. Some are only 10x faster, some
+are 30x faster.
+
+The prototype that embodies the new idea is in
+[prototype.rkt](prototype.rkt).
+
+All the drivers end up looking much nicer with this new
+implementation. The previously-separate GL-2D support is now
+integrated as just another driver (though the timing characteristics
+of the old implementation are not precisely preserved). The
+[ground.rkt](ground.rkt) implementation is much cleaner.
+
+Install the package by getting a Git checkout and running
+
+```shell
+raco pkg install --link -n imperative-syndicate `pwd`
+```
+
+The implementation test suite lives in [test/](test/). Run it with:
+
+```shell
+raco setup imperative-syndicate; raco test -p imperative-syndicate
+```
+
+Try out the "many Racket logos" animation example/demo:
+
+```shell
+racket examples/gl-2d-many.rkt
+```
+
+Hopefully you'll get a smooth 60fps, though I admit I'm running it on
+a fairly fast machine so you might need to drop the sprite-count in
+the code a bit to sustain 60fps.

imperative/assertions.rkt

@@ -0,0 +1,37 @@
+#lang racket/base
+
+(provide message-struct
+         assertion-struct
+         (struct-out observe)
+         (struct-out seal)
+         (struct-out inbound)
+         (struct-out outbound)
+         strong-gensym)
+
+(require (only-in net/base64 base64-encode))
+(require (only-in racket/random crypto-random-bytes))
+(require (only-in racket/string string-trim))
+
+;; Thin veneers over `struct` for declaring intent.
+(define-syntax-rule (assertion-struct item ...) (struct item ... #:prefab))
+(define-syntax-rule (message-struct item ...) (struct item ... #:prefab))
+
+(assertion-struct observe (specification))
+
+;; Seals are used by protocols to prevent routing from examining
+;; internal structure of values.
+(struct seal (contents) ;; NB. Neither transparent nor prefab
+  #:methods gen:custom-write
+  [(define (write-proc s port mode)
+     (fprintf port "#{~v}" (seal-contents s)))])
+
+(struct inbound (assertion) #:prefab)
+(struct outbound (assertion) #:prefab)
+
+(define (strong-gensym [head 'g] #:random-bytes [count 16])
+  (string->symbol
+   (format "~a~a"
+           head
+           (string-trim (bytes->string/latin-1
+                         (base64-encode (crypto-random-bytes count) #""))
+                        #px"=+"))))

imperative/bag.rkt

@@ -0,0 +1,72 @@
+#lang racket/base
+;; Bags and Deltas (which are Bags where item-counts can be negative).
+
+(provide make-bag ;; mutable
+         bag ;; immutable
+         bag-change!
+         bag-change
+         bag-ref
+         bag-clear!
+         bag-member?
+         bag-empty?
+         bag-key-count
+         in-bag
+         in-bag/count
+         for/bag/count
+         for/bag
+         set->bag
+         bag->set)
+
+(require racket/set)
+
+;; A `(MutableBagof X)` is a `(MutableHash X Nat)`, where the `Nat`
+;; against an `X` is its replication count in the bag.
+;;
+;; A `(Bagof X)` is similar, but immutable.
+;;
+;; `MutableDeltaof` and `Deltaof` are like `MutableBagof` and `Bagof`,
+;; respectively, except the replication counts can be negative.
+
+(define make-bag make-hash)
+(define bag hash)
+
+(define (bag-change! b x delta)
+  (define old-count (bag-ref b x))
+  (define new-count (+ old-count delta))
+  (if (zero? new-count)
+      (begin (hash-remove! b x)
+             (if (zero? old-count) 'absent->absent 'present->absent))
+      (begin (hash-set! b x new-count)
+             (if (zero? old-count) 'absent->present 'present->present))))
+
+(define (bag-change b x delta #:clamp? [clamp? #f])
+  (define old-count (bag-ref b x))
+  (define new-count (if clamp?
+                        (max 0 (+ old-count delta))
+                        (+ old-count delta)))
+  (if (zero? new-count)
+      (values (hash-remove b x)
+              (if (zero? old-count) 'absent->absent 'present->absent))
+      (values (hash-set b x new-count)
+              (if (zero? old-count) 'absent->present 'present->present))))
+
+(define (bag-ref b x)
+  (hash-ref b x 0))
+
+(define bag-clear! hash-clear!)
+(define bag-member? hash-has-key?)
+(define bag-empty? hash-empty?)
+(define bag-key-count hash-count)
+
+(define-syntax-rule (in-bag piece ...) (in-hash-keys piece ...))
+(define-syntax-rule (in-bag/count piece ...) (in-hash piece ...))
+
+(define-syntax-rule (for/bag/count iters expr ...) (for/hash iters expr ...))
+(define-syntax-rule (for/bag iters expr ...) (for/bag/count iters (values (begin expr ...) 1)))
+
+(define (set->bag s [count 1])
+  (for/hash [(e (in-set s))]
+    (values e count)))
+
+(define (bag->set b)
+  (list->set (hash-keys b)))

imperative/bin/syndicate-server-debug.rkt

@@ -0,0 +1,9 @@
+#lang racket
+(module+ main
+  (require racket/logging)
+  (with-logging-to-port (current-error-port)
+    (lambda ()
+      (dynamic-require '(submod imperative-syndicate/distributed main) #f))
+    'debug 'syndicate/distributed
+    'debug 'syndicate/federation
+    ))

imperative/bin/syndicate-server.rkt

@@ -0,0 +1,3 @@
+#lang racket
+(module+ main
+  (dynamic-require '(submod imperative-syndicate/distributed main) #f))

imperative/dataspace.rkt

@@ -0,0 +1,635 @@
+#lang racket/base
+
+(provide make-dataspace ;; TODO: how to cleanly provide this?
+         with-current-facet ;; TODO: shouldn't be provided
+         with-non-script-context ;; TODO: shouldn't be provided
+         run-scripts! ;; TODO: how to cleanly provide this?
+         apply-patch! ;; TODO: DEFINITELY SHOULDN'T BE PROVIDED - needed by relay.rkt
+
+         dataspace?
+         dataspace-assertions ;; TODO: shouldn't be provided - needed by various tests
+         dataspace-routing-table ;; TODO: shouldn't be provided - needed by relay.rkt
+         generate-id! ;; TODO: shouldn't be provided - inline syntax.rkt??
+
+         actor?
+         actor-id
+         actor-name
+         actor-dataspace ;; TODO: should this be provided?
+
+         facet?
+         facet-actor
+         facet-live?
+
+         field-handle ;; TODO: shouldn't be provided - inline syntax.rkt??
+         field-handle?
+         field-handle-name
+         field-handle-id
+         field-handle-owner
+         field-handle-value
+
+         current-actor-crash-logger
+
+         current-actor
+         current-facet
+         in-script? ;; TODO: shouldn't be provided - inline syntax.rkt??
+         capture-facet-context ;; TODO: shouldn't be provided - inline syntax.rkt??
+         suspend-script* ;; TODO: shouldn't be provided - inline syntax.rkt??
+
+         add-facet!
+         stop-facet!
+         add-stop-script! ;; TODO: shouldn't be provided - inline syntax.rkt??
+         add-endpoint!
+         remove-endpoint!
+         terminate-facet! ;; TODO: shouldn't be provided - inline syntax.rkt??
+         schedule-script! ;; TODO: shouldn't be provided - inline syntax.rkt??
+         push-script! ;; TODO: shouldn't be provided - inline syntax.rkt??
+         ensure-in-script! ;; TODO: shouldn't be provided - inline syntax.rkt??
+
+         spawn! ;; TODO: should this be provided?
+         enqueue-send! ;; TODO: should this be provided?
+         enqueue-deferred-turn! ;; TODO: should this be provided?
+         adhoc-retract! ;; TODO: should this be provided?
+         adhoc-assert! ;; TODO: should this be provided?
+         actor-adhoc-assertions ;; TODO: should this be provided?
+         )
+
+(require syndicate/functional-queue)
+(require syndicate/dataflow)
+(require racket/match)
+(require racket/set)
+(require (only-in racket/exn exn->string))
+
+(require "skeleton.rkt")
+(require "pattern.rkt")
+(require "bag.rkt")
+(require "reflection.rkt")
+
+;; An `ActorID` uniquely identifies an actor in a `Dataspace`.
+;; A `FID` is a Facet ID, uniquely identifying a facet in a `Dataspace`.
+
+;; A `Dataspace` is a ... TODO
+
+;; An `Action` is one of
+;;  - `(patch (MutableDeltaof Assertion))`
+;;  - `(message Assertion)`
+;;  - `(spawn Any BootProc (Set Assertion))`
+;;  - `(quit)`
+;;  - `(deferred-turn (-> Any))`
+(struct patch (changes) #:prefab)
+(struct message (body) #:prefab)
+(struct spawn (name boot-proc initial-assertions) #:prefab)
+(struct quit () #:prefab)
+(struct deferred-turn (continuation) #:prefab)
+
+(struct dataspace ([next-id #:mutable] ;; Nat
+                   routing-table ;; Skeleton
+                   ;; v TODO: Caches have to be bags, not sets; once
+                   ;; this change is made, can I avoid keeping a bag
+                   ;; of assertions in the dataspace as a whole?
+                   assertions ;; (MutableBagof Assertion)
+                   dataflow ;; DataflowGraph
+                   [runnable #:mutable] ;; (Listof Actor)
+                   [pending-actions #:mutable] ;; (Queueof ActionGroup)
+                   ) #:transparent)
+
+(struct actor (id ;; ActorID
+               dataspace ;; Dataspace
+               name ;; Any
+               [root-facet #:mutable] ;; (Option Facet)
+               [runnable? #:mutable] ;; Boolean
+               pending-scripts ;; (MutableVectorof (Queueof (-> Any)))
+               [pending-actions #:mutable] ;; (Queueof Action)
+               [adhoc-assertions #:mutable] ;; (Bagof Assertion)
+               [cleanup-changes #:mutable] ;; (Deltaof Assertion)
+               )
+  #:methods gen:custom-write
+  [(define (write-proc a p mode)
+     (fprintf p "#<actor ~a ~v>" (actor-id a) (actor-name a)))])
+
+(struct action-group (actor ;; (U Actor 'meta)
+                      actions ;; (Listof Action)
+                      )
+  #:transparent)
+
+(struct facet (id ;; FID
+               [live? #:mutable] ;; Boolean
+               actor ;; Actor
+               parent ;; (Option Facet)
+               endpoints ;; (MutableHash EID Endpoint)
+               [stop-scripts #:mutable] ;; (Listof Script) -- IN REVERSE ORDER
+               [children #:mutable] ;; (Seteqof Facet)
+               )
+  #:methods gen:custom-write
+  [(define (write-proc f p mode)
+     (local-require (only-in racket/string string-join))
+     (define (facet-id-chain f)
+       (if f
+           (cons (number->string (facet-id f)) (facet-id-chain (facet-parent f)))
+           '()))
+     (fprintf p "#<facet ~a ~v ~a>"
+              (actor-id (facet-actor f))
+              (actor-name (facet-actor f))
+              (string-join (facet-id-chain f) ":")))])
+
+(struct endpoint (id ;; EID
+                  [assertion #:mutable] ;; Assertion
+                  [handler #:mutable] ;; (Option SkInterest)
+                  update-fn ;; (-> (Values Assertion (Option SkInterest)))
+                  )
+  #:methods gen:custom-write
+  [(define (write-proc e p mode)
+     (fprintf p "#<endpoint ~a>" (endpoint-id e)))])
+
+;; TODO: the field ownership checks during field-ref/field-set! might
+;; be quite expensive. Are they worth it?
+(struct field-handle (name ;; Symbol
+                      id ;; Nat
+                      owner ;; Actor
+                      [value #:mutable] ;; Any
+                      )
+  #:methods gen:custom-write
+  [(define (write-proc f port mode)
+     (fprintf port "#<field-handle:~a:~a>" (field-handle-name f) (field-handle-id f)))]
+  #:property prop:procedure
+  (case-lambda
+    [(f)
+     (define ac (current-actor))
+     (when (not (eq? (field-handle-owner f) ac)) (field-scope-error 'field-ref f))
+     (dataflow-record-observation! (dataspace-dataflow (actor-dataspace ac)) f)
+     (field-handle-value f)]
+    [(f v)
+     (define ac (current-actor))
+     (when (not (eq? (field-handle-owner f) (current-actor))) (field-scope-error 'field-set! f))
+     (when (not (equal? (field-handle-value f) v))
+       (dataflow-record-damage! (dataspace-dataflow (actor-dataspace ac)) f)
+       (set-field-handle-value! f v))]))
+
+(define (field-scope-error who f)
+  (error who "Field ~a used out-of-scope; owner = ~a, current = ~a"
+         f
+         (field-handle-owner f)
+         (current-actor)))
+
+;; Parameterof (Actor Exn -> Void)
+(define current-actor-crash-logger
+  (make-parameter
+   (lambda (a e)
+     (log-error "Actor ~a died with exception:\n~a" a (exn->string e)))))
+
+(define (current-actor) (facet-actor (current-facet)))
+
+;; Parameterof Facet
+(define current-facet (make-parameter #f))
+
+;; Parameterof Boolean
+(define in-script? (make-parameter #t))
+
+;;---------------------------------------------------------------------------
+
+;; Script priorities. These are used to ensure that the results of
+;; some *side effects* are visible to certain pieces of code.
+
+(module priorities racket/base
+  (require (for-syntax racket/base))
+
+  (define-syntax (define-priority-levels stx)
+    (let loop ((counter 0) (stx (syntax-case stx ()
+                                  [(_ level ...) #'(level ...)])))
+      (syntax-case stx ()
+        [()
+         #'(void)]
+        [(#:count c)
+         #`(begin (define c #,counter)
+                  (provide c))]
+        [(this-level more ...)
+         #`(begin (define this-level #,counter)
+                  (provide this-level)
+                  #,(loop (+ counter 1) #'(more ...)))])))
+
+  (define-priority-levels ;; highest-priority to lowest-priority
+    *query-priority-high*
+    *query-priority*
+    *query-handler-priority*
+    *normal-priority*
+    *gc-priority*
+    *idle-priority*
+    #:count priority-count))
+
+(require (submod "." priorities))
+
+;;---------------------------------------------------------------------------
+
+(define (make-dataspace boot-proc)
+  (dataspace 0
+             (make-empty-skeleton)
+             (make-bag)
+             (make-dataflow-graph)
+             '()
+             (enqueue (make-queue) (action-group 'meta (list (spawn #f boot-proc (set)))))))
+
+(define (generate-id! ds)
+  (let ((id (dataspace-next-id ds)))
+    (set-dataspace-next-id! ds (+ id 1))
+    id))
+
+(define (add-actor! ds name boot-proc initial-assertions)
+  (define the-actor-id (generate-id! ds))
+  (define filtered-initial-assertions (set-remove initial-assertions (void)))
+  (define initial-delta (set->bag filtered-initial-assertions +1))
+  (define the-actor (actor the-actor-id
+                           ds
+                           name
+                           #f
+                           #f
+                           (make-vector priority-count (make-queue))
+                           (make-queue)
+                           initial-delta
+                           (bag)))
+  (apply-patch! ds the-actor initial-delta)
+  ;; Root facet is a dummy "system" facet that exists to hold one-or-more "user" "root" facets.
+  (add-facet! #f
+              the-actor
+              #f
+              (lambda ()
+                ;; The "true root", user-visible facet.
+                (add-facet! #f
+                            the-actor
+                            (current-facet)
+                            (lambda ()
+                              (boot-proc)))
+                (for [(a filtered-initial-assertions)]
+                  (adhoc-retract! the-actor a)))))
+
+(define-syntax-rule (with-current-facet [f0] body ...)
+  (let ((f f0))
+    ;; (when (not f)
+    ;;   (error 'with-current-facet "Cannot use with-current-facet this way"))
+    (parameterize ((current-facet f))
+      (with-handlers ([(lambda (e) (not (exn:break? e)))
+                       (lambda (e)
+                         (define a (current-actor))
+                         ((current-actor-crash-logger) a e)
+                         (abandon-queued-work! a)
+                         ;; v Supply #f for `emit-patches?` here
+                         ;; because we are in an uncertain limbo after
+                         ;; discarding previously-queued actions.
+                         ;; Instead of emitting patches to orderly
+                         ;; tear down assertions from endpoints, we
+                         ;; rely on the recorded `cleanup-changes`.
+                         (terminate-actor! a #f e))]) ;; TODO: tracing
+        (call-with-syndicate-prompt
+         (lambda ()
+           body ...))
+        (void)))))
+
+(define-syntax-rule (with-non-script-context body ...)
+  (parameterize ((in-script? #f))
+    body ...))
+
+(define (capture-facet-context proc)
+  (let ((f (current-facet)))
+    ;; (when (not f)
+    ;;   (error 'capture-facet-context "Cannot capture non-facet"))
+    (lambda args
+      (with-current-facet [f]
+        (apply proc args)))))
+
+(define (pop-next-script! ac)
+  (define priority-levels (actor-pending-scripts ac))
+  (let loop ((level 0))
+    (and (< level (vector-length priority-levels))
+         (let ((q (vector-ref priority-levels level)))
+           (if (queue-empty? q)
+               (loop (+ level 1))
+               (let-values (((script q) (dequeue q)))
+                 (vector-set! priority-levels level q)
+                 script))))))
+
+(define (run-actor-pending-scripts! ds ac)
+  (let loop ()
+    (let ((script (pop-next-script! ac)))
+      (and script
+           (begin (script)
+                  (refresh-facet-assertions! ds)
+                  (loop))))))
+
+(define (refresh-facet-assertions! ds)
+  (with-non-script-context
+    (dataflow-repair-damage! (dataspace-dataflow ds)
+                             (lambda (subject-id)
+                               (match-define (list f eid) subject-id)
+                               (when (facet-live? f) ;; TODO: necessary test, or tautological?
+                                 (define ac (facet-actor f))
+                                 (with-current-facet [f]
+                                   (define ep (hash-ref (facet-endpoints f) eid))
+                                   (match-define (endpoint _ old-assertion old-handler update-fn) ep)
+                                   (define-values (new-assertion new-handler) (update-fn))
+                                   (when (not (equal? old-assertion new-assertion))
+                                     (retract! ac old-assertion)
+                                     (when old-handler (dataspace-unsubscribe! ds old-handler))
+                                     (set-endpoint-assertion! ep new-assertion)
+                                     (set-endpoint-handler! ep new-handler)
+                                     (assert! ac new-assertion)
+                                     (when new-handler (dataspace-subscribe! ds new-handler)))))))))
+
+(define (commit-actions! ds ac)
+  (define pending (queue->list (actor-pending-actions ac)))
+  ;; (log-info "commit-actions!: ~a actions ~a" ac pending)
+  (when (pair? pending)
+    (set-actor-pending-actions! ac (make-queue))
+    (set-dataspace-pending-actions! ds (enqueue (dataspace-pending-actions ds)
+                                                (action-group ac pending)))))
+
+(define (run-all-pending-scripts! ds)
+  (define runnable (dataspace-runnable ds))
+  (set-dataspace-runnable! ds '())
+  (for [(ac (in-list runnable))]
+    (run-actor-pending-scripts! ds ac)
+    (set-actor-runnable?! ac #f)
+    (commit-actions! ds ac)))
+
+(define (perform-pending-actions! ds)
+  (define groups (queue->list (dataspace-pending-actions ds)))
+  (set-dataspace-pending-actions! ds (make-queue))
+  (for [(group (in-list groups))]
+    (match-define (action-group ac actions) group)
+    (for [(action (in-list actions))]
+      ;; (log-info "~a in ~a performing ~a" ac (eq-hash-code ds) action)
+      (match action
+        [(patch delta)
+         (apply-patch! ds ac delta)]
+        [(message body)
+         (send-assertion! (dataspace-routing-table ds) body)]
+        [(spawn name boot-proc initial-assertions)
+         (add-actor! ds name boot-proc initial-assertions)]
+        [(quit)
+         (apply-patch! ds ac (actor-cleanup-changes ac))]
+        [(deferred-turn k)
+         (push-script! ac k)])
+      (run-all-pending-scripts! ds))))
+
+(define (apply-patch! ds ac delta)
+  (when (not (bag-empty? delta))
+    (define ds-assertions (dataspace-assertions ds))
+    ;; (log-info "apply-patch! ~a ~v" ac delta)
+    ;; (for [((a c) (in-bag/count ds-assertions))] (log-info "  . ~v = ~v" a c))
+    ;; (for [((a c) (in-bag/count delta))] (log-info "  → ~v = ~v" a c))
+    (define rt (dataspace-routing-table ds))
+    (define pending-removals '())
+    (define new-cleanup-changes
+      (for/fold [(cleanup-changes (actor-cleanup-changes ac))] [((a count) (in-bag/count delta))]
+        (match (bag-change! ds-assertions a count)
+          ['present->absent (set! pending-removals (cons a pending-removals))]
+          ['absent->present (add-assertion! rt a)]
+          ;; 'absent->absent absurd
+          ['present->present (void)]) ;; i.e. no visible change
+        (define-values (updated-bag _summary) (bag-change cleanup-changes a (- count)))
+        updated-bag))
+    (for [(a (in-list pending-removals))]
+      (remove-assertion! rt a))
+    (set-actor-cleanup-changes! ac new-cleanup-changes)))
+
+(define (run-scripts! ds)
+  (run-all-pending-scripts! ds)
+  (perform-pending-actions! ds)
+  ;; TODO: figure out when a dataspace should quit itself. Given the
+  ;; mutable nature of the implementation, maybe never? It might be
+  ;; being held elsewhere!
+  (not (and (null? (dataspace-runnable ds))
+            (queue-empty? (dataspace-pending-actions ds)))))
+
+(define (add-facet! where actor parent boot-proc)
+  (when (and (not (in-script?)) where)
+    (error 'add-facet!
+           "~a: Cannot add facet outside script; are you missing an (on ...)?"
+           where))
+  (define f (facet (generate-id! (actor-dataspace actor))
+                   #t
+                   actor
+                   parent
+                   (make-hash)
+                   '()
+                   (seteq)))
+  (if parent
+      (set-facet-children! parent (set-add (facet-children parent) f))
+      (begin
+        (when (actor-root-facet actor)
+          ;; This should never happen. We deliberately create an
+          ;; otherwise-dummy root facet for each actor specifically to
+          ;; hold user facets, and there should be no way for the user
+          ;; to stop that root facet explicitly, which means user code
+          ;; can't start any replacements for it at all, let alone
+          ;; more than one!
+          (error 'add-facet! "INTERNAL ERROR: Attempt to add second root facet"))
+        (set-actor-root-facet! actor f)))
+  (with-current-facet [f]
+    (with-non-script-context
+      (boot-proc)))
+  (push-script! actor (lambda ()
+                        (when (or (and parent (not (facet-live? parent))) (facet-inert? f))
+                          (terminate-facet! f)))))
+
+(define (facet-inert? f)
+  (and (hash-empty? (facet-endpoints f))
+       (set-empty? (facet-children f))))
+
+(define (schedule-script! #:priority [priority *normal-priority*] ac thunk)
+  (push-script! #:priority priority ac (capture-facet-context thunk)))
+
+(define (push-script! #:priority [priority *normal-priority*] ac thunk-with-context)
+  (when (not (actor-runnable? ac))
+    (set-actor-runnable?! ac #t)
+    (let ((ds (actor-dataspace ac)))
+      (set-dataspace-runnable! ds (cons ac (dataspace-runnable ds)))))
+  (define v (actor-pending-scripts ac))
+  (vector-set! v priority (enqueue (vector-ref v priority) thunk-with-context)))
+
+(define (retract-facet-assertions-and-subscriptions! f emit-patches?)
+  (define ac (facet-actor f))
+  (define ds (actor-dataspace ac))
+  (push-script! ac (lambda ()
+                     (for [((eid ep) (in-hash (facet-endpoints f)))]
+                       (destroy-endpoint! ds ac f ep emit-patches?))
+                     (hash-clear! (facet-endpoints f)))))
+
+(define (abandon-queued-work! ac)
+  (set-actor-pending-actions! ac (make-queue))
+  (let ((scripts (actor-pending-scripts ac)))
+    (for [(i (in-range (vector-length scripts)))]
+      (vector-set! scripts i (make-queue)))))
+
+;; Abruptly terminates an entire actor, without running stop-scripts etc.
+(define (terminate-actor! the-actor emit-patches? maybe-exn)
+  (when emit-patches?
+    (push-script! the-actor (lambda () (for [(a (in-bag (actor-adhoc-assertions the-actor)))]
+                                         (retract! the-actor a)))))
+  (let ((f (actor-root-facet the-actor)))
+    (when f
+      (let abort-facet! ((f f))
+        (set-facet-live?! f #f)
+        (for [(child (in-set (facet-children f)))] (abort-facet! child))
+        (retract-facet-assertions-and-subscriptions! f emit-patches?))))
+  (push-script! the-actor (lambda ()
+                            (let ((name (actor-name the-actor)))
+                              (when name
+                                (enqueue-send! the-actor (terminated name maybe-exn))))
+                            (enqueue-action! the-actor (quit)))))
+
+;; Cleanly terminates a facet and its children, running stop-scripts etc.
+(define (terminate-facet! f)
+  (when (facet-live? f)
+    (define ac (facet-actor f))
+    (define parent (facet-parent f))
+    (if parent
+        (set-facet-children! parent (set-remove (facet-children parent) f))
+        (set-actor-root-facet! ac #f))
+
+    (set-facet-live?! f #f)
+
+    (for [(child (in-set (facet-children f)))] (terminate-facet! child))
+
+    ;; Run stop-scripts after terminating children. This means that
+    ;; children's stop-scripts run before ours.
+    (push-script! ac (lambda ()
+                       (with-current-facet [f]
+                         (for [(script (in-list (reverse (facet-stop-scripts f))))]
+                           (script)))))
+
+    (retract-facet-assertions-and-subscriptions! f #t)
+
+    (push-script! #:priority *gc-priority* ac
+                  (lambda ()
+                    (if parent
+                        (when (facet-inert? parent) (terminate-facet! parent))
+                        (terminate-actor! ac #t #f))))))
+
+(define (stop-facet! f stop-script)
+  (define ac (facet-actor f))
+  (with-current-facet [(facet-parent f)] ;; run in parent context wrt terminating facet
+    (schedule-script! ac (lambda ()
+                           (terminate-facet! f)
+                           (schedule-script! ac stop-script)))))
+
+(define (add-stop-script! f script-proc)
+  (set-facet-stop-scripts! f (cons script-proc (facet-stop-scripts f))))
+
+(define (add-endpoint! f where dynamic? update-fn)
+  (when (in-script?)
+    (error 'add-endpoint!
+           "~a: Cannot add endpoint in script; are you missing a (react ...)?"
+           where))
+  (define ds (actor-dataspace (facet-actor f)))
+  (define eid (generate-id! ds))
+  (define-values (assertion handler)
+    (parameterize ((current-dataflow-subject-id (if dynamic? (list f eid) #f)))
+      (call-with-syndicate-prompt update-fn)))
+  (define ep (endpoint eid assertion handler update-fn))
+  (assert! (facet-actor f) assertion)
+  (when handler (dataspace-subscribe! ds handler))
+  (hash-set! (facet-endpoints f) eid ep)
+  eid)
+
+(define (remove-endpoint! f eid)
+  (define eps (facet-endpoints f))
+  (define ep (hash-ref eps eid #f))
+  (when ep
+    (define ac (facet-actor f))
+    (define ds (actor-dataspace ac))
+    (destroy-endpoint! ds ac f ep #t)
+    (hash-remove! eps eid)))
+
+(define (destroy-endpoint! ds ac f ep emit-patches?)
+  (match-define (endpoint eid assertion handler _update-fn) ep)
+  (dataflow-forget-subject! (dataspace-dataflow ds) (list f eid))
+  (when emit-patches? (retract! ac assertion))
+  (when handler (dataspace-unsubscribe! ds handler)))
+
+(define (enqueue-action! ac action)
+  (set-actor-pending-actions! ac (enqueue (actor-pending-actions ac) action)))
+
+(define (ensure-patch-action! ac)
+  (let ((q (actor-pending-actions ac)))
+    (when (or (queue-empty? q) (not (patch? (queue-last q))))
+      (enqueue-action! ac (patch (make-bag)))))
+  (patch-changes (queue-last (actor-pending-actions ac))))
+
+(define (retract! ac assertion)
+  (when (not (void? assertion))
+    (bag-change! (ensure-patch-action! ac) assertion -1)))
+
+(define (assert! ac assertion)
+  (when (not (void? assertion))
+    (bag-change! (ensure-patch-action! ac) assertion +1)))
+
+(define (adhoc-retract! ac assertion [count 1])
+  (when (not (void? assertion))
+    (define-values (new-assertions summary)
+      (bag-change (actor-adhoc-assertions ac) assertion (- count) #:clamp? #t))
+    (set-actor-adhoc-assertions! ac new-assertions)
+    (match summary
+      ;; 'absent->present absurd (if the call to `adhoc-retract!`
+      ;; matches a previous `adhoc-assert!`)
+      ['present->absent (retract! ac assertion)]
+      ['present->present (void)]
+      ['absent->absent (void)]))) ;; can happen if we're exploiting the clamping
+
+(define (adhoc-assert! ac assertion [count 1])
+  (when (not (void? assertion))
+    (define-values (new-assertions summary)
+      (bag-change (actor-adhoc-assertions ac) assertion count))
+    (set-actor-adhoc-assertions! ac new-assertions)
+    (match summary
+      ;; 'absent->absent and 'present->absent absurd (assuming there
+      ;; haven't been too many calls to `adhoc-retract!` in the past)
+      ['absent->present (assert! ac assertion)]
+      ['present->present (void)])))
+
+(define (dataspace-unsubscribe! ds h)
+  (remove-interest! (dataspace-routing-table ds) h))
+
+(define (dataspace-subscribe! ds h)
+  (add-interest! (dataspace-routing-table ds) h))
+
+(define (ensure-in-script! who)
+  (when (not (in-script?))
+    (error who "Attempt to perform action outside script; are you missing an (on ...)?")))
+
+(define (enqueue-send! ac body)
+  (enqueue-action! ac (message body)))
+
+(define (enqueue-deferred-turn! ac k)
+  (enqueue-action! ac (deferred-turn (capture-facet-context k))))
+
+(define (spawn! ac name boot-proc initial-assertions)
+  (enqueue-action! ac (spawn name boot-proc initial-assertions)))
+
+;;---------------------------------------------------------------------------
+;; Script suspend-and-resume.
+
+(define prompt-tag (make-continuation-prompt-tag 'syndicate))
+
+(define (call-with-syndicate-prompt thunk)
+  (call-with-continuation-prompt thunk prompt-tag))
+
+(define (suspend-script* where proc)
+  (when (not (in-script?))
+    (error 'suspend-script
+           "~a: Cannot suspend script outside script; are you missing an (on ...)?"
+           where))
+  (call-with-composable-continuation
+   (lambda (k)
+     (abort-current-continuation
+      prompt-tag
+      (lambda ()
+        (define in? (in-script?))
+        (define raw-resume-parent
+          (capture-facet-context
+           (lambda results
+             (parameterize ((in-script? in?))
+               (apply k results)))))
+        (define resume-parent
+          (lambda results
+            (push-script! (current-actor)
+                          (lambda () (apply raw-resume-parent results)))))
+        (proc resume-parent))))
+   prompt-tag))

imperative/distributed.rkt

@@ -0,0 +1,5 @@
+#lang imperative-syndicate
+
+(provide (all-from-out "distributed/main.rkt"))
+(require/activate "distributed/main.rkt")
+(module+ main (require (submod "distributed/main.rkt" main)))

imperative/distributed/buffer.rkt

@@ -0,0 +1,14 @@
+#lang imperative-syndicate
+
+(provide make-buffer)
+
+(define (make-buffer)
+  (field [pending '()])
+  (define (push item)
+    (pending (cons item (pending))))
+  (define (drain handler)
+    (begin/dataflow
+      (when (pair? (pending))
+        (for [(item (in-list (reverse (pending))))] (handler item))
+        (pending '()))))
+  (values push drain))

imperative/distributed/client.rkt

@@ -0,0 +1,110 @@
+#lang imperative-syndicate
+
+(provide generic-client-session-facet)
+
+(require "wire-protocol.rkt")
+(require "internal-protocol.rkt")
+(require "protocol.rkt")
+(require "turn.rkt")
+(require imperative-syndicate/term)
+
+(require/activate "heartbeat.rkt")
+
+(define-logger syndicate/distributed)
+
+(spawn #:name 'client-factory
+       (during (to-server $a _) (assert (server-connection a)))
+       (during (observe (from-server $a _)) (assert (server-connection a)))
+       (during (observe (server-connected $a)) (assert (server-connection a))))
+
+(struct sub (spec [captures #:mutable]) #:transparent)
+
+(define (generic-client-session-facet address scope w)
+  (on-start (log-syndicate/distributed-info "Connected to ~v" address))
+  (on-stop (log-syndicate/distributed-info "Disconnected from ~v" address))
+  (assert (server-connected address))
+  (assert (server-session-connected address))
+
+  (when (log-level? syndicate/distributed-logger 'debug)
+    (set! w (let ((w* w))
+              (lambda (p)
+                (log-syndicate/distributed-debug "C OUT ~v ~v" address p)
+                (w* p)))))
+
+  (define turn (turn-recorder (lambda (items) (w (Turn items)))))
+
+  (define next-ep
+    (let ((counter 0))
+      (lambda ()
+        (begin0 counter
+          (set! counter (+ counter 1))))))
+
+  (define pubs (hash))
+  (define subs (hash))
+  (define matches (hash))
+
+  (on-start (w (Connect scope)))
+  (on-stop (for* [(s (in-hash-values matches)) (a (in-hash-values (sub-captures s)))] (retract! a)))
+
+  (define (instantiate s vs)
+    (instantiate-term->value (from-server address (sub-spec s)) vs))
+
+  (on (asserted (to-server address $a))
+      (define ep (next-ep))
+      (extend-turn! turn (Assert ep a))
+      (set! pubs (hash-set pubs a ep)))
+
+  (on (retracted (to-server address $a))
+      (define ep (hash-ref pubs a))
+      (extend-turn! turn (Clear ep))
+      (set! pubs (hash-remove pubs a)))
+
+  (on (message (to-server address $a))
+      (extend-turn! turn (Message a)))
+
+  (on (asserted (observe (from-server address $spec)))
+      (define ep (next-ep))
+      (extend-turn! turn (Assert ep (observe spec)))
+      (set! subs (hash-set subs spec ep))
+      (set! matches (hash-set matches ep (sub spec (hash)))))
+
+  (on (retracted (observe (from-server address $spec)))
+      (extend-turn! turn (Clear (hash-ref subs spec)))
+      (set! subs (hash-remove subs spec)))
+
+  (define reset-heartbeat! (heartbeat (list 'client address scope)
+                                      w
+                                      (lambda () (stop-current-facet))))
+
+  (on (message (server-packet address _))
+      (reset-heartbeat!))
+
+  (on (message (server-packet address (Ping)))
+      (w (Pong)))
+
+  (on (message (server-packet address (Err $detail $context)))
+      (log-syndicate/distributed-error "Error from ~a: ~v~a"
+                                       address
+                                       detail
+                                       (if context
+                                           (format " ~v" context)
+                                           ""))
+      (stop-current-facet))
+
+  (on (message (server-packet address (Turn $items)))
+      (for [(item (in-list items))]
+        (match item
+          [(Add ep vs) (let* ((s (hash-ref matches ep))
+                              (a (instantiate s vs)))
+                         (set-sub-captures! s (hash-set (sub-captures s) vs a))
+                         (assert! a))]
+          [(Del ep vs) (let* ((s (hash-ref matches ep))
+                              (a (hash-ref (sub-captures s) vs)))
+                         (retract! a)
+                         (set-sub-captures! s (hash-remove (sub-captures s) vs)))]
+          [(Msg ep vs) (let* ((s (hash-ref matches ep)))
+                         (send! (instantiate s vs)))]
+          [(End ep)    (let* ((s (hash-ref matches ep #f)))
+                         (when s
+                           (for [(a (in-hash-values (sub-captures s)))] (retract! a))
+                           (set! matches (hash-remove matches ep))))]))))

imperative/distributed/client/loopback.rkt

@@ -0,0 +1,22 @@
+#lang imperative-syndicate
+
+(require "../client.rkt")
+(require "../wire-protocol.rkt")
+(require "../internal-protocol.rkt")
+(require "../protocol.rkt")
+
+(require imperative-syndicate/protocol/credit)
+
+(require/activate imperative-syndicate/distributed/server)
+
+(spawn #:name 'loopback-client-factory
+       (during/spawn (server-connection ($ address (server-loopback-connection $scope)))
+         #:name address
+         (assert (server-poa address))
+         (on (message (message-server->poa address $p)) (send! (server-packet address p)))
+         (on-start (react
+                    (stop-when (asserted (observe (message-poa->server address _)))
+                      (react (generic-client-session-facet
+                              address
+                              scope
+                              (lambda (x) (send! (message-poa->server address x))))))))))

imperative/distributed/client/tcp.rkt

@@ -0,0 +1,44 @@
+#lang imperative-syndicate
+
+(require "../client.rkt")
+(require "../wire-protocol.rkt")
+(require "../internal-protocol.rkt")
+(require "../protocol.rkt")
+(require imperative-syndicate/reassert)
+
+(require/activate imperative-syndicate/drivers/tcp)
+
+(spawn #:name 'tcp-client-factory
+       (during/spawn (server-connection ($ address (server-tcp-connection $host $port $scope)))
+         #:name address
+         (define id (list (gensym 'client) host port))
+
+         (reassert-on (tcp-connection id (tcp-address host port))
+                      (retracted (tcp-accepted id))
+                      (asserted (tcp-rejected id _))
+                      (retracted (server-transport-connected address))
+                      (retracted (server-session-connected address)))
+
+         (during (tcp-accepted id)
+           (on-start (issue-unbounded-credit! tcp-in id))
+           (assert (server-transport-connected address))
+           (define accumulate! (packet-accumulator (lambda (p) (send! (server-packet address p)))))
+           (on (message (tcp-in id $bs)) (accumulate! bs)))
+
+         (during (server-transport-connected address)
+           ;; If we run generic-client-session-facet in the `tcp-accepted` handler above, then
+           ;; unfortunately disconnection of the TCP socket on error overtakes the error report
+           ;; itself, terminating the generic-client-session-facet before it has a chance to
+           ;; handle the error report.
+           ;;
+           ;; Could timing errors like that be something a type system could help us with? The
+           ;; conversation in `server-packet`s is sort-of "nested" inside the conversation in
+           ;; `tcp-in`s; a single facet reacting to both conversations (in this instance, to
+           ;; `server-packets` in an implicit frame, but explicitly to the frame of the
+           ;; `tcp-in`s, namely `tcp-accepted`) is probably an error. Or rather, any situation
+           ;; where pending "inner conversation" business could be obliterated by discarding a
+           ;; facet based on "outer conversation" framing is probably an error.
+           ;;
+           (generic-client-session-facet address
+                                         scope
+                                         (lambda (x) (send! (tcp-out id (encode x))))))))

imperative/distributed/federation.rkt

@@ -0,0 +1,468 @@
+#lang imperative-syndicate
+;; Relays for federation, both "client" (outbound) and "server" (inbound) ends.
+
+(require "wire-protocol.rkt")
+(require "internal-protocol.rkt")
+(require "protocol.rkt")
+(require "buffer.rkt")
+(require "turn.rkt")
+
+(require imperative-syndicate/term)
+(require imperative-syndicate/reassert)
+(require racket/set)
+
+(require/activate imperative-syndicate/drivers/tcp)
+
+(define-logger syndicate/federation)
+
+;; A federated scope (as distinct from a non-federated server scope)
+;; communicates via "links" to "peers", which come in three flavours:
+;;   - inbound links, aka "downlinks" from the POV of this node, which
+;;     result from incoming TCP/websocket/etc connections
+;;   - outbound links, aka "uplinks", which reach out to a remote TCP/
+;;     websocket/etc server
+;;   - local links, (usually? always?) just one per scope, which
+;;     connect the federated scope to its local server scope
+;;
+;; All links are identified by a link ID, scoped the same as
+;; connection IDs in <server.rkt> (namely, dataspace-unique). Links
+;; are stateful.
+;;
+;; The link protocol is enacted in special non-federated, local
+;; federation-management server scopes, identified by
+;; `federation-management-scope` assertions. The code in this module
+;; responds to assertions and messages in these scopes. Besides its
+;; scoped nature, the protocol is otherwise ordinary. By reusing
+;; Syndicate itself for management and operation of federation, we are
+;; able to address transport independently of federation.
+;;
+;; Inbound links are set up by code outside this module in response to
+;; the appearance of some new federated peer "downstream" of this one.
+;; For example, after establishing a new client-server connection to a
+;; federation-management scope, a remote peer may begin using the link
+;; protocol.
+;;
+;; Outbound links are created in response to an assertion of a
+;; `federated-uplink` record in a federation-management scope. Each
+;; such record contains a triple of a local scope ID, a client
+;; transport address (such as `server-tcp-connection` from
+;; <client/tcp.rkt>), and a remote scope ID. Together, these federate
+;; the local and remote scope IDs via a client-server connection to
+;; the given address.
+;;
+;; Local links are a special case of inbound link. They are created
+;; automatically whenever there is an active server scope of the same
+;; name as a federated scope.
+;;
+;; Local federation-management scopes must not be federated.
+;; TODO: Enforce this?
+
+;; Subscription IDs (== "endpoint IDs") must be connection-unique AND
+;; must correspond one-to-one with a specific subscription spec. That
+;; is, a subscription ID is merely connection-local shorthand for its
+;; spec, and two subscription IDs within a connection must be `equal?`
+;; exactly when their corresponding specs are `equal?`.
+;;
+;; Local IDs must be scope-unique. They are used as subscription IDs
+;; in outbound messages.
+;;
+;; Each federated scope maintains a bidirectional mapping between
+;; subscription IDs (each scoped within its connection ID) and local
+;; IDs. One local ID may map to multiple subscription IDs - this is
+;; the place where aggregation pops up.
+
+;; Unlike the client/server protocol, both Actions and Events are
+;; BIDIRECTIONAL, travelling in both directions along edges linking
+;; peer nodes.
+
+;;---------------------------------------------------------------------------
+;; Outbound links. (Really, they end up being a kind of "inbound link"
+;; too! Ultimately we have just *links*, connected to arbitrary
+;; things. For traditional "inbound", it's some remote party that has
+;; connected to us; for "local", it's a local server scope; for
+;; "outbound", it's a connection to another server that we reached out
+;; to.)
+
+(spawn #:name 'federated-uplink-factory
+       (during (federation-management-scope $management-scope)
+         (during/spawn (server-envelope management-scope
+                                        ($ link (federated-uplink $local-scope
+                                                                  $peer-addr
+                                                                  $remote-scope)))
+           #:name link
+           (during (server-connected peer-addr)
+
+             (assert (server-proposal management-scope (federated-uplink-connected link)))
+             ;; ^ out to local requester
+
+             (define session-id (strong-gensym 'peer-))
+             (assert (server-proposal management-scope (federated-link session-id local-scope)))
+             (assert (to-server peer-addr (federated-link session-id remote-scope)))
+
+             ;; We have to buffer in both directions, because at startup there's latency
+             ;; between asserting a federated-link record and it being ready to receive
+             ;; message-poa->server records.
+             (define-values (push-in drain-in) (make-buffer))
+             (define-values (push-out drain-out) (make-buffer))
+
+             (on (message (from-server peer-addr (message-server->poa session-id $p)))
+                 (push-in p))
+             (on (message (server-envelope management-scope (message-server->poa session-id $p)))
+                 (push-out p))
+
+             (define (wrap p) (message-poa->server session-id p))
+             (during (server-envelope management-scope (federated-link-ready session-id))
+               (during (from-server peer-addr (federated-link-ready session-id))
+                 (drain-in (lambda (p) (send! (server-proposal management-scope (wrap p)))))
+                 (drain-out (lambda (p) (send! (to-server peer-addr (wrap p)))))))))))
+
+;;---------------------------------------------------------------------------
+;; Local links.
+
+(spawn #:name 'federated-local-link-factory
+
+       (struct sub (spec [captures #:mutable]) #:transparent)
+
+       (during (federation-management-scope $management-scope)
+         (during (server-envelope management-scope (federated-link _ $scope))
+           (during/spawn (server-active scope)
+             #:name (list 'local-link management-scope scope)
+
+             (define session-id (gensym 'local-link))
+             (assert (server-proposal management-scope (federated-link session-id scope)))
+
+             (define (!! m)
+               (send! (server-proposal management-scope (message-poa->server session-id m))))
+
+             (define turn (turn-recorder (lambda (items) (!! (Turn items)))))
+
+             (define remote-endpoints (hash))
+             (define local-endpoints (hash))
+             (define local-matches (hash))
+
+             (define (instantiate s vs)
+               (instantiate-term->value (server-envelope scope (sub-spec s)) vs))
+
+             (on (asserted (observe (server-envelope scope $spec)))
+                 (define ep (gensym 'ep))
+                 (extend-turn! turn (Assert ep (observe spec)))
+                 (set! local-endpoints (hash-set local-endpoints spec ep))
+                 (set! local-matches (hash-set local-matches ep (sub spec (hash)))))
+
+             (on (retracted (observe (server-envelope scope $spec)))
+                 (define ep (hash-ref local-endpoints spec))
+                 (extend-turn! turn (Clear ep))
+                 (set! local-endpoints (hash-remove local-endpoints spec)))
+
+             (on (message (server-envelope management-scope
+                                           (message-server->poa session-id (Turn $items))))
+                 (for [(item (in-list items))]
+                   (match item
+                     [(Assert subid (observe spec))
+                      (when (hash-has-key? remote-endpoints subid)
+                        (error 'local-link "Duplicate endpoint" subid))
+                      (react
+                       (define ep-facet (current-facet))
+                       (set! remote-endpoints (hash-set remote-endpoints subid ep-facet))
+                       (on-stop (set! remote-endpoints (hash-remove remote-endpoints subid)))
+                       (assert (server-envelope scope (observe spec)))
+                       (define ((! ctor) cs) (extend-turn! turn (ctor subid cs)))
+                       (add-observer-endpoint! (lambda () (server-proposal scope spec))
+                                               #:on-add (! Add)
+                                               #:on-remove (! Del)
+                                               #:on-message (! Msg)))]
+                     [(Clear subid)
+                      (stop-facet (hash-ref remote-endpoints subid)
+                                  (extend-turn! turn (End subid)))]
+                     [(Add ep vs) (let* ((s (hash-ref local-matches ep))
+                                         (a (instantiate s vs)))
+                                    (set-sub-captures! s (hash-set (sub-captures s) vs a))
+                                    (assert! a))]
+                     [(Del ep vs) (let* ((s (hash-ref local-matches ep))
+                                         (a (hash-ref (sub-captures s) vs)))
+                                    (retract! a)
+                                    (set-sub-captures! s (hash-remove (sub-captures s) vs)))]
+                     [(Msg ep vs) (let* ((s (hash-ref local-matches ep)))
+                                    (send! (instantiate s vs)))]
+                     [(End ep)    (let* ((s (hash-ref local-matches ep #f)))
+                                    (when s
+                                      (for [(a (in-hash-values (sub-captures s)))] (retract! a))
+                                      (set! local-matches (hash-remove local-matches ep))))])))))))
+
+;;---------------------------------------------------------------------------
+;; Federated scopes.
+
+(spawn #:name 'federated-scope-factory
+
+       (struct subscription (id ;; LocalID
+                             spec ;; Assertion
+                             holders ;; (Hash LinkID SubscriptionID)
+                             matches ;; (Hash (Listof Assertion) (Set LinkID))
+                             )
+         #:transparent)
+
+       (during (federation-management-scope $management-scope)
+         (during/spawn (server-envelope management-scope (federated-link _ $scope))
+           #:name (list 'federated-scope management-scope scope)
+
+           ;; Generates a fresh local ID naming a subscription propagated to our peers.
+           (define make-localid (let ((next 0)) (lambda () (begin0 next (set! next (+ next 1))))))
+
+           (field [turns (hash)] ;; (Map LinkID Turn)
+                  [specs (hash)] ;; (Hash Spec LocalID)
+                  [subs (hasheq)] ;; (Hash LocalID Subscription)
+                  )
+
+           (define (send-to-link! peer p)
+             (extend-turn! (hash-ref (turns) peer) p))
+
+           (when (log-level? syndicate/federation-logger 'debug)
+             (begin/dataflow
+               (log-syndicate/federation-debug "~a turns:" scope)
+               (for [((peer turn) (in-hash (turns)))]
+                 (log-syndicate/federation-debug "  link ~v -> ~v" peer (turn 'debug)))
+               (log-syndicate/federation-debug "-"))
+             (begin/dataflow
+               (log-syndicate/federation-debug "~a specs:" scope)
+               (for [((spec local) (in-hash (specs)))]
+                 (log-syndicate/federation-debug "  spec ~v -> local ~a" spec local))
+               (log-syndicate/federation-debug "-"))
+             (begin/dataflow
+               (log-syndicate/federation-debug "~a subs:" scope)
+               (for [((local sub) (in-hash (subs)))]
+                 (match-define (subscription _id spec holders matches) sub)
+                 (log-syndicate/federation-debug "  local ~a -> sub spec ~v" local spec)
+                 (when (not (hash-empty? holders))
+                   (log-syndicate/federation-debug "    holders:")
+                   (for [((link ep) (in-hash holders))]
+                     (log-syndicate/federation-debug "      link ~a -> ep ~a" link ep)))
+                 (when (not (hash-empty? matches))
+                   (log-syndicate/federation-debug "    matches:")
+                   (for [((captures holders) (in-hash matches))]
+                     (log-syndicate/federation-debug "      captures ~v held by ~a"
+                                                     captures holders))))
+               (log-syndicate/federation-debug "-")))
+
+           (define (call-with-sub localid linkid f #:not-found-ok? [not-found-ok? #t])
+             (match (hash-ref (subs) localid #f)
+               [#f (when (not not-found-ok?)
+                     (log-syndicate/federation-error
+                      "Mention of nonexistent local ID ~v from link ~v. Ignoring."
+                      localid linkid))]
+               [sub (f sub)]))
+
+           (define (store-sub! sub)
+             (match-define (subscription localid spec holders matches) sub)
+             (if (and (hash-empty? holders) (hash-empty? matches))
+                 (begin (specs (hash-remove (specs) spec))
+                        (subs (hash-remove (subs) localid)))
+                 (subs (hash-set (subs) localid sub))))
+
+           (define (unsubscribe! localid linkid)
+             (call-with-sub
+              #:not-found-ok? #f
+              localid linkid
+              (lambda (sub)
+                (define new-holders (hash-remove (subscription-holders sub) linkid))
+                (store-sub! (struct-copy subscription sub [holders new-holders]))
+
+                ;; The messages we send depend on (hash-count new-holders):
+                ;;  - if >1, there are enough other active subscribers that we don't need to send
+                ;;    any messages.
+                ;;  - if =1, we retract the subscription from that peer (INVARIANT: will not be linkid)
+                ;;  - if =0, we retract the subscription from all peers except linkid
+
+                (match (hash-count new-holders)
+                  [0 (for [((peer turn) (in-hash (turns)))]
+                       (when (not (equal? peer linkid))
+                         (extend-turn! turn (Clear localid))))]
+                  [1 (for [(peer (in-hash-keys new-holders))] ;; there will only be one, ≠ linkid
+                       (send-to-link! peer (Clear localid)))]
+                  [_ (void)]))))
+
+           (define (remove-match! localid captures linkid)
+             (call-with-sub
+              localid linkid
+              (lambda (sub)
+                (define old-matches (subscription-matches sub))
+                (define old-match-holders (hash-ref old-matches captures set))
+                (define new-match-holders (set-remove old-match-holders linkid))
+                (define new-matches (if (set-empty? new-match-holders)
+                                        (hash-remove old-matches captures)
+                                        (hash-set old-matches captures new-match-holders)))
+                (store-sub! (struct-copy subscription sub [matches new-matches]))
+                (match (set-count new-match-holders)
+                  [0 (for [((peer peer-subid) (in-hash (subscription-holders sub)))]
+                       (when (not (equal? peer linkid))
+                         (send-to-link! peer (Del peer-subid captures))))]
+                  [1 (for [(peer (in-set new-match-holders))] ;; only one, ≠ linkid
+                       (define maybe-peer-subid (hash-ref (subscription-holders sub) peer #f))
+                       (when maybe-peer-subid
+                         (send-to-link! peer (Del maybe-peer-subid captures))))]
+                  [_ (void)]))))
+
+           (during (server-envelope management-scope (federated-link $linkid scope))
+             (assert (server-proposal management-scope (federated-link-ready linkid)))
+
+             (define turn (turn-recorder
+                           (lambda (items)
+                             (send! (server-proposal management-scope
+                                                     (message-server->poa linkid (Turn items)))))))
+
+             (field [link-subs (hash)] ;; (Hash SubscriptionID LocalID)
+                    [link-matches (hash)] ;; (Hash LocalID (Set (Listof Assertion)))
+                    )
+
+             (define (err! detail [context #f])
+               (send! (server-proposal management-scope (message-server->poa linkid
+                                                                             (Err detail context))))
+               (reset-turn! turn)
+               (stop-current-facet))
+
+             (on-start (log-syndicate/federation-debug "+PEER ~a link ~a" scope linkid)
+                       (turns (hash-set (turns) linkid turn))
+                       (for ([(spec localid) (in-hash (specs))])
+                         (when (not (hash-empty? (subscription-holders (hash-ref (subs) localid))))
+                           (extend-turn! turn (Assert localid (observe spec)))))
+                       (commit-turn! turn))
+
+             (on-stop (log-syndicate/federation-debug "-PEER ~a link ~a" scope linkid)
+                      (turns (hash-remove (turns) linkid))
+                      (for [((localid matches) (in-hash (link-matches)))]
+                        (for [(captures (in-set matches))]
+                          (remove-match! localid captures linkid)))
+                      (for ([localid (in-hash-values (link-subs))])
+                        (unsubscribe! localid linkid))
+                      (commit-turn! turn))
+
+             (when (log-level? syndicate/federation-logger 'debug)
+               (begin/dataflow (log-syndicate/federation-debug "~a ~a link-subs:" scope linkid)
+                               (for [((sub local) (in-hash (link-subs)))]
+                                 (log-syndicate/federation-debug "  sub ~a -> local ~a" sub local))
+                               (log-syndicate/federation-debug "-"))
+               (begin/dataflow (log-syndicate/federation-debug "~a ~a link-matches:" scope linkid)
+                               (for [((local matches) (in-hash (link-matches)))]
+                                 (for [(captures (in-set matches))]
+                                   (log-syndicate/federation-debug "  local ~a captures ~v"
+                                                                   local captures)))
+                               (log-syndicate/federation-debug "-")))
+
+             (stop-when
+                 (message (server-envelope management-scope
+                                           (message-poa->server linkid (Err $detail $context))))
+               (log-syndicate/federation-error
+                "Received Err from peer link ~v: detail ~v; context ~v"
+                linkid
+                detail
+                context)
+               (reset-turn! turn))
+
+             (on (message (server-envelope management-scope
+                                           (message-poa->server linkid (Turn $items))))
+                 (for [(item (in-list items))]
+                   (match item
+                     [(Assert subid (observe spec))
+                      (define known? (hash-has-key? (specs) spec))
+                      (define localid (if known? (hash-ref (specs) spec) (make-localid)))
+                      (define sub (hash-ref (subs) localid (lambda () (subscription localid
+                                                                                    spec
+                                                                                    (hash)
+                                                                                    (hash)))))
+                      (define holders (subscription-holders sub))
+                      (cond
+                        [(hash-has-key? holders linkid)
+                         (log-syndicate/federation-error
+                          "Duplicate subscription ~a, ID ~a, from link ~a."
+                          spec subid linkid)
+                         (err! 'duplicate-endpoint item)]
+                        [else
+                         (link-subs (hash-set (link-subs) subid localid))
+                         (when (not known?) (specs (hash-set (specs) spec localid)))
+                         (subs (hash-set (subs)
+                                         localid
+                                         (struct-copy subscription sub
+                                           [holders (hash-set holders linkid subid)])))
+
+                         ;; If not known, then relay the subscription to all peers except `linkid`.
+                         ;;
+                         ;; If known, then one or more links that aren't this one have previously
+                         ;; subscribed with this spec. If exactly one other link has previously
+                         ;; subscribed, the only subscription that needs sent is to that peer;
+                         ;; otherwise, no subscriptions at all need sent, since everyone has already
+                         ;; been informed of this subscription.
+
+                         (cond
+                           [(not known?)
+                            (for [((peer peer-turn) (in-hash (turns)))]
+                              (when (not (equal? peer linkid))
+                                (extend-turn! peer-turn (Assert localid (observe spec)))))]
+                           [(= (hash-count holders) 1)
+                            (for [(peer (in-hash-keys holders))] ;; there will only be one, ≠ linkid
+                              (send-to-link! peer (Assert localid (observe spec))))]
+                           [else
+                            (void)])
+
+                         ;; Once subscription relaying has taken place, send up matches to the active
+                         ;; link.
+                         (for [((captures match-holders) (in-hash (subscription-matches sub)))]
+                           ;; Compute the number of times someone OTHER THAN this link has asserted
+                           ;; a match to this spec. If it's nonzero, we need to hear about it:
+                           (when (not (set-empty? (set-remove match-holders linkid)))
+                             (extend-turn! turn (Add subid captures))))
+
+                         ])]
+                     [(Clear subid)
+                      (match (hash-ref (link-subs) subid #f)
+                        [#f (log-syndicate/federation-error
+                             "Mention of nonexistent subscription ID ~v from link ~v."
+                             subid linkid)
+                            (err! 'nonexistent-endpoint item)]
+                        [localid
+                         (link-subs (hash-remove (link-subs) subid))
+                         (unsubscribe! localid linkid)])
+                      (extend-turn! turn (End subid))]
+                     [(End localid)
+                      (for [(captures (in-set (hash-ref (link-matches) localid set)))]
+                        (remove-match! localid captures linkid))
+                      (link-matches (hash-remove (link-matches) localid))]
+                     [(Add localid captures)
+                      (define matches (hash-ref (link-matches) localid set))
+                      (cond
+                        [(set-member? matches captures)
+                         (err! 'duplicate-capture item)]
+                        [else
+                         (link-matches (hash-set (link-matches) localid (set-add matches captures)))
+                         (call-with-sub
+                          localid linkid
+                          (lambda (sub)
+                            (define old-matches (subscription-matches sub))
+                            (define old-match-holders (hash-ref old-matches captures set))
+                            (define new-match-holders (set-add old-match-holders linkid))
+                            (define new-matches (hash-set old-matches captures new-match-holders))
+                            (store-sub! (struct-copy subscription sub [matches new-matches]))
+                            (match (set-count old-match-holders)
+                              [0 (for [((peer peer-subid) (in-hash (subscription-holders sub)))]
+                                   (when (not (equal? peer linkid))
+                                     (send-to-link! peer (Add peer-subid captures))))]
+                              [1 (for [(peer (in-set old-match-holders))] ;; only one, ≠ linkid
+                                   (define peer-subid (hash-ref (subscription-holders sub) peer #f))
+                                   (when peer-subid ;; the other holder may not itself subscribe!
+                                     (send-to-link! peer (Add peer-subid captures))))]
+                              [_ (void)])))])]
+                     [(Del localid captures)
+                      (define matches (hash-ref (link-matches) localid set))
+                      (if (not (set-member? matches captures))
+                          (err! 'nonexistent-capture item)
+                          (let ((new-matches (set-remove matches captures)))
+                            (link-matches (if (set-empty? new-matches)
+                                              (hash-remove (link-matches) localid)
+                                              (hash-set (link-matches) localid new-matches)))
+                            (remove-match! localid captures linkid)))]
+                     [(Msg localid captures)
+                      (call-with-sub
+                       localid linkid
+                       (lambda (sub)
+                         (for ([(peer peer-subid) (in-hash (subscription-holders sub))])
+                           (when (not (equal? peer linkid))
+                             (send-to-link! peer (Msg peer-subid captures))))))]
+                     )))))))

imperative/distributed/heartbeat.rkt

@@ -0,0 +1,50 @@
+#lang imperative-syndicate
+
+(provide heartbeat)
+
+(module+ for-testing
+  (provide heartbeats-enabled?))
+
+(require "wire-protocol.rkt")
+
+(require/activate imperative-syndicate/drivers/timer)
+
+(define-logger syndicate/distributed)
+
+(define heartbeats-enabled? (make-parameter #t))
+
+;; TODO: move heartbeats to transport level, and use separate transport-activity timeouts from
+;; message-activity timeouts. Using message-activity only has problems when messages are large
+;; and links are slow. Also, moving to transport level lets us use e.g. WebSocket's ping
+;; mechanism rather than a message-level mechanism.
+(define (heartbeat who send-message teardown)
+  (cond
+    [(heartbeats-enabled?)
+     (define period (ping-interval))
+     (define grace (* 3 period))
+
+     (log-syndicate/distributed-debug
+      "Peer ~v heartbeat period ~ams; must not experience silence longer than ~ams"
+      who period grace)
+
+     (field [next-ping-time 0]) ;; when we are to send the next ping
+     (field [last-received-traffic (current-inexact-milliseconds)]) ;; when we last heard from the peer
+
+     (define (schedule-next-ping!)
+       (next-ping-time (+ (current-inexact-milliseconds) period)))
+
+     (on (asserted (later-than (next-ping-time)))
+         (schedule-next-ping!)
+         (send-message (Ping)))
+
+     (on (asserted (later-than (+ (last-received-traffic) grace)))
+         (log-syndicate/distributed-info "Peer ~v heartbeat timeout after ~ams of inactivity"
+                                         who grace)
+         (teardown))
+
+     (lambda ()
+       (schedule-next-ping!)
+       (last-received-traffic (current-inexact-milliseconds)))]
+    [else
+     (log-syndicate/distributed-debug "Peer ~v heartbeats disabled" who)
+     void]))

imperative/distributed/internal-protocol.rkt

@@ -0,0 +1,35 @@
+#lang imperative-syndicate
+;; Internal server and federation protocol
+
+(provide (all-defined-out))
+
+;; Client-server internal protocol
+;; Received packets from server are relayed via one of these.
+(message-struct server-packet (address packet))
+;; Like `server-connected`, but for reflecting `tcp-accepted` to the
+;; client end of a client-server connection without reordering wrt
+;; `server-packet` messages. Implementation-facing, where
+;; `server-connected` is part of the API.
+(assertion-struct server-transport-connected (address))
+;; Like `server-connected`, but for reflecting the state of the
+;; session to the transport driver. Observation of
+;; `server-session-connected` is not creative (of `server-connected`),
+;; unlike observation of `server-connected`.
+(assertion-struct server-session-connected (address))
+
+;; Internal connection protocol
+(assertion-struct server-poa (connection-id)) ;; "Point of Attachment"
+(assertion-struct server-poa-ready (connection-id))
+(assertion-struct message-poa->server (connection-id body))
+(assertion-struct message-server->poa (connection-id body))
+
+;; Internal isolation -- these are isomorphic to `to-server` and `from-server`!
+;;                       (and, for that matter, to `outbound` and `inbound`!)
+(assertion-struct server-proposal (scope body)) ;; suggestions (~ actions)
+(assertion-struct server-envelope (scope body)) ;; decisions (~ events)
+
+(assertion-struct server-active (scope))
+
+;; Federated links generally
+(assertion-struct federated-link (id scope))
+(assertion-struct federated-link-ready (id))

imperative/distributed/main.rkt

@@ -0,0 +1,93 @@
+#lang imperative-syndicate
+
+(provide (all-from-out "protocol.rkt")
+         (all-from-out "client.rkt")
+         (all-from-out "client/tcp.rkt")
+         (all-from-out "client/loopback.rkt")
+         (all-from-out "server.rkt")
+         (all-from-out "server/tcp.rkt")
+         (all-from-out "server/websocket.rkt"))
+
+(require "internal-protocol.rkt")
+(require "protocol.rkt")
+
+(require/activate "client.rkt")
+(require/activate "client/tcp.rkt")
+(require/activate "client/loopback.rkt")
+
+(require/activate "server.rkt")
+(require/activate "server/tcp.rkt")
+(require/activate "server/websocket.rkt")
+
+(require/activate "federation.rkt")
+
+(module+ main
+  (require racket/cmdline)
+  (define tcp-port default-tcp-server-port)
+  (define http-port default-http-server-port)
+  (define default-management-scope "local")
+  (define uplinks '())
+  (define management-scope default-management-scope)
+  (command-line #:once-any
+                ["--tcp" port
+                 ((format "Listen on plain TCP port (default ~a)" default-tcp-server-port))
+                 (set! tcp-port (string->number port))]
+                ["--no-tcp" "Do not listen on any plain TCP port"
+                 (set! tcp-port #f)]
+                #:once-any
+                ["--http" port
+                 ((format "Listen on websocket HTTP port (default ~a)" default-http-server-port))
+                 (set! http-port (string->number port))]
+                ["--no-http" "Do not listen on any websocket HTTP port"
+                 (set! http-port #f)]
+                #:multi
+                [("--management-scope" "-m") scope
+                 ("Set the management scope for future `--uplink`s and, "
+                  "ultimately, for local federation management use. "
+                  (format "(default ~v)" default-management-scope))
+                 (set! management-scope scope)]
+                ["--uplink" local-scope host port remote-scope
+                 ("Connect the named local-scope to the named remote-scope"
+                  "via the management scope in the server at host:port")
+                 (define port-number (string->number port))
+                 (when (not port-number)
+                   (eprintf "Invalid --uplink port number: ~v" port)
+                   (exit 1))
+                 (set! uplinks (cons (federated-uplink local-scope
+                                                       (server-tcp-connection host
+                                                                              port-number
+                                                                              management-scope)
+                                                       remote-scope)
+                                     uplinks))])
+  (extend-ground-boot! (lambda ()
+                         (spawn (assert (federation-management-scope management-scope)))
+                         ;; ^ for inbound as well as outbound links
+                         (when tcp-port (spawn-tcp-server! tcp-port))
+                         (when http-port (spawn-websocket-server! http-port))
+                         (when (pair? uplinks)
+                           (spawn (define a (server-loopback-connection management-scope))
+                                  (assert (server-connection a))
+                                  (for [(u uplinks)]
+                                    (assert (to-server a u))))))))
+
+(define-logger syndicate/distributed)
+
+(when (log-level? syndicate/distributed-logger 'debug)
+  (spawn #:name 'client-debug
+         (on (asserted (server-connection $addr))
+             (log-syndicate/distributed-debug "C + ~v" addr))
+         (on (retracted (server-connection $addr))
+             (log-syndicate/distributed-debug "C - ~v" addr))
+         (on (message (server-packet $addr $p))
+             (log-syndicate/distributed-debug "C IN  ~v ~v" addr p))
+         ;; C OUT is covered in client.rkt
+         )
+  (spawn #:name 'server-debug
+         (on (asserted (server-poa $id))
+             (log-syndicate/distributed-debug "S + ~v" id))
+         (on (retracted (server-poa $id))
+             (log-syndicate/distributed-debug "S - ~v" id))
+         (on (message (message-poa->server $id $p))
+             (log-syndicate/distributed-debug "S IN  ~v ~v" id p))
+         (on (message (message-server->poa $id $p))
+             (log-syndicate/distributed-debug "S OUT ~v ~v" id p))))

imperative/distributed/protocol.rkt

@@ -0,0 +1,24 @@
+#lang imperative-syndicate
+
+(provide (all-defined-out))
+
+;; Addressing
+(assertion-struct server-tcp-connection (host port scope))
+(assertion-struct server-loopback-connection (scope))
+
+(define (standard-localhost-server/tcp [scope "broker"])
+  (server-tcp-connection "localhost" 8001 scope))
+
+;; Client protocol
+(assertion-struct to-server (address assertion))
+(assertion-struct from-server (address assertion))
+(assertion-struct server-connection (address))
+(assertion-struct server-connected (address))
+(message-struct force-server-disconnect (address))
+
+;; Federation configuration
+;; e.g. (federated-uplink "scope1" (server-tcp-connection "peer.example" 8001 "local") "scope2")
+(assertion-struct federated-uplink (local-scope peer remote-scope))
+(assertion-struct federated-uplink-connected (link))
+
+(assertion-struct federation-management-scope (name))

imperative/distributed/server.rkt

@@ -0,0 +1,85 @@
+#lang imperative-syndicate
+
+(require "wire-protocol.rkt")
+(require "internal-protocol.rkt")
+(require "turn.rkt")
+
+(require/activate "heartbeat.rkt")
+
+(spawn #:name 'server-factory
+
+       ;; Previously, we just had server-envelope. Now, we have both
+       ;; server-envelope and server-proposal. While not everything
+       ;; decided is (locally) suggested, it is true that everything
+       ;; suggested is decided (in this implementation at least),
+       ;; and the following clauses reflect this:
+       (on (asserted (server-proposal $scope $assertion))
+           (assert! (server-envelope scope assertion)))
+       (on (retracted (server-proposal $scope $assertion))
+           (retract! (server-envelope scope assertion)))
+       (on (message (server-proposal $scope $body))
+           (send! (server-envelope scope body)))
+       (on (asserted (observe (server-envelope $scope $spec)))
+           (assert! (server-proposal scope (observe spec))))
+       (on (retracted (observe (server-envelope $scope $spec)))
+           (retract! (server-proposal scope (observe spec))))
+
+       (during/spawn (server-poa $id)
+         (define root-facet (current-facet))
+         (assert (server-poa-ready id))
+         (on-start
+          (match (let-event [(message (message-poa->server id $p))] p)
+            [(Connect scope) (react (connected id scope root-facet))]
+            [_ (send! (message-server->poa id (Err 'connection-not-setup #f)))]))))
+
+(define (connected id scope root-facet)
+  (define endpoints (hash))
+
+  (define turn (turn-recorder (lambda (items) (send! (message-server->poa id (Turn items))))))
+
+  (assert (server-active scope))
+
+  (define (send-error! detail [context #f])
+    (send! (message-server->poa id (Err detail context)))
+    (reset-turn! turn)
+    (stop-facet root-facet))
+
+  (define reset-heartbeat! (heartbeat (list 'server id scope)
+                                      (lambda (m) (send! (message-server->poa id m)))
+                                      (lambda () (stop-facet root-facet))))
+
+  (on (message (message-poa->server id $p))
+      (reset-heartbeat!)
+      (match p
+        [(Turn items)
+         (for [(item (in-list items))]
+           (match item
+             [(Assert ep a)
+              (if (hash-has-key? endpoints ep)
+                  (send-error! 'duplicate-endpoint item)
+                  (react
+                   (define ep-facet (current-facet))
+                   (set! endpoints (hash-set endpoints ep ep-facet))
+                   (on-stop (set! endpoints (hash-remove endpoints ep)))
+
+                   (assert (server-proposal scope a))
+
+                   (when (observe? a)
+                     (define ((! ctor) cs) (extend-turn! turn (ctor ep cs)))
+                     (add-observer-endpoint!
+                      (lambda () (server-envelope scope (observe-specification a)))
+                      #:on-add (! Add)
+                      #:on-remove (! Del)
+                      #:on-message (! Msg)))))]
+             [(Clear ep)
+              (match (hash-ref endpoints ep #f)
+                [#f (send-error! 'nonexistent-endpoint item)]
+                [ep-facet (stop-facet ep-facet (extend-turn! turn (End ep)))])]
+             [(Message body)
+              (send! (server-proposal scope body))]))]
+        [(Ping)
+         (send! (message-server->poa id (Pong)))]
+        [(Pong)
+         (void)]
+        [_
+         (send-error! 'invalid-message p)])))

imperative/distributed/server/tcp.rkt

@@ -0,0 +1,32 @@
+#lang imperative-syndicate
+
+(provide server-facet/tcp
+         default-tcp-server-port
+         spawn-tcp-server!)
+
+(require "../wire-protocol.rkt")
+(require "../internal-protocol.rkt")
+
+(require/activate imperative-syndicate/drivers/tcp)
+(require/activate imperative-syndicate/distributed/server)
+
+(define (server-facet/tcp id)
+  (assert (tcp-accepted id))
+  (assert (server-poa id))
+  (stop-when (retracted (server-poa-ready id)))
+  (on-start (issue-unbounded-credit! tcp-in id))
+  (define accumulate! (packet-accumulator (lambda (p) (send! (message-poa->server id p)))))
+  (on (message (tcp-in id $bs))
+      (accumulate! bs))
+  (on (message (message-server->poa id $p))
+      (send! (tcp-out id (encode p)))
+      (when (Err? p) (stop-current-facet))))
+
+(define default-tcp-server-port 21369)
+
+(define (spawn-tcp-server! [port default-tcp-server-port])
+  (spawn #:name 'tcp-server-listener
+         (during/spawn (tcp-connection $id (tcp-listener port))
+           #:name `(server-poa ,id)
+           (on-start (issue-credit! (tcp-listener port)))
+           (server-facet/tcp id))))

imperative/distributed/server/websocket.rkt

@@ -0,0 +1,35 @@
+#lang imperative-syndicate
+
+(provide server-facet/websocket
+         default-http-server-port
+         spawn-websocket-server!)
+
+(require "../wire-protocol.rkt")
+(require "../internal-protocol.rkt")
+
+(require imperative-syndicate/protocol/credit)
+
+(require/activate imperative-syndicate/drivers/web)
+(require/activate imperative-syndicate/distributed/server)
+
+(define (server-facet/websocket id)
+  (assert (http-accepted id))
+  (assert (http-response-websocket id))
+  (assert (server-poa id))
+  (stop-when (retracted (server-poa-ready id)))
+  (on (message (websocket-in id $body))
+      (define-values (packet remainder) (decode body))
+      (when (not (equal? remainder #""))
+        (error 'server-facet/websocket "Multiple packets in a single websocket message"))
+      (send! (message-poa->server id packet)))
+  (on (message (message-server->poa id $p))
+      (send! (websocket-out id (encode p)))
+      (when (Err? p) (stop-current-facet))))
+
+(define default-http-server-port 8000)
+
+(define (spawn-websocket-server! [port default-http-server-port])
+  (spawn #:name 'websocket-server-listener
+         (during/spawn (http-request $id 'get (http-resource (http-server _ port #f) `("" ())) _ _ _)
+           #:name `(server-poa ,id)
+           (server-facet/websocket id))))

imperative/distributed/turn.rkt

@@ -0,0 +1,34 @@
+#lang imperative-syndicate
+
+(provide turn-recorder
+         extend-turn!
+         commit-turn!
+         reset-turn!)
+
+(require (submod "../dataspace.rkt" priorities))
+
+(define (extend-turn! t item) (t 'extend item))
+(define (commit-turn! t)      (t 'commit))
+(define (reset-turn! t)       (t 'reset))
+
+(define (turn-recorder on-commit)
+  (field [commit-needed #f])
+  (define items '())
+  (define t
+    (match-lambda*
+      [(list 'extend item)
+       (set! items (cons item items))
+       (commit-needed #t)]
+      [(list 'commit)
+       (when (commit-needed)
+         (on-commit (reverse items))
+         (reset-turn! t))]
+      [(list 'reset)
+       (set! items '())
+       (commit-needed #f)]
+      [(list 'debug)
+       (reverse items)]))
+  (begin/dataflow
+    #:priority *idle-priority*
+    (commit-turn! t))
+  t)

imperative/distributed/wire-protocol.rkt

@@ -0,0 +1,70 @@
+#lang imperative-syndicate
+
+(provide (all-defined-out))
+
+(require (prefix-in preserves: preserves))
+(require bitsyntax)
+(require (only-in net/rfc6455 ws-idle-timeout))
+(require (only-in racket/list index-of))
+
+;; Enrolment
+(message-struct Connect (scope)) ;; Client --> Server
+
+;; Transactions
+(message-struct Turn (items)) ;; Bidirectional
+  ;; Items:
+  ;; Actions; Client --> Server (and Peer --> Peer, except for Message)
+  (message-struct Assert (endpoint-name assertion))
+  (message-struct Clear (endpoint-name))
+  (message-struct Message (body))
+  ;; Events; Server --> Client (and Peer --> Peer)
+  (message-struct Add (endpoint-name captures))
+  (message-struct Del (endpoint-name captures))
+  (message-struct Msg (endpoint-name captures))
+  (message-struct End (endpoint-name))
+
+;; Errors
+(message-struct Err (detail context)) ;; Server --> Client (and Peer --> Peer)
+
+;; Transport-related; Bidirectional
+(message-struct Ping ())
+(message-struct Pong ())
+
+;; In peer mode, *actions* and *events* travel in *both* directions,
+;; but `Message`s do not appear and (for now) `Assert` is only used to
+;; establish `observe`s, i.e. subscriptions.
+
+(define (decode bs)
+  (parameterize ((preserves:current-placeholder->value
+                  (lambda (v) (vector-ref '#(discard capture observe) v))))
+    (bit-string-case bs
+      #:on-short (lambda (fail) (values #f bs))
+      ([ (v :: (preserves:wire-value)) (rest :: binary) ] (values v (bit-string->bytes rest)))
+      (else (error 'decode "Invalid wire message")))))
+
+(define (encode v)
+  (parameterize ((preserves:current-value->placeholder
+                  (lambda (v) (index-of '(discard capture observe) v eq?))))
+    (preserves:encode v)))
+
+(define (ping-interval)
+  (* 1000 (min 60 ;; reasonable default?
+               ;;
+               ;; TODO: disable the net/rfc6455 ws-idle-timeout, when we can.
+               ;;
+               ;; The net/rfc6455 ws-idle-timeout has to be paid attention to here because it
+               ;; can't be disabled, because the built-in webserver (which net/rfc6455
+               ;; interoperates with) has a per-connection timer that also can't be disabled.
+               ;;
+               (max (- (ws-idle-timeout) 10)
+                    (* (ws-idle-timeout) 0.8)))))
+
+(define (packet-accumulator handle-packet!)
+  (field [buffer #""])
+  (begin/dataflow
+    (define-values (packet remainder) (decode (buffer)))
+    (when packet
+      (buffer remainder)
+      (handle-packet! packet)))
+  (lambda (chunk)
+    (buffer (bytes-append (buffer) chunk))))

imperative/drivers/config.rkt

@@ -0,0 +1,38 @@
+#lang imperative-syndicate
+;; Monitor configuration files.
+
+(provide (struct-out config)
+         spawn-configuration
+         define/query-config
+         config-ref)
+
+(define-logger syndicate/drivers/config)
+
+(require racket/file)
+(require/activate imperative-syndicate/drivers/filesystem)
+
+;; (config Any Any)
+(assertion-struct config (scope item))
+
+(define (spawn-configuration scope path #:hook [hook void])
+  (spawn #:name (list 'configuration-monitor scope path)
+         (hook)
+         (during (file-content path file->list $items)
+           (cond
+             [(not items)
+              (log-syndicate/drivers/config-warning "config ~s is missing" path)]
+             [else
+              (log-syndicate/drivers/config-info "loading config ~s" path)
+              (for [(item items)]
+                (log-syndicate/drivers/config-info "config ~s: ~s" path item)
+                (assert (config scope item)))]))))
+
+(define-syntax define/query-config
+  (syntax-rules ()
+    [(_ scope id default)
+     (define/query-config id scope id default)]
+    [(_ id scope key default)
+     (define/query-value id default (config scope (list 'key $val)) val)]))
+
+(define (config-ref scope key default)
+  (immediate-query (query-value default (config scope (list key $val)) val)))

imperative/drivers/external-event.rkt

@@ -0,0 +1,19 @@
+#lang imperative-syndicate
+
+(provide (struct-out external-event))
+
+(message-struct external-event (descriptor values))
+
+(spawn #:name 'external-event-relay
+       (during/spawn (observe (inbound (external-event $desc _)))
+         (define ch (make-channel))
+         (thread (lambda ()
+                   (let loop ()
+                     (sync ch
+                           (handle-evt desc
+                                       (lambda results
+                                         (ground-send! (inbound (external-event desc results)))
+                                         (loop)))))))
+         (signal-background-activity! +1)
+         (on-stop (channel-put ch 'quit)
+                  (signal-background-activity! -1))))

imperative/drivers/filesystem.rkt

@@ -0,0 +1,82 @@
+#lang imperative-syndicate
+;; Filesystem change monitor driver
+
+(provide (struct-out file-content)
+         spawn-filesystem-driver)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(assertion-struct file-content (name reader-proc content))
+
+;; Internal driver ground-level protocol
+(message-struct file-changed (name))
+(message-struct file-container-changed (parent-path))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (spawn-filesystem-driver)
+  (spawn #:name 'drivers/filesystem
+         (during/spawn (observe (file-content $name $reader-proc _))
+           #:name (list 'file-content name reader-proc)
+           (track-file name reader-proc))
+         (during (observe (inbound (file-changed $name)))
+           (monitor-thread name))))
+
+(define (read-file name reader-proc)
+  (and (or (file-exists? name) (directory-exists? name))
+       (reader-proc name)))
+
+(define (path->parent-path name)
+  (let-values (((parent-path _leaf _syntactically-dir?)
+                (split-path (path->complete-path name))))
+    parent-path))
+
+(define (track-file name reader-proc)
+  (field [content (read-file name reader-proc)])
+  (assert (file-content name reader-proc (content)))
+  (on (message (inbound (file-changed name)))
+      (content (read-file name reader-proc)))
+  ;; This horrible hack is required to work around limitations in the
+  ;; OS's file-change reporting. It seems (?) as if, monitoring both
+  ;; "a/b" and "a/", that only the event for "a/" will be fired when
+  ;; "a/b" changes. This manifests as follows: if I monitor "a/b" and
+  ;; "a/nonexistent", then when "a/b" changes, only "a/nonexistent"'s
+  ;; event will fire. Therefore, I've kludged in the
+  ;; `file-container-changed` message, which copes with one level of
+  ;; directory hierarchy of this problem.
+  ;;
+  ;; TODO: Consider whether it will actually be required to listen for
+  ;; file-container-changed events for ALL recursive parents of the
+  ;; path of interest up to the root.
+  ;;
+  (on (message (inbound (file-container-changed (path->parent-path name))))
+      (content (read-file name reader-proc))))
+
+(define (monitor-thread name)
+  (define control-ch (make-channel))
+  (thread (lambda ()
+            (define parent-path (path->parent-path name))
+            (let loop ()
+              (sync (handle-evt control-ch
+                                (lambda (msg)
+                                  ;; (log-info "track-file-changes ~v: ~v" name msg)
+                                  (match msg
+                                    ['quit (void)])))
+                    (if (or (file-exists? name) (directory-exists? name)) ;; TODO: TOCTTOU :-(
+                        (handle-evt (filesystem-change-evt name)
+                                    (lambda (_dummy)
+                                      ;; (log-info "track-file-changes ~v: changed" name)
+                                      (ground-send! (inbound (file-changed name)))
+                                      (loop)))
+                        (handle-evt (filesystem-change-evt parent-path)
+                                    (lambda (_dummy)
+                                      ;; (log-info "track-file-changes ~v: directory changed" name)
+                                      (ground-send! (inbound (file-container-changed parent-path)))
+                                      (loop))))))
+            (signal-background-activity! -1)))
+  (signal-background-activity! +1)
+  (on-stop (channel-put control-ch 'quit)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(spawn-filesystem-driver)

imperative/drivers/gl-2d.rkt

@@ -0,0 +1,662 @@
+#lang imperative-syndicate
+
+(provide (struct-out window)
+         (struct-out frame-event)
+         (struct-out key-event)
+         (struct-out key-pressed)
+         (struct-out mouse-event)
+         (struct-out mouse-state)
+         (struct-out touching)
+         (struct-out coordinate-map)
+         (struct-out scene)
+         (except-out (struct-out sprite) sprite)
+         (rename-out [sprite <sprite>] [make-sprite sprite])
+         (struct-out gl-control)
+         in-unit-circle?
+         in-unit-square?
+         simple-sprite
+         assert-scene
+         spawn-keyboard-integrator
+         spawn-mouse-integrator
+         spawn-gl-2d-driver)
+
+(require data/order)
+(require data/splay-tree)
+(require data/queue)
+(require sgl/gl)
+(require sgl/gl-vectors)
+
+(require racket/gui/base)
+(require racket/dict)
+(require (only-in racket/class
+                  send is-a? make-object class class* inherit this new super-new init
+                  define/public define/override define/augment))
+(require (only-in racket/math sqr))
+
+(require (prefix-in image: 2htdp/image))
+(require (prefix-in pict: pict))
+
+(require syndicate-gl/texture)
+(require syndicate-gl/affine)
+
+(require/activate imperative-syndicate/drivers/timer)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Shared state maintained by dataspace. Describes current window dimensions.
+(assertion-struct window (width height))
+
+;; Message sent by dataspace. Describes render time.
+(message-struct frame-event (counter timestamp elapsed-ms target-frame-rate))
+
+;; Message sent by dataspace. Describes a key event. Key is a sealed
+;; key-event%. `press?` is #t when the key is pressed (or
+;; autorepeated!), and #f when it is released.
+(message-struct key-event (code press? key))
+
+;; Assertion. Indicates that the named key is held down. See role
+;; KeyboardIntegrator and spawn-keyboard-integrator.
+(assertion-struct key-pressed (code))
+
+;; Message sent by dataspace. Describes a mouse event. State is a
+;; MouseState.
+(message-struct mouse-event (type state))
+
+;; Assertion. Indicates that the mouse is in a particular state. See
+;; role MouseIntegrator and spawn-mouse-integrator.
+(assertion-struct mouse-state (x y left-down? middle-down? right-down?))
+
+;; Assertion. Indicates that the mouse is touching a particular touchable.
+(assertion-struct touching (id))
+
+;; Assertion. Communicates aggregate device-to-user transformation
+;; requested as part of sprite instruction sequences.
+(assertion-struct coordinate-map (id matrix))
+
+;; Shared state maintained by program. Prelude and postlude are to be
+;; sealed instruction lists. It is an error to have more than exactly
+;; one active such record at a given time.
+(assertion-struct scene (prelude postlude))
+
+;; A SpriteID is an equal?-comparable dataspace-unique value.
+
+;; Shared state maintained by program. `id` is a SpriteID, and
+;; `parent-id` is an (Option SpriteID); #f in `parent-id` means that
+;; this sprite is a child of the root. Z is to be a number, negative
+;; toward camera. Instructions to be a sealed instruction list.
+(assertion-struct sprite (id parent-id z instructions))
+
+;; Message and assertion.
+;;
+;; When sent as a message with `body` of `'stop`, closes the GL window
+;; and terminates the driver.
+;;
+;; When asserted with `body` of `'fullscreen`, causes the window to be
+;; fullscreen; otherwise, it is a normal window.
+;;
+(assertion-struct gl-control (body))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-syntax-rule (assert-scene prelude postlude)
+  (assert (scene (seal prelude) (seal postlude))))
+
+(define (make-sprite z instructions #:id [id #f] #:parent [parent-id #f])
+  (sprite (or id (gensym 'sprite)) parent-id z (seal instructions)))
+
+(define (in-unit-circle? x y)
+  (<= (+ (sqr (- x 0.5)) (sqr (- y 0.5))) (sqr 0.5)))
+
+(define (in-unit-square? x y)
+  (and (<= 0 x 1)
+       (<= 0 y 1)))
+
+(define (simple-sprite z x y w h i
+                       #:parent [parent-id #f]
+                       #:rotation [rotation 0]
+                       #:coordinate-map-id [coordinate-map-id #f]
+                       #:touchable-id [touchable-id #f]
+                       #:touchable-predicate [touchable-predicate in-unit-square?])
+  (make-sprite #:id touchable-id
+               #:parent parent-id
+               z
+               `((translate ,x ,y)
+                 ,@(if (zero? rotation) `() `((rotate ,rotation)))
+                 (push-matrix
+                  (scale ,w ,h)
+                  ,@(if touchable-id
+                        `((touchable ,touchable-id ,touchable-predicate))
+                        `())
+                  (texture ,i))
+                 ,@(if coordinate-map-id
+                       `((coordinate-map ,coordinate-map-id))
+                       `())
+                 (render-children))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; KeyboardIntegrator. Integrates key-events into key-pressed assertions.
+(define (spawn-keyboard-integrator)
+  (spawn #:name 'gl-2d/keyboard-integratpr
+         (local-require racket/set)
+         (define keys-pressed (mutable-set))
+         ;; TODO: consider adding set-semantics assert!/retract! API for this kind of thing
+         (on (message (key-event $code #t _))
+             (unless (set-member? keys-pressed code)
+               (set-add! keys-pressed code)
+               (assert! (key-pressed code))))
+         (on (message (key-event $code #f _))
+             (when (set-member? keys-pressed code)
+               (set-remove! keys-pressed code)
+               (retract! (key-pressed code))))))
+
+;; MouseIntegrator. Integrates mouse-events into mouse-state assertions.
+(define (spawn-mouse-integrator)
+  (spawn #:name 'gl-2d/mouse-integrator
+         (field [in-bounds? #f] [state #f])
+         (assert #:when (in-bounds?) (state))
+         (on (message (mouse-event $type $new-state))
+             (in-bounds? (not (eq? type 'leave)))
+             (state new-state))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; A Touchable is one of
+;;
+;; - (touchable Any TransformationMatrix (Number Number -> Boolean))
+;;   Represents a composed device-to-user transformation, plus a
+;;   predicate on user coordinates, and an ID to use when the
+;;   predicate answers truthily.
+;;
+;; - (touchable-map)
+;;   Represents the location in a sequence of touchables where the
+;;   aggregate partial device-to-user transformation used when mapping
+;;   along parent-child relationship edges in the sprite tree should
+;;   be applied to child sprites.
+;;
+(struct touchable (id transformation predicate) #:transparent)
+(struct touchable-map () #:transparent)
+
+;; A Children is a (SplayTree Sprite CompiledInstructions), ordered
+;; first by sprite-z, then sprite-id hash code, then
+;; sprite-instructions hash-code.
+;;
+;; A ChildMap is a (Hash SpriteID Children), mapping sprite-id to the
+;; children of that sprite.
+
+;; (compiled-instructions (ChildMap SpriteID -> Void)
+;;                        (Listof Touchable)
+;;                        (Listof CoordinateMap)
+;;                        (Listof Resource)
+;;                        (Option TransformationMatrix)
+;;                        TransformationMatrix)
+;; A single compiled sprite. The resources and coordinate-maps aren't
+;; in any particular order, but the touchables are: the leftmost
+;; touchable is the first to check; that is, it is the *topmost*
+;; touchable in this sprite. The child-xform, if present, is the
+;; transformation needed to map between mouse coordinates and child
+;; sprite space; if absent, no (render-children) instruction was found
+;; in this sprite's render code. The final-xform is the final
+;; transformation after the render instructions have completed.
+(struct compiled-instructions
+  (render-proc touchables coordinate-maps resources child-xform final-xform))
+
+(define-namespace-anchor ns-anchor)
+(define ns (namespace-anchor->namespace ns-anchor))
+
+(define (compile-instructions instrs)
+  (define touchables '())
+  (define coordinate-maps '())
+  (define resources '())
+  (define child-xform #f)
+
+  (define (instructions->racket-code instrs xform)
+    (define-values (code-rev new-xform)
+      (for/fold [(code-rev '()) (xform xform)] [(instr (in-list instrs))]
+        (define-values (new-code new-xform) (instruction->racket-code instr xform))
+        (values (cons new-code code-rev) new-xform)))
+    (let ((code (reverse code-rev)))
+      (values (lambda (CHILDMAP SELF-ID)
+                (for [(p (in-list code))]
+                  (p CHILDMAP SELF-ID)))
+              new-xform)))
+
+  (define (instruction->racket-code instr xform)
+    (match instr
+      [`(rotate ,(? number? deg))
+       (values (lambda (CHILDMAP SELF-ID) (glRotated deg 0 0 -1))
+               (compose-transformation xform (rotation-transformation (- deg))))]
+      [`(scale ,(? number? x) ,(? number? y))
+       (values (lambda (CHILDMAP SELF-ID) (glScaled x y 1))
+               (compose-transformation xform (stretching-transformation x y)))]
+      [`(translate ,(? number? x) ,(? number? y))
+       (values (lambda (CHILDMAP SELF-ID) (glTranslated x y 0))
+               (compose-transformation xform (translation-transformation x y)))]
+      [`(color ,(? color-number? r) ,(? color-number? g) ,(? color-number? b) ,(? color-number? a))
+       (values (lambda (CHILDMAP SELF-ID) (glColor4d r g b a)) xform)]
+      [`(texture ,i)
+       (define entry (image->texture-cache-entry i))
+       (define tex (send entry get-texture))
+       (set! resources (cons entry resources))
+       (values (lambda (CHILDMAP SELF-ID) (draw-gl-face tex)) xform)]
+      [`(texture ,i ,l ,t ,w ,h) #:when (andmap number? (list l t w h))
+       (define entry (image->texture-cache-entry i))
+       (define tex (send entry get-texture))
+       (set! resources (cons entry resources))
+       (values (lambda (CHILDMAP SELF-ID) (draw-gl-face tex l t w h)) xform)]
+      [`(touchable ,id ,predicate)
+       (set! touchables (cons (touchable id xform predicate) touchables))
+       (values void xform)]
+      [`(coordinate-map ,id)
+       (set! coordinate-maps (cons (coordinate-map id xform) coordinate-maps))
+       (values void xform)]
+      [`(push-matrix ,instr ...)
+       (define-values (code _new-xform) (instructions->racket-code instr xform))
+       (values (lambda (CHILDMAP SELF-ID)
+                 (glPushMatrix)
+                 (code CHILDMAP SELF-ID)
+                 (glPopMatrix))
+               xform)]
+      [`(begin ,instr ...)
+       (define-values (code new-xform) (instructions->racket-code instr xform))
+       (values code new-xform)]
+      [`(render-children) ;; we assume that there will only be one of these
+       (set! child-xform xform)
+       (set! touchables (cons (touchable-map) touchables))
+       (values render-sprites! xform)]
+      [other
+       (error 'instruction->racket-code "unknown render instruction: ~v" other)]))
+
+  (define-values (render-proc final-transformation)
+    (instruction->racket-code `(begin ,@instrs) identity-transformation))
+  (compiled-instructions render-proc
+                         touchables
+                         coordinate-maps
+                         resources
+                         child-xform
+                         final-transformation))
+
+(define empty-instructions (compile-instructions '()))
+
+(define (compiled-instructions-dispose! i)
+  (when i
+    (for [(resource (in-list (compiled-instructions-resources i)))]
+      (send resource dispose))))
+
+(define (color-number? n)
+  (and (number? n)
+       (<= 0.0 n 1.0)))
+
+(define (image->bitmap i)
+  (cond
+    [(is-a? i bitmap%)
+     i]
+    [(image:image? i)
+     (define w (max 1 (image:image-width i)))
+     (define h (max 1 (image:image-height i)))
+     (define bm (make-object bitmap% w h #f #t))
+     (define dc (send bm make-dc))
+     (send i draw dc
+           0 0
+           0 0
+           w h
+           0 0
+           #f)
+     bm]
+    [(pict:pict? i)
+     (pict:pict->bitmap i)]
+    [else
+     (error 'image->bitmap "unsupported image type ~v" i)]))
+
+(define (image->texture-cache-entry i)
+  (texture-cache-get i image->bitmap))
+
+;; (define (lerp a b v) (+ (* v a) (* (- 1 v) b)))
+
+(define (draw-gl-face texture [left 0] [top 0] [width 1] [height 1])
+  (define bot (+ top height))
+  (define right (+ left width))
+  (send texture bind-texture)
+  (glBegin GL_QUADS)
+  (glNormal3d 0 0 -1)
+  (glTexCoord2d left top)
+  (glVertex3d 0 0 0)
+  (glTexCoord2d right top)
+  (glVertex3d 1 0 0)
+  (glTexCoord2d right bot)
+  (glVertex3d 1 1 0)
+  (glTexCoord2d left bot)
+  (glVertex3d 0 1 0)
+  (glEnd))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define sprite-order
+  (order 'sprite-order
+         sprite?
+         (lambda (a b) (and (equal? (sprite-id a) (sprite-id b))
+                            (= (sprite-z a) (sprite-z b))
+                            (eq? (sprite-instructions a)
+                                 (sprite-instructions b))))
+         (lambda (a b) (or (> (sprite-z a) (sprite-z b))
+                           (and (= (sprite-z a) (sprite-z b))
+                                (let ((a-id-code (equal-hash-code (sprite-id a)))
+                                      (b-id-code (equal-hash-code (sprite-id b))))
+                                  (or (< a-id-code b-id-code)
+                                      (and (= a-id-code b-id-code)
+                                           (< (eq-hash-code (sprite-instructions a))
+                                              (eq-hash-code (sprite-instructions b)))))))))))
+
+(define (remove-sprite! childmap s)
+  (define sprites (hash-ref childmap (sprite-parent-id s) #f))
+  (when sprites
+    (compiled-instructions-dispose! (splay-tree-ref sprites s #f))
+    (splay-tree-remove! sprites s)
+    (when (dict-empty? sprites) (hash-remove! childmap (sprite-parent-id s)))))
+
+(define (add-sprite! childmap s)
+  (define sprites (hash-ref childmap (sprite-parent-id s)
+                            (lambda ()
+                              (define ss (make-splay-tree sprite-order))
+                              (hash-set! childmap (sprite-parent-id s) ss)
+                              ss)))
+  (define instrs `((color 1 1 1 1)
+                   (push-matrix ,@(seal-contents (sprite-instructions s)))))
+  (define i (compile-instructions instrs))
+  (splay-tree-set! sprites s i))
+
+(define (for-each-child-sprite childmap id f)
+  (define children (hash-ref childmap id #f))
+  (let loop ((iter (and children (splay-tree-iterate-first children))))
+    (when iter
+      (define s (splay-tree-iterate-key children iter))
+      (define ci (splay-tree-iterate-value children iter))
+      (f s ci)
+      (loop (splay-tree-iterate-next children iter)))))
+
+(define (render-sprites! childmap self-id)
+  (for-each-child-sprite childmap self-id
+                         (lambda (s ci)
+                           ((compiled-instructions-render-proc ci) childmap (sprite-id s)))))
+
+(define (render-scene! prelude childmap postlude)
+  ((compiled-instructions-render-proc prelude) childmap #f)
+  (render-sprites! childmap #f)
+  ((compiled-instructions-render-proc postlude) childmap #f))
+
+(define (detect-touch prelude childmap postlude state)
+  (and state
+       (let ()
+         (define x (mouse-state-x state))
+         (define y (mouse-state-y state))
+         (or (detect-touch* childmap #f postlude x y)
+             (detect-sprites-touch childmap #f x y)
+             (detect-touch* childmap #f prelude x y)))))
+
+(define (detect-sprites-touch childmap self-id x y)
+  (define sprites (hash-ref childmap self-id #f))
+  (let loop ((iter (and sprites (splay-tree-iterate-greatest sprites))))
+    (and iter
+         (let ((s (splay-tree-iterate-key sprites iter)))
+           (define ci (splay-tree-iterate-value sprites iter))
+           (or (detect-touch* childmap (sprite-id s) ci x y)
+               (loop (splay-tree-iterate-greatest/<? sprites s)))))))
+
+(define (detect-touch* childmap self-id ci x y)
+  (for/or [(t (in-list (compiled-instructions-touchables ci)))]
+    (match t
+      [(touchable id xform contains?)
+       (define-values (ux uy) (untransform-point* xform x y))
+       (and (contains? ux uy) (touching id))]
+      [(touchable-map)
+       (define xform (compiled-instructions-child-xform ci))
+       (define-values (ux uy) (untransform-point* xform x y))
+       (detect-sprites-touch childmap self-id ux uy)])))
+
+(define (untransform-point* xform x y)
+  (define p (untransform-point xform (make-rectangular x y)))
+  (values (real-part p) (imag-part p)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define dataspace-frame%
+  (class* frame% ()
+    (init ground-ch)
+    (super-new)
+    (define (stop!)
+      (parameterize ((current-ground-event-async-channel ground-ch))
+        (ground-send! (gl-control 'stop))))
+    (define/augment (on-close) (stop!))))
+
+(define dataspace-canvas%
+  (class canvas%
+    (inherit refresh with-gl-context swap-gl-buffers)
+
+    (init [(eventspace0 eventspace)])
+    (init ground-ch)
+
+    (define eventspace eventspace0)
+
+    (define (! msg)
+      (parameterize ((current-ground-event-async-channel ground-ch))
+        (ground-send! msg)))
+
+    (define (++ assertion)
+      (parameterize ((current-ground-event-async-channel ground-ch))
+        (ground-assert! assertion)))
+
+    (define (-- assertion)
+      (parameterize ((current-ground-event-async-channel ground-ch))
+        (ground-retract! assertion)))
+
+    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+    (define initialised? #f)
+
+    (define near-depth 10) ;; 2.5D
+    (define far-depth 15) ;; 2.5D
+
+    (define prelude empty-instructions)
+    (define childmap (make-hash))
+    (define postlude empty-instructions)
+
+    (define current-window-width #f)
+    (define current-window-height #f)
+    (define current-mouse-state #f)
+    (define current-coordinate-maps (hash))
+    (define current-touching #f)
+
+    (define render-needed? #t)
+
+    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+    (define (mark-dirty!)
+      (when (not render-needed?)
+        (parameterize ((current-eventspace eventspace))
+          (queue-callback (lambda () (refresh)))))
+      (set! render-needed? #t))
+
+    (define/public (replace-scene! new-prelude new-postlude)
+      (with-gl-context
+        (lambda ()
+          (compiled-instructions-dispose! prelude)
+          (compiled-instructions-dispose! postlude)
+          (set! prelude (compile-instructions new-prelude))
+          (set! postlude (compile-instructions new-postlude)))))
+
+    (define/public (alter-sprites! changes)
+      (with-gl-context
+        (lambda ()
+          (for [(change (in-list changes))]
+            (match change
+              [(cons '+ s) (add-sprite! childmap s)]
+              [(cons '- s) (remove-sprite! childmap s)]))
+          (mark-dirty!))))
+
+    (define/public (initialize!)
+      (unless initialised?
+        (with-gl-context
+          (lambda ()
+            (glBlendFunc GL_ONE GL_ONE_MINUS_SRC_ALPHA) ;; premultiplied
+            (glEnable GL_BLEND)
+            (glEnable GL_TEXTURE_2D)
+            (glClearColor 0 0 0 1)
+            (set! initialised? #t)))))
+
+    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+    (define/override (on-paint)
+      (initialize!)
+
+      (with-gl-context
+        (lambda ()
+          (update-touching!)
+          (update-coordinate-maps!)
+          (flush-texture-cache!)
+
+          (glClear GL_COLOR_BUFFER_BIT)
+          (glLoadIdentity)
+          (glTranslated 0 0 (- near-depth))
+          (render-scene! prelude childmap postlude)
+          (glFlush)
+          (swap-gl-buffers)
+
+          (set! render-needed? #f))))
+
+    (define/override (on-size width height)
+      (with-gl-context
+        (lambda ()
+          (when (not (and (equal? current-window-width width)
+                          (equal? current-window-height height)))
+            (-- (window current-window-width current-window-height))
+            (set! current-window-width width)
+            (set! current-window-height height)
+            (++ (window current-window-width current-window-height)))
+          (glViewport 0 0 width height)
+          (glMatrixMode GL_PROJECTION)
+          (glLoadIdentity)
+          (glOrtho 0 width height 0 0.1 100)
+          (glMatrixMode GL_MODELVIEW)
+          (glLoadIdentity)
+          (mark-dirty!))))
+
+    (define/override (on-char key)
+      (with-gl-context
+        (lambda ()
+          (! (match (send key get-key-code)
+               ['release (key-event (send key get-key-release-code) #f (seal key))]
+               [code     (key-event code                            #t (seal key))])))))
+
+    (define/override (on-event mouse)
+      (with-gl-context
+        (lambda ()
+          (define-values (x y)
+            (untransform-point* (compiled-instructions-final-xform prelude)
+                                (send mouse get-x)
+                                (send mouse get-y)))
+          (define s (mouse-state x
+                                 y
+                                 (send mouse get-left-down)
+                                 (send mouse get-middle-down)
+                                 (send mouse get-right-down)))
+          (set! current-mouse-state s)
+          (update-touching!)
+          (! (mouse-event (send mouse get-event-type) s)))))
+
+    (define (update-touching!)
+      (define new-touching (detect-touch prelude childmap postlude current-mouse-state))
+      (when (not (equal? current-touching new-touching))
+        (when current-touching (-- current-touching))
+        (set! current-touching new-touching)
+        (when current-touching (++ current-touching))))
+
+    (define (update-coordinate-maps!)
+      (define (update-single-map! cmid cmx)
+        (define existing (hash-ref current-coordinate-maps cmid #f))
+        (define proposed (coordinate-map cmid cmx))
+        (when (not (equal? existing proposed))
+          (set! current-coordinate-maps (hash-set current-coordinate-maps cmid proposed))
+          (-- existing)
+          (++ proposed)))
+
+      (let process-children-of ((id #f) (xform identity-transformation))
+        (for-each-child-sprite childmap id
+                               (lambda (s ci)
+                                 (for [(cm (in-list (compiled-instructions-coordinate-maps ci)))]
+                                   (match-define (coordinate-map cmid cmx) cm)
+                                   (update-single-map! cmid (compose-transformation xform cmx)))
+                                 (define child-xform (compiled-instructions-child-xform ci))
+                                 (when child-xform
+                                   (process-children-of (sprite-id s)
+                                                        (compose-transformation xform
+                                                                                child-xform)))))))
+
+    (super-new (style '(gl no-autoclear)))))
+
+(define (spawn-gl-2d-driver #:label [frame-label "syndicate-gl"]
+                            #:width [width #f]
+                            #:height [height #f])
+  (spawn #:name 'gl-2d/driver
+         (define frame #f) ;; "frame" here refers to *window frame* onscreen, i.e. GUI, not GL
+         (define c #f)
+
+         (parameterize ((current-eventspace (make-eventspace)))
+           (set! frame (new dataspace-frame%
+                            [style '(fullscreen-button)]
+                            [label frame-label]
+                            [width (or width 640)]
+                            [height (or height 480)]
+                            [ground-ch (current-ground-event-async-channel)]))
+           (set! c (new dataspace-canvas%
+                        [parent frame]
+                        [eventspace (current-eventspace)]
+                        [ground-ch (current-ground-event-async-channel)]))
+           (unless (send (send (send c get-dc) get-gl-context) ok?)
+             (error 'gl-2d "OpenGL context failed to initialize"))
+           (send c focus)
+           (send frame show #t))
+
+         (define start-time (current-inexact-milliseconds))
+         (define frame-counter 0)
+         (define target-frame-rate 60)
+         (define changes '())
+         (define dirty? #f)
+
+         (field [sim-time 0])
+
+         (on (asserted (later-than (+ (sim-time) start-time)))
+             (define per-frame-ms (* (/ target-frame-rate) 1000.0))
+             (send! (frame-event frame-counter (sim-time) per-frame-ms target-frame-rate))
+             (set! frame-counter (+ frame-counter 1))
+             (sim-time (* frame-counter per-frame-ms))
+             (when dirty?
+               (send c alter-sprites! (reverse changes))
+               (set! changes '())
+               (set! dirty? #f)))
+
+         ;; TODO: maybe add a means of setting target frame rate?
+         ;; (define/public (set-target-frame-rate! r)
+         ;;   (set! target-frame-rate r))
+
+         (on (asserted (scene $sealed-prelude $sealed-postlude))
+             (send c replace-scene!
+                   (seal-contents sealed-prelude)
+                   (seal-contents sealed-postlude))
+             (set! dirty? #t))
+
+         (on (retracted ($ s (sprite _ _ _ _)))
+             (set! changes (cons (cons '- s) changes))
+             (set! dirty? #t))
+         (on (asserted ($ s (sprite _ _ _ _)))
+             (set! changes (cons (cons '+ s) changes))
+             (set! dirty? #t))
+
+         (on (message (gl-control 'stop))
+             (send frame show #f)
+             (stop-current-facet))
+
+         (during (gl-control 'fullscreen)
+           (on-start (send frame fullscreen #t))
+           (on-stop  (send frame fullscreen #f)))
+
+         ))

imperative/drivers/sqlite.rkt

@@ -0,0 +1,167 @@
+#lang imperative-syndicate
+;; SQLite driver
+
+(provide (struct-out sqlite-db)
+         (struct-out sqlite-db-ready)
+         (struct-out sqlite-row)
+         (struct-out sqlite-exec)
+         (struct-out sqlite-create-table)
+         (struct-out sqlite-insert)
+         (struct-out sqlite-delete)
+         sqlite-exec!
+         sqlite-create-table!
+         sqlite-insert!
+         sqlite-delete!
+         (struct-out discard) ;; from imperative-syndicate/pattern
+         )
+
+(require db)
+(require racket/set)
+(require racket/string)
+(require imperative-syndicate/pattern)
+
+(define-logger syndicate/sqlite)
+
+(struct sqlite-db (path) #:prefab)
+
+(assertion-struct sqlite-db-ready (db))
+
+(assertion-struct sqlite-row (db table columns))
+
+(message-struct sqlite-exec (db template arguments id))
+(message-struct sqlite-status (id value))
+
+(message-struct sqlite-create-table (db table column-names id))
+(message-struct sqlite-insert (db table columns id))
+(message-struct sqlite-delete (db table columns id))
+
+(define (sqlite-call db msg-proc)
+  (define id (gensym 'exec))
+  (react/suspend (k)
+    (on (message (sqlite-status id $v))
+        (if (exn? v) (raise v) (k v)))
+    (on (asserted (sqlite-db-ready db))
+        (send! (msg-proc id)))))
+
+(define (sqlite-exec! db template . arguments)
+  (sqlite-call db (lambda (id) (sqlite-exec db template arguments id))))
+
+(define (sqlite-create-table! db table . column-names)
+  (sqlite-call db (lambda (id) (sqlite-create-table db table column-names id))))
+
+(define (sqlite-insert! db table . columns)
+  (sqlite-call db (lambda (id) (sqlite-insert db table columns id))))
+
+(define (sqlite-delete! db table . columns)
+  (sqlite-call db (lambda (id) (sqlite-delete db table columns id))))
+
+(define (strip-capture p)
+  (if (capture? p)
+      (strip-capture (capture-detail p))
+      p))
+
+(spawn #:name 'drivers/sqlite
+       (during/spawn ($ db (sqlite-db $path))
+         #:name (list 'drivers/sqlite path)
+         (define handle (sqlite3-connect #:database path #:mode 'create)) ;; TODO: #:use-place ?
+         (on-stop (disconnect handle))
+
+         (assert (sqlite-db-ready db))
+
+         (on (message (sqlite-exec db $template $arguments $id))
+             (with-handlers [(exn:fail? (lambda (e) (send! (sqlite-status id e))))]
+               (log-syndicate/sqlite-debug "~s ~s" template arguments)
+               (send! (sqlite-status id (apply query-exec handle template arguments)))))
+
+         (field [known-tables (set)])
+
+         (on (message (sqlite-create-table db $table $column-names $id))
+             (with-handlers [(exn:fail? (lambda (e) (send! (sqlite-status id e))))]
+               (define template
+                 (format "create table ~a (~a)" table (string-join column-names ", ")))
+               (define arguments '())
+               (table-facet handle known-tables db table column-names)
+               (log-syndicate/sqlite-debug "~s ~s" template arguments)
+               (send! (sqlite-status id (apply query-exec handle template arguments)))))
+
+         (on-start
+          (for [(table (query-list handle
+                                   "select distinct name from sqlite_master where type='table'"))]
+            (define column-names
+              (map (lambda (r) (vector-ref r 1))
+                   (query-rows handle (string-append "pragma table_info(" table ")"))))
+            (table-facet handle known-tables db table column-names)))))
+
+(define (table-facet handle known-tables db table column-names)
+  (when (not (set-member? (known-tables) table))
+    (known-tables (set-add (known-tables) table))
+    (react
+     (on (message ($ m (sqlite-insert db table $columns $id)))
+         (with-handlers [(exn:fail? (lambda (e) (send! (sqlite-status id e))))]
+           (define template (format "insert into ~a values (~a)"
+                                    table
+                                    (string-join (for/list [(i (in-naturals 1)) (c columns)]
+                                                   (format "$~a" i))
+                                                 ", ")))
+           (define arguments columns)
+           (log-syndicate/sqlite-debug "~s ~s" template arguments)
+           (send! (sqlite-status id (apply query-exec handle template arguments)))))
+
+     (on (message ($ m (sqlite-delete db table $columns $id)))
+         (with-handlers [(exn:fail? (lambda (e) (send! (sqlite-status id e))))]
+           (define filters
+             (for/list [(n column-names) (c columns) #:when (not (discard? c))]
+               (list n c)))
+           (define template
+             (format "delete from ~a~a"
+                     table
+                     (if (null? filters)
+                         ""
+                         (format " where ~a"
+                                 (string-join (for/list [(i (in-naturals 1)) (f filters)]
+                                                (format "~a = $~a" (car f) i))
+                                              " and ")))))
+           (define arguments (map cadr filters))
+           (log-syndicate/sqlite-debug "~s ~s" template arguments)
+           (send! (sqlite-status id (apply query-exec handle template arguments)))))
+
+     (define (row-facet columns)
+       (react (assert (sqlite-row db table columns))
+              (on (message (sqlite-delete db table $cs _))
+                  (when (for/and [(c1 columns) (c2 cs)] (or (discard? c2) (equal? c1 c2)))
+                    (stop-current-facet)))))
+
+     (during/spawn (observe (sqlite-row db table $column-patterns0))
+       (define column-patterns
+         (let ((ps (strip-capture column-patterns0)))
+           (if (discard? ps)
+               (for/list [(n column-names)] (discard))
+               ps)))
+       (define filters
+         (for/list [(n column-names)
+                    (p (map strip-capture column-patterns))
+                    #:when (not (discard? p))]
+           (list n p)))
+
+       (define initial-rows
+         (let ()
+           (define template
+             (format "select distinct * from ~a~a"
+                     table
+                     (if (null? filters)
+                         ""
+                         (format " where ~a"
+                                 (string-join (for/list [(i (in-naturals 1)) (f filters)]
+                                                (format "~a = $~a" (car f) i))
+                                              " and ")))))
+           (define arguments (map cadr filters))
+           (log-syndicate/sqlite-debug "~s ~s" template arguments)
+           (map vector->list (apply query-rows handle template (map cadr filters)))))
+
+       (on-start (for-each row-facet initial-rows))
+       (on (message (sqlite-insert db table $columns _))
+           (when (for/and [(n column-names) (c columns)]
+                   (match (assoc n filters)
+                     [(list _ v) (equal? c v)]
+                     [#f #t]))
+             (row-facet columns)))))))

imperative/drivers/tcp.rkt

@@ -0,0 +1,206 @@
+#lang imperative-syndicate
+;; TCP/IP driver interface.
+;;
+;; TODO: This protocol is overly simplified.
+;; a) no facility for separate shutdown of inbound/outbound streams
+
+(provide (struct-out tcp-connection)
+         (struct-out tcp-connection-peer)
+         (struct-out tcp-accepted)
+         (struct-out tcp-rejected)
+         (struct-out tcp-out)
+         (struct-out tcp-in)
+         (struct-out tcp-in-line)
+
+         (struct-out tcp-address)
+         (struct-out tcp-listener)
+
+         (all-from-out imperative-syndicate/protocol/credit))
+
+(define-logger syndicate/tcp)
+
+(require racket/exn)
+(require (prefix-in tcp: racket/tcp))
+(require (only-in racket/port read-bytes-avail!-evt read-bytes-line-evt))
+
+(require racket/unit)
+(require net/tcp-sig)
+(require net/tcp-unit)
+
+(require syndicate/support/bytes)
+
+(require imperative-syndicate/protocol/credit)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Protocol messages
+
+(assertion-struct tcp-connection (id spec))
+(assertion-struct tcp-connection-peer (id addr))
+(assertion-struct tcp-accepted (id))
+(assertion-struct tcp-rejected (id exn))
+(message-struct tcp-out (id bytes))
+(message-struct tcp-in (id bytes))
+(message-struct tcp-in-line (id bytes))
+
+(assertion-struct tcp-address (host port))
+(assertion-struct tcp-listener (port))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Ground-level communication messages
+
+(message-struct raw-tcp-accepted (local-addr remote-addr cin cout))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Driver
+
+(spawn #:name 'drivers/tcp
+
+       (during/spawn (observe (tcp-connection _ (tcp-listener $port)))
+         #:name (list 'drivers/tcp 'listener port)
+         (run-listener port))
+
+       (during/spawn (tcp-connection $id (tcp-address $host $port))
+         #:name (list 'drivers/tcp 'outbound id host port)
+         (match (with-handlers ([exn:fail? (lambda (e) (list e))])
+                  (define-values (cin cout) (tcp:tcp-connect host port))
+                  (list cin cout))
+           [(list e) (assert (tcp-rejected id e))]
+           [(list cin cout)
+            (assert (tcp-accepted id))
+            (run-connection id cin cout)])))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Listener
+
+(define (run-listener port)
+  (define server-addr (tcp-listener port))
+  (define listener (tcp:tcp-listen port 128 #t))
+  (define control-ch (make-channel))
+
+  (thread (lambda ()
+            (let loop ((credit 1)) ;; NB. not zero initially!
+              (sync (handle-evt control-ch
+                                (match-lambda
+                                  [(list 'credit 'reset) (loop 0)]
+                                  [(list 'credit (? number? amount)) (loop (+ credit amount))]
+                                  ['quit (void)]))
+                    (if (zero? credit)
+                        never-evt
+                        (handle-evt (tcp:tcp-accept-evt listener)
+                                    (lambda (cin+cout)
+                                      (match-define (list cin cout) cin+cout)
+                                      (define-values
+                                        (local-hostname local-port remote-hostname remote-port)
+                                        (tcp:tcp-addresses cin #t))
+                                      (ground-send!
+                                       (inbound
+                                        (raw-tcp-accepted server-addr
+                                                          (tcp-address remote-hostname remote-port)
+                                                          cin
+                                                          cout)))
+                                      (loop (- credit 1)))))))
+            (tcp:tcp-close listener)
+            (signal-background-activity! -1)))
+  (signal-background-activity! +1)
+
+  (on-stop (channel-put control-ch 'quit))
+
+  (on (message (credit* (list server-addr) $amount))
+      (channel-put control-ch (list 'credit amount)))
+
+  (on (message (inbound (raw-tcp-accepted server-addr $remote-addr $cin $cout)))
+      (define id (seal (list port remote-addr)))
+      (spawn #:name (list 'drivers/tcp 'inbound id)
+             (assert (tcp-connection id server-addr))
+             (assert (tcp-connection-peer id remote-addr))
+             (run-connection id cin cout)
+             (stop-when (asserted (tcp-rejected id _)))
+             (stop-when (retracted (tcp-accepted id))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Connection
+
+(define (run-connection id cin cout)
+  (define control-ch (make-channel))
+  (thread (lambda () (connection-thread control-ch id cin)))
+  (signal-background-activity! +1)
+
+  (define (shutdown-connection!)
+    (when control-ch
+      (channel-put control-ch 'quit)
+      (set! control-ch #f))
+    (when cout
+      (close-output-port cout)
+      (set! cout #f)))
+
+  (on-stop (shutdown-connection!))
+
+  (on (asserted (observe (credit* (list tcp-out id) _)))
+      (send! (credit tcp-out id +inf.0)))
+
+  (on (message (credit* (list tcp-in id) $amount))
+      (when control-ch (channel-put control-ch (list 'credit amount))))
+
+  (field [mode 'bytes])
+  (begin/dataflow (when control-ch (channel-put control-ch (mode))))
+
+  (on (message (inbound (tcp-in id $eof-or-bs)))
+      (if (eof-object? eof-or-bs)
+          (stop-current-facet)
+          (send! (match (mode)
+                   ['bytes (tcp-in id eof-or-bs)]
+                   ['lines (tcp-in-line id eof-or-bs)]))))
+
+  (during (observe (tcp-in-line id _))
+    (on-start (mode 'lines))
+    (on-stop (mode 'bytes)))
+
+  (define-syntax-rule (trap-exns body ...)
+    (with-handlers ([(lambda (e) (not (exn:break? e)))
+                     (lambda (e)
+                       (shutdown-connection!)
+                       (raise e))])
+      body ...))
+
+  (on (message (tcp-out id $bs))
+      (trap-exns
+       (if (string? bs)
+           (write-string bs cout)
+           (write-bytes bs cout))
+       (flush-output cout))))
+
+(define (connection-thread control-ch id cin)
+  (let loop ((credit 0) (mode 'bytes))
+    (sync (handle-evt control-ch
+                      (match-lambda
+                        [(list 'credit 'reset) (loop 0 mode)]
+                        [(list 'credit (? number? amount)) (loop (+ credit amount) mode)]
+                        ['lines (loop credit 'lines)]
+                        ['bytes (loop credit 'bytes)]
+                        ['quit (void)]))
+          (if (zero? credit)
+              never-evt
+              (handle-evt (match mode
+                            ['bytes (read-bytes-avail-evt (inexact->exact (truncate (min credit 32768))) cin)]
+                            ['lines (read-bytes-line-evt cin 'any)])
+                          (lambda (eof-or-bs)
+                            (ground-send! (inbound (tcp-in id eof-or-bs)))
+                            (loop (if (eof-object? eof-or-bs)
+                                      0
+                                      (- credit (match mode
+                                                  ['bytes (bytes-length eof-or-bs)]
+                                                  ['lines 1])))
+                                  mode))))))
+  (close-input-port cin)
+  (signal-background-activity! -1))
+
+(define (read-bytes-avail-evt len input-port)
+  (guard-evt
+   (lambda ()
+     (let ([bstr (make-bytes len)])
+       (handle-evt
+        (read-bytes-avail!-evt bstr input-port)
+        (lambda (v)
+          (if (number? v)
+              (if (= v len) bstr (subbytes bstr 0 v))
+              v)))))))

imperative/drivers/timer.rkt

@@ -0,0 +1,116 @@
+#lang imperative-syndicate
+;; Timer driver.
+
+;; Uses mutable state internally, but because the scope of the
+;; mutation is limited to each timer process alone, it's easy to show
+;; correct linear use of the various pointers.
+
+(provide (struct-out set-timer)
+	 (struct-out timer-expired)
+         (struct-out later-than)
+         on-timeout
+         stop-when-timeout
+         sleep)
+
+(define-logger syndicate/drivers/timer)
+
+(require racket/set)
+(require data/heap)
+
+(message-struct set-timer (label msecs kind))
+(message-struct timer-expired (label msecs))
+
+(assertion-struct later-than (msecs))
+
+(spawn #:name 'drivers/timer
+       (define control-ch (make-channel))
+
+       (thread (lambda ()
+                 (struct pending-timer (deadline label) #:transparent)
+
+                 (define heap
+                   (make-heap (lambda (t1 t2) (<= (pending-timer-deadline t1)
+                                                  (pending-timer-deadline t2)))))
+
+                 (define timers (make-hash))
+
+                 (define (next-timer)
+                   (and (positive? (heap-count heap))
+                        (heap-min heap)))
+
+                 (define (fire-timers! now)
+                   (define count-fired 0)
+                   (let loop ()
+                     (when (positive? (heap-count heap))
+                       (let ((m (heap-min heap)))
+                         (when (<= (pending-timer-deadline m) now)
+                           (define label (pending-timer-label m))
+                           (heap-remove-min! heap)
+                           (hash-remove! timers label)
+                           (log-syndicate/drivers/timer-debug "expired timer ~a" label)
+                           (ground-send! (timer-expired label now))
+                           (set! count-fired (+ count-fired 1))
+                           (loop)))))
+                   (signal-background-activity! (- count-fired)))
+
+                 (define (clear-timer! label)
+                   (match (hash-ref timers label #f)
+                     [#f (void)]
+                     [deadline
+                      (heap-remove! heap (pending-timer deadline label))
+                      (hash-remove! timers label)
+                      (signal-background-activity! -1)]))
+
+                 (define (install-timer! label deadline)
+                   (clear-timer! label)
+                   (heap-add! heap (pending-timer deadline label))
+                   (hash-set! timers label deadline)
+                   (signal-background-activity! +1))
+
+                 (let loop ()
+                   (sync (match (next-timer)
+                           [#f never-evt]
+                           [t (handle-evt (alarm-evt (pending-timer-deadline t))
+                                          (lambda (_dummy)
+                                            (define now (current-inexact-milliseconds))
+                                            (fire-timers! now)
+                                            (loop)))])
+                         (handle-evt control-ch
+                                     (match-lambda
+                                       [(set-timer label _ 'clear)
+                                        (clear-timer! label)
+                                        (loop)]
+                                       [(set-timer label msecs 'relative)
+                                        (define deadline (+ (current-inexact-milliseconds) msecs))
+                                        (install-timer! label deadline)
+                                        (loop)]
+                                       [(set-timer label deadline 'absolute)
+                                        (install-timer! label deadline)
+                                        (loop)]))))))
+
+       (on (message ($ instruction (set-timer _ _ _)))
+           (log-syndicate/drivers/timer-debug "received instruction ~a" instruction)
+           (channel-put control-ch instruction))
+
+       (during (observe (later-than $msecs))
+         (log-syndicate/drivers/timer-debug "observing (later-than ~a) at ~a"
+                                            msecs
+                                            (current-inexact-milliseconds))
+         (define timer-id (gensym 'timestate))
+         (on-start (send! (set-timer timer-id msecs 'absolute)))
+         (on-stop (send! (set-timer timer-id msecs 'clear)))
+         (on (message (timer-expired timer-id _))
+             (react (assert (later-than msecs))))))
+
+(define-syntax-rule (on-timeout relative-msecs body ...)
+  (let ((timer-id (gensym 'timeout)))
+    (on-start (send! (set-timer timer-id relative-msecs 'relative)))
+    (on (message (timer-expired timer-id _)) body ...)))
+
+(define-syntax-rule (stop-when-timeout relative-msecs body ...)
+  (on-timeout relative-msecs (stop-current-facet body ...)))
+
+(define (sleep sec)
+  (define timer-id (gensym 'sleep))
+  (until (message (timer-expired timer-id _))
+    (on-start (send! (set-timer timer-id (* sec 1000.0) 'relative)))))

imperative/drivers/udp.rkt

@@ -0,0 +1,98 @@
+#lang imperative-syndicate
+
+(provide (struct-out udp-remote-address)
+	 (struct-out udp-handle)
+	 (struct-out udp-listener)
+         (struct-out udp-multicast-group-member)
+         (struct-out udp-multicast-loopback)
+	 udp-address?
+	 udp-local-address?
+	 (struct-out udp-packet))
+
+(require (prefix-in udp: racket/udp))
+
+;; A UdpAddress is one of
+;; -- a (udp-remote-address String Uint16), representing a remote socket
+;; -- a (udp-handle Any), representing a local socket on a kernel-assigned port
+;; -- a (udp-listener Uint16), representing a local socket on a user-assigned port
+;; Note that udp-handle-ids must be chosen carefully: they are scoped
+;; to the local dataspace, i.e. shared between processes in that
+;; dataspace, so processes must make sure not to accidentally clash in
+;; handle ID selection.
+(struct udp-remote-address (host port) #:prefab)
+(struct udp-handle (id) #:prefab)
+(struct udp-listener (port) #:prefab)
+
+(define (udp-address? x)
+  (or (udp-remote-address? x)
+      (udp-local-address? x)))
+
+(define (udp-local-address? x)
+  (or (udp-handle? x)
+      (udp-listener? x)))
+
+;; A UdpMembership is a (udp-multicast-group-member UdpLocalAddress String String),
+;; where the latter two arguments correspond to the last two arguments
+;; of `udp-multicast-join-group!`.
+(assertion-struct udp-multicast-group-member (local-address group-address interface))
+
+;; A UdpLoopback is a (udp-multicast-loopback UdpLocalAddress Boolean).
+(assertion-struct udp-multicast-loopback (local-address enabled?))
+
+;; A UdpPacket is a (udp-packet UdpAddress UdpAddress Bytes), and
+;; represents a packet appearing on our local "subnet" of the full UDP
+;; network, complete with source, destination and contents.
+(message-struct udp-packet (source destination body))
+
+(spawn #:name 'udp-driver
+       (during/spawn (observe ($ local-addr (udp-listener _)))
+         #:name local-addr
+         (udp-main local-addr))
+       (during/spawn (observe ($ local-addr (udp-handle _)))
+         #:name local-addr
+         (udp-main local-addr)))
+
+;; UdpLocalAddress -> Void
+(define (udp-main local-addr)
+  (define socket (udp:udp-open-socket #f #f))
+
+  (match local-addr
+    [(udp-listener port) (udp:udp-bind! socket #f port #t)]
+    [(udp-handle _) (udp:udp-bind! socket #f 0)]) ;; kernel-allocated port number
+
+  (define control-ch (make-channel))
+  (thread (lambda () (udp-receiver-thread local-addr socket control-ch)))
+  (signal-background-activity! +1)
+  (on-stop (channel-put control-ch 'quit))
+
+  (assert local-addr)
+  (stop-when (retracted (observe local-addr)))
+
+  (during (udp-multicast-group-member local-addr $group $interface)
+    (on-start (udp:udp-multicast-join-group! socket group interface))
+    (on-stop (udp:udp-multicast-leave-group! socket group interface)))
+
+  (on (asserted (udp-multicast-loopback local-addr $enabled))
+      (udp:udp-multicast-set-loopback! socket enabled))
+
+  (on (message (inbound ($ p (udp-packet _ local-addr _))))
+      (send! p))
+
+  (on (message (udp-packet local-addr (udp-remote-address $h $p) $body))
+      (udp:udp-send-to* socket h p body)))
+
+;; UdpLocalAddress UdpSocket Channel -> Void
+(define (udp-receiver-thread local-addr socket control-ch)
+  (define buffer (make-bytes 65536))
+  (let loop ()
+    (sync (handle-evt control-ch (match-lambda ['quit (void)]))
+	  (handle-evt (udp:udp-receive!-evt socket buffer)
+		      (lambda (receive-results)
+			(match-define (list len source-hostname source-port) receive-results)
+                        (ground-send!
+			 (udp-packet (udp-remote-address source-hostname source-port)
+				     local-addr
+				     (subbytes buffer 0 len)))
+			(loop)))))
+  (udp:udp-close socket)
+  (signal-background-activity! -1))

imperative/drivers/web.rkt

@@ -0,0 +1,348 @@
+#lang imperative-syndicate
+
+(provide (struct-out http-server)
+         (struct-out http-resource)
+         (struct-out http-request)
+         (struct-out http-accepted)
+         (except-out (struct-out http-response) http-response)
+         (rename-out [make-http-response http-response]
+                     [http-response <http-response>])
+         (except-out (struct-out http-response-websocket) http-response-websocket)
+         (rename-out [make-http-response-websocket http-response-websocket]
+                     [http-response-websocket <http-response-websocket>])
+         (struct-out http-request-peer-details)
+         (struct-out http-request-cookie)
+         (struct-out http-response-chunk)
+         (struct-out websocket-out)
+         (struct-out websocket-in)
+
+         xexpr->bytes/utf-8)
+
+(require racket/async-channel)
+(require racket/exn)
+(require (only-in racket/list flatten))
+(require (only-in racket/string string-append*))
+(require (only-in racket/bytes bytes-append*))
+(require racket/tcp)
+
+(require net/rfc6455)
+(require net/rfc6455/conn-api)
+(require net/rfc6455/dispatcher)
+(require net/url)
+
+(require struct-defaults)
+
+(require web-server/http/bindings)
+(require web-server/http/cookie)
+(require web-server/http/cookie-parse)
+(require web-server/http/request)
+(require web-server/http/request-structs)
+(require web-server/http/response)
+(require web-server/http/response-structs)
+(require web-server/private/connection-manager)
+(require (only-in web-server/private/util lowercase-symbol!))
+(require web-server/dispatchers/dispatch)
+
+(require xml)
+
+(module+ test (require rackunit))
+
+(define-logger syndicate/drivers/web)
+
+(define (url-path->resource-path up)
+  (define elements (for/list [(p (in-list up))]
+                     (match-define (path/param path-element params) p)
+                     (list* path-element params)))
+  (foldr (lambda (e acc) (append e (list acc))) '() elements))
+
+(define (build-headers hs)
+  (for/list ((h (in-list hs)))
+    (header (string->bytes/utf-8 (symbol->string (car h)))
+            (string->bytes/utf-8 (cdr h)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; API/Protocol
+
+(assertion-struct http-server (host port ssl?))
+(assertion-struct http-resource (server path))
+
+(assertion-struct http-request (id method resource headers query body))
+(assertion-struct http-accepted (id))
+
+(assertion-struct http-response (id code message last-modified-seconds mime-type headers detail))
+;; ^ detail = (U Bytes 'chunked)
+(assertion-struct http-response-websocket (id headers))
+
+(assertion-struct http-request-peer-details (id local-ip local-port remote-ip remote-port))
+(assertion-struct http-request-cookie (id name value domain path))
+
+(message-struct http-response-chunk (id bytes))
+
+(message-struct websocket-out (id body))
+(message-struct websocket-in (id body))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Ground messages
+
+(message-struct web-raw-request (id port connection addresses req control-ch))
+(message-struct web-raw-client-conn (id connection))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define web-server-max-waiting (make-parameter 511)) ;; sockets
+(define web-server-connection-manager (make-parameter #f))
+(define web-server-initial-connection-timeout (make-parameter 30)) ;; seconds
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(spawn
+ #:name 'http-server-factory
+
+ (during (observe (http-request _ _ (http-resource $server _) _ _ _))
+   (assert server))
+
+ (during/spawn (http-server _ $port _)
+   #:name (list 'http-listener port)
+
+   (define ssl? #f)
+   (on (asserted (http-server _ port #t))
+       (error 'http-listener "SSL service not yet implemented")) ;; TODO
+
+   (define cm (or (web-server-connection-manager) (start-connection-manager)))
+
+   (define listener (tcp-listen port (web-server-max-waiting) #t))
+   (define listener-control (make-channel))
+   (thread (lambda ()
+             (let loop ()
+               (sync (handle-evt (tcp-accept-evt listener)
+                                 (lambda (ports)
+                                   (connection-thread port cm ports)
+                                   (loop)))
+                     (handle-evt listener-control
+                                 (match-lambda
+                                   [(list 'quit k-ch)
+                                    (tcp-close listener)
+                                    (signal-background-activity! -1)
+                                    (channel-put k-ch (void))]))))))
+   (signal-background-activity! +1)
+
+   (on-start (log-syndicate/drivers/web-debug "Starting listener on port ~v" port))
+   (on-stop (define k-ch (make-channel))
+            (log-syndicate/drivers/web-debug "Stopping listener on port ~v" port)
+            (channel-put listener-control (list 'quit k-ch))
+            (channel-get k-ch)
+            (log-syndicate/drivers/web-debug "Stopped listener on port ~v" port))
+
+   (on (message (inbound (web-raw-request $id port $conn $addresses $lowlevel-req $control-ch)))
+       (spawn #:name (list 'http-request id)
+        (define root-facet (current-facet))
+
+        (define method
+          (string->symbol (string-downcase (bytes->string/latin-1 (request-method lowlevel-req)))))
+        (define resource (http-resource (req->http-server lowlevel-req port ssl?)
+                                        (url-path->resource-path
+                                         (url-path (request-uri lowlevel-req)))))
+
+        (assert (http-request id
+                              method
+                              resource
+                              (request-headers lowlevel-req)
+                              (url-query (request-uri lowlevel-req))
+                              (request-post-data/raw lowlevel-req)))
+
+        (for [(c (request-cookies lowlevel-req))]
+          (match-define (client-cookie n v d p) c)
+          (assert (http-request-cookie id n v d p)))
+
+        (match-let ([(list Lip Lport Rip Rport) addresses])
+          (assert (http-request-peer-details id Lip Lport Rip Rport)))
+
+        (define (respond! resp)
+          (match-define (http-response _ c m lms mime-type headers body) resp)
+          (define hs (build-headers headers))
+          (channel-put control-ch
+                       (list 'response
+                             (response/full c m lms mime-type hs (flatten body)))))
+
+        (define (respond/chunked! resp)
+          (match-define (http-response _ c m lms mime-type headers _) resp)
+          (define hs (build-headers headers))
+          (define stream-ch (make-async-channel))
+          (define (output-writer op)
+            (match (async-channel-get stream-ch)
+              [#f (void)]
+              [bss (for [(bs bss)] (write-bytes bs op))
+                   ;; (flush-output op) ;; seemingly does nothing. TODO
+                   (output-writer op)]))
+          (react (stop-when (retracted resp))
+                 (on-stop (async-channel-put stream-ch #f)
+                          (stop-facet root-facet))
+                 (on (message (http-response-chunk id $chunk))
+                     (async-channel-put stream-ch (flatten chunk)))
+                 (on-start (channel-put control-ch
+                                        (list 'response
+                                              (response c m lms mime-type hs output-writer))))))
+
+        (define (respond/websocket! headers)
+          (define ws-ch (make-channel))
+          (define hs (build-headers headers))
+          (react (stop-when (retracted (http-response-websocket id headers)))
+                 (on-start (channel-put control-ch (list 'websocket hs ws-ch)))
+                 (on-stop (channel-put ws-ch 'quit)
+                          (stop-facet root-facet))
+                 (on (message (websocket-out id $body))
+                     (define flat (flatten body))
+                     (define payload (cond [(null? flat) ""]
+                                           [(bytes? (car flat)) (bytes-append* flat)]
+                                           [(string? (car flat)) (string-append* flat)]
+                                           [else (error 'respond/websocket!
+                                                        "Bad payload: mixed content: ~v"
+                                                        flat)]))
+                     (channel-put ws-ch (list 'send payload)))
+                 (on (message (inbound (websocket-in id $body)))
+                     (if (eof-object? body)
+                         (stop-current-facet)
+                         (send! (websocket-in id body))))))
+
+        (field [respondent-exists? #f])
+        (on-start (for [(i 3)] (flush!)) ;; TODO: UGHHHH
+                  (when (not (respondent-exists?))
+                    (stop-facet root-facet
+                                (respond! (make-http-response #:code 404
+                                                              #:message #"Not found"
+                                                              id
+                                                              (xexpr->bytes/utf-8
+                                                               `(html (h1 "Not found"))))))))
+
+        (on (asserted (http-accepted id))
+            (respondent-exists? #t)
+            (react
+             (stop-when (retracted (http-accepted id))
+               (stop-facet root-facet
+                           (respond! (make-http-response #:code 500
+                                                         #:message #"Server error"
+                                                         id
+                                                         (xexpr->bytes/utf-8
+                                                          `(html (h1 "Server error")))))))
+             (stop-when (asserted ($ resp (http-response id _ _ _ _ _ $detail)))
+               (match detail
+                 ['chunked (respond/chunked! resp)]
+                 [_ (stop-facet root-facet (respond! resp))]))
+             (stop-when (asserted (http-response-websocket id $headers))
+               (respond/websocket! headers))))))))
+
+(define (req->http-server r port ssl?)
+  (match (assq 'host (request-headers r))
+    [#f
+     (http-server #f port ssl?)]
+    [(cons _ (regexp #px"(.*):(\\d+)" (list _ host port)))
+     (http-server host (string->number port) ssl?)]
+    [(cons _ host)
+     (http-server host port ssl?)]))
+
+(define (connection-thread listen-port cm connection-ports)
+  (signal-background-activity! +1)
+  (thread
+   (lambda ()
+     (match-define (list i o) connection-ports)
+     ;; Deliberately construct an empty custodian for the connection. Killing the connection
+     ;; abruptly can cause deadlocks since the connection thread communicates with Syndicate
+     ;; via synchronous channels.
+     (define conn
+       (new-connection cm (web-server-initial-connection-timeout) i o (make-custodian) #f))
+     (define addresses
+       (let-values (((Lip Lport Rip Rport) (tcp-addresses i #t)))
+         (list Lip Lport Rip Rport)))
+     (define control-ch (make-channel))
+     (let do-request ()
+       (define-values (req should-close?)
+         (with-handlers ([exn:fail? (lambda (e) (values #f #f))])
+           (read-request conn listen-port tcp-addresses)))
+       (when req
+         (define id (gensym 'web))
+         (ground-send! (inbound (web-raw-request id listen-port conn addresses req control-ch)))
+         (sync (handle-evt control-ch
+                           (match-lambda
+                             [(list 'websocket reply-headers ws-ch)
+                              (with-handlers ((exn:dispatcher?
+                                               (lambda (_e)
+                                                 (define resp
+                                                   (response/full 400
+                                                                  #"Bad request"
+                                                                  (current-seconds)
+                                                                  #"text/plain"
+                                                                  (list)
+                                                                  (list)))
+                                                 (output-response/method conn
+                                                                         resp
+                                                                         (request-method req))
+                                                 (drain-ws-ch! ws-ch))))
+                                ((make-general-websockets-dispatcher
+                                  (websocket-connection-main id ws-ch)
+                                  (lambda _args (values reply-headers (void))))
+                                 conn req))]
+                             [(list 'response resp)
+                              (output-response/method conn resp (request-method req))
+                              (when (not should-close?)
+                                (do-request))])))))
+     (with-handlers ([exn:fail? (lambda (e) (values #f #f))]) (close-input-port i))
+     (with-handlers ([exn:fail? (lambda (e) (values #f #f))]) (close-output-port o))
+     (signal-background-activity! -1))))
+
+(define ((websocket-connection-main id ws-ch) wsc _ws-connection-state)
+  (define quit-seen? #f)
+  (define (shutdown!)
+    (ground-send! (inbound (websocket-in id eof)))
+    (with-handlers ([(lambda (e) #t)
+                     (lambda (e) (log-syndicate/drivers/web-error
+                                  "Unexpected ws-close! error: ~a"
+                                  (if (exn? e)
+                                      (exn->string e)
+                                      (format "~v" e))))])
+      (ws-close! wsc)))
+  (with-handlers [(exn:fail:network? (lambda (e) (shutdown!)))
+                  (exn:fail:port-is-closed? (lambda (e) (shutdown!)))
+                  (exn:fail? (lambda (e)
+                               (log-syndicate/drivers/web-error "Unexpected websocket error: ~a"
+                                                                (exn->string e))
+                               (shutdown!)))]
+    (let loop ()
+      (sync (handle-evt (ws-recv-evt wsc #:payload-type 'auto)
+                        (lambda (msg)
+                          (ground-send! (inbound (websocket-in id msg)))
+                          (loop)))
+            (handle-evt ws-ch (match-lambda
+                                ['quit
+                                 (set! quit-seen? #t)
+                                 (void)]
+                                [(list 'send m)
+                                 (ws-send! wsc m #:payload-type (if (bytes? m) 'binary 'text))
+                                 (loop)]))))
+    (ws-close! wsc))
+  (when (not quit-seen?)
+    (drain-ws-ch! ws-ch)))
+
+(define (drain-ws-ch! ws-ch)
+  (when (not (equal? (channel-get ws-ch) 'quit))
+    (drain-ws-ch! ws-ch)))
+
+;; D-:  uck barf
+;; TODO: something to fix this :-/
+(define (exn:fail:port-is-closed? e)
+  (and (exn:fail? e)
+       (regexp-match #px"port is closed" (exn-message e))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(begin-for-declarations
+  (define-struct-defaults make-http-response http-response
+    (#:code [http-response-code 200]
+     #:message [http-response-message #"OK"]
+     #:last-modified-seconds [http-response-last-modified-seconds (current-seconds)]
+     #:mime-type [http-response-mime-type #"text/html"]
+     #:headers [http-response-headers '()]))
+  (define-struct-defaults make-http-response-websocket http-response-websocket
+    (#:headers [http-response-websocket-headers '()])))
+
+(define (xexpr->bytes/utf-8 #:preamble [preamble #"<!DOCTYPE html>"] xexpr)
+  (bytes-append preamble (string->bytes/utf-8 (xexpr->string xexpr))))

imperative/event-expander.rkt

@@ -0,0 +1,23 @@
+#lang racket/base
+
+(require auxiliary-macro-context)
+
+(define-auxiliary-macro-context
+  #:context-name event-expander
+  #:prop-name prop:event-expander
+  #:prop-predicate-name event-expander?
+  #:prop-accessor-name event-expander-proc
+  #:macro-definer-name define-event-expander
+  #:introducer-parameter-name current-event-expander-introducer
+  #:local-introduce-name syntax-local-event-expander-introduce
+  #:expander-id-predicate-name event-expander-id?
+  #:expander-transform-name event-expander-transform)
+
+(provide (for-syntax
+          prop:event-expander
+          event-expander?
+          event-expander-proc
+          syntax-local-event-expander-introduce
+          event-expander-id?
+          event-expander-transform)
+         define-event-expander)

imperative/examples/box-and-client.rkt

@@ -0,0 +1,21 @@
+#lang imperative-syndicate
+;; Simple mutable box and count-to-infinity box client.
+
+(message-struct set-box (new-value))
+(assertion-struct box-state (value))
+
+(spawn (field [current-value 0])
+       (assert (box-state (current-value)))
+       (stop-when-true (= (current-value) 10)
+                       (log-info "box: terminating"))
+       (on (message (set-box $new-value))
+           (log-info "box: taking on new-value ~v" new-value)
+           (current-value new-value)))
+
+(spawn (stop-when (retracted (observe (set-box _)))
+                  (log-info "client: box has gone"))
+       (on (asserted (box-state $v))
+           (log-info "client: learned that box's value is now ~v" v)
+           (send! (set-box (+ v 1))))
+       (on (retracted (box-state _))
+           (log-info "client: box state disappeared")))

imperative/examples/chat-client.rkt

@@ -0,0 +1,34 @@
+#lang imperative-syndicate
+
+(require/activate imperative-syndicate/drivers/tcp)
+(require/activate imperative-syndicate/drivers/external-event)
+(require/activate imperative-syndicate/reassert)
+(require (only-in racket/port read-bytes-line-evt))
+
+(spawn (define id 'chat)
+       (define root-facet (current-facet))
+
+       (reassert-on (tcp-connection id (tcp-address "localhost" 5999))
+                    (retracted (tcp-accepted id))
+                    (asserted (tcp-rejected id _)))
+
+       (on (asserted (tcp-rejected id $reason))
+           (printf "*** ~a\n" (exn-message reason)))
+
+       (during (tcp-accepted id)
+         (on-start (printf "*** Connected.\n")
+                   (issue-credit! tcp-in id))
+         (on (retracted (tcp-accepted id)) (printf "*** Remote EOF.\n"))
+         ;; ^ Not on-stop, because the facet is stopped by local EOF too!
+
+         (on (message (tcp-in-line id $bs))
+             (write-bytes bs)
+             (newline)
+             (flush-output)
+             (issue-credit! tcp-in id))
+
+         (define stdin-evt (read-bytes-line-evt (current-input-port) 'any))
+         (on (message (inbound (external-event stdin-evt (list $line))))
+             (if (eof-object? line)
+                 (stop-facet root-facet (printf "*** Local EOF. Terminating.\n"))
+                 (send! (tcp-out id (bytes-append line #"\n")))))))

imperative/examples/chat-server-nested-dataspace.rkt

@@ -0,0 +1,29 @@
+#lang imperative-syndicate
+
+(require/activate imperative-syndicate/drivers/tcp)
+(require racket/format)
+
+(message-struct speak (who what))
+(assertion-struct present (who))
+
+(dataspace
+ (spawn #:name 'chat-server
+        (during/spawn (inbound (tcp-connection $id (tcp-listener 5999)))
+          #:name (list 'chat-connection id)
+          (assert (outbound (tcp-accepted id)))
+          (on-start (send! (outbound (credit (tcp-listener 5999) 1)))
+                    (send! (outbound (credit tcp-in id 1))))
+          (let ((me (gensym 'user)))
+            (assert (present me))
+            (on (message (inbound (tcp-in-line id $bs)))
+                (match bs
+                  [#"/quit" (stop-current-facet)]
+                  [#"/stop-server" (quit-dataspace!)]
+                  [_ (send! (speak me (bytes->string/utf-8 bs)))
+                     (send! (outbound (credit tcp-in id 1)))])))
+          (during (present $user)
+            (on-start (send! (outbound (tcp-out id (string->bytes/utf-8 (~a user " arrived\n"))))))
+            (on-stop  (send! (outbound (tcp-out id (string->bytes/utf-8 (~a user " left\n"))))))
+            (on (message (speak user $text))
+                (send!
+                 (outbound (tcp-out id (string->bytes/utf-8 (~a user " says '" text "'\n"))))))))))

imperative/examples/chat-server.rkt

@@ -0,0 +1,30 @@
+#lang imperative-syndicate
+
+(require/activate imperative-syndicate/drivers/tcp)
+(require racket/format)
+
+(message-struct speak (who what))
+(assertion-struct present (who))
+
+(message-struct stop-server ())
+
+(spawn #:name 'chat-server
+       (stop-when (message (stop-server)))
+       (during/spawn (tcp-connection $id (tcp-listener 5999))
+         #:name (list 'chat-connection id)
+         (assert (tcp-accepted id))
+         (on-start (issue-credit! (tcp-listener 5999))
+                   (issue-credit! tcp-in id))
+         (let ((me (gensym 'user)))
+           (assert (present me))
+           (on (message (tcp-in-line id $bs))
+               (issue-credit! tcp-in id)
+               (match bs
+                 [#"/quit" (stop-current-facet)]
+                 [#"/stop-server" (send! (stop-server))]
+                 [_ (send! (speak me (bytes->string/utf-8 bs)))])))
+         (during (present $user)
+           (on-start (send! (tcp-out id (string->bytes/utf-8 (~a user " arrived\n")))))
+           (on-stop  (send! (tcp-out id (string->bytes/utf-8 (~a user " left\n")))))
+           (on (message (speak user $text))
+               (send! (tcp-out id (string->bytes/utf-8 (~a user " says '" text "'\n"))))))))

imperative/examples/filesystem.rkt

@@ -0,0 +1,31 @@
+#lang imperative-syndicate
+
+(require/activate imperative-syndicate/drivers/external-event)
+(require/activate imperative-syndicate/drivers/filesystem)
+(require racket/file)
+
+(require (only-in racket/port read-bytes-line-evt))
+(require (only-in racket/string string-trim string-split))
+
+(spawn #:name 'monitor-shell
+       (define e (read-bytes-line-evt (current-input-port) 'any))
+       (on (message (inbound (external-event e (list $line))))
+           (match line
+             [(? eof-object?)
+              (stop-current-facet (send! (list "close" 'all)))]
+             [(? bytes? command-bytes)
+              (send! (string-split (string-trim (bytes->string/utf-8 command-bytes))))])))
+
+(spawn #:name 'monitor-opener
+
+       (define (monitor name reader-proc)
+         (spawn #:name (list 'monitor name)
+                (stop-when (message (list "close" 'all))) ;; old-syndicate version used wildcard
+                (stop-when (message (list "close" name)))
+                (on (asserted (file-content name reader-proc $data))
+                    (log-info "~a: ~v" name data))))
+
+       (on (message (list "open" $name)) (monitor name file->bytes))
+
+       ;; The driver can track directory "contents" just as well as files.
+       (on (message (list "opendir" $name)) (monitor name directory-list)))

imperative/examples/gl-2d-basic.rkt

@@ -0,0 +1,133 @@
+#lang imperative-syndicate
+
+(require racket/set)
+(require 2htdp/image)
+(require/activate imperative-syndicate/drivers/gl-2d)
+
+(define (spawn-background)
+  (spawn (during (window $width $height)
+           (assert-scene `((push-matrix (scale ,width ,(* height 2))
+                                        (translate 0 -0.25)
+                                        (texture
+                                         ,(overlay/xy (rectangle 1 1 "solid" "white")
+                                                      0 0
+                                                      (rectangle 1 2 "solid" "black"))))
+                           ;; (rotate -30)
+                           ;; (scale 5 5)
+                           )
+                         `()))))
+
+(define (draggable-mixin touching? x y)
+  (define (idle)
+    (react (stop-when #:when (touching?)
+                      (message (mouse-event 'left-down (mouse-state $mx $my _ _ _)))
+                      (log-info "idle -> dragging; in-script? ~v" (in-script?))
+                      (dragging (- mx (x)) (- my (y))))))
+
+  (define (dragging dx dy)
+    (react (on (message (mouse-event 'motion (mouse-state $mx $my _ _ _)))
+               (x (- mx dx))
+               (y (- my dy)))
+           (stop-when (message (mouse-event 'left-up _)) (idle))
+           (stop-when (message (mouse-event 'leave _)) (idle))))
+
+  (idle))
+
+(define (draggable-shape name orig-x orig-y z plain-image hover-image
+                         #:coordinate-map-id [coordinate-map-id #f]
+                         #:parent [parent-id #f])
+  (spawn (field [x orig-x] [y orig-y])
+         (define/query-value touching? #f (touching name) #t)
+         (assert (simple-sprite #:parent parent-id
+                                #:coordinate-map-id coordinate-map-id
+                                #:touchable-id name
+                                #:touchable-predicate in-unit-circle?
+                                z (x) (y) 50 50
+                                (if (touching?)
+                                    hover-image
+                                    plain-image)))
+         (on-start (draggable-mixin touching? x y))))
+
+(define (tooltip touching? x y w h label-string)
+  (define label-text (text label-string 22 "black"))
+  (define label (overlay label-text (empty-scene (+ (image-width label-text) 10)
+                                                 (+ (image-height label-text) 10))))
+  (define (pos)
+    (define v (- (x) (image-width label) 10))
+    (if (negative? v)
+        (+ (x) w 10)
+        v))
+  (react (assert #:when (touching?)
+                 (simple-sprite -10
+                                (pos)
+                                (+ (y) (* 1/2 h) (- (* 1/2 (image-height label))))
+                                (image-width label)
+                                (image-height label)
+                                label))))
+
+(define (spawn-player-avatar)
+  (local-require 2htdp/planetcute)
+  (define CC character-cat-girl)
+
+  (spawn (field [x 100] [y 100])
+         (assert (simple-sprite #:touchable-id 'player
+                                #:coordinate-map-id 'player
+                                -0.5 (x) (y) (image-width CC) (image-height CC) CC))
+
+         (field [keys-down (set)])
+         (on (asserted (key-pressed $k)) (keys-down (set-add (keys-down) k)))
+         (on (retracted (key-pressed $k)) (keys-down (set-remove (keys-down) k)))
+         (define (key->delta k distance) (if (set-member? (keys-down) k) distance 0))
+
+         (define/query-value touching? #f (touching 'player) #t)
+         (on-start (draggable-mixin touching? x y))
+
+         (on (asserted (coordinate-map 'player $xform))
+             ;; TODO: figure out why this causes lag in frame updates
+             (log-info "Player coordinate map: ~v" xform))
+
+         (on-start (tooltip touching? x y (image-width CC) (image-height CC) "The Player"))
+
+         (on (message (frame-event _ _ $elapsed-ms _))
+             (define-values (old-x old-y) (values (x) (y)))
+             (define distance (* 0.360 elapsed-ms))
+             (define nx (+ old-x (key->delta 'right distance) (key->delta 'left (- distance))))
+             (define ny (+ old-y (key->delta 'down distance) (key->delta 'up (- distance))))
+             (when (not (and (= nx old-x) (= ny old-y)))
+               (x nx)
+               (y ny)))))
+
+(define (spawn-frame-counter)
+  (spawn (field [i empty-image])
+         (assert (simple-sprite -10 300 10 (image-width (i)) (image-height (i)) (i)))
+         (on (message (frame-event $counter $sim-time-ms _ _))
+             (when (> sim-time-ms 0)
+               (define fps (/ counter (/ sim-time-ms 1000.0)))
+               (i (text (format "~a fps" fps) 22 "black"))))))
+
+(spawn-keyboard-integrator)
+(spawn-mouse-integrator)
+(spawn-background)
+;; (spawn-frame-counter)
+(spawn-player-avatar)
+
+(draggable-shape 'orange 50 50 0
+                 (circle 50 "solid" "orange")
+                 (circle 50 "solid" "red"))
+
+(draggable-shape 'yellow 10 -10 0 #:parent 'orange
+                 (circle 50 "solid" "yellow")
+                 (circle 50 "solid" "purple"))
+
+(draggable-shape 'green 60 60 -1
+                 (circle 50 "solid" "green")
+                 (circle 50 "solid" "cyan"))
+
+(spawn* (until (message (key-event #\q #t _)))
+        (assert! (gl-control 'stop)))
+
+(spawn (during (touching $id)
+               (on-start (log-info "Touching ~v" id))
+               (on-stop (log-info "No longer touching ~v" id))))
+
+(spawn-gl-2d-driver)

imperative/examples/gl-2d-clock-face.rkt

@@ -0,0 +1,87 @@
+#lang imperative-syndicate
+;; Compare to "ezd" clock-face example from: J. F. Bartlett, “Don’t
+;; Fidget with Widgets, Draw!,” Palo Alto, California, DEC WRL
+;; Research Report 91/6, May 1991.
+
+(require lang/posn)
+(require 2htdp/image)
+(require (only-in racket/math pi))
+(require racket/date)
+
+(require/activate imperative-syndicate/drivers/gl-2d)
+
+(define hand
+  (polygon (list (make-posn 0 0)
+                 (make-posn 30 10)
+                 (make-posn 100 0)
+                 (make-posn 30 -10))
+           "solid"
+           "black"))
+
+(define (fmod a b)
+  (- a (* b (truncate (/ a b)))))
+
+(define (hand-sprite id layer angle-field length)
+  (sprite #:id id layer `((translate 100 100)
+                          (rotate ,(fmod (- 90 (angle-field)) 360))
+                          (scale ,length ,(/ length 5))
+                          (translate 0 -0.5)
+                          (touchable ,id ,in-unit-square?)
+                          (texture ,hand))))
+
+(define (text-sprite layer x y content)
+  (define i (text content 24 "green"))
+  (simple-sprite layer x y (image-width i) (image-height i) i))
+
+(spawn (field [minute-angle 0]
+              [hour-angle 0]
+              [start-time (current-inexact-milliseconds)]
+              [elapsed-seconds 0]
+              [displacement (let ((now (current-date)))
+                              (* 6 (+ (* 60 (date-hour now))
+                                      (date-minute now))))])
+
+       (assert (simple-sprite 10 0 0 200 200 (circle 100 "solid" "blue")))
+       (assert (hand-sprite 'minute 9 minute-angle 95))
+       (assert (text-sprite 8 40 40 "time"))
+       (assert (text-sprite 8 110 80 "drifts"))
+       (assert (text-sprite 8 40 120 "by"))
+       (assert (hand-sprite 'hour 7 hour-angle 65))
+       (assert (simple-sprite 6 95 95 10 10 (circle 5 "solid" "black")))
+
+       (define (respond-to-drags id scale)
+         (define/query-value touching? #f (touching id) #t)
+         (on #:when (touching?) (message (mouse-event 'left-down (mouse-state $mx $my _ _ _)))
+             (start-time #f)
+             (elapsed-seconds 0)
+             (update-displacement! mx my scale)
+             (react (stop-when (message (mouse-event 'left-up _)))
+                    (stop-when (message (mouse-event 'leave _)))
+                    (on-stop (start-time (current-inexact-milliseconds)))
+                    (on (message (mouse-event 'motion (mouse-state $mx $my _ _ _)))
+                        (update-displacement! mx my scale)))))
+
+       (define (update-displacement! mx my scale)
+         (define angle (- 90 (* (/ 180 pi) (atan (- 100 my) (- mx 100)))))
+         (define delta0 (fmod (- (* scale angle) (displacement)) 360))
+         (define delta (if (<= delta0 -180) (+ delta0 360) delta0))
+         (displacement (+ (displacement) delta)))
+
+       (respond-to-drags 'minute 1)
+       (respond-to-drags 'hour 12)
+
+       (begin/dataflow
+         (define angle (+ (/ (elapsed-seconds) 1000 10) (displacement)))
+         (minute-angle angle)
+         (hour-angle (/ angle 12)))
+
+       (on (message (frame-event _ _ _ _))
+           (when (start-time)
+             (elapsed-seconds (- (current-inexact-milliseconds) (start-time)))))
+
+       (on (message (key-event #\q #t _))
+           (send! (gl-control 'stop))))
+
+(spawn-gl-2d-driver #:label "Syndicate Clock"
+                    #:width 200
+                    #:height 200)

imperative/examples/gl-2d-many.rkt

@@ -0,0 +1,84 @@
+#lang imperative-syndicate
+;; Multiple animated sprites.
+;;
+;; 2018-05-01 With the new "imperative" implementation of Syndicate,
+;; the same 2.6GHz laptop mentioned below can animate 135 logos in a
+;; 640x480 window at 60 fps on a single core, with a bit of headroom
+;; to spare.
+;;
+;; 2016-12-12 With the current implementations of (a) Syndicate's
+;; dataspaces and (b) Syndicate's 2D sprite support, my reasonably new
+;; 2.6GHz laptop can animate 20 logos at 256x256 pixels at about 20
+;; frames per second on a single core.
+;;
+;; For comparison, Kay recounts in "The Early History of Smalltalk"
+;; (1993) that "by the Fall of '73 [Steve Purcell] could demo 80
+;; ping-pong balls and 10 flying horses running at 10 frames per
+;; second in 2 1/2 D" in an early Smalltalk (?) on a NOVA.
+
+(require 2htdp/image)
+(require images/logos)
+(require/activate imperative-syndicate/drivers/gl-2d)
+
+(define speed-limit 40)
+(define sprite-count 135)
+
+(define (spawn-background)
+  (spawn
+   (during (window $width $height)
+     (assert-scene `((push-matrix (scale ,width ,height)
+                                  (texture ,(rectangle 1 1 "solid" "white"))))
+                   `()))))
+
+(define i:logo (plt-logo))
+(define i:logo-width (image-width i:logo))
+(define i:logo-height (image-height i:logo))
+
+(define (spawn-logo)
+  (spawn (field [x 100] [y 100])
+         (field [dx (* (- (random) 0.5) speed-limit)]
+                [dy (* (- (random) 0.5) speed-limit)])
+         (define/query-value w #f ($ w (window _ _)) w)
+         (assert (simple-sprite 0
+                                (x)
+                                (y)
+                                i:logo-width
+                                i:logo-height
+                                i:logo))
+         (define (bounce f df limit)
+           (define v (f))
+           (define limit* (- limit i:logo-width))
+           (cond [(< v 0) (f 0) (df (abs (df)))]
+                 [(> v limit*) (f limit*) (df (- (abs (df))))]
+                 [else (void)]))
+         (on (message (frame-event _ _ _ _))
+             (when (w) ;; don't animate until we know the window bounds
+               (x (+ (x) (dx)))
+               (y (+ (y) (dy)))
+               (bounce x dx (window-width (w)))
+               (bounce y dy (window-height (w)))))))
+
+(spawn-background)
+(for [(i sprite-count)]
+  (spawn-logo))
+
+(spawn (define start-time #f)
+       (log-info "Sprite count: ~a" sprite-count)
+       (on (message (frame-event $counter $timestamp _ _))
+           (if (eq? start-time #f)
+               (set! start-time (current-inexact-milliseconds))
+               (let ((delta (- (current-inexact-milliseconds) start-time)))
+                 (when (and (zero? (modulo counter 100)) (positive? delta))
+                   (log-info "~v frames, ~v ms ==> ~v Hz"
+                             counter
+                             delta
+                             (/ counter (/ delta 1000.0))))))))
+
+(spawn-gl-2d-driver)
+
+(spawn (field [fullscreen? #f])
+       (on (message (key-event #\f #t _)) (fullscreen? (not (fullscreen?))))
+       (assert #:when (fullscreen?) (gl-control 'fullscreen))
+
+       (on (message (key-event #\q #t _))
+           (send! (gl-control 'stop))))

imperative/examples/gl-2d-platformer.rkt

@@ -0,0 +1,825 @@
+#lang imperative-syndicate
+
+(require 2htdp/image)
+(require 2htdp/planetcute)
+
+(require racket/set)
+(require plot/utils) ;; for vector utilities
+
+(require (only-in racket/string string-prefix?))
+(require (only-in racket/gui/base play-sound))
+
+(require/activate imperative-syndicate/drivers/timer)
+(require/activate imperative-syndicate/drivers/gl-2d)
+(require imperative-syndicate/bag)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Layers:
+;;
+;; - External I/O
+;;   as arranged by syndicate-gl/2d
+;;   including keyboard events, interface to rendering, and frame timing
+;;
+;; - Ground
+;;   corresponds to computer itself
+;;   device drivers
+;;   applications (e.g. in this instance, the game)
+;;
+;; - Game
+;;   running application
+;;   per-game state, such as score and count-of-deaths
+;;   process which spawns levels
+;;   regular frame ticker
+;;
+;; - Level
+;;   model of the game world
+;;   actors represent entities in the world, mostly
+;;   misc actors do physicsish things
+;;
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; ## Common Data Definitions
+;;
+;; A Vec is a (vector Number Number)
+;; A Point is a (vector Number Number)
+;; (See vector functions in plot/utils)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; ## Ground Layer Protocols
+
+;;-------------------------------------------------------------------------
+;; ### Scene Management
+;;     - assertion: ScrollOffset
+;;     - assertion: OnScreenDisplay
+;;     - role: SceneManager
+;;         Displays the scene backdrop and adjusts display coordinates via ScrollOffset.
+;;
+;; A ScrollOffset is a (scroll-offset Vec), indicating the vector to *subtract*
+;; from world coordinates to get device coordinates.
+(struct scroll-offset (vec) #:transparent)
+;;
+;; An OnScreenDisplay is an (on-screen-display Number Number (Seal Image)),
+;; representing an item to display in a fixed window-relative position
+;; above the scrolled part of the scene. If the coordinates are
+;; positive, they measure right/down from the left/top of the image;
+;; if negative, they measure left/up from the right/bottom.
+(struct on-screen-display (x y sealed-image) #:transparent)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; ## Game Layer Protocols
+
+;;-------------------------------------------------------------------------
+;; ### Scoring
+;;     - message: AddToScore
+;;     - assertion: CurrentScore
+;;     - role: ScoreKeeper
+;;         Maintains the score as private state.
+;;         Publishes the score using a CurrentScore.
+;;         Responds to AddToScore by updating the score.
+;;
+;; An AddToScore is an (add-to-score Number), a message
+;; which signals a need to add the given number to the player's
+;; current score.
+(struct add-to-score (delta) #:transparent)
+;;
+;; A CurrentScore is a (current-score Number), an assertion
+;; indicating the player's current score.
+(struct current-score (value) #:transparent)
+
+;;-------------------------------------------------------------------------
+;; ### Level Spawning
+;;     - assertion: LevelRunning
+;;     - message: LevelCompleted
+;;     - role: LevelSpawner
+;;         Maintains the current level number as private state.
+;;         Spawns a new Level when required.
+;;         Monitors LevelRunning - when it drops, the level is over.
+;;         Receives LevelCompleted messages. If LevelRunning drops without
+;;         a LevelCompleted having arrived, the level ended in failure and
+;;         should be restarted. If LevelComplete arrived before LevelRunning
+;;         dropped, the level was completed successfully, and the next level
+;;         should be presented.
+;;     - role: Level
+;;         Running level instance. Maintains LevelRunning while it's still
+;;         going. Sends LevelCompleted if the player successfully completed
+;;         the level.
+;;
+;; A LevelRunning is a (level-running), an assertion indicating that the
+;; current level is still in progress.
+(struct level-running () #:transparent)
+;;
+;; A LevelCompleted is a (level-completed), a message indicating that
+;; the current level was *successfully* completed before it terminated.
+(struct level-completed () #:transparent)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; ## Level Layer Protocols
+
+;;-------------------------------------------------------------------------
+;; ### Movement and Physics
+;;     - message: JumpRequest
+;;     - assertion: Impulse
+;;     - assertion: Position
+;;     - assertion: GamePieceConfiguration
+;;     - assertion: Touching
+;;     - role: PhysicsEngine
+;;         Maintains positions, velocities and accelerations of all GamePieces.
+;;         Uses GamePieceConfiguration for global properties of pieces.
+;;         Publishes Position to match.
+;;         Listens to FrameDescription, using it to advance the simulation.
+;;         Considers only mobile GamePieces for movement.
+;;         Takes Impulses as the baseline for moving GamePieces around.
+;;         For massive mobile GamePieces, applies gravitational acceleration.
+;;         Computes collisions between GamePieces.
+;;         Uses Attributes of GamePieces to decide what to do in response to collisions.
+;;         For 'touchable GamePieces, a Touching row is asserted.
+;;         Responds to JumpRequest by checking whether the named piece is in a
+;;         jumpable location, and sets its upward velocity negative if so.
+;;     - role: GamePiece
+;;         Maintains private state. Asserts Impulse to move around,
+;;         and GamePieceConfiguration to get things started. May issue
+;;         JumpRequests at any time. Represents both the player,
+;;         enemies, the goal(s), and platforms and blocks in the
+;;         environment. Asserts a Sprite two layers out to render
+;;         itself.
+;;
+;; An ID is a Symbol; the special symbol 'player indicates the player's avatar.
+;; Gensyms from (gensym 'enemy) name enemies, etc.
+;;
+;; A JumpRequest is a (jump-request ID), a message indicating a *request* to jump,
+;; not necessarily honoured by the physics engine.
+(struct jump-request (id) #:transparent)
+;;
+;; An Impulse is an (impulse ID Vec), an assertion indicating a contribution to
+;; the net *requested* velocity of the given gamepiece.
+(struct impulse (id vec) #:transparent)
+;;
+;; A Position is a (position ID Point Vec), an assertion describing
+;; the current actual top-left corner and (physics-related, not
+;; necessarily graphics-related) size of the named gamepiece.
+(struct position (id top-left size) #:transparent)
+;;
+;; An Attribute is either
+;;  - 'player - the named piece is a player avatar
+;;  - 'touchable - the named piece reacts to the player's touch
+;;  - 'solid - the named piece can be stood on / jumped from
+;;  - 'mobile - the named piece is not fixed in place
+;;  - 'massive - the named piece is subject to effects of gravity
+;;               (it is an error to be 'massive but not 'mobile)
+;;
+;; A GamePieceConfiguration is a
+;;  - (game-piece-configuration ID Point Vec (Set Attribute))
+;; an assertion specifying not only the *existence* of a named
+;; gamepiece, but also its initial position and size and a collection
+;; of its Attributes.
+(struct game-piece-configuration (id initial-position size attributes) #:transparent)
+;;
+;; A Touching is a
+;;  - (touching ID ID Side)
+;; an assertion indicating that the first ID is touching the second on
+;; the named side of the second ID.
+(struct touching (a b side) #:transparent)
+;;
+;; A Side is either 'top, 'left, 'right, 'bottom or the special value
+;; 'mid, indicating an unknown or uncomputable side.
+
+(define (game-piece-has-attribute? g attr)
+  (set-member? (game-piece-configuration-attributes g) attr))
+
+;;-------------------------------------------------------------------------
+;; ### Player State
+;;     - message: Damage
+;;     - assertion: Health
+;;     - role: Player
+;;         Maintains hitpoints, which it reflects using Health.
+;;         Responds to Damage.
+;;         When hitpoints drop low enough, removes the player from the board.
+;;
+;; A Damage is a (damage ID Number), a message indicating an event that should
+;; consume the given number of health points of the named gamepiece.
+(struct damage (id hit-points) #:transparent)
+;;
+;; A Health is a (health ID Number), an assertion describing the current hitpoints
+;; of the named gamepiece.
+(struct health (id hit-points) #:transparent)
+
+;;-------------------------------------------------------------------------
+;; ### World State
+;;     - assertion: LevelSize
+;;     - role: DisplayControl
+;;         Maintains a LevelSize assertion.
+;;         Observes the Position of the player, and computes and maintains a
+;;         ScrollOffset two layers out, to match.
+;;         Also kills the player if they wander below the bottom of the level.
+;;
+;; A LevelSize is a (level-size Vec), an assertion describing the right-hand and
+;; bottom edges of the level canvas (in World coordinates).
+(struct level-size (vec) #:transparent)
+
+;; -----------
+;; Interaction Diagrams (to be refactored into the description later)
+;;
+;; ================================================================================
+;;
+;; title Jump Sequence
+;;
+;; Player -> Physics: (jump 'player)
+;; note right of Physics: Considers the request.
+;; note right of Physics: Denied -- Player is not on a surface.
+;;
+;; Player -> Physics: (jump 'player)
+;; note right of Physics: Considers the request.
+;; note right of Physics: Accepted.
+;; note right of Physics: Updates velocity, position
+;; Physics -> Subscribers: (vel 'player ...)
+;; Physics -> Subscribers: (pos 'player ...)
+;;
+;;
+;; ================================================================================
+;;
+;; title Display Control Updates
+;;
+;; Physics -> DisplayCtl: (pos 'player ...)
+;; note right of DisplayCtl: Compares player pos to level size
+;; DisplayCtl -> Subscribers: (inbound (inbound (scroll-offset ...)))
+;;
+;; ================================================================================
+;;
+;; title Movement Sequence
+;;
+;; Moveable -> Physics: (mobile ID Boolean)
+;; Moveable -> Physics: (attr ID ...)
+;; Moveable -> Physics: (impulse ID vec)
+;; note right of Physics: Processes simulation normally
+;; Physics -> Subscribers: (pos ID ...)
+;; Physics -> Subscribers: (vel ID ...)
+;;
+;; ================================================================================
+;;
+;; title Keyboard Interpretation
+;;
+;; Keyboard -> Player: (press right-arrow)
+;; Player -->> Physics: assert (impulse ID (vec DX 0))
+;;
+;; note right of Physics: Processes simulation normally
+;;
+;; Keyboard -> Player: (press left-arrow)
+;; Player -->> Physics: assert (impulse ID (vec 0 0))
+;;
+;; Keyboard -> Player: (release right-arrow)
+;; Player -->> Physics: assert (impulse ID (vec -DX 0))
+;;
+;; Keyboard -> Player: (press space)
+;; Player -> Physics: (jump)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Icon
+
+(struct icon (pict scale hitbox-width-fraction hitbox-height-fraction baseline-fraction)
+  #:transparent)
+
+(define (icon-width i) (* (image-width (icon-pict i)) (icon-scale i)))
+(define (icon-height i) (* (image-height (icon-pict i)) (icon-scale i)))
+(define (icon-hitbox-width i) (* (icon-width i) (icon-hitbox-width-fraction i)))
+(define (icon-hitbox-height i) (* (icon-height i) (icon-hitbox-height-fraction i)))
+(define (icon-hitbox-size i) (vector (icon-hitbox-width i) (icon-hitbox-height i)))
+
+(define (focus->top-left i x y)
+  (vector (- x (/ (icon-hitbox-width i) 2))
+          (- y (icon-hitbox-height i))))
+
+(define (icon-sprite i layer pos)
+  (match-define (vector x y) pos)
+  (simple-sprite layer
+                 (- x (/ (- (icon-width i) (icon-hitbox-width i)) 2))
+                 (- y (- (* (icon-baseline-fraction i) (icon-height i)) (icon-hitbox-height i)))
+                 (icon-width i)
+                 (icon-height i)
+                 (icon-pict i)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; SceneManager
+
+(define (spawn-scene-manager)
+  (spawn #:name 'scene-manager
+         (define backdrop (rectangle 1 1 "solid" "white"))
+
+         (define/query-value size (vector 0 0) (window $x $y) (vector x y))
+         (define/query-set osds ($ o (on-screen-display _ _ _)) o)
+         (define/query-value offset (vector 0 0) (scroll-offset $v) v)
+
+         (field [fullscreen? #f])
+         (assert #:when (fullscreen?) (gl-control 'fullscreen))
+         (on (message (key-event #\f #t _))
+             (fullscreen? (not (fullscreen?))))
+
+         (define (compute-backdrop)
+           (match-define (vector width height) (size))
+           (match-define (vector ofs-x ofs-y) (offset))
+           (define osd-blocks
+             (for/list [(osd (in-set (osds)))]
+               (match-define (on-screen-display raw-x raw-y (seal i)) osd)
+               (define x (if (negative? raw-x) (+ width raw-x) raw-x))
+               (define y (if (negative? raw-y) (+ height raw-y) raw-y))
+               `(push-matrix (translate ,x ,y)
+                             (scale ,(image-width i) ,(image-height i))
+                             (texture ,i))))
+           (scene (seal `((push-matrix
+                           (scale ,width ,height)
+                           (texture ,backdrop))
+                          (translate ,(- ofs-x) ,(- ofs-y))))
+                  (seal `((translate ,ofs-x ,ofs-y)
+                          ,@osd-blocks))))
+         (assert (compute-backdrop))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; ScoreKeeper
+
+(define (spawn-score-keeper)
+  (spawn #:name 'score-keeper
+         (field [score 0])
+         (assert (current-score (score)))
+         (assert (outbound
+                  (on-screen-display -150 10
+                                     (seal (text (format "Score: ~a" (score)) 24 "white")))))
+         (on (message (add-to-score $delta))
+             (score (+ (score) delta))
+             (log-info "Score increased by ~a to ~a" delta (score))
+             (play-sound-sequence 270304))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; PhysicsEngine
+
+(define impulse-multiplier 0.360) ;; 360 pixels per second
+(define jump-vel (vector 0 -2))
+(define gravity 0.004)
+
+(define (spawn-physics-engine)
+  (spawn #:name 'physics-engine
+   (field [configs (hash)]
+          [previous-positions (hash)]
+          [previous-velocities (hash)]
+          [positions (hash)]
+          [velocities (hash)])
+
+   (during (game-piece-configuration $id $initial-position $size $attrs)
+           (on-start (configs
+                      (hash-set (configs) id
+                                (game-piece-configuration id initial-position size attrs))))
+           (on-stop (configs (hash-remove (configs) id))
+                    (positions (hash-remove (positions) id))
+                    (velocities (hash-remove (velocities) id)))
+           (assert (position id (hash-ref (positions) id initial-position) size)))
+
+   (define/query-hash impulses (impulse $id $vec) id vec)
+
+   (define (piece-cfg id) (hash-ref (configs) id))
+   (define (piece-pos which id)
+     (hash-ref (which) id (lambda () (game-piece-configuration-initial-position (piece-cfg id)))))
+   (define (piece-vel which id) (hash-ref (which) id (lambda () (vector 0 0))))
+   (define (piece-imp id) (hash-ref (impulses) id (lambda () (vector 0 0))))
+
+   (define (update-piece! g new-pos new-vel)
+     (positions (hash-set (positions) (game-piece-configuration-id g) new-pos))
+     (velocities (hash-set (velocities) (game-piece-configuration-id g) new-vel)))
+
+   (define (find-support p size which-pos)
+     (match-define (vector p-left p-top) p)
+     (match-define (vector p-w p-h) size)
+     (define p-right (+ p-left p-w))
+     (define p-bottom (+ p-top p-h))
+     (for/or [((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'solid)]
+       (match-define (vector left top) (piece-pos which-pos id))
+       (and (< (abs (- top p-bottom)) 0.5)
+            (<= left p-right)
+            (match (game-piece-configuration-size g)
+              [(vector w h)
+               (<= p-left (+ left w))])
+            g)))
+
+   (define (segment-intersection-time p0 r q0 q1)
+     ;; See http://stackoverflow.com/a/565282/169231
+     ;; Enhanced to consider the direction of impact with the segment,
+     ;; too: only returns an intersection when the vector of motion is
+     ;; at an obtuse angle to the normal of the segment.
+     (define s (v- q1 q0))
+     (define rxs (vcross2 r s))
+     (cond [(< (abs rxs) 0.005) #f] ;; zeroish; lines are parallel (and maybe collinear)
+           [else
+            (define q-p (v- q0 p0))
+            (define q-pxs (vcross2 q-p s))
+            (define t (/ q-pxs rxs))
+            (and (<= 0 t 1)
+                 (let* ((q-pxr (vcross2 q-p r))
+                        (u (/ q-pxr rxs)))
+                   (and (< 0 u 1)
+                        (let* ((q-norm
+                                (vnormalize (vector (vector-ref s 1) (- (vector-ref s 0))))))
+                          (and (not (positive? (vdot r q-norm)))
+                               (- t 0.001))))))]))
+
+   (define (three-corners top-left size)
+     (match-define (vector w h) size)
+     (values (v+ top-left (vector w 0))
+             (v+ top-left size)
+             (v+ top-left (vector 0 h))))
+
+   (define (clip-movement-by top-left moved-top-left size solid-top-left solid-size)
+     (define-values (solid-top-right solid-bottom-right solid-bottom-left)
+       (three-corners solid-top-left solid-size))
+     (define-values (top-right bottom-right bottom-left)
+       (three-corners top-left size))
+     (define r (v- moved-top-left top-left))
+     (define t
+       (apply min
+              (for/list [(p (in-list (list #;top-left #;top-right bottom-right bottom-left)))]
+                (min (or (segment-intersection-time p r solid-top-left solid-top-right) 1)
+                     ;; TODO: some means of specifying *which edges* should appear solid.
+                     #;(or (segment-intersection-time p r solid-top-right solid-bottom-right) 1)
+                     #;(or (segment-intersection-time p r solid-bottom-right solid-bottom-left) 1)
+                     #;(or (segment-intersection-time p r solid-bottom-left solid-top-left) 1)))))
+     (v+ top-left (v* r t)))
+
+   (define (clip-movement-by-solids p0 p1 size)
+     (for/fold [(p1 p1)]
+               [((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'solid)]
+       (clip-movement-by p0 p1 size
+                         (piece-pos previous-positions id)
+                         (game-piece-configuration-size g))))
+
+   (define (touched-during-movement? TL moved-TL size touchable-TL touchable-size)
+     (define r (v- moved-TL TL))
+     (if (positive? (vmag^2 r)) ;; r is nonzero, in other words
+         (let ()
+           (define-values (touchable-TR touchable-BR touchable-BL)
+             (three-corners touchable-TL touchable-size))
+           (define-values (TR BR BL)
+             (three-corners TL size))
+           (for/or [(p (in-list (list TL TR BR BL)))]
+             (or
+              (and (segment-intersection-time p r touchable-TR touchable-BR) 'right)
+              (and (segment-intersection-time p r touchable-BR touchable-BL) 'bottom)
+              (and (segment-intersection-time p r touchable-BL touchable-TL) 'left)
+              (and (segment-intersection-time p r touchable-TL touchable-TR) 'top))))
+         (let ()
+           (match-define (vector left top) TL)
+           (match-define (vector touchable-left touchable-top) touchable-TL)
+           (match-define (vector width height) size)
+           (match-define (vector touchable-width touchable-height) touchable-size)
+           (and (<= left (+ touchable-left touchable-width))
+                (<= top (+ touchable-top touchable-height))
+                (<= touchable-left (+ left width))
+                (<= touchable-top (+ top height))
+                'mid))))
+
+   (define (touchables-touched-during-movement p0 p1 size)
+     (for/fold [(ts '())]
+               [((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'touchable)]
+       (define side (touched-during-movement? p0 p1 size
+                                              (piece-pos previous-positions id)
+                                              (game-piece-configuration-size g)))
+       (if side (cons (cons side g) ts) ts)))
+
+   (define (update-game-piece! elapsed-ms id)
+     (define g (piece-cfg id))
+     (define size (game-piece-configuration-size g))
+     (define pos0 (piece-pos previous-positions id))
+     (define support (find-support pos0 size previous-positions))
+
+     (define vel0 (piece-vel previous-velocities id))
+     (define imp0 (piece-imp id))
+
+     (define vel1 (cond
+                    [(and support (not (negative? (vector-ref vel0 1))))
+                     (piece-vel previous-velocities (game-piece-configuration-id support))]
+                    [(game-piece-has-attribute? g 'massive)
+                     (v+ vel0 (vector 0 (* gravity elapsed-ms)))]
+                    [else
+                     vel0]))
+
+     (define pos1 (v+ pos0 (v* (v+ vel1 imp0) (* impulse-multiplier elapsed-ms))))
+     (define final-pos (clip-movement-by-solids pos0 pos1 size))
+     ;; TODO: figure out how to cancel just the component of velocity blocked by the obstacle(s)
+     ;; - which will avoid the "sticking to the wall" artifact
+     (define final-vel (if (v= pos1 final-pos) vel1 (vector 0 0))) ;; stop at collision
+     (define touchables (touchables-touched-during-movement pos0 final-pos size))
+
+     (for [(a (in-bag (current-adhoc-assertions)))]
+       (when (touching? a)
+         (retract! a +inf.0)))
+     (for [(t touchables)]
+       (match-define (cons side tg) t)
+       (assert! (touching id (game-piece-configuration-id tg) side)))
+     (update-piece! g final-pos final-vel))
+
+   (on (message (jump-request $id))
+       (define g (piece-cfg id))
+       (define pos (piece-pos positions id))
+       (when (find-support pos (game-piece-configuration-size g) positions)
+         (play-sound-sequence 270318)
+         (update-piece! g pos jump-vel)))
+
+   (define start-time #f)
+   (on (message (inbound (inbound (frame-event $counter _ _ _))))
+       (let ((stop-time (current-inexact-milliseconds)))
+         (when (not (eq? start-time #f))
+           (define elapsed-ms (- stop-time start-time))
+           (when (zero? (modulo counter 10))
+             (log-info "Instantaneous frame rate at frame ~a: ~a Hz"
+                       counter
+                       (/ 1000.0 elapsed-ms)))
+           (previous-positions (positions))
+           (previous-velocities (velocities))
+           (for [((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'mobile)]
+             (update-game-piece! elapsed-ms id)))
+         (set! start-time stop-time)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Player
+
+(define player-id 'player)
+(define planetcute-scale 1/2)
+
+(define (spawn-player-avatar initial-focus-x initial-focus-y)
+  (spawn #:name 'player-avatar
+   (define i (icon character-cat-girl planetcute-scale 2/6 3/10 13/16))
+   (define initial-top-left (focus->top-left i initial-focus-x initial-focus-y))
+
+   (assert (game-piece-configuration player-id
+                                     initial-top-left
+                                     (icon-hitbox-size i)
+                                     (set 'player 'mobile 'massive)))
+
+   (define/query-value pos initial-top-left (position player-id $hitbox-top-left _)
+     hitbox-top-left)
+   (assert (outbound (outbound (icon-sprite i 0 (pos)))))
+
+   (field [hit-points 1])
+   (assert (health player-id (hit-points)))
+   (stop-when-true (<= (hit-points) 0))
+   (on (message (damage player-id $amount))
+       (hit-points (- (hit-points) amount)))
+
+   (on (asserted (inbound (inbound (key-pressed #\space)))) (send! (jump-request player-id)))
+   (on (asserted (inbound (inbound (key-pressed #\.))))     (send! (jump-request player-id)))
+
+   (define/query-set keys-down (inbound (inbound (key-pressed $k))) k)
+   (define (any-key-down? . ks) (for/or [(k ks)] (set-member? (keys-down) k)))
+   (assert (impulse player-id (vector (+ (if (any-key-down? 'left 'prior) -1 0)
+                                         (if (any-key-down? 'right 'next) 1 0))
+                                      0)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Ground Block
+
+(define (spawn-ground-block top-left size #:color [color "purple"])
+  (spawn #:name (list 'ground-block top-left size color)
+         (match-define (vector x y) top-left)
+         (match-define (vector w h) size)
+         (define block-id (gensym 'ground-block))
+         (define block-pict (rectangle w h "solid" color))
+         (assert (outbound (outbound (simple-sprite 0 x y w h block-pict))))
+         (assert (game-piece-configuration block-id
+                                            top-left
+                                            size
+                                            (set 'solid)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Goal piece
+;;
+;; When the player touches a goal, sends LevelCompleted one layer out.
+
+(define (spawn-goal-piece initial-focus-x initial-focus-y)
+  (define goal-id (gensym 'goal))
+
+  (define i (icon key planetcute-scale 1/3 2/5 4/5))
+  (define initial-top-left (focus->top-left i initial-focus-x initial-focus-y))
+
+  (spawn #:name (list 'goal-piece initial-focus-x initial-focus-y)
+         (on (asserted (touching player-id goal-id _))
+             (send! (outbound (level-completed))))
+         (assert (game-piece-configuration goal-id
+                                           initial-top-left
+                                           (icon-hitbox-size i)
+                                           (set 'touchable)))
+         (assert (outbound (outbound (icon-sprite i -1 initial-top-left))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Enemy
+
+(define (spawn-enemy initial-x initial-y range-lo range-hi
+                     #:speed [speed 0.2]
+                     #:facing [initial-facing 'right])
+  (spawn #:name (list 'enemy initial-x initial-y initial-facing)
+   (define enemy-id (gensym 'enemy))
+   (define i (icon enemy-bug planetcute-scale 9/10 1/3 5/6))
+   (define i-flipped (struct-copy icon i [pict (flip-horizontal (icon-pict i))]))
+   (define initial-top-left (focus->top-left i initial-x initial-y))
+   (match-define (vector width height) (icon-hitbox-size i))
+
+   (assert (game-piece-configuration enemy-id
+                                     initial-top-left
+                                     (icon-hitbox-size i)
+                                     (set 'mobile 'massive 'touchable)))
+
+   (define/query-value current-level-size #f (level-size $v) v)
+
+   (define/query-value pos initial-top-left (position enemy-id $top-left _) top-left
+     #:on-add (match-let (((vector left top) top-left))
+                (facing (cond [(< left range-lo) 'right]
+                              [(> (+ left width) range-hi) 'left]
+                              [else (facing)]))))
+
+   (stop-when-true (and (current-level-size)
+                        (> (vector-ref (pos) 1)
+                           (vector-ref (current-level-size) 1))))
+
+   (field [facing initial-facing])
+   (assert (outbound (outbound
+                      (icon-sprite (match (facing) ['right i] ['left i-flipped]) -1 (pos)))))
+
+   (assert (impulse enemy-id (vector (* speed (match (facing) ['right 1] ['left -1])) 0)))
+
+   (stop-when (asserted (touching player-id enemy-id 'top))
+              (play-sound-sequence 270325)
+              (send! (outbound (add-to-score 1))))
+
+   (on (asserted (touching player-id enemy-id $side))
+       (when (not (eq? side 'top)) (send! (damage player-id 1))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; DisplayControl
+
+(define (spawn-display-controller level-size-vec)
+  (match-define (vector level-width level-height) level-size-vec)
+
+  (spawn #:name 'display-controller
+   (field [offset-pos (vector 0 0)])
+   (assert (outbound (outbound (scroll-offset (offset-pos)))))
+   (assert (level-size level-size-vec))
+
+   (define/query-value window-size-vec #f (inbound (inbound (window $w $h))) (vector w h))
+
+   (define (compute-offset pos viewport limit)
+     (min (max 0 (- pos (/ viewport 2))) (- limit viewport)))
+
+   (on (asserted (position player-id (vector $px $py) _))
+       (when (window-size-vec)
+         (match-define (vector ww wh) (window-size-vec))
+         (when (> py level-height) (send! (damage player-id +inf.0)))
+         (offset-pos (vector (compute-offset px ww level-width)
+                             (compute-offset py wh level-height)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; LevelTerminationMonitor
+;;
+;; When the player vanishes from the board, or LevelCompleted is seen,
+;; kills the dataspace.
+
+(define (wait-for-level-termination)
+  (spawn #:name 'wait-for-level-termination
+   (assert (outbound (level-running)))
+   (on (retracted (game-piece-configuration player-id _ _ _))
+       (log-info "Player died! Terminating level.")
+       (play-sound-sequence 270328)
+       (quit-dataspace!))
+   (on (message (inbound (level-completed)))
+       (log-info "Level completed! Terminating level.")
+       (play-sound-sequence 270330)
+       (send! (outbound (add-to-score 100)))
+       (quit-dataspace!))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; LevelSpawner
+
+(define (spawn-background-image level-size scene)
+  (match-define (vector level-width level-height) level-size)
+  (define scene-width (image-width scene))
+  (define scene-height (image-height scene))
+  (define level-aspect (/ level-width level-height))
+  (define scene-aspect (/ scene-width scene-height))
+  (define scale (if (> level-aspect scene-aspect) ;; level is wider, proportionally, than scene
+                    (/ level-width scene-width)
+                    (/ level-height scene-height)))
+  (spawn #:name 'background-image
+         (assert (outbound
+                  (outbound
+                   (sprite 10
+                           `((scale ,(* scene-width scale)
+                                    ,(* scene-height scale))
+                             (texture ,scene))))))))
+
+;; http://www.travelization.net/wp-content/uploads/2012/07/beautiful-grassland-wallpapers-1920x1080.jpg
+(define grassland-backdrop (bitmap "../../examples/platformer/beautiful-grassland-wallpapers-1920x1080.jpg"))
+
+(define (spawn-level #:initial-player-x [initial-player-x 50]
+                     #:initial-player-y [initial-player-y 50]
+                     #:level-size [level-size-vec (vector 4000 2000)]
+                     #:scene [scene grassland-backdrop]
+                     actions-thunk)
+  (lambda ()
+    (dataspace #:name 'level-dataspace
+               (when scene (spawn-background-image level-size-vec scene))
+               (spawn-display-controller level-size-vec)
+               (spawn-physics-engine)
+               (spawn-player-avatar initial-player-x initial-player-y)
+               (actions-thunk)
+               (wait-for-level-termination))))
+
+(define standard-ground-height 50)
+
+(define (slab left top width #:color [color "purple"])
+  (spawn-ground-block (vector left top) (vector width standard-ground-height) #:color color))
+
+(define levels
+  (list
+   (spawn-level (lambda ()
+                  (slab 25 125 100)
+                  (slab 50 300 500)
+                  (spawn-enemy 100 300 50 550)
+                  (spawn-enemy 300 300 50 550 #:facing 'left)
+                  (spawn-goal-piece 570 150)
+                  (slab 850 300 50)
+                  (slab 925 400 50)
+                  (slab 975 500 50)
+                  (slab 975 600 50)
+                  (slab 500 600 150 #:color "orange")))
+   (spawn-level (lambda ()
+                  (slab 25 300 500)
+                  (slab 500 400 500)
+                  (slab 1000 500 400)
+                  (spawn-goal-piece 1380 500)))
+   (spawn-level (lambda ()
+                  (slab 25 300 1000)
+                  (spawn-enemy 600 300 25 1025 #:facing 'left)
+                  (spawn-goal-piece 980 300)))
+   (spawn-level (lambda ()
+                  (spawn-goal-piece 250 280)
+                  (spawn-enemy 530 200 400 600)
+                  (spawn-enemy 500 200 -100 1000 #:facing 'left)
+                  (slab 400 200 200)
+                  (spawn-ground-block (vector 200 280) (vector 200 200) #:color "orange")
+                  (slab 25 300 500)
+                  (slab 600 1300 600)
+                  (slab 1150 1200 25 #:color "red")
+                  (for/list ((n 10))
+                    (slab 900 (+ 200 (* n 100)) 50)))
+                )
+   ))
+
+(define (spawn-numbered-level level-number)
+  (if (< level-number (length levels))
+      ((list-ref levels level-number))
+      (spawn #:name 'victory-message
+             (assert (outbound
+                      (let ((message (text "You won!" 72 "red")))
+                        (simple-sprite 0
+                                       10
+                                       100
+                                       (image-width message)
+                                       (image-height message)
+                                       message)))))))
+
+(define (spawn-level-spawner starting-level)
+  (spawn #:name 'level-spawner
+         (field [current-level starting-level]
+                [level-complete? #f])
+
+         (on (message (level-completed)) (level-complete? #t))
+
+         (on (retracted (level-running))
+             (current-level (if (level-complete?) (+ (current-level) 1) (current-level)))
+             (level-complete? #f)
+             (spawn-numbered-level (current-level)))
+
+         (on-start (spawn-numbered-level starting-level))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Sounds
+
+(require racket/runtime-path)
+(begin-for-declarations
+  (define-runtime-path sounds-path "../../examples/platformer/sounds"))
+(define (lookup-sound-file sound-number)
+  (define sought-prefix (build-path sounds-path (format "~a__" sound-number)))
+  (for/or [(filename (in-directory sounds-path))]
+    (and (string-prefix? (path->string filename) (path->string sought-prefix))
+         filename)))
+
+;; TODO: make this a sound driver...
+;; TODO: ...and make sound triggering based on assertions of game
+;; state, not hardcoding in game logic
+(define (play-sound-sequence . sound-numbers)
+  (thread (lambda ()
+            (for [(sound-number (in-list sound-numbers))]
+              (define sound-file (lookup-sound-file sound-number))
+              (play-sound sound-file #f)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(spawn-keyboard-integrator)
+(spawn-scene-manager)
+(spawn-gl-2d-driver #:width 600 #:height 400)
+(dataspace #:name 'game-dataspace
+           (spawn-score-keeper)
+           (spawn-level-spawner 0))

imperative/examples/gui/README.md

@@ -0,0 +1,22 @@
+# Simple GUI experiments using Syndicate
+
+This directory contains UI experiments using
+[Syndicate](http://syndicate-lang.org/) and its OpenGL 2D support.
+
+Files:
+
+ - `gui.rkt`: Main entry point. Run `racket gui.rkt` to run the demo.
+
+ - `layout/`: A simple widget layout engine, loosely inspired by TeX's boxes-and-glue model.
+
+     - `sizing.rkt`: TeX-like "dimensions", including "fills"
+
+     - `layout.rkt`: Uses "dimensions" to specify "table layouts",
+       which are then realized in terms of specified rectangle
+       coordinates
+
+ - `hsv.rkt`: Utility for converting HSV colors to RGB.
+
+Screenshot:
+
+![Syndicate GUI screenshot](syndicate-gui-snapshot.png)

imperative/examples/gui/gui.rkt

@@ -0,0 +1,662 @@
+#lang imperative-syndicate
+
+(require racket/set)
+(require data/order)
+(require srfi/19)
+(require (prefix-in i: 2htdp/image))
+(require (prefix-in p: pict))
+(require syndicate-gl/affine)
+(require "layout/main.rkt")
+(require "hsv.rkt")
+(require imperative-syndicate/bag)
+(require imperative-syndicate/pattern)
+
+(require/activate imperative-syndicate/drivers/gl-2d)
+
+;;---------------------------------------------------------------------------
+
+(define theme-font (make-parameter "Roboto"))
+(define theme-font-size (make-parameter 16))
+(define theme-title-font (make-parameter "Roboto Condensed"))
+(define theme-title-font-size (make-parameter 20))
+(define theme-title-font-color (make-parameter "white"))
+(define theme-title-bar-color (make-parameter (hsv->color 260 1 0.6)))
+(define theme-title-bar-selected-color (make-parameter (hsv->color 260 1 1)))
+(define theme-title-bar-height (make-parameter 48))
+(define theme-button-background-color (make-parameter (hsv->color 30 0.9 1)))
+(define theme-button-color (make-parameter "white"))
+(define theme-button-x-padding (make-parameter 40))
+(define theme-button-y-padding (make-parameter 24))
+(define theme-button-min-height (make-parameter 48))
+(define theme-window-border-width (make-parameter 8))
+(define theme-window-resize-corner-size (make-parameter 16))
+(define theme-menu-item-color (make-parameter "white"))
+(define theme-menu-item-background-color (make-parameter (hsv->color 240 1 0.8)))
+(define theme-menu-item-selected-background-color (make-parameter (hsv->color 345 1 1)))
+(define theme-menu-item-padding (make-parameter 16))
+(define theme-menu-separator-width (make-parameter 2))
+(define theme-menu-separator-color (make-parameter "white"))
+
+;;---------------------------------------------------------------------------
+
+(define (*width x)
+  (cond [(i:image? x) (i:image-width x)]
+        [(p:pict? x) (p:pict-width x)]
+        [else (error '*width "Neither an image nor a pict: ~v" x)]))
+
+(define (*height x)
+  (cond [(i:image? x) (i:image-height x)]
+        [(p:pict? x) (p:pict-height x)]
+        [else (error '*height "Neither an image nor a pict: ~v" x)]))
+
+(define (costume #:id [id #f] #:parent [parent-id #f] #:coordinate-map-id [coordinate-map-id #f] i)
+  (define iw (*width i))
+  (define ih (*height i))
+  (define iaspect (/ iw ih))
+  (lambda (z rect)
+    (match-define (rectangle left top sw sh) rect)
+    (define saspect (if (and (positive? sw) (positive? sh)) (/ sw sh) 1))
+    (define-values (scale-w scale-h translate-x translate-y)
+      (if (> saspect iaspect)
+          (let ((scale-h (/ sw iaspect)))
+            (values sw scale-h 0 (/ (- sh scale-h) 2)))
+          (let ((scale-w (* sh iaspect)))
+            (values scale-w sh (/ (- sw scale-w) 2) 0))))
+    (sprite #:id (or id (gensym 'costume))
+            #:parent parent-id
+            z
+            `((translate ,left ,top)
+              (push-matrix (scale ,sw ,sh)
+                           ,@(if id
+                                 `((touchable ,id ,in-unit-square?))
+                                 `())
+                           ,@(if coordinate-map-id
+                                 `((coordinate-map ,coordinate-map-id))
+                                 `())
+                           (texture ,i
+                                    ,(- (/ translate-x scale-w))
+                                    ,(- (/ translate-y scale-h))
+                                    ,(/ sw scale-w)
+                                    ,(/ sh scale-h)
+                                    ))
+              (render-children)))))
+
+(define (draggable-mixin touching? x y id-to-raise)
+  (define (idle)
+    (react (stop-when #:when (touching?)
+                      (message (mouse-event 'left-down (mouse-state $mx $my _ _ _)))
+                      (dragging (- mx (x)) (- my (y))))))
+
+  (define (dragging dx dy)
+    (when id-to-raise (send! (raise-widget id-to-raise)))
+    (react (on (message (mouse-event 'motion (mouse-state $mx $my _ _ _)))
+               (x (- mx dx))
+               (y (- my dy)))
+           (stop-when (message (mouse-event 'left-up _)) (idle))
+           (stop-when (message (mouse-event 'leave _)) (idle))))
+
+  (idle))
+
+(spawn #:name 'root-window
+       (define c (costume #:id 'root (i:bitmap "oakura-beach-20081225.jpg")))
+       (define/query-value touching? #f (touching 'root) #t)
+       (on #:when (touching?) (message (mouse-event 'right-down (mouse-state $x $y _ _ _)))
+           (send! (pop-up-menu-trigger 'system-menu x y 0 0.5 'right-up)))
+       ;; (during (window $width $height)
+       ;;   (assert-scene `((translate ,width 0) (rotate -90)) `())
+       ;;   (assert (desktop height width))
+       ;;   (assert (c 0 (rectangle 0 0 height width))))
+       (during (window $width $height)
+         (assert (desktop width height))
+         (assert (c 0 (rectangle 0 0 width height))))
+       )
+
+(define (button-underlay i)
+  (define w (+ (*width i) (theme-button-x-padding)))
+  (define h (max (+ (*height i) (theme-button-y-padding)) (theme-button-min-height)))
+  (i:rectangle w h "solid" (theme-button-background-color)))
+
+;;---------------------------------------------------------------------------
+;; Protocol: Layout.
+;;---------------------------------------------------------------------------
+;; Roles:
+;;
+;;  Layout Solver
+;;    Responds to assertions of interest in layout solutions by
+;;    computing layouts and asserting the resulting positions.
+;;
+;;      (Observe LayoutSolution)+ ==>
+;;        RequestedLayoutSize ==>
+;;          ComputedLayoutSize ∧ LayoutSolution+
+;;
+;;  Layout Observer
+;;    Supplies any initial constraints on the overall layout size,
+;;    and may observe the final overall computed layout size.
+;;
+;;      RequestedLayoutSize ∧ (ComputedLayoutSize ==> 1)?
+;;
+;;  Layout Participant
+;;    Supplies constraints on an individual item to be laid out
+;;    and monitors the resulting position decision for that item.
+;;
+;;      LayoutSolution ==> 1
+;;---------------------------------------------------------------------------
+
+;; A LayoutSpec is one of
+;;  - (horizontal-layout Any)
+;;  - (vertical-layout Any)
+;;  - (tabular-layout Nat Nat)
+;; where the first two use their keys for *ordering* peers relative to
+;; each other using datum-order, and the last uses the given row and
+;; column to place the item within an implicitly-sized grid layout.
+(struct horizontal-layout (key) #:transparent)
+(struct vertical-layout (key) #:transparent)
+(struct tabular-layout (row col) #:transparent)
+
+;; ASSERTION. A RequestedLayoutSize is a
+;; (requested-layout-size Any (Option (box-size (Option Sizing) (Option Sizing))))
+;; and describes overall constraints on the total size of the layout to be
+;; constructed. Supplying `size` as `#f` means that there is no constraint at all;
+;; otherwise, the `box-size` given is used as the exact dimensions of
+;; the layout, unless one or both of the dimensions of the `box-size`
+;; are given as `#f`, in which case there is no constraint for that
+;; dimension.
+(struct requested-layout-size (container-id size) #:transparent)
+
+;; ASSERTION. A ComputedLayoutSize is a
+;; (computed-layout-size Any BoxSize)
+;; and gives the concrete dimensions of the layout after layout
+;; computation has completed.
+(struct computed-layout-size (container-id size) #:transparent)
+
+;; ASSERTION. A LayoutSolution is a
+;; (layout-solution Any LayoutSpec BoxSize Rectangle)
+;; and denotes the computed bounds of a given item within a layout.
+;; TODO: introduce an item ID??
+(struct layout-solution (container-id
+                         spec
+                         size
+                         rectangle) #:transparent)
+
+;; ASSERTION. Describes the size of the desktop area.
+(struct desktop (width height) #:transparent)
+
+;;---------------------------------------------------------------------------
+
+(struct layout-item (spec size) #:transparent)
+
+(define (layout-item-spec-key li)
+  (define v (layout-item-spec li))
+  (if (number? v) (exact->inexact v) v))
+
+(spawn #:name 'layout-driver
+       (during/spawn (observe (layout-solution $container-id _ _ _))
+         #:name (list 'layout container-id)
+         (stop-when (asserted (observe (layout-solution container-id (horizontal-layout _) _ _)))
+           (react (solve-hv-layout #f container-id)))
+         (stop-when (asserted (observe (layout-solution container-id (vertical-layout _) _ _)))
+           (react (solve-hv-layout #t container-id)))
+         (stop-when (asserted (observe (layout-solution container-id (tabular-layout _ _) _ _)))
+           (react (solve-tabular-layout container-id)))))
+
+(define (solve-hv-layout vertical? container-id)
+  (field [items (set)])
+
+  (if vertical?
+      (query-set* items
+                  (observe (layout-solution container-id (vertical-layout $key) $size _))
+                  (layout-item key size))
+      (query-set* items
+                  (observe (layout-solution container-id (horizontal-layout $key) $size _))
+                  (layout-item key size)))
+
+  (define/dataflow ordered-items (sort (set->list (items))
+                                       (order-<? datum-order)
+                                       #:key layout-item-spec-key)
+    #:default '())
+
+  (define/dataflow table
+    (if vertical?
+        (map list (map layout-item-size (ordered-items)))
+        (list (map layout-item-size (ordered-items)))))
+
+  (solve-layout* container-id
+                 table
+                 (lambda (layout)
+                   (for [(item (ordered-items))
+                         (cell (if vertical? (map car layout) (car layout)))]
+                     (assert! (layout-solution container-id
+                                               (if vertical?
+                                                   (vertical-layout (layout-item-spec item))
+                                                   (horizontal-layout (layout-item-spec item)))
+                                               (layout-item-size item)
+                                               cell))))))
+
+(define (merge-box-size existing computed)
+  (match existing
+    [#f computed]
+    [(box-size h v)
+     (box-size (or h (box-size-horizontal computed))
+               (or v (box-size-vertical computed)))]))
+
+(define (solve-layout* container-id table on-layout)
+  (during (requested-layout-size container-id $reqsize)
+    (define/dataflow total-size (merge-box-size reqsize (table-sizing (table))))
+    (assert (computed-layout-size container-id (total-size)))
+    (define (total-width) (sizing-ideal (box-size-horizontal (total-size))))
+    (define (total-height) (sizing-ideal (box-size-vertical (total-size))))
+    (define/dataflow layout (table-layout (table) 0 0 (total-width) (total-height)) #:default '())
+    (begin/dataflow
+      (for [(a (in-bag (current-adhoc-assertions)))]
+        (match a
+          [(layout-solution (== container-id) _ _ _) (retract! a)]
+          [_ (void)]))
+      (on-layout (layout)))))
+
+(define (solve-tabular-layout container-id)
+  (define/query-set items
+    (observe (layout-solution container-id (tabular-layout $row $col) $size _))
+    (layout-item (cons row col) size))
+  (define/dataflow items-table
+    (let* ((specs (map layout-item-spec (set->list (items))))
+           (row-count (+ 1 (apply max -1 (map car specs))))
+           (col-count (+ 1 (apply max -1 (map cdr specs))))
+           (mtx (for/vector [(r row-count)] (make-vector col-count #f))))
+      (for [(item (items))]
+        (vector-set! (vector-ref mtx (car (layout-item-spec item)))
+                     (cdr (layout-item-spec item))
+                     item))
+      mtx))
+  (define/dataflow table
+    (for/list [(row (items-table))]
+      (for/list [(item row)]
+        (if item (layout-item-size item) weak-fill-box-size))))
+
+  (solve-layout* container-id
+                 table
+                 (lambda (layout)
+                   (define mtx (list->vector (map list->vector layout)))
+                   (for [(item (items))]
+                     (match-define (cons row col) (layout-item-spec item))
+                     (assert! (layout-solution container-id
+                                               (tabular-layout row col)
+                                               (layout-item-size item)
+                                               (vector-ref (vector-ref mtx row) col)))))))
+
+;;---------------------------------------------------------------------------
+
+;; TODO: Having pop-up-menu-trigger be a message means that it's not
+;; possible to cancel or move the menu once it has been triggered.
+;; Consider using the "start" button in the corner to pop up a menu,
+;; following which the screen is resized before the menu is dismissed.
+;; Currently, the menu will continue to float in an incorrect location
+;; rather than following the screen resize. If, however, the trigger
+;; for a menu was an assertion, then the menu could track changes in
+;; its triggering parameters and could be repositioned without fuss.
+
+(struct pop-up-menu-trigger (menu-id x y x-pin y-pin release-event) #:transparent)
+(struct menu-separator (menu-id order) #:transparent)
+(struct menu-item (menu-id order image message) #:transparent)
+
+(spawn #:name 'pop-up-menu-driver
+       (on (message (pop-up-menu-trigger $menu-id $x $y $x-pin $y-pin $release-event))
+           (run-pop-up-menu menu-id x y x-pin y-pin release-event)))
+
+(define (run-pop-up-menu menu-id pop-up-cursor-x pop-up-cursor-y x-pin y-pin release-event)
+  (define instance-id (list menu-id (gensym 'instance)))
+  (define pad (theme-menu-item-padding))
+  (define pad2 (* pad 2))
+  (define normal (i:rectangle 1 1 "solid" (theme-menu-item-background-color)))
+  (define highlight (i:rectangle 1 1 "solid" (theme-menu-item-selected-background-color)))
+  (define separator (i:rectangle 1 1 "solid" (theme-menu-separator-color)))
+  (spawn #:name instance-id
+         (assert (requested-layout-size instance-id #f))
+         (during (menu-item menu-id $order $sealed-image $msg)
+           (define item-id (gensym 'item))
+           (define im (seal-contents sealed-image))
+           (define imsize (box-size (sizing (+ pad2 (*width im)) 0 0)
+                                    (sizing (+ pad2 (*height im)) 0 0)))
+           (during (layout-solution instance-id (vertical-layout order) imsize $rect)
+             (match-define (rectangle left top width height) rect)
+             (assert (sprite #:id item-id #:parent instance-id
+                             0
+                             `((translate ,left ,top)
+                               (push-matrix
+                                (scale ,width ,height)
+                                (touchable (,instance-id ,item-id ,msg) ,in-unit-square?)
+                                (texture ,(if (eq? (selected-item) item-id) highlight normal)))
+                               (push-matrix
+                                (translate ,pad ,pad)
+                                (scale ,(*width im) ,(*height im))
+                                (texture ,im)))))))
+
+         (during (menu-separator menu-id $order)
+           (define sep-id (gensym 'sep))
+           (during (layout-solution instance-id (vertical-layout order)
+                                    (box-size weak-fill-sizing
+                                              (sizing (theme-menu-separator-width) 0 0))
+                                    $rect)
+             (match-define (rectangle left top width height) rect)
+             (assert (sprite #:id sep-id #:parent instance-id
+                             0
+                             `((translate ,left ,top)
+                               (scale ,width ,height)
+                               (texture ,separator))))))
+
+         (during (computed-layout-size instance-id $menu-size)
+           (match-define (box-size (sizing menu-width _ _) (sizing menu-height _ _)) menu-size)
+           (define offset-x (- pop-up-cursor-x (* x-pin (+ menu-width 2)) -1))
+           (define offset-y (- pop-up-cursor-y (* y-pin (+ menu-height 2)) -1))
+           (assert (sprite #:id instance-id
+                           -1
+                           `((translate ,offset-x ,offset-y)
+                             (render-children)))))
+
+         (define/query-value selected-item #f (touching `(,instance-id ,$i ,_)) i)
+         (define/query-value selected-msg #f (touching `(,instance-id ,_ ,$msg)) msg)
+         (stop-when (message (mouse-event release-event _))
+           (when (selected-item) (send! (selected-msg))))))
+
+;;---------------------------------------------------------------------------
+
+(define (system-text str [color #f])
+  (i:text/font str (theme-font-size) (or color "white")
+               (theme-font) 'default 'normal 'normal #f))
+
+(define (title-font-text str)
+  (i:text/font str (theme-title-font-size) (theme-title-font-color)
+               (theme-title-font) 'default 'normal 'normal #f))
+
+(define (menu-item/text menu-id order str message)
+  (menu-item menu-id order (seal (system-text str (theme-menu-item-color))) message))
+
+;;---------------------------------------------------------------------------
+
+(struct window-state (window-id title state) #:transparent)
+(struct raise-widget (id) #:transparent)
+(struct top-widget (id) #:transparent)
+
+(define close-icon-i
+  (parameterize ((theme-font-size (round (* 4/3 (theme-title-font-size)))))
+    (system-text "×" (theme-title-font-color))))
+
+(define (window-frame id title backdrop-color
+                      #:close-icon? [close-icon? #t]
+                      #:parent [parent-id 'root])
+  (define title-text-i (title-font-text title))
+  (define title-text-w (i:image-width title-text-i))
+  (define title-text-h (i:image-height title-text-i))
+  (define (title-bar-i focus?) (i:rectangle 1 1 "solid"
+                                            (if focus?
+                                                (theme-title-bar-selected-color)
+                                                (theme-title-bar-color))))
+  (define close-icon-w (i:image-width close-icon-i))
+  (define close-icon-h (i:image-height close-icon-i))
+  (define gap (/ (- (theme-title-bar-height) close-icon-w) 2))
+  (define backdrop (i:rectangle 1 1 "solid" backdrop-color))
+  (lambda (z rect focus?)
+    (match-define (rectangle left top width height) rect)
+    (sprite #:id id
+            #:parent parent-id
+            z
+            `((translate ,left ,top)
+              (push-matrix (translate ,(- (theme-window-border-width))
+                                      ,(- (theme-title-bar-height)))
+                           (scale ,(+ width (* 2 (theme-window-border-width)))
+                                  ,(+ height (theme-title-bar-height) (theme-window-border-width)))
+                           (touchable (,id window-backdrop) ,in-unit-square?)
+                           (texture ,(title-bar-i focus?)))
+              (push-matrix (translate 0 ,(- (theme-title-bar-height)))
+                           (scale ,width ,(theme-title-bar-height))
+                           (touchable (,id title-bar) ,in-unit-square?))
+              (push-matrix (translate ,(- (+ width (theme-window-border-width))
+                                          (theme-window-resize-corner-size))
+                                      ,(- (+ height (theme-window-border-width))
+                                          (theme-window-resize-corner-size)))
+                           (scale ,(theme-window-resize-corner-size)
+                                  ,(theme-window-resize-corner-size))
+                           (touchable (,id resize-corner) ,in-unit-square?))
+              ,@(if close-icon?
+                    `((push-matrix
+                       (translate ,gap ,(- (/ (+ (theme-title-bar-height) close-icon-h) 2)))
+                       (scale ,close-icon-w ,close-icon-h)
+                       (touchable (,id close-icon) ,in-unit-square?)
+                       (texture ,close-icon-i)))
+                    `())
+              (push-matrix (translate ,(/ (- width title-text-w) 2)
+                                      ,(- (/ (+ (theme-title-bar-height) title-text-h) 2)))
+                           (scale ,title-text-w ,title-text-h)
+                           (texture ,title-text-i))
+              (push-matrix (scale ,width ,height)
+                           (texture ,backdrop))
+              (render-children)))))
+
+(define (open-window window-id window-title x y width height [backdrop-color (hsv->color 200 1 1)]
+                     #:resizable? [resizable? #t])
+  (define c (window-frame window-id window-title backdrop-color))
+
+  (field [z (- (current-inexact-milliseconds))])
+  (define/query-value touching-title-bar?
+    #f (touching `(,window-id title-bar)) #t)
+  (on-start (draggable-mixin touching-title-bar? x y window-id))
+
+  (when resizable?
+    (define/query-value touching-resize-corner?
+      #f (touching `(,window-id resize-corner)) #t)
+    (on-start (draggable-mixin touching-resize-corner? width height window-id)))
+
+  (define/query-value touching-close-icon?
+    #f (touching `(,window-id close-icon)) #t)
+  (stop-when #:when (touching-close-icon?) (message (mouse-event 'left-up _)))
+
+  (on (message (raise-widget window-id))
+      (z (- (current-inexact-milliseconds))))
+
+  (define/query-value focus? #f (top-widget window-id) #t)
+
+  (define/dataflow bounds (rectangle (x) (y) (width) (height)) #:default zero-rectangle)
+  (assert (window-state window-id window-title (bounds)))
+  (assert (c (z) (bounds) (focus?))))
+
+(spawn #:name 'top-widget-monitor
+       (local-require data/heap)
+
+       (define *widget-heap* (make-heap (lambda (a b) (<= (cdr a) (cdr b)))))
+       (field [widget-heap-version 0])
+       (define (widget-heap) (begin (widget-heap-version) *widget-heap*)) ;; gross hack
+       ;; ^ this is to cope with the use of mutable data in a field.
+       ;; Field update only registers damage if the field *changes*, as detected by `equal?`.
+       (define (trigger-dependencies!) (widget-heap-version (+ (widget-heap-version) 1)))
+
+       (on (asserted (<sprite> $id 'root $z _))
+           (heap-add! (widget-heap) (cons id z))
+           (trigger-dependencies!))
+       (on (retracted (<sprite> $id 'root $z _))
+           (heap-remove! (widget-heap) (cons id z))
+           (trigger-dependencies!))
+
+       (assert #:when (positive? (heap-count (widget-heap)))
+               (top-widget (car (heap-min (widget-heap))))))
+
+;;---------------------------------------------------------------------------
+
+(struct button-click (id mouse-state) #:transparent)
+
+(begin-for-declarations
+  ;; TODO: figure out what it is about (define (f #:x x) x) that
+  ;; mandates begin-for-declarations to hide it from syndicate/lang's
+  ;; local-expansion here :-(
+  (define (pushbutton label-str x y [w #f] [h #f]
+                      #:shrink-x [shrink-x 0]
+                      #:id id
+                      #:coordinate-map-id [coordinate-map-id #f]
+                      #:parent parent-id
+                      #:trigger-event [trigger-event 'left-up])
+    (define label (system-text label-str (theme-button-color)))
+    (define i (i:overlay/align "middle" "middle" label (button-underlay label)))
+    (define c (costume #:id id #:parent parent-id #:coordinate-map-id coordinate-map-id i))
+
+    (define/query-value touching? #f (touching id) #t)
+    (on #:when (touching?) (message (mouse-event trigger-event $s))
+        (send! (button-click id s)))
+    (assert (c 0 (rectangle (x)
+                            (y)
+                            (or (and w (w)) (*width i))
+                            (or (and h (h)) (*height i)))))
+    (box-size (sizing (*width i) 0 (* shrink-x (*width i))) (sizing (*height i) 0 0))))
+
+;;---------------------------------------------------------------------------
+
+(define (enforce-minimum f v)
+  (begin/dataflow (when (< (f) v) (f v))))
+
+(begin-for-declarations
+  (define (message-box title init-x init-y body #:id id)
+    (define msg (system-text body))
+    (spawn #:name (list 'message-box id)
+           (field [x init-x]
+                  [y init-y]
+                  [width (max 250 (*width msg))]
+                  [height (max 100 (*height msg))])
+           (open-window id title x y width height #:resizable? #f)
+           (assert ((costume #:parent id msg)
+                    0
+                    (rectangle (/ (- (width) (*width msg)) 2)
+                               (/ (- (height) (*height msg)) 2)
+                               (*width msg)
+                               (*height msg)))))))
+
+(spawn #:name 'test-window
+
+       (field [x 140] [y 140] [width 400] [height 300])
+       (open-window 'w "Window Title" x y width height)
+       (enforce-minimum width 300)
+       (enforce-minimum height 300)
+
+       (assert (menu-item/text 'testmenu 0 "First item" '(testmenu first)))
+       (assert (menu-item/text 'testmenu 1 "Second item" '(testmenu second)))
+       (assert (menu-item/text 'testmenu 2 "Third item" '(testmenu third)))
+
+       (during (desktop $width $height)
+         (on (message `(testmenu ,$which))
+             (define box-id (gensym 'box))
+             (message-box #:id box-id
+                          (date->string (seconds->date (current-seconds))
+                                        "Selected at ~3")
+                          (random width) (random height)
+                          (format "~a" which))))
+
+       (pushbutton "Click me"
+                   (lambda () 100)
+                   (lambda () 100)
+                   #:id 'click-me #:parent 'w #:trigger-event 'left-down)
+       (on (message (button-click 'click-me (mouse-state $x $y _ _ _)))
+           (send! (pop-up-menu-trigger 'testmenu x y 0 0.5 'left-up))))
+
+;;---------------------------------------------------------------------------
+
+(spawn #:name 'fullscreen-menu-item
+       (field [fullscreen? #f])
+       (assert (menu-item/text 'system-menu -1
+                               (if (fullscreen?)
+                                   "Fullscreen ✓"
+                                   "Fullscreen")
+                               '(system-menu toggle-fullscreen)))
+       (assert (menu-separator 'system-menu -0.9))
+       (on (message '(system-menu toggle-fullscreen))
+           (fullscreen? (not (fullscreen?))))
+       (assert #:when (fullscreen?) (gl-control 'fullscreen)))
+
+(spawn #:name 'quit-menu-item
+       (assert (menu-item/text 'system-menu 0 "Quit" '(system-menu quit)))
+       (stop-when (message '(system-menu quit))
+         (send! (gl-control 'stop)))
+       (stop-when (message (key-event #\q #t _))
+         (send! (gl-control 'stop))))
+
+(spawn #:name 'toolbar
+
+       (field [window-width 0] [window-height 0])
+       (on (asserted (desktop $w $h))
+           (window-width w)
+           (window-height h))
+
+       (define pad 4) ;;(theme-menu-item-padding))
+       (define pad2 (* pad 2))
+
+       (assert (requested-layout-size 'toolbar (box-size (sizing (- (window-width) pad2) 0 0) #f)))
+       (assert (observe (layout-solution 'toolbar
+                                         (horizontal-layout '(0.0 0.0))
+                                         weak-fill-box-size
+                                         (discard))))
+
+       (during (computed-layout-size 'toolbar (box-size (sizing $w _ _) (sizing $h _ _)))
+         (assert (sprite #:id 'toolbar #:parent #f
+                         -0.5
+                         `((translate 0 ,(- (window-height) h pad2))
+                           (push-matrix (scale ,(window-width) ,(+ h pad2))
+                                        (touchable toolbar ,in-unit-square?)
+                                        (texture ,(i:rectangle 1 1 "solid" "black")))
+                           (translate ,pad ,pad)
+                           (render-children))))))
+
+(spawn #:name 'start-button
+       (field [x 0] [y 0])
+       (define reqsize
+         (parameterize ((theme-button-y-padding 8)
+                        (theme-button-min-height 0))
+           (pushbutton "Start" x y #:id 'start-button #:parent 'toolbar
+                       #:coordinate-map-id 'start-button
+                       #:trigger-event 'left-down)))
+       (during (layout-solution 'toolbar (horizontal-layout '(-10.0 0.0)) reqsize
+                                (rectangle $l $t $w $h))
+         (x l)
+         (y t)
+         (during (coordinate-map 'start-button $xform)
+           (on (message (button-click 'start-button _))
+               (define pt (- (transform-point xform 0+0i) 1+4i)) ;; padding + unoffset
+               (send!
+                (pop-up-menu-trigger 'system-menu (real-part pt) (imag-part pt) 0 1 'left-up))))))
+
+(spawn #:name 'window-list-monitor
+       (during/spawn (window-state $id $title _)
+         #:name (list 'window-list id)
+         (field [x 0] [y 0] [width #f] [height #f])
+         (define reqsize
+           (parameterize ((theme-button-y-padding 8)
+                          (theme-button-min-height 0)
+                          (theme-button-background-color (hsv->color 240 1 0.6)))
+             (pushbutton title x y width height #:id (list 'window-list id) #:parent 'toolbar
+                         #:shrink-x 1
+                         #:trigger-event 'left-down)))
+         (during (layout-solution 'toolbar (horizontal-layout `(-5.0 ,id)) reqsize
+                                  (rectangle $l $t $w $h))
+           (begin (x l) (y t) (width w) (height h))
+           (during (top-widget id)
+             (assert (sprite #:id (list 'window-list id 'highlight)
+                             #:parent (list 'window-list id)
+                             0
+                             `((translate 0 ,(- h 1))
+                               (scale ,w 1)
+                               (texture ,(i:rectangle 1 1 "solid" "white"))))))
+           (on (message (button-click (list 'window-list id) _))
+               (send! (raise-widget id))))))
+
+(spawn #:name 'clock
+       (field [now (current-seconds)])
+       (on (message (frame-event _ $timestamp _ _))
+           (define new (current-seconds))
+           (when (not (= new (now))) (now new)))
+       (define/dataflow now-im (system-text (date->string (seconds->date (now)) "~a ~b ~d, ~3"))
+         #:default i:empty-image)
+       (during (layout-solution 'toolbar (horizontal-layout '(10.0 0.0))
+                                (box-size (sizing (*width (now-im)) 0 0)
+                                          (sizing (*height (now-im)) 0 0))
+                                (rectangle $l $t $w $h))
+         (assert (sprite #:id 'clock #:parent 'toolbar
+                         0
+                         `((translate ,l ,(+ t (/ (- h (*height (now-im))) 2)))
+                           (scale ,(*width (now-im)) ,(*height (now-im)))
+                           (texture ,(now-im)))))))
+
+(spawn-gl-2d-driver)

imperative/examples/gui/hsv.rkt

@@ -0,0 +1,29 @@
+#lang racket/base
+
+(provide fmod
+         hsv->color
+         color-by-hash)
+
+(require 2htdp/image)
+
+(define (fmod a b)
+  (- a (* b (truncate (/ a b)))))
+
+(define (hsv->color h s v)
+  (define h* (fmod (/ h 60.0) 6))
+  (define chroma (* v s))
+  (define x (* chroma (- 1 (abs (- (fmod h* 2) 1)))))
+  (define-values (r g b)
+    (cond
+     [(< h* 1) (values chroma x 0)]
+     [(< h* 2) (values x chroma 0)]
+     [(< h* 3) (values 0 chroma x)]
+     [(< h* 4) (values 0 x chroma)]
+     [(< h* 5) (values x 0 chroma)]
+     [else     (values chroma 0 x)]))
+  (define m (- v chroma))
+  (define (scale x) (inexact->exact (truncate (* 255 (+ x m)))))
+  (make-color (scale r) (scale g) (scale b)))
+
+(define (color-by-hash v)
+  (hsv->color (* 360.0 (/ (bitwise-and (equal-hash-code v) 16777215) 16777216.0)) 1 1))

imperative/examples/gui/layout/layout.rkt

@@ -0,0 +1,191 @@
+#lang racket/base
+;; Tabular layout
+
+(provide table-sizing
+         table-layout)
+
+(require racket/match)
+(require "sizing.rkt")
+
+(module+ test (require rackunit))
+
+;;---------------------------------------------------------------------------
+
+(define (transpose rows)
+  (if (null? rows)
+      '()
+      (apply map list rows)))
+
+(define (swedish-round x)
+  (floor (+ x 1/2)))
+
+;;---------------------------------------------------------------------------
+
+(define (table-sizing box-sizes)
+  (box-size (sizing-sum (table-column-widths box-sizes))
+            (sizing-sum (table-row-heights box-sizes))))
+
+(define (table-row-heights box-sizes)
+  (map transverse-sizing (extract box-size-vertical box-sizes)))
+
+(define (table-column-widths box-sizes)
+  (map transverse-sizing (extract box-size-horizontal (transpose box-sizes))))
+
+(define (extract acc mtx)
+  (map (lambda (r) (map acc r)) mtx))
+
+(define (transverse-sizing sizings)
+  (define-values (lb-v lb-f) (transverse-bound sizings sizing-shrink - max))
+  (define-values (ub-v ub-f) (transverse-bound sizings sizing-stretch + min))
+  (let* ((ideal-v (foldl max 0 (map sizing-ideal sizings)))
+         (ideal-v (if ub-v (min ideal-v ub-v) ideal-v))
+         (ideal-v (if lb-v (max ideal-v lb-v) ideal-v)))
+    (sizing ideal-v
+            (if ub-v (- ub-v ideal-v) ub-f)
+            (if lb-v (- ideal-v lb-v) lb-f))))
+
+(define (transverse-bound sizings sizing-accessor minus-or-plus max-or-min)
+  (define vals (for/list [(s sizings) #:when (number? (sizing-accessor s))]
+                 (minus-or-plus (sizing-ideal s) (sizing-accessor s))))
+  (values (and (pair? vals) (apply max-or-min vals))
+          (foldl fill-max 0 (filter fill? (map sizing-accessor sizings)))))
+
+;;---------------------------------------------------------------------------
+
+(define (table-layout box-sizes top left width height #:round [round? #t])
+  (define row-sizings (table-row-heights box-sizes))
+  (define col-sizings (table-column-widths box-sizes))
+  (define row-heights (compute-concrete-adjacent-sizes row-sizings height))
+  (define col-widths (compute-concrete-adjacent-sizes col-sizings width))
+  (define local-round (if round? swedish-round values))
+  (define-values (_bot rows-rev)
+    (for/fold [(top top) (rows-rev '())] [(row-height row-heights)]
+      (define next-top (+ top row-height))
+      (define rounded-top (local-round top))
+      (define rounded-height (- (local-round next-top) rounded-top))
+      (define-values (_right cells-rev)
+        (for/fold [(left left) (cells-rev '())] [(col-width col-widths)]
+          (define next-left (+ left col-width))
+          (define rounded-left (local-round left))
+          (define rounded-width (- (local-round next-left) rounded-left))
+          (values next-left
+                  (cons (rectangle rounded-left
+                                   rounded-top
+                                   rounded-width
+                                   rounded-height)
+                        cells-rev))))
+      (values next-top
+              (cons (reverse cells-rev) rows-rev))))
+  (reverse rows-rev))
+
+(define (compute-concrete-adjacent-sizes sizings actual-bound)
+  (define ideal-total (foldl + 0 (map sizing-ideal sizings)))
+  (define-values (available-slop sizing-give apply-give)
+    (if (<= ideal-total actual-bound)
+        (values (- actual-bound ideal-total) sizing-stretch +)
+        (values (- ideal-total actual-bound) sizing-shrink -)))
+  (define total-give (foldl fill+ 0 (map sizing-give sizings)))
+  (if (number? total-give)
+      (let ((scale (if (zero? total-give) 0 (/ available-slop total-give))))
+        (map (lambda (s)
+               ;; numeric total-give ⇒ no fills for any give in the list
+               (apply-give (sizing-ideal s) (* (sizing-give s) scale)))
+             sizings))
+      (let* ((weight (fill-weight total-give))
+             (rank (fill-rank total-give))
+             (scale (if (zero? weight) 0 (/ available-slop weight))))
+        (map (lambda (s)
+               (match (sizing-give s)
+                 [(fill w (== rank)) (apply-give (sizing-ideal s) (* w scale))]
+                 [_ (sizing-ideal s)]))
+             sizings))))
+
+;;---------------------------------------------------------------------------
+
+(module+ test
+  (check-equal? (transpose '((1 2 3) (4 5 6) (7 8 9))) '((1 4 7) (2 5 8) (3 6 9)))
+  (check-equal? (swedish-round 0.1) 0.0)
+  (check-equal? (swedish-round 0.5) 1.0)
+  (check-equal? (swedish-round 0.9) 1.0)
+  (check-equal? (swedish-round 1.1) 1.0)
+  (check-equal? (swedish-round 1.5) 2.0)
+  (check-equal? (swedish-round 1.9) 2.0))
+
+(module+ test
+  (define s211 (sizing 2 1 1))
+  (define s0f0 (sizing 0 weak-fill 0))
+  (define b22 (box-size s211 s211))
+  (define b42 (box-size (sizing 4 1 1) s211))
+  (define b62 (box-size (sizing 6 1 1) s211))
+  (define b00 (box-size s0f0 s0f0))
+
+  (define t1 (list (list b22 b22 b00 b22)
+                   (list b22 b22 b00 b22)
+                   (list b22 b22 b00 b22)))
+
+  (define t2 (list (list b22 b22 b22)
+                   (list b22 b00 b22)
+                   (list b22 b22 b22)))
+
+  (define t3 (list (list b22 b42 b22)
+                   (list b22 b00 b22)
+                   (list b22 b22 b22)))
+
+  (define t4 (list (list b22 b62 b22)
+                   (list b22 b00 b22)
+                   (list b22 b22 b22)))
+
+  (check-equal? (table-sizing t1)
+                (box-size (sizing 6 weak-fill 3)
+                          (sizing 6 3 3)))
+
+  (check-equal? (table-sizing t2)
+                (box-size (sizing 6 3 3)
+                          (sizing 6 3 3)))
+
+  ;; Is this sane?
+  (check-equal? (table-sizing t3)
+                (box-size (sizing 7 2 2)
+                          (sizing 6 3 3)))
+
+  ;; Is this sane?
+  (check-equal? (table-sizing t4)
+                (box-size (sizing 9 0 2)
+                          (sizing 6 3 3)))
+
+  (check-equal? (table-layout t1 0 0 20 20)
+                (list (list (rectangle 0 0 2 7)
+                            (rectangle 2 0 2 7)
+                            (rectangle 4 0 14 7)
+                            (rectangle 18 0 2 7))
+                      (list (rectangle 0 7 2 6)
+                            (rectangle 2 7 2 6)
+                            (rectangle 4 7 14 6)
+                            (rectangle 18 7 2 6))
+                      (list (rectangle 0 13 2 7)
+                            (rectangle 2 13 2 7)
+                            (rectangle 4 13 14 7)
+                            (rectangle 18 13 2 7))))
+
+  (check-equal? (table-layout t2 0 0 20 20)
+                (list (list (rectangle 0 0 7 7)
+                            (rectangle 7 0 6 7)
+                            (rectangle 13 0 7 7))
+                      (list (rectangle 0 7 7 6)
+                            (rectangle 7 7 6 6)
+                            (rectangle 13 7 7 6))
+                      (list (rectangle 0 13 7 7)
+                            (rectangle 7 13 6 7)
+                            (rectangle 13 13 7 7))))
+
+  ;; Is this sane?
+  (check-equal? (table-layout t3 0 0 20 20)
+                (list (list (rectangle 0 0 9 7)
+                            (rectangle 9 0 3 7)
+                            (rectangle 12 0 8 7))
+                      (list (rectangle 0 7 9 6)
+                            (rectangle 9 7 3 6)
+                            (rectangle 12 7 8 6))
+                      (list (rectangle 0 13 9 7)
+                            (rectangle 9 13 3 7)
+                            (rectangle 12 13 8 7)))))

imperative/examples/gui/layout/main.rkt

@@ -0,0 +1,8 @@
+#lang racket/base
+;; Layout, based loosely on TeX's boxes-and-glue model.
+
+(require "sizing.rkt")
+(require "layout.rkt")
+
+(provide (all-from-out "sizing.rkt")
+         (all-from-out "layout.rkt"))

imperative/examples/gui/layout/sizing.rkt

@@ -0,0 +1,150 @@
+#lang racket/base
+;; Dimension sizing, based loosely on TeX's boxes-and-glue model.
+
+(provide (struct-out fill)
+         (struct-out sizing)
+         (struct-out box-size)
+         (struct-out rectangle)
+
+         weak-fill
+         zero-sizing
+         weak-fill-sizing
+         zero-box-size
+         weak-fill-box-size
+         zero-rectangle
+
+         fill+
+         fill-max
+         fill-min
+         fill-scale
+         fill-weaken
+
+         sizing-contains?
+         sizing-min
+         sizing-max
+         sizing-overlap?
+         sizing-scale
+         sizing-weaken
+         sizing-pad
+         sizing-adjust-ideal
+         sizing-sum
+
+         box-size-weaken)
+
+(require racket/match)
+
+;;---------------------------------------------------------------------------
+
+;; A Fill is one of
+;; - a Nat, a fixed amount of space
+;; - a (fill Nat Nat), a potentially infinite amount of space
+(struct fill (weight rank) #:transparent)
+
+;; A Sizing is a (sizing Nat Fill Fill)
+(struct sizing (ideal stretch shrink) #:transparent)
+
+;; A BoxSize is a (box-size Sizing Sizing)
+(struct box-size (horizontal vertical) #:transparent)
+
+;; A Rectangle is a (rectangle Nat Nat BoxSize)
+(struct rectangle (left top width height) #:transparent)
+
+;;---------------------------------------------------------------------------
+
+;; A very weak fill.
+(define weak-fill (fill 1 -1))
+
+(define zero-sizing (sizing 0 0 0))
+
+(define weak-fill-sizing (sizing 0 weak-fill 0))
+
+(define zero-box-size (box-size zero-sizing zero-sizing))
+
+(define weak-fill-box-size (box-size weak-fill-sizing weak-fill-sizing))
+
+(define zero-rectangle (rectangle 0 0 0 0))
+
+;;---------------------------------------------------------------------------
+
+;; (Nat Nat -> Nat) -> (Fill Fill -> Fill)
+(define ((fill-binop op) a b)
+  (match* (a b)
+    [((? number?) (? number?)) (op a b)]
+    [((? number?) (? fill?)) b]
+    [((? fill?) (? number?)) a]
+    [((fill w1 r1) (fill w2 r2))
+     (cond [(= r1 r2) (fill (op w1 w2) r1)]
+           [(> r1 r2) (fill w1 r1)]
+           [(< r1 r2) (fill w2 r2)])]))
+
+;; Fill Fill -> Fill
+(define fill+ (fill-binop +))
+(define fill-max (fill-binop max))
+(define (fill-min a b)
+  (if (and (number? a) (number? b))
+      (min a b)
+      0))
+
+(define (fill-scale f scale)
+  (if (number? f)
+      (* f scale)
+      f))
+
+(define (fill-weaken f w r)
+  (if (fill? f)
+      (fill w r)
+      f))
+
+(define (sizing-contains? s v)
+  (match-define (sizing x x+ x-) s)
+  (cond [(>= v x) (if (number? x+) (<= v (+ x x+)) #t)]
+        [(<= v x) (if (number? x-) (>= v (- x x-)) #t)]))
+
+(define (sizing-min s)
+  (match (sizing-shrink s)
+    [(? number? n) (- (sizing-ideal s) n)]
+    [(? fill?) -inf.0]))
+
+(define (sizing-max s)
+  (match (sizing-stretch s)
+    [(? number? n) (+ (sizing-ideal s) n)]
+    [(? fill?) +inf.0]))
+
+(define (sizing-overlap? x y)
+  (define largest-min (max (sizing-min x) (sizing-min y)))
+  (define smallest-max (min (sizing-max x) (sizing-max y)))
+  (< largest-min smallest-max))
+
+(define (sizing-scale s scale)
+  (match-define (sizing x x+ x-) s)
+  (sizing (* x scale) (fill-scale x+ scale) (fill-scale x- scale)))
+
+(define (sizing-weaken s
+                       [stretch-weight 1]
+                       [stretch-rank 0]
+                       [shrink-weight stretch-weight]
+                       [shrink-rank stretch-rank])
+  (match-define (sizing x x+ x-) s)
+  (sizing x
+          (fill-weaken x+ stretch-weight stretch-rank)
+          (fill-weaken x- shrink-weight shrink-rank)))
+
+(define (sizing-pad s amount)
+  (match-define (sizing x x+ x-) s)
+  (sizing (+ x amount) x+ x-))
+
+(define (sizing-adjust-ideal s i)
+  (match-define (sizing x x+ x-) s)
+  (sizing i
+          (if (fill? x+) x+ (+ x+ (- x i)))
+          (if (fill? x-) x- (- x- (- x i)))))
+
+(define (sizing-sum sizings)
+  (sizing (foldl + 0 (map sizing-ideal sizings))
+          (foldl fill+ 0 (map sizing-stretch sizings))
+          (foldl fill+ 0 (map sizing-shrink sizings))))
+
+(define (box-size-weaken bs [weight 1] [rank 0])
+  (match-define (box-size h v) bs)
+  (box-size (sizing-weaken h weight rank)
+            (sizing-weaken v weight rank)))

imperative/examples/ircd/Makefile

@@ -0,0 +1,10 @@
+all:
+
+run:
+	raco make main.rkt && racket main.rkt
+
+clean:
+	rm -rf compiled
+
+client:
+	irssi --config=irssi-config -n client

imperative/examples/ircd/channel.rkt

@@ -0,0 +1,31 @@
+#lang imperative-syndicate
+
+(require "protocol.rkt")
+(require "message.rkt")
+
+(require/activate imperative-syndicate/reload)
+
+(spawn #:name 'channel-factory
+       (stop-when-reloaded)
+
+       (during (ircd-channel-member $Ch _)
+         (assert (ircd-channel Ch)))
+
+       (during/spawn (ircd-channel $Ch)
+         #:name (ircd-channel Ch)
+         (field [topic #f])
+         (assert (ircd-channel-topic Ch (topic)))
+
+         (define/query-count user-count (ircd-channel-member Ch $who) 'any)
+         (assert (ircd-channel-user-count Ch (hash-ref (user-count) 'any 0)))
+
+         (on (message (ircd-action $who (irc-message _ "MODE" (list Ch "b") _)))
+             (send! (ircd-event who (irc-message server-prefix 368 (list (lookup-nick who) Ch)
+                                                 "End of Channel Ban List"))))
+
+         (on (message (ircd-action $who (irc-message _ "MODE" (list Ch) _)))
+             (send! (ircd-event who (irc-message server-prefix 324
+                                                 (list (lookup-nick who) Ch "+") #f))))
+
+         (on (message (ircd-action _ (irc-message _ "TOPIC" (list Ch) $new-topic)))
+             (topic new-topic))))

imperative/examples/ircd/config.rkt

@@ -0,0 +1,27 @@
+#lang imperative-syndicate
+
+(require/activate imperative-syndicate/reload)
+(require/activate imperative-syndicate/supervise)
+(require/activate imperative-syndicate/drivers/config)
+
+(require "protocol.rkt")
+
+(require racket/set)
+(require (only-in racket/list append* flatten))
+(require (only-in racket/string string-split))
+
+(spawn-configuration 'ircd "ircd-config.rktd" #:hook (lambda () (stop-when-reloaded)))
+
+(spawn #:name 'config
+       (stop-when-reloaded)
+
+       (during (config 'ircd `(port ,$port))
+         (assert (ircd-listener port)))
+
+       (during (config 'ircd `(channel ,$Ch))
+         (assert (ircd-channel Ch)))
+
+       (define/query-set motds (config 'ircd `(motd ,$text)) text)
+       (assert (ircd-motd (append*
+                           (map (lambda (t) (string-split t "\n"))
+                                (flatten (set->list (motds))))))))

imperative/examples/ircd/dynamic-main.rkt

@@ -0,0 +1,6 @@
+#lang imperative-syndicate
+(require/activate imperative-syndicate/reload)
+(spawn-reloader "config.rkt")
+(spawn-reloader "session.rkt")
+(spawn-reloader "channel.rkt")
+(spawn-reloader "greeter.rkt")

imperative/examples/ircd/greeter.rkt

@@ -0,0 +1,21 @@
+#lang imperative-syndicate
+
+(require "protocol.rkt")
+(require "message.rkt")
+
+(require/activate imperative-syndicate/reload)
+
+(spawn #:name 'greeter
+       (stop-when-reloaded)
+       (on (asserted (ircd-channel-member $Ch $conn))
+           (match-define (ircd-connection-info _ N U)
+             (immediate-query [query-value #f ($ I (ircd-connection-info conn _ _)) I]))
+           ;; TODO: history replay? As the following illustrates, we are able to forge messages
+           (send! (ircd-event conn (irc-message (irc-source-nick N U) "PRIVMSG" (list Ch)
+                                                (format "Welcome to ~a, ~a!" Ch N))))))
+
+(spawn #:name 'authenticator
+       (stop-when-reloaded)
+       (during (observe (ircd-credentials $nick $user $password _))
+         (log-info "Credentials: ~a ~a ~a" nick user password)
+         (assert (ircd-credentials nick user password (equal? password "foobar")))))

imperative/examples/ircd/ircd-config.rktd

@@ -0,0 +1,3 @@
+(port 6667)
+(motd "Hello, world!")
+(channel "#syndicate")

imperative/examples/ircd/irssi-config

@@ -0,0 +1,24 @@
+servers = (
+  {
+    address = "localhost";
+    chatnet = "Syndicate";
+    port = "6667";
+    autoconnect = "yes";
+    password = "foobar";
+  }
+);
+
+chatnets = { Syndicate = { type = "IRC"; }; };
+
+channels = (
+  { name = "#test"; chatnet = "Syndicate"; autojoin = "yes"; },
+  { name = "#test2"; chatnet = "Syndicate"; autojoin = "yes"; }
+);
+settings = {
+  core = {
+    real_name = "Alice Exampleuser";
+    user_name = "alice";
+    nick = "client";
+  };
+  "fe-text" = { actlist_sort = "refnum"; };
+};

imperative/examples/ircd/main.rkt

@@ -0,0 +1,3 @@
+#lang imperative-syndicate
+(require/activate imperative-syndicate/reload)
+(spawn-reloader "dynamic-main.rkt")

imperative/examples/ircd/message.rkt

@@ -0,0 +1,93 @@
+#lang racket/base
+
+(provide (struct-out irc-message)
+         (struct-out irc-user)
+         (struct-out irc-privmsg)
+
+         (struct-out irc-source-servername)
+         (struct-out irc-source-nick)
+
+         parse-irc-message
+         render-irc-message
+
+         ;; TODO make these assertions in the dataspace:
+         server-name
+         server-prefix)
+
+(require racket/string)
+(require racket/match)
+(require racket/format)
+
+;; <message>  ::= [':' <prefix> <SPACE> ] <command> <params> <crlf>
+;; <prefix>   ::= <servername> | <nick> [ '!' <user> ] [ '@' <host> ]
+;; <command>  ::= <letter> { <letter> } | <number> <number> <number>
+;; <SPACE>    ::= ' ' { ' ' }
+;; <params>   ::= <SPACE> [ ':' <trailing> | <middle> <params> ]
+;;
+;; <middle>   ::= <Any *non-empty* sequence of octets not including SPACE
+;;                or NUL or CR or LF, the first of which may not be ':'>
+;; <trailing> ::= <Any, possibly *empty*, sequence of octets not including
+;;                  NUL or CR or LF>
+;;
+;; <crlf>     ::= CR LF
+
+;; <target>     ::= <to> [ "," <target> ]
+;; <to>         ::= <channel> | <user> '@' <servername> | <nick> | <mask>
+;; <channel>    ::= ('#' | '&') <chstring>
+;; <servername> ::= <host>
+;; <host>       ::= see RFC 952 [DNS:4] for details on allowed hostnames
+;; <nick>       ::= <letter> { <letter> | <number> | <special> }
+;; <mask>       ::= ('#' | '$') <chstring>
+;; <chstring>   ::= <any 8bit code except SPACE, BELL, NUL, CR, LF and
+;;                   comma (',')>
+
+;; <user>       ::= <nonwhite> { <nonwhite> }
+;; <letter>     ::= 'a' ... 'z' | 'A' ... 'Z'
+;; <number>     ::= '0' ... '9'
+;; <special>    ::= '-' | '[' | ']' | '\' | '`' | '^' | '{' | '}'
+
+;; <nonwhite>   ::= <any 8bit code except SPACE (0x20), NUL (0x0), CR
+;;                   (0xd), and LF (0xa)>
+
+(struct irc-message (prefix command params trailing) #:prefab)
+(struct irc-user (username hostname realname) #:prefab)
+(struct irc-privmsg (source target text notice?) #:prefab)
+
+(struct irc-source-servername (servername) #:prefab)
+(struct irc-source-nick (nick user) #:prefab)
+
+(define (parse-irc-message line0)
+  (match (string-trim #:left? #f line0 #px"[\r\n]")
+    [(pregexp #px"^:([^ ]+) +(.*)$" (list _ prefix rest)) (parse-command prefix rest)]
+    [line (parse-command #f line)]))
+
+(define (parse-command prefix line)
+  (match-define (pregexp #px"^([^ ]+)( +([^:]+)?(:(.*))?)?$" (list _ command _ params _ rest)) line)
+  (irc-message prefix
+               (string-upcase command)
+               (string-split (or params ""))
+               rest))
+
+;; libpurple's irc protocol support crashes (!) (SIGSEGV) if you send
+;; a prefix on a JOIN event from the server as just "nick" rather than
+;; "nick!user@host" - specifically, it will crash if "!" doesn't
+;; appear in the prefix.
+;;
+(define (render-irc-message m)
+  (match-define (irc-message prefix command params trailing) m)
+  (string-append (render-prefix prefix)
+                 (~a command)
+                 (if (pair? params) (string-append " " (string-join (map ~a params))) "")
+                 (if trailing (string-append " :" trailing) "")))
+
+(define (render-prefix p)
+  (match p
+    [#f
+     ""]
+    [(irc-source-servername servername)
+     (format ":~a " servername)]
+    [(irc-source-nick nick (irc-user username hostname _))
+     (format ":~a!~a@~a " nick username hostname)]))
+
+(define server-name "syndicate-ircd")
+(define server-prefix (irc-source-servername "syndicate-ircd.example"))

imperative/examples/ircd/protocol.rkt

@@ -0,0 +1,68 @@
+#lang imperative-syndicate
+
+(provide (struct-out ircd-listener)
+         (struct-out ircd-motd)
+
+         (struct-out claim)
+         (struct-out decision)
+
+         (struct-out ircd-nick)
+         (struct-out ircd-connection-info)
+         (struct-out ircd-channel)
+         (struct-out ircd-channel-member)
+         (struct-out ircd-channel-topic)
+         (struct-out ircd-channel-user-count)
+
+         (struct-out ircd-action)
+         (struct-out ircd-event)
+
+         (struct-out ircd-credentials)
+
+         lookup-nick)
+
+;; A Connection is a TcpAddress
+
+;;---------------------------------------------------------------------------
+;; Configuration
+
+;; (ircd-listener PortNumber) - causes TCP connections to be accepted on this port
+(assertion-struct ircd-listener (port))
+
+;; (ircd-motd (Listof String)) - Message Of The Day text
+(assertion-struct ircd-motd (lines))
+
+;;---------------------------------------------------------------------------
+;; Affine resources
+
+;; (claim Any NonFalse) -- any number of these. Decider picks a claimant
+(assertion-struct claim (resource claimant))
+
+;; (decision Any NonFalse) -- zero or one of these for a given resource.
+(assertion-struct decision (resource resource-holder))
+
+;;---------------------------------------------------------------------------
+;; IRC protocol
+
+;; (ircd-nick String) - a unique resource
+(assertion-struct ircd-nick (name))
+
+;; (ircd-connection-info Connection String IRCUser) -- mapping: nick <--> conn + userinfo
+(assertion-struct ircd-connection-info (conn nick user))
+
+(assertion-struct ircd-channel (channel))
+(assertion-struct ircd-channel-member (channel conn))
+(assertion-struct ircd-channel-topic (channel topic))
+(assertion-struct ircd-channel-user-count (channel count))
+
+(message-struct ircd-action (conn message))
+(message-struct ircd-event (conn message))
+
+(assertion-struct ircd-credentials (nick user password valid?))
+
+;;---------------------------------------------------------------------------
+;; Application: chatroom model
+
+;;---------------------------------------------------------------------------
+
+(define (lookup-nick conn)
+  (immediate-query [query-value #f (ircd-connection-info conn $N _) N]))

imperative/examples/ircd/session.rkt

@@ -0,0 +1,235 @@
+#lang imperative-syndicate
+
+(require racket/set)
+(require racket/string)
+
+(require "protocol.rkt")
+(require "message.rkt")
+
+(require/activate imperative-syndicate/reload)
+(require/activate imperative-syndicate/drivers/tcp)
+(require syndicate/support/hash)
+(require (only-in racket/list append*))
+
+(spawn #:name 'affine-resource-arbiter
+       (stop-when-reloaded)
+       (during (claim $resource _)
+         (define/query-set claimants (claim resource $claimant) claimant)
+         (field [holder #f])
+         (begin/dataflow
+           (when (not (set-member? (claimants) (holder)))
+             (holder (and (not (set-empty? (claimants)))
+                          (set-first (claimants))))))
+         (assert #:when (holder) (decision resource (holder)))))
+
+(define (ircd-connection-facet connection-root-facet this-conn peer-host)
+  (define (send-to-remote #:newline [with-newline #t] fmt . vs)
+    (define bs (string->bytes/utf-8 (apply format fmt vs)))
+    (log-info "~a <- ~v" this-conn bs)
+    (send! (tcp-out this-conn (if with-newline (bytes-append bs #"\r\n") bs))))
+
+  (define (send-irc-message m)
+    (send-to-remote "~a" (render-irc-message m)))
+
+  (define (send* #:source [prefix server-prefix] #:trailing [trailing #f] command . params)
+    (send-irc-message (irc-message prefix command params trailing)))
+
+  (on-start (log-info "Connecting ~a" this-conn))
+  (on-stop (log-info "Disconnecting ~a" this-conn))
+
+  (field [nick #f]
+         [user #f]
+         [password #f]
+         [registered? #f])
+  (assert (ircd-connection-info this-conn (nick) (user)))
+  (assert #:when (nick) (claim (ircd-nick (nick)) this-conn))
+
+  (on-start
+   (react
+    (stop-when (asserted (ircd-motd $motd-lines))
+      (react
+       (begin/dataflow
+         (when (and (nick) (user))
+           (stop-current-facet
+            (react
+             (stop-when (asserted (ircd-credentials (nick) (user) (password) $valid?))
+               (cond
+                 [valid?
+                  (registered? #t)
+                  (send* 375 (nick) #:trailing (format "- ~a Message of the day - " server-name))
+                  (for [(line motd-lines)] (send* 372 (nick) #:trailing (format "- ~a" line)))
+                  (send* 376 (nick) #:trailing (format "End of /MOTD command"))
+                  (assert! (ircd-channel-member "#syndicate" this-conn)) ;; force membership!
+                  ]
+                 [else
+                  (send* 464 (nick) #:trailing "Password incorrect")
+                  (stop-facet connection-root-facet)]))))))))))
+
+  (field [peer-common-channels (hash)]
+         [peer-names (hash)])
+
+  (during (ircd-channel-member $Ch this-conn)
+    (field [initial-names-sent? #f]
+           [initial-member-nicks (set)])
+
+    (on-start (send* #:source (irc-source-nick (nick) (user)) "JOIN" Ch)
+              (flush!)
+              (flush!)
+              (define nicks (initial-member-nicks))
+              (initial-names-sent? #t)
+              (initial-member-nicks 'no-longer-valid)
+              (send* 353 (nick) "@" Ch #:trailing (string-join (set->list nicks)))
+              (send* 366 (nick) Ch #:trailing "End of /NAMES list"))
+
+    (during (ircd-channel-member Ch $other-conn)
+      (on-start (peer-common-channels (hashset-add (peer-common-channels) other-conn Ch)))
+      (on-stop (peer-common-channels (hashset-remove (peer-common-channels) other-conn Ch)))
+      (field [current-other-source #f])
+      (define/query-value next-other-source #f
+        (ircd-connection-info other-conn $N $U)
+        (irc-source-nick N U))
+      (on (retracted (ircd-channel-member Ch other-conn))
+          (when (current-other-source) (send* #:source (current-other-source) "PART" Ch)))
+      (on-stop (when (not (hash-has-key? (peer-common-channels) other-conn))
+                 (peer-names (hash-remove (peer-names) other-conn))))
+      (begin/dataflow
+        (when (not (equal? (current-other-source) (next-other-source)))
+          (if (not (next-other-source)) ;; other-conn is disconnecting
+              (when (hash-ref (peer-names) other-conn #f)
+                (send* #:source (current-other-source) "QUIT")
+                (peer-names (hash-remove (peer-names) other-conn)))
+              (begin
+                (cond
+                  [(not (initial-names-sent?)) ;; still gathering data for 353/366 below
+                   (initial-member-nicks (set-add (initial-member-nicks)
+                                                  (irc-source-nick-nick (next-other-source))))]
+                  [(not (current-other-source)) ;; other-conn is joining
+                   (send* #:source (next-other-source) "JOIN" Ch)]
+                  [else ;; it's a nick change
+                   (when (not (equal? this-conn other-conn)) ;; avoid dups for our own connection
+                     (when (not (equal? (next-other-source) (hash-ref (peer-names) other-conn #f)))
+                       (send* #:source (current-other-source) "NICK"
+                              (irc-source-nick-nick (next-other-source)))))])
+                (peer-names (hash-set (peer-names) other-conn (next-other-source)))))
+          (current-other-source (next-other-source)))))
+
+    (on (asserted (ircd-channel-topic Ch $topic))
+        (if topic
+            (send* 332 (nick) Ch #:trailing topic)
+            (send* 331 (nick) Ch #:trailing "No topic is set")))
+
+    (on (message (ircd-action this-conn (irc-message _ "WHO" (list Ch) _)))
+        (flush!) ;; Wait for responses to come in. GROSS and not in
+                 ;; general correct (e.g. in the presence of
+                 ;; pipelining)
+        (send! (ircd-event this-conn
+                           (irc-message server-prefix 315 (list (nick) Ch) "End of WHO list."))))
+    (on (message (ircd-action $who (irc-message _ "WHO" (list Ch) _)))
+        (match-define (irc-user U H R) (user))
+        (send! (ircd-event who (irc-message server-prefix 352
+                                            (list (nick) Ch U H server-name (nick) "H")
+                                            (format "0 ~a" R)))))
+
+    (on (message (ircd-action $other-conn (irc-privmsg $source Ch $text $notice?)))
+        (when (not (equal? other-conn this-conn))
+          (send* #:source source (if notice? "NOTICE" "PRIVMSG") Ch #:trailing text))))
+
+  (on (message (ircd-event this-conn $m))
+      (send-irc-message m))
+
+  (on (message (ircd-action $other-conn (irc-privmsg $source (nick) $text $notice?)))
+      (when (not (equal? other-conn this-conn))
+        (send* #:source source (if notice? "NOTICE" "PRIVMSG") (nick) #:trailing text)))
+
+  (on (message (tcp-in-line this-conn $bs))
+      (define m (parse-irc-message (bytes->string/utf-8 bs)))
+      (log-info "~a -> ~v" this-conn m)
+      (send! (ircd-action this-conn m))
+      (issue-credit! tcp-in this-conn)
+      (match m
+        [(irc-message _ "PING" _ _) (void)] ;; RFC says servers don't reply to PINGs
+        [(or (irc-message _ "PASS" (list P) _)
+             (irc-message _ "PASS" '() P)) ;; libpurple does this (!)
+         (if (registered?)
+             (send* 462 (nick) #:trailing "You may not reregister")
+             (password P))]
+        [(or (irc-message _ "NICK" (list N) _)
+             (irc-message _ "NICK" '() N)) ;; libpurple does this (!)
+         ;; TODO: enforce syntactic restrictions on nick
+         (react (assert (claim (ircd-nick N) this-conn))
+                (on (asserted (decision (ircd-nick N) $who))
+                    (if (equal? who this-conn)
+                        (begin (when (nick) (send* #:source (irc-source-nick (nick) (user)) "NICK" N))
+                               (nick N))
+                        (send* 433 (or (nick) "*") N #:trailing "Nickname is already in use"))
+                    (stop-current-facet)))]
+        [(irc-message _ "USER" (list U _Hostname _Servername) R)
+         ;; TODO: enforce syntactic restrictions on parameters to USER
+         (if (registered?)
+             (send* 462 (nick) #:trailing "You may not reregister")
+             (user (irc-user U peer-host R)))]
+        [(irc-message _ "QUIT" _ _) (stop-current-facet)]
+        [_
+         (when (registered?)
+           (match m
+             [(irc-message _ "JOIN" (cons Channels _MaybeKeys) _)
+              (for [(Ch (string-split Channels #px",+"))]
+                (assert! (ircd-channel-member Ch this-conn)))]
+             [(irc-message _ "PART" (list Channels) _)
+              (for [(Ch (string-split Channels #px",+"))]
+                (retract! (ircd-channel-member Ch this-conn)))]
+             [(irc-message _ "WHOIS" _ _)
+              (send* 318 (nick) #:trailing "End of /WHOIS list")] ;; TODO
+             [(irc-message _
+                           (and cmd (or "PRIVMSG" "NOTICE"))
+                           (list Targets)
+                           Text)
+              (for [(T (string-split Targets #px",+"))]
+                (send! (ircd-action this-conn
+                                    (irc-privmsg (irc-source-nick (nick) (user))
+                                                 T
+                                                 Text
+                                                 (equal? cmd "NOTICE")))))]
+             [_ (void)]))])))
+
+(spawn #:name 'ison-responder
+       (stop-when-reloaded)
+       (define/query-set nicks (ircd-connection-info _ $N _) N)
+       (on (message (ircd-action $conn (irc-message _ "ISON" $SomeNicks $MoreNicks)))
+           (define Nicks (append SomeNicks (string-split (or MoreNicks ""))))
+           (define (on? N) (set-member? (nicks) N))
+           (define Present (string-join (filter on? Nicks) " "))
+           (send! (ircd-event conn (irc-message server-prefix 303 '("*") Present)))))
+
+(spawn #:name 'list-responder
+       (stop-when-reloaded)
+       (define/query-hash topics (ircd-channel-topic $Ch $topic) Ch topic)
+       (define/query-hash counts (ircd-channel-user-count $Ch $count) Ch count)
+       (on (message (ircd-action $conn (irc-message _ "LIST" $requested-channel-names0 _)))
+           (define requested-channel-names
+             (append* (map (lambda (ns) (string-split ns #px",+")) requested-channel-names0)))
+           (send! (ircd-event conn (irc-message server-prefix 321 '("*" "Channel") "Users  Name")))
+           (for [(Ch (if (null? requested-channel-names)
+                         (in-hash-keys (topics))
+                         (in-list requested-channel-names)))]
+             (when (hash-has-key? (topics) Ch)
+               (define topic (hash-ref (topics) Ch))
+               (define count (hash-ref (counts) Ch 0))
+               (send! (ircd-event conn (irc-message server-prefix 322 (list "*" Ch count) topic)))))
+           (send! (ircd-event conn (irc-message server-prefix 323 '("*") "End of /LIST")))))
+
+(spawn #:name 'session-listener-factory
+       (stop-when-reloaded)
+       (during/spawn (ircd-listener $port)
+         #:name (ircd-listener port)
+         (on-start (log-info "Listening on port ~a." port))
+         (on-stop (log-info "No longer listening on port ~a." port))
+         (define server-handle (tcp-listener port))
+         (during/spawn (tcp-connection $this-conn server-handle)
+           #:name `(ircd-connection ,this-conn)
+           (define connection-root-facet (current-facet))
+           (on-start (issue-credit! server-handle)
+                     (issue-credit! tcp-in this-conn))
+           (during (tcp-connection-peer this-conn (tcp-address $peer-host _))
+             (assert (tcp-accepted this-conn))
+             (ircd-connection-facet connection-root-facet this-conn peer-host)))))

imperative/examples/netstack/Makefile

@@ -0,0 +1,7 @@
+all:
+
+run:
+	raco make main.rkt && racket main.rkt
+
+clean:
+	find . -name compiled -type d | xargs rm -rf

imperative/examples/netstack/README.md

@@ -0,0 +1,19 @@
+# TCP/IP Stack
+
+This implementation is largely the same as the old-Syndicate
+"incremental highlevel" implementation, but using new-Syndicate.
+
+## Linux Firewall Configuration
+
+Imagine a setup where the machine you are running this code has IP
+192.168.1.10. This code claims 192.168.1.222 for itself. Now, pinging
+192.168.1.222 from some other machine, say 192.168.1.99, will cause
+the local kernel to receive the pings and then *forward them on to
+192.168.1.222*, which because of the gratuitous ARP announcement, it
+knows to be on its own Ethernet MAC address. This causes the ping
+requests to repeat endlessly, each time with one lower TTL.
+
+One approach to solving the problem is to prevent the kernel from
+forwarding packets addressed to 192.168.1.222. To do this,
+
+    sudo iptables -I FORWARD -d 192.168.1.222 -j DROP

imperative/examples/netstack/TODO.md

@@ -0,0 +1,24 @@
+Ideas on TCP unit testing:
+<https://www.snellman.net/blog/archive/2015-07-09-unit-testing-a-tcp-stack/>
+
+Check behaviour around TCP zero-window probing. Is the correct
+behaviour already a consequence of the way `send-outbound` works?
+
+Do something smarter with TCP timers and RTT estimation than the
+nothing that's already being done.
+
+TCP options negotiation.
+ - SACK
+ - Window scaling
+
+Check that we handle the situations in figs. 9, 10, 11, pp.33- of RFC 793.
+
+Bugs:
+ - RST kills a connection even if its sequence number is bogus. Check
+   to make sure it's in the window. (See
+   http://static.googleusercontent.com/media/research.google.com/en//pubs/archive/41848.pdf
+   and RFC 5961)
+
+   Conform better to the rules for reset generation and processing
+   from pp.36- of RFC 793. In particular, do not blindly accept RSTs
+   without checking sequence numbers against windows etc.

imperative/examples/netstack/arp.rkt

@@ -0,0 +1,189 @@
+#lang imperative-syndicate
+;; ARP protocol, http://tools.ietf.org/html/rfc826
+;; Only does ARP-over-ethernet.
+
+(provide (struct-out arp-query)
+	 (struct-out arp-assertion)
+	 (struct-out arp-interface))
+
+(require racket/set)
+(require racket/match)
+(require/activate imperative-syndicate/drivers/timer)
+(require bitsyntax)
+
+(require "dump-bytes.rkt")
+(require "configuration.rkt")
+(require/activate "ethernet.rkt")
+
+(struct arp-query (protocol protocol-address interface-name link-address) #:prefab)
+(struct arp-assertion (protocol protocol-address interface-name) #:prefab)
+(struct arp-interface (interface-name) #:prefab)
+
+(struct arp-interface-up (interface-name) #:prefab)
+
+(define ARP-ethertype #x0806)
+(define cache-entry-lifetime-msec (* 14400 1000))
+(define wakeup-interval 5000)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (spawn-arp-driver)
+  (spawn #:name 'arp-driver
+         (during/spawn (arp-interface $interface-name)
+                       #:name (list 'arp-interface interface-name)
+                       (assert (arp-interface-up interface-name))
+                       (during (ethernet-interface interface-name $hwaddr)
+                         (run-arp-interface interface-name hwaddr)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(struct cache-key (protocol address) #:transparent)
+(struct cache-value (expiry interface-name address) #:transparent)
+
+(define (expire-cache c)
+  (define now (current-inexact-milliseconds))
+  (define (not-expired? v) (< now (cache-value-expiry v)))
+  (for/hash [((k v) (in-hash c)) #:when (not-expired? v)]
+    (values k v)))
+
+(define (run-arp-interface interface-name hwaddr)
+  (log-info "ARP interface ~v ~v" interface-name hwaddr)
+
+  (define (build-packet dest-mac ptype oper sender-ha sender-pa target-ha target-pa)
+    (define hlen (bytes-length target-ha))
+    (define plen (bytes-length target-pa))
+    (define packet (bit-string->bytes
+		    (bit-string (1 :: integer bytes 2)
+				(ptype :: integer bytes 2)
+				hlen
+				plen
+				(oper :: integer bytes 2)
+				(sender-ha :: binary bytes hlen)
+				(sender-pa :: binary bytes plen)
+				(target-ha :: binary bytes hlen)
+				(target-pa :: binary bytes plen))))
+    (ethernet-packet interface-name
+		     #f
+		     hwaddr
+		     dest-mac
+		     ARP-ethertype
+		     packet))
+
+  (define (some-asserted-pa ptype)
+    (match (filter (lambda (k) (equal? (cache-key-protocol k) ptype)) (set->list (assertions)))
+      ['() #f]
+      [(list* k _) (cache-key-address k)]))
+
+  (define (send-questions!)
+    (for [(q (set-subtract (queries) (list->set (hash-keys (cache)))))]
+      (define pa (some-asserted-pa (cache-key-protocol q)))
+      (log-info "~a ARP Asking for ~a from ~a"
+                interface-name
+                (pretty-bytes (cache-key-address q))
+                (and pa (pretty-bytes pa)))
+      (when pa
+        (send! (build-packet broadcast-ethernet-address
+                             (cache-key-protocol q)
+                             1 ;; request
+                             hwaddr
+                             pa
+                             zero-ethernet-address
+                             (cache-key-address q))))))
+
+  (field [cache (hash)]
+         [queries (set)]
+         [assertions (set)])
+
+  (field [expiry-deadline (+ (current-inexact-milliseconds) wakeup-interval)])
+  (on (asserted (later-than (expiry-deadline)))
+      (cache (expire-cache (cache)))
+      (send-questions!)
+      (expiry-deadline (+ (current-inexact-milliseconds) wakeup-interval)))
+
+  (on (message ($ p (ethernet-packet-pattern interface-name #t ARP-ethertype)))
+      (match-define (ethernet-packet _ _ source destination _ body) p)
+      (bit-string-case body
+         ([ (= 1 :: integer bytes 2)
+            (ptype :: integer bytes 2)
+            hlen
+            plen
+            (oper :: integer bytes 2)
+            (sender-hardware-address0 :: binary bytes hlen)
+            (sender-protocol-address0 :: binary bytes plen)
+            (target-hardware-address0 :: binary bytes hlen)
+            (target-protocol-address0 :: binary bytes plen)
+            (:: binary) ;; The extra zeros exist because ethernet packets
+                        ;; have a minimum size. This is, in part, why IPv4
+                        ;; headers have a total-length field, so that the
+                        ;; zero padding can be removed.
+            ]
+          (let ()
+            (define sender-protocol-address (bit-string->bytes sender-protocol-address0))
+            (define sender-hardware-address (bit-string->bytes sender-hardware-address0))
+            (define target-protocol-address (bit-string->bytes target-protocol-address0))
+            (define learned-key (cache-key ptype sender-protocol-address))
+
+            (when (and (set-member? (queries) learned-key) ;; it is relevant to our interests
+                       (not (equal? sender-hardware-address
+                                    (cache-value-address (hash-ref (cache)
+                                                                   learned-key
+                                                                   (lambda ()
+                                                                     (cache-value #f #f #f)))))))
+              (log-info "~a ARP Adding ~a = ~a to cache"
+                        interface-name
+                        (pretty-bytes sender-protocol-address)
+                        (pretty-bytes sender-hardware-address)))
+
+            (cache (hash-set (expire-cache (cache))
+                             learned-key
+                             (cache-value (+ (current-inexact-milliseconds)
+                                             cache-entry-lifetime-msec)
+                                          interface-name
+                                          sender-hardware-address)))
+            (case oper
+              [(1) ;; request
+               (when (set-member? (assertions) (cache-key ptype target-protocol-address))
+                 (log-info "~a ARP answering request for ~a/~a"
+                           interface-name
+                           ptype
+                           (pretty-bytes target-protocol-address))
+                 (send! (build-packet sender-hardware-address
+                                      ptype
+                                      2 ;; reply
+                                      hwaddr
+                                      target-protocol-address
+                                      sender-hardware-address
+                                      sender-protocol-address)))]
+              [(2) (void)] ;; reply
+              [else (void)])))
+         (else #f)))
+
+  (during (arp-assertion $protocol $protocol-address interface-name)
+          (define a (cache-key protocol protocol-address))
+          (on-start (assertions (set-add (assertions) a))
+                    (log-info "~a ARP Announcing ~a as ~a"
+                              interface-name
+                              (pretty-bytes (cache-key-address a))
+                              (pretty-bytes hwaddr))
+                    (send! (build-packet broadcast-ethernet-address
+                                         (cache-key-protocol a)
+                                         2 ;; reply -- gratuitous announcement
+                                         hwaddr
+                                         (cache-key-address a)
+                                         hwaddr
+                                         (cache-key-address a))))
+          (on-stop (assertions (set-remove (assertions) a))))
+
+  (during (observe (arp-query $protocol $protocol-address interface-name _))
+          (define key (cache-key protocol protocol-address))
+          (on-start (queries (set-add (queries) key))
+                    (send-questions!))
+          (on-stop (queries (set-remove (queries) key)))
+          (assert #:when (hash-has-key? (cache) key)
+                  (match (hash-ref (cache) key)
+                    [(cache-value _ ifname addr)
+                     (arp-query protocol protocol-address ifname addr)]))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(spawn-arp-driver)

imperative/examples/netstack/checksum.rkt

@@ -0,0 +1,52 @@
+#lang racket/base
+
+(provide ones-complement-sum16 ip-checksum)
+
+(require bitsyntax)
+(require "dump-bytes.rkt")
+
+(define (ones-complement-+16 a b)
+  (define c (+ a b))
+  (bitwise-and #xffff (+ (arithmetic-shift c -16) c)))
+
+(define (ones-complement-sum16 bs)
+  (bit-string-case bs
+    ([ (n :: integer bytes 2) (rest :: binary) ]
+     (ones-complement-+16 n (ones-complement-sum16 rest)))
+    ([ odd-byte ]
+     (arithmetic-shift odd-byte 8))
+    ([ ]
+     0)))
+
+(define (ones-complement-negate16-safely x)
+  (define r (bitwise-and #xffff (bitwise-not x)))
+  (if (= r 0) #xffff r))
+
+(define (ip-checksum offset blob #:pseudo-header [pseudo-header #""])
+  (bit-string-case blob
+    ([ (prefix :: binary bytes offset)
+       (:: binary bytes 2)
+       (suffix :: binary) ]
+     ;; (log-info "Packet pre checksum:\n~a" (dump-bytes->string blob))
+     (define result (ones-complement-+16
+		     (ones-complement-sum16 pseudo-header)
+		     (ones-complement-+16 (ones-complement-sum16 prefix)
+					  (ones-complement-sum16 suffix))))
+     ;; (log-info "result: ~a" (number->string result 16))
+     (define checksum (ones-complement-negate16-safely result))
+     ;; (log-info "Checksum ~a" (number->string checksum 16))
+     (define final-packet (bit-string (prefix :: binary)
+				      (checksum :: integer bytes 2)
+				      (suffix :: binary)))
+     ;; (log-info "Packet with checksum:\n~a" (dump-bytes->string final-packet))
+     final-packet)))
+
+(module+ test
+  (require rackunit)
+  (check-equal? (ones-complement-negate16-safely
+		 (ones-complement-sum16 (bytes #x45 #x00 #x00 #x54
+					       #x00 #x00 #x00 #x00
+					       #x40 #x01 #x00 #x00
+					       #xc0 #xa8 #x01 #xde
+					       #xc0 #xa8 #x01 #x8f)))
+		#xf5eb))

imperative/examples/netstack/configuration.rkt

@@ -0,0 +1,18 @@
+#lang racket/base
+
+(provide (struct-out host-route)
+	 (struct-out gateway-route)
+	 (struct-out net-route)
+
+         (struct-out route-up))
+
+;; A Route is one of
+;;  - (host-route IpAddrBytes NetmaskNat InterfaceName), an own-IP route
+;;  - (gateway-route NetAddrBytes NetmaskNat IpAddrBytes InterfaceName), a gateway for a subnet
+;;  - (net-route NetAddrBytes NetmaskNat InterfaceName), an ethernet route for a subnet
+;; NetmaskNat in a net-route is a default route.
+(struct host-route (ip-addr netmask interface-name) #:prefab)
+(struct gateway-route (network-addr netmask gateway-addr interface-name) #:prefab)
+(struct net-route (network-addr netmask link) #:prefab)
+
+(struct route-up (route) #:prefab) ;; assertion: the given Route is running

imperative/examples/netstack/demo-config.rkt

@@ -0,0 +1,21 @@
+#lang imperative-syndicate
+;; Demonstration stack configuration for various hosts.
+
+(require racket/match)
+(require (only-in mzlib/os gethostname))
+(require (only-in racket/string string-split))
+(require "configuration.rkt")
+
+(spawn
+ (match (gethostname)
+   ["stockholm.ccs.neu.edu"
+    (assert (host-route (bytes 129 10 115 94) 24 "eth0"))
+    (assert (gateway-route (bytes 0 0 0 0) 0 (bytes 129 10 115 1) "eth0"))]
+   [other ;; assume a private network
+    (define interface
+      (match (car (string-split other "."))
+        ["skip" "en0"]
+        ["leap" "wlp4s0"] ;; wtf
+        [_ "wlan0"]))
+    (assert (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) interface))
+    (assert (host-route (bytes 192 168 1 222) 24 interface))]))

imperative/examples/netstack/dump-bytes.rkt

@@ -0,0 +1,80 @@
+#lang racket/base
+;; Copyright (C) 2012 Tony Garnock-Jones <tonygarnockjones@gmail.com>
+;;
+;; dump-bytes.rkt is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published
+;; by the Free Software Foundation, either version 3 of the License,
+;; or (at your option) any later version.
+;;
+;; dump-bytes.rkt is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with dump-bytes.rkt. If not, see <http://www.gnu.org/licenses/>.
+
+;; Pretty hex dump output of a Bytes.
+
+(provide dump-bytes!
+	 dump-bytes->string
+	 pretty-bytes)
+
+(require (only-in bitsyntax bit-string->bytes))
+(require (only-in file/sha1 bytes->hex-string))
+
+(define (pretty-bytes bs)
+  (bytes->hex-string (bit-string->bytes bs)))
+
+;; Exact Exact -> String
+;; Returns the "0"-padded, width-digit hex representation of n
+(define (hex width n)
+  (define s (number->string n 16))
+  (define slen (string-length s))
+  (cond
+   ((< slen width) (string-append (make-string (- width slen) #\0) s))
+   ((= slen width) s)
+   ((> slen width) (substring s 0 width))))
+
+;; Bytes Exact -> Void
+;; Prints a pretty hex/ASCII dump of bs on (current-output-port).
+(define (dump-bytes! bs0 [requested-count #f] #:base [baseaddr 0])
+  (define bs (bit-string->bytes bs0))
+  (define count (if requested-count (min requested-count (bytes-length bs)) (bytes-length bs)))
+  (define clipped (subbytes bs 0 count))
+  (define (dump-hex i)
+    (if (< i count)
+	(display (hex 2 (bytes-ref clipped i)))
+	(display "  "))
+    (display #\space))
+  (define (dump-char i)
+    (if (< i count)
+	(let ((ch (bytes-ref clipped i)))
+	  (if (<= 32 ch 127)
+	      (display (integer->char ch))
+	      (display #\.)))
+	(display #\space)))
+  (define (for-each-between f low high)
+    (do ((i low (+ i 1)))
+	((= i high))
+      (f i)))
+  (define (dump-line i)
+    (display (hex 8 (+ i baseaddr)))
+    (display #\space)
+    (for-each-between dump-hex i (+ i 8))
+    (display ": ")
+    (for-each-between dump-hex (+ i 8) (+ i 16))
+    (display #\space)
+    (for-each-between dump-char i (+ i 8))
+    (display " : ")
+    (for-each-between dump-char (+ i 8) (+ i 16))
+    (newline))
+  (do ((i 0 (+ i 16)))
+      ((>= i count))
+    (dump-line i)))
+
+(define (dump-bytes->string bs [requested-count #f] #:base [baseaddr 0])
+  (define s (open-output-string))
+  (parameterize ((current-output-port s))
+    (dump-bytes! bs requested-count #:base baseaddr))
+  (get-output-string s))

imperative/examples/netstack/ethernet.rkt

@@ -0,0 +1,120 @@
+#lang imperative-syndicate
+;; Ethernet driver
+
+(provide (struct-out available-ethernet-interface)
+         (struct-out ethernet-interface)
+	 (struct-out ethernet-packet)
+	 zero-ethernet-address
+	 broadcast-ethernet-address
+	 ethernet-packet-pattern)
+
+(require/activate imperative-syndicate/drivers/timer)
+(require racket/set)
+(require racket/match)
+(require racket/async-channel)
+
+(require packet-socket)
+(require bitsyntax)
+
+(require "configuration.rkt")
+(require "dump-bytes.rkt")
+(require imperative-syndicate/pattern-expander)
+
+(assertion-struct available-ethernet-interface (name))
+(assertion-struct ethernet-interface (name hwaddr))
+(message-struct ethernet-packet (interface-name from-wire? source destination ethertype body))
+
+(define zero-ethernet-address (bytes 0 0 0 0 0 0))
+(define broadcast-ethernet-address (bytes 255 255 255 255 255 255))
+
+(define interface-names (raw-interface-names))
+(log-info "Device names: ~a" interface-names)
+
+(define (spawn-ethernet-driver)
+  (spawn #:name 'ethernet-driver
+
+   (for [(n interface-names)]
+     (assert (available-ethernet-interface n)))
+
+   (during/spawn
+    (observe (ethernet-packet $interface-name #t _ _ _ _))
+    #:name (list 'ethernet-interface interface-name)
+
+    (define h (raw-interface-open interface-name))
+    (when (not h) (error 'ethernet "Couldn't open interface ~v" interface-name))
+    (log-info "Opened interface ~a, yielding handle ~v" interface-name h)
+
+    (assert (ethernet-interface interface-name (raw-interface-hwaddr h)))
+
+    (define control-ch (make-async-channel))
+    (thread (lambda () (interface-packet-read-loop interface-name h control-ch)))
+    (signal-background-activity! +1)
+    (on-start (async-channel-put control-ch 'unblock))
+    (on-stop (async-channel-put control-ch 'quit))
+
+    ;; (on (message ($ p (ethernet-packet interface #t _ _ _ _)))
+    ;;     (log-info "Interface ~a inbound packet ~a -> ~a (type 0x~a)"
+    ;;               (ethernet-interface-name (ethernet-packet-interface p))
+    ;;               (pretty-bytes (ethernet-packet-source p))
+    ;;               (pretty-bytes (ethernet-packet-destination p))
+    ;;               (number->string (ethernet-packet-ethertype p) 16))
+    ;;     (log-info "~a" (dump-bytes->string (ethernet-packet-body p))))
+
+    (on (message ($ p (ethernet-packet interface-name #f _ _ _ _)))
+        ;; (log-info "Interface ~a OUTBOUND packet ~a -> ~a (type 0x~a)"
+        ;;           (ethernet-interface-name (ethernet-packet-interface p))
+        ;;           (pretty-bytes (ethernet-packet-source p))
+        ;;           (pretty-bytes (ethernet-packet-destination p))
+        ;;           (number->string (ethernet-packet-ethertype p) 16))
+        ;; (log-info "~a" (dump-bytes->string (ethernet-packet-body p)))
+        (raw-interface-write h (encode-ethernet-packet p))))))
+
+(define (interface-packet-read-loop interface-name h control-ch)
+  (define (blocked)
+    (match (async-channel-get control-ch)
+      ['unblock (unblocked)]
+      ['quit (void)]))
+  (define (unblocked)
+    (match (async-channel-try-get control-ch)
+      ['unblock (unblocked)]
+      ['quit (void)]
+      [#f
+       (define p (raw-interface-read h))
+       (define decoded (decode-ethernet-packet interface-name p))
+       (when decoded (ground-send! decoded))
+       (unblocked)]))
+  (blocked)
+  (raw-interface-close h)
+  (signal-background-activity! -1))
+
+(define (decode-ethernet-packet interface-name p)
+  (bit-string-case p
+    ([ (destination :: binary bytes 6)
+       (source :: binary bytes 6)
+       (ethertype :: integer bytes 2)
+       (body :: binary) ]
+     (ethernet-packet interface-name
+		      #t
+		      (bit-string->bytes source)
+		      (bit-string->bytes destination)
+		      ethertype
+		      (bit-string->bytes body)))
+    (else #f)))
+
+(define (encode-ethernet-packet p)
+  (match-define (ethernet-packet _ _ source destination ethertype body) p)
+  (bit-string->bytes
+   (bit-string (destination :: binary bytes 6)
+	       (source :: binary bytes 6)
+	       (ethertype :: integer bytes 2)
+	       (body :: binary))))
+
+(begin-for-declarations
+  (define-pattern-expander ethernet-packet-pattern
+    (syntax-rules ()
+      [(_ interface-name from-wire? ethertype)
+       (ethernet-packet interface-name from-wire? _ _ ethertype _)])))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(spawn-ethernet-driver)

imperative/examples/netstack/fetchurl.rkt

@@ -0,0 +1,32 @@
+#lang imperative-syndicate
+
+(require/activate "ethernet.rkt")
+(require/activate "arp.rkt")
+(require/activate "ip.rkt")
+(require/activate "tcp.rkt")
+(require/activate "udp.rkt")
+(require/activate "demo-config.rkt")
+(require net/dns) ;; not syndicateish yet
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(let ()
+  (define host "www.w3.org")
+  (define port 80)
+  (define connection-id 'httpclient)
+  (define remote-handle (tcp-address (dns-get-address (dns-find-nameserver) host) port))
+
+  (spawn (assert (tcp-connection connection-id remote-handle))
+         (stop-when (asserted (tcp-rejected connection-id $reason))
+           (local-require racket/exn)
+           (printf "Connection failed:\n  ~a" (exn->string reason)))
+         (on (asserted (tcp-accepted connection-id))
+             (send! (tcp-out connection-id
+                             (bytes-append #"GET / HTTP/1.0\r\nHost: "
+                                           (string->bytes/utf-8 host)
+                                           #"\r\n\r\n"))))
+         (stop-when (retracted (tcp-accepted connection-id))
+           (printf "URL fetcher exiting.\n"))
+         (on (message (tcp-in connection-id $bs))
+             (printf "----------------------------------------\n~a\n" bs)
+             (printf "----------------------------------------\n"))))

imperative/examples/netstack/ip.rkt

@@ -0,0 +1,259 @@
+#lang imperative-syndicate
+
+(provide (struct-out ip-packet)
+	 ip-address->hostname
+	 ip-string->ip-address
+	 apply-netmask
+	 ip-address-in-subnet?
+         query-local-ip-addresses
+	 broadcast-ip-address
+	 spawn-ip-driver)
+
+(require racket/set)
+(require (only-in racket/string string-split))
+(require bitsyntax)
+
+(require "dump-bytes.rkt")
+(require "configuration.rkt")
+(require "checksum.rkt")
+
+(require/activate imperative-syndicate/drivers/timer)
+(require/activate "ethernet.rkt")
+(require/activate "arp.rkt")
+
+(message-struct ip-packet
+                (source-interface ;; string for an ethernet interface, or #f for local interfaces
+                 source
+                 destination
+                 protocol
+                 options
+                 body
+                 ;; TODO: more fields
+                 ))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (ip-address->hostname bs)
+  (bit-string-case bs
+    ([ a b c d ] (format "~a.~a.~a.~a" a b c d))))
+
+(define (ip-string->ip-address str)
+  (list->bytes (map string->number (string-split str "."))))
+
+(define (apply-netmask addr netmask)
+  (bit-string-case addr
+    ([ (n :: integer bytes 4) ]
+     (bit-string ((bitwise-and n (arithmetic-shift #x-100000000 (- netmask)))
+		  :: integer bytes 4)))))
+
+(define (ip-address-in-subnet? addr network netmask)
+  (equal? (apply-netmask network netmask)
+	  (apply-netmask addr netmask)))
+
+(define broadcast-ip-address (bytes 255 255 255 255))
+
+(define (query-local-ip-addresses)
+  (query-set local-ips (host-route $addr _ _) addr))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (spawn-ip-driver)
+  (spawn #:name 'ip-driver
+   (during/spawn (host-route $my-address $netmask $interface-name)
+                 (assert (route-up (host-route my-address netmask interface-name)))
+                 (do-host-route my-address netmask interface-name))
+   (during/spawn (gateway-route $network $netmask $gateway-addr $interface-name)
+                 (assert (route-up (gateway-route network netmask gateway-addr interface-name)))
+                 (do-gateway-route network netmask gateway-addr interface-name))
+   (during/spawn (net-route $network-addr $netmask $link)
+                 (assert (route-up (net-route network-addr netmask link)))
+                 (do-net-route network-addr netmask link))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Local IP route
+
+(define (do-host-route my-address netmask interface-name)
+  (let ((network-addr (apply-netmask my-address netmask)))
+    (do-normal-ip-route (host-route my-address netmask interface-name)
+                        network-addr
+                        netmask
+                        interface-name))
+
+  (assert (arp-assertion IPv4-ethertype my-address interface-name))
+  (on (message (ip-packet _ $peer-address my-address PROTOCOL-ICMP _ $body))
+      (bit-string-case body
+        ([ type code (checksum :: integer bytes 2) (rest :: binary) ] ;; TODO: check cksum
+         (case type
+           [(8) ;; ECHO (0 is ECHO-REPLY)
+            (log-info "Ping of ~a from ~a"
+                      (pretty-bytes my-address)
+                      (pretty-bytes peer-address))
+            (define reply-data0 (bit-string 0
+                                            code
+                                            (0 :: integer bytes 2) ;; TODO
+                                            (rest :: binary)))
+            (send! (ip-packet #f
+                              my-address
+                              peer-address
+                              PROTOCOL-ICMP
+                              #""
+                              (ip-checksum 2 reply-data0)))]
+           [else
+            (log-info "ICMP ~a/~a (cksum ~a) to ~a from ~a:\n~a"
+                      type
+                      code
+                      checksum
+                      (pretty-bytes my-address)
+                      (pretty-bytes peer-address)
+                      (dump-bytes->string rest))]))
+        (else #f))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Gateway IP route
+
+(define (do-gateway-route network netmask gateway-addr interface-name)
+  (define the-route (gateway-route network netmask gateway-addr interface-name))
+
+  (field [routes (set)])
+  (query-set* routes (host-route $addr $netmask _) (list addr netmask))
+  (query-set* routes (gateway-route $addr $netmask _ _) (list addr netmask))
+  (query-set* routes (net-route $addr $netmask _) (list addr netmask))
+
+  (define (covered-by-some-other-route? addr)
+    (for/or ([r (in-set (routes))])
+      (match-define (list net msk) r)
+      (and (positive? msk)
+	   (ip-address-in-subnet? addr net msk))))
+
+  (during (ethernet-interface interface-name $gateway-interface-hwaddr)
+    (field [gateway-hwaddr #f])
+    (on (asserted (arp-query IPv4-ethertype gateway-addr interface-name $hwaddr))
+        (when (not (gateway-hwaddr))
+          (log-info "Discovered gateway ~a at ~a on interface ~a."
+                    (ip-address->hostname gateway-addr)
+                    interface-name
+                    (pretty-bytes hwaddr)))
+        (gateway-hwaddr hwaddr))
+
+    (on (message ($ p (ip-packet _ _ _ _ _ _)))
+        (when (not (gateway-hwaddr))
+          (log-warning "Gateway hwaddr for ~a not known, packet dropped."
+                       (ip-address->hostname gateway-addr)))
+        (when (and (gateway-hwaddr)
+                   (not (equal? (ip-packet-source-interface p) interface-name))
+                   (not (covered-by-some-other-route? (ip-packet-destination p))))
+          (send! (ethernet-packet interface-name
+                                  #f
+                                  gateway-interface-hwaddr
+                                  (gateway-hwaddr)
+                                  IPv4-ethertype
+                                  (format-ip-packet p)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; General net route
+
+(define (do-net-route network-addr netmask link)
+  (do-normal-ip-route (net-route network-addr netmask link) network-addr netmask link))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Normal IP route
+
+(define (do-normal-ip-route the-route network netmask interface-name)
+  (assert (arp-interface interface-name))
+  (on (message (ethernet-packet interface-name #t _ _ IPv4-ethertype $body))
+      (define p (parse-ip-packet interface-name body))
+      (when p (send! p)))
+  (during (ethernet-interface interface-name $interface-hwaddr)
+    (on (message ($ p (ip-packet _ _ _ _ _ _)))
+        (define destination (ip-packet-destination p))
+        (when (and (not (equal? (ip-packet-source-interface p) interface-name))
+                   (ip-address-in-subnet? destination network netmask))
+          ;; v Use `spawn` instead of `react` to avoid gratuitous packet
+          ;; reordering.
+          (spawn (stop-when-timeout 5000
+                   (log-warning "ARP lookup of ~a failed, packet dropped"
+                                (ip-address->hostname destination)))
+                 (stop-when (asserted (arp-query IPv4-ethertype
+                                                 destination
+                                                 interface-name
+                                                 $destination-hwaddr))
+                   (send! (ethernet-packet interface-name
+                                           #f
+                                           interface-hwaddr
+                                           destination-hwaddr
+                                           IPv4-ethertype
+                                           (format-ip-packet p)))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define IPv4-ethertype #x0800)
+
+(define IP-VERSION 4)
+(define IP-MINIMUM-HEADER-LENGTH 5)
+
+(define PROTOCOL-ICMP 1)
+
+(define default-ttl 64)
+
+(define (parse-ip-packet interface-name body)
+  ;; (log-info "IP ~a got body ~a" (pretty-bytes my-address) (pretty-bytes body))
+  (bit-string-case body
+    ([ (= IP-VERSION :: bits 4)
+       (header-length :: bits 4)
+       service-type
+       (total-length :: bits 16)
+       (id :: bits 16)
+       (flags :: bits 3)
+       (fragment-offset :: bits 13)
+       ttl
+       protocol
+       (header-checksum :: bits 16) ;; TODO: check checksum
+       (source-ip0 :: binary bits 32)
+       (destination-ip0 :: binary bits 32)
+       (rest :: binary) ]
+     (let* ((source-ip (bit-string->bytes source-ip0))
+	    (destination-ip (bit-string->bytes destination-ip0))
+	    (options-length (* 4 (- header-length IP-MINIMUM-HEADER-LENGTH)))
+	    (data-length (- total-length (* 4 header-length))))
+       (if (and (>= header-length 5)
+		(>= (bit-string-byte-count body) (* header-length 4)))
+	   (bit-string-case rest
+	     ([ (opts :: binary bytes options-length)
+		(data :: binary bytes data-length)
+		(:: binary) ] ;; Very short ethernet packets have a trailer of zeros
+	      (ip-packet interface-name
+			 (bit-string->bytes source-ip)
+			 (bit-string->bytes destination-ip)
+			 protocol
+			 (bit-string->bytes opts)
+			 (bit-string->bytes data))))
+	   #f)))
+    (else #f)))
+
+(define (format-ip-packet p)
+  (match-define (ip-packet _ src dst protocol options body) p)
+
+  (define header-length ;; TODO: ensure options is a multiple of 4 bytes
+    (+ IP-MINIMUM-HEADER-LENGTH (quotient (bit-string-byte-count options) 4)))
+
+  (define header0 (bit-string (IP-VERSION :: bits 4)
+			      (header-length :: bits 4)
+			      0 ;; TODO: service type
+			      ((+ (* header-length 4) (bit-string-byte-count body))
+			       :: bits 16)
+			      (0 :: bits 16)  ;; TODO: identifier
+			      (0 :: bits 3)   ;; TODO: flags
+			      (0 :: bits 13)  ;; TODO: fragments
+			      default-ttl
+			      protocol
+			      (0 :: bits 16)
+			      (src :: binary bits 32)
+			      (dst :: binary bits 32)
+			      (options :: binary)))
+  (define full-packet (bit-string ((ip-checksum 10 header0) :: binary) (body :: binary)))
+
+  full-packet)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(spawn-ip-driver)

imperative/examples/netstack/main.rkt

@@ -0,0 +1,93 @@
+#lang imperative-syndicate
+
+(require/activate imperative-syndicate/drivers/timer)
+(require/activate "ethernet.rkt")
+(require/activate "arp.rkt")
+(require/activate "ip.rkt")
+(require/activate "tcp.rkt")
+(require/activate "udp.rkt")
+(require/activate "demo-config.rkt")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(let ()
+  (local-require racket/format)
+
+  (message-struct speak (who what))
+  (assertion-struct present (who))
+
+  (dataspace #:name 'chat-server-app
+   (spawn #:name 'chat-server
+    (during/spawn (inbound (tcp-connection $id (tcp-listener 5999)))
+      #:name (list 'chat-connection id)
+      (assert (outbound (tcp-accepted id)))
+      (let ((me (gensym 'user)))
+        (assert (present me))
+        (on (message (inbound (tcp-in-line id $bs)))
+            (match bs
+              [#"/quit" (stop-current-facet)]
+              [_ (send! (speak me (bytes->string/utf-8 bs)))])))
+      (during (present $user)
+        (on-start (send! (outbound (tcp-out id (string->bytes/utf-8 (~a user " arrived\n"))))))
+        (on-stop  (send! (outbound (tcp-out id (string->bytes/utf-8 (~a user " left\n"))))))
+        (on (message (speak user $text))
+            (send! (outbound
+                    (tcp-out id (string->bytes/utf-8 (~a user " says '" text "'\n")))))))))))
+
+(let ()
+  (dataspace #:name 'connection-rejection-test
+   (spawn #:name 'connection-rejection-main
+          (local-require racket/exn)
+          (define peer-host "192.168.1.1")
+          ;; TODO: ^ this will only reliably "fail" the way we want on my own network...
+          (define peer-port 9999)
+          (assert (outbound (tcp-connection 'x (tcp-address peer-host peer-port))))
+          (stop-when (asserted (inbound (tcp-rejected 'x $reason)))
+            (log-info "Connection to ~a:~a rejected:\n~a" peer-host peer-port (exn->string reason)))
+          (on (asserted (inbound (tcp-accepted 'x)))
+              (error 'connection-rejection-main
+                     "Unexpected accepted connection???")))))
+
+(let ((dst (udp-listener 6667)))
+  (dataspace #:name 'udp-echo-program-app
+   (spawn #:name 'udp-echo-program
+    (on (message (inbound (udp-packet $src dst $body)))
+        (log-info "Got packet from ~v: ~v" src body)
+        (send! (outbound
+                (udp-packet dst src (string->bytes/utf-8 (format "You said: ~a" body)))))))))
+
+(let ()
+  (dataspace #:name 'webserver-dataspace
+   (spawn #:name 'webserver-counter
+          (field [counter 0])
+          (on (message 'bump)
+              (send! `(counter ,(counter)))
+              (counter (+ (counter) 1))))
+
+   (define us (tcp-listener 80))
+   (spawn #:name 'webserver
+          (during/spawn (inbound (tcp-connection $them us))
+            #:name (list 'webserver-session them)
+            (log-info "Got connection from ~v" them)
+            (assert (outbound (tcp-accepted them)))
+            (on (message (inbound (tcp-in them _)))) ;; ignore input
+
+            (on-start (send! 'bump))
+            (on (message `(counter ,$counter))
+                (define response
+                  (string->bytes/utf-8
+                   (format (string-append
+                            "HTTP/1.0 200 OK\r\n"
+                            "Content-Type: text/html\r\n"
+                            "\r\n"
+                            "<h1>Hello world from syndicate-netstack!</h1>\n"
+                            "<p>This is running on syndicate's own\n"
+                            "<a href='https://github.com/tonyg/syndicate/'>\n"
+                            "TCP/IP stack</a>.</p>\n"
+                            "<p>There have been ~a requests prior to this one.</p>\n")
+                           counter)))
+                (send! (outbound (tcp-out them response)))
+                (for [(i 4)]
+                  (define buf (make-bytes 1024 (+ #x30 (modulo i 10))))
+                  (send! (outbound (tcp-out them buf))))
+                (stop-facet (current-facet)))))))

imperative/examples/netstack/port-allocator.rkt

@@ -0,0 +1,36 @@
+#lang imperative-syndicate
+;; UDP/TCP port allocator
+
+(provide spawn-port-allocator
+         allocate-port!
+	 (struct-out port-allocation-request)
+         (struct-out port-allocation-reply))
+
+(require racket/set)
+(require "ip.rkt")
+
+(struct port-allocation-request (reqid type) #:prefab)
+(struct port-allocation-reply (reqid port) #:prefab)
+
+(define (spawn-port-allocator allocator-type query-used-ports)
+  (spawn #:name (list 'port-allocator allocator-type)
+         (define local-ips (query-local-ip-addresses))
+         (define used-ports (query-used-ports))
+
+         (begin/dataflow
+           (log-info "port-allocator ~v used ports: ~v" allocator-type (used-ports)))
+
+         (on (message (port-allocation-request $reqid allocator-type))
+             (define currently-used-ports (used-ports))
+             (let randomly-allocate-until-unused ()
+               (define p (+ 1024 (random 64512)))
+               (if (set-member? currently-used-ports p)
+                   (randomly-allocate-until-unused)
+                   (begin (used-ports (set-add currently-used-ports p))
+                          (send! (port-allocation-reply reqid p))))))))
+
+(define (allocate-port! type)
+  (define reqid (gensym 'allocate-port!))
+  (react/suspend (done)
+    (stop-when (message (port-allocation-reply reqid $port)) (done port))
+    (on-start (send! (port-allocation-request reqid type)))))

imperative/examples/netstack/tcp.rkt

@@ -0,0 +1,771 @@
+#lang imperative-syndicate
+
+(provide (struct-out tcp-connection)
+         (struct-out tcp-accepted)
+         (struct-out tcp-rejected)
+         (struct-out tcp-out)
+         (struct-out tcp-in)
+         (struct-out tcp-in-line)
+
+         (struct-out tcp-address)
+         (struct-out tcp-listener)
+
+	 spawn-tcp-driver)
+
+(require racket/set)
+(require bitsyntax)
+
+(require "dump-bytes.rkt")
+(require "checksum.rkt")
+
+(require/activate imperative-syndicate/drivers/timer)
+(require "ip.rkt")
+(require "port-allocator.rkt")
+
+(module+ test (require rackunit))
+
+(define-logger netstack/tcp)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Protocol messages
+
+(assertion-struct tcp-connection (id spec))
+(assertion-struct tcp-accepted (id))
+(assertion-struct tcp-rejected (id exn))
+(message-struct tcp-out (id bytes))
+(message-struct tcp-in (id bytes))
+(message-struct tcp-in-line (id bytes))
+
+(assertion-struct tcp-address (host port))
+(assertion-struct tcp-listener (port))
+
+(assertion-struct tcp-quad (remote-ip remote-port local-ip local-port))
+
+(message-struct tcp-packet (from-wire?
+                            quad
+                            sequence-number
+                            ack-number
+                            flags
+                            window-size
+                            options
+                            data))
+
+;; (tcp-port-allocation Number (U TcpAddress TcpListener))
+(assertion-struct tcp-port-allocation (port handle))
+
+(define (tcp-quad->string from-wire? q)
+  (match-define (tcp-quad ri rp li lp) q)
+  (if from-wire?
+      (format "(I) ~a:~a -> ~a:~a" (ip-address->hostname ri) rp (ip-address->hostname li) lp)
+      (format "(O) ~a:~a -> ~a:~a" (ip-address->hostname li) lp (ip-address->hostname ri) rp)))
+
+(define (summarize-tcp-packet packet)
+  (format "~a (seq ~a, ack ~a, flags ~a, window ~a, payload ~a)"
+          (tcp-quad->string (tcp-packet-from-wire? packet) (tcp-packet-quad packet))
+          (tcp-packet-sequence-number packet)
+          (tcp-packet-ack-number packet)
+          (tcp-packet-flags packet)
+          (tcp-packet-window-size packet)
+          (bit-string-byte-count (tcp-packet-data packet))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Driver startup
+
+(define PROTOCOL-TCP 6)
+
+(define (spawn-tcp-driver)
+  (spawn-port-allocator 'tcp (lambda () (query-set tcp-ports (tcp-port-allocation $p _) p)))
+
+  (spawn #:name 'kernel-tcp-driver
+   (define local-ips (query-local-ip-addresses))
+
+   (define/query-set active-state-vectors ($ q (tcp-quad _ _ _ _)) q)
+
+   (define (state-vector-active? statevec)
+     (set-member? (active-state-vectors) statevec))
+
+   (define (analyze-incoming-packet src-ip dst-ip body)
+     (bit-string-case body
+       ([ (src-port :: integer bytes 2)
+          (dst-port :: integer bytes 2)
+          (sequence-number :: integer bytes 4)
+          (ack-number :: integer bytes 4)
+          (data-offset :: integer bits 4)
+          (reserved :: integer bits 3)
+          (ns :: integer bits 1)
+          (cwr :: integer bits 1)
+          (ece :: integer bits 1)
+          (urg :: integer bits 1)
+          (ack :: integer bits 1)
+          (psh :: integer bits 1)
+          (rst :: integer bits 1)
+          (syn :: integer bits 1)
+          (fin :: integer bits 1)
+          (window-size :: integer bytes 2)
+          (checksum :: integer bytes 2) ;; TODO: check checksum
+          (urgent-pointer :: integer bytes 2)
+          (rest :: binary) ]
+        (let* ((flags (set))
+               (statevec (tcp-quad src-ip src-port dst-ip dst-port))
+               (old-active-state-vectors (active-state-vectors))
+               (spawn-needed? (and (not (state-vector-active? statevec))
+                                   (zero? rst)))) ;; don't bother spawning if it's a rst
+          (define-syntax-rule (set-flags! v ...)
+            (begin (unless (zero? v) (set! flags (set-add flags 'v))) ...))
+          (set-flags! ns cwr ece urg ack psh rst syn fin)
+          (bit-string-case rest
+            ([ (opts :: binary bytes (- (* data-offset 4) 20))
+               (data :: binary) ]
+             (let ((packet (tcp-packet #t
+                                       statevec
+                                       sequence-number
+                                       ack-number
+                                       flags
+                                       window-size
+                                       (bit-string->bytes opts)
+                                       (bit-string->bytes data))))
+               (log-netstack/tcp-debug "TCP ~a" (summarize-tcp-packet packet))
+               (when spawn-needed?
+                 (log-netstack/tcp-debug "  - spawn needed!")
+                 (active-state-vectors (set-add (active-state-vectors) statevec))
+                 (spawn-state-vector #f (tcp-address (ip-address->hostname src-ip) src-port) statevec))
+               (send! packet)))
+            (else #f))))
+       (else #f)))
+
+   (begin/dataflow
+     (log-netstack/tcp-debug "SCN yielded statevecs ~v and local-ips ~v"
+                             (active-state-vectors)
+                             (local-ips)))
+
+   (define (deliver-outbound-packet p)
+     (match-define (tcp-packet #f
+                               (tcp-quad dst-ip    ;; \__ remote
+                                         dst-port  ;; /
+                                         src-ip    ;; \__ local
+                                         src-port) ;; /
+                               sequence-number
+                               ack-number
+                               flags
+                               window-size
+                               options
+                               data)
+       p)
+     (log-netstack/tcp-debug "TCP ~a" (summarize-tcp-packet p))
+     (define (flag-bit sym) (if (set-member? flags sym) 1 0))
+     (define payload (bit-string (src-port :: integer bytes 2)
+                                 (dst-port :: integer bytes 2)
+                                 (sequence-number :: integer bytes 4)
+                                 (ack-number :: integer bytes 4)
+                                 ((+ 5 (quotient (bit-string-byte-count options) 4))
+                                  :: integer bits 4) ;; TODO: enforce 4-byte alignment
+                                 (0 :: integer bits 3)
+                                 ((flag-bit 'ns) :: integer bits 1)
+                                 ((flag-bit 'cwr) :: integer bits 1)
+                                 ((flag-bit 'ece) :: integer bits 1)
+                                 ((flag-bit 'urg) :: integer bits 1)
+                                 ((flag-bit 'ack) :: integer bits 1)
+                                 ((flag-bit 'psh) :: integer bits 1)
+                                 ((flag-bit 'rst) :: integer bits 1)
+                                 ((flag-bit 'syn) :: integer bits 1)
+                                 ((flag-bit 'fin) :: integer bits 1)
+                                 (window-size :: integer bytes 2)
+                                 (0 :: integer bytes 2) ;; checksum location
+                                 (0 :: integer bytes 2) ;; TODO: urgent pointer
+                                 (data :: binary)))
+     (define pseudo-header (bit-string (src-ip :: binary bytes 4)
+                                       (dst-ip :: binary bytes 4)
+                                       0
+                                       PROTOCOL-TCP
+                                       ((bit-string-byte-count payload) :: integer bytes 2)))
+     (send! (ip-packet #f src-ip dst-ip PROTOCOL-TCP #""
+                       (ip-checksum 16 payload #:pseudo-header pseudo-header))))
+
+   (on (message (ip-packet $source-if $src $dst PROTOCOL-TCP _ $body))
+       (when (and source-if ;; source-if == #f iff packet originates locally
+                  (set-member? (local-ips) dst))
+         (analyze-incoming-packet src dst body)))
+
+   (on (message ($ p (tcp-packet #f _ _ _ _ _ _ _)))
+       (deliver-outbound-packet p))
+
+   (during (observe (tcp-connection _ (tcp-listener $port)))
+     (assert (tcp-port-allocation port (tcp-listener port))))
+
+   (on (asserted (tcp-connection $id (tcp-address $remote-host $remote-port)))
+       (define port (allocate-port! 'tcp))
+       ;; TODO: Choose a sensible IP address for the outbound
+       ;; connection. We don't have enough information to do this
+       ;; well at the moment, so just pick some available local IP
+       ;; address.
+       ;;
+       ;; Interesting note: In some sense, the right answer is a
+       ;; *wildcard*. This would give us a form of mobility, where IP
+       ;; addresses only route to a given bucket-of-state and ONLY the
+       ;; port number selects a substate therein. That's not how TCP
+       ;; is defined however so we can't do that.
+       (define appropriate-ip (set-first (local-ips)))
+       (define appropriate-host (ip-address->hostname appropriate-ip))
+       (define remote-ip (ip-string->ip-address remote-host))
+       (define q (tcp-quad remote-ip remote-port appropriate-ip port))
+       (active-state-vectors (set-add (active-state-vectors) q))
+       (spawn-state-vector #t id q))
+
+   (during/spawn (observe (tcp-in-line $id _))
+     #:name (list 'drivers/tcp 'line-reader id)
+     (local-require (only-in syndicate/support/bytes bytes-index))
+     (field [buffer #""])
+     (on (message (tcp-in id $bs)) (buffer (bytes-append (buffer) bs)))
+     (begin/dataflow
+       (define newline-pos (bytes-index (buffer) (char->integer #\newline)))
+       (when newline-pos
+         (define line (subbytes (buffer) 0 newline-pos))
+         (buffer (subbytes (buffer) (+ newline-pos 1)))
+         (send! (tcp-in-line id line)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Per-connection state vector process
+
+;;---------------------------------------------------------------------------
+;; From the RFC:
+;;
+;;     Send Sequence Variables
+;;
+;;       SND.UNA - send unacknowledged
+;;       SND.NXT - send next
+;;       SND.WND - send window
+;;       SND.UP  - send urgent pointer
+;;       SND.WL1 - segment sequence number used for last window update
+;;       SND.WL2 - segment acknowledgment number used for last window
+;;                 update
+;;       ISS     - initial send sequence number
+;;
+;;     Receive Sequence Variables
+;;
+;;       RCV.NXT - receive next
+;;       RCV.WND - receive window
+;;       RCV.UP  - receive urgent pointer
+;;       IRS     - initial receive sequence number
+;;
+;;   The following diagrams may help to relate some of these variables to
+;;   the sequence space.
+;;
+;;   Send Sequence Space
+;;
+;;                    1         2          3          4
+;;               ----------|----------|----------|----------
+;;                      SND.UNA    SND.NXT    SND.UNA
+;;                                           +SND.WND
+;;
+;;         1 - old sequence numbers which have been acknowledged
+;;         2 - sequence numbers of unacknowledged data
+;;         3 - sequence numbers allowed for new data transmission
+;;         4 - future sequence numbers which are not yet allowed
+;;
+;;                           Send Sequence Space
+;;
+;;                                Figure 4.
+;;
+;;   The send window is the portion of the sequence space labeled 3 in
+;;   figure 4.
+;;
+;;   Receive Sequence Space
+;;
+;;                        1          2          3
+;;                    ----------|----------|----------
+;;                           RCV.NXT    RCV.NXT
+;;                                     +RCV.WND
+;;
+;;         1 - old sequence numbers which have been acknowledged
+;;         2 - sequence numbers allowed for new reception
+;;         3 - future sequence numbers which are not yet allowed
+;;
+;;                          Receive Sequence Space
+;;
+;;                                Figure 5.
+;;
+;;   The receive window is the portion of the sequence space labeled 2 in
+;;   figure 5.
+;;
+;;   There are also some variables used frequently in the discussion that
+;;   take their values from the fields of the current segment.
+;;
+;;     Current Segment Variables
+;;
+;;       SEG.SEQ - segment sequence number
+;;       SEG.ACK - segment acknowledgment number
+;;       SEG.LEN - segment length
+;;       SEG.WND - segment window
+;;       SEG.UP  - segment urgent pointer
+;;       SEG.PRC - segment precedence value
+;;
+;;---------------------------------------------------------------------------
+
+(struct buffer (data ;; bit-string
+		seqn ;; names leftmost byte in data
+		window ;; counts bytes from leftmost byte in data
+		finished?) ;; boolean: true after FIN
+	#:transparent)
+
+;; Regarding acks:
+;;
+;; - we send an ack number that is (buffer-seqn (inbound)) plus the
+;;   number of buffered bytes.
+;;
+;; - acks received allow us to advance (buffer-seqn (outbound)) (that
+;;   is, SND.UNA) to that point, discarding buffered data to do so.
+
+;; Regarding windows:
+;;
+;; - (buffer-window (outbound)) is the size of the peer's receive
+;;   window. Do not allow more than this many bytes to be
+;;   unacknowledged on the wire.
+;;
+;; - (buffer-window (inbound)) is the size of our receive window. The
+;;   peer should not exceed this; we should ignore data received that
+;;   extends beyond this. Once we implement flow control locally
+;;   (ahem) we should move this around, but at present it is fixed.
+
+;; TODO: Zero receive window probe when we have something to say.
+
+(define (buffer-push b data)
+  (struct-copy buffer b [data (bit-string-append (buffer-data b) data)]))
+
+(define inbound-buffer-limit 65535)
+(define maximum-segment-size 536) ;; bytes
+(define maximum-segment-lifetime-sec (* 2 60)) ;; two minutes; 2MSL is TIME-WAIT timeout
+(define user-timeout-msec (* 5 60 1000)) ;; per RFC 793, this should be per-connection, but I
+        ;; cheat; RFC 793 says "the present global default is five minutes", which is
+        ;; reasonable to be getting on with
+
+(define (seq+ a b) (bitwise-and #xffffffff (+ a b)))
+
+;; Always positive
+(define (seq- larger smaller)
+  (if (< larger smaller) ;; wraparound has occurred
+      (+ (- larger smaller) #x100000000)
+      (- larger smaller)))
+
+(define (seq> a b)
+  (not (seq>= b a)))
+
+(define (seq>= a b)
+  (< (seq- a b) #x80000000))
+
+(define (seq-min a b) (if (seq> a b) b a))
+(define (seq-max a b) (if (seq> a b) a b))
+
+(module+ test
+  (check-equal? (seq+ 41724780 1) 41724781)
+  (check-equal? (seq+ 0 1) 1)
+  (check-equal? (seq+ #x80000000 1) #x80000001)
+  (check-equal? (seq+ #xffffffff 1) #x00000000)
+
+  (check-equal? (seq> 41724780 41724780) #f)
+  (check-equal? (seq> 41724781 41724780) #t)
+  (check-equal? (seq> 41724780 41724781) #f)
+
+  (check-equal? (seq> 0 0) #f)
+  (check-equal? (seq> 1 0) #t)
+  (check-equal? (seq> 0 1) #f)
+
+  (check-equal? (seq> #x80000000 #x80000000) #f)
+  (check-equal? (seq> #x80000001 #x80000000) #t)
+  (check-equal? (seq> #x80000000 #x80000001) #f)
+
+  (check-equal? (seq> #xffffffff #xffffffff) #f)
+  (check-equal? (seq> #x00000000 #xffffffff) #t)
+  (check-equal? (seq> #xffffffff #x00000000) #f)
+
+  (check-equal? (seq>= 41724780 41724780) #t)
+  (check-equal? (seq>= 41724781 41724780) #t)
+  (check-equal? (seq>= 41724780 41724781) #f)
+
+  (check-equal? (seq>= 0 0) #t)
+  (check-equal? (seq>= 1 0) #t)
+  (check-equal? (seq>= 0 1) #f)
+
+  (check-equal? (seq>= #x80000000 #x80000000) #t)
+  (check-equal? (seq>= #x80000001 #x80000000) #t)
+  (check-equal? (seq>= #x80000000 #x80000001) #f)
+
+  (check-equal? (seq>= #xffffffff #xffffffff) #t)
+  (check-equal? (seq>= #x00000000 #xffffffff) #t)
+  (check-equal? (seq>= #xffffffff #x00000000) #f))
+
+(define (spawn-state-vector outbound? connection-id q)
+  (match-define (tcp-quad remote-ip remote-port local-ip local-port) q)
+
+  (spawn #:name (list 'tcp-state-vector
+                      (ip-address->hostname remote-ip)
+                      remote-port
+                      (ip-address->hostname local-ip)
+                      local-port)
+   (define root-facet (current-facet))
+
+   (assert (tcp-port-allocation local-port
+                                (tcp-address (ip-address->hostname remote-ip) remote-port)))
+
+   (define initial-outbound-seqn
+     ;; Yuck
+     (inexact->exact (truncate (* #x100000000 (random)))))
+
+   (field [outbound (buffer #"!" initial-outbound-seqn 0 #f)] ;; dummy data at SYN position
+          [send-next initial-outbound-seqn] ;; SND.NXT
+          [high-water-mark initial-outbound-seqn]
+
+          [inbound (buffer #"" #f inbound-buffer-limit #f)]
+          [transmission-needed? #f]
+          [syn-acked? #f]
+          [fin-seen? #f]
+          [unblocked? #f]
+
+          [latest-peer-activity-time (current-inexact-milliseconds)]
+          ;; ^ the most recent time we heard from our peer
+          [user-timeout-base-time (current-inexact-milliseconds)]
+          ;; ^ when the index of the first outbound unacknowledged byte changed
+
+          ;; RFC 6298
+          [rtt-estimate #f] ;; milliseconds; "SRTT"
+          [rtt-mean-deviation #f] ;; milliseconds; "RTTVAR"
+          [retransmission-timeout 1000] ;; milliseconds
+          [retransmission-deadline #f]
+          [rtt-estimate-seqn-target #f]
+          [rtt-estimate-start-time #f]
+          )
+
+   (define (next-expected-seqn)
+     (define b (inbound))
+     (define v (buffer-seqn b))
+     (and v (seq+ v (bit-string-byte-count (buffer-data b)))))
+
+   (define (set-inbound-seqn! seqn)
+     (inbound (struct-copy buffer (inbound) [seqn seqn])))
+
+   (define (incorporate-segment! data)
+     (when (not (buffer-finished? (inbound)))
+       (inbound (buffer-push (inbound) data))))
+
+   (define (deliver-inbound-locally!)
+     (define b (inbound))
+     (when (not (bit-string-empty? (buffer-data b)))
+       (define chunk (bit-string->bytes (buffer-data b)))
+       (send! (tcp-in connection-id chunk))
+       (inbound (struct-copy buffer b
+                  [data #""]
+                  [seqn (seq+ (buffer-seqn b) (bytes-length chunk))]))))
+
+   ;; -> Void
+   (define (check-fin!)
+     (define b (inbound))
+     (when (not (buffer-finished? b))
+       (unless (bit-string-empty? (buffer-data b)) ;; assured by deliver-inbound-locally
+         (error 'check-fin "Nonempty inbound buffer"))
+       (when (fin-seen?)
+         (log-netstack/tcp-debug "Closing inbound stream.")
+         (inbound (struct-copy buffer b
+                    [seqn (seq+ (buffer-seqn b) 1)] ;; reliable: count fin as a byte
+                    [finished? #t]))
+         (transmission-needed? #t)))) ;; we must send an ack
+
+   (define (connected?)
+     (and (syn-acked?) ;; the SYN we sent has been acked by the remote peer
+          (not (buffer-finished? (inbound))))) ;; the remote peer hasn't sent a FIN
+
+   (on (asserted (tcp-accepted connection-id))
+       (unblocked? #t))
+
+   (begin/dataflow
+     (when (and (connected?) (unblocked?))
+       (deliver-inbound-locally!)
+       (check-fin!)))
+
+   ;; -> Void
+   (define (arm-retransmission-timer!)
+     (log-netstack/tcp-debug "Arming retransmission timer (~a ms)" (retransmission-timeout))
+     (retransmission-deadline (+ (current-inexact-milliseconds) (retransmission-timeout))))
+
+   ;; Timestamp -> Void
+   (define (start-rtt-estimate! now)
+     (define target (send-next))
+     (when (seq>= target (high-water-mark))
+       (log-netstack/tcp-debug "Starting RTT estimation; target seqn is ~a" target)
+       (rtt-estimate-start-time now)
+       (rtt-estimate-seqn-target target)))
+
+   ;; -> Void
+   (define (reset-rtt-estimate!)
+     (rtt-estimate-start-time #f)
+     (rtt-estimate-seqn-target #f))
+
+   ;; Timestamp -> Void
+   (define (finish-rtt-estimate! now)
+     (define rtt-measurement (- now (rtt-estimate-start-time)))
+     (reset-rtt-estimate!)
+     (log-netstack/tcp-debug "RTT measurement: ~a ms" rtt-measurement)
+     ;; RFC 6298 Section 2.
+     (cond [(rtt-estimate) => ;; we have a previous estimate, RFC 6298 rule (2.3)
+            (lambda (prev-estimate)
+              (rtt-mean-deviation (+ (* 0.75 (rtt-mean-deviation))
+                                     (* 0.25 (abs (- rtt-measurement prev-estimate)))))
+              (rtt-estimate (+ (* 0.875 prev-estimate)
+                               (* 0.125 rtt-measurement))))]
+           [else ;; no previous estimate, RFC 6298 rule (2.2) applies
+            (rtt-estimate rtt-measurement)
+            (rtt-mean-deviation (/ rtt-measurement 2))])
+     (default-retransmission-timeout!)
+     (log-netstack/tcp-debug "RTT measurement ~a ms; estimate ~a ms; mean deviation ~a ms; RTO ~a ms"
+                             rtt-measurement
+                             (rtt-estimate)
+                             (rtt-mean-deviation)
+                             (retransmission-timeout)))
+
+   (define (default-retransmission-timeout!)
+     (retransmission-timeout
+      (max 200 ;; RFC 6298 rule (2.4), but cribbing from Linux's 200ms minimum
+           (min 60000 ;; (2.5)
+                (+ (rtt-estimate) (* 4 (rtt-mean-deviation))))))) ;; (2.2), (2.3)
+
+   ;; Boolean SeqNum -> Void
+   (define (discard-acknowledged-outbound! ack? ackn)
+     (when ack?
+       (let* ((b (outbound))
+              (base (buffer-seqn b))
+              (ackn (seq-min ackn (high-water-mark)))
+              (ackn (seq-max ackn base))
+              (dist (seq- ackn base)))
+         (user-timeout-base-time (current-inexact-milliseconds))
+         (when (positive? dist)
+           (when (not (syn-acked?)) (syn-acked? #t))
+           (log-netstack/tcp-debug "******** ackn ~a; send-next ~a; high-water-mark ~a"
+                                   ackn
+                                   (send-next)
+                                   (high-water-mark))
+           (when (seq> ackn (send-next)) (send-next ackn))
+           (when (and (rtt-estimate-seqn-target) (seq>= ackn (rtt-estimate-seqn-target)))
+             (finish-rtt-estimate! (current-inexact-milliseconds)))
+
+           (define remaining-data (bit-string-drop (buffer-data b) (* dist 8))) ;; bit offset!
+           (outbound (struct-copy buffer b [data remaining-data] [seqn ackn]))
+
+           (default-retransmission-timeout!)
+           (log-netstack/tcp-debug "Positive distance moved by ack, RTO now ~a"
+                                   (retransmission-timeout))
+           (arm-retransmission-timer!)))))
+
+   ;; Nat -> Void
+   (define (update-outbound-window! peer-window)
+     (log-netstack/tcp-debug "Peer's receive-window is now ~a" peer-window)
+     (outbound (struct-copy buffer (outbound) [window peer-window])))
+
+   ;; True iff there is no queued-up data waiting either for
+   ;; transmission or (if transmitted already) for acknowledgement.
+   (define (all-output-acknowledged?)
+     (bit-string-empty? (buffer-data (outbound))))
+
+   (define (close-outbound-stream!)
+     (log-netstack/tcp-debug "Closing outbound stream.")
+     (define b (outbound))
+     (when (not (buffer-finished? b))
+       (outbound (struct-copy buffer (buffer-push b #"!") ;; dummy FIN byte
+                   [finished? #t]))
+       (transmission-needed? #t))) ;; the FIN machinery is awkwardly
+                                   ;; different from the usual
+                                   ;; advance-based decision on
+                                   ;; whether to send a packet or not
+
+   ;; SeqNum Boolean Boolean Bytes -> TcpPacket
+   (define (build-outbound-packet seqn mention-syn? mention-fin? payload)
+     (define ackn (next-expected-seqn))
+     (define window (min 65535 ;; limit of field width
+                         (max 0 ;; can't be negative
+                              (- (buffer-window (inbound))
+                                 (bit-string-byte-count (buffer-data (inbound)))))))
+
+     (define flags (set))
+     (when ackn         (set! flags (set-add flags 'ack)))
+     (when mention-syn? (set! flags (set-add flags 'syn)))
+     (when mention-fin? (set! flags (set-add flags 'fin)))
+     (tcp-packet #f q seqn (or ackn 0) flags window #"" payload))
+
+   (define (outbound-data-chunk offset length)
+     (bit-string-take (bit-string-drop (buffer-data (outbound)) (* offset 8)) (* length 8)))
+
+   ;; Transmit acknowledgements and outbound data.
+   (begin/dataflow
+     (define in-flight-count (seq- (send-next) (buffer-seqn (outbound))))
+
+     (define-values (mention-syn? ;; whether to mention SYN
+                     payload-size ;; how many bytes of payload data to include
+                     mention-fin? ;; whether to mention FIN
+                     advance)     ;; how far to advance send-next
+       (if (syn-acked?)
+           (let* ((effective-window (max 0 (- (buffer-window (outbound)) in-flight-count)))
+                  (stream-ended? (buffer-finished? (outbound)))
+                  (max-advance (- (bit-string-byte-count (buffer-data (outbound))) in-flight-count))
+                  (payload-size (min maximum-segment-size effective-window max-advance)))
+             (if (and stream-ended? ;; there's a FIN enqueued,
+                      (positive? payload-size) ;; we aren't sending nothing at all,
+                      (= payload-size max-advance)) ;; and our payload would cover the FIN
+                 (values #f (- payload-size 1) #t payload-size)
+                 (values #f payload-size #f payload-size)))
+           (cond [(= in-flight-count 0) (values #t 0 #f 1)]
+                 [(= in-flight-count 1) (values #t 0 #f 0)]
+                 [else (error 'send-outbound!
+                              "Invalid state: send-next had advanced too far before SYN")])))
+
+     (when (and (or (next-expected-seqn) outbound?)
+                ;; ^ Talk only either if: we know the peer's seqn, or
+                ;; we don't, but we're an outbound connection rather
+                ;; than a listener.
+                (or (transmission-needed?)
+                    (positive? advance))
+                ;; ^ ... and we have something to say. Something to
+                ;; ack, or something to send.
+                )
+       (define packet-seqn (if mention-syn? (buffer-seqn (outbound)) (send-next)))
+       (define packet (build-outbound-packet packet-seqn
+                                             mention-syn?
+                                             mention-fin?
+                                             (outbound-data-chunk in-flight-count payload-size)))
+       (when (positive? advance)
+         (define new-send-next (seq+ (send-next) advance))
+         (send-next new-send-next)
+         (when (seq> new-send-next (high-water-mark))
+           (high-water-mark new-send-next)))
+       (when (transmission-needed?)
+         (transmission-needed? #f))
+
+       ;; (log-netstack/tcp-debug " sending ~v" packet)
+       (send! packet)
+       ;; (if (> (random) 0.5)
+       ;;     (begin (log-netstack/tcp-debug "Send ~a" (summarize-tcp-packet packet))
+       ;;            (send! packet))
+       ;;     (log-netstack/tcp-debug "Drop ~a" (summarize-tcp-packet packet)))
+
+       (when (or mention-syn? mention-fin? (positive? advance))
+         (when (not (retransmission-deadline))
+           (arm-retransmission-timer!))
+         (when (not (rtt-estimate-start-time))
+           (start-rtt-estimate! (current-inexact-milliseconds))))))
+
+   (begin/dataflow
+     (when (and (retransmission-deadline) (all-output-acknowledged?))
+       (log-netstack/tcp-debug "All output acknowledged; disarming retransmission timer")
+       (retransmission-deadline #f)))
+
+   (on #:when (retransmission-deadline) (asserted (later-than (retransmission-deadline)))
+     (send-next (buffer-seqn (outbound)))
+     (log-netstack/tcp-debug "Retransmission deadline fired, RTO was ~a; reset to ~a"
+                             (retransmission-timeout)
+                             (send-next))
+     (update-outbound-window! maximum-segment-size) ;; temporary. Will reopen on next ack
+     (transmission-needed? #t)
+     (retransmission-deadline #f)
+     (reset-rtt-estimate!) ;; give up on current RTT estimation
+     (retransmission-timeout (min 64000 (* 2 (retransmission-timeout))))
+     (log-netstack/tcp-debug "  RTO now ~a" (retransmission-timeout)))
+
+   (define (reset! seqn ackn)
+     (define reset-packet (tcp-packet #f q seqn ackn (set 'ack 'rst) 0 #"" #""))
+     (log-netstack/tcp-warning "Reset ~a" (summarize-tcp-packet reset-packet))
+     (stop-facet root-facet)
+     (send! reset-packet))
+
+   (assert q) ;; Declare that this state vector exists
+   (on-start (log-netstack/tcp-info "Starting ~a" (tcp-quad->string (not outbound?) q)))
+   (on-stop  (log-netstack/tcp-info "Stopping ~a" (tcp-quad->string (not outbound?) q)))
+
+   (stop-when #:when (and (buffer-finished? (outbound))
+                          (buffer-finished? (inbound))
+                          (all-output-acknowledged?))
+              (asserted (later-than (+ (latest-peer-activity-time)
+                                       (* 2 1000 maximum-segment-lifetime-sec))))
+    ;; Everything is cleanly shut down, and we just need to wait a while for unexpected
+    ;; packets before we release the state vector.
+    )
+
+   (stop-when #:when (not (all-output-acknowledged?))
+              (asserted (later-than (+ (user-timeout-base-time) user-timeout-msec)))
+    ;; We've been plaintively retransmitting for user-timeout-msec without hearing anything
+    ;; back; this is a crude approximation of the real condition for TCP_USER_TIMEOUT, but
+    ;; it will do for now? TODO
+    (log-netstack/tcp-warning "TCP_USER_TIMEOUT fired."))
+
+   (define/query-value listener-listening?
+     #f (observe (tcp-connection _ (tcp-listener local-port))) #t)
+
+   (define (trigger-ack!)
+     (transmission-needed? #t))
+
+   (on (message (tcp-packet #t q $seqn $ackn $flags $window $options $data))
+       (define expected (next-expected-seqn))
+       (define is-syn? (set-member? flags 'syn))
+       (define is-fin? (set-member? flags 'fin))
+       (cond
+         [(set-member? flags 'rst)
+          (stop-facet root-facet
+                      (when (not (connected?)) ;; --> rejected!
+                        (define e (exn:fail:network
+                                   (format "~a: Connection rejected" (tcp-quad->string #f q))
+                                   (current-continuation-marks)))
+                        (react (assert (tcp-rejected connection-id e))
+                               (on-start (sleep 5)
+                                         (stop-current-facet)))))]
+         [(and (not expected) ;; no syn yet
+               (or (not is-syn?) ;; and this isn't it
+                   (and (not (listener-listening?)) ;; or it is, but no listener...
+                        (not outbound?)))) ;; ...and we're not an outbound connection
+          (reset! ackn ;; this is *our* seqn
+                  (seq+ seqn (+ (if is-syn? 1 0) (if is-fin? 1 0)))
+                  ;; ^^ this is what we should acknowledge...
+                  )]
+         [else
+          (cond
+            [(not expected) ;; haven't seen syn yet, but we know this is it
+             (set-inbound-seqn! (seq+ seqn 1))
+             (incorporate-segment! data)
+             (trigger-ack!)]
+            [(= expected seqn)
+             (incorporate-segment! data)
+             (when (positive? (bit-string-byte-count data)) (trigger-ack!))]
+            [else
+             (trigger-ack!)])
+          (when is-fin? (fin-seen? #t))
+          (discard-acknowledged-outbound! (set-member? flags 'ack) ackn)
+          (update-outbound-window! window)
+          (latest-peer-activity-time (current-inexact-milliseconds))]))
+
+   (on (message (tcp-out connection-id $bs))
+       ;; (log-netstack/tcp-debug "GOT MORE STUFF TO DELIVER ~v" bs)
+
+       (when (all-output-acknowledged?)
+         ;; Only move user-timeout-base-time if there wasn't
+         ;; already some outstanding output.
+         (user-timeout-base-time (current-inexact-milliseconds)))
+
+       (outbound (buffer-push (outbound) bs)))
+
+   (if outbound?
+       (begin
+         (assert #:when (connected?) (tcp-accepted connection-id))
+         (on (retracted (tcp-connection connection-id (tcp-address _ _)))
+             (close-outbound-stream!)))
+       (begin
+         (assert #:when (connected?) (tcp-connection connection-id (tcp-listener local-port)))
+         (on (asserted (tcp-rejected connection-id _))
+             ;; In principle, we have the flexibility to delay
+             ;; replying to SYN until userland decides whether or not
+             ;; to accept an incoming connection! We don't do that yet
+             ;; though.
+             (close-outbound-stream!))
+         (on (retracted (tcp-accepted connection-id))
+             (close-outbound-stream!))
+         (on-start (sleep 5)
+                   (when (not (unblocked?))
+                     (log-netstack/tcp-error "TCP relay process ~a timed out waiting for peer" q)
+                     (stop-facet root-facet)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(spawn-tcp-driver)

imperative/examples/netstack/udp.rkt

@@ -0,0 +1,133 @@
+#lang imperative-syndicate
+
+(provide (struct-out udp-remote-address)
+	 (struct-out udp-handle)
+	 (struct-out udp-listener)
+	 udp-address?
+	 udp-local-address?
+	 (struct-out udp-packet)
+	 spawn-udp-driver)
+
+(require racket/set)
+(require bitsyntax)
+
+(require "dump-bytes.rkt")
+(require "checksum.rkt")
+(require "configuration.rkt")
+(require/activate "ip.rkt")
+(require "port-allocator.rkt")
+
+;; udp-address/udp-address : "kernel" udp connection state machines
+;; udp-handle/udp-address : "user" outbound connections
+;; udp-listener/udp-address : "user" inbound connections
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Protocol messages
+
+(struct udp-remote-address (host port) #:prefab)
+(struct udp-handle (id) #:prefab)
+(struct udp-listener (port) #:prefab)
+
+(define (udp-address? x)
+  (or (udp-remote-address? x)
+      (udp-local-address? x)))
+
+(define (udp-local-address? x)
+  (or (udp-handle? x)
+      (udp-listener? x)))
+
+;; USER-level protocol
+(struct udp-packet (source destination body) #:prefab)
+
+;; KERNEL-level protocol
+(struct udp-datagram (source-ip source-port destination-ip destination-port body) #:prefab)
+(struct udp-port-allocation (port handle) #:prefab) ;; (udp-port-allocation Number UdpLocalAddress)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; User-accessible driver startup
+
+(define (spawn-udp-driver)
+  (spawn-port-allocator 'udp (lambda () (query-set udp-ports (udp-port-allocation $p _) p)))
+  (spawn-kernel-udp-driver)
+  (spawn #:name 'udp-driver
+   (on (asserted (observe (udp-packet _ ($ h (udp-listener _)) _)))
+       (spawn-udp-relay (udp-listener-port h) h))
+   (on (asserted (observe (udp-packet _ ($ h (udp-handle _)) _)))
+       (spawn #:name (list 'udp-transient h)
+              (on-start (spawn-udp-relay (allocate-port! 'udp) h))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Relaying
+
+(define (spawn-udp-relay local-port local-user-addr)
+  (spawn #:name (list 'udp-relay local-port local-user-addr)
+         (on-start (log-info "Spawning UDP relay ~v / ~v" local-port local-user-addr))
+
+         (stop-when (retracted (observe (udp-packet _ local-user-addr _))))
+         (assert (udp-port-allocation local-port local-user-addr))
+
+         (during (host-route $ip _ _)
+                 (on (message (udp-datagram $source-ip $source-port ip local-port $bs))
+                     (send!
+                      (udp-packet (udp-remote-address (ip-address->hostname source-ip)
+                                                      source-port)
+                                  local-user-addr
+                                  bs))))
+
+         (define local-ips (query-local-ip-addresses))
+         (on (message (udp-packet local-user-addr (udp-remote-address $other-host $other-port) $bs))
+             ;; Choose arbitrary local IP address for outbound packet!
+             ;; TODO: what can be done? Must I examine the routing table?
+             (send! (udp-datagram (set-first (local-ips))
+                                  local-port
+                                  (ip-string->ip-address other-host)
+                                  other-port
+                                  bs)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Codec & kernel-level driver
+
+(define PROTOCOL-UDP 17)
+
+(define (spawn-kernel-udp-driver)
+  (spawn #:name 'kernel-udp-driver
+         (define local-ips (query-local-ip-addresses))
+
+         (on (message (ip-packet $source-if $src-ip $dst-ip PROTOCOL-UDP _ $body))
+             (when (and source-if (set-member? (local-ips) dst-ip))
+               (bit-string-case body
+                 ([ (src-port :: integer bytes 2)
+                    (dst-port :: integer bytes 2)
+                    (length :: integer bytes 2)
+                    (checksum :: integer bytes 2) ;; TODO: check checksum
+                    (data :: binary) ]
+                  (bit-string-case data
+                    ([ (payload :: binary bytes (- length 8)) ;; min UDP header size is 8 bytes
+                       (:: binary) ]
+                     (send! (udp-datagram src-ip src-port dst-ip dst-port
+                                          (bit-string->bytes payload))))
+                    (else #f)))
+                 (else #f))))
+
+         (on (message (udp-datagram $src-ip $src-port $dst-ip $dst-port $bs))
+             (when (set-member? (local-ips) src-ip)
+               (let* ((payload (bit-string (src-port :: integer bytes 2)
+                                           (dst-port :: integer bytes 2)
+                                           ((+ 8 (bit-string-byte-count bs))
+                                            :: integer bytes 2)
+                                           (0 :: integer bytes 2) ;; checksum location
+                                           (bs :: binary)))
+                      (pseudo-header (bit-string (src-ip :: binary bytes 4)
+                                                 (dst-ip :: binary bytes 4)
+                                                 0
+                                                 PROTOCOL-UDP
+                                                 ((bit-string-byte-count payload)
+                                                  :: integer bytes 2)))
+                      (checksummed-payload (ip-checksum #:pseudo-header pseudo-header
+                                                        6 payload)))
+                 (send! (ip-packet #f src-ip dst-ip PROTOCOL-UDP #""
+                                   checksummed-payload)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(spawn-udp-driver)

imperative/examples/santa.rkt

@@ -0,0 +1,83 @@
+#lang imperative-syndicate
+;; Santa Claus Problem
+;; https://www.schoolofhaskell.com/school/advanced-haskell/beautiful-concurrency/4-the-santa-claus-problem
+;; https://arxiv.org/pdf/1810.09613.pdf
+
+(require/activate imperative-syndicate/drivers/timer)
+(require racket/list)
+(require racket/set)
+
+(assertion-struct elf-has-a-problem (id))
+(assertion-struct reindeer-has-returned (id))
+
+(assertion-struct problem-resolved (id))
+(assertion-struct deliver-toys ())
+
+(define N-ELVES 10)
+(define ELF-GROUP-SIZE 3)
+(define N-REINDEER 9)
+
+(define (elf)
+  (define elf-self (gensym 'elf))
+  (spawn* #:name elf-self
+          (let work-industriously ()
+            (sleep (/ (random 1000) 1000.0))
+            (react (assert (elf-has-a-problem elf-self))
+                   (stop-when (asserted (problem-resolved elf-self))
+                     (work-industriously))))))
+
+(define (reindeer)
+  (define reindeer-self (gensym 'reindeer))
+  (spawn* #:name reindeer-self
+          (let holiday ()
+            (sleep (/ (random 9000) 1000.0))
+            (react (assert (reindeer-has-returned reindeer-self))
+                   (stop-when (asserted (deliver-toys))
+                     (react (stop-when (retracted (deliver-toys))
+                              (holiday))))))))
+
+(spawn* #:name 'santa
+        (define (wait-for-work)
+          (react (define/query-set stuck-elves (elf-has-a-problem $id) id)
+                 (define/query-set returned-reindeer (reindeer-has-returned $id) id)
+                 (stop-when-true (= (set-count (returned-reindeer)) N-REINDEER)
+                   (harness-reindeer))
+                 (stop-when-true (>= (set-count (stuck-elves)) ELF-GROUP-SIZE)
+                   (talk-to-elves (take (set->list (stuck-elves)) ELF-GROUP-SIZE)))))
+
+        (define (harness-reindeer)
+          (react (assert (deliver-toys))
+                 (stop-when (retracted (reindeer-has-returned _))
+                   (wait-for-work))))
+
+        (define (talk-to-elves elves)
+          (match elves
+            ['() (wait-for-work)]
+            [(cons elf remainder)
+             (react (assert (problem-resolved elf))
+                    (stop-when (retracted (elf-has-a-problem elf))
+                      (talk-to-elves remainder)))]))
+
+        (wait-for-work))
+
+(for [(i N-ELVES)] (elf))
+(for [(i N-REINDEER)] (reindeer))
+
+(spawn #:name 'narrator
+       (during (elf-has-a-problem $id)
+         (on-start (printf "~a has a problem!\n" id))
+         (on-stop  (printf "~a's problem is resolved. ~a returns to work.\n" id id)))
+
+       (on (asserted (reindeer-has-returned $id))
+           (printf "~a has returned from holiday and is ready to deliver toys!\n" id))
+
+       (on (retracted (reindeer-has-returned $id))
+           (printf "~a delivers toys with the other reindeer.\n" id)
+           (react (stop-when (retracted (deliver-toys))
+                    (printf "~a has been dismissed by Santa, and goes back on holiday.\n" id))))
+
+       (on (asserted (deliver-toys))
+           (printf "Santa does the delivery run!\n"))
+
+       (on (asserted (problem-resolved $id))
+           (printf "Santa resolves the problem of ~a.\n" id)))

imperative/examples/server-chat-client.rkt

@@ -0,0 +1,45 @@
+#lang imperative-syndicate
+
+(require/activate imperative-syndicate/distributed)
+(require/activate imperative-syndicate/drivers/external-event)
+(require (only-in racket/port read-line-evt))
+
+(assertion-struct Present (name))
+(message-struct Says (who what))
+
+(define host (make-parameter "localhost"))
+(define port (make-parameter 8001))
+(define scope (make-parameter "chat"))
+(define initial-username (make-parameter (symbol->string (strong-gensym 'chatter-))))
+
+(file-stream-buffer-mode (current-output-port) 'line)
+
+(module+ main
+  (require racket/cmdline)
+  (command-line #:once-each
+                ["--host" hostname "Server hostname" (host hostname)]
+                ["--port" portnum "Server port number" (port (string->number portnum))]
+                ["--scope" scopename "Server scope" (scope scopename)]
+                ["--nick" nick "User nickname" (initial-username nick)]))
+
+(spawn #:name 'main
+       (field [username (initial-username)])
+
+       (define root-facet (current-facet))
+       (define url (server-tcp-connection (host) (port) (scope)))
+       (during (server-connected url)
+         (on-start (log-info "Connected to server."))
+         (on-stop (log-info "Disconnected from server."))
+
+         (on (asserted (from-server url (Present $who))) (printf "~a arrived.\n" who))
+         (on (retracted (from-server url (Present $who))) (printf "~a departed.\n" who))
+         (on (message (from-server url (Says $who $what))) (printf "~a: ~a\n" who what))
+
+         (assert (to-server url (Present (username))))
+
+         (define stdin-evt (read-line-evt (current-input-port) 'any))
+         (on (message (inbound (external-event stdin-evt (list $line))))
+             (match line
+               [(? eof-object?) (stop-facet root-facet)]
+               [(pregexp #px"^/nick (.+)$" (list _ newnick)) (username newnick)]
+               [other (send! (to-server url (Says (username) other)))]))))

imperative/examples/simple-cross-layer.rkt

@@ -0,0 +1,12 @@
+#lang imperative-syndicate
+
+(assertion-struct greeting (text))
+
+(spawn #:name "A" (assert (greeting "Hi from outer space!")))
+(spawn #:name "B" (on (asserted (greeting $t))
+                      (printf "Outer dataspace: ~a\n" t)))
+
+(dataspace #:name "C"
+  (spawn #:name "D" (assert (outbound (greeting "Hi from inner!"))))
+  (spawn #:name "E" (on (asserted (inbound (greeting $t)))
+                        (printf "Inner dataspace: ~a\n" t))))

imperative/examples/sqlite.rkt

@@ -0,0 +1,36 @@
+#lang imperative-syndicate
+
+(require/activate imperative-syndicate/drivers/sqlite)
+(require/activate imperative-syndicate/drivers/timer)
+
+(define PATH "t.sqlite")
+(define DB (sqlite-db PATH))
+
+(spawn* (with-handlers [(exn:fail:filesystem? void)]
+          (delete-file PATH))
+        (react (assert DB))
+
+        (sqlite-create-table! DB "x" "y" "z")
+
+        (send! (sqlite-insert DB "x" (list 1 "yy") (gensym 'init)))
+        (send! (sqlite-insert DB "x" (list "yy" "hello") (gensym 'init)))
+        (send! (sqlite-insert DB "x" (list "yy" "goodbye") (gensym 'init)))
+        (send! (sqlite-insert DB "x" (list 1 "yy") (gensym 'init)))
+
+        (react
+         (during (sqlite-row DB "x" (list _ $key))
+           (during (sqlite-row DB "x" (list key $value))
+             (on-start (printf "+ ~a row in x: ~a\n" key value))
+             (on-stop (printf "- ~a row in x: ~a\n" key value))))
+         (during (sqlite-row DB "x" $columns)
+           (on-start (printf "+ row in x: ~a\n" columns))
+           (on-stop (printf "- row in x: ~a\n" columns))))
+
+        (sqlite-insert! DB "x" "a" "b")
+        (sqlite-insert! DB "x" "a" "c")
+        (sqlite-insert! DB "x" "yy" "b")
+        (sqlite-insert! DB "x" "yy" "c")
+        (sqlite-delete! DB "x" "a" "b")
+        (sqlite-delete! DB "x" (discard) "b")
+        (sqlite-delete! DB "x" "a" (discard))
+        (sqlite-delete! DB "x" (discard) "c"))

imperative/examples/stdin-echo.rkt

@@ -0,0 +1,10 @@
+#lang imperative-syndicate
+
+(require/activate imperative-syndicate/drivers/external-event)
+(require (only-in racket/port read-bytes-line-evt))
+
+(spawn (define stdin-evt (read-bytes-line-evt (current-input-port) 'any))
+       (on (message (inbound (external-event stdin-evt (list $line))))
+           (if (eof-object? line)
+               (stop-current-facet)
+               (printf "~a\n" line))))

imperative/examples/time.rkt

@@ -0,0 +1,21 @@
+#lang imperative-syndicate
+
+(require/activate imperative-syndicate/drivers/timer)
+
+(spawn #:name 'plain-timer-demo
+       (field [count 0])
+       (on-start (send! (set-timer 'main-timer 0 'relative)))
+       (on (message (timer-expired 'main-timer $now))
+           (log-info "main-timer expired at ~a" now)
+           (count (+ (count) 1))
+           (when (< (count) 5)
+             (send! (set-timer 'main-timer 500 'relative)))))
+
+(spawn #:name 'later-than-demo
+       (field [deadline (current-inexact-milliseconds)]
+              [count 0])
+       (on (asserted (later-than (deadline)))
+           (log-info "later-than ticked for deadline ~a" (deadline))
+           (count (+ (count) 1))
+           (when (< (count) 5)
+             (deadline (+ (deadline) 500)))))

imperative/examples/udp-echo.rkt

@@ -0,0 +1,10 @@
+#lang imperative-syndicate
+
+(require/activate imperative-syndicate/drivers/udp)
+
+(spawn (define s (udp-listener 5999))
+       (during s
+         (on (message (udp-packet $c s $body))
+             (printf "~a: ~v\n" c body)
+             (define reply (string->bytes/utf-8 (format "You said: ~a" body)))
+             (send! (udp-packet s c reply)))))

imperative/examples/udp-multicast.rkt

@@ -0,0 +1,38 @@
+#lang imperative-syndicate
+
+(require/activate imperative-syndicate/drivers/timer)
+(require/activate imperative-syndicate/drivers/udp)
+(require racket/random file/sha1)
+
+;; IANA offers guidelines for choosing multicast addresses [1].
+;;
+;; Reasonable candidates for local experimentation include:
+;;  - 224.0.1.20, "any private experiment"
+;;  - 233.252.0.0 - 233.252.0.255, "MCAST-TEST-NET", for examples and documentation (only)
+;;
+;; For production and semi-production use, registering an address may
+;; be an option; failing that, the Administratively Scoped Block
+;; (239/8; see RFC 2365) may be used:
+;;  - 239.255.0.0 - 239.255.255.255, "IPv4 Local Scope"
+;;  - 239.192.0.0 - 239.195.255.255, "Organization Local Scope"
+;;
+;; [1] http://www.iana.org/assignments/multicast-addresses/
+
+(define group-address "233.252.0.101") ;; falls within MCAST-TEST-NET
+(define group-port 5999) ;; make sure your firewall is open to UDP on this port
+
+(spawn (define me (bytes->hex-string (crypto-random-bytes 8)))
+       (define h (udp-listener group-port))
+       (during h
+         (assert (udp-multicast-group-member h group-address #f))
+         (assert (udp-multicast-loopback h #t))
+
+         (field [deadline (current-inexact-milliseconds)])
+         (on (asserted (later-than (deadline)))
+             (send! (udp-packet h
+                                (udp-remote-address group-address group-port)
+                                (string->bytes/utf-8 (format "~a ~a" me (deadline)))))
+             (deadline (+ (deadline) 1000)))
+
+         (on (message (udp-packet $source h $body))
+             (printf "~a: ~a\n" source body))))

imperative/examples/web-core.rkt

@@ -0,0 +1,84 @@
+#lang imperative-syndicate
+
+(require/activate imperative-syndicate/drivers/web)
+(require/activate imperative-syndicate/drivers/timer)
+
+(define server (http-server "localhost" 8081 #f))
+
+(define (button text link)
+  `(form ((method "POST") (action ,link)) (button ((type "submit")) ,text)))
+
+(define (redirect-response id url)
+  (http-response #:code 303 #:message #"See other"
+                 #:headers `((Location . ,url))
+                 id (xexpr->bytes/utf-8 `(html (a ((href ,url)) "continue")))))
+
+(spawn
+
+ (during (http-request $id $method $resource _ _ _)
+   (stop-when (asserted ($ details (http-request-peer-details id _ _ _ _)))
+     (log-info "~a: ~a ~v ~v" id method resource details)))
+
+ (during/spawn (http-request $id 'get (http-resource server '("" ())) _ _ _)
+   (assert (http-accepted id))
+   (assert (http-response id (xexpr->bytes/utf-8
+                              `(html
+                                (h1 "Hello")
+                                ,(button "Make a new counter" "/newcounter"))))))
+
+ (during/spawn (http-request $id 'post (http-resource server '("newcounter" ())) _ _ _)
+   (assert (http-accepted id))
+   (on-start (define counter-url (spawn-counter))
+             (react (assert (redirect-response id counter-url)))))
+
+ (during/spawn (http-request $id 'get (http-resource server '("chunked" ())) _ _ _)
+   (assert (http-accepted id))
+   (assert (http-response id 'chunked #:mime-type #"text/plain"))
+   (on-start (sleep 1)
+             (send! (http-response-chunk id #"One\n"))
+             (sleep 1)
+             (send! (http-response-chunk id #"Two\n"))
+             (sleep 1)
+             (send! (http-response-chunk id #"Three\n"))
+             (stop-current-facet)))
+
+ (during/spawn (http-request $id 'get (http-resource server '("ws-echo" ())) _ _ _)
+   (assert (http-accepted id))
+   (assert (http-response-websocket id))
+   (on (message (websocket-in id $body))
+       (log-info "~a sent: ~v" id body)
+       (send! (websocket-out id (format "You said: ~a" body))))
+   (on (message (websocket-in id "quit"))
+       (stop-current-facet))
+   (on-start (log-info "Starting websocket connection ~a" id))
+   (on-stop (log-info "Stopping websocket connection ~a" id)))
+ )
+
+(define (spawn-counter)
+  (define counter-id (symbol->string (gensym 'counter)))
+  (define counter-url (string-append "/" counter-id))
+  (begin0 counter-url
+    (spawn
+     #:name counter-id
+
+     (field [counter 0])
+
+     (during (http-request $id 'get (http-resource server `(,counter-id ())) _ _ _)
+       (assert (http-accepted id))
+       (assert
+        (http-response id (xexpr->bytes/utf-8
+                           `(html (h1 "Counter")
+                                  (p "The counter is: " ,(number->string (counter)))
+                                  ,(button "Increment" (string-append "/" counter-id "/inc"))
+                                  ,(button "Decrement" (string-append "/" counter-id "/dec"))
+                                  (p "(Return " (a ((href "/")) "home") ")"))))))
+
+     (during (http-request $id 'post (http-resource server `(,counter-id ("inc" ()))) _ _ _)
+       (assert (http-accepted id))
+       (on-start (counter (+ (counter) 1))
+                 (react (assert (redirect-response id counter-url)))))
+
+     (during (http-request $id 'post (http-resource server `(,counter-id ("dec" ()))) _ _ _)
+       (assert (http-accepted id))
+       (on-start (counter (- (counter) 1))
+                 (react (assert (redirect-response id counter-url))))))))

imperative/ground.rkt

@@ -0,0 +1,103 @@
+#lang racket/base
+;; Breaking the infinite tower of nested dataspaces, connecting to Racket at the fracture line.
+
+(provide current-ground-event-async-channel
+         ground-send!
+         ground-assert!
+         ground-retract!
+         signal-background-activity!
+         extend-ground-boot!
+         run-ground)
+
+(define-logger syndicate/ground)
+
+(require racket/async-channel)
+(require racket/set)
+(require racket/match)
+(require racket/list)
+(require "dataspace.rkt")
+(require "syntax.rkt")
+
+(define current-ground-event-async-channel (make-parameter #f))
+(define *ground-boot-extensions* '())
+
+(define (ground-enqueue! item)
+  (async-channel-put (current-ground-event-async-channel) item))
+
+(define (ground-send! body)
+  (ground-enqueue! (lambda (ac) (enqueue-send! ac body))))
+
+(define (ground-assert! assertion)
+  (ground-enqueue! (lambda (ac) (adhoc-assert! ac assertion))))
+
+(define (ground-retract! assertion)
+  (ground-enqueue! (lambda (ac) (adhoc-retract! ac assertion))))
+
+(define (signal-background-activity! delta)
+  (ground-enqueue! delta))
+
+(define (extend-ground-boot! proc)
+  (set! *ground-boot-extensions* (cons proc *ground-boot-extensions*)))
+
+(define (run-ground* boot-proc)
+  (define ch (make-async-channel))
+  (parameterize ((current-ground-event-async-channel ch))
+    (define ground-event-relay-actor #f)
+    (define background-activity-count 0)
+
+    (define (handle-ground-event-item item)
+      (match item
+        [(? procedure? proc)
+         (push-script! ground-event-relay-actor
+                       (lambda () (proc ground-event-relay-actor)))]
+        [(? number? delta)
+         (set! background-activity-count (+ background-activity-count delta))]))
+
+    (define (drain-external-events)
+      (define item (async-channel-try-get ch))
+      (when item
+        (handle-ground-event-item item)
+        (drain-external-events)))
+
+    (define ground-event-relay-evt
+      (handle-evt ch (lambda (item)
+                       (handle-ground-event-item item)
+                       (drain-external-events))))
+
+    (define ds (make-dataspace
+                (lambda ()
+                  (schedule-script! (current-actor)
+                                    (lambda ()
+                                      (spawn #:name 'ground-event-relay
+                                             (set! ground-event-relay-actor (current-actor))
+                                             ;; v Adds a dummy endpoint to keep this actor alive
+                                             (begin/dataflow (void)))))
+                  (schedule-script! (current-actor)
+                                    (lambda ()
+                                      (boot-proc)
+                                      (let ((extensions (reverse *ground-boot-extensions*)))
+                                        (set! *ground-boot-extensions* '())
+                                        (for [(p (in-list extensions))] (p))))))))
+
+    (let loop ()
+      (define work-remaining? (run-scripts! ds))
+      (define events-expected? (positive? background-activity-count))
+      (log-syndicate/ground-debug "GROUND: ~a; ~a background activities"
+                                  (if work-remaining? "busy" "idle")
+                                  background-activity-count)
+      (cond
+        [events-expected?
+         (sync ground-event-relay-evt (if work-remaining? (system-idle-evt) never-evt))
+         (loop)]
+        [work-remaining?
+         (sync ground-event-relay-evt (system-idle-evt))
+         (loop)]
+        [else
+         (sync (handle-evt ground-event-relay-evt (lambda _ (loop))) (system-idle-evt))]))))
+
+(define (run-ground boot-proc)
+  (if (equal? (getenv "SYNDICATE_PROFILE") "ground")
+      (let ()
+        (local-require profile)
+        (profile (run-ground* boot-proc)))
+      (run-ground* boot-proc)))

imperative/info.rkt

@@ -0,0 +1,4 @@
+#lang setup/infotab
+(define collection "imperative-syndicate")
+(define racket-launcher-names '("syndicate-server" "syndicate-server-debug"))
+(define racket-launcher-libraries '("bin/syndicate-server.rkt" "bin/syndicate-server-debug.rkt"))

imperative/lang.rkt

@@ -0,0 +1,116 @@
+#lang racket/base
+
+(provide (rename-out [module-begin #%module-begin])
+         activate
+         require/activate
+         current-ground-dataspace
+         current-activated-modules
+         begin-for-declarations ;; TODO: this seems like a horrible hack
+	 (except-out (all-from-out racket/base) #%module-begin sleep)
+	 (all-from-out racket/match)
+         (all-from-out "main.rkt")
+	 (for-syntax (all-from-out racket/base)))
+
+(require racket/match)
+(require "main.rkt")
+(require (for-syntax racket/base syntax/kerncase))
+
+(define-syntax (activate stx)
+  (syntax-case stx ()
+    [(_ module-path ...)
+     (syntax/loc stx
+       (begin
+         (let ()
+           (local-require (submod module-path syndicate-main))
+           (activate!))
+         ...))]))
+
+(define-syntax (require/activate stx)
+  (syntax-case stx ()
+    [(_ module-path ...)
+     (syntax/loc stx
+       (begin
+         (require module-path ...)
+         (activate module-path ...)))]))
+
+(define-syntax-rule (begin-for-declarations decl ...)
+  (begin decl ...))
+
+(define current-ground-dataspace (make-parameter #f))
+(define current-activated-modules (make-parameter #f))
+
+(define-syntax (module-begin stx)
+  (unless (eq? (syntax-local-context) 'module-begin)
+    (raise-syntax-error #f "allowed only around a module body" stx))
+  (syntax-case stx ()
+    [(_ forms ...)
+     (let ()
+
+       (define (accumulate-actions activation-forms final-forms forms)
+         (cond
+           [(null? forms)
+            (define final-stx
+              #`(#%module-begin
+                 ;----------------------------------------
+                 ; The final module has three pieces:
+                 ; - a `syndicate-main` submodule, for activation
+                 ; - a `main` submodule, for programs
+                 ; - actual definitions, for everything else.
+                 ; The `main` submodule is split into two pieces,
+                 ; in order to initialise defaults that can then
+                 ; be overridden by the module being compiled.
+
+                 (module+ syndicate-main
+                   (provide activate!* activate!)
+                   (define (activate!*)
+                     #,@(reverse activation-forms)
+                     (void))
+                   (define (activate!)
+                     (when (not (hash-has-key? (current-activated-modules) activate!*))
+                       (hash-set! (current-activated-modules) activate!* #t)
+                       (activate!*))))
+
+                 (module+ main (current-ground-dataspace run-ground))
+
+                 #,@(reverse final-forms)
+
+                 (module+ main
+                   (require (submod ".." syndicate-main))
+                   (parameterize ((current-activated-modules (make-hasheq)))
+                     ((current-ground-dataspace) activate!)))
+
+                 ;----------------------------------------
+                 ))
+            ;;(pretty-print (syntax->datum final-stx))
+            final-stx]
+
+           [else
+            (syntax-case (local-expand (car forms)
+                                       'module
+                                       (append (list #'module+
+                                                     #'begin-for-declarations)
+                                               (kernel-form-identifier-list))) ()
+              [(head rest ...)
+               (cond
+                 [(free-identifier=? #'head #'begin)
+                  (accumulate-actions activation-forms
+                                      final-forms
+                                      (append (syntax->list #'(rest ...)) (cdr forms)))]
+                 [(ormap (lambda (i) (free-identifier=? #'head i))
+                         (syntax->list #'(define-values define-syntaxes begin-for-syntax
+                                           module module* module+
+                                           #%module-begin
+                                           #%require #%provide
+                                           begin-for-declarations)))
+                  (accumulate-actions activation-forms
+                                      (cons (car forms) final-forms)
+                                      (cdr forms))]
+                 [else
+                  (accumulate-action (car forms) activation-forms final-forms (cdr forms))])]
+              [non-pair-syntax
+               (accumulate-action (car forms) activation-forms final-forms (cdr forms))])]))
+
+       (define (accumulate-action action activation-forms final-forms remaining-forms)
+	 (accumulate-actions (cons action activation-forms) final-forms remaining-forms))
+
+       (accumulate-actions '() '() (syntax->list #'(forms ...))))]))

imperative/main.rkt

@@ -0,0 +1,15 @@
+#lang racket/base
+
+(provide (all-from-out "dataspace.rkt")
+         (all-from-out "assertions.rkt")
+         (all-from-out "syntax.rkt")
+         (all-from-out "ground.rkt")
+         (all-from-out "relay.rkt"))
+
+(module reader syntax/module-reader imperative-syndicate/lang)
+
+(require "dataspace.rkt")
+(require "assertions.rkt")
+(require "syntax.rkt")
+(require "ground.rkt")
+(require "relay.rkt")

imperative/mc/mc-chat-client.rkt

@@ -0,0 +1,25 @@
+#lang imperative-syndicate
+
+(require/activate "udp-dataspace.rkt")
+(require/activate imperative-syndicate/drivers/external-event)
+(require (only-in racket/port read-bytes-line-evt))
+(require racket/random file/sha1)
+
+(message-struct speak (who what))
+(assertion-struct present (who))
+
+(spawn (define me (bytes->hex-string (crypto-random-bytes 8)))
+       (define stdin-evt (read-bytes-line-evt (current-input-port) 'any))
+
+       (assert (mcds-outbound (present me)))
+
+       (on (message (inbound (external-event stdin-evt (list $line))))
+           (if (eof-object? line)
+               (stop-current-facet)
+               (send! (mcds-outbound (speak me line)))))
+
+       (during (mcds-inbound (present $user))
+         (on-start (printf "~a arrived\n" user))
+         (on-stop  (printf "~a left\n" user))
+         (on (message (mcds-inbound (speak user $text)))
+             (printf "~a says '~a'\n" user text))))

imperative/mc/udp-dataspace.rkt

@@ -0,0 +1,120 @@
+#lang imperative-syndicate
+
+(provide (struct-out mcds-inbound)
+         (struct-out mcds-outbound))
+
+(require/activate imperative-syndicate/drivers/timer)
+(require/activate imperative-syndicate/drivers/udp)
+(require racket/random file/sha1)
+(require imperative-syndicate/skeleton)
+(require imperative-syndicate/term)
+(require preserves)
+
+(define-logger mcds)
+
+(struct mcds-inbound (assertion) #:prefab)
+(struct mcds-outbound (assertion) #:prefab)
+
+(struct mcds-change (peer type assertion) #:transparent)
+(struct mcds-demand () #:transparent)
+
+(struct mcds-relevant (assertion peer) #:transparent)
+
+(define group-address "239.192.57.49") ;; falls within Organization Local Scope (see RFC 2365)
+(define group-port 5999) ;; make sure your firewall is open to UDP on this port
+(define group-target (udp-remote-address group-address group-port))
+
+(define *assertion-lifetime* 30000)
+(define *assertion-refresh* (* 0.9 *assertion-lifetime*))
+
+(define (send-packet! h packet)
+  (send! (udp-packet h group-target (encode packet))))
+
+(define (packet-statistics h)
+  (define report-period 10000)
+  (field [packet-count 0]
+         [byte-count 0]
+         [reset-time (+ (current-inexact-milliseconds) report-period)])
+  (on (message (udp-packet _ h $body))
+      (packet-count (+ (packet-count) 1))
+      (byte-count (+ (byte-count) (bytes-length body))))
+  (on (asserted (later-than (reset-time)))
+      (reset-time (+ (reset-time) report-period))
+      (log-mcds-info "~a packets, ~a bytes received in ~a ms = ~a Hz, ~a bytes/s"
+                     (packet-count)
+                     (byte-count)
+                     report-period
+                     (/ (packet-count) (/ report-period 1000.0))
+                     (/ (byte-count) (/ report-period 1000.0)))
+      (packet-count 0)
+      (byte-count 0)))
+
+(spawn (during (observe (mcds-inbound _)) (assert (mcds-demand)))
+       (during (mcds-outbound _)          (assert (mcds-demand)))
+
+       (during/spawn (mcds-demand)
+         (define me (crypto-random-bytes 8))
+         (define h (udp-listener group-port))
+         (during h
+           (assert (udp-multicast-group-member h group-address #f))
+           (assert (udp-multicast-loopback h #t))
+
+           (packet-statistics h)
+
+           (on (message (udp-packet _ h $body))
+               (spawn*
+                ;; (log-mcds-info "received: ~v" body)
+                (match (decode body)
+                  [(list peer type assertion)
+                   ;; (log-mcds-info "~v ~v ~v" peer type assertion)
+                   (send! (mcds-change peer type assertion))])))
+
+           (on (message (mcds-change $peer '+ $assertion))
+               (spawn
+                (define expiry (+ (current-inexact-milliseconds) *assertion-lifetime*))
+                (assert (mcds-inbound assertion))
+
+                (when (observe? assertion)
+                  (define pattern (observe-specification assertion))
+                  (define x (mcds-outbound pattern))
+                  (add-observer-endpoint!
+                   (lambda () x)
+                   #:on-add
+                   (lambda (captured-values)
+                     ;; TODO: flawed?? Needs visibility-restriction, or some other way of
+                     ;; ignoring the opaque placeholders!
+                     (assert! (mcds-relevant (instantiate-term->value pattern
+                                                                      captured-values
+                                                                      #:visibility-restriction-proj
+                                                                      #f)
+                                             peer)))))
+
+                (stop-when (message (mcds-change peer '- assertion)))
+                (stop-when (asserted (later-than expiry)))
+                (stop-when (retracted (mcds-demand)))))
+
+           (during (observe (mcds-inbound $pattern))
+             (assert (mcds-relevant (observe pattern) me))
+             (assert (mcds-outbound (observe pattern))))
+
+           (during (mcds-relevant $assertion _)
+             (during (mcds-outbound assertion)
+               (define (refresh!) (send-packet! h (list me '+ assertion)))
+               (on-start (refresh!))
+               (on-stop (send-packet! h (list me '- assertion)))
+
+               (field [deadline (+ (current-inexact-milliseconds) *assertion-refresh*)])
+               (on (asserted (later-than (deadline)))
+                   (refresh!)
+                   (deadline (+ (deadline) *assertion-refresh*)))
+
+               (on (asserted (mcds-relevant assertion $peer))
+                   ;; (log-mcds-info "Peer ~a cares about outbound assertion ~v" peer assertion)
+                   (define soon (+ (current-inexact-milliseconds) 100))
+                   (when (> (deadline) soon) (deadline soon)))))
+
+           (on (message (mcds-change $peer '! $body))
+               (send! (mcds-inbound body)))
+
+           (on (message (mcds-outbound $body))
+               (send-packet! h (list me '! body))))))

imperative/pattern-expander.rkt

@@ -0,0 +1,23 @@
+#lang racket/base
+
+(require auxiliary-macro-context)
+
+(define-auxiliary-macro-context
+  #:context-name pattern-expander
+  #:prop-name prop:pattern-expander
+  #:prop-predicate-name pattern-expander?
+  #:prop-accessor-name pattern-expander-proc
+  #:macro-definer-name define-pattern-expander
+  #:introducer-parameter-name current-pattern-expander-introducer
+  #:local-introduce-name syntax-local-pattern-expander-introduce
+  #:expander-id-predicate-name pattern-expander-id?
+  #:expander-transform-name pattern-expander-transform)
+
+(provide (for-syntax
+          prop:pattern-expander
+          pattern-expander?
+          pattern-expander-proc
+          syntax-local-pattern-expander-introduce
+          pattern-expander-id?
+          pattern-expander-transform)
+         define-pattern-expander)

imperative/pattern.rkt

@@ -0,0 +1,240 @@
+#lang racket/base
+
+(provide (struct-out discard)
+         (struct-out capture)
+
+         (for-syntax analyse-pattern
+                     instantiate-pattern->pattern
+                     instantiate-pattern->value
+                     desc->key
+                     desc->skeleton-proj
+                     desc->skeleton-stx
+                     desc->capture-proj
+                     desc->capture-names
+                     desc->assertion-stx)
+
+         (all-from-out "pattern-expander.rkt"))
+
+(require (for-syntax racket/base))
+(require (for-syntax racket/match))
+(require (for-syntax racket/struct-info))
+(require (for-syntax syntax/stx))
+(require "pattern-expander.rkt")
+
+(struct discard () #:prefab)
+(struct capture (detail) #:prefab)
+
+;;---------------------------------------------------------------------------
+;; ## Analysing patterns
+;;
+;; Patterns generate several pieces, which work together to form
+;; routing tables:
+;;
+;;  - the *assertion* allows observers of observers to function;
+;;  - the `Skeleton` classifies the shape of the pattern;
+;;  - two `SkProj`s select constant and variable pieces from a pattern, respectively; and
+;;  - a `SkKey` specifies constant pieces of a pattern, matched against one of the `SkProj`s.
+;;
+;; The other `SkProj` generates a second `SkKey` which is used as the
+;; input to a handler function.
+
+(define-for-syntax orig-insp
+  (variable-reference->module-declaration-inspector (#%variable-reference)))
+
+(begin-for-syntax
+  (define (dollar-id? stx)
+    (and (identifier? stx)
+         (char=? (string-ref (symbol->string (syntax-e stx)) 0) #\$)))
+
+  (define (undollar stx)
+    (and (dollar-id? stx)
+         (datum->syntax stx (string->symbol (substring (symbol->string (syntax-e stx)) 1)))))
+
+  (define (discard-id? stx)
+    (and (identifier? stx)
+         (free-identifier=? #'_ stx)))
+
+  (define (id-value stx)
+    (and (identifier? stx)
+         (syntax-local-value stx (lambda () #f))))
+
+  (define (list-id? stx)
+    (and (identifier? stx)
+         (free-identifier=? #'list stx)))
+
+  (define (vector-id? stx)
+    (and (identifier? stx)
+         (free-identifier=? #'vector stx)))
+
+  (define (analyse-pattern stx)
+    (define disarmed-stx (syntax-disarm stx orig-insp))
+    (syntax-case disarmed-stx ($ quasiquote unquote quote)
+      [(expander args ...)
+       (pattern-expander-id? #'expander)
+       (pattern-expander-transform disarmed-stx
+                                   (lambda (result)
+                                     (analyse-pattern (syntax-rearm result stx))))]
+
+      ;; Extremely limited support for quasiquoting and quoting
+      [(quasiquote (unquote p)) (analyse-pattern #'p)]
+      [(quasiquote (p ...)) (analyse-pattern #'(list (quasiquote p) ...))]
+      [(quasiquote p) (list 'atom stx)]
+      [(quote p) (list 'atom stx)]
+
+      [(ctor piece ...)
+       (struct-info? (id-value #'ctor))
+       (list* 'compound
+              (extract-struct-info (id-value #'ctor))
+              (stx-map analyse-pattern #'(piece ...)))]
+      [(list piece ...)
+       (list-id? #'list)
+       (list* 'compound
+              'list
+              (stx-map analyse-pattern #'(piece ...)))]
+      [(vector piece ...)
+       (vector-id? #'vector)
+       (list* 'compound
+              'vector
+              (stx-map analyse-pattern #'(piece ...)))]
+      [id
+       (dollar-id? #'id)
+       (list 'capture (undollar #'id) (list 'discard))]
+      [($ id p)
+       (list 'capture #'id (analyse-pattern #'p))]
+      [id
+       (discard-id? #'id)
+       (list 'discard)]
+      [_
+       (list 'atom stx)]))
+
+  (define (instantiate-pattern->pattern stx)
+    (define disarmed-stx (syntax-disarm stx orig-insp))
+    (syntax-case disarmed-stx ($ quasiquote unquote quote)
+      [(expander args ...)
+       (pattern-expander-id? #'expander)
+       (pattern-expander-transform disarmed-stx
+                                   (lambda (result)
+                                     (instantiate-pattern->pattern (syntax-rearm result stx))))]
+
+      ;; Extremely limited support for quasiquoting and quoting
+      [(quasiquote (unquote p)) (instantiate-pattern->pattern #'p)]
+      [(quasiquote (p ...)) (instantiate-pattern->pattern #'(list (quasiquote p) ...))]
+      [(quasiquote p) stx]
+      [(quote p) stx]
+
+      [(ctor piece ...)
+       (struct-info? (id-value #'ctor))
+       (quasisyntax/loc stx (ctor #,@(stx-map instantiate-pattern->pattern #'(piece ...))))]
+      [(list piece ...)
+       (list-id? #'list)
+       (quasisyntax/loc stx (list #,@(stx-map instantiate-pattern->pattern #'(piece ...))))]
+      [(vector piece ...)
+       (vector-id? #'vector)
+       (quasisyntax/loc stx (vector #,@(stx-map instantiate-pattern->pattern #'(piece ...))))]
+      [id
+       (dollar-id? #'id)
+       (undollar #'id)]
+      [($ id p)
+       #'id]
+      [id
+       (discard-id? #'id)
+       #'id]
+      [other
+       #'other]))
+
+  (define (instantiate-pattern->value stx)
+    (define disarmed-stx (syntax-disarm stx orig-insp))
+    (syntax-case disarmed-stx ($ quasiquote unquote quote)
+      [(expander args ...)
+       (pattern-expander-id? #'expander)
+       (pattern-expander-transform disarmed-stx
+                                   (lambda (result)
+                                     (instantiate-pattern->value (syntax-rearm result stx))))]
+
+      ;; Extremely limited support for quasiquoting and quoting
+      [(quasiquote (unquote p)) (instantiate-pattern->value #'p)]
+      [(quasiquote (p ...)) (instantiate-pattern->value #'(list (quasiquote p) ...))]
+      [(quasiquote p) stx]
+      [(quote p) stx]
+
+      [(ctor piece ...)
+       (struct-info? (id-value #'ctor))
+       (quasisyntax/loc stx (ctor #,@(stx-map instantiate-pattern->value #'(piece ...))))]
+      [(list piece ...)
+       (list-id? #'list)
+       (quasisyntax/loc stx (list #,@(stx-map instantiate-pattern->value #'(piece ...))))]
+      [(vector piece ...)
+       (vector-id? #'vector)
+       (quasisyntax/loc stx (vector #,@(stx-map instantiate-pattern->value #'(piece ...))))]
+      [id
+       (dollar-id? #'id)
+       (undollar #'id)]
+      [($ id p)
+       #'id]
+      [id
+       (discard-id? #'id)
+       #'(discard)]
+      [other
+       #'other])))
+
+;;---------------------------------------------------------------------------
+
+(begin-for-syntax
+  (define (select-pattern-leaves desc capture-fn atom-fn)
+    (define (walk-node key-rev desc)
+      (match desc
+        [`(compound ,_ ,pieces ...) (walk-edge 0 key-rev pieces)]
+        [`(capture ,name-stx ,p) (append (capture-fn key-rev name-stx) (walk-node key-rev p))]
+        [`(discard) (list)]
+        [`(atom ,v) (atom-fn key-rev v)]))
+    (define (walk-edge index key-rev pieces)
+      (match pieces
+        ['() '()]
+        [(cons p pieces) (append (walk-node (cons index key-rev) p)
+                                 (walk-edge (+ index 1) key-rev pieces))]))
+    (walk-node '() desc))
+
+  (define (desc->key desc)
+    (select-pattern-leaves desc
+                           (lambda (key-rev name-stx) (list))
+                           (lambda (key-rev atom) (list atom))))
+
+  (define (desc->skeleton-proj desc)
+    (select-pattern-leaves desc
+                           (lambda (key-rev name-stx) (list))
+                           (lambda (key-rev atom) (list (reverse key-rev)))))
+
+  (define (desc->skeleton-stx desc)
+    (match desc
+      [`(compound list ,pieces ...)
+       #`(list 'list #,@(map desc->skeleton-stx pieces))]
+      [`(compound vector ,pieces ...)
+       #`(list 'vector #,@(map desc->skeleton-stx pieces))]
+      [`(compound (,struct-type ,_ctor ,_pred ,_getters ,_setters ,_super) ,pieces ...)
+       #`(list #,struct-type #,@(map desc->skeleton-stx pieces))]
+      [`(capture ,_ ,p) (desc->skeleton-stx p)]
+      [`(discard) #'#f]
+      [`(atom ,atom-stx) #'#f]))
+
+  (define (desc->capture-proj desc)
+    (select-pattern-leaves desc
+                           (lambda (key-rev name-stx) (list (reverse key-rev)))
+                           (lambda (key-rev atom) (list))))
+
+  (define (desc->capture-names desc)
+    (select-pattern-leaves desc
+                           (lambda (key-rev name-stx) (list name-stx))
+                           (lambda (key-rev atom) (list))))
+
+  (define (desc->assertion-stx desc)
+    (match desc
+      [`(compound list ,pieces ...)
+       #`(list #,@(map desc->assertion-stx pieces))]
+      [`(compound vector ,pieces ...)
+       #`(vector #,@(map desc->assertion-stx pieces))]
+      [`(compound (,_struct-type ,ctor ,_pred ,_getters ,_setters ,_super) ,pieces ...)
+       #`(#,ctor #,@(map desc->assertion-stx pieces))]
+      [`(capture ,_ ,p) #`(capture #,(desc->assertion-stx p))]
+      [`(discard) #'(discard)]
+      [`(atom ,v) v]))
+  )

imperative/protocol/credit.rkt

@@ -0,0 +1,72 @@
+#lang imperative-syndicate
+
+(provide (all-defined-out))
+
+(require syndicate/functional-queue)
+
+(define-logger syndicate/protocol/credit)
+
+;; (credit* Any (U Number 'reset))
+;; (credit Any ... (U Number 'reset))
+;;
+;; Send this message to issue `amount` units of credit (in the context
+;; of credit-based flow control) to the given `context`.
+;;
+;; A `context` may identify any essentially asynchronous stream where
+;; either the possibility of overwhelming a consumer exists, or the
+;; need for occasionally changing the settings of a producer in an
+;; atomic way exists. For example, reading HTTP headers proceeds
+;; line-by-line until the body is reached, at which point it proceeds
+;; byte-by-byte.
+;;
+;; The `amount` may either be a number or `'reset`, which should zero
+;; out (discard) any available credit. In particular, it may be
+;; `+inf.0`, effectively turning credit-based flow control off for the
+;; named context.
+;;
+;; See also https://eighty-twenty.org/2011/05/15/origins-of-ack-and-flow-control.
+;;
+(message-struct credit* (context amount))
+
+(define-match-expander credit
+  (syntax-rules () [(_ context ... amount) (credit* (list context ...) amount)])
+  (syntax-rules () [(_ context ... amount) (credit* (list context ...) amount)]))
+
+(define (issue-credit! #:amount [amount 1] . context)
+  (send! (credit* context amount)))
+
+(define (issue-unbounded-credit! . context)
+  (send! (credit* context +inf.0)))
+
+(define (make-flow-controlled-sender . context)
+  (make-flow-controlled-sender* context))
+
+(define (make-flow-controlled-sender* context)
+  (field [q (make-queue)]
+         [item-credit 0])
+  (when (log-level? syndicate/protocol/credit-logger 'debug)
+    (begin/dataflow
+      (log-syndicate/protocol/credit-debug
+       "context ~a, queue length ~a, credit ~a"
+       context
+       (queue-length (q))
+       (item-credit))))
+  (begin/dataflow
+    (when (and (positive? (item-credit))
+               (not (queue-empty? (q))))
+      (define-values (item new-q) (dequeue (q)))
+      (send! item)
+      (q new-q)
+      (item-credit (- (item-credit) 1))))
+  (on (message (credit* context $amount))
+      (item-credit (if (eq? amount 'reset) 0 (+ (item-credit) amount))))
+  (lambda (item) (q (enqueue (q) item))))
+
+;; It's quite possible that credit-based flow control is not the right
+;; approach for Syndicate. Using assertions that describe the content
+;; of a stream more relationally ought to allow "replay" of
+;; information in different contexts; though the trade-off is not only
+;; reduced performance, but a need to garbage-collect
+;; no-longer-interesting portions of the stream; that is,
+;; *acknowledgements*. In a reliable-delivery context, it would appear
+;; that at least one of acks or flow-control is required! (?!?)

imperative/prototype.rkt

@@ -0,0 +1,266 @@
+#lang racket/base
+
+(provide (all-defined-out))
+
+(require syndicate/support/struct)
+(require racket/match)
+(require racket/set)
+(require racket/list)
+(require racket/hash)
+
+(require (for-syntax racket/base))
+(require (for-syntax syntax/stx))
+
+(module+ test (require rackunit))
+
+;; A `SkProj` is a *skeleton projection*, a specification of loci
+;; within a tree-shaped datum to collect into a flat list.
+;;
+;;     SkProj = (Listof (Listof Nat))
+;;
+;; The outer list specifies elements of the flat list; the inner lists
+;; specify paths via zero-indexed links to child nodes in the
+;; tree-shaped datum being examined. A precondition for use of a
+;; `SkProj` is that the datum being examined has been checked for
+;; conformance to the skeleton being projected.
+
+;; A `SkKey` is the result of running a `SkProj` over a term,
+;; extracting the values at the denoted locations.
+
+;; A `SkCont` is a *skeleton continuation*, a collection of "next
+;; steps" after a `Skeleton` has matched the general outline of a
+;; datum.
+;;
+;;     SkCont = (MutableHash SkProj (MutableHash SkKey (MutableHash SkProj (Setof (... -> Any)))))
+;;
+;; The outer `SkProj` selects *constant* portions of the term for more
+;; matching against the `SkKey`s in the hash table. The inner
+;; `SkProj`, if any, selects *variable* portions of the term to be
+;; given to the handler function.
+
+;; A `Skeleton` is a structural guard on a datum: essentially,
+;; specification of (the outline of) its shape; its silhouette.
+;;
+;;     Skeleton = (skeleton-node SkCont (AListof SkLabel SkNode))
+;;      SkLabel = (skeleton-edge Nat Nat SkClass Nat)
+;;      SkClass = StructType | 'list
+;;
+(struct skeleton-node (continuations [edges #:mutable]) #:transparent)
+(struct skeleton-edge (pop-count index class arity) #:transparent)
+
+(define (make-empty-skeleton)
+  (skeleton-node (make-hash) '()))
+
+(define (select-pattern-leaves stx capture-fn atom-fn)
+  (define (walk-node key-rev stx)
+    (match stx
+      [(list pieces ...) (walk-edge 0 key-rev pieces)]
+      ['$ (capture-fn key-rev)]
+      ['_ (list)]
+      [atom (atom-fn key-rev atom)]))
+  (define (walk-edge index key-rev pieces)
+    (match pieces
+      ['() '()]
+      [(cons p pieces) (append (walk-node (cons index key-rev) p)
+                               (walk-edge (+ index 1) key-rev pieces))]))
+  (walk-node '(0) stx))
+
+(define (pattern-stx->key stx)
+  (select-pattern-leaves stx
+                         (lambda (_key-rev) (list))
+                         (lambda (_key-rev atom) (list atom))))
+
+(define (pattern-stx->skeleton-proj stx)
+  (select-pattern-leaves stx
+                         (lambda (_key-rev) (list))
+                         (lambda (key-rev _atom) (list (reverse key-rev)))))
+
+(define (pattern-stx->capture-proj stx)
+  (select-pattern-leaves stx
+                         (lambda (key-rev) (list (reverse key-rev)))
+                         (lambda (_key-rev _atom) (list))))
+
+(define merge-skcont!
+  (let ()
+    (define (merge-proj-handler old new)
+      (hash-union! old new #:combine set-union))
+    (define (merge-key-proj-handler old new)
+      (hash-union! old new #:combine merge-proj-handler))
+    (lambda (old new)
+      (hash-union! old new #:combine merge-key-proj-handler))))
+
+;; Imperatively extends `sk` to include the pattern `stx` terminating
+;; in `skcont`.
+(define (extend-skeleton! sk skcont stx)
+  (define (walk-node! sk pop-count index stx)
+    (match stx
+      [(list pieces ...)
+       (define edge (skeleton-edge pop-count index 'list (length pieces)))
+       (define next
+         (match (assoc edge (skeleton-node-edges sk))
+           [#f (let ((next (make-empty-skeleton)))
+                 (set-skeleton-node-edges! sk (cons (cons edge next) (skeleton-node-edges sk)))
+                 next)]
+           [(cons _edge next) next]))
+       (walk-edge! next 0 0 pieces)]
+      [_
+       (values pop-count sk)]))
+  (define (walk-edge! sk pop-count index pieces)
+    (match pieces
+      ['()
+       (values (+ pop-count 1) sk)]
+      [(cons p pieces)
+       (let-values (((pop-count sk) (walk-node! sk pop-count index p)))
+         (walk-edge! sk pop-count (+ index 1) pieces))]))
+  (let-values (((_pop-count sk) (walk-edge! sk 0 0 (list stx))))
+    (merge-skcont! (skeleton-node-continuations sk) skcont)
+    sk))
+
+;; TODO: avoid repeated descent into `term` by factoring out prefixes of paths in `proj`
+(define (apply-projection term proj)
+  (for/list [(path proj)]
+    (for/fold [(term (list term))] [(index path)]
+      (cond [(list? term) (list-ref term index)]
+            [else (error 'apply-projection "Non-lists not supported: ~v" term)]))))
+
+(module+ test
+  (define stx0 '$)
+  (define stx1 '3)
+  (define stxA '($ 3))
+  (define stxB '(4 $))
+  (define stxC '(_ ($ $)))
+  (define stxD '(_ (1 2)))
+  (define stxE '((6 6) _))
+  (define stxF '(($ $) (3 9)))
+  (define stxG '((_ _) (1 2)))
+  (define stxH '((_ _) ((_ _) ($ _))))
+  (define stxI '(((_ _) _) (_ _)))
+  (define stxJ '(((_ _) (_ _)) (_ _)))
+
+  (define (summarise-skeleton sk)
+    (define (walk-node sk)
+      (match-define (skeleton-node continuations edges) sk)
+      (append (if (hash-empty? continuations) '() (list continuations))
+              (map walk-edge edges)))
+    (define (walk-edge e)
+      (match-define (cons (skeleton-edge pop-count index class arity) sk) e)
+      (for/fold [(acc (list* (list index class arity) (walk-node sk)))]
+                [(n pop-count)]
+        (list 'POP acc)))
+    (walk-node sk))
+
+  (define (skcont . ids)
+    (define acc (make-hash))
+    ;; Not quite the right shape! Just a dummy placeholder for testing
+    (for [(id ids)]
+      (merge-skcont! acc
+                     (make-hash
+                      (list (cons id (make-hash
+                                      (list (cons id (make-hash
+                                                      (list (cons id (set))))))))))))
+    acc)
+
+  (define (skeleton-stx->skeleton id pat-stx)
+    (define sk (make-empty-skeleton))
+    (extend-skeleton! sk (skcont id) pat-stx)
+    sk)
+
+  (check-equal? `(,(skcont 0))
+                (summarise-skeleton (skeleton-stx->skeleton '0 stx0)))
+  (check-equal? `(,(skcont 1))
+                (summarise-skeleton (skeleton-stx->skeleton '1 stx1)))
+  (check-equal? `(((0 list 2) ,(skcont 'A)))
+                (summarise-skeleton (skeleton-stx->skeleton 'A stxA)))
+  (check-equal? `(((0 list 2) ,(skcont 'B)))
+                (summarise-skeleton (skeleton-stx->skeleton 'B stxB)))
+  (check-equal? `(((0 list 2) ((1 list 2) ,(skcont 'C))))
+                (summarise-skeleton (skeleton-stx->skeleton 'C stxC)))
+  (check-equal? `(((0 list 2) ((1 list 2) ,(skcont 'D))))
+                (summarise-skeleton (skeleton-stx->skeleton 'D stxD)))
+  (check-equal? `(((0 list 2) ((0 list 2) ,(skcont 'E))))
+                (summarise-skeleton (skeleton-stx->skeleton 'E stxE)))
+  (check-equal? `(((0 list 2) ((0 list 2) (POP ((1 list 2) ,(skcont 'F))))))
+                (summarise-skeleton (skeleton-stx->skeleton 'F stxF)))
+  (check-equal? `(((0 list 2) ((0 list 2) (POP ((1 list 2) ,(skcont 'G))))))
+                (summarise-skeleton (skeleton-stx->skeleton 'G stxG)))
+  (check-equal? `(((0 list 2)
+                   ((0 list 2) (POP ((1 list 2) ((0 list 2) (POP ((1 list 2) ,(skcont 'H)))))))))
+                (summarise-skeleton (skeleton-stx->skeleton 'H stxH)))
+  (check-equal? `(((0 list 2) ((0 list 2) ((0 list 2) (POP (POP ((1 list 2) ,(skcont 'I))))))))
+                (summarise-skeleton (skeleton-stx->skeleton 'I stxI)))
+  (check-equal? `(((0 list 2)
+                   ((0 list 2)
+                    ((0 list 2) (POP ((1 list 2) (POP (POP ((1 list 2) ,(skcont 'J))))))))))
+                (summarise-skeleton (skeleton-stx->skeleton 'J stxJ)))
+
+  (check-equal? `(,(skcont 0 1)
+                  ((0 list 2)
+                   ,(skcont 'A 'B)
+                   ((0 list 2)
+                    ,(skcont 'E)
+                    ((0 list 2)
+                     (POP ((1 list 2) (POP (POP ((1 list 2) ,(skcont 'J))))))
+                     (POP (POP ((1 list 2) ,(skcont 'I)))))
+                    (POP ((1 list 2) ,(skcont 'F 'G) ((0 list 2) (POP ((1 list 2) ,(skcont 'H)))))))
+                   ((1 list 2) ,(skcont 'C 'D))))
+                (let ((sk (make-empty-skeleton)))
+                  (extend-skeleton! sk (skcont '0) stx0)
+                  (extend-skeleton! sk (skcont '1) stx1)
+                  (extend-skeleton! sk (skcont 'A) stxA)
+                  (extend-skeleton! sk (skcont 'B) stxB)
+                  (extend-skeleton! sk (skcont 'C) stxC)
+                  (extend-skeleton! sk (skcont 'D) stxD)
+                  (extend-skeleton! sk (skcont 'E) stxE)
+                  (extend-skeleton! sk (skcont 'F) stxF)
+                  (extend-skeleton! sk (skcont 'G) stxG)
+                  (extend-skeleton! sk (skcont 'H) stxH)
+                  (extend-skeleton! sk (skcont 'I) stxI)
+                  (extend-skeleton! sk (skcont 'J) stxJ)
+                  (summarise-skeleton sk)))
+
+  (check-equal? '() (pattern-stx->skeleton-proj stx0))
+  (check-equal? '((0)) (pattern-stx->skeleton-proj stx1))
+  (check-equal? '((0 1)) (pattern-stx->skeleton-proj stxA))
+  (check-equal? '((0 0)) (pattern-stx->skeleton-proj stxB))
+  (check-equal? '() (pattern-stx->skeleton-proj stxC))
+  (check-equal? '((0 1 0) (0 1 1)) (pattern-stx->skeleton-proj stxD))
+  (check-equal? '((0 0 0) (0 0 1)) (pattern-stx->skeleton-proj stxE))
+  (check-equal? '((0 1 0) (0 1 1)) (pattern-stx->skeleton-proj stxF))
+  (check-equal? '((0 1 0) (0 1 1)) (pattern-stx->skeleton-proj stxG))
+  (check-equal? '() (pattern-stx->skeleton-proj stxH))
+  (check-equal? '() (pattern-stx->skeleton-proj stxI))
+  (check-equal? '() (pattern-stx->skeleton-proj stxJ))
+
+  (check-equal? '() (pattern-stx->key stx0))
+  (check-equal? '(3) (pattern-stx->key stx1))
+  (check-equal? '(3) (pattern-stx->key stxA))
+  (check-equal? '(4) (pattern-stx->key stxB))
+  (check-equal? '() (pattern-stx->key stxC))
+  (check-equal? '(1 2) (pattern-stx->key stxD))
+  (check-equal? '(6 6) (pattern-stx->key stxE))
+  (check-equal? '(3 9) (pattern-stx->key stxF))
+  (check-equal? '(1 2) (pattern-stx->key stxG))
+  (check-equal? '() (pattern-stx->key stxH))
+  (check-equal? '() (pattern-stx->key stxI))
+  (check-equal? '() (pattern-stx->key stxJ))
+
+  (check-equal? '((0)) (pattern-stx->capture-proj stx0))
+  (check-equal? '() (pattern-stx->capture-proj stx1))
+  (check-equal? '((0 0)) (pattern-stx->capture-proj stxA))
+  (check-equal? '((0 1)) (pattern-stx->capture-proj stxB))
+  (check-equal? '((0 1 0) (0 1 1)) (pattern-stx->capture-proj stxC))
+  (check-equal? '() (pattern-stx->capture-proj stxD))
+  (check-equal? '() (pattern-stx->capture-proj stxE))
+  (check-equal? '((0 0 0) (0 0 1)) (pattern-stx->capture-proj stxF))
+  (check-equal? '() (pattern-stx->capture-proj stxG))
+  (check-equal? '((0 1 1 0)) (pattern-stx->capture-proj stxH))
+  (check-equal? '() (pattern-stx->capture-proj stxI))
+  (check-equal? '() (pattern-stx->capture-proj stxJ))
+
+  (check-equal? '(goodbye hello)
+                (apply-projection '((goodbye hello) (3 9)) (pattern-stx->capture-proj stxF)))
+  (check-equal? '(99)
+                (apply-projection '(4 99) (pattern-stx->capture-proj stxB)))
+  (check-equal? '((4 99))
+                (apply-projection '(4 99) (pattern-stx->capture-proj stx0)))
+  )

imperative/reassert.rkt

@@ -0,0 +1,35 @@
+#lang imperative-syndicate
+;; Re-assert an assertion when one of a set of triggering events is seen, after a delay.
+;; Building block for building reconnection strategies.
+
+(provide reassert-on
+         (struct-out fixed-retry))
+
+(require/activate imperative-syndicate/drivers/timer)
+
+(struct fixed-retry (delay-ms) #:transparent
+  #:property prop:procedure
+  (lambda (f) (values (fixed-retry-delay-ms f) f)))
+
+(define-logger syndicate/reassert)
+
+(define-syntax reassert-on
+  (syntax-rules ()
+    [(_ assertion #:strategy strategy reset-event ...)
+     (reassert-on* assertion
+                   #:strategy strategy
+                   (list (lambda (k) (stop-when reset-event (k))) ...))]
+    [(_ assertion reset-event ...)
+     (reassert-on assertion #:strategy (fixed-retry 1000) reset-event ...)]))
+
+(begin-for-declarations
+  (define (reassert-on* assertion #:strategy strategy event-fns)
+    (on-start (let reassert ((strategy strategy))
+                (react (log-syndicate/reassert-debug "~v: Asserting" assertion)
+                       (assert assertion)
+                       (define (reset)
+                         (log-syndicate/reassert-debug "~v: Resetting with ~v" assertion strategy)
+                         (define-values (delay-ms next-strategy) (strategy))
+                         (sleep (/ delay-ms 1000.0))
+                         (reassert next-strategy))
+                       (for-each (lambda (f) (f reset)) event-fns))))))

imperative/reflection.rkt

@@ -0,0 +1,9 @@
+#lang racket/base
+;; Reflective protocols
+
+(provide (struct-out terminated))
+
+;; (terminated Any (Option Any))
+;; The `actor-name` is the name of the terminated actor.
+;; The `reason` is either `#f` or a termination reason, usually an `exn?`.
+(struct terminated (actor-name reason) #:transparent)

imperative/relay.rkt

@@ -0,0 +1,154 @@
+#lang racket/base
+;; Cross-layer relaying between adjacent dataspaces
+;; TODO: protocol for *clean* shutdown of a dataspace
+
+;; TODO: Actually elide the need for relays entirely, by allowing an
+;; actor to manifest in multiple dataspaces (multiple
+;; points-of-attachment), and by placing assertions and subscriptions
+;; directly in the dataspace concerned. (Done naively, this would
+;; avoid manifesting observed assertions in intermediate nested
+;; dataspaces; but then, if anyone cared, they'd be observing the
+;; tuples themselves - right?? Oh, maybe observing the observers would
+;; be an, er, observable difference.)
+
+(provide quit-dataspace!
+         dataspace)
+
+(require racket/match)
+(require racket/set)
+(require "assertions.rkt")
+(require "dataspace.rkt")
+(require "syntax.rkt")
+(require "skeleton.rkt")
+(require "term.rkt")
+(require "bag.rkt")
+
+(require (for-syntax racket/base))
+(require (for-syntax syntax/parse))
+(require "syntax-classes.rkt")
+
+(struct *quit-dataspace* () #:transparent)
+
+;; TODO: inbound^n, outbound^n -- protocol/standard-relay, iow
+
+(define (quit-dataspace!)
+  (send! (*quit-dataspace*)))
+
+(define-syntax (dataspace stx)
+  (syntax-parse stx
+    [(_ name:name form ...)
+     (syntax/loc stx
+       (let ((ds-name name.N))
+         (spawn #:name ds-name
+                (define outer-facet (current-facet))
+                (begin/dataflow (void)) ;; eww. dummy endpoint to keep the root facet alive
+                (define (schedule-inner!)
+                  (push-script!
+                   (facet-actor outer-facet)
+                   (lambda ()
+                     (with-current-facet [outer-facet]
+                       (when (facet-live? outer-facet)
+                         (defer-turn! (lambda ()
+                                        (when (run-scripts! inner-ds)
+                                          (schedule-inner!)))))))))
+                (define inner-ds (make-dataspace
+                                  (lambda ()
+                                    (schedule-script!
+                                     (current-actor)
+                                     (lambda ()
+                                       (spawn #:name (list 'ds-link ds-name)
+                                              (boot-relay schedule-inner!
+                                                          outer-facet))
+                                       (spawn* form ...))))))
+                (on-start (schedule-inner!)))))]))
+
+(define (boot-relay schedule-inner! outer-facet)
+  (define inbound-endpoints (make-hash))
+  (define outbound-endpoints (make-hash))
+
+  (define inner-facet (current-facet))
+  (define inner-actor (current-actor))
+  (define inner-ds (actor-dataspace inner-actor))
+
+  (on (asserted (observe (inbound $x)))
+      ;; (log-info "~a (asserted (observe (inbound ~v)))" inner-actor x)
+      (with-current-facet [outer-facet]
+        (with-non-script-context
+          (define (make-endpoint)
+            (define inner-capture-proj
+              ;; inner-capture-proj accounts for the extra (inbound ...) layer around
+              ;; assertions
+              (let ((outer-capture-proj (term->capture-proj x)))
+                (map (lambda (p) (cons 0 p)) outer-capture-proj)))
+            (define (rebuild cs)
+              (instantiate-term->value (inbound x) cs
+                                       #:visibility-restriction-proj inner-capture-proj))
+            (define ((wrap f) cs)
+              (f (rebuild cs))
+              (schedule-inner!))
+            (add-raw-observer-endpoint!
+             (lambda () x)
+             #:on-add (wrap (lambda (t) (apply-patch! inner-ds inner-actor (bag t +1))))
+             #:on-remove (wrap (lambda (t) (apply-patch! inner-ds inner-actor (bag t -1))))
+             #:on-message (wrap (lambda (t) (send-assertion! (dataspace-routing-table inner-ds) t)))
+             #:cleanup (lambda (cache)
+                         (apply-patch! inner-ds inner-actor (for/bag/count [(cs (in-bag cache))]
+                                                              (values (rebuild cs) -1)))
+                         (schedule-inner!))))
+          (record-endpoint-if-live! outer-facet inbound-endpoints x make-endpoint))))
+
+  (on (message (*quit-dataspace*))
+      (with-current-facet [outer-facet]
+        (stop-current-facet)))
+
+  (on (retracted (observe (inbound $x)))
+      ;; (log-info "~a (retracted (observe (inbound ~v)))" inner-actor x)
+      (with-current-facet [outer-facet]
+        (with-non-script-context
+          (remove-endpoint! outer-facet (hash-ref inbound-endpoints x))
+          (hash-remove! inbound-endpoints x))))
+
+  (on (asserted (outbound $x))
+      ;; (log-info "~a (asserted (outbound ~v))" inner-actor x)
+      (with-current-facet [outer-facet]
+        (with-non-script-context
+          (record-endpoint-if-live! outer-facet
+                                    outbound-endpoints
+                                    x
+                                    (lambda ()
+                                      (add-endpoint! outer-facet
+                                                     "dataspace-relay (outbound ...)"
+                                                     #t
+                                                     (lambda () (values x #f))))))))
+
+  (on (retracted (outbound $x))
+      ;; (log-info "~a (retracted (outbound ~v))" inner-actor x)
+      (with-current-facet [outer-facet]
+        (with-non-script-context
+          (remove-endpoint! outer-facet (hash-ref outbound-endpoints x))
+          (hash-remove! outbound-endpoints x))))
+
+  (on (message (outbound $x))
+      ;; (log-info "~a (message (outbound ~v))" inner-actor x)
+      (with-current-facet [outer-facet]
+        (send! x))))
+
+(define (record-endpoint-if-live! f table key ep-adder)
+  (when (facet-live? f)
+    ;;
+    ;; ^ Check that `f` is still alive, because we're (carefully!!)
+    ;; violating an invariant of `dataspace.rkt` by adding an endpoint
+    ;; well after the construction of the facet we're in. We may be
+    ;; executing this handler just after clean shutdown of the facet
+    ;; by a `quit-dataspace!` request, and in that case we MUST NOT
+    ;; add any further endpoints because their assertions will not get
+    ;; removed, because cleanup (as part of `(quit)` processing) has
+    ;; already been done.
+    ;;
+    ;; We don't have to do a similar check before calling
+    ;; `remove-endpoint!`, because shortly after all (both) calls to
+    ;; `destroy-endpoint!`, all destroyed endpoints are removed from
+    ;; the `facet-endpoints` table, ensuring they won't be processed
+    ;; again.
+    ;;
+    (hash-set! table key (ep-adder))))