artdag: Phase 7 consumes lib/maude mau/confluent? (no bespoke confluence checker)

The CID-stability check now calls mau/confluent? / mau/non-joinable-pairs from
lib/maude/confluence.sx (merged in) instead of re-implementing critical-pair
analysis inside lib/artdag. Picks up confluence.sx via the architecture merge.

Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>

.claude/scheduled_tasks.lock

@@ -1 +1 @@
-{"sessionId":"bf20a443-9df8-4cb9-932e-8c6f4c4625c2","pid":1303602,"procStart":"253831081","acquiredAt":1779865895644}
+{"sessionId":"c4d97db1-361c-4a04-a99b-c838f9385469","pid":2426590,"procStart":"349789073","acquiredAt":1780789990975}

hosts/ocaml/bin/sx_server.ml

@@ -571,9 +571,12 @@ and cek_run_with_io state =
           Hashtbl.replace d "descent" (Number desc);
           Dict d
         | _ ->
-          let args = let a = Sx_runtime.get_val request (String "args") in
-            (match a with List l -> l | _ -> [a]) in
-          io_request op args
+          let argsv = Sx_runtime.get_val request (String "args") in
+          (match Sx_persist_store.handle_op op argsv with
+           | Some resp -> resp
+           | None ->
+             let args = (match argsv with List l -> l | _ -> [argsv]) in
+             io_request op args)
       in
       s := Sx_ref.cek_resume !s response;
       loop ()
@@ -1698,7 +1701,12 @@ let rec dispatch env cmd =
                | Some path -> load_library_file path | None -> ());
               Nil
             end
-          end else Nil (* non-import IO: resume with nil *) in
+          end else
+            (* durable-storage ops: service against on-disk store *)
+            let args = Sx_runtime.get_val request (String "args") in
+            (match Sx_persist_store.handle_op op args with
+             | Some resp -> resp
+             | None -> Nil (* non-import IO: resume with nil *)) in
           s := Sx_ref.cek_resume !s response
         done;
         Sx_ref.cek_value !s
@@ -4051,7 +4059,10 @@ let http_mode port =
       Dict d
     | "io-sleep" | "sleep" -> Nil
     | "import" -> Nil
-    | _ -> Nil);
+    | _ ->
+      (match Sx_persist_store.handle_op op args with
+       | Some resp -> resp
+       | None -> Nil));
   (* Response cache — path → full HTTP response string.
      Populated during pre-warm, serves cached responses in <0.1ms.
      Thread-safe: reads are lock-free (Hashtbl.find_opt is atomic for

hosts/ocaml/lib/sx_persist_store.ml

@@ -0,0 +1,293 @@
+(* sx_persist_store — host durable-storage adapter for lib/persist.
+   Production twin of `persist/serve` (lib/persist/durable.sx): it answers the
+   same `persist/...` IO ops, but backs them with real on-disk storage so writes
+   survive a process restart. Stateless-on-disk: every op reads/writes the
+   filesystem directly, so a fresh process recovers state with no warm-up — the
+   log on disk IS the state.
+
+   On-disk layout under the root dir (default ./persist-data, or $SX_PERSIST_DIR):
+     streams/<hex(stream)>.log   append-only, one SX-serialized event per line
+     streams/<hex(stream)>.seq   per-stream monotonic high-water counter (int)
+     kv/<hex(key)>               one SX-serialized value per key
+
+   Invariants honoured (see plans/persist-on-sx.md Blocker spec):
+   1. last-seq is a per-stream monotonic counter stored in .seq, SEPARATE from
+      the rows — it keeps climbing across truncate, so a compacted stream never
+      reassigns a seq.
+   2. append never renumbers — the event already carries its :seq (log.sx does
+      last-seq+1); the host only bumps the high-water mark to max(hw, seq).
+   3. read returns surviving events in append order with :seq intact.
+   4. streams is the set of streams that ever had an append — keyed off the .seq
+      file, which truncate never deletes, so it survives full compaction.
+   5. values round-trip structurally via the SX serializer/parser. *)
+
+open Sx_types
+
+(* ---- root dir ---------------------------------------------------------- *)
+
+let _root : string option ref = ref None
+
+let set_root dir = _root := Some dir
+
+let root_dir () =
+  match !_root with
+  | Some d -> d
+  | None -> (try Sys.getenv "SX_PERSIST_DIR" with Not_found -> "persist-data")
+
+(* ---- filesystem helpers ------------------------------------------------ *)
+
+let rec ensure_dir dir =
+  if dir = "" || dir = "." || dir = "/" || Sys.file_exists dir then ()
+  else begin
+    ensure_dir (Filename.dirname dir);
+    (try Unix.mkdir dir 0o755 with Unix.Unix_error (Unix.EEXIST, _, _) -> ())
+  end
+
+let streams_dir () = Filename.concat (root_dir ()) "streams"
+let kv_dir () = Filename.concat (root_dir ()) "kv"
+let blobs_dir () = Filename.concat (root_dir ()) "blobs"
+
+let read_file path =
+  let ic = open_in_bin path in
+  let n = in_channel_length ic in
+  let s = really_input_string ic n in
+  close_in ic;
+  s
+
+(* Atomic write: temp file in the same dir then rename over the target. *)
+let write_file_atomic path contents =
+  ensure_dir (Filename.dirname path);
+  let tmp = path ^ ".tmp" in
+  let oc = open_out_bin tmp in
+  output_string oc contents;
+  flush oc;
+  close_out oc;
+  Sys.rename tmp path
+
+let append_line path line =
+  ensure_dir (Filename.dirname path);
+  let oc = open_out_gen [Open_append; Open_creat; Open_wronly] 0o644 path in
+  output_string oc line;
+  output_char oc '\n';
+  close_out oc
+
+(* ---- name <-> filename (hex, reversible, fs-safe) ---------------------- *)
+
+let hex_encode s =
+  let b = Buffer.create (String.length s * 2) in
+  String.iter (fun c -> Buffer.add_string b (Printf.sprintf "%02x" (Char.code c))) s;
+  Buffer.contents b
+
+let hex_decode s =
+  let n = String.length s / 2 in
+  String.init n (fun i -> Char.chr (int_of_string ("0x" ^ String.sub s (i * 2) 2)))
+
+let stream_log stream = Filename.concat (streams_dir ()) (hex_encode stream ^ ".log")
+let stream_seq stream = Filename.concat (streams_dir ()) (hex_encode stream ^ ".seq")
+let kv_path key = Filename.concat (kv_dir ()) (hex_encode key)
+
+(* ---- value <-> SX text (round-trips through Sx_parser) ----------------- *)
+
+let escape_str s =
+  let len = String.length s in
+  let buf = Buffer.create (len + 16) in
+  for i = 0 to len - 1 do
+    match s.[i] with
+    | '"'  -> Buffer.add_string buf "\\\""
+    | '\\' -> Buffer.add_string buf "\\\\"
+    | '\n' -> Buffer.add_string buf "\\n"
+    | '\r' -> Buffer.add_string buf "\\r"
+    | '\t' -> Buffer.add_string buf "\\t"
+    | c    -> Buffer.add_char buf c
+  done;
+  Buffer.contents buf
+
+let rec serialize = function
+  | Nil -> "nil"
+  | Bool true -> "true"
+  | Bool false -> "false"
+  | Integer n -> string_of_int n
+  | Number n -> format_number n
+  | String s -> "\"" ^ escape_str s ^ "\""
+  | Symbol s -> "(quote " ^ s ^ ")"
+  | Keyword k -> ":" ^ k
+  | List items | ListRef { contents = items } ->
+    "(list" ^ (List.fold_left (fun acc v -> acc ^ " " ^ serialize v) "" items) ^ ")"
+  | Dict d ->
+    let pairs = Hashtbl.fold (fun k v acc ->
+      (Printf.sprintf ":%s %s" k (serialize v)) :: acc) d [] in
+    "{" ^ String.concat " " (List.sort String.compare pairs) ^ "}"
+  | _ -> "nil"
+
+(* Parse one serialized value back. Empty / blank -> Nil. *)
+let rec deserialize line =
+  let line = String.trim line in
+  if line = "" then Nil
+  else match Sx_parser.parse_all line with
+    | v :: _ -> eval_quote_lists v
+    | [] -> Nil
+
+(* serialize emits lists as `(list ...)` and symbols as `(quote s)` so the
+   parser yields data, not a call — but the parser leaves those as AST. Walk
+   the parsed AST and collapse `(list ...)`/`(quote s)` back to values. *)
+and eval_quote_lists v =
+  match v with
+  | List (Symbol "quote" :: x :: []) -> x
+  | List (Symbol "list" :: rest) -> List (List.map eval_quote_lists rest)
+  | List items -> List (List.map eval_quote_lists items)
+  | ListRef { contents = items } -> List (List.map eval_quote_lists items)
+  | Dict d ->
+    let d' = Hashtbl.create (Hashtbl.length d) in
+    Hashtbl.iter (fun k v -> Hashtbl.replace d' k (eval_quote_lists v)) d;
+    Dict d'
+  | other -> other
+
+(* ---- seq counter ------------------------------------------------------- *)
+
+let read_seq stream =
+  let p = stream_seq stream in
+  if Sys.file_exists p then (try int_of_string (String.trim (read_file p)) with _ -> 0)
+  else 0
+
+let write_seq stream n = write_file_atomic (stream_seq stream) (string_of_int n)
+
+let value_to_int = function
+  | Integer n -> n
+  | Number n -> int_of_float n
+  | _ -> 0
+
+let event_seq ev =
+  match ev with
+  | Dict d -> (match Hashtbl.find_opt d "seq" with Some v -> value_to_int v | None -> 0)
+  | _ -> 0
+
+(* ---- ops --------------------------------------------------------------- *)
+
+let do_append stream ev =
+  ensure_dir (streams_dir ());
+  (* bump the monotonic high-water mark; create .seq on first append so the
+     stream shows up in `streams` and survives later truncation. *)
+  let hw = read_seq stream in
+  let s = event_seq ev in
+  write_seq stream (max hw s);
+  append_line (stream_log stream) (serialize ev)
+
+let do_read stream =
+  let p = stream_log stream in
+  if not (Sys.file_exists p) then List []
+  else begin
+    let content = read_file p in
+    let lines = String.split_on_char '\n' content in
+    let evs = List.filter_map (fun l ->
+      if String.trim l = "" then None else Some (deserialize l)) lines in
+    List evs
+  end
+
+let do_last_seq stream = Number (float_of_int (read_seq stream))
+
+let list_dir_suffix dir suffix =
+  if not (Sys.file_exists dir) then []
+  else
+    Array.to_list (Sys.readdir dir)
+    |> List.filter (fun f -> Filename.check_suffix f suffix)
+    |> List.map (fun f -> hex_decode (Filename.chop_suffix f suffix))
+    |> List.sort String.compare
+
+let do_streams () = List (List.map (fun s -> String s) (list_dir_suffix (streams_dir ()) ".seq"))
+
+(* drop events with seq <= n; the .seq high-water counter is untouched. *)
+let do_truncate stream n =
+  let p = stream_log stream in
+  if Sys.file_exists p then begin
+    let evs = match do_read stream with List l -> l | _ -> [] in
+    let kept = List.filter (fun ev -> event_seq ev > n) evs in
+    let body = String.concat "" (List.map (fun ev -> serialize ev ^ "\n") kept) in
+    write_file_atomic p body
+  end
+
+let do_kv_get key =
+  let p = kv_path key in
+  if Sys.file_exists p then deserialize (read_file p) else Nil
+
+let do_kv_put key v =
+  ensure_dir (kv_dir ());
+  write_file_atomic (kv_path key) (serialize v)
+
+let do_kv_delete key =
+  let p = kv_path key in
+  if Sys.file_exists p then (try Sys.remove p with _ -> ())
+
+let do_kv_has key = Bool (Sys.file_exists (kv_path key))
+
+let do_kv_keys () =
+  if not (Sys.file_exists (kv_dir ())) then List []
+  else
+    List (
+      Array.to_list (Sys.readdir (kv_dir ()))
+      |> List.map hex_decode
+      |> List.sort String.compare
+      |> List.map (fun s -> String s))
+
+(* ---- blob store (content-addressed) ------------------------------------ *)
+(* Same pattern as the persist ops, but a SEPARATE adapter: large objects live
+   in a content-addressed directory keyed by a CIDv1 (raw codec, sha2-256).
+   persist only ever stores the returned ref ({:cid :size :mime}), never bytes.
+   blob/put is idempotent — identical bytes hash to the same cid + same file. *)
+
+let codec_raw = 0x55
+
+let blob_cid bytes =
+  let digest = Sx_cid.unhex (Sx_sha2.sha256_hex bytes) in
+  Sx_cid.cidv1 codec_raw (Sx_cid.multihash Sx_cid.mh_sha2_256 digest)
+
+let blob_path cid = Filename.concat (blobs_dir ()) cid
+
+let do_blob_put bytes =
+  let cid = blob_cid bytes in
+  let p = blob_path cid in
+  if not (Sys.file_exists p) then write_file_atomic p bytes;
+  String cid
+
+let do_blob_get cid =
+  let p = blob_path cid in
+  if Sys.file_exists p then String (read_file p) else Nil
+
+let do_blob_has cid = Bool (Sys.file_exists (blob_path cid))
+
+(* ---- dispatch ---------------------------------------------------------- *)
+
+let arglist = function
+  | List l | ListRef { contents = l } -> l
+  | Nil -> []
+  | v -> [v]
+
+(* Returns Some response if op is a persist op this store owns, None otherwise. *)
+let handle_op op args =
+  let a = arglist args in
+  let str = function String s -> s | v -> value_to_string v in
+  match op with
+  | "persist/append" ->
+    (match a with stream :: ev :: _ -> do_append (str stream) ev | _ -> ()); Some Nil
+  | "persist/read" ->
+    (match a with stream :: _ -> Some (do_read (str stream)) | _ -> Some (List []))
+  | "persist/last-seq" ->
+    (match a with stream :: _ -> Some (do_last_seq (str stream)) | _ -> Some (Number 0.0))
+  | "persist/streams" -> Some (do_streams ())
+  | "persist/truncate" ->
+    (match a with stream :: n :: _ -> do_truncate (str stream) (value_to_int n) | _ -> ()); Some Nil
+  | "persist/kv-get" ->
+    (match a with key :: _ -> Some (do_kv_get (str key)) | _ -> Some Nil)
+  | "persist/kv-put" ->
+    (match a with key :: v :: _ -> do_kv_put (str key) v | _ -> ()); Some Nil
+  | "persist/kv-delete" ->
+    (match a with key :: _ -> do_kv_delete (str key) | _ -> ()); Some Nil
+  | "persist/kv-has?" ->
+    (match a with key :: _ -> Some (do_kv_has (str key)) | _ -> Some (Bool false))
+  | "persist/kv-keys" -> Some (do_kv_keys ())
+  | "blob/put" ->
+    (match a with bytes :: _ -> Some (do_blob_put (str bytes)) | _ -> Some Nil)
+  | "blob/get" ->
+    (match a with cid :: _ -> Some (do_blob_get (str cid)) | _ -> Some Nil)
+  | "blob/has?" ->
+    (match a with cid :: _ -> Some (do_blob_has (str cid)) | _ -> Some (Bool false))
+  | _ -> None

hosts/ocaml/test/persist_durable_test.sh

@@ -0,0 +1,144 @@
+#!/usr/bin/env bash
+# hosts/ocaml/test/persist_durable_test.sh
+# Acceptance test for the host durable-storage adapter (Sx_persist_store).
+#
+# Exercises `persist/durable-backend` (REAL `perform`, not the mock) under the
+# WORKTREE-built sx_server.exe, and asserts:
+#   1. durable: writes land on disk and read back (the silent-data-loss repro
+#      from plans/persist-on-sx.md now returns correct values).
+#   2. last-seq is monotonic across truncate (compaction never reassigns a seq).
+#   3. kv ops round-trip and delete.
+#   4. recovery: a REAL process restart (write, exit, fresh process, replay)
+#      recovers state from disk.
+#
+# Run from repo root or anywhere; locates the worktree binary relative to itself.
+set -uo pipefail
+
+HERE="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)"
+ROOT="$(cd "$HERE/../../.." && pwd)"        # repo/worktree root
+cd "$ROOT"
+
+SX="hosts/ocaml/_build/default/bin/sx_server.exe"
+if [ ! -x "$SX" ]; then
+  echo "ERROR: worktree binary not found at $SX — build it first:" >&2
+  echo "  (cd hosts/ocaml && dune build bin/sx_server.exe)" >&2
+  exit 1
+fi
+
+DATADIR="$(mktemp -d)"
+trap 'rm -rf "$DATADIR"' EXIT
+
+PASS=0
+FAIL=0
+check() { # check <label> <got> <expected>
+  if [ "$2" = "$3" ]; then
+    PASS=$((PASS + 1)); printf '  ok   %-40s => %s\n' "$1" "$2"
+  else
+    FAIL=$((FAIL + 1)); printf '  FAIL %-40s got [%s] want [%s]\n' "$1" "$2" "$3"
+  fi
+}
+
+PRELUDE='(epoch 1)
+(load "spec/stdlib.sx")
+(load "lib/r7rs.sx")
+(load "lib/persist/event.sx")
+(load "lib/persist/backend.sx")
+(load "lib/persist/log.sx")
+(load "lib/persist/kv.sx")
+(load "lib/persist/durable.sx")
+(load "lib/persist/blob.sx")
+(epoch 2)'
+
+# run_eval <sx-expr-string>: prints the final (ok-len 2 ...) payload line.
+run_eval() {
+  local expr="$1"
+  printf '%s\n(eval %s)\n' "$PRELUDE" "$expr" \
+    | SX_PERSIST_DIR="$DATADIR" timeout 60 "$SX" 2>/dev/null \
+    | awk '/^\(ok-len 2 / {getline; print; exit}'
+}
+
+# escape an SX program into a single-line double-quoted SX string literal for
+# (eval "..."). The REPL reads one command per physical line, so newlines in the
+# program are collapsed to spaces.
+q() { printf '"%s"' "$(printf '%s' "$1" | tr '\n' ' ' | sed 's/\\/\\\\/g; s/"/\\"/g')"; }
+
+echo "== durable: append/read/last-seq round-trip on disk =="
+GOT=$(run_eval "$(q '(let ((b (persist/durable-backend)))
+  (begin
+    (persist/append b "s" "x" 0 {:v 1})
+    (persist/append b "s" "x" 0 {:v 2})
+    (list (persist/event-seq (persist/append b "s" "x" 0 {:v 3}))
+          (persist/count b "s")
+          (len (persist/read b "s")))))')")
+check "append/count/read" "$GOT" "(3 3 3)"
+
+echo "== last-seq monotonic across truncate =="
+GOT=$(run_eval "$(q '(let ((b (persist/durable-backend)))
+  (begin
+    (persist/append b "t" "x" 0 {})
+    (persist/append b "t" "x" 0 {})
+    (persist/append b "t" "x" 0 {})
+    (persist/truncate b "t" 2)
+    (list (persist/last-seq b "t") (persist/count b "t"))))')")
+check "last-seq survives truncate" "$GOT" "(3 1)"
+
+echo "== streams set survives compaction =="
+GOT=$(run_eval "$(q '(let ((b (persist/durable-backend)))
+  (sort ((get b "streams"))))')")
+check "streams" "$GOT" '("s" "t")'
+
+echo "== kv round-trip + delete =="
+GOT=$(run_eval "$(q '(let ((b (persist/durable-backend)))
+  (begin
+    (persist/kv-put b "k" {:a 1 :b "two"})
+    (persist/kv-put b "gone" 9)
+    (persist/kv-delete b "gone")
+    (list (get (persist/kv-get b "k") :b)
+          (persist/kv-has? b "k")
+          (persist/kv-has? b "gone"))))')")
+check "kv get/has/delete" "$GOT" '("two" true false)'
+
+echo "== recovery: state survives a REAL process restart =="
+# write in process A then let it exit; the next run is a brand-new process.
+run_eval "$(q '(let ((b (persist/durable-backend)))
+  (begin
+    (persist/append b "r" "ev" 0 {:n 1})
+    (persist/append b "r" "ev" 0 {:n 2})
+    (persist/kv-put b "survive" "yes")
+    (persist/count b "r")))')" >/dev/null
+# fresh process, same SX_PERSIST_DIR — must replay from disk.
+GOT=$(run_eval "$(q '(let ((b (persist/durable-backend)))
+  (list (persist/count b "r")
+        (persist/last-seq b "r")
+        (get (get (nth (persist/read b "r") 1) :data) :n)
+        (persist/kv-get b "survive")))')")
+check "recovered after restart" "$GOT" '(2 2 2 "yes")'
+
+echo "== blob: content-addressed put/get/has? round-trip =="
+GOT=$(run_eval "$(q '(let ((bs (persist/blob-store-backend)))
+  (let ((r (persist/blob-store bs "hello world" "text/plain")))
+    (list (persist/blob-size r)
+          (persist/blob-mime r)
+          (persist/blob-fetch bs r)
+          (persist/blob-exists? bs r))))')")
+check "blob size/mime/fetch/exists" "$GOT" '(11 "text/plain" "hello world" true)'
+
+echo "== blob: put is content-addressed (idempotent cid) =="
+GOT=$(run_eval "$(q '(let ((bs (persist/blob-store-backend)))
+  (equal? (persist/blob-cid (persist/blob-store bs "same bytes" "x"))
+          (persist/blob-cid (persist/blob-store bs "same bytes" "x"))))')")
+check "same bytes -> same cid" "$GOT" "true"
+
+echo "== blob: bytes + ref-in-kv survive a REAL restart =="
+# process A: store a blob, keep only its ref in the durable kv.
+run_eval "$(q '(let ((b (persist/durable-backend)) (bs (persist/blob-store-backend)))
+  (begin (persist/kv-put b "logo" (persist/blob-store bs "PNGDATA" "image/png")) nil))')" >/dev/null
+# fresh process: read the ref from kv, fetch the bytes from the blob store.
+GOT=$(run_eval "$(q '(let ((b (persist/durable-backend)) (bs (persist/blob-store-backend)))
+  (let ((r (persist/kv-get b "logo")))
+    (list (persist/blob-fetch bs r) (persist/blob-exists? bs r) (persist/blob-mime r))))')")
+check "blob recovered via ref after restart" "$GOT" '("PNGDATA" true "image/png")'
+
+echo
+echo "durable adapter: $PASS passed, $FAIL failed"
+[ "$FAIL" -eq 0 ]

lib/artdag/analyze.sx

@@ -0,0 +1,88 @@
+; lib/artdag/analyze.sx — Phase 2: Analyze on Datalog.
+; Project the DAG's edges into a Datalog db and answer dependency questions
+; (deps, dependents, transitive reachability) plus dirty-closure propagation
+; as recursive Datalog — the acl/relations reachability shape. Depends on
+; lib/artdag/dag.sx and the lib/datalog/ public API.
+
+; edge(input-id, node-id): data flows input -> node (input is a dependency).
+(define
+  artdag/edge-facts
+  (fn
+    (dag)
+    (reduce
+      (fn
+        (acc id)
+        (concat
+          acc
+          (map
+            (fn (in) (list (quote edge) in id))
+            (artdag/node-inputs (artdag/dag-get dag id)))))
+      (list)
+      (keys (artdag/dag-nodes dag)))))
+
+; reachable(X,Y): Y is a transitive dependent of X (forward, downstream).
+(define
+  artdag/reach-rules
+  (quote
+    ((reachable X Y <- (edge X Y))
+      (reachable X Z <- (edge X Y) (reachable Y Z)))))
+
+(define
+  artdag/analyze
+  (fn (dag) (dl-program-data (artdag/edge-facts dag) artdag/reach-rules)))
+
+; pull a single variable's bindings out of a subst list, sorted for determinism.
+(define
+  artdag/-bindings
+  (fn
+    (substs var)
+    (artdag/sort-strings (map (fn (s) (get s var)) substs))))
+
+; direct dependencies (inputs) of a node.
+(define
+  artdag/deps-of
+  (fn
+    (db id)
+    (artdag/-bindings (dl-query db (list (quote edge) (quote X) id)) :X)))
+
+; direct dependents of a node.
+(define
+  artdag/dependents-of
+  (fn
+    (db id)
+    (artdag/-bindings (dl-query db (list (quote edge) id (quote Y))) :Y)))
+
+; transitive dependents (everything downstream of a node).
+(define
+  artdag/reachable-from
+  (fn
+    (db id)
+    (artdag/-bindings
+      (dl-query db (list (quote reachable) id (quote Y)))
+      :Y)))
+
+; transitive dependencies (everything upstream of a node).
+(define
+  artdag/ancestors-of
+  (fn
+    (db id)
+    (artdag/-bindings
+      (dl-query db (list (quote reachable) (quote X) id))
+      :X)))
+
+; dirty propagation: dirty(Y) :- edge(X,Y), dirty(X). Seeds are changed nodes.
+(define artdag/dirty-rules (quote ((dirty Y <- (edge X Y) (dirty X)))))
+
+(define
+  artdag/dirty-seeds
+  (fn (changed) (map (fn (c) (list (quote dirty) c)) changed)))
+
+; transitive dirty closure of a set of changed node-ids: the changed nodes plus
+; every transitive dependent that must recompute. Sorted, deduplicated.
+(define
+  artdag/dirty-closure
+  (fn
+    (dag changed)
+    (let
+      ((db (dl-program-data (concat (artdag/edge-facts dag) (artdag/dirty-seeds changed)) artdag/dirty-rules)))
+      (artdag/-bindings (dl-query db (list (quote dirty) (quote X))) :X))))

lib/artdag/api.sx

@@ -0,0 +1,91 @@
+; lib/artdag/api.sx — public API index for the artdag content-addressed dataflow
+; DAG engine. Reference-only: `load` is an epoch-protocol command, not an SX
+; function, so this file cannot reload the modules from inside another `.sx`. To
+; set up a session, issue these loads in order (after spec/stdlib.sx + lib/r7rs.sx,
+; the lib/datalog/* modules, and the lib/persist/* modules):
+;
+;   (load "lib/artdag/dag.sx")
+;   (load "lib/artdag/analyze.sx")      ; requires lib/datalog/*
+;   (load "lib/artdag/plan.sx")
+;   (load "lib/artdag/execute.sx")      ; requires lib/persist/*
+;   (load "lib/artdag/optimize.sx")
+;   (load "lib/artdag/federation.sx")
+;   (load "lib/artdag/cost.sx")
+;   (load "lib/artdag/serialize.sx")
+;   (load "lib/artdag/stats.sx")
+;   (load "lib/artdag/fault.sx")
+;
+; (lib/artdag/conformance.sh runs this load list automatically.)
+;
+; ── Public API surface ─────────────────────────────────────────────
+;
+;   Model / content addressing (dag.sx):
+;     (artdag/node op inputs params)        node spec (non-commutative)
+;     (artdag/cnode op inputs params)       commutative node spec
+;     (artdag/content-id node)              structural digest "node:..."
+;     (artdag/build entries)                {:ok :nodes :names :order} | {:ok false :error}
+;       entry = (name op (input-names...) params [commutative?])
+;     (artdag/dag-id dag name)              local name -> content-id
+;     (artdag/dag-get dag id)               content-id -> node
+;     (artdag/dag-node-by-name dag name)    name -> node
+;     (artdag/dag-order dag)                topo-ordered content-ids
+;     (artdag/node-count dag)               distinct node count
+;
+;   Analyze on Datalog (analyze.sx):
+;     (artdag/analyze dag)                  -> datalog db
+;     (artdag/deps-of db id)                direct dependencies
+;     (artdag/dependents-of db id)          direct dependents
+;     (artdag/reachable-from db id)         transitive dependents
+;     (artdag/ancestors-of db id)           transitive dependencies
+;     (artdag/dirty-closure dag changed)    changed nodes + all dependents
+;
+;   Plan (plan.sx):
+;     (artdag/plan dag cap)                 topo batches under width cap (0 = unlimited)
+;     (artdag/plan-dirty dag changed cap)   incremental plan over the dirty closure
+;     (artdag/plan-batches/-width/-size/-flatten plan)
+;
+;   Execute (execute.sx):
+;     (artdag/op-table-runner table)        runner from op-name -> (fn (params inputs))
+;     (artdag/run dag runner cache)         full memoized run
+;     (artdag/run-dirty dag changed runner cache)
+;     (artdag/execute dag plan runner cache) -> {:results :recomputed :hits}
+;     (artdag/result-of/recompute-count/hit-count/recomputed exec)
+;       cache = a lib/persist kv backend (persist/open)
+;
+;   Optimize (optimize.sx):
+;     (artdag/dce dag outputs)              drop nodes not feeding the outputs
+;     (artdag/cse entries)                  == build (sharing is free from content ids)
+;     (artdag/fuse entries fusible?)        collapse fusible unary chains -> pipeline nodes
+;     (artdag/fusing-runner base-runner)    runner that replays pipeline stages
+;     (artdag/optimize entries outputs fusible?)  fuse then dce
+;
+;   Federation (federation.sx):
+;     (artdag/fed-open)                     {:cache :prov}
+;     (artdag/fed-run fed dag runner)       run against the instance cache
+;     (artdag/fed-export fed peer-id)       bundle of {:cid :result :peer}
+;     (artdag/fed-import fed bundle trusted?)  trust-gated import + provenance
+;     (artdag/fed-pull fed fetch-fn peer-id trusted?)  pull via injected transport
+;     (artdag/fed-invalidate fed peer-id)   drop a peer's results (peer-scoped)
+;
+;   Cost / scheduling (cost.sx):
+;     (artdag/const-cost) (artdag/op-cost table)   cost-fn (op params) -> number
+;     (artdag/critical-path dag cost-fn)    longest weighted path
+;     (artdag/makespan dag plan cost-fn)    estimated wall-clock under a plan
+;     (artdag/total-work dag cost-fn) (artdag/speedup dag plan cost-fn)
+;
+;   Serialize (serialize.sx):
+;     (artdag/dag->wire dag) (artdag/wire->dag records)  portable record form
+;     (artdag/wire-verify records)          content-id integrity check
+;     (artdag/dag->string dag) (artdag/string->dag s)    text transport
+;
+;   Stats (stats.sx):
+;     (artdag/hit-ratio exec)
+;     (artdag/work-recomputed/work-saved exec dag cost-fn)
+;     (artdag/savings-ratio exec dag cost-fn) (artdag/exec-summary exec dag cost-fn)
+;
+;   Fault tolerance (fault.sx):
+;     (artdag/fail reason) (artdag/failed? v)
+;     (artdag/run-safe dag runner cache)    -> {:results :recomputed :hits :failed}
+;     (artdag/failed-nodes/failure-count/all-ok? exec)
+
+(define artdag/version "1.0")

lib/artdag/conformance.sh

@@ -0,0 +1,153 @@
+#!/usr/bin/env bash
+# lib/artdag/conformance.sh — run artdag test suites, emit scoreboard.json + scoreboard.md.
+
+set -uo pipefail
+cd "$(git rev-parse --show-toplevel)"
+
+SX_SERVER="${SX_SERVER:-/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe}"
+if [ ! -x "$SX_SERVER" ]; then
+  SX_SERVER="hosts/ocaml/_build/default/bin/sx_server.exe"
+fi
+if [ ! -x "$SX_SERVER" ]; then
+  echo "ERROR: sx_server.exe not found." >&2
+  exit 1
+fi
+
+SUITES=(dag analyze plan execute optimize fed cost serialize stats fault maude-optimize)
+
+OUT_JSON="lib/artdag/scoreboard.json"
+OUT_MD="lib/artdag/scoreboard.md"
+
+run_suite() {
+  local suite=$1
+  local file="lib/artdag/tests/${suite}.sx"
+  local TMP
+  TMP=$(mktemp)
+  local MAUDE_LOADS=""
+  local BRIDGE_LOAD=""
+  if [ "$suite" = "maude-optimize" ]; then
+    MAUDE_LOADS='(load "lib/guest/lex.sx")
+(load "lib/guest/pratt.sx")
+(load "lib/maude/term.sx")
+(load "lib/maude/parser.sx")
+(load "lib/maude/sorts.sx")
+(load "lib/maude/reduce.sx")
+(load "lib/maude/matching.sx")
+(load "lib/maude/conditional.sx")
+(load "lib/maude/fire.sx")
+(load "lib/maude/rewrite.sx")
+(load "lib/maude/searchpath.sx")
+(load "lib/maude/strategy.sx")
+(load "lib/maude/meta.sx")
+(load "lib/maude/pretty.sx")
+(load "lib/maude/run.sx")'
+    BRIDGE_LOAD='(load "lib/artdag/maude-bridge.sx")'
+  fi
+  cat > "$TMP" << EPOCHS
+(epoch 1)
+(load "spec/stdlib.sx")
+(load "lib/r7rs.sx")
+(load "lib/datalog/tokenizer.sx")
+(load "lib/datalog/parser.sx")
+(load "lib/datalog/unify.sx")
+(load "lib/datalog/db.sx")
+(load "lib/datalog/builtins.sx")
+(load "lib/datalog/aggregates.sx")
+(load "lib/datalog/strata.sx")
+(load "lib/datalog/eval.sx")
+(load "lib/datalog/api.sx")
+(load "lib/persist/event.sx")
+(load "lib/persist/backend.sx")
+(load "lib/persist/log.sx")
+(load "lib/persist/kv.sx")
+(load "lib/persist/api.sx")
+${MAUDE_LOADS}
+(load "lib/artdag/dag.sx")
+(load "lib/artdag/analyze.sx")
+(load "lib/artdag/plan.sx")
+(load "lib/artdag/execute.sx")
+(load "lib/artdag/optimize.sx")
+(load "lib/artdag/federation.sx")
+(load "lib/artdag/cost.sx")
+(load "lib/artdag/serialize.sx")
+(load "lib/artdag/stats.sx")
+(load "lib/artdag/fault.sx")
+(load "lib/artdag/api.sx")
+${BRIDGE_LOAD}
+(epoch 2)
+(eval "(define artdag-test-pass 0)")
+(eval "(define artdag-test-fail 0)")
+(eval "(define artdag-test (fn (name got expected) (if (= got expected) (set! artdag-test-pass (+ artdag-test-pass 1)) (set! artdag-test-fail (+ artdag-test-fail 1)))))")
+(epoch 3)
+(load "${file}")
+(epoch 4)
+(eval "(list artdag-test-pass artdag-test-fail)")
+EPOCHS
+
+  local OUTPUT
+  OUTPUT=$(timeout 300 "$SX_SERVER" < "$TMP" 2>/dev/null)
+  rm -f "$TMP"
+
+  local LINE
+  LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 4 / {getline; print; exit}')
+  if [ -z "$LINE" ]; then
+    LINE=$(echo "$OUTPUT" | grep -E '^\(ok 4 \([0-9]+ [0-9]+\)\)' | tail -1 \
+            | sed -E 's/^\(ok 4 //; s/\)$//')
+  fi
+
+  local P F
+  P=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\1/')
+  F=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\2/')
+  P=${P:-0}
+  F=${F:-0}
+  echo "${P} ${F}"
+}
+
+declare -A SUITE_PASS
+declare -A SUITE_FAIL
+TOTAL_PASS=0
+TOTAL_FAIL=0
+
+echo "Running artdag conformance suite..." >&2
+for s in "${SUITES[@]}"; do
+  read -r p f < <(run_suite "$s")
+  SUITE_PASS[$s]=$p
+  SUITE_FAIL[$s]=$f
+  TOTAL_PASS=$((TOTAL_PASS + p))
+  TOTAL_FAIL=$((TOTAL_FAIL + f))
+  printf "  %-12s %d/%d\n" "$s" "$p" "$((p+f))" >&2
+done
+
+{
+  printf '{\n'
+  printf '  "suites": {\n'
+  first=1
+  for s in "${SUITES[@]}"; do
+    if [ $first -eq 0 ]; then printf ',\n'; fi
+    printf '    "%s": {"pass": %d, "fail": %d}' "$s" "${SUITE_PASS[$s]}" "${SUITE_FAIL[$s]}"
+    first=0
+  done
+  printf '\n  },\n'
+  printf '  "total_pass": %d,\n' "$TOTAL_PASS"
+  printf '  "total_fail": %d,\n' "$TOTAL_FAIL"
+  printf '  "total": %d\n' "$((TOTAL_PASS + TOTAL_FAIL))"
+  printf '}\n'
+} > "$OUT_JSON"
+
+{
+  printf '# artdag Conformance Scoreboard\n\n'
+  printf '_Generated by `lib/artdag/conformance.sh`_\n\n'
+  printf '| Suite | Pass | Fail | Total |\n'
+  printf '|-------|-----:|-----:|------:|\n'
+  for s in "${SUITES[@]}"; do
+    p=${SUITE_PASS[$s]}
+    f=${SUITE_FAIL[$s]}
+    printf '| %s | %d | %d | %d |\n' "$s" "$p" "$f" "$((p+f))"
+  done
+  printf '| **Total** | **%d** | **%d** | **%d** |\n' "$TOTAL_PASS" "$TOTAL_FAIL" "$((TOTAL_PASS + TOTAL_FAIL))"
+} > "$OUT_MD"
+
+echo "Wrote $OUT_JSON and $OUT_MD" >&2
+echo "Total: $TOTAL_PASS pass, $TOTAL_FAIL fail" >&2
+
+[ "$TOTAL_FAIL" -eq 0 ]

lib/artdag/cost.sx

@@ -0,0 +1,66 @@
+; lib/artdag/cost.sx — cost model for the scheduler: per-node weights, critical
+; path (min makespan with unlimited parallelism), plan makespan under batching/cap,
+; total serial work, and the resulting speedup. Costs come from an injected
+; cost-fn (op params) -> number so media-op costs stay opaque. Depends on dag.sx.
+
+(define artdag/const-cost (fn (op params) 1))
+
+(define
+  artdag/op-cost
+  (fn
+    (table)
+    (fn (op params) (if (has-key? table op) (get table op) 1))))
+
+(define
+  artdag/-node-cost
+  (fn
+    (dag cost-fn id)
+    (let
+      ((n (artdag/dag-get dag id)))
+      (cost-fn (artdag/node-op n) (artdag/node-params n)))))
+
+(define
+  artdag/-max
+  (fn (xs) (reduce (fn (mx x) (if (> x mx) x mx)) 0 xs)))
+
+; longest weighted path through the dag = makespan with unlimited workers.
+(define
+  artdag/critical-path
+  (fn
+    (dag cost-fn)
+    (let
+      ((ft (reduce (fn (m id) (let ((maxdep (artdag/-max (map (fn (d) (get m d)) (artdag/node-inputs (artdag/dag-get dag id)))))) (assoc m id (+ (artdag/-node-cost dag cost-fn id) maxdep)))) {} (artdag/dag-order dag))))
+      (artdag/-max (map (fn (id) (get ft id)) (keys ft))))))
+
+; estimated wall-clock for a plan: each batch runs in parallel (costs its
+; slowest node), batches run in sequence.
+(define
+  artdag/makespan
+  (fn
+    (dag plan cost-fn)
+    (reduce
+      (fn
+        (total batch)
+        (+
+          total
+          (artdag/-max
+            (map (fn (id) (artdag/-node-cost dag cost-fn id)) batch))))
+      0
+      plan)))
+
+; total serial work = sum of all node costs.
+(define
+  artdag/total-work
+  (fn
+    (dag cost-fn)
+    (reduce
+      (fn (s id) (+ s (artdag/-node-cost dag cost-fn id)))
+      0
+      (keys (artdag/dag-nodes dag)))))
+
+; speedup of a plan vs running everything serially.
+(define
+  artdag/speedup
+  (fn
+    (dag plan cost-fn)
+    (/ (artdag/total-work dag cost-fn) (artdag/makespan dag plan cost-fn))))

lib/artdag/dag.sx

@@ -0,0 +1,226 @@
+; lib/artdag/dag.sx — DAG model + structural content addressing.
+; A node = {:op :inputs :params :commutative}. inputs are content-ids of upstream
+; nodes. The content-id is a deterministic structural digest so identical
+; subgraphs collapse to one id (and one cache slot). No clock, no randomness.
+
+; ---- string ordering (no host sort/string<?) ----
+
+(define
+  artdag/str<?-at
+  (fn
+    (a b i la lb)
+    (cond
+      ((and (>= i la) (>= i lb)) false)
+      ((>= i la) true)
+      ((>= i lb) false)
+      (else
+        (let
+          ((ca (char-code (substring a i (+ i 1))))
+            (cb (char-code (substring b i (+ i 1)))))
+          (cond
+            ((< ca cb) true)
+            ((> ca cb) false)
+            (else (artdag/str<?-at a b (+ i 1) la lb))))))))
+
+(define
+  artdag/str<?
+  (fn
+    (a b)
+    (artdag/str<?-at a b 0 (string-length a) (string-length b))))
+
+(define
+  artdag/insert-string
+  (fn
+    (sorted x)
+    (cond
+      ((empty? sorted) (list x))
+      ((artdag/str<? x (first sorted)) (cons x sorted))
+      (else (cons (first sorted) (artdag/insert-string (rest sorted) x))))))
+
+(define
+  artdag/sort-strings
+  (fn (xs) (reduce (fn (acc x) (artdag/insert-string acc x)) (list) xs)))
+
+; ---- canonical serialization ----
+
+(define
+  artdag/canon-list
+  (fn
+    (xs)
+    (if
+      (empty? xs)
+      ""
+      (reduce
+        (fn (acc x) (str acc " " (artdag/canon x)))
+        (artdag/canon (first xs))
+        (rest xs)))))
+
+(define
+  artdag/canon-dict
+  (fn
+    (d)
+    (str
+      "{"
+      (reduce
+        (fn (acc k) (str acc " " k "=" (artdag/canon (get d k))))
+        ""
+        (artdag/sort-strings (keys d)))
+      "}")))
+
+(define
+  artdag/canon
+  (fn
+    (v)
+    (let
+      ((t (type-of v)))
+      (cond
+        ((equal? t "nil") "nil")
+        ((equal? t "boolean") (if v "#t" "#f"))
+        ((equal? t "number") (number->string v))
+        ((equal? t "string") (str "\"" v "\""))
+        ((equal? t "keyword") (str ":" (keyword-name v)))
+        ((equal? t "symbol") (str "'" (write-to-string v)))
+        ((equal? t "list") (str "(" (artdag/canon-list v) ")"))
+        ((equal? t "dict") (artdag/canon-dict v))
+        (else (str "<" t ">" (write-to-string v)))))))
+
+; ---- node + content id ----
+
+(define artdag/node (fn (op inputs params) {:inputs inputs :commutative false :op op :params params}))
+
+(define artdag/cnode (fn (op inputs params) {:inputs inputs :commutative true :op op :params params}))
+
+(define artdag/node-op (fn (n) (get n :op)))
+(define artdag/node-inputs (fn (n) (get n :inputs)))
+(define artdag/node-params (fn (n) (get n :params)))
+
+(define
+  artdag/content-id
+  (fn
+    (node)
+    (let
+      ((ins (if (get node :commutative) (artdag/sort-strings (get node :inputs)) (get node :inputs))))
+      (str
+        "node:"
+        (artdag/canon (list (get node :op) ins (get node :params)))))))
+
+(define artdag/id-of artdag/content-id)
+
+; ---- list helpers ----
+
+(define artdag/member? (fn (x xs) (some (fn (y) (equal? y x)) xs)))
+
+(define
+  artdag/all-in?
+  (fn (xs placed) (every? (fn (x) (artdag/member? x placed)) xs)))
+
+; ---- build: entries -> validated, content-addressed dag ----
+; entry = (local-name op (input-local-names...) params [commutative?])
+
+(define artdag/entry-name (fn (e) (nth e 0)))
+(define artdag/entry-op (fn (e) (nth e 1)))
+(define artdag/entry-inputs (fn (e) (nth e 2)))
+(define artdag/entry-params (fn (e) (nth e 3)))
+(define
+  artdag/entry-commutative
+  (fn (e) (if (> (len e) 4) (nth e 4) false)))
+
+(define
+  artdag/entries->map
+  (fn
+    (entries)
+    (reduce
+      (fn (m e) (assoc m (artdag/entry-name e) {:inputs (artdag/entry-inputs e) :commutative (artdag/entry-commutative e) :op (artdag/entry-op e) :params (artdag/entry-params e)}))
+      {}
+      entries)))
+
+(define
+  artdag/dangling
+  (fn
+    (spec-map)
+    (reduce
+      (fn
+        (acc name)
+        (reduce
+          (fn (a in) (if (has-key? spec-map in) a (cons in a)))
+          acc
+          (get (get spec-map name) :inputs)))
+      (list)
+      (keys spec-map))))
+
+(define
+  artdag/ready-names
+  (fn
+    (spec-map placed)
+    (filter
+      (fn
+        (name)
+        (and
+          (not (artdag/member? name placed))
+          (artdag/all-in? (get (get spec-map name) :inputs) placed)))
+      (artdag/sort-strings (keys spec-map)))))
+
+(define
+  artdag/topo-loop
+  (fn
+    (spec-map placed)
+    (if
+      (= (len placed) (len (keys spec-map)))
+      {:order placed :ok true}
+      (let
+        ((ready (artdag/ready-names spec-map placed)))
+        (if
+          (empty? ready)
+          {:error "cycle" :ok false}
+          (artdag/topo-loop spec-map (concat placed ready)))))))
+
+(define artdag/topo (fn (spec-map) (artdag/topo-loop spec-map (list))))
+
+(define
+  artdag/resolve-ids
+  (fn
+    (spec-map order)
+    (reduce
+      (fn
+        (dag name)
+        (let
+          ((spec (get spec-map name)))
+          (let
+            ((resolved (map (fn (in) (get (get dag :names) in)) (get spec :inputs))))
+            (let
+              ((node {:inputs resolved :commutative (get spec :commutative) :op (get spec :op) :params (get spec :params)}))
+              (let ((id (artdag/content-id node))) {:names (assoc (get dag :names) name id) :order (if (artdag/member? id (get dag :order)) (get dag :order) (concat (get dag :order) (list id))) :nodes (assoc (get dag :nodes) id node)})))))
+      {:names {} :order (list) :nodes {}}
+      order)))
+
+(define
+  artdag/build
+  (fn
+    (entries)
+    (let
+      ((spec-map (artdag/entries->map entries)))
+      (let
+        ((dang (artdag/dangling spec-map)))
+        (if
+          (not (empty? dang))
+          {:refs dang :error "dangling" :ok false}
+          (let
+            ((topo (artdag/topo spec-map)))
+            (if
+              (not (get topo :ok))
+              {:error (get topo :error) :ok false}
+              (assoc
+                (artdag/resolve-ids spec-map (get topo :order))
+                :ok true))))))))
+
+; ---- dag accessors ----
+
+(define artdag/dag-nodes (fn (dag) (get dag :nodes)))
+(define artdag/dag-names (fn (dag) (get dag :names)))
+(define artdag/dag-order (fn (dag) (get dag :order)))
+(define artdag/dag-id (fn (dag name) (get (get dag :names) name)))
+(define artdag/dag-get (fn (dag id) (get (get dag :nodes) id)))
+(define
+  artdag/dag-node-by-name
+  (fn (dag name) (artdag/dag-get dag (artdag/dag-id dag name))))
+(define artdag/node-count (fn (dag) (len (keys (get dag :nodes)))))

lib/artdag/execute.sx

@@ -0,0 +1,82 @@
+; lib/artdag/execute.sx — Phase 4: interpret a plan with a content-addressed
+; memo cache. A node's result is keyed by its content-id, so a node whose id is
+; already in the cache is skipped (cache hit). Because changing a leaf changes
+; the content-ids of its whole dirty closure, re-running recomputes exactly those
+; nodes and cache-hits the rest — incremental recompute falls out of content
+; addressing. Depends on dag.sx and plan.sx; the cache is a lib/persist/ backend.
+
+; runner: (fn (op params input-results) -> result). The injected effect interface.
+; In production this performs the op (perform -> JAX/IPFS adapter); in tests it
+; dispatches a pure SX op over its already-computed input results.
+
+; build a runner from a dict of op-name -> (fn (params inputs) -> result).
+(define
+  artdag/op-table-runner
+  (fn (table) (fn (op params inputs) ((get table op) params inputs))))
+
+; resolve an input id's result: this run's results first, then the warm cache.
+(define
+  artdag/-input-result
+  (fn
+    (results cache in)
+    (if (has-key? results in) (get results in) (persist/kv-get cache in))))
+
+(define
+  artdag/-exec-node
+  (fn
+    (dag runner cache acc id)
+    (let
+      ((node (artdag/dag-get dag id)))
+      (if
+        (persist/kv-has? cache id)
+        (assoc
+          acc
+          :results (assoc (get acc :results) id (persist/kv-get cache id))
+          :hits (concat (get acc :hits) (list id)))
+        (let
+          ((inputs (map (fn (in) (artdag/-input-result (get acc :results) cache in)) (artdag/node-inputs node))))
+          (let
+            ((result (runner (artdag/node-op node) (artdag/node-params node) inputs)))
+            (begin
+              (persist/kv-put cache id result)
+              (assoc
+                acc
+                :results (assoc (get acc :results) id result)
+                :recomputed (concat (get acc :recomputed) (list id))))))))))
+
+; execute a plan against a memo cache, returning {:results :recomputed :hits}.
+(define
+  artdag/execute
+  (fn
+    (dag plan runner cache)
+    (reduce
+      (fn (acc id) (artdag/-exec-node dag runner cache acc id))
+      {:recomputed (list) :results {} :hits (list)}
+      (artdag/plan-flatten plan))))
+
+; full run over every node, unlimited width.
+(define
+  artdag/run
+  (fn
+    (dag runner cache)
+    (artdag/execute dag (artdag/plan dag 0) runner cache)))
+
+; incremental run: schedule only the dirty closure of the changed nodes.
+(define
+  artdag/run-dirty
+  (fn
+    (dag changed runner cache)
+    (artdag/execute
+      dag
+      (artdag/plan-dirty dag changed 0)
+      runner
+      cache)))
+
+; ---- result inspection ----
+
+(define artdag/result-of (fn (exec id) (get (get exec :results) id)))
+(define
+  artdag/recomputed
+  (fn (exec) (artdag/sort-strings (get exec :recomputed))))
+(define artdag/recompute-count (fn (exec) (len (get exec :recomputed))))
+(define artdag/hit-count (fn (exec) (len (get exec :hits))))

lib/artdag/fault.sx

@@ -0,0 +1,56 @@
+; lib/artdag/fault.sx — fault-tolerant execution. A node op may fail by returning
+; (artdag/fail reason); the failure is confined to that node and its transitive
+; dependents (which cannot run without it), while independent branches still
+; compute. Failed results are NEVER cached, so a later run with the fault fixed
+; recomputes only the failed closure. Depends on execute.sx and plan.sx.
+
+(define artdag/fail (fn (reason) {:artdag-fail true :reason reason}))
+(define artdag/failed? (fn (v) (and (dict? v) (has-key? v :artdag-fail))))
+
+(define
+  artdag/-exec-safe-node
+  (fn
+    (dag runner cache acc id)
+    (let
+      ((node (artdag/dag-get dag id)))
+      (let
+        ((ins (artdag/node-inputs node)))
+        (if
+          (some (fn (in) (artdag/member? in (get acc :failed))) ins)
+          (assoc acc :failed (concat (get acc :failed) (list id)))
+          (if
+            (persist/kv-has? cache id)
+            (assoc
+              acc
+              :results (assoc (get acc :results) id (persist/kv-get cache id))
+              :hits (concat (get acc :hits) (list id)))
+            (let
+              ((inputs (map (fn (in) (artdag/-input-result (get acc :results) cache in)) ins)))
+              (let
+                ((result (runner (artdag/node-op node) (artdag/node-params node) inputs)))
+                (if
+                  (artdag/failed? result)
+                  (assoc acc :failed (concat (get acc :failed) (list id)))
+                  (begin
+                    (persist/kv-put cache id result)
+                    (assoc
+                      acc
+                      :results (assoc (get acc :results) id result)
+                      :recomputed (concat (get acc :recomputed) (list id)))))))))))))
+
+(define
+  artdag/run-safe
+  (fn
+    (dag runner cache)
+    (reduce
+      (fn (acc id) (artdag/-exec-safe-node dag runner cache acc id))
+      {:recomputed (list) :results {} :hits (list) :failed (list)}
+      (artdag/plan-flatten (artdag/plan dag 0)))))
+
+(define
+  artdag/failed-nodes
+  (fn (exec) (artdag/sort-strings (get exec :failed))))
+(define artdag/failure-count (fn (exec) (len (get exec :failed))))
+(define
+  artdag/all-ok?
+  (fn (exec) (= (len (get exec :failed)) 0)))

lib/artdag/federation.sx

@@ -0,0 +1,75 @@
+; lib/artdag/federation.sx — Phase 6: shared content-addressed cache across
+; instances (the L2-registry analog). Because content-ids are global, a result
+; computed on one instance is reusable on another by id. Imports are trust-gated
+; and carry provenance so a peer's results can be invalidated when trust is
+; withdrawn. Transport is injected (mock in tests). Depends on dag.sx, execute.sx
+; (the cache is a lib/persist/ kv backend) — federation tracks provenance beside it.
+
+; an instance: a persist kv cache + a provenance map {cid -> origin-peer}.
+(define artdag/fed-open (fn () {:cache (persist/open) :prov {}}))
+(define artdag/fed-cache (fn (fed) (get fed :cache)))
+(define artdag/fed-prov (fn (fed) (get fed :prov)))
+
+(define
+  artdag/-dict-remove
+  (fn
+    (d key)
+    (reduce
+      (fn (acc k) (if (= k key) acc (assoc acc k (get d k))))
+      {}
+      (keys d))))
+
+; export every cached result as a bundle of {:cid :result :peer}, tagged with
+; the exporting instance's peer id (the result's origin/provenance).
+(define
+  artdag/fed-export
+  (fn
+    (fed peer-id)
+    (map (fn (cid) {:peer peer-id :cid cid :result (persist/kv-get (get fed :cache) cid)}) (persist/kv-keys (get fed :cache)))))
+
+; import a bundle, accepting only records from trusted peers (trust gating) and
+; recording each accepted result's provenance. Returns the updated instance.
+(define
+  artdag/fed-import
+  (fn
+    (fed bundle trusted?)
+    (reduce
+      (fn
+        (f rec)
+        (if
+          (trusted? (get rec :peer))
+          (begin
+            (persist/kv-put (get f :cache) (get rec :cid) (get rec :result))
+            {:cache (get f :cache) :prov (assoc (get f :prov) (get rec :cid) (get rec :peer))})
+          f))
+      fed
+      bundle)))
+
+; pull from a peer through an injected transport (fetch-fn peer-id -> bundle).
+(define
+  artdag/fed-pull
+  (fn
+    (fed fetch-fn peer-id trusted?)
+    (artdag/fed-import fed (fetch-fn peer-id) trusted?)))
+
+; invalidate: drop every cached result provenanced to a peer (trust withdrawn),
+; from both the cache and the provenance map. Locally-computed results (no
+; provenance) are untouched. Returns the updated instance.
+(define
+  artdag/fed-invalidate
+  (fn
+    (fed peer-id)
+    (reduce
+      (fn
+        (f cid)
+        (if
+          (= (get (get f :prov) cid) peer-id)
+          (begin (persist/kv-delete (get f :cache) cid) {:cache (get f :cache) :prov (artdag/-dict-remove (get f :prov) cid)})
+          f))
+      fed
+      (keys (get fed :prov)))))
+
+; convenience: run a dag against an instance's cache.
+(define
+  artdag/fed-run
+  (fn (fed dag runner) (artdag/run dag runner (artdag/fed-cache fed))))

lib/artdag/maude-bridge.sx

@@ -0,0 +1,118 @@
+; lib/artdag/maude-bridge.sx — adapter between an artdag effect DAG and maude terms.
+; A node {:op :inputs :params :commutative} <-> a maude (mau/app op (args...)).
+; Inputs become argument subterms (recursively from the DAG). A trailing
+; "artdag:meta" subterm carries the params (a write-to-string token) and the
+; commutativity flag, so the encoding is lossless and dag->term->dag is the
+; identity on canonical (content-id) form. Commutative ops map to maude AC
+; operators in the optimizer module, so input order is irrelevant there —
+; mirroring the content-id's order-insensitivity for commutative nodes.
+;
+; maude (lib/maude) is a READ-ONLY consumed substrate: mau/app, mau/const,
+; mau/op, mau/args, mau/app? are its term constructors/accessors.
+
+; ---- list helpers (no host last/but-last) ----
+
+(define
+  artdag/mb-last
+  (fn
+    (xs)
+    (if (empty? (rest xs)) (first xs) (artdag/mb-last (rest xs)))))
+
+(define
+  artdag/mb-but-last
+  (fn
+    (xs)
+    (if
+      (empty? (rest xs))
+      (list)
+      (cons (first xs) (artdag/mb-but-last (rest xs))))))
+
+; ---- params <-> token ----
+; params are keyword-keyed dicts; write-to-string/read round-trips them
+; (key order may differ but the dicts compare structurally equal).
+
+(define artdag/mb-meta-op "artdag:meta")
+
+(define artdag/params->token (fn (params) (write-to-string params)))
+
+(define artdag/token->params (fn (token) (read (open-input-string token))))
+
+(define
+  artdag/mb-meta-term
+  (fn
+    (params commutative)
+    (mau/app
+      artdag/mb-meta-op
+      (list
+        (mau/const (artdag/params->token params))
+        (mau/const (if commutative "c" "n"))))))
+
+(define
+  artdag/mb-meta-term?
+  (fn (t) (and (mau/app? t) (= (mau/op t) artdag/mb-meta-op))))
+
+; ---- dag -> term ----
+
+(define
+  artdag/node->term
+  (fn
+    (node input-terms)
+    (mau/app
+      (artdag/node-op node)
+      (concat
+        input-terms
+        (list
+          (artdag/mb-meta-term
+            (artdag/node-params node)
+            (get node :commutative)))))))
+
+(define
+  artdag/dag->term
+  (fn
+    (dag id)
+    (let
+      ((node (artdag/dag-get dag id)))
+      (artdag/node->term
+        node
+        (map (fn (in) (artdag/dag->term dag in)) (artdag/node-inputs node))))))
+
+; ---- term -> dag ----
+; build-entries with synthesized local names; artdag/build recomputes content-ids
+; (which are name-independent), so the reconstructed dag is identical on canonical
+; form. Shared subterms re-collapse to one node/id during build's dedup.
+
+(define artdag/term-meta (fn (t) (artdag/mb-last (mau/args t))))
+
+(define artdag/term-input-terms (fn (t) (artdag/mb-but-last (mau/args t))))
+
+(define
+  artdag/term-params
+  (fn
+    (t)
+    (artdag/token->params (mau/op (first (mau/args (artdag/term-meta t)))))))
+
+(define
+  artdag/term-commutative
+  (fn
+    (t)
+    (= "c" (mau/op (nth (mau/args (artdag/term-meta t)) 1)))))
+
+(define
+  artdag/term->build
+  (fn
+    (t counter acc)
+    (let
+      ((built (reduce (fn (st child) (let ((r (artdag/term->build child (get st :counter) (get st :acc)))) {:counter (get r :counter) :acc (get r :acc) :names (concat (get st :names) (list (get r :name)))})) {:counter counter :acc acc :names (list)} (artdag/term-input-terms t))))
+      (let ((my-name (str "mb" (get built :counter)))) {:name my-name :counter (+ (get built :counter) 1) :acc (concat (get built :acc) (list (list my-name (mau/op t) (get built :names) (artdag/term-params t) (artdag/term-commutative t))))}))))
+
+(define
+  artdag/term->entries
+  (fn (t) (get (artdag/term->build t 0 (list)) :acc)))
+
+(define artdag/term->dag (fn (t) (artdag/build (artdag/term->entries t))))
+
+; ---- round-trip convenience ----
+
+(define
+  artdag/mb-roundtrip
+  (fn (dag id) (artdag/term->dag (artdag/dag->term dag id))))

lib/artdag/optimize.sx

@@ -0,0 +1,202 @@
+; lib/artdag/optimize.sx — Phase 5: result-preserving DAG rewrites.
+;   DCE    — drop nodes not reachable upstream from the requested outputs.
+;   CSE    — free from content addressing: structurally identical subexpressions
+;            already collapse to one node at build time (artdag/cse == build).
+;   Fusion — collapse a maximal 1-to-1 chain of fusible unary ops into a single
+;            "artdag/pipeline" node that replays the stages; output-equivalent.
+;   optimize — fuse then DCE in one pass.
+; Depends on dag.sx and analyze.sx.
+
+; ---- dict helper ----
+
+(define
+  artdag/-dict-filter
+  (fn
+    (d keep?)
+    (reduce
+      (fn (acc k) (if (keep? k (get d k)) (assoc acc k (get d k)) acc))
+      {}
+      (keys d))))
+
+(define
+  artdag/-union
+  (fn
+    (a b)
+    (reduce (fn (acc x) (if (artdag/member? x acc) acc (cons x acc))) a b)))
+
+; ---- dead-node elimination ----
+; keep only the outputs and their transitive dependencies; ids are preserved.
+(define
+  artdag/dce
+  (fn
+    (dag outputs)
+    (let
+      ((db (artdag/analyze dag)))
+      (let
+        ((live (reduce (fn (acc out) (artdag/-union (artdag/-union acc (list out)) (artdag/ancestors-of db out))) (list) outputs)))
+        {:names (artdag/-dict-filter (artdag/dag-names dag) (fn (k v) (artdag/member? v live))) :order (filter (fn (id) (artdag/member? id live)) (artdag/dag-order dag)) :ok true :nodes (artdag/-dict-filter (artdag/dag-nodes dag) (fn (k v) (artdag/member? k live)))}))))
+
+; ---- common-subexpression elimination ----
+; structural sharing is inherent to content addressing: build already maps
+; structurally identical specs to a single node/id.
+(define artdag/cse artdag/build)
+
+; ---- adjacent-op fusion (entry-level rewrite) ----
+
+(define artdag/pipeline-op "artdag/pipeline")
+
+(define
+  artdag/-name->entry
+  (fn
+    (entries)
+    (reduce
+      (fn (m e) (assoc m (artdag/entry-name e) e))
+      {}
+      entries)))
+
+; name -> list of dependent names
+(define
+  artdag/-deps-map
+  (fn
+    (entries)
+    (reduce
+      (fn
+        (m e)
+        (reduce
+          (fn
+            (mm i)
+            (assoc
+              mm
+              i
+              (cons
+                (artdag/entry-name e)
+                (if (has-key? mm i) (get mm i) (list)))))
+          m
+          (artdag/entry-inputs e)))
+      {}
+      entries)))
+
+(define artdag/-stage (fn (e) {:op (artdag/entry-op e) :params (artdag/entry-params e)}))
+
+; the single predecessor that `name` may absorb, or nil. Requires: name is a
+; fusible unary op; its one input is a locally-defined fusible node whose ONLY
+; dependent is name (so fusing cannot break sharing).
+(define
+  artdag/-absorbs
+  (fn
+    (n->e deps fusible? name)
+    (let
+      ((e (get n->e name)))
+      (let
+        ((ins (artdag/entry-inputs e)))
+        (if
+          (= (len ins) 1)
+          (let
+            ((x (first ins)))
+            (if
+              (and
+                (has-key? n->e x)
+                (fusible? (artdag/entry-op e))
+                (fusible? (artdag/entry-op (get n->e x)))
+                (= (get deps x) (list name)))
+              x
+              nil))
+          nil)))))
+
+(define
+  artdag/-absorbed-set
+  (fn
+    (n->e deps fusible? names)
+    (reduce
+      (fn
+        (acc y)
+        (let
+          ((p (artdag/-absorbs n->e deps fusible? y)))
+          (if (nil? p) acc (cons p acc))))
+      (list)
+      names)))
+
+; walk predecessors from a tail, building stages head->tail.
+(define
+  artdag/-fuse-chain
+  (fn
+    (n->e deps fusible? cur stages)
+    (let
+      ((p (artdag/-absorbs n->e deps fusible? cur)))
+      (if
+        (nil? p)
+        {:stages (cons (artdag/-stage (get n->e cur)) stages) :head cur}
+        (artdag/-fuse-chain
+          n->e
+          deps
+          fusible?
+          p
+          (cons (artdag/-stage (get n->e cur)) stages))))))
+
+(define
+  artdag/fuse-entries
+  (fn
+    (entries fusible?)
+    (let
+      ((n->e (artdag/-name->entry entries))
+        (deps (artdag/-deps-map entries))
+        (names (map artdag/entry-name entries)))
+      (let
+        ((absorbed (artdag/-absorbed-set n->e deps fusible? names)))
+        (map
+          (fn
+            (name)
+            (let
+              ((c (artdag/-fuse-chain n->e deps fusible? name (list))))
+              (if
+                (> (len (get c :stages)) 1)
+                (list
+                  name
+                  artdag/pipeline-op
+                  (artdag/entry-inputs (get n->e (get c :head)))
+                  {:stages (get c :stages)})
+                (get n->e name))))
+          (filter (fn (name) (not (artdag/member? name absorbed))) names))))))
+
+(define
+  artdag/fuse
+  (fn
+    (entries fusible?)
+    (artdag/build (artdag/fuse-entries entries fusible?))))
+
+; runner that replays a fused pipeline over its single input, delegating each
+; stage to a base runner; non-pipeline ops fall through unchanged.
+(define
+  artdag/pipeline-run
+  (fn
+    (base-runner)
+    (fn
+      (params inputs)
+      (reduce
+        (fn
+          (val stage)
+          (base-runner (get stage :op) (get stage :params) (list val)))
+        (first inputs)
+        (get params :stages)))))
+
+(define
+  artdag/fusing-runner
+  (fn
+    (base-runner)
+    (fn
+      (op params inputs)
+      (if
+        (= op artdag/pipeline-op)
+        ((artdag/pipeline-run base-runner) params inputs)
+        (base-runner op params inputs)))))
+
+; ---- full optimization pass ----
+; fuse the entry list, then drop everything not feeding the requested output
+; names. Output names survive fusion (sinks are never absorbed).
+(define
+  artdag/optimize
+  (fn
+    (entries outputs fusible?)
+    (let
+      ((fused (artdag/fuse entries fusible?)))
+      (artdag/dce fused (map (fn (nm) (artdag/dag-id fused nm)) outputs)))))

lib/artdag/plan.sx

@@ -0,0 +1,100 @@
+; lib/artdag/plan.sx — Phase 3: schedule a DAG (or its dirty subset) into
+; topological batches under a max-parallelism cap. A batch is a set of nodes
+; whose deps are all satisfied by earlier batches, so they run in parallel.
+; cap <= 0 means unlimited width. Depends on dag.sx and analyze.sx.
+
+; inputs of id that also lie inside the scheduled set (out-of-set deps are
+; treated as already satisfied — e.g. clean cache hits in an incremental plan).
+(define
+  artdag/-deps-in
+  (fn
+    (dag id sset)
+    (filter
+      (fn (in) (artdag/member? in sset))
+      (artdag/node-inputs (artdag/dag-get dag id)))))
+
+(define
+  artdag/-ready-in
+  (fn
+    (dag sset placed)
+    (filter
+      (fn
+        (id)
+        (and
+          (not (artdag/member? id placed))
+          (artdag/all-in? (artdag/-deps-in dag id sset) placed)))
+      (artdag/sort-strings sset))))
+
+(define
+  artdag/-batch-loop
+  (fn
+    (dag sset placed batches)
+    (if
+      (= (len placed) (len sset))
+      batches
+      (let
+        ((wave (artdag/-ready-in dag sset placed)))
+        (artdag/-batch-loop
+          dag
+          sset
+          (concat placed wave)
+          (concat batches (list wave)))))))
+
+; split a wave into consecutive chunks of at most n (sorted order preserved).
+(define
+  artdag/-chunk
+  (fn
+    (xs n)
+    (if
+      (<= (len xs) n)
+      (list xs)
+      (cons
+        (slice xs 0 n)
+        (artdag/-chunk (slice xs n (len xs)) n)))))
+
+(define
+  artdag/-cap-split
+  (fn
+    (batches cap)
+    (if
+      (<= cap 0)
+      batches
+      (reduce
+        (fn (acc b) (concat acc (artdag/-chunk b cap)))
+        (list)
+        batches))))
+
+; schedule an explicit set of node-ids into capped topological batches.
+(define
+  artdag/plan-subset
+  (fn
+    (dag node-ids cap)
+    (artdag/-cap-split (artdag/-batch-loop dag node-ids (list) (list)) cap)))
+
+; full plan over every node in the dag.
+(define
+  artdag/plan
+  (fn (dag cap) (artdag/plan-subset dag (keys (artdag/dag-nodes dag)) cap)))
+
+; incremental plan: schedule only the dirty closure of the changed nodes.
+(define
+  artdag/plan-dirty
+  (fn
+    (dag changed cap)
+    (artdag/plan-subset dag (artdag/dirty-closure dag changed) cap)))
+
+; ---- plan inspection ----
+
+(define artdag/plan-batches (fn (plan) (len plan)))
+
+(define
+  artdag/plan-width
+  (fn
+    (plan)
+    (reduce (fn (m b) (if (> (len b) m) (len b) m)) 0 plan)))
+
+(define
+  artdag/plan-flatten
+  (fn (plan) (reduce (fn (acc b) (concat acc b)) (list) plan)))
+
+(define artdag/plan-size (fn (plan) (len (artdag/plan-flatten plan))))

lib/artdag/scoreboard.json

@@ -0,0 +1,18 @@
+{
+  "suites": {
+    "dag": {"pass": 20, "fail": 0},
+    "analyze": {"pass": 16, "fail": 0},
+    "plan": {"pass": 18, "fail": 0},
+    "execute": {"pass": 15, "fail": 0},
+    "optimize": {"pass": 22, "fail": 0},
+    "fed": {"pass": 15, "fail": 0},
+    "cost": {"pass": 13, "fail": 0},
+    "serialize": {"pass": 13, "fail": 0},
+    "stats": {"pass": 12, "fail": 0},
+    "fault": {"pass": 14, "fail": 0},
+    "maude-optimize": {"pass": 14, "fail": 0}
+  },
+  "total_pass": 172,
+  "total_fail": 0,
+  "total": 172
+}

lib/artdag/scoreboard.md

@@ -0,0 +1,18 @@
+# artdag Conformance Scoreboard
+
+_Generated by `lib/artdag/conformance.sh`_
+
+| Suite | Pass | Fail | Total |
+|-------|-----:|-----:|------:|
+| dag | 20 | 0 | 20 |
+| analyze | 16 | 0 | 16 |
+| plan | 18 | 0 | 18 |
+| execute | 15 | 0 | 15 |
+| optimize | 22 | 0 | 22 |
+| fed | 15 | 0 | 15 |
+| cost | 13 | 0 | 13 |
+| serialize | 13 | 0 | 13 |
+| stats | 12 | 0 | 12 |
+| fault | 14 | 0 | 14 |
+| maude-optimize | 14 | 0 | 14 |
+| **Total** | **172** | **0** | **172** |

lib/artdag/serialize.sx

@@ -0,0 +1,62 @@
+; lib/artdag/serialize.sx — portable wire form for whole DAGs, so a peer can
+; receive and run a graph it did not author. The form is a topo-ordered list of
+; node records (id op inputs params commutative) — plain lists with keyword-keyed
+; param dicts, which survive write/read (unlike string-keyed node dicts). The id
+; is the content-id, so the form is self-verifying. Depends on dag.sx.
+
+(define
+  artdag/node->record
+  (fn
+    (dag id)
+    (let
+      ((n (artdag/dag-get dag id)))
+      (list
+        id
+        (artdag/node-op n)
+        (artdag/node-inputs n)
+        (artdag/node-params n)
+        (get n :commutative)))))
+
+; dag -> list of records, in topological order.
+(define
+  artdag/dag->wire
+  (fn
+    (dag)
+    (map (fn (id) (artdag/node->record dag id)) (artdag/dag-order dag))))
+
+; an empty input list reads back as nil; normalize it.
+(define
+  artdag/-rec-inputs
+  (fn (rec) (let ((i (nth rec 2))) (if (nil? i) (list) i))))
+
+(define artdag/-rec->node (fn (rec) {:inputs (artdag/-rec-inputs rec) :commutative (nth rec 4) :op (nth rec 1) :params (nth rec 3)}))
+
+; records -> dag. Local author names are not part of the wire form; the receiver
+; works by content-id. :names is left empty.
+(define
+  artdag/wire->dag
+  (fn
+    (records)
+    (reduce
+      (fn (dag rec) (let ((id (nth rec 0))) {:names (get dag :names) :order (concat (get dag :order) (list id)) :ok true :nodes (assoc (get dag :nodes) id (artdag/-rec->node rec))}))
+      {:names {} :order (list) :ok true :nodes {}}
+      records)))
+
+; integrity: each record's id must equal the content-id recomputed from its spec.
+(define
+  artdag/wire-verify
+  (fn
+    (records)
+    (every?
+      (fn
+        (rec)
+        (= (nth rec 0) (artdag/content-id (artdag/-rec->node rec))))
+      records)))
+
+; string transport.
+(define
+  artdag/dag->string
+  (fn (dag) (write-to-string (artdag/dag->wire dag))))
+(define
+  artdag/string->dag
+  (fn (s) (artdag/wire->dag (read (open-input-string s)))))

lib/artdag/stats.sx

@@ -0,0 +1,51 @@
+; lib/artdag/stats.sx — observability over an execution: cache hit ratio and the
+; compute work saved by memoization (weighted by the cost model). An exec is the
+; {:results :recomputed :hits} record returned by artdag/execute. Depends on
+; execute.sx (exec accessors) and cost.sx (artdag/-node-cost).
+
+(define
+  artdag/exec-total
+  (fn (exec) (+ (artdag/recompute-count exec) (artdag/hit-count exec))))
+
+; fraction of executed nodes served from cache (0 when nothing ran).
+(define
+  artdag/hit-ratio
+  (fn
+    (exec)
+    (let
+      ((n (artdag/exec-total exec)))
+      (if (= n 0) 0 (/ (artdag/hit-count exec) n)))))
+
+(define
+  artdag/-sum-cost
+  (fn
+    (dag cost-fn ids)
+    (reduce
+      (fn (s id) (+ s (artdag/-node-cost dag cost-fn id)))
+      0
+      ids)))
+
+; weighted compute work that actually ran this execution.
+(define
+  artdag/work-recomputed
+  (fn
+    (exec dag cost-fn)
+    (artdag/-sum-cost dag cost-fn (get exec :recomputed))))
+
+; weighted compute work avoided by cache hits.
+(define
+  artdag/work-saved
+  (fn (exec dag cost-fn) (artdag/-sum-cost dag cost-fn (get exec :hits))))
+
+; fraction of total weighted work that the cache saved (0 when no work at all).
+(define
+  artdag/savings-ratio
+  (fn
+    (exec dag cost-fn)
+    (let
+      ((saved (artdag/work-saved exec dag cost-fn))
+        (ran (artdag/work-recomputed exec dag cost-fn)))
+      (if (= (+ saved ran) 0) 0 (/ saved (+ saved ran))))))
+
+; compact summary dict for logging.
+(define artdag/exec-summary (fn (exec dag cost-fn) {:work-saved (artdag/work-saved exec dag cost-fn) :recomputed (artdag/recompute-count exec) :total (artdag/exec-total exec) :work-ran (artdag/work-recomputed exec dag cost-fn) :hits (artdag/hit-count exec)}))

lib/artdag/tests/analyze.sx

@@ -0,0 +1,119 @@
+; Phase 2 — Analyze on Datalog: deps/dependents/reachability + dirty closure.
+
+; diamond:  a -> b, a -> c, (b,c) -> d
+(define
+  an-D
+  (artdag/build
+    (list
+      (list "a" "load" (list) {})
+      (list "b" "f" (list "a") {})
+      (list "c" "g" (list "a") {})
+      (list "d" "add" (list "b" "c") {} true))))
+(define an-db (artdag/analyze an-D))
+(define an-a (artdag/dag-id an-D "a"))
+(define an-b (artdag/dag-id an-D "b"))
+(define an-c (artdag/dag-id an-D "c"))
+(define an-d (artdag/dag-id an-D "d"))
+
+; ---- direct deps / dependents ----
+
+(artdag-test
+  "deps-of: direct inputs"
+  (artdag/deps-of an-db an-d)
+  (artdag/sort-strings (list an-b an-c)))
+
+(artdag-test "deps-of: leaf has none" (artdag/deps-of an-db an-a) (list))
+
+(artdag-test
+  "dependents-of: direct consumers"
+  (artdag/dependents-of an-db an-a)
+  (artdag/sort-strings (list an-b an-c)))
+
+(artdag-test
+  "dependents-of: output has none"
+  (artdag/dependents-of an-db an-d)
+  (list))
+
+; ---- transitive reachability ----
+
+(artdag-test
+  "reachable-from: all downstream"
+  (artdag/reachable-from an-db an-a)
+  (artdag/sort-strings (list an-b an-c an-d)))
+
+(artdag-test
+  "reachable-from: mid node reaches output"
+  (artdag/reachable-from an-db an-b)
+  (list an-d))
+
+(artdag-test
+  "ancestors-of: all upstream"
+  (artdag/ancestors-of an-db an-d)
+  (artdag/sort-strings (list an-a an-b an-c)))
+
+(artdag-test
+  "ancestors-of: leaf has none"
+  (artdag/ancestors-of an-db an-a)
+  (list))
+
+; ---- deep chain ----
+
+(define
+  ch-D
+  (artdag/build
+    (list
+      (list "a" "load" (list) {})
+      (list "b" "f" (list "a") {})
+      (list "c" "f" (list "b") {})
+      (list "d" "f" (list "c") {}))))
+(define ch-db (artdag/analyze ch-D))
+
+(artdag-test
+  "deep chain: reachable-from leaf"
+  (artdag/reachable-from ch-db (artdag/dag-id ch-D "a"))
+  (artdag/sort-strings
+    (list
+      (artdag/dag-id ch-D "b")
+      (artdag/dag-id ch-D "c")
+      (artdag/dag-id ch-D "d"))))
+
+(artdag-test
+  "deep chain: ancestors of tip"
+  (artdag/ancestors-of ch-db (artdag/dag-id ch-D "d"))
+  (artdag/sort-strings
+    (list
+      (artdag/dag-id ch-D "a")
+      (artdag/dag-id ch-D "b")
+      (artdag/dag-id ch-D "c"))))
+
+; ---- dirty closure ----
+
+(artdag-test
+  "dirty closure: change leaf dirties all"
+  (artdag/dirty-closure an-D (list an-a))
+  (artdag/sort-strings (list an-a an-b an-c an-d)))
+
+(artdag-test
+  "dirty closure: change mid touches only downstream"
+  (artdag/dirty-closure an-D (list an-b))
+  (artdag/sort-strings (list an-b an-d)))
+
+(artdag-test
+  "dirty closure: unaffected stay clean (count)"
+  (len (artdag/dirty-closure an-D (list an-b)))
+  2)
+
+(artdag-test
+  "dirty closure: change output dirties only itself"
+  (artdag/dirty-closure an-D (list an-d))
+  (list an-d))
+
+(artdag-test
+  "dirty closure: multiple seeds union"
+  (artdag/dirty-closure an-D (list an-b an-c))
+  (artdag/sort-strings (list an-b an-c an-d)))
+
+(artdag-test
+  "dirty closure: empty seed set"
+  (artdag/dirty-closure an-D (list))
+  (list))

lib/artdag/tests/cost.sx

@@ -0,0 +1,117 @@
+; cost model: critical path, makespan under cap, total work, speedup.
+
+(define
+  cost-CHAIN
+  (artdag/build
+    (list
+      (list "a" "in" (list) {})
+      (list "b" "f" (list "a") {})
+      (list "c" "f" (list "b") {})
+      (list "d" "f" (list "c") {}))))
+
+(define
+  cost-DIA
+  (artdag/build
+    (list
+      (list "a" "in" (list) {})
+      (list "b" "f" (list "a") {})
+      (list "c" "g" (list "a") {})
+      (list "d" "add" (list "b" "c") {} true))))
+
+(define cost-W (artdag/op-cost {:f 2 :add 5}))
+
+; ---- unit cost ----
+
+(artdag-test
+  "critical path: chain is its length"
+  (artdag/critical-path cost-CHAIN artdag/const-cost)
+  4)
+
+(artdag-test
+  "critical path: diamond longest path"
+  (artdag/critical-path cost-DIA artdag/const-cost)
+  3)
+
+(artdag-test
+  "total work: unit cost equals node count"
+  (artdag/total-work cost-DIA artdag/const-cost)
+  4)
+
+(artdag-test
+  "single node critical path is its cost"
+  (artdag/critical-path
+    (artdag/build (list (list "a" "in" (list) {})))
+    artdag/const-cost)
+  1)
+
+; ---- makespan vs cap ----
+
+(artdag-test
+  "full plan makespan equals critical path"
+  (artdag/makespan
+    cost-DIA
+    (artdag/plan cost-DIA 0)
+    artdag/const-cost)
+  (artdag/critical-path cost-DIA artdag/const-cost))
+
+(artdag-test
+  "serial plan makespan equals total work"
+  (artdag/makespan
+    cost-DIA
+    (artdag/plan cost-DIA 1)
+    artdag/const-cost)
+  (artdag/total-work cost-DIA artdag/const-cost))
+
+(artdag-test
+  "capped makespan is never below the critical path"
+  (>=
+    (artdag/makespan
+      cost-DIA
+      (artdag/plan cost-DIA 1)
+      artdag/const-cost)
+    (artdag/critical-path cost-DIA artdag/const-cost))
+  true)
+
+; ---- weighted costs ----
+
+(artdag-test
+  "weighted critical path follows heavy ops"
+  (artdag/critical-path cost-DIA cost-W)
+  8)
+
+(artdag-test
+  "weighted total work sums all node costs"
+  (artdag/total-work cost-DIA cost-W)
+  9)
+
+(artdag-test
+  "op-cost defaults unknown ops to 1"
+  (artdag/total-work
+    (artdag/build (list (list "a" "in" (list) {})))
+    cost-W)
+  1)
+
+(artdag-test
+  "weighted full-plan makespan equals critical path"
+  (artdag/makespan cost-DIA (artdag/plan cost-DIA 0) cost-W)
+  (artdag/critical-path cost-DIA cost-W))
+
+; ---- speedup ----
+
+(artdag-test
+  "serial plan has no speedup"
+  (artdag/speedup
+    cost-DIA
+    (artdag/plan cost-DIA 1)
+    artdag/const-cost)
+  1)
+
+(artdag-test
+  "parallel plan beats serial"
+  (>
+    (artdag/speedup
+      cost-DIA
+      (artdag/plan cost-DIA 0)
+      artdag/const-cost)
+    1)
+  true)

lib/artdag/tests/dag.sx

@@ -0,0 +1,182 @@
+; Phase 1 — dag model + structural content addressing.
+
+; ---- content-id determinism ----
+
+(artdag-test
+  "same spec -> same id"
+  (equal?
+    (artdag/content-id (artdag/node "blur" (list "i1") {:r 3}))
+    (artdag/content-id (artdag/node "blur" (list "i1") {:r 3})))
+  true)
+
+(artdag-test
+  "op affects id"
+  (equal?
+    (artdag/content-id (artdag/node "blur" (list "i1") {}))
+    (artdag/content-id (artdag/node "sharpen" (list "i1") {})))
+  false)
+
+(artdag-test
+  "params affect id"
+  (equal?
+    (artdag/content-id (artdag/node "blur" (list "i1") {:r 3}))
+    (artdag/content-id (artdag/node "blur" (list "i1") {:r 5})))
+  false)
+
+(artdag-test
+  "inputs affect id"
+  (equal?
+    (artdag/content-id (artdag/node "add" (list "i1") {}))
+    (artdag/content-id (artdag/node "add" (list "i2") {})))
+  false)
+
+(artdag-test
+  "param key order does not affect id"
+  (equal?
+    (artdag/content-id (artdag/node "op" (list) {:a 1 :b 2}))
+    (artdag/content-id (artdag/node "op" (list) {:a 1 :b 2})))
+  true)
+
+; ---- commutativity ----
+
+(artdag-test
+  "commutative op: input order ignored"
+  (equal?
+    (artdag/content-id (artdag/cnode "add" (list "i1" "i2") {}))
+    (artdag/content-id (artdag/cnode "add" (list "i2" "i1") {})))
+  true)
+
+(artdag-test
+  "non-commutative op: input order matters"
+  (equal?
+    (artdag/content-id (artdag/node "sub" (list "i1" "i2") {}))
+    (artdag/content-id (artdag/node "sub" (list "i2" "i1") {})))
+  false)
+
+; ---- build: success ----
+
+(artdag-test
+  "build ok for valid dag"
+  (get
+    (artdag/build
+      (list
+        (list "a" "load" (list) {})
+        (list "b" "load" (list) {:s 1})
+        (list "c" "add" (list "a" "b") {})))
+    :ok)
+  true)
+
+(artdag-test
+  "node-count counts distinct nodes"
+  (artdag/node-count
+    (artdag/build
+      (list
+        (list "a" "load" (list) {})
+        (list "b" "load" (list) {:s 1})
+        (list "c" "add" (list "a" "b") {}))))
+  3)
+
+; ---- subgraph sharing ----
+
+(artdag-test
+  "identical leaves dedup to one node"
+  (artdag/node-count
+    (artdag/build
+      (list
+        (list "a" "load" (list) {:s 1})
+        (list "b" "load" (list) {:s 1})
+        (list "c" "add" (list "a" "b") {}))))
+  2)
+
+(artdag-test
+  "duplicate names map to same id"
+  (let
+    ((d (artdag/build (list (list "a" "load" (list) {:s 1}) (list "b" "load" (list) {:s 1})))))
+    (equal? (artdag/dag-id d "a") (artdag/dag-id d "b")))
+  true)
+
+(artdag-test
+  "identical subgraph shares id across dags"
+  (let
+    ((d1 (artdag/build (list (list "x" "load" (list) {:s 7}) (list "y" "neg" (list "x") {}))))
+      (d2
+        (artdag/build
+          (list
+            (list "p" "load" (list) {:s 7})
+            (list "q" "neg" (list "p") {})))))
+    (equal? (artdag/dag-id d1 "y") (artdag/dag-id d2 "q")))
+  true)
+
+; ---- validation ----
+
+(artdag-test
+  "cycle rejected"
+  (get
+    (artdag/build
+      (list
+        (list "a" "f" (list "b") {})
+        (list "b" "g" (list "a") {})))
+    :error)
+  "cycle")
+
+(artdag-test
+  "self-cycle rejected"
+  (get (artdag/build (list (list "a" "f" (list "a") {}))) :error)
+  "cycle")
+
+(artdag-test
+  "dangling input rejected"
+  (get
+    (artdag/build (list (list "a" "f" (list "ghost") {})))
+    :error)
+  "dangling")
+
+(artdag-test
+  "dangling refs reported"
+  (get
+    (artdag/build (list (list "a" "f" (list "ghost") {})))
+    :refs)
+  (list "ghost"))
+
+; ---- topological order ----
+
+(artdag-test
+  "topo order: deps before dependents"
+  (let
+    ((d (artdag/build (list (list "c" "add" (list "a" "b") {}) (list "a" "load" (list) {:s 1}) (list "b" "load" (list) {:s 2})))))
+    (artdag/dag-order d))
+  (let
+    ((d (artdag/build (list (list "c" "add" (list "a" "b") {}) (list "a" "load" (list) {:s 1}) (list "b" "load" (list) {:s 2})))))
+    (list (artdag/dag-id d "a") (artdag/dag-id d "b") (artdag/dag-id d "c"))))
+
+(artdag-test
+  "topo order: deep chain"
+  (let
+    ((d (artdag/build (list (list "d" "f" (list "c") {}) (list "c" "f" (list "b") {}) (list "b" "f" (list "a") {}) (list "a" "load" (list) {})))))
+    (artdag/dag-order d))
+  (let
+    ((d (artdag/build (list (list "d" "f" (list "c") {}) (list "c" "f" (list "b") {}) (list "b" "f" (list "a") {}) (list "a" "load" (list) {})))))
+    (list
+      (artdag/dag-id d "a")
+      (artdag/dag-id d "b")
+      (artdag/dag-id d "c")
+      (artdag/dag-id d "d"))))
+
+; ---- accessors ----
+
+(artdag-test
+  "dag-node-by-name returns node spec"
+  (artdag/node-op
+    (artdag/dag-node-by-name
+      (artdag/build (list (list "a" "load" (list) {})))
+      "a"))
+  "load")
+
+(artdag-test
+  "resolved inputs are content-ids"
+  (let
+    ((d (artdag/build (list (list "a" "load" (list) {}) (list "b" "neg" (list "a") {})))))
+    (artdag/node-inputs (artdag/dag-node-by-name d "b")))
+  (let
+    ((d (artdag/build (list (list "a" "load" (list) {}) (list "b" "neg" (list "a") {})))))
+    (list (artdag/dag-id d "a"))))

lib/artdag/tests/execute.sx

@@ -0,0 +1,188 @@
+; Phase 4 — Execute: effect interpreter + content-addressed memo + incremental.
+
+(define ex-RT (artdag/op-table-runner {:in (fn (params inputs) (get params :v)) :add (fn (params inputs) (+ (nth inputs 0) (nth inputs 1))) :inc (fn (params inputs) (+ 1 (first inputs)))}))
+
+; two-leaf diamond: p,q leaves; b=inc(p); c=inc(q); d=add(b,c)
+(define
+  ex-D1
+  (artdag/build
+    (list
+      (list "p" "in" (list) {:v 10})
+      (list "q" "in" (list) {:v 20})
+      (list "b" "inc" (list "p") {})
+      (list "c" "inc" (list "q") {})
+      (list "d" "add" (list "b" "c") {} true))))
+
+; same shape, leaf q changed (20 -> 21)
+(define
+  ex-D2
+  (artdag/build
+    (list
+      (list "p" "in" (list) {:v 10})
+      (list "q" "in" (list) {:v 21})
+      (list "b" "inc" (list "p") {})
+      (list "c" "inc" (list "q") {})
+      (list "d" "add" (list "b" "c") {} true))))
+
+; a different dag that shares the p->b subgraph with ex-D1, plus z=inc(b)
+(define
+  ex-D3
+  (artdag/build
+    (list
+      (list "p" "in" (list) {:v 10})
+      (list "b" "inc" (list "p") {})
+      (list "z" "inc" (list "b") {}))))
+
+; ---- full execution ----
+
+(artdag-test
+  "full run: result is correct"
+  (let
+    ((cache (persist/open)))
+    (artdag/result-of
+      (artdag/run ex-D1 ex-RT cache)
+      (artdag/dag-id ex-D1 "d")))
+  32)
+
+(artdag-test
+  "full run: cold cache recomputes every node"
+  (let
+    ((cache (persist/open)))
+    (artdag/recompute-count (artdag/run ex-D1 ex-RT cache)))
+  5)
+
+(artdag-test
+  "full run: cold cache has no hits"
+  (let
+    ((cache (persist/open)))
+    (artdag/hit-count (artdag/run ex-D1 ex-RT cache)))
+  0)
+
+; ---- memoization ----
+
+(artdag-test
+  "re-run unchanged: zero recomputes"
+  (let
+    ((cache (persist/open)))
+    (begin
+      (artdag/run ex-D1 ex-RT cache)
+      (artdag/recompute-count (artdag/run ex-D1 ex-RT cache))))
+  0)
+
+(artdag-test
+  "re-run unchanged: all cache hits"
+  (let
+    ((cache (persist/open)))
+    (begin
+      (artdag/run ex-D1 ex-RT cache)
+      (artdag/hit-count (artdag/run ex-D1 ex-RT cache))))
+  5)
+
+(artdag-test
+  "re-run unchanged: result preserved"
+  (let
+    ((cache (persist/open)))
+    (begin
+      (artdag/run ex-D1 ex-RT cache)
+      (artdag/result-of
+        (artdag/run ex-D1 ex-RT cache)
+        (artdag/dag-id ex-D1 "d"))))
+  32)
+
+; ---- incremental recompute (the keystone) ----
+
+(artdag-test
+  "leaf change recomputes only the dirty closure (count)"
+  (let
+    ((cache (persist/open)))
+    (begin
+      (artdag/run ex-D1 ex-RT cache)
+      (artdag/recompute-count (artdag/run ex-D2 ex-RT cache))))
+  3)
+
+(artdag-test
+  "leaf change: unchanged nodes are cache hits"
+  (let
+    ((cache (persist/open)))
+    (begin
+      (artdag/run ex-D1 ex-RT cache)
+      (artdag/hit-count (artdag/run ex-D2 ex-RT cache))))
+  2)
+
+(artdag-test
+  "leaf change: recomputed set is exactly q,c,d"
+  (let
+    ((cache (persist/open)))
+    (begin
+      (artdag/run ex-D1 ex-RT cache)
+      (artdag/recomputed (artdag/run ex-D2 ex-RT cache))))
+  (artdag/sort-strings
+    (list
+      (artdag/dag-id ex-D2 "q")
+      (artdag/dag-id ex-D2 "c")
+      (artdag/dag-id ex-D2 "d"))))
+
+(artdag-test
+  "leaf change: untouched sibling p is reused"
+  (let
+    ((cache (persist/open)))
+    (begin
+      (artdag/run ex-D1 ex-RT cache)
+      (artdag/member?
+        (artdag/dag-id ex-D2 "p")
+        (get (artdag/run ex-D2 ex-RT cache) :hits))))
+  true)
+
+(artdag-test
+  "leaf change: new result is correct"
+  (let
+    ((cache (persist/open)))
+    (begin
+      (artdag/run ex-D1 ex-RT cache)
+      (artdag/result-of
+        (artdag/run ex-D2 ex-RT cache)
+        (artdag/dag-id ex-D2 "d"))))
+  33)
+
+; ---- explicit dirty-only execution ----
+
+(artdag-test
+  "run-dirty: schedules only the changed closure"
+  (let
+    ((cache (persist/open)))
+    (begin
+      (artdag/run ex-D1 ex-RT cache)
+      (artdag/recompute-count
+        (artdag/run-dirty ex-D2 (list (artdag/dag-id ex-D2 "q")) ex-RT cache))))
+  3)
+
+; ---- cross-dag cache sharing (content addressing) ----
+
+(artdag-test
+  "shared subgraph hits cache across different dags"
+  (let
+    ((cache (persist/open)))
+    (begin
+      (artdag/run ex-D1 ex-RT cache)
+      (artdag/recompute-count (artdag/run ex-D3 ex-RT cache))))
+  1)
+
+(artdag-test
+  "shared subgraph: p and b reused across dags"
+  (let
+    ((cache (persist/open)))
+    (begin
+      (artdag/run ex-D1 ex-RT cache)
+      (artdag/hit-count (artdag/run ex-D3 ex-RT cache))))
+  2)
+
+(artdag-test
+  "shared subgraph: z still computes correctly"
+  (let
+    ((cache (persist/open)))
+    (begin
+      (artdag/run ex-D1 ex-RT cache)
+      (artdag/result-of
+        (artdag/run ex-D3 ex-RT cache)
+        (artdag/dag-id ex-D3 "z"))))
+  12)

lib/artdag/tests/fault.sx

@@ -0,0 +1,144 @@
+; fault-tolerant execution: failure confined to its closure, cache never poisoned.
+
+(define ft-BAD (artdag/op-table-runner {:boom (fn (p i) (artdag/fail "kaboom")) :in (fn (p i) (get p :v)) :add (fn (p i) (+ (nth i 0) (nth i 1))) :inc (fn (p i) (+ 1 (first i)))}))
+
+(define ft-GOOD (artdag/op-table-runner {:boom (fn (p i) 99) :in (fn (p i) (get p :v)) :add (fn (p i) (+ (nth i 0) (nth i 1))) :inc (fn (p i) (+ 1 (first i)))}))
+
+; p,q leaves; b=inc(p) (independent); c=boom(q); d=add(b,c)
+(define
+  ft-D
+  (artdag/build
+    (list
+      (list "p" "in" (list) {:v 10})
+      (list "q" "in" (list) {:v 20})
+      (list "b" "inc" (list "p") {})
+      (list "c" "boom" (list "q") {})
+      (list "d" "add" (list "b" "c") {} true))))
+
+; ---- markers ----
+
+(artdag-test
+  "fail constructor is detected"
+  (artdag/failed? (artdag/fail "x"))
+  true)
+
+(artdag-test
+  "plain values are not failures"
+  (artdag/failed? 42)
+  false)
+
+; ---- failure confinement ----
+
+(artdag-test
+  "failure count covers node and its dependents"
+  (let
+    ((cache (persist/open)))
+    (artdag/failure-count (artdag/run-safe ft-D ft-BAD cache)))
+  2)
+
+(artdag-test
+  "failed set is exactly c and d"
+  (let
+    ((cache (persist/open)))
+    (artdag/failed-nodes (artdag/run-safe ft-D ft-BAD cache)))
+  (artdag/sort-strings
+    (list (artdag/dag-id ft-D "c") (artdag/dag-id ft-D "d"))))
+
+(artdag-test
+  "independent branch still computes"
+  (let
+    ((cache (persist/open)))
+    (artdag/recompute-count (artdag/run-safe ft-D ft-BAD cache)))
+  3)
+
+(artdag-test
+  "independent node result is available"
+  (let
+    ((cache (persist/open)))
+    (artdag/result-of
+      (artdag/run-safe ft-D ft-BAD cache)
+      (artdag/dag-id ft-D "b")))
+  11)
+
+(artdag-test
+  "all-ok? is false when something failed"
+  (let
+    ((cache (persist/open)))
+    (artdag/all-ok? (artdag/run-safe ft-D ft-BAD cache)))
+  false)
+
+(artdag-test
+  "all-ok? is true on a clean run"
+  (let
+    ((cache (persist/open)))
+    (artdag/all-ok? (artdag/run-safe ft-D ft-GOOD cache)))
+  true)
+
+; ---- cache integrity ----
+
+(artdag-test
+  "good node is cached"
+  (let
+    ((cache (persist/open)))
+    (begin
+      (artdag/run-safe ft-D ft-BAD cache)
+      (persist/kv-has? cache (artdag/dag-id ft-D "b"))))
+  true)
+
+(artdag-test
+  "failed node is never cached"
+  (let
+    ((cache (persist/open)))
+    (begin
+      (artdag/run-safe ft-D ft-BAD cache)
+      (persist/kv-has? cache (artdag/dag-id ft-D "c"))))
+  false)
+
+; ---- retry after fix ----
+
+(artdag-test
+  "retry recomputes only the failed closure"
+  (let
+    ((cache (persist/open)))
+    (begin
+      (artdag/run-safe ft-D ft-BAD cache)
+      (artdag/recompute-count (artdag/run-safe ft-D ft-GOOD cache))))
+  2)
+
+(artdag-test
+  "retry reuses the good nodes from cache"
+  (let
+    ((cache (persist/open)))
+    (begin
+      (artdag/run-safe ft-D ft-BAD cache)
+      (artdag/hit-count (artdag/run-safe ft-D ft-GOOD cache))))
+  3)
+
+(artdag-test
+  "retry produces the correct result"
+  (let
+    ((cache (persist/open)))
+    (begin
+      (artdag/run-safe ft-D ft-BAD cache)
+      (artdag/result-of
+        (artdag/run-safe ft-D ft-GOOD cache)
+        (artdag/dag-id ft-D "d"))))
+  110)
+
+; ---- transitive cascade ----
+
+(artdag-test
+  "failure cascades through a deep chain"
+  (let
+    ((cache (persist/open)))
+    (artdag/failure-count
+      (artdag/run-safe
+        (artdag/build
+          (list
+            (list "a" "in" (list) {:v 1})
+            (list "b" "boom" (list "a") {})
+            (list "c" "inc" (list "b") {})
+            (list "d" "inc" (list "c") {})))
+        ft-BAD
+        cache)))
+  3)

lib/artdag/tests/fed.sx

@@ -0,0 +1,157 @@
+; Phase 6 — federation: shared content-addressed cache, trust gating, invalidation.
+
+(define fed-BASE (artdag/op-table-runner {:in (fn (params inputs) (get params :v)) :add (fn (params inputs) (+ (nth inputs 0) (nth inputs 1))) :inc (fn (params inputs) (+ 1 (first inputs)))}))
+
+(define
+  fed-D
+  (artdag/build
+    (list
+      (list "p" "in" (list) {:v 10})
+      (list "q" "in" (list) {:v 20})
+      (list "b" "inc" (list "p") {})
+      (list "c" "inc" (list "q") {})
+      (list "d" "add" (list "b" "c") {} true))))
+
+(define fed-trust-A (fn (p) (= p "A")))
+(define fed-trust-none (fn (p) false))
+
+; a warmed instance A and its export bundle (origin peer "A").
+(define fed-A (artdag/fed-open))
+(define fed-warm (artdag/fed-run fed-A fed-D fed-BASE))
+(define fed-bundle (artdag/fed-export fed-A "A"))
+
+; ---- export ----
+
+(artdag-test
+  "export: bundle covers every cached node"
+  (len fed-bundle)
+  5)
+
+; ---- remote cache hit ----
+
+(artdag-test
+  "trusted import enables remote cache hit (no recompute)"
+  (artdag/recompute-count
+    (artdag/fed-run
+      (artdag/fed-import (artdag/fed-open) fed-bundle fed-trust-A)
+      fed-D
+      fed-BASE))
+  0)
+
+(artdag-test
+  "trusted import: every node is a hit"
+  (artdag/hit-count
+    (artdag/fed-run
+      (artdag/fed-import (artdag/fed-open) fed-bundle fed-trust-A)
+      fed-D
+      fed-BASE))
+  5)
+
+(artdag-test
+  "remote hit yields correct result"
+  (artdag/result-of
+    (artdag/fed-run
+      (artdag/fed-import (artdag/fed-open) fed-bundle fed-trust-A)
+      fed-D
+      fed-BASE)
+    (artdag/dag-id fed-D "d"))
+  32)
+
+; ---- trust gating ----
+
+(artdag-test
+  "untrusted peer is rejected (recompute everything)"
+  (artdag/recompute-count
+    (artdag/fed-run
+      (artdag/fed-import (artdag/fed-open) fed-bundle fed-trust-none)
+      fed-D
+      fed-BASE))
+  5)
+
+(artdag-test
+  "trust gating: untrusted records never enter the cache"
+  (let
+    ((B (artdag/fed-import (artdag/fed-open) (cons {:peer "C" :cid "node:foreign" :result 99} fed-bundle) fed-trust-A)))
+    (persist/kv-has? (artdag/fed-cache B) "node:foreign"))
+  false)
+
+(artdag-test
+  "trust gating: trusted records still admitted alongside rejected"
+  (let
+    ((B (artdag/fed-import (artdag/fed-open) (cons {:peer "C" :cid "node:foreign" :result 99} fed-bundle) fed-trust-A)))
+    (persist/kv-has? (artdag/fed-cache B) (artdag/dag-id fed-D "d")))
+  true)
+
+; ---- provenance ----
+
+(artdag-test
+  "provenance is recorded for imported results"
+  (get
+    (artdag/fed-prov
+      (artdag/fed-import (artdag/fed-open) fed-bundle fed-trust-A))
+    (artdag/dag-id fed-D "d"))
+  "A")
+
+(artdag-test
+  "locally computed results carry no provenance"
+  (len (keys (artdag/fed-prov fed-A)))
+  0)
+
+; ---- injected transport ----
+
+(artdag-test
+  "fed-pull imports via an injected fetch transport"
+  (artdag/recompute-count
+    (artdag/fed-run
+      (artdag/fed-pull
+        (artdag/fed-open)
+        (fn (peer) fed-bundle)
+        "A"
+        fed-trust-A)
+      fed-D
+      fed-BASE))
+  0)
+
+; ---- invalidation ----
+
+(artdag-test
+  "invalidation drops a peer's results (recompute again)"
+  (let
+    ((B (artdag/fed-import (artdag/fed-open) fed-bundle fed-trust-A)))
+    (artdag/recompute-count
+      (artdag/fed-run (artdag/fed-invalidate B "A") fed-D fed-BASE)))
+  5)
+
+(artdag-test
+  "invalidation: recomputed result still correct"
+  (let
+    ((B (artdag/fed-import (artdag/fed-open) fed-bundle fed-trust-A)))
+    (artdag/result-of
+      (artdag/fed-run (artdag/fed-invalidate B "A") fed-D fed-BASE)
+      (artdag/dag-id fed-D "d")))
+  32)
+
+(artdag-test
+  "invalidation: provenance map is cleared for that peer"
+  (let
+    ((B (artdag/fed-import (artdag/fed-open) fed-bundle fed-trust-A)))
+    (len (keys (artdag/fed-prov (artdag/fed-invalidate B "A")))))
+  0)
+
+(artdag-test
+  "invalidation is peer-scoped: other peers' results survive"
+  (let
+    ((B (artdag/fed-import (artdag/fed-open) (cons {:peer "C" :cid "node:fromC" :result 7} fed-bundle) (fn (p) true))))
+    (persist/kv-has?
+      (artdag/fed-cache (artdag/fed-invalidate B "A"))
+      "node:fromC"))
+  true)
+
+(artdag-test
+  "invalidation is peer-scoped: target peer's results removed"
+  (let
+    ((B (artdag/fed-import (artdag/fed-open) (cons {:peer "C" :cid "node:fromC" :result 7} fed-bundle) (fn (p) true))))
+    (persist/kv-has?
+      (artdag/fed-cache (artdag/fed-invalidate B "A"))
+      (artdag/dag-id fed-D "d")))
+  false)

lib/artdag/tests/maude-optimize.sx

@@ -0,0 +1,112 @@
+; Phase 7 — rule-based optimization via maude-on-sx.
+; Bridge round-trip: dag->term->dag is the identity on canonical (content-id) form.
+
+; ---- linear chain a -> b -> c (b carries params) ----
+
+(define
+  mo-chain
+  (artdag/build
+    (list
+      (list "a" "in" (list) {:v 5})
+      (list "b" "blur" (list "a") {:radius 2})
+      (list "c" "blur" (list "b") {:radius 3}))))
+(define mo-c-id (artdag/dag-id mo-chain "c"))
+(define mo-chain-rt (artdag/mb-roundtrip mo-chain mo-c-id))
+
+(artdag-test
+  "roundtrip: sink id preserved"
+  (artdag/member? mo-c-id (keys (artdag/dag-nodes mo-chain-rt)))
+  true)
+
+(artdag-test
+  "roundtrip: node count preserved"
+  (artdag/node-count mo-chain-rt)
+  3)
+
+(artdag-test
+  "roundtrip: sink op preserved"
+  (artdag/node-op (artdag/dag-get mo-chain-rt mo-c-id))
+  "blur")
+
+(artdag-test
+  "roundtrip: sink params preserved"
+  (artdag/node-params (artdag/dag-get mo-chain-rt mo-c-id))
+  {:radius 3})
+
+(artdag-test
+  "roundtrip: full reconstructed node equals original"
+  (= (artdag/dag-get mo-chain-rt mo-c-id) (artdag/dag-get mo-chain mo-c-id))
+  true)
+
+; ---- term shape ----
+
+(define mo-c-term (artdag/dag->term mo-chain mo-c-id))
+
+(artdag-test "term: sink op is the maude operator" (mau/op mo-c-term) "blur")
+
+(artdag-test
+  "term: params recovered from meta"
+  (artdag/term-params mo-c-term)
+  {:radius 3})
+
+(artdag-test
+  "term: commutative flag recovered (false)"
+  (artdag/term-commutative mo-c-term)
+  false)
+
+(artdag-test
+  "term->entries: one entry per node"
+  (len (artdag/term->entries mo-c-term))
+  3)
+
+; ---- commutative node: order-insensitive id survives round-trip ----
+
+(define
+  mo-comm
+  (artdag/build
+    (list
+      (list "x" "src" (list) {})
+      (list "y" "noise" (list) {})
+      (list "z" "over" (list "x" "y") {} true))))
+(define mo-z-id (artdag/dag-id mo-comm "z"))
+(define mo-comm-rt (artdag/mb-roundtrip mo-comm mo-z-id))
+
+(artdag-test
+  "roundtrip comm: commutative id preserved"
+  (artdag/member? mo-z-id (keys (artdag/dag-nodes mo-comm-rt)))
+  true)
+
+(artdag-test
+  "term comm: commutative flag recovered (true)"
+  (artdag/term-commutative (artdag/dag->term mo-comm mo-z-id))
+  true)
+
+; ---- diamond: shared subgraph re-collapses to one node ----
+
+(define
+  mo-diamond
+  (artdag/build
+    (list
+      (list "a" "src" (list) {})
+      (list "b" "blur" (list "a") {:radius 1})
+      (list "c" "bright" (list "a") {:gain 2})
+      (list "d" "over" (list "b" "c") {} true))))
+(define mo-d-id (artdag/dag-id mo-diamond "d"))
+(define mo-diamond-rt (artdag/mb-roundtrip mo-diamond mo-d-id))
+
+(artdag-test
+  "roundtrip diamond: shared node not duplicated"
+  (artdag/node-count mo-diamond-rt)
+  4)
+
+(artdag-test
+  "roundtrip diamond: sink id preserved"
+  (artdag/member? mo-d-id (keys (artdag/dag-nodes mo-diamond-rt)))
+  true)
+
+(artdag-test
+  "roundtrip diamond: shared src id preserved"
+  (artdag/member?
+    (artdag/dag-id mo-diamond "a")
+    (keys (artdag/dag-nodes mo-diamond-rt)))
+  true)

lib/artdag/tests/optimize.sx

@@ -0,0 +1,215 @@
+; Phase 5 — optimization: DCE, CSE (content-id sharing), adjacent-op fusion.
+
+(define opt-BASE (artdag/op-table-runner {:in (fn (params inputs) (get params :v)) :sq (fn (params inputs) (* (first inputs) (first inputs))) :add (fn (params inputs) (+ (nth inputs 0) (nth inputs 1))) :inc (fn (params inputs) (+ 1 (first inputs)))}))
+(define opt-RUN (artdag/fusing-runner opt-BASE))
+(define opt-inc? (fn (op) (= op "inc")))
+(define opt-incsq? (fn (op) (or (= op "inc") (= op "sq"))))
+
+; linear chain a(in) -> b -> c -> d, all inc
+(define
+  opt-chain
+  (list
+    (list "a" "in" (list) {:v 5})
+    (list "b" "inc" (list "a") {})
+    (list "c" "inc" (list "b") {})
+    (list "d" "inc" (list "c") {})))
+
+; ---- DCE ----
+
+(define
+  dce-entries
+  (list
+    (list "a" "in" (list) {:v 5})
+    (list "b" "inc" (list "a") {})
+    (list "c" "inc" (list "b") {})
+    (list "x" "sq" (list "a") {})))
+(define dce-G (artdag/build dce-entries))
+
+(artdag-test
+  "dce: removes dead node"
+  (artdag/node-count (artdag/dce dce-G (list (artdag/dag-id dce-G "c"))))
+  3)
+
+(artdag-test
+  "dce: keeps live closure intact"
+  (artdag/node-count (artdag/dce dce-G (list (artdag/dag-id dce-G "x"))))
+  2)
+
+(artdag-test
+  "dce: preserves surviving node ids"
+  (artdag/member?
+    (artdag/dag-id dce-G "c")
+    (keys
+      (artdag/dag-nodes (artdag/dce dce-G (list (artdag/dag-id dce-G "c"))))))
+  true)
+
+(artdag-test
+  "dce: output result unchanged after elimination"
+  (let
+    ((cache (persist/open)))
+    (artdag/result-of
+      (artdag/run
+        (artdag/dce dce-G (list (artdag/dag-id dce-G "c")))
+        opt-RUN
+        cache)
+      (artdag/dag-id dce-G "c")))
+  7)
+
+(artdag-test
+  "dce: nothing dead is a no-op on count"
+  (artdag/node-count
+    (artdag/dce
+      dce-G
+      (list (artdag/dag-id dce-G "c") (artdag/dag-id dce-G "x"))))
+  4)
+
+; ---- CSE (free from content addressing) ----
+
+(define
+  cse-entries
+  (list
+    (list "a" "in" (list) {:v 3})
+    (list "s1" "sq" (list "a") {})
+    (list "s2" "sq" (list "a") {})
+    (list "d" "add" (list "s1" "s2") {} true)))
+(define cse-C (artdag/cse cse-entries))
+
+(artdag-test
+  "cse: identical subexpressions collapse to one node"
+  (artdag/node-count cse-C)
+  3)
+
+(artdag-test
+  "cse: shared node computes once"
+  (let
+    ((cache (persist/open)))
+    (artdag/recompute-count (artdag/run cse-C opt-RUN cache)))
+  3)
+
+(artdag-test
+  "cse: s1 and s2 are the same id"
+  (equal? (artdag/dag-id cse-C "s1") (artdag/dag-id cse-C "s2"))
+  true)
+
+(artdag-test
+  "cse: result is correct"
+  (let
+    ((cache (persist/open)))
+    (artdag/result-of
+      (artdag/run cse-C opt-RUN cache)
+      (artdag/dag-id cse-C "d")))
+  18)
+
+; ---- fusion ----
+
+(artdag-test
+  "fusion: collapses a unary chain"
+  (artdag/node-count (artdag/fuse opt-chain opt-inc?))
+  2)
+
+(artdag-test
+  "fusion: unfused has all nodes"
+  (artdag/node-count (artdag/build opt-chain))
+  4)
+
+(artdag-test
+  "fusion: output-equivalent to unfused"
+  (let
+    ((c1 (persist/open)) (c2 (persist/open)))
+    (=
+      (artdag/result-of
+        (artdag/run (artdag/build opt-chain) opt-RUN c1)
+        (artdag/dag-id (artdag/build opt-chain) "d"))
+      (artdag/result-of
+        (artdag/run (artdag/fuse opt-chain opt-inc?) opt-RUN c2)
+        (artdag/dag-id (artdag/fuse opt-chain opt-inc?) "d"))))
+  true)
+
+(artdag-test
+  "fusion: leaf is never fused"
+  (artdag/node-op
+    (artdag/dag-node-by-name (artdag/fuse opt-chain opt-inc?) "a"))
+  "in")
+
+(artdag-test
+  "fusion: tail becomes a pipeline node"
+  (artdag/node-op
+    (artdag/dag-node-by-name (artdag/fuse opt-chain opt-inc?) "d"))
+  "artdag/pipeline")
+
+(artdag-test
+  "fusion: mixed fusible set fuses across op kinds"
+  (artdag/node-count
+    (artdag/fuse
+      (list
+        (list "a" "in" (list) {:v 2})
+        (list "b" "inc" (list "a") {})
+        (list "c" "sq" (list "b") {})
+        (list "d" "inc" (list "c") {}))
+      opt-incsq?))
+  2)
+
+(artdag-test
+  "fusion: mixed chain replays correctly"
+  (let
+    ((cache (persist/open)))
+    (let
+      ((f (artdag/fuse (list (list "a" "in" (list) {:v 2}) (list "b" "inc" (list "a") {}) (list "c" "sq" (list "b") {}) (list "d" "inc" (list "c") {})) opt-incsq?)))
+      (artdag/result-of (artdag/run f opt-RUN cache) (artdag/dag-id f "d"))))
+  10)
+
+(artdag-test
+  "fusion: fanout node is not fused"
+  (artdag/node-count
+    (artdag/fuse
+      (list
+        (list "a" "in" (list) {:v 1})
+        (list "b" "inc" (list "a") {})
+        (list "c" "inc" (list "b") {})
+        (list "e" "sq" (list "b") {}))
+      opt-inc?))
+  4)
+
+(artdag-test
+  "fusion: empty fusible set leaves dag unchanged"
+  (artdag/node-count (artdag/fuse opt-chain (fn (op) false)))
+  4)
+
+; ---- full optimization pass (fuse + dce) ----
+
+(define
+  optp-entries
+  (list
+    (list "a" "in" (list) {:v 5})
+    (list "b" "inc" (list "a") {})
+    (list "c" "inc" (list "b") {})
+    (list "x" "sq" (list "a") {})))
+
+(artdag-test
+  "optimize: fuses chain and drops dead node"
+  (artdag/node-count (artdag/optimize optp-entries (list "c") opt-inc?))
+  2)
+
+(artdag-test
+  "optimize: leaves dead node when it is an output"
+  (artdag/node-count (artdag/optimize optp-entries (list "c" "x") opt-inc?))
+  3)
+
+(artdag-test
+  "optimize: result equals the unoptimized dag"
+  (let
+    ((c1 (persist/open)) (c2 (persist/open)))
+    (let
+      ((o (artdag/optimize optp-entries (list "c") opt-inc?)))
+      (=
+        (artdag/result-of (artdag/run o opt-RUN c1) (artdag/dag-id o "c"))
+        (artdag/result-of
+          (artdag/run (artdag/build optp-entries) opt-RUN c2)
+          (artdag/dag-id (artdag/build optp-entries) "c")))))
+  true)
+
+(artdag-test
+  "optimize: no fusible ops still drops dead nodes"
+  (artdag/node-count
+    (artdag/optimize optp-entries (list "c") (fn (op) false)))
+  3)

lib/artdag/tests/plan.sx

@@ -0,0 +1,122 @@
+; Phase 3 — Plan: topological batches under a parallelism cap, incremental plan.
+
+; diamond:  a -> b, a -> c, (b,c) -> d
+(define
+  pl-D
+  (artdag/build
+    (list
+      (list "a" "load" (list) {})
+      (list "b" "f" (list "a") {})
+      (list "c" "g" (list "a") {})
+      (list "d" "add" (list "b" "c") {} true))))
+(define pl-a (artdag/dag-id pl-D "a"))
+(define pl-b (artdag/dag-id pl-D "b"))
+(define pl-c (artdag/dag-id pl-D "c"))
+(define pl-d (artdag/dag-id pl-D "d"))
+
+; wide:  a -> b, c, e, f  (four independent dependents)
+(define
+  pl-W
+  (artdag/build
+    (list
+      (list "a" "load" (list) {})
+      (list "b" "f" (list "a") {})
+      (list "c" "g" (list "a") {})
+      (list "e" "h" (list "a") {})
+      (list "f" "k" (list "a") {}))))
+
+; ---- full plan, unlimited width ----
+
+(artdag-test
+  "full plan: batch count"
+  (artdag/plan-batches (artdag/plan pl-D 0))
+  3)
+
+(artdag-test
+  "full plan: schedules every node"
+  (artdag/plan-size (artdag/plan pl-D 0))
+  4)
+
+(artdag-test
+  "full plan: first batch is the leaf"
+  (first (artdag/plan pl-D 0))
+  (list pl-a))
+
+(artdag-test
+  "full plan: middle batch runs b,c in parallel"
+  (first (rest (artdag/plan pl-D 0)))
+  (artdag/sort-strings (list pl-b pl-c)))
+
+(artdag-test
+  "full plan: last batch is the sink"
+  (first (rest (rest (artdag/plan pl-D 0))))
+  (list pl-d))
+
+(artdag-test
+  "full plan: max width is 2"
+  (artdag/plan-width (artdag/plan pl-D 0))
+  2)
+
+; ---- parallelism cap ----
+
+(artdag-test
+  "cap 1: width never exceeds 1"
+  (artdag/plan-width (artdag/plan pl-D 1))
+  1)
+
+(artdag-test
+  "cap 1: serializes into one node per batch"
+  (artdag/plan-batches (artdag/plan pl-D 1))
+  4)
+
+(artdag-test
+  "cap larger than widest wave is a no-op"
+  (artdag/plan pl-D 10)
+  (artdag/plan pl-D 0))
+
+(artdag-test
+  "wide cap 2: width capped at 2"
+  (artdag/plan-width (artdag/plan pl-W 2))
+  2)
+
+(artdag-test
+  "wide cap 2: leaf wave then two capped sub-batches"
+  (artdag/plan-batches (artdag/plan pl-W 2))
+  3)
+
+(artdag-test
+  "wide cap 2: still schedules all five nodes"
+  (artdag/plan-size (artdag/plan pl-W 2))
+  5)
+
+(artdag-test
+  "wide unlimited: single wave of four after leaf"
+  (artdag/plan-width (artdag/plan pl-W 0))
+  4)
+
+; ---- incremental (dirty-only) plan ----
+
+(artdag-test
+  "dirty plan: schedules only the dirty closure"
+  (artdag/plan-size (artdag/plan-dirty pl-D (list pl-b) 0))
+  2)
+
+(artdag-test
+  "dirty plan: b then d"
+  (artdag/plan-dirty pl-D (list pl-b) 0)
+  (list (list pl-b) (list pl-d)))
+
+(artdag-test
+  "dirty plan: clean deps treated as satisfied"
+  (first (artdag/plan-dirty pl-D (list pl-b) 0))
+  (list pl-b))
+
+(artdag-test
+  "dirty plan: leaf change replans whole graph"
+  (artdag/plan-size (artdag/plan-dirty pl-D (list pl-a) 0))
+  4)
+
+(artdag-test
+  "dirty plan: sink change is a single batch"
+  (artdag/plan-dirty pl-D (list pl-d) 0)
+  (list (list pl-d)))

lib/artdag/tests/serialize.sx

@@ -0,0 +1,115 @@
+; portable wire form: dag <-> records <-> string, with content-id integrity.
+
+(define ser-RT (artdag/op-table-runner {:in (fn (p i) (get p :v)) :add (fn (p i) (+ (nth i 0) (nth i 1))) :inc (fn (p i) (+ 1 (first i)))}))
+
+(define
+  ser-D
+  (artdag/build
+    (list
+      (list "a" "in" (list) {:v 10})
+      (list "b" "inc" (list "a") {})
+      (list "c" "add" (list "a" "b") {} true))))
+
+(define ser-cid (artdag/dag-id ser-D "c"))
+
+; ---- wire form ----
+
+(artdag-test
+  "wire has one record per node"
+  (len (artdag/dag->wire ser-D))
+  3)
+
+(artdag-test
+  "wire records follow topological order"
+  (map (fn (rec) (nth rec 0)) (artdag/dag->wire ser-D))
+  (artdag/dag-order ser-D))
+
+(artdag-test
+  "wire record carries the content-id"
+  (nth (nth (artdag/dag->wire ser-D) 0) 0)
+  (artdag/dag-id ser-D "a"))
+
+; ---- reconstruction ----
+
+(artdag-test
+  "wire->dag restores node count"
+  (artdag/node-count (artdag/wire->dag (artdag/dag->wire ser-D)))
+  3)
+
+(artdag-test
+  "wire->dag restores order"
+  (artdag/dag-order (artdag/wire->dag (artdag/dag->wire ser-D)))
+  (artdag/dag-order ser-D))
+
+(artdag-test
+  "reconstructed leaf inputs normalize to empty list"
+  (artdag/node-inputs
+    (artdag/dag-get
+      (artdag/wire->dag (artdag/dag->wire ser-D))
+      (artdag/dag-id ser-D "a")))
+  (list))
+
+(artdag-test
+  "reconstructed node preserves inputs"
+  (artdag/node-inputs
+    (artdag/dag-get (artdag/wire->dag (artdag/dag->wire ser-D)) ser-cid))
+  (artdag/node-inputs (artdag/dag-get ser-D ser-cid)))
+
+(artdag-test
+  "reconstructed node id matches recomputed content-id"
+  (artdag/content-id
+    (artdag/dag-get (artdag/wire->dag (artdag/dag->wire ser-D)) ser-cid))
+  ser-cid)
+
+; ---- execution equivalence ----
+
+(artdag-test
+  "reconstructed dag executes to same result"
+  (let
+    ((c1 (persist/open)) (c2 (persist/open)))
+    (=
+      (artdag/result-of (artdag/run ser-D ser-RT c1) ser-cid)
+      (artdag/result-of
+        (artdag/run (artdag/wire->dag (artdag/dag->wire ser-D)) ser-RT c2)
+        ser-cid)))
+  true)
+
+(artdag-test
+  "string round-trip executes to same result"
+  (let
+    ((cache (persist/open)))
+    (artdag/result-of
+      (artdag/run
+        (artdag/string->dag (artdag/dag->string ser-D))
+        ser-RT
+        cache)
+      ser-cid))
+  21)
+
+; ---- integrity ----
+
+(artdag-test
+  "wire-verify accepts a genuine wire form"
+  (artdag/wire-verify (artdag/dag->wire ser-D))
+  true)
+
+(artdag-test
+  "wire-verify rejects a tampered id"
+  (artdag/wire-verify
+    (list (list "node:bogus" "in" (list) {:v 1} false)))
+  false)
+
+(artdag-test
+  "wire-verify rejects mutated params under a stale id"
+  (artdag/wire-verify
+    (map
+      (fn
+        (rec)
+        (list
+          (nth rec 0)
+          (nth rec 1)
+          (nth rec 2)
+          {:v 999}
+          (nth rec 4)))
+      (artdag/dag->wire ser-D)))
+  false)

lib/artdag/tests/stats.sx

@@ -0,0 +1,150 @@
+; execution stats: hit ratio + memoized work saved (cost-weighted).
+
+(define st-RT (artdag/op-table-runner {:in (fn (p i) (get p :v)) :add (fn (p i) (+ (nth i 0) (nth i 1))) :inc (fn (p i) (+ 1 (first i)))}))
+
+(define
+  st-D
+  (artdag/build
+    (list
+      (list "p" "in" (list) {:v 10})
+      (list "q" "in" (list) {:v 20})
+      (list "b" "inc" (list "p") {})
+      (list "c" "inc" (list "q") {})
+      (list "d" "add" (list "b" "c") {} true))))
+
+; same shape, leaf q changed -> dirty closure {q,c,d}
+(define
+  st-D2
+  (artdag/build
+    (list
+      (list "p" "in" (list) {:v 10})
+      (list "q" "in" (list) {:v 21})
+      (list "b" "inc" (list "p") {})
+      (list "c" "inc" (list "q") {})
+      (list "d" "add" (list "b" "c") {} true))))
+
+(define st-W (artdag/op-cost {:add 5 :inc 2}))
+
+; ---- cold run ----
+
+(artdag-test
+  "cold run: hit ratio is zero"
+  (let
+    ((cache (persist/open)))
+    (artdag/hit-ratio (artdag/run st-D st-RT cache)))
+  0)
+
+(artdag-test
+  "cold run: nothing saved"
+  (let
+    ((cache (persist/open)))
+    (artdag/work-saved (artdag/run st-D st-RT cache) st-D artdag/const-cost))
+  0)
+
+(artdag-test
+  "cold run: all work runs"
+  (let
+    ((cache (persist/open)))
+    (artdag/work-recomputed
+      (artdag/run st-D st-RT cache)
+      st-D
+      artdag/const-cost))
+  5)
+
+(artdag-test
+  "cold run: weighted work ran"
+  (let
+    ((cache (persist/open)))
+    (artdag/work-recomputed (artdag/run st-D st-RT cache) st-D st-W))
+  11)
+
+; ---- warm rerun ----
+
+(artdag-test
+  "warm rerun: hit ratio is one"
+  (let
+    ((cache (persist/open)))
+    (begin
+      (artdag/run st-D st-RT cache)
+      (artdag/hit-ratio (artdag/run st-D st-RT cache))))
+  1)
+
+(artdag-test
+  "warm rerun: savings ratio is one"
+  (let
+    ((cache (persist/open)))
+    (begin
+      (artdag/run st-D st-RT cache)
+      (artdag/savings-ratio
+        (artdag/run st-D st-RT cache)
+        st-D
+        artdag/const-cost)))
+  1)
+
+(artdag-test
+  "warm rerun: all weighted work saved"
+  (let
+    ((cache (persist/open)))
+    (begin
+      (artdag/run st-D st-RT cache)
+      (artdag/work-saved (artdag/run st-D st-RT cache) st-D st-W)))
+  11)
+
+; ---- partial (incremental) ----
+
+(artdag-test
+  "incremental: total is every node"
+  (let
+    ((cache (persist/open)))
+    (begin
+      (artdag/run st-D st-RT cache)
+      (artdag/exec-total (artdag/run st-D2 st-RT cache))))
+  5)
+
+(artdag-test
+  "incremental: saved work counts unchanged nodes"
+  (let
+    ((cache (persist/open)))
+    (begin
+      (artdag/run st-D st-RT cache)
+      (artdag/work-saved
+        (artdag/run st-D2 st-RT cache)
+        st-D2
+        artdag/const-cost)))
+  2)
+
+(artdag-test
+  "incremental: ran work counts dirty closure"
+  (let
+    ((cache (persist/open)))
+    (begin
+      (artdag/run st-D st-RT cache)
+      (artdag/work-recomputed
+        (artdag/run st-D2 st-RT cache)
+        st-D2
+        artdag/const-cost)))
+  3)
+
+(artdag-test
+  "summary reports recompute count"
+  (let
+    ((cache (persist/open)))
+    (get
+      (artdag/exec-summary
+        (artdag/run st-D st-RT cache)
+        st-D
+        artdag/const-cost)
+      :recomputed))
+  5)
+
+(artdag-test
+  "summary reports total"
+  (let
+    ((cache (persist/open)))
+    (get
+      (artdag/exec-summary
+        (artdag/run st-D st-RT cache)
+        st-D
+        artdag/const-cost)
+      :total))
+  5)

lib/commerce/api.sx

@@ -0,0 +1,56 @@
+;; lib/commerce/api.sx — public commerce surface.
+;;
+;; A session bundles a pricing context with a cart: {:ctx CTX :cart CART}.
+;; All operations are pure and return a new session. The total and the
+;; per-line breakdown are deterministic functions of (ctx, cart).
+;;
+;; commerce-checkout is a Phase-3 stub — the order lifecycle is a durable
+;; flow that suspends at the SumUp payment boundary.
+
+(define commerce-session (fn (ctx) {:cart empty-cart :ctx ctx}))
+
+(define commerce-ctx (fn (sess) (get sess :ctx)))
+(define commerce-cart (fn (sess) (get sess :cart)))
+(define commerce-lines (fn (sess) (cart-lines (get sess :cart))))
+(define commerce-count (fn (sess) (cart-count (get sess :cart))))
+
+(define
+  commerce-add
+  (fn
+    (sess sku variant qty)
+    (assoc sess :cart (cart-add (get sess :cart) sku variant qty))))
+
+(define
+  commerce-remove
+  (fn
+    (sess sku variant)
+    (assoc sess :cart (cart-remove (get sess :cart) sku variant))))
+
+(define
+  commerce-set-qty
+  (fn
+    (sess sku variant qty)
+    (assoc sess :cart (cart-set-qty (get sess :cart) sku variant qty))))
+
+;; True when the sku exists in the session's catalog snapshot.
+(define
+  commerce-can-add?
+  (fn (sess sku) (catalog-has? (ctx-catalog (get sess :ctx)) sku)))
+
+(define
+  commerce-total
+  (fn (sess) (cart-total (get sess :ctx) (get sess :cart))))
+
+;; Per-line audit breakdown — the "which line contributed what" view.
+(define
+  line-detail
+  (fn (ctx line) (let ((cat (ctx-catalog ctx))) {:sku (line-sku line) :unit (line-unit-price cat (line-sku line) (line-variant line)) :qty (line-qty line) :variant (line-variant line) :extended (line-extended cat line) :tax (line-tax ctx line)})))
+
+(define
+  commerce-explain
+  (fn
+    (sess)
+    (map (fn (l) (line-detail (get sess :ctx) l)) (get sess :cart))))
+
+;; Phase 3 — order lifecycle flow (reserve -> pay -> fulfil) lands here.
+(define commerce-checkout (fn (sess) {:note "order lifecycle flow lands in Phase 3" :phase 3 :status :not-implemented}))

lib/commerce/attribution.sx

@@ -0,0 +1,100 @@
+;; lib/commerce/attribution.sx — line-level discount attribution.
+;;
+;; The briefing's marquee backward query: "which line item triggered this
+;; discount?". promo.sx computes discount amounts at the class/order level;
+;; this layer answers the *scope* question relationally and in both directions:
+;;   forward  — which lines does code C touch?   (lines-for-code)
+;;   backward — which codes touch this line?     (codes-for-line)
+;; Both are the same relation promo-toucheso run with different vars bound.
+;;
+;; A :fixed promo is order-level (touches no single line); query those with
+;; order-level-codes. Only promos that actually apply (amount > 0) touch lines.
+
+;; Lines whose sku is in product-class `cls`.
+(define
+  class-lines
+  (fn
+    (ctx cart cls)
+    (filter
+      (fn (l) (= (catalog-class (ctx-catalog ctx) (line-sku l)) cls))
+      cart)))
+
+;; The lines a promo applies to (its scope). :fixed is order-level → no lines.
+(define
+  promo-lines
+  (fn
+    (ctx cart p)
+    (let
+      ((k (promo-kind p)))
+      (cond
+        ((= k :percent) (class-lines ctx cart (nth p 2)))
+        ((= k :member)
+          (if
+            (= (get ctx :customer) :member)
+            (class-lines ctx cart (nth p 2))
+            (list)))
+        ((= k :bundle)
+          (filter (fn (l) (= (line-sku l) (nth p 2))) cart))
+        (:else (list))))))
+
+;; Relation: promo `code` touches `line`. Only applying promos (amount > 0)
+;; touch anything, so an inapplicable promo contributes no pairs.
+(define
+  promo-toucheso
+  (fn
+    (ctx cart ruleset code line)
+    (fresh
+      (p)
+      (membero p ruleset)
+      (project
+        (p)
+        (if
+          (> (promo-amount ctx cart p) 0)
+          (mk-conj
+            (== code (promo-code p))
+            (membero line (promo-lines ctx cart p)))
+          fail)))))
+
+;; --- query helpers ---
+
+(define
+  lines-for-code
+  (fn
+    (ctx cart ruleset code)
+    (run* line (promo-toucheso ctx cart ruleset code line))))
+
+(define
+  codes-for-line
+  (fn
+    (ctx cart ruleset line)
+    (run* code (promo-toucheso ctx cart ruleset code line))))
+
+(define
+  line-touched-by?
+  (fn
+    (ctx cart ruleset code line)
+    (not
+      (empty?
+        (run
+          1
+          c
+          (mk-conj (promo-toucheso ctx cart ruleset code line) (== c true)))))))
+
+;; Applying order-level (:fixed) promos — discounts with no single line.
+(define
+  order-level-codes
+  (fn
+    (ctx cart ruleset)
+    (run*
+      code
+      (fresh
+        (p)
+        (membero p ruleset)
+        (project
+          (p)
+          (if
+            (and
+              (> (promo-amount ctx cart p) 0)
+              (= (promo-kind p) :fixed))
+            (== code (promo-code p))
+            fail))))))

lib/commerce/cart.sx

@@ -0,0 +1,86 @@
+;; lib/commerce/cart.sx — cart as an ordered list of line items.
+;;
+;; A cart is a native list of lines; a line is (list sku variant qty).
+;; All operations are pure: they return a new cart, never mutate. Line
+;; order is insertion order (stable) so totals are reproducible.
+;;
+;; cart-lineo is the relational view — because a line *is* a (sku variant qty)
+;; tuple, membero queries the cart directly, forward or backward.
+
+(define empty-cart (list))
+
+(define make-line (fn (sku variant qty) (list sku variant qty)))
+(define line-sku (fn (l) (nth l 0)))
+(define line-variant (fn (l) (nth l 1)))
+(define line-qty (fn (l) (nth l 2)))
+
+(define
+  same-line?
+  (fn
+    (l sku variant)
+    (and (= (line-sku l) sku) (= (line-variant l) variant))))
+
+(define
+  cart-qty
+  (fn
+    (cart sku variant)
+    (let
+      ((m (filter (fn (l) (same-line? l sku variant)) cart)))
+      (if (empty? m) 0 (line-qty (first m))))))
+
+(define
+  cart-remove
+  (fn
+    (cart sku variant)
+    (filter (fn (l) (not (same-line? l sku variant))) cart)))
+
+;; Add qty units; merges into an existing (sku,variant) line in place,
+;; otherwise appends a new line at the end.
+(define
+  cart-add
+  (fn
+    (cart sku variant qty)
+    (let
+      ((existing (cart-qty cart sku variant)))
+      (if
+        (= existing 0)
+        (append cart (list (make-line sku variant qty)))
+        (map
+          (fn
+            (l)
+            (if
+              (same-line? l sku variant)
+              (make-line sku variant (+ existing qty))
+              l))
+          cart)))))
+
+;; Set the absolute quantity; qty <= 0 removes the line.
+(define
+  cart-set-qty
+  (fn
+    (cart sku variant qty)
+    (if
+      (<= qty 0)
+      (cart-remove cart sku variant)
+      (if
+        (= (cart-qty cart sku variant) 0)
+        (append cart (list (make-line sku variant qty)))
+        (map
+          (fn
+            (l)
+            (if (same-line? l sku variant) (make-line sku variant qty) l))
+          cart)))))
+
+(define cart-empty? (fn (cart) (empty? cart)))
+(define cart-lines (fn (cart) cart))
+(define cart-skus (fn (cart) (map line-sku cart)))
+
+;; Total number of units across all lines.
+(define
+  cart-count
+  (fn (cart) (reduce (fn (acc l) (+ acc (line-qty l))) 0 cart)))
+
+;; Relational view of cart lines.
+(define
+  cart-lineo
+  (fn (cart sku variant qty) (membero (list sku variant qty) cart)))

lib/commerce/catalog.sx

@@ -0,0 +1,83 @@
+;; lib/commerce/catalog.sx — catalog snapshot + relational accessors.
+;;
+;; A catalog snapshot is an immutable dict:
+;;   {:products (list (list sku price class) ...)
+;;    :variants (list (list sku variant delta) ...)
+;;    :stock    (list (list sku variant qty) ...)}
+;;
+;; Money is integer minor units (pence/cents). class is a keyword product
+;; class consumed later by tax and promotion relations. delta is a signed
+;; price adjustment for a variant; qty is on-hand stock for (sku,variant).
+;;
+;; Accessor relations take the snapshot as the first argument and are fully
+;; multidirectional: (producto cat "widget" p c) binds p,c forward;
+;; (producto cat s 1000 c) enumerates every sku priced 1000 backward.
+
+(define empty-catalog {:products (list) :stock (list) :variants (list)})
+
+(define make-catalog (fn (products variants stock) {:products products :stock stock :variants variants}))
+
+(define cat-products (fn (cat) (get cat :products)))
+(define cat-variants (fn (cat) (get cat :variants)))
+(define cat-stock (fn (cat) (get cat :stock)))
+
+;; --- core fact relations ---
+
+(define
+  producto
+  (fn
+    (cat sku price class)
+    (membero (list sku price class) (get cat :products))))
+
+(define
+  varianto
+  (fn
+    (cat sku variant delta)
+    (membero (list sku variant delta) (get cat :variants))))
+
+(define
+  stocko
+  (fn
+    (cat sku variant qty)
+    (membero (list sku variant qty) (get cat :stock))))
+
+;; --- derived relations ---
+
+(define
+  priceo
+  (fn (cat sku price) (fresh (c) (producto cat sku price c))))
+
+(define
+  classo
+  (fn (cat sku class) (fresh (p) (producto cat sku p class))))
+
+;; Effective unit price of a (sku,variant): base + variant delta.
+(define
+  unit-priceo
+  (fn
+    (cat sku variant price)
+    (fresh
+      (base delta)
+      (priceo cat sku base)
+      (varianto cat sku variant delta)
+      (pluso-i base delta price))))
+
+;; --- deterministic lookups (first solution under fixed fact order) ---
+
+(define
+  catalog-price
+  (fn
+    (cat sku)
+    (let
+      ((rs (run 1 p (priceo cat sku p))))
+      (if (empty? rs) nil (first rs)))))
+
+(define
+  catalog-class
+  (fn
+    (cat sku)
+    (let
+      ((rs (run 1 c (classo cat sku c))))
+      (if (empty? rs) nil (first rs)))))
+
+(define catalog-has? (fn (cat sku) (not (nil? (catalog-price cat sku)))))

lib/commerce/conformance.sh

@@ -0,0 +1,153 @@
+#!/usr/bin/env bash
+# lib/commerce/conformance.sh — run commerce test suites in one sx_server
+# process per suite, emit scoreboard.json + scoreboard.md.
+#
+# commerce-on-sx builds pricing/promotion as miniKanren relations, so every
+# suite loads the miniKanren stack first, then the commerce modules.
+
+set -uo pipefail
+cd "$(git rev-parse --show-toplevel)"
+
+SX_SERVER="${SX_SERVER:-/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe}"
+if [ ! -x "$SX_SERVER" ]; then
+  SX_SERVER="hosts/ocaml/_build/default/bin/sx_server.exe"
+fi
+if [ ! -x "$SX_SERVER" ]; then
+  echo "ERROR: sx_server.exe not found." >&2
+  exit 1
+fi
+
+SUITES=(catalog cart price api promo stack quote ledger order recon federation attribution payment window nettax stock refund integration)
+
+OUT_JSON="lib/commerce/scoreboard.json"
+OUT_MD="lib/commerce/scoreboard.md"
+
+run_suite() {
+  local suite=$1
+  local file="lib/commerce/tests/${suite}.sx"
+  local TMP
+  TMP=$(mktemp)
+  cat > "$TMP" << EPOCHS
+(epoch 1)
+(load "spec/stdlib.sx")
+(load "lib/r7rs.sx")
+(load "lib/guest/match.sx")
+(load "lib/minikanren/unify.sx")
+(load "lib/minikanren/stream.sx")
+(load "lib/minikanren/goals.sx")
+(load "lib/minikanren/fresh.sx")
+(load "lib/minikanren/conde.sx")
+(load "lib/minikanren/run.sx")
+(load "lib/minikanren/relations.sx")
+(load "lib/minikanren/project.sx")
+(load "lib/minikanren/intarith.sx")
+(load "lib/minikanren/matche.sx")
+(load "lib/minikanren/defrel.sx")
+(load "lib/persist/event.sx")
+(load "lib/persist/backend.sx")
+(load "lib/persist/log.sx")
+(load "lib/persist/kv.sx")
+(load "lib/persist/idempotency.sx")
+(load "lib/guest/lex.sx")
+(load "lib/guest/reflective/env.sx")
+(load "lib/guest/reflective/quoting.sx")
+(load "lib/scheme/parser.sx")
+(load "lib/scheme/eval.sx")
+(load "lib/scheme/runtime.sx")
+(load "lib/flow/spec.sx")
+(load "lib/flow/store.sx")
+(load "lib/flow/remote.sx")
+(load "lib/flow/host.sx")
+(load "lib/flow/api.sx")
+(load "lib/commerce/catalog.sx")
+(load "lib/commerce/cart.sx")
+(load "lib/commerce/price.sx")
+(load "lib/commerce/api.sx")
+(load "lib/commerce/promo.sx")
+(load "lib/commerce/stack.sx")
+(load "lib/commerce/quote.sx")
+(load "lib/commerce/window.sx")
+(load "lib/commerce/nettax.sx")
+(load "lib/commerce/stock.sx")
+(load "lib/commerce/ledger.sx")
+(load "lib/commerce/order.sx")
+(load "lib/commerce/refund.sx")
+(load "lib/commerce/payment.sx")
+(load "lib/commerce/recon.sx")
+(load "lib/commerce/federation.sx")
+(load "lib/commerce/attribution.sx")
+(epoch 2)
+(eval "(define ct-pass 0)")
+(eval "(define ct-fail 0)")
+(eval "(define ct-fails (list))")
+(eval "(define commerce-test (fn (name got expected) (if (= got expected) (set! ct-pass (+ ct-pass 1)) (begin (set! ct-fail (+ ct-fail 1)) (append! ct-fails name)))))")
+(epoch 3)
+(load "${file}")
+(epoch 4)
+(eval "(list ct-pass ct-fail)")
+(eval "ct-fails")
+EPOCHS
+
+  local OUTPUT
+  OUTPUT=$(timeout 560 "$SX_SERVER" < "$TMP" 2>/dev/null)
+  rm -f "$TMP"
+
+  # The (list ct-pass ct-fail) result follows its (ok-len 2 N) ack line.
+  local LINE
+  LINE=$(echo "$OUTPUT" | grep -oE '^\([0-9]+ [0-9]+\)$' | tail -1)
+  local P F
+  P=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\)$/\1/')
+  F=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\)$/\2/')
+  P=${P:-0}
+  F=${F:-0}
+  echo "${P} ${F}"
+}
+
+declare -A SUITE_PASS
+declare -A SUITE_FAIL
+TOTAL_PASS=0
+TOTAL_FAIL=0
+
+echo "Running commerce conformance suite..." >&2
+for s in "${SUITES[@]}"; do
+  read -r p f < <(run_suite "$s")
+  SUITE_PASS[$s]=$p
+  SUITE_FAIL[$s]=$f
+  TOTAL_PASS=$((TOTAL_PASS + p))
+  TOTAL_FAIL=$((TOTAL_FAIL + f))
+  printf "  %-12s %d/%d\n" "$s" "$p" "$((p+f))" >&2
+done
+
+{
+  printf '{\n'
+  printf '  "suites": {\n'
+  first=1
+  for s in "${SUITES[@]}"; do
+    if [ $first -eq 0 ]; then printf ',\n'; fi
+    printf '    "%s": {"pass": %d, "fail": %d}' "$s" "${SUITE_PASS[$s]}" "${SUITE_FAIL[$s]}"
+    first=0
+  done
+  printf '\n  },\n'
+  printf '  "total_pass": %d,\n' "$TOTAL_PASS"
+  printf '  "total_fail": %d,\n' "$TOTAL_FAIL"
+  printf '  "total": %d\n' "$((TOTAL_PASS + TOTAL_FAIL))"
+  printf '}\n'
+} > "$OUT_JSON"
+
+{
+  printf '# commerce Conformance Scoreboard\n\n'
+  printf '_Generated by `lib/commerce/conformance.sh`_\n\n'
+  printf '| Suite | Pass | Fail | Total |\n'
+  printf '|-------|-----:|-----:|------:|\n'
+  for s in "${SUITES[@]}"; do
+    p=${SUITE_PASS[$s]}
+    f=${SUITE_FAIL[$s]}
+    printf '| %s | %d | %d | %d |\n' "$s" "$p" "$f" "$((p+f))"
+  done
+  printf '| **Total** | **%d** | **%d** | **%d** |\n' "$TOTAL_PASS" "$TOTAL_FAIL" "$((TOTAL_PASS + TOTAL_FAIL))"
+} > "$OUT_MD"
+
+echo "Wrote $OUT_JSON and $OUT_MD" >&2
+echo "Total: $TOTAL_PASS pass, $TOTAL_FAIL fail" >&2
+
+[ "$TOTAL_FAIL" -eq 0 ]

lib/commerce/federation.sx

@@ -0,0 +1,86 @@
+;; lib/commerce/federation.sx — cross-instance catalog (federated marketplace).
+;;
+;; STUB: instances are registered in-process; there is no real network or
+;; ActivityPub transport here (that lives in the federation service). The point
+;; is the relational model: a federated catalog is just the UNION of each
+;; instance's product facts, tagged with origin, so the same miniKanren
+;; relations answer cross-instance questions — "which instances sell this sku?",
+;; "which is cheapest?" — as backward queries, no new query engine.
+
+(define federation-stub? true)
+
+(define make-federation (fn (instance cat) {:instances (list (list instance cat))}))
+
+(define
+  federation-add
+  (fn
+    (fed instance cat)
+    (assoc
+      fed
+      :instances (append (get fed :instances) (list (list instance cat))))))
+
+(define federation-instances (fn (fed) (map first (get fed :instances))))
+
+;; Flatten to (instance sku price class) origin-tagged tuples.
+(define
+  fed-products
+  (fn
+    (fed)
+    (reduce
+      (fn
+        (acc pair)
+        (let
+          ((instance (first pair)) (cat (nth pair 1)))
+          (append
+            acc
+            (map (fn (p) (cons instance p)) (get cat :products)))))
+      (list)
+      (get fed :instances))))
+
+;; --- relations over the federated catalog (multidirectional) ---
+
+(define
+  fed-producto
+  (fn
+    (fed instance sku price class)
+    (membero (list instance sku price class) (fed-products fed))))
+
+(define
+  fed-priceo
+  (fn
+    (fed instance sku price)
+    (fresh (c) (fed-producto fed instance sku price c))))
+
+;; --- query helpers ---
+
+;; Which instances carry a sku? (backward query)
+(define
+  instances-with-sku
+  (fn (fed sku) (run* inst (fresh (p c) (fed-producto fed inst sku p c)))))
+
+;; All (price instance) offers for a sku, in federation order.
+(define
+  sku-offers
+  (fn
+    (fed sku)
+    (run*
+      pair
+      (fresh
+        (inst p c)
+        (fed-producto fed inst sku p c)
+        (== pair (list p inst))))))
+
+;; Cheapest (price instance) for a sku — the deterministic selection layer.
+(define
+  cheapest-offer
+  (fn
+    (fed sku)
+    (let
+      ((offers (sku-offers fed sku)))
+      (if
+        (empty? offers)
+        nil
+        (reduce
+          (fn (best x) (if (< (first x) (first best)) x best))
+          (first offers)
+          offers)))))

lib/commerce/ledger.sx

@@ -0,0 +1,176 @@
+;; lib/commerce/ledger.sx — the order ledger as a persist event stream.
+;;
+;; Each order is an append-only stream "order/<id>" in a persist backend.
+;; Order state is never stored directly — it is a projection (fold) over the
+;; events, so the ledger is the single source of truth and replays identically.
+;;
+;; Lifecycle events:
+;;   :created   quote snapshot {:subtotal :discount :tax :total :codes ...}
+;;   :reserved  stock reserved
+;;   :paid      {:amount :ref}  — recorded idempotently on the payment ref
+;;   :fulfilled order shipped/delivered
+;;   :cancelled / :refunded
+;;
+;; Idempotency: the SumUp webhook can fire twice for one payment. order-pay
+;; uses persist/append-once keyed by the payment ref, so a replayed webhook
+;; yields the SAME :paid event without double-recording. Reconciliation then
+;; detects genuine mismatches (paid != ordered) across the whole ledger.
+
+(define order-stream (fn (order-id) (str "order/" order-id)))
+
+;; --- writes ---
+
+(define
+  order-create
+  (fn
+    (b order-id at quote)
+    (persist/append b (order-stream order-id) :created at quote)))
+
+(define
+  order-reserve
+  (fn
+    (b order-id at data)
+    (persist/append b (order-stream order-id) :reserved at data)))
+
+;; Idempotent on payment ref — a replayed webhook does not double-record.
+(define
+  order-pay
+  (fn
+    (b order-id ref at amount)
+    (persist/append-once b (order-stream order-id) ref :paid at {:amount amount :ref ref})))
+
+(define
+  order-fulfil
+  (fn
+    (b order-id at data)
+    (persist/append b (order-stream order-id) :fulfilled at data)))
+
+(define
+  order-cancel
+  (fn
+    (b order-id at reason)
+    (persist/append b (order-stream order-id) :cancelled at {:reason reason})))
+
+(define
+  order-refund
+  (fn
+    (b order-id ref at amount)
+    (persist/append-once
+      b
+      (order-stream order-id)
+      (str "refund/" ref)
+      :refunded at
+      {:amount amount :ref ref})))
+
+;; --- reads ---
+
+(define
+  order-events
+  (fn (b order-id) (persist/read b (order-stream order-id))))
+
+;; --- projections over an event list ---
+
+(define
+  order-status-of
+  (fn
+    (events)
+    (reduce
+      (fn
+        (st e)
+        (let
+          ((t (persist/event-type e)))
+          (cond
+            ((= t :created) :pending)
+            ((= t :reserved) :reserved)
+            ((= t :paid) :paid)
+            ((= t :fulfilled) :fulfilled)
+            ((= t :cancelled) :cancelled)
+            ((= t :refunded) :refunded)
+            (:else st))))
+      :new events)))
+
+(define
+  order-total-of
+  (fn
+    (events)
+    (let
+      ((created (filter (fn (e) (= (persist/event-type e) :created)) events)))
+      (if
+        (empty? created)
+        0
+        (get (persist/event-data (first created)) :total)))))
+
+(define
+  order-paid-amount-of
+  (fn
+    (events)
+    (reduce
+      (fn
+        (acc e)
+        (if
+          (= (persist/event-type e) :paid)
+          (+ acc (get (persist/event-data e) :amount))
+          acc))
+      0
+      events)))
+
+(define
+  order-refunded-amount-of
+  (fn
+    (events)
+    (reduce
+      (fn
+        (acc e)
+        (if
+          (= (persist/event-type e) :refunded)
+          (+ acc (get (persist/event-data e) :amount))
+          acc))
+      0
+      events)))
+
+;; Net settled = paid - refunded. Reconciliation compares this to the order
+;; total, but only once a payment exists.
+(define
+  order-recon-of
+  (fn
+    (events)
+    (let
+      ((net (- (order-paid-amount-of events) (order-refunded-amount-of events)))
+        (total (order-total-of events))
+        (has-paid (some (fn (e) (= (persist/event-type e) :paid)) events)))
+      (cond
+        ((not has-paid) :unpaid)
+        ((= net total) :ok)
+        ((< net total) :underpaid)
+        (:else :overpaid)))))
+
+;; --- backend-level helpers ---
+
+(define
+  order-status
+  (fn (b order-id) (order-status-of (order-events b order-id))))
+(define
+  order-total
+  (fn (b order-id) (order-total-of (order-events b order-id))))
+(define
+  order-paid
+  (fn (b order-id) (order-paid-amount-of (order-events b order-id))))
+(define
+  order-recon
+  (fn (b order-id) (order-recon-of (order-events b order-id))))
+
+(define order-ids (fn (b) (persist/backend-streams b)))
+
+;; Streams whose net payment does not match the order total (true mismatches,
+;; excluding orders that are simply not yet paid).
+(define
+  ledger-mismatches
+  (fn
+    (b)
+    (filter
+      (fn
+        (s)
+        (let
+          ((r (order-recon-of (persist/read b s))))
+          (or (= r :underpaid) (= r :overpaid))))
+      (persist/backend-streams b))))

lib/commerce/nettax.sx

@@ -0,0 +1,80 @@
+;; lib/commerce/nettax.sx — discount-aware tax (alternative policy).
+;;
+;; price.sx / quote.sx tax the GROSS per-line amounts (discount reduces payable
+;; but not the tax base). This module is the alternative explicit policy: tax the
+;; NET (post-discount) base. The basket-level discount is allocated across lines
+;; in proportion to each line's extended price, with a deterministic
+;; largest-remainder pass so per-line shares sum EXACTLY to the discount; tax is
+;; then charged on each line's net at its class rate.
+;;
+;; Both policies are reproducible from (ctx, cart, ruleset, exclusions); pick the
+;; one the jurisdiction requires. cart-quote-net mirrors cart-quote's shape.
+
+(define ct-sum (fn (xs) (reduce (fn (a x) (+ a x)) 0 xs)))
+
+;; Add 1 to the first `rem` elements (deterministic remainder distribution).
+(define
+  ct-add-rem
+  (fn
+    (xs rem)
+    (cond
+      ((empty? xs) (list))
+      ((> rem 0)
+        (cons
+          (+ (first xs) 1)
+          (ct-add-rem (rest xs) (- rem 1))))
+      (:else xs))))
+
+;; Per-line discount allocation (parallel to cart), summing exactly to
+;; total-discount, proportional to line-extended share.
+(define
+  allocate-discount
+  (fn
+    (cat cart total-discount)
+    (let
+      ((sub (cart-subtotal cat cart)))
+      (if
+        (= sub 0)
+        (map (fn (l) 0) cart)
+        (let
+          ((floors (map (fn (l) (quotient (* total-discount (line-extended cat l)) sub)) cart)))
+          (ct-add-rem floors (- total-discount (ct-sum floors))))))))
+
+;; Tax on one line's net (extended - allocated discount), clamped at 0.
+(define
+  net-line-tax
+  (fn
+    (ctx line alloc)
+    (let
+      ((cat (ctx-catalog ctx)))
+      (let
+        ((net (- (line-extended cat line) alloc)))
+        (apply-bps
+          (if (< net 0) 0 net)
+          (rate-bps
+            (get ctx :tax-rules)
+            (get ctx :jurisdiction)
+            (catalog-class cat (line-sku line))
+            (get ctx :customer)))))))
+
+(define
+  net-tax
+  (fn
+    (ctx cart allocations)
+    (ct-sum
+      (map (fn (line alloc) (net-line-tax ctx line alloc)) cart allocations))))
+
+;; Discount-aware quote: tax computed on the net (post-discount) base.
+(define
+  cart-quote-net
+  (fn
+    (ctx cart ruleset exclusions)
+    (let
+      ((cat (ctx-catalog ctx)))
+      (let
+        ((sub (cart-subtotal cat cart))
+          (disc (best-promo-discount ctx cart ruleset exclusions))
+          (codes (best-promo-codes ctx cart ruleset exclusions)))
+        (let
+          ((tax (net-tax ctx cart (allocate-discount cat cart disc))))
+          {:codes codes :subtotal sub :discount disc :total (+ (- sub disc) tax) :tax tax})))))

lib/commerce/order.sx

@@ -0,0 +1,119 @@
+;; lib/commerce/order.sx — order lifecycle as a durable flow-on-sx flow.
+;;
+;; The lifecycle (reserve -> await payment -> fulfil) is a Scheme flow running
+;; in the flow-on-sx guest (lib/flow). The flow is PURE ORCHESTRATION: it
+;; carries only the order-id and enforces step ordering + the suspension at the
+;; payment IO boundary. All IO/state lives in SX: the SX driver here services
+;; each flow request by appending to the persist ledger (ledger.sx).
+;;
+;;   reserve  -> SX appends :reserved, resumes  (synchronous host effect)
+;;   payment  -> flow stays SUSPENDED until the SumUp webhook resumes it
+;;   fulfil   -> SX appends :fulfilled, resumes (synchronous host effect)
+;;
+;; Durability: the flow's replay log is plain data (flow-store-export), so a
+;; suspended order survives a process restart — order-flow-restart! simulates
+;; that entirely Scheme-side. Idempotency: order-settle! only resumes a flow
+;; still waiting on payment, so a replayed webhook is a no-op at the flow level,
+;; and order-pay is idempotent at the ledger level.
+
+;; The flow definition (Scheme source). oid is in scope throughout the begin.
+(define
+  order-flow-src
+  "(defflow order-lifecycle (lambda (oid) (begin (request (quote reserve) oid) (request (quote payment) oid) (request (quote fulfil) oid))))")
+
+;; Build a flow env with the order flow registered. Never returns the env from
+;; an eval boundary (the env is large/cyclic — serializing it hangs).
+(define
+  order-make-env
+  (fn
+    ()
+    (let
+      ((env (flow-make-env)))
+      (begin (flow-run-in env order-flow-src) env))))
+
+;; --- thin Scheme bridge (string-interpolated flow ops) ---
+
+(define
+  order-flow-start
+  (fn
+    (env oid)
+    (flow-run-in env (str "(flow/start order-lifecycle \"" oid "\")"))))
+
+(define
+  order-flow-resume
+  (fn
+    (env id sym)
+    (flow-run-in env (str "(flow/resume " id " (quote " sym "))"))))
+
+(define
+  order-flow-status
+  (fn (env id) (flow-run-in env (str "(flow/status " id ")"))))
+(define
+  order-flow-result
+  (fn (env id) (flow-run-in env (str "(flow/result " id ")"))))
+
+;; The request kind the flow with this id is waiting on, or nil if it is not
+;; suspended on a host request (done / cancelled / unknown).
+(define
+  order-flow-waiting
+  (fn
+    (env id)
+    (let
+      ((reqs (flow-run-in env "(flow-host-requests)")))
+      (let
+        ((mine (filter (fn (r) (= (first r) id)) reqs)))
+        (if (empty? mine) nil (nth (first mine) 1))))))
+
+;; Id out of a (flow-suspended id tag) start/resume result.
+(define order-susp-id (fn (susp) (nth susp 1)))
+
+;; --- high-level lifecycle (flow + ledger composed) ---
+
+;; Create the order, start the flow, service the reserve step, and leave the
+;; flow suspended at payment. Returns the flow id (needed to settle later).
+(define
+  order-begin!
+  (fn
+    (env b oid at quote)
+    (begin
+      (order-create b oid at quote)
+      (let
+        ((id (order-susp-id (order-flow-start env oid))))
+        (begin
+          (order-reserve b oid (+ at 1) {})
+          (order-flow-resume env id :reserved)
+          id)))))
+
+;; Settle a payment: record it, resume the flow past payment, service fulfil.
+;; Idempotent — only acts when the flow is still waiting on payment, so a
+;; replayed webhook returns :already-settled without double-charging.
+(define
+  order-settle!
+  (fn
+    (env b id oid ref at amount)
+    (if
+      (= (order-flow-waiting env id) "payment")
+      (begin
+        (order-pay b oid ref at amount)
+        (order-flow-resume env id :paid)
+        (order-fulfil b oid (+ at 1) {})
+        (order-flow-resume env id :fulfilled)
+        :settled)
+      :already-settled)))
+
+;; Simulate a process restart: export the flow store, reset the runtime, reload
+;; the flow definition, reimport the store. Done entirely Scheme-side so the
+;; (large) store is never marshalled across the boundary. The persist ledger is
+;; a separate store and is unaffected. Suspended flows resume afterwards.
+(define
+  order-flow-restart!
+  (fn
+    (env)
+    (flow-run-in
+      env
+      (str
+        "(begin (define _saved (flow-store-export)) "
+        flow-reset-src
+        " "
+        order-flow-src
+        " (flow-store-import! _saved) #t)"))))

lib/commerce/payment.sx

@@ -0,0 +1,41 @@
+;; lib/commerce/payment.sx — provider-neutral payment-request envelope.
+;;
+;; The order flow (order.sx) suspends on `(request 'payment oid)` — it carries
+;; ONLY the order-id and calls no provider. This layer materialises, at the IO
+;; edge, the envelope a provider adapter needs to initiate payment:
+;;
+;;   {:order oid :amount <ledger total> :currency C :return-url U}
+;;
+;; amount comes from the ledger (the :created quote total); currency + return-url
+;; are host/provider config (legitimately host-supplied). The engine stays
+;; vendor-agnostic: SumUp/Stripe/etc. adapters consume this envelope, and
+;; order-settle!(ref, amount) is the vendor-neutral resume seam. No provider
+;; SDK, HTTP, or webhook parsing lives here — that is the orders service's job.
+
+(define payment-request (fn (b oid currency return-url) {:order oid :amount (order-total b oid) :return-url return-url :currency currency}))
+
+(define payment-request-order (fn (pr) (get pr :order)))
+(define payment-request-amount (fn (pr) (get pr :amount)))
+(define payment-request-currency (fn (pr) (get pr :currency)))
+(define payment-request-return-url (fn (pr) (get pr :return-url)))
+
+;; A Scheme string carried as a flow payload round-trips back to SX wrapped as
+;; {:scm-string "..."}; unwrap it to the bare order-id.
+(define
+  scm->string
+  (fn
+    (v)
+    (if (and (dict? v) (has-key? v :scm-string)) (get v :scm-string) v)))
+
+;; Host poller seam: every order currently suspended awaiting payment, each with
+;; its envelope. A provider adapter iterates these, initiates payment, and later
+;; calls order-settle! when the webhook arrives. Needs the flow env.
+(define
+  pending-payments
+  (fn
+    (env b currency return-url)
+    (let
+      ((reqs (flow-run-in env "(flow-host-requests)")))
+      (map
+        (fn (r) {:id (first r) :request (payment-request b (scm->string (nth r 2)) currency return-url)})
+        (filter (fn (r) (= (nth r 1) "payment")) reqs)))))

lib/commerce/price.sx

@@ -0,0 +1,110 @@
+;; lib/commerce/price.sx — deterministic subtotal + jurisdiction-relational tax.
+;;
+;; A pricing context bundles the inputs that make a total reproducible:
+;;   {:catalog CAT :tax-rules RULES :jurisdiction J :customer C}
+;; Same context + same cart => identical total, every run.
+;;
+;; Tax is NOT a hardcoded VAT rate. Rules are facts indexed by
+;;   (jurisdiction, product-class, customer-class) -> rate-bps
+;; where rate-bps is an integer in basis points (2000 = 20%). taxo queries
+;; them multidirectionally. Money stays in integer minor units; rounding is
+;; half-up per line via integer arithmetic only — never floats.
+
+(define
+  make-pricing-context
+  (fn (catalog tax-rules jurisdiction customer) {:customer customer :jurisdiction jurisdiction :catalog catalog :tax-rules tax-rules}))
+
+(define ctx-catalog (fn (ctx) (get ctx :catalog)))
+
+;; --- unit + line pricing ---
+
+;; Variant delta, defaulting to 0 when the (sku,variant) has no variant fact.
+(define
+  variant-delta
+  (fn
+    (cat sku variant)
+    (let
+      ((rs (run 1 d (varianto cat sku variant d))))
+      (if (empty? rs) 0 (first rs)))))
+
+;; Effective unit price = base price + variant delta. nil if sku unknown.
+(define
+  line-unit-price
+  (fn
+    (cat sku variant)
+    (let
+      ((base (catalog-price cat sku)))
+      (if (nil? base) nil (+ base (variant-delta cat sku variant))))))
+
+;; Extended (line) price = unit price * quantity.
+(define
+  line-extended
+  (fn
+    (cat line)
+    (*
+      (line-unit-price cat (line-sku line) (line-variant line))
+      (line-qty line))))
+
+(define
+  cart-subtotal
+  (fn
+    (cat cart)
+    (reduce (fn (acc l) (+ acc (line-extended cat l))) 0 cart)))
+
+;; --- tax (jurisdiction-relational) ---
+
+;; rules: (list (list jurisdiction class customer bps) ...)
+(define
+  taxo
+  (fn
+    (rules juris class cust bps)
+    (membero (list juris class cust bps) rules)))
+
+;; Deterministic rate lookup; 0 when no rule matches.
+(define
+  rate-bps
+  (fn
+    (rules juris class cust)
+    (let
+      ((rs (run 1 b (taxo rules juris class cust b))))
+      (if (empty? rs) 0 (first rs)))))
+
+;; Apply a basis-point rate to an integer amount, rounding half up.
+(define
+  apply-bps
+  (fn (amount bps) (quotient (+ (* amount bps) 5000) 10000)))
+
+(define
+  line-tax
+  (fn
+    (ctx line)
+    (let
+      ((cat (ctx-catalog ctx)))
+      (let
+        ((class (catalog-class cat (line-sku line))))
+        (apply-bps
+          (line-extended cat line)
+          (rate-bps
+            (get ctx :tax-rules)
+            (get ctx :jurisdiction)
+            class
+            (get ctx :customer)))))))
+
+(define
+  cart-tax
+  (fn
+    (ctx cart)
+    (reduce (fn (acc l) (+ acc (line-tax ctx l))) 0 cart)))
+
+;; --- total ---
+
+;; Returns {:subtotal :discounts :tax :total}. discounts is 0 until Phase 2.
+(define
+  cart-total
+  (fn
+    (ctx cart)
+    (let
+      ((cat (ctx-catalog ctx)))
+      (let
+        ((sub (cart-subtotal cat cart)) (tax (cart-tax ctx cart)))
+        {:subtotal sub :discounts 0 :total (+ sub tax) :tax tax}))))

lib/commerce/promo.sx

@@ -0,0 +1,153 @@
+;; lib/commerce/promo.sx — promotions as relations over the cart + catalog.
+;;
+;; A promo is a tagged tuple; the second field is always its code:
+;;   (:percent code class pct-bps)   pct-bps off every line of product-class
+;;   (:fixed   code threshold amount) amount off when subtotal >= threshold
+;;   (:bundle  code sku n)            every nth unit of sku is free
+;;   (:member  code class pct-bps)    like :percent, members only
+;;
+;; A ruleset is a list of promo tuples. The discount a promo yields on a
+;; given cart is a pure integer computation (minor units); the *enumeration*
+;; of which promos apply is relational, so promo-applieso runs forward
+;; ("which codes apply and for how much?") and backward ("which code yields
+;; this discount?"). Stacking precedence is a separate layer (stack.sx).
+
+(define promo-kind (fn (p) (nth p 0)))
+(define promo-code (fn (p) (nth p 1)))
+
+;; Extended price of all lines whose sku is in product-class `class`.
+(define
+  class-extended
+  (fn
+    (ctx cart class)
+    (let
+      ((cat (ctx-catalog ctx)))
+      (reduce
+        (fn
+          (acc l)
+          (if
+            (= (catalog-class cat (line-sku l)) class)
+            (+ acc (line-extended cat l))
+            acc))
+        0
+        cart))))
+
+(define
+  sku-qty
+  (fn
+    (cart sku)
+    (reduce
+      (fn (acc l) (if (= (line-sku l) sku) (+ acc (line-qty l)) acc))
+      0
+      cart)))
+
+;; --- per-type discount amounts (pure, integer minor units) ---
+
+(define
+  percent-amount
+  (fn
+    (ctx cart p)
+    (apply-bps
+      (class-extended ctx cart (nth p 2))
+      (nth p 3))))
+
+(define
+  fixed-amount
+  (fn
+    (ctx cart p)
+    (let
+      ((sub (cart-subtotal (ctx-catalog ctx) cart)))
+      (if
+        (>= sub (nth p 2))
+        (min (nth p 3) sub)
+        0))))
+
+(define
+  bundle-amount
+  (fn
+    (ctx cart p)
+    (let
+      ((sku (nth p 2)) (n (nth p 3)))
+      (let
+        ((free (quotient (sku-qty cart sku) n)))
+        (* free (catalog-price (ctx-catalog ctx) sku))))))
+
+(define
+  member-amount
+  (fn
+    (ctx cart p)
+    (if
+      (= (get ctx :customer) :member)
+      (apply-bps
+        (class-extended ctx cart (nth p 2))
+        (nth p 3))
+      0)))
+
+;; Discount this promo yields on this cart (0 if it does not apply).
+(define
+  promo-amount
+  (fn
+    (ctx cart p)
+    (let
+      ((k (promo-kind p)))
+      (cond
+        ((= k :percent) (percent-amount ctx cart p))
+        ((= k :fixed) (fixed-amount ctx cart p))
+        ((= k :bundle) (bundle-amount ctx cart p))
+        ((= k :member) (member-amount ctx cart p))
+        (:else 0)))))
+
+;; --- relational enumeration ---
+
+;; (code, amount) for every promo in the ruleset (amount may be 0).
+(define
+  promo-discounto
+  (fn
+    (ctx cart ruleset code amount)
+    (fresh
+      (p)
+      (membero p ruleset)
+      (project
+        (p)
+        (== code (promo-code p))
+        (== amount (promo-amount ctx cart p))))))
+
+;; (code, amount) restricted to promos that actually apply (amount > 0).
+(define
+  promo-applieso
+  (fn
+    (ctx cart ruleset code amount)
+    (fresh
+      (p)
+      (membero p ruleset)
+      (project
+        (p)
+        (if
+          (> (promo-amount ctx cart p) 0)
+          (mk-conj
+            (== code (promo-code p))
+            (== amount (promo-amount ctx cart p)))
+          fail)))))
+
+;; --- deterministic helpers ---
+
+;; List of (list code amount) for applicable promos, in ruleset order.
+(define
+  applicable-promos
+  (fn
+    (ctx cart ruleset)
+    (run*
+      pair
+      (fresh
+        (code amount)
+        (promo-applieso ctx cart ruleset code amount)
+        (== pair (list code amount))))))
+
+;; Discount for one code (0 if absent / inapplicable).
+(define
+  promo-amount-for
+  (fn
+    (ctx cart ruleset code)
+    (let
+      ((rs (run 1 a (promo-applieso ctx cart ruleset code a))))
+      (if (empty? rs) 0 (first rs)))))

lib/commerce/quote.sx

@@ -0,0 +1,36 @@
+;; lib/commerce/quote.sx — the final priced quote: price + promo + stacking.
+;;
+;; A quote is the deterministic composition of the pricing pipeline for a
+;; (context, cart, ruleset, exclusions) tuple:
+;;   {:subtotal S :discount D :tax T :total (S - D + T) :codes (...)}
+;;
+;; Tax policy (explicit, for the determinism contract): tax is computed on the
+;; GROSS per-line amounts (pre-discount), via price.sx cart-tax. The best
+;; promo stacking reduces the payable total but not the tax base. Same inputs
+;; always yield the same quote — this is the value the order flow carries.
+
+(define
+  cart-quote
+  (fn
+    (ctx cart ruleset exclusions)
+    (let
+      ((cat (ctx-catalog ctx)))
+      (let
+        ((sub (cart-subtotal cat cart))
+          (disc (best-promo-discount ctx cart ruleset exclusions))
+          (tax (cart-tax ctx cart))
+          (codes (best-promo-codes ctx cart ruleset exclusions)))
+        {:codes codes :subtotal sub :discount disc :total (+ (- sub disc) tax) :tax tax}))))
+
+(define quote-subtotal (fn (q) (get q :subtotal)))
+(define quote-discount (fn (q) (get q :discount)))
+(define quote-tax (fn (q) (get q :tax)))
+(define quote-total (fn (q) (get q :total)))
+(define quote-codes (fn (q) (get q :codes)))
+
+;; Session-level convenience (a session is {:ctx :cart}).
+(define
+  session-quote
+  (fn
+    (sess ruleset exclusions)
+    (cart-quote (get sess :ctx) (get sess :cart) ruleset exclusions)))

lib/commerce/recon.sx

@@ -0,0 +1,100 @@
+;; lib/commerce/recon.sx — reconciliation as relational queries over the ledger.
+;;
+;; The ledger (ledger.sx) is the source of truth; reconciliation projects it
+;; into per-order summary tuples and then asks miniKanren questions about them.
+;; "Which orders are overpaid?" / "which order settled to net N?" are backward
+;; queries (run*) over the same relation, not separate code paths.
+;;
+;; A summary tuple is positional:
+;;   (order-stream total paid refunded net status)
+;; net = paid - refunded; status = :unpaid|:ok|:underpaid|:overpaid.
+
+(define
+  order-summary
+  (fn
+    (b stream)
+    (let
+      ((events (persist/read b stream)))
+      (let
+        ((total (order-total-of events))
+          (paid (order-paid-amount-of events))
+          (refunded (order-refunded-amount-of events)))
+        (list
+          stream
+          total
+          paid
+          refunded
+          (- paid refunded)
+          (order-recon-of events))))))
+
+(define
+  ledger-summaries
+  (fn (b) (map (fn (s) (order-summary b s)) (persist/backend-streams b))))
+
+;; --- relations over the summary set ---
+
+(define
+  summaryo
+  (fn
+    (summaries id total paid refunded net status)
+    (membero (list id total paid refunded net status) summaries)))
+
+(define
+  recon-statuso
+  (fn
+    (summaries id status)
+    (fresh (t p r n) (summaryo summaries id t p r n status))))
+
+(define
+  neto
+  (fn
+    (summaries id net)
+    (fresh (t p r status) (summaryo summaries id t p r net status))))
+
+;; A mismatch is any order whose money does not reconcile (over or under).
+(define
+  mismatcho
+  (fn
+    (summaries id)
+    (fresh
+      (status)
+      (recon-statuso summaries id status)
+      (conde ((== status :underpaid)) ((== status :overpaid))))))
+
+;; --- deterministic query helpers (run* over the live ledger) ---
+
+(define
+  orders-with-status
+  (fn (b status) (run* id (recon-statuso (ledger-summaries b) id status))))
+
+(define overpaid-orders (fn (b) (orders-with-status b :overpaid)))
+(define underpaid-orders (fn (b) (orders-with-status b :underpaid)))
+(define settled-orders (fn (b) (orders-with-status b :ok)))
+(define unpaid-orders (fn (b) (orders-with-status b :unpaid)))
+
+(define
+  mismatched-orders
+  (fn (b) (run* id (mismatcho (ledger-summaries b) id))))
+
+;; Backward: which order(s) settled to a given net amount?
+(define
+  orders-with-net
+  (fn (b net) (run* id (neto (ledger-summaries b) id net))))
+
+;; Total signed discrepancy across the ledger (net - total over paid orders);
+;; 0 when every settled order reconciles exactly.
+(define
+  ledger-discrepancy
+  (fn
+    (b)
+    (reduce
+      (fn
+        (acc s)
+        (let
+          ((status (nth s 5)))
+          (if
+            (= status :unpaid)
+            acc
+            (+ acc (- (nth s 4) (nth s 1))))))
+      0
+      (ledger-summaries b))))

lib/commerce/refund.sx

@@ -0,0 +1,97 @@
+;; lib/commerce/refund.sx — refund lifecycle as a second flow-on-sx flow.
+;;
+;; A refund is request → approve → settle, with TWO genuine suspension points:
+;; approval (a human/policy decision) and settlement (the provider issuing the
+;; refund). Like order.sx the flow is pure orchestration carrying only the
+;; order-id; the SX driver does all ledger IO and reuses order.sx's generic flow
+;; helpers (order-flow-waiting/-resume/-status, order-susp-id).
+;;
+;;   refund-begin!   → ledger :refund-requested, flow suspends at 'approve
+;;   refund-approve! → resume past approval, flow suspends at 'settle
+;;   refund-settle!  → ledger :refunded (idempotent), flow completes
+;;   refund-reject!  → ledger :refund-rejected, flow cancelled
+;;
+;; Only :refunded moves the books (recon.sx), so a requested-but-unsettled or
+;; rejected refund leaves reconciliation unchanged.
+
+(define
+  refund-flow-src
+  "(defflow refund-lifecycle (lambda (oid) (begin (request (quote approve) oid) (request (quote settle) oid))))")
+
+(define
+  refund-make-env
+  (fn
+    ()
+    (let
+      ((env (flow-make-env)))
+      (begin (flow-run-in env refund-flow-src) env))))
+
+;; Register the refund flow into an existing (e.g. order) env.
+(define
+  refund-flow-load!
+  (fn (env) (begin (flow-run-in env refund-flow-src) env)))
+
+(define
+  refund-flow-start
+  (fn
+    (env oid)
+    (flow-run-in env (str "(flow/start refund-lifecycle \"" oid "\")"))))
+
+;; --- ledger writes ---
+
+(define
+  refund-request
+  (fn
+    (b oid ref at amount)
+    (persist/append-once
+      b
+      (order-stream oid)
+      (str "refund-req/" ref)
+      :refund-requested at
+      {:amount amount :ref ref})))
+
+;; --- lifecycle ---
+
+;; Open a refund: record the request, start the flow, suspend at approval.
+(define
+  refund-begin!
+  (fn
+    (env b oid ref at amount)
+    (begin
+      (refund-request b oid ref at amount)
+      (order-susp-id (refund-flow-start env oid)))))
+
+(define
+  refund-approve!
+  (fn
+    (env id)
+    (if
+      (= (order-flow-waiting env id) "approve")
+      (begin (order-flow-resume env id :approved) :approved)
+      :not-pending-approval)))
+
+(define
+  refund-reject!
+  (fn
+    (env b oid id at reason)
+    (if
+      (= (order-flow-waiting env id) "approve")
+      (begin
+        (persist/append b (order-stream oid) :refund-rejected at {:reason reason})
+        (flow-run-in env (str "(flow/cancel " id ")"))
+        :rejected)
+      :not-pending-approval)))
+
+;; Settle (provider issued the refund): idempotent — only acts while waiting on
+;; settle, so a replayed provider callback returns :already-settled.
+(define
+  refund-settle!
+  (fn
+    (env b id oid ref at amount)
+    (if
+      (= (order-flow-waiting env id) "settle")
+      (begin
+        (order-refund b oid ref at amount)
+        (order-flow-resume env id :settled)
+        :settled)
+      :already-settled)))

lib/commerce/scoreboard.json

@@ -0,0 +1,25 @@
+{
+  "suites": {
+    "catalog": {"pass": 16, "fail": 0},
+    "cart": {"pass": 18, "fail": 0},
+    "price": {"pass": 20, "fail": 0},
+    "api": {"pass": 12, "fail": 0},
+    "promo": {"pass": 17, "fail": 0},
+    "stack": {"pass": 16, "fail": 0},
+    "quote": {"pass": 13, "fail": 0},
+    "ledger": {"pass": 20, "fail": 0},
+    "order": {"pass": 22, "fail": 0},
+    "recon": {"pass": 20, "fail": 0},
+    "federation": {"pass": 12, "fail": 0},
+    "attribution": {"pass": 16, "fail": 0},
+    "payment": {"pass": 7, "fail": 0},
+    "window": {"pass": 19, "fail": 0},
+    "nettax": {"pass": 11, "fail": 0},
+    "stock": {"pass": 19, "fail": 0},
+    "refund": {"pass": 20, "fail": 0},
+    "integration": {"pass": 19, "fail": 0}
+  },
+  "total_pass": 297,
+  "total_fail": 0,
+  "total": 297
+}

lib/commerce/scoreboard.md

@@ -0,0 +1,25 @@
+# commerce Conformance Scoreboard
+
+_Generated by `lib/commerce/conformance.sh`_
+
+| Suite | Pass | Fail | Total |
+|-------|-----:|-----:|------:|
+| catalog | 16 | 0 | 16 |
+| cart | 18 | 0 | 18 |
+| price | 20 | 0 | 20 |
+| api | 12 | 0 | 12 |
+| promo | 17 | 0 | 17 |
+| stack | 16 | 0 | 16 |
+| quote | 13 | 0 | 13 |
+| ledger | 20 | 0 | 20 |
+| order | 22 | 0 | 22 |
+| recon | 20 | 0 | 20 |
+| federation | 12 | 0 | 12 |
+| attribution | 16 | 0 | 16 |
+| payment | 7 | 0 | 7 |
+| window | 19 | 0 | 19 |
+| nettax | 11 | 0 | 11 |
+| stock | 19 | 0 | 19 |
+| refund | 20 | 0 | 20 |
+| integration | 19 | 0 | 19 |
+| **Total** | **297** | **0** | **297** |

lib/commerce/stack.sx

@@ -0,0 +1,121 @@
+;; lib/commerce/stack.sx — promotion stacking precedence + best price.
+;;
+;; Per the miniKanren design rule, precedence is NOT encoded inside the promo
+;; rules. promo.sx enumerates which promos apply; this layer enumerates which
+;; *combinations* are legal and selects the best one by an explicit cost
+;; function (max total discount = min price).
+;;
+;; Exclusivity is a list of unordered code pairs that may not both apply:
+;;   exclusions = (list (list code-a code-b) ...)
+;; A stacking is a subset of applicable (code amount) pairs containing no
+;; excluded pair. valid-stackings enumerates them; best-stacking is the
+;; deterministic selection layer; stacking-by-totalo is the backward query
+;; ("which legal stacking yields this total discount?").
+
+(define
+  excluded-pair?
+  (fn
+    (exclusions a b)
+    (some
+      (fn
+        (p)
+        (or
+          (and (= (first p) a) (= (nth p 1) b))
+          (and (= (first p) b) (= (nth p 1) a))))
+      exclusions)))
+
+;; True when no two distinct codes in the list are mutually excluded.
+(define
+  compatible?
+  (fn
+    (exclusions codes)
+    (every?
+      (fn
+        (a)
+        (every?
+          (fn (b) (or (= a b) (not (excluded-pair? exclusions a b))))
+          codes))
+      codes)))
+
+;; All subsets of xs, preserving element order. 2^n entries.
+(define
+  powerset
+  (fn
+    (xs)
+    (if
+      (empty? xs)
+      (list (list))
+      (let
+        ((r (powerset (cdr xs))))
+        (append r (map (fn (s) (cons (first xs) s)) r))))))
+
+(define stacking-codes (fn (st) (map first st)))
+
+(define
+  stacking-total
+  (fn
+    (st)
+    (reduce (fn (acc pair) (+ acc (nth pair 1))) 0 st)))
+
+;; Every legal stacking of the applicable (code amount) pairs.
+(define
+  valid-stackings
+  (fn
+    (exclusions applicable)
+    (filter
+      (fn (st) (compatible? exclusions (stacking-codes st)))
+      (powerset applicable))))
+
+;; Deterministic selection: the legal stacking with the greatest total
+;; discount; ties keep the earlier (stable) candidate, so the result is a
+;; reproducible function of (exclusions, applicable).
+(define
+  best-stacking
+  (fn
+    (exclusions applicable)
+    (reduce
+      (fn
+        (best st)
+        (if (> (stacking-total st) (stacking-total best)) st best))
+      (list)
+      (valid-stackings exclusions applicable))))
+
+(define
+  best-discount
+  (fn
+    (exclusions applicable)
+    (stacking-total (best-stacking exclusions applicable))))
+
+(define
+  best-codes
+  (fn
+    (exclusions applicable)
+    (stacking-codes (best-stacking exclusions applicable))))
+
+;; Backward query: legal stackings (as code lists) whose total discount = D.
+(define
+  stacking-by-totalo
+  (fn
+    (stackings codes total)
+    (fresh
+      (st)
+      (membero st stackings)
+      (project
+        (st)
+        (mk-conj
+          (== codes (stacking-codes st))
+          (== total (stacking-total st)))))))
+
+;; --- top-level entry: best discount for a cart under a ruleset ---
+
+(define
+  best-promo-discount
+  (fn
+    (ctx cart ruleset exclusions)
+    (best-discount exclusions (applicable-promos ctx cart ruleset))))
+
+(define
+  best-promo-codes
+  (fn
+    (ctx cart ruleset exclusions)
+    (best-codes exclusions (applicable-promos ctx cart ruleset))))

lib/commerce/stock.sx

@@ -0,0 +1,106 @@
+;; lib/commerce/stock.sx — stock-constrained reservation.
+;;
+;; Reservation is a precondition the host checks BEFORE order-begin! (validate →
+;; begin), so the order flow stays pure orchestration. Availability is read
+;; relationally from the catalog stock facts (catalog.sx stocko); a stock view
+;; subtracts already-reserved quantities so concurrent orders can't over-reserve.
+;;
+;;   can-reserve? cat cart                  — every line fits available stock
+;;   reservation-shortfalls cat cart        — the lines that do not, with detail
+;;   effective-available cat reservations …  — availability net of reservations
+;;   sufficient-stocko cat sku variant qty  — relational "can supply qty?" query
+
+;; Deterministic on-hand stock for a (sku,variant); 0 if absent.
+(define
+  available-stock
+  (fn
+    (cat sku variant)
+    (let
+      ((rs (run 1 q (stocko cat sku variant q))))
+      (if (empty? rs) 0 (first rs)))))
+
+;; Units a line cannot fulfil from on-hand stock (0 if it fits).
+(define
+  line-shortfall
+  (fn
+    (cat line)
+    (let
+      ((short (- (line-qty line) (available-stock cat (line-sku line) (line-variant line)))))
+      (if (< short 0) 0 short))))
+
+(define
+  line-reservable?
+  (fn (cat line) (= (line-shortfall cat line) 0)))
+
+;; Lines that cannot be fully reserved, each with requested/available/short.
+(define
+  reservation-shortfalls
+  (fn
+    (cat cart)
+    (reduce
+      (fn
+        (acc line)
+        (let
+          ((short (line-shortfall cat line)))
+          (if (> short 0) (append acc (list {:requested (line-qty line) :available (available-stock cat (line-sku line) (line-variant line)) :sku (line-sku line) :variant (line-variant line) :short short})) acc)))
+      (list)
+      cart)))
+
+(define
+  can-reserve?
+  (fn (cat cart) (empty? (reservation-shortfalls cat cart))))
+
+;; Validate → reject; the host gates order-begin! on this.
+(define
+  reserve-check
+  (fn (cat cart) (if (can-reserve? cat cart) :ok {:shortfalls (reservation-shortfalls cat cart) :rejected :insufficient-stock})))
+
+;; --- reservation view (concurrent-safety) ---
+;; reservations: list of (sku variant qty) already held.
+
+(define
+  reserved-qty
+  (fn
+    (reservations sku variant)
+    (reduce
+      (fn
+        (acc r)
+        (if
+          (and (= (first r) sku) (= (nth r 1) variant))
+          (+ acc (nth r 2))
+          acc))
+      0
+      reservations)))
+
+;; On-hand minus already-reserved (clamped at 0).
+(define
+  effective-available
+  (fn
+    (cat reservations sku variant)
+    (let
+      ((eff (- (available-stock cat sku variant) (reserved-qty reservations sku variant))))
+      (if (< eff 0) 0 eff))))
+
+;; Can a line be reserved given existing reservations?
+(define
+  line-reservable-with?
+  (fn
+    (cat reservations line)
+    (<=
+      (line-qty line)
+      (effective-available
+        cat
+        reservations
+        (line-sku line)
+        (line-variant line)))))
+
+;; --- relational availability query (the showcase) ---
+
+;; Succeeds when on-hand stock for (sku,variant) covers qty. Multidirectional
+;; over the stock facts: "which variants of widget can supply 5?" is a backward
+;; query.
+(define
+  sufficient-stocko
+  (fn
+    (cat sku variant qty)
+    (fresh (avail) (stocko cat sku variant avail) (lteo-i qty avail))))

lib/commerce/tests/api.sx

@@ -0,0 +1,73 @@
+;; lib/commerce/tests/api.sx — public commerce session surface.
+;; Uses (commerce-test name got expected) provided by conformance.sh.
+
+(define
+  acat
+  (make-catalog
+    (list
+      (list "widget" 1000 :standard)
+      (list "book" 800 :zero-rated))
+    (list (list "widget" :small -200))
+    (list)))
+
+(define
+  arules
+  (list
+    (list :uk :standard :guest 2000)
+    (list :uk :zero-rated :guest 0)))
+
+(define actx (make-pricing-context acat arules :uk :guest))
+(define sess0 (commerce-session actx))
+
+;; --- empty session ---
+
+(commerce-test "new-session-empty" (commerce-cart sess0) empty-cart)
+(commerce-test "new-count" (commerce-count sess0) 0)
+(commerce-test "new-total" (commerce-total sess0) {:subtotal 0 :discounts 0 :total 0 :tax 0})
+
+;; --- add + total ---
+
+(define
+  sess1
+  (commerce-add
+    (commerce-add sess0 "widget" :small 2)
+    "book"
+    :none 1))
+
+(commerce-test "add-count" (commerce-count sess1) 3)
+(commerce-test
+  "add-lines"
+  (commerce-lines sess1)
+  (list (list "widget" :small 2) (list "book" :none 1)))
+(commerce-test "add-total" (commerce-total sess1) {:subtotal 2400 :discounts 0 :total 2720 :tax 320})
+
+;; --- mutate ---
+
+(commerce-test
+  "set-qty"
+  (commerce-lines (commerce-set-qty sess1 "widget" :small 1))
+  (list (list "widget" :small 1) (list "book" :none 1)))
+
+(commerce-test
+  "remove"
+  (commerce-lines (commerce-remove sess1 "book" :none))
+  (list (list "widget" :small 2)))
+
+;; --- validation ---
+
+(commerce-test "can-add-yes" (commerce-can-add? sess0 "widget") true)
+(commerce-test "can-add-no" (commerce-can-add? sess0 "ghost") false)
+
+;; --- audit breakdown ---
+
+(commerce-test
+  "explain"
+  (commerce-explain sess1)
+  (list {:sku "widget" :unit 800 :qty 2 :variant :small :extended 1600 :tax 320} {:sku "book" :unit 800 :qty 1 :variant :none :extended 800 :tax 0}))
+
+;; --- checkout stub ---
+
+(commerce-test
+  "checkout-stub"
+  (get (commerce-checkout sess1) :status)
+  :not-implemented)

lib/commerce/tests/attribution.sx

@@ -0,0 +1,124 @@
+;; lib/commerce/tests/attribution.sx — line-level discount attribution.
+;; Uses (commerce-test name got expected) provided by conformance.sh.
+
+(define
+  pcat
+  (make-catalog
+    (list
+      (list "widget" 1000 :standard)
+      (list "gizmo" 2000 :standard)
+      (list "book" 800 :zero-rated)
+      (list "tea" 1000 :reduced))
+    (list)
+    (list)))
+
+(define gctx (make-pricing-context pcat (list) :uk :guest))
+(define mctx (make-pricing-context pcat (list) :uk :member))
+
+(define
+  cart
+  (list
+    (list "widget" :none 2)
+    (list "gizmo" :none 1)
+    (list "book" :none 1)
+    (list "tea" :none 6)))
+
+(define
+  ruleset
+  (list
+    (list :percent "TEN" :standard 1000)
+    (list :percent "TWENTY" :standard 2000)
+    (list :bundle "B3T" "tea" 3)
+    (list :fixed "FIVE" 0 500)
+    (list :member "MEM" :standard 1500)))
+
+(define w-line (list "widget" :none 2))
+(define t-line (list "tea" :none 6))
+(define bk-line (list "book" :none 1))
+
+;; --- scope helpers ---
+
+(commerce-test
+  "class-lines-standard"
+  (class-lines gctx cart :standard)
+  (list (list "widget" :none 2) (list "gizmo" :none 1)))
+
+(commerce-test
+  "promo-lines-bundle"
+  (promo-lines gctx cart (list :bundle "B3T" "tea" 3))
+  (list (list "tea" :none 6)))
+
+(commerce-test
+  "promo-lines-fixed-none"
+  (promo-lines gctx cart (list :fixed "FIVE" 0 500))
+  (list))
+
+;; --- forward: which lines does a code touch? ---
+
+(commerce-test
+  "lines-for-ten"
+  (lines-for-code gctx cart ruleset "TEN")
+  (list (list "widget" :none 2) (list "gizmo" :none 1)))
+
+(commerce-test
+  "lines-for-bundle"
+  (lines-for-code gctx cart ruleset "B3T")
+  (list (list "tea" :none 6)))
+
+(commerce-test
+  "lines-for-fixed-empty"
+  (lines-for-code gctx cart ruleset "FIVE")
+  (list))
+(commerce-test
+  "lines-for-mem-guest-empty"
+  (lines-for-code gctx cart ruleset "MEM")
+  (list))
+
+;; --- backward: which codes touch this line? (the showcase) ---
+
+(commerce-test
+  "codes-for-widget-guest"
+  (codes-for-line gctx cart ruleset w-line)
+  (list "TEN" "TWENTY"))
+
+(commerce-test
+  "codes-for-tea"
+  (codes-for-line gctx cart ruleset t-line)
+  (list "B3T"))
+(commerce-test
+  "codes-for-book-none"
+  (codes-for-line gctx cart ruleset bk-line)
+  (list))
+
+;; member sees the member rate too
+(commerce-test
+  "codes-for-widget-member"
+  (codes-for-line mctx cart ruleset w-line)
+  (list "TEN" "TWENTY" "MEM"))
+
+(commerce-test
+  "lines-for-mem-member"
+  (lines-for-code mctx cart ruleset "MEM")
+  (list (list "widget" :none 2) (list "gizmo" :none 1)))
+
+;; --- predicate ---
+
+(commerce-test
+  "touched-yes"
+  (line-touched-by? gctx cart ruleset "TEN" w-line)
+  true)
+(commerce-test
+  "touched-no-wrong-class"
+  (line-touched-by? gctx cart ruleset "B3T" w-line)
+  false)
+(commerce-test
+  "touched-no-guest-mem"
+  (line-touched-by? gctx cart ruleset "MEM" w-line)
+  false)
+
+;; --- order-level (fixed) codes ---
+
+(commerce-test
+  "order-level"
+  (order-level-codes gctx cart ruleset)
+  (list "FIVE"))

lib/commerce/tests/cart.sx

@@ -0,0 +1,103 @@
+;; lib/commerce/tests/cart.sx — cart structure + line operations.
+;; Uses (commerce-test name got expected) provided by conformance.sh.
+
+;; --- add ---
+
+(commerce-test
+  "add-to-empty"
+  (cart-add empty-cart "widget" :small 2)
+  (list (list "widget" :small 2)))
+
+(commerce-test
+  "add-merges-same-line"
+  (cart-add
+    (cart-add empty-cart "widget" :small 2)
+    "widget"
+    :small 3)
+  (list (list "widget" :small 5)))
+
+(commerce-test
+  "add-different-variant-separate"
+  (cart-add
+    (cart-add empty-cart "widget" :small 2)
+    "widget"
+    :large 1)
+  (list (list "widget" :small 2) (list "widget" :large 1)))
+
+(commerce-test
+  "add-different-sku-separate"
+  (cart-add
+    (cart-add empty-cart "widget" :small 2)
+    "gadget"
+    :std 1)
+  (list (list "widget" :small 2) (list "gadget" :std 1)))
+
+(commerce-test
+  "add-preserves-order"
+  (cart-skus
+    (cart-add
+      (cart-add (cart-add empty-cart "a" :v 1) "b" :v 1)
+      "c"
+      :v 1))
+  (list "a" "b" "c"))
+
+;; --- qty queries ---
+
+(define
+  c2
+  (cart-add
+    (cart-add empty-cart "widget" :small 2)
+    "gadget"
+    :std 4))
+
+(commerce-test "cart-qty-found" (cart-qty c2 "widget" :small) 2)
+(commerce-test "cart-qty-missing" (cart-qty c2 "widget" :large) 0)
+(commerce-test "cart-count" (cart-count c2) 6)
+(commerce-test "cart-empty-yes" (cart-empty? empty-cart) true)
+(commerce-test "cart-empty-no" (cart-empty? c2) false)
+
+;; --- set-qty ---
+
+(commerce-test
+  "set-qty-existing"
+  (cart-set-qty c2 "widget" :small 10)
+  (list (list "widget" :small 10) (list "gadget" :std 4)))
+
+(commerce-test
+  "set-qty-new-line"
+  (cart-set-qty empty-cart "book" :std 3)
+  (list (list "book" :std 3)))
+
+(commerce-test
+  "set-qty-zero-removes"
+  (cart-set-qty c2 "widget" :small 0)
+  (list (list "gadget" :std 4)))
+
+;; --- remove ---
+
+(commerce-test
+  "remove-line"
+  (cart-remove c2 "gadget" :std)
+  (list (list "widget" :small 2)))
+
+(commerce-test
+  "remove-missing-noop"
+  (cart-remove c2 "nope" :std)
+  (list (list "widget" :small 2) (list "gadget" :std 4)))
+
+;; --- relational view ---
+
+(commerce-test
+  "cart-lineo-forward"
+  (run* q (cart-lineo c2 "gadget" :std q))
+  (list 4))
+
+(commerce-test
+  "cart-lineo-sku-by-qty-backward"
+  (run* sk (fresh (v) (cart-lineo c2 sk v 4)))
+  (list "gadget"))
+
+(commerce-test
+  "cart-lineo-all-skus"
+  (run* sk (fresh (v q) (cart-lineo c2 sk v q)))
+  (list "widget" "gadget"))

lib/commerce/tests/catalog.sx

@@ -0,0 +1,93 @@
+;; lib/commerce/tests/catalog.sx — catalog facts + relational accessors.
+;; Uses (commerce-test name got expected) provided by conformance.sh.
+;; Query vars avoid the name `s` (the run-n macro binds `s` internally).
+
+(define
+  cat
+  (make-catalog
+    (list
+      (list "widget" 1000 :standard)
+      (list "gadget" 2500 :standard)
+      (list "book" 800 :zero-rated)
+      (list "tea" 1000 :reduced))
+    (list
+      (list "widget" :small -200)
+      (list "widget" :large 500)
+      (list "gadget" :std 0))
+    (list
+      (list "widget" :small 5)
+      (list "widget" :large 0)
+      (list "gadget" :std 12))))
+
+;; --- forward lookups ---
+
+(commerce-test
+  "price-forward"
+  (run* p (priceo cat "widget" p))
+  (list 1000))
+(commerce-test
+  "class-forward"
+  (run* c (classo cat "book" c))
+  (list :zero-rated))
+(commerce-test
+  "product-forward"
+  (run* q (fresh (p c) (producto cat "gadget" p c) (== q (list p c))))
+  (list (list 2500 :standard)))
+
+;; --- backward lookups (the showcase) ---
+
+(commerce-test
+  "sku-by-price-backward"
+  (run* sk (priceo cat sk 1000))
+  (list "widget" "tea"))
+
+(commerce-test
+  "sku-by-class-backward"
+  (run* sk (classo cat sk :standard))
+  (list "widget" "gadget"))
+
+(commerce-test
+  "all-prices"
+  (run* p (fresh (sk) (priceo cat sk p)))
+  (list 1000 2500 800 1000))
+
+;; --- variants + effective unit price ---
+
+(commerce-test
+  "variant-delta-forward"
+  (run* d (varianto cat "widget" :small d))
+  (list -200))
+
+(commerce-test
+  "unit-price-small"
+  (run* p (unit-priceo cat "widget" :small p))
+  (list 800))
+
+(commerce-test
+  "unit-price-large"
+  (run* p (unit-priceo cat "widget" :large p))
+  (list 1500))
+
+(commerce-test
+  "variant-by-delta-backward"
+  (run* v (varianto cat "widget" v -200))
+  (list :small))
+
+;; --- stock ---
+
+(commerce-test
+  "stock-forward"
+  (run* q (stocko cat "widget" :small q))
+  (list 5))
+
+(commerce-test
+  "in-stock-skus-backward"
+  (run* sk (fresh (v q) (stocko cat sk v q) (lto-i 0 q)))
+  (list "widget" "gadget"))
+
+;; --- deterministic helpers ---
+
+(commerce-test "catalog-price-helper" (catalog-price cat "gadget") 2500)
+(commerce-test "catalog-class-helper" (catalog-class cat "tea") :reduced)
+(commerce-test "catalog-has-yes" (catalog-has? cat "book") true)
+(commerce-test "catalog-has-no" (catalog-has? cat "nonesuch") false)

lib/commerce/tests/federation.sx

@@ -0,0 +1,88 @@
+;; lib/commerce/tests/federation.sx — federated catalog (out-of-scope stub).
+;; Uses (commerce-test name got expected) provided by conformance.sh.
+
+(define
+  cat-a
+  (make-catalog
+    (list
+      (list "widget" 1000 :standard)
+      (list "book" 800 :zero-rated))
+    (list)
+    (list)))
+
+(define
+  cat-b
+  (make-catalog
+    (list
+      (list "widget" 900 :standard)
+      (list "tea" 1200 :reduced))
+    (list)
+    (list)))
+
+(define
+  cat-c
+  (make-catalog (list (list "widget" 1100 :standard)) (list) (list)))
+
+(define
+  fed
+  (federation-add
+    (federation-add (make-federation :alpha cat-a) :beta cat-b)
+    :gamma cat-c))
+
+;; --- structure ---
+
+(commerce-test "is-stub" federation-stub? true)
+(commerce-test
+  "instances"
+  (federation-instances fed)
+  (list :alpha :beta :gamma))
+(commerce-test "product-count" (len (fed-products fed)) 5)
+
+;; --- forward query ---
+
+(commerce-test
+  "price-at-instance"
+  (run* p (fed-priceo fed :beta "widget" p))
+  (list 900))
+
+;; --- backward queries (the showcase) ---
+
+(commerce-test
+  "instances-with-widget"
+  (instances-with-sku fed "widget")
+  (list :alpha :beta :gamma))
+
+(commerce-test
+  "instances-with-book"
+  (instances-with-sku fed "book")
+  (list :alpha))
+
+(commerce-test
+  "instances-with-tea"
+  (instances-with-sku fed "tea")
+  (list :beta))
+
+(commerce-test
+  "instance-by-price-backward"
+  (run* inst (fresh (c) (fed-producto fed inst "widget" 1100 c)))
+  (list :gamma))
+
+;; --- offers + cheapest (deterministic selection) ---
+
+(commerce-test
+  "widget-offers"
+  (sku-offers fed "widget")
+  (list
+    (list 1000 :alpha)
+    (list 900 :beta)
+    (list 1100 :gamma)))
+
+(commerce-test
+  "cheapest-widget"
+  (cheapest-offer fed "widget")
+  (list 900 :beta))
+(commerce-test
+  "cheapest-book"
+  (cheapest-offer fed "book")
+  (list 800 :alpha))
+(commerce-test "cheapest-missing" (cheapest-offer fed "ghost") nil)

lib/commerce/tests/integration.sx

@@ -0,0 +1,104 @@
+;; lib/commerce/tests/integration.sx — end-to-end composition proof.
+;; Uses (commerce-test name got expected) provided by conformance.sh.
+;;
+;; One narrative across every module: catalog → stock check → quote
+;; (promo+stack+tax) → order flow → payment envelope → settle → recon → refund.
+;; Proves the seams tie together with consistent numbers (the project's thesis:
+;; minikanren pricing + flow lifecycle + persist ledger compose).
+;; Builds one flow env with BOTH the order and refund flows.
+
+(define env (order-make-env))
+(define _rf (refund-flow-load! env))
+(define b (persist/mem-backend))
+
+(define
+  cat
+  (make-catalog
+    (list
+      (list "widget" 1000 :standard)
+      (list "book" 800 :zero-rated))
+    (list (list "widget" :small -200))
+    (list (list "widget" :small 10) (list "book" :none 5))))
+
+(define
+  rules
+  (list
+    (list :uk :standard :guest 2000)
+    (list :uk :zero-rated :guest 0)))
+
+(define ctx (make-pricing-context cat rules :uk :guest))
+
+(define
+  ruleset
+  (list
+    (list :percent "TEN" :standard 1000)
+    (list :fixed "FIVE" 0 50)))
+
+;; widget :small x2 → unit 800, extended 1600 (standard); book x1 → 800 (zero-rated)
+(define
+  cart
+  (list (list "widget" :small 2) (list "book" :none 1)))
+
+;; 1. stock gating passes (widget:small 10 >= 2)
+(commerce-test "int-can-reserve" (can-reserve? cat cart) true)
+
+;; 2. quote ties the whole pricing pipeline together
+;;    subtotal 2400; discount TEN 160 + FIVE 50 = 210; tax 1600@20% = 320;
+;;    total 2400 - 210 + 320 = 2510
+(define q (cart-quote ctx cart ruleset (list)))
+(commerce-test "int-quote-subtotal" (quote-subtotal q) 2400)
+(commerce-test "int-quote-discount" (quote-discount q) 210)
+(commerce-test "int-quote-tax" (quote-tax q) 320)
+(commerce-test "int-quote-total" (quote-total q) 2510)
+
+;; 3. attribution explains where the discount landed
+(commerce-test
+  "int-attribution"
+  (codes-for-line ctx cart ruleset (list "widget" :small 2))
+  (list "TEN"))
+(commerce-test
+  "int-order-level"
+  (order-level-codes ctx cart ruleset)
+  (list "FIVE"))
+
+;; 4. order carries the quote total into the ledger; suspends at payment
+(define oid "INT-1")
+(define id (order-begin! env b oid 1000 q))
+(commerce-test "int-order-total-from-quote" (order-total b oid) 2510)
+(commerce-test "int-waiting-payment" (order-flow-waiting env id) "payment")
+
+;; 5. the payment envelope reflects the quoted total
+(commerce-test
+  "int-payment-envelope"
+  (payment-request b oid :GBP "https://shop/return")
+  {:order "INT-1" :amount 2510 :return-url "https://shop/return" :currency :GBP})
+
+;; 6. settle the quoted amount → reconciles exactly
+(commerce-test
+  "int-settled"
+  (order-settle! env b id oid "pay-int" 1002 2510)
+  :settled)
+(commerce-test "int-status-fulfilled" (order-status b oid) :fulfilled)
+(commerce-test "int-recon-ok" (order-recon b oid) :ok)
+
+;; 7. partial refund via its own flow → recon moves to underpaid
+(define rid (refund-begin! env b oid "rf-int" 2000 510))
+(commerce-test "int-refund-approve" (refund-approve! env rid) :approved)
+(commerce-test
+  "int-refund-settle"
+  (refund-settle! env b rid oid "rf-int" 2001 510)
+  :settled)
+(commerce-test
+  "int-refunded-amount"
+  (order-refunded-amount-of (order-events b oid))
+  510)
+(commerce-test "int-recon-after-refund" (order-recon b oid) :underpaid)
+
+;; 8. ledger reconciliation flags the now-mismatched order
+(commerce-test
+  "int-mismatch"
+  (mismatched-orders b)
+  (list (order-stream "INT-1")))
+
+;; 9. distinct flow ids for the order and the refund
+(commerce-test "int-distinct-flow-ids" (not (= id rid)) true)

lib/commerce/tests/ledger.sx

@@ -0,0 +1,80 @@
+;; lib/commerce/tests/ledger.sx — order ledger on persist + idempotent recon.
+;; Uses (commerce-test name got expected) provided by conformance.sh.
+
+(define q1 {:codes (list) :subtotal 1000 :discount 0 :total 1200 :tax 200})
+
+;; --- lifecycle status projection ---
+
+(define b1 (persist/mem-backend))
+(define _c1 (order-create b1 "A1" 100 q1))
+(commerce-test "status-pending" (order-status b1 "A1") :pending)
+(define _r1 (order-reserve b1 "A1" 101 {:lines 2}))
+(commerce-test "status-reserved" (order-status b1 "A1") :reserved)
+(define _p1 (order-pay b1 "A1" "ref-1" 102 1200))
+(commerce-test "status-paid" (order-status b1 "A1") :paid)
+(define _f1 (order-fulfil b1 "A1" 103 {:carrier "post"}))
+(commerce-test "status-fulfilled" (order-status b1 "A1") :fulfilled)
+
+(commerce-test "total-projection" (order-total b1 "A1") 1200)
+(commerce-test "paid-projection" (order-paid b1 "A1") 1200)
+(commerce-test "recon-ok" (order-recon b1 "A1") :ok)
+(commerce-test "event-count" (len (order-events b1 "A1")) 4)
+
+;; --- idempotency: replayed webhook does not double-record ---
+
+(define b2 (persist/mem-backend))
+(define _c2 (order-create b2 "B1" 200 q1))
+(define _p2a (order-pay b2 "B1" "sumup-9" 201 1200))
+(define _p2b (order-pay b2 "B1" "sumup-9" 201 1200))
+(define _p2c (order-pay b2 "B1" "sumup-9" 201 1200))
+
+(commerce-test "idem-single-event" (len (order-events b2 "B1")) 2)
+(commerce-test "idem-paid-once" (order-paid b2 "B1") 1200)
+(commerce-test "idem-recon-ok" (order-recon b2 "B1") :ok)
+(commerce-test "idem-same-event" (= _p2a _p2c) true)
+
+;; --- mismatch detection ---
+
+(define bun (persist/mem-backend))
+(define _cu (order-create bun "U1" 300 q1))
+(commerce-test "unpaid-recon" (order-recon bun "U1") :unpaid)
+
+(define bup (persist/mem-backend))
+(define _cp (order-create bup "U2" 300 q1))
+(define _pp1 (order-pay bup "U2" "r-a" 301 1200))
+(define _pp2 (order-pay bup "U2" "r-b" 302 1200))
+(commerce-test "double-charge-overpaid" (order-recon bup "U2") :overpaid)
+(commerce-test "double-charge-amount" (order-paid bup "U2") 2400)
+
+(define bsh (persist/mem-backend))
+(define _cs (order-create bsh "U3" 400 q1))
+(define _ps (order-pay bsh "U3" "r-short" 401 1000))
+(commerce-test "underpaid-recon" (order-recon bsh "U3") :underpaid)
+
+;; --- refund (idempotent) reduces net ---
+
+(define brf (persist/mem-backend))
+(define _crf (order-create brf "R1" 500 q1))
+(define _prf (order-pay brf "R1" "p-1" 501 1200))
+(define _rf1 (order-refund brf "R1" "rf-1" 502 200))
+(define _rf2 (order-refund brf "R1" "rf-1" 502 200))
+(commerce-test "refund-idem-net" (order-recon brf "R1") :underpaid)
+(commerce-test "refund-idem-events" (len (order-events brf "R1")) 3)
+
+;; --- cross-ledger reconciliation ---
+
+(define bL (persist/mem-backend))
+(define _l1 (order-create bL "OK1" 600 q1))
+(define _l1p (order-pay bL "OK1" "ok-ref" 601 1200))
+(define _l2 (order-create bL "OVER1" 600 q1))
+(define _l2a (order-pay bL "OVER1" "o-a" 602 1200))
+(define _l2b (order-pay bL "OVER1" "o-b" 603 1200))
+(define _l3 (order-create bL "UNDER1" 600 q1))
+(define _l3p (order-pay bL "UNDER1" "u-ref" 604 900))
+(define _l4 (order-create bL "PENDING1" 600 q1))
+
+(commerce-test "ledger-order-count" (len (order-ids bL)) 4)
+(commerce-test
+  "ledger-mismatches"
+  (sort (ledger-mismatches bL))
+  (sort (list (order-stream "OVER1") (order-stream "UNDER1"))))

lib/commerce/tests/nettax.sx

@@ -0,0 +1,92 @@
+;; lib/commerce/tests/nettax.sx — discount-aware (net) tax policy.
+;; Uses (commerce-test name got expected) provided by conformance.sh.
+
+(define
+  pcat
+  (make-catalog
+    (list
+      (list "widget" 1000 :standard)
+      (list "tea" 1000 :reduced))
+    (list)
+    (list)))
+
+(define
+  rules
+  (list
+    (list :uk :standard :guest 2000)
+    (list :uk :reduced :guest 500)))
+
+(define gctx (make-pricing-context pcat rules :uk :guest))
+
+;; widget x3 = 3000 (standard), tea x6 = 6000 (reduced); subtotal 9000
+(define
+  cart
+  (list (list "widget" :none 3) (list "tea" :none 6)))
+
+(define ruleset (list (list :percent "TEN" :standard 1000)))
+
+;; --- allocation: proportional, sums exactly to the discount ---
+
+(commerce-test
+  "allocate-even"
+  (allocate-discount pcat cart 300)
+  (list 100 200))
+(commerce-test
+  "allocate-sums-to-discount"
+  (ct-sum (allocate-discount pcat cart 300))
+  300)
+
+;; remainder distribution: 100 over (3000,6000)/9000 = (33,66) rem 1 -> (34,66)
+(commerce-test
+  "allocate-remainder"
+  (allocate-discount pcat cart 100)
+  (list 34 66))
+(commerce-test
+  "allocate-remainder-sums"
+  (ct-sum (allocate-discount pcat cart 100))
+  100)
+
+(commerce-test
+  "allocate-zero"
+  (allocate-discount pcat cart 0)
+  (list 0 0))
+(commerce-test
+  "allocate-empty"
+  (allocate-discount pcat empty-cart 0)
+  (list))
+
+;; --- net tax vs gross tax ---
+;; discount = TEN 10% of standard 3000 = 300, allocated (100 200).
+;; net: widget 2900@20%=580, tea 5800@5%=290 -> net tax 870 (gross was 900).
+
+(commerce-test
+  "net-quote"
+  (cart-quote-net gctx cart ruleset (list))
+  {:codes (list "TEN") :subtotal 9000 :discount 300 :total 9570 :tax 870})
+
+;; same cart through the gross policy taxes 900 (the documented default)
+(commerce-test
+  "gross-quote-for-contrast"
+  (quote-tax (cart-quote gctx cart ruleset (list)))
+  900)
+
+(commerce-test
+  "net-tax-lower"
+  (quote-tax (cart-quote-net gctx cart ruleset (list)))
+  870)
+
+;; --- no discount: net policy == gross policy ---
+
+(commerce-test
+  "no-discount-net-equals-gross"
+  (=
+    (cart-quote-net gctx cart (list) (list))
+    (cart-quote gctx cart (list) (list)))
+  true)
+
+;; --- empty cart ---
+
+(commerce-test
+  "net-empty"
+  (cart-quote-net gctx empty-cart ruleset (list))
+  {:codes (list) :subtotal 0 :discount 0 :total 0 :tax 0})

lib/commerce/tests/order.sx

@@ -0,0 +1,74 @@
+;; lib/commerce/tests/order.sx — order lifecycle as a flow-on-sx flow.
+;; Uses (commerce-test name got expected) provided by conformance.sh.
+;; Builds the (expensive) flow env once; all assertions share it.
+
+(define env (order-make-env))
+(define b (persist/mem-backend))
+(define q1 {:codes (list) :subtotal 1000 :discount 0 :total 1200 :tax 200})
+
+;; --- happy path: begin suspends at payment ---
+
+(define id1 (order-begin! env b "O1" 100 q1))
+
+(commerce-test "begin-status-reserved" (order-status b "O1") :reserved)
+(commerce-test "begin-waiting-payment" (order-flow-waiting env id1) "payment")
+(commerce-test "begin-not-yet-paid" (order-paid b "O1") 0)
+
+;; --- settle: payment webhook drives fulfilment ---
+
+(define s1 (order-settle! env b id1 "O1" "ref-1" 102 1200))
+
+(commerce-test "settle-result" s1 :settled)
+(commerce-test "settle-status-fulfilled" (order-status b "O1") :fulfilled)
+(commerce-test "settle-flow-done" (order-flow-status env id1) "done")
+(commerce-test "settle-recon-ok" (order-recon b "O1") :ok)
+(commerce-test "settle-event-count" (len (order-events b "O1")) 4)
+
+;; --- webhook replay: a second settle is a no-op ---
+
+(define s1b (order-settle! env b id1 "O1" "ref-1" 102 1200))
+
+(commerce-test "replay-already-settled" s1b :already-settled)
+(commerce-test
+  "replay-no-extra-events"
+  (len (order-events b "O1"))
+  4)
+(commerce-test "replay-recon-still-ok" (order-recon b "O1") :ok)
+
+;; --- a second order gets its own flow id and suspends independently ---
+
+(define id2 (order-begin! env b "O2" 200 q1))
+
+(commerce-test "second-distinct-id" (not (= id1 id2)) true)
+(commerce-test
+  "second-waiting-payment"
+  (order-flow-waiting env id2)
+  "payment")
+(commerce-test "first-unaffected" (order-status b "O1") :fulfilled)
+
+;; --- durability: a suspended order survives a process restart ---
+
+(define id3 (order-begin! env b "O3" 300 q1))
+(commerce-test "pre-restart-waiting" (order-flow-waiting env id3) "payment")
+
+(define _restart (order-flow-restart! env))
+
+(commerce-test
+  "post-restart-still-waiting"
+  (order-flow-waiting env id3)
+  "payment")
+(commerce-test "post-restart-ledger-intact" (order-status b "O3") :reserved)
+
+(define s3 (order-settle! env b id3 "O3" "ref-3" 302 1200))
+
+(commerce-test "post-restart-settled" s3 :settled)
+(commerce-test "post-restart-status" (order-status b "O3") :fulfilled)
+(commerce-test "post-restart-recon-ok" (order-recon b "O3") :ok)
+(commerce-test "post-restart-flow-done" (order-flow-status env id3) "done")
+
+;; --- payment-request envelope (provider-neutral) for the still-suspended O2 ---
+
+(commerce-test
+  "pending-payments-lists-suspended"
+  (pending-payments env b :GBP "https://shop/return")
+  (list {:id id2 :request {:order "O2" :amount 1200 :return-url "https://shop/return" :currency :GBP}}))

lib/commerce/tests/payment.sx

@@ -0,0 +1,43 @@
+;; lib/commerce/tests/payment.sx — provider-neutral payment-request envelope.
+;; Uses (commerce-test name got expected) provided by conformance.sh.
+;; Envelope construction is ledger-only (no flow env); pending-payments (which
+;; needs the flow env) is exercised in the order suite.
+
+(define q1 {:codes (list) :subtotal 1000 :discount 0 :total 1200 :tax 200})
+(define q2 {:codes (list) :subtotal 5000 :discount 500 :total 4500 :tax 0})
+
+(define b (persist/mem-backend))
+(define _c1 (order-create b "P1" 1 q1))
+(define _c2 (order-create b "P2" 1 q2))
+
+(commerce-test
+  "envelope"
+  (payment-request b "P1" :GBP "https://shop/return")
+  {:order "P1" :amount 1200 :return-url "https://shop/return" :currency :GBP})
+
+(commerce-test
+  "envelope-amount"
+  (payment-request-amount (payment-request b "P1" :GBP "x"))
+  1200)
+(commerce-test
+  "envelope-currency"
+  (payment-request-currency (payment-request b "P1" :GBP "x"))
+  :GBP)
+(commerce-test
+  "envelope-order"
+  (payment-request-order (payment-request b "P1" :GBP "x"))
+  "P1")
+(commerce-test
+  "envelope-return-url"
+  (payment-request-return-url (payment-request b "P1" :GBP "https://r"))
+  "https://r")
+
+;; amount tracks the ledger total, currency is per-call (provider/instance config)
+(commerce-test
+  "envelope-amount-2"
+  (payment-request-amount (payment-request b "P2" :EUR "x"))
+  4500)
+(commerce-test
+  "envelope-currency-2"
+  (payment-request-currency (payment-request b "P2" :EUR "x"))
+  :EUR)

lib/commerce/tests/price.sx

@@ -0,0 +1,100 @@
+;; lib/commerce/tests/price.sx — subtotal + jurisdiction-relational tax.
+;; Uses (commerce-test name got expected) provided by conformance.sh.
+
+(define
+  pcat
+  (make-catalog
+    (list
+      (list "widget" 1000 :standard)
+      (list "book" 800 :zero-rated)
+      (list "tea" 1000 :reduced))
+    (list
+      (list "widget" :small -200)
+      (list "widget" :large 500))
+    (list)))
+
+(define
+  rules
+  (list
+    (list :uk :standard :guest 2000)
+    (list :uk :reduced :guest 500)
+    (list :uk :zero-rated :guest 0)
+    (list :uk :standard :member 1000)
+    (list :ie :standard :guest 2300)))
+
+(define gctx (make-pricing-context pcat rules :uk :guest))
+(define mctx (make-pricing-context pcat rules :uk :member))
+
+;; --- unit + line pricing ---
+
+(commerce-test
+  "unit-price-variant"
+  (line-unit-price pcat "widget" :small)
+  800)
+(commerce-test
+  "unit-price-no-variant"
+  (line-unit-price pcat "widget" :none)
+  1000)
+(commerce-test "unit-price-unknown" (line-unit-price pcat "ghost" :none) nil)
+(commerce-test
+  "line-extended"
+  (line-extended pcat (list "widget" :small 2))
+  1600)
+
+;; --- subtotal ---
+
+(define
+  cart1
+  (list (list "widget" :small 2) (list "book" :none 1)))
+
+(commerce-test "subtotal" (cart-subtotal pcat cart1) 2400)
+(commerce-test "subtotal-empty" (cart-subtotal pcat empty-cart) 0)
+
+;; --- tax rate lookup (relational, both directions) ---
+
+(commerce-test
+  "rate-forward"
+  (rate-bps rules :uk :standard :guest)
+  2000)
+(commerce-test
+  "rate-missing"
+  (rate-bps rules :fr :standard :guest)
+  0)
+(commerce-test
+  "rate-juris-by-bps-backward"
+  (run* j (fresh (cust) (taxo rules j :standard cust 2300)))
+  (list :ie))
+(commerce-test
+  "rate-customer-by-bps-backward"
+  (run* cust (taxo rules :uk :standard cust 1000))
+  (list :member))
+
+;; --- apply-bps rounding (half up, integer only) ---
+
+(commerce-test "bps-exact" (apply-bps 1600 2000) 320)
+(commerce-test "bps-round-up" (apply-bps 799 2000) 160)
+(commerce-test "bps-zero" (apply-bps 800 0) 0)
+
+;; --- line + cart tax ---
+
+(commerce-test
+  "line-tax-standard"
+  (line-tax gctx (list "widget" :small 2))
+  320)
+(commerce-test
+  "line-tax-zero-rated"
+  (line-tax gctx (list "book" :none 1))
+  0)
+(commerce-test
+  "line-tax-member"
+  (line-tax mctx (list "widget" :small 2))
+  160)
+(commerce-test "cart-tax-guest" (cart-tax gctx cart1) 320)
+
+;; --- total dict (deterministic) ---
+
+(commerce-test "total-guest" (cart-total gctx cart1) {:subtotal 2400 :discounts 0 :total 2720 :tax 320})
+
+(commerce-test "total-member" (cart-total mctx cart1) {:subtotal 2400 :discounts 0 :total 2560 :tax 160})
+
+(commerce-test "total-empty" (cart-total gctx empty-cart) {:subtotal 0 :discounts 0 :total 0 :tax 0})

lib/commerce/tests/promo.sx

@@ -0,0 +1,142 @@
+;; lib/commerce/tests/promo.sx — promo rules + relational enumeration.
+;; Uses (commerce-test name got expected) provided by conformance.sh.
+
+(define
+  pcat
+  (make-catalog
+    (list
+      (list "widget" 1000 :standard)
+      (list "book" 800 :zero-rated)
+      (list "tea" 1000 :reduced))
+    (list)
+    (list)))
+
+(define gctx (make-pricing-context pcat (list) :uk :guest))
+(define mctx (make-pricing-context pcat (list) :uk :member))
+
+(define
+  cart
+  (list
+    (list "widget" :none 3)
+    (list "book" :none 1)
+    (list "tea" :none 6)))
+
+(define
+  ruleset
+  (list
+    (list :percent "TEN" :standard 1000)
+    (list :fixed "FIVER" 5000 500)
+    (list :bundle "B3T" "tea" 3)
+    (list :member "MEM" :standard 1500)))
+
+;; --- per-type amounts ---
+
+(commerce-test
+  "percent-amount"
+  (promo-amount gctx cart (list :percent "TEN" :standard 1000))
+  300)
+
+(commerce-test
+  "fixed-amount-met"
+  (promo-amount gctx cart (list :fixed "FIVER" 5000 500))
+  500)
+
+(commerce-test
+  "fixed-amount-not-met"
+  (promo-amount
+    gctx
+    (list (list "widget" :none 1))
+    (list :fixed "FIVER" 5000 500))
+  0)
+
+(commerce-test
+  "fixed-amount-capped"
+  (promo-amount
+    gctx
+    (list (list "book" :none 1))
+    (list :fixed "BIG" 0 9999))
+  800)
+
+(commerce-test
+  "bundle-amount"
+  (promo-amount gctx cart (list :bundle "B3T" "tea" 3))
+  2000)
+
+(commerce-test
+  "member-amount-guest"
+  (promo-amount gctx cart (list :member "MEM" :standard 1500))
+  0)
+
+(commerce-test
+  "member-amount-member"
+  (promo-amount mctx cart (list :member "MEM" :standard 1500))
+  450)
+
+;; --- relational enumeration: forward ---
+
+(commerce-test
+  "discounto-all-guest"
+  (run*
+    pair
+    (fresh
+      (code amount)
+      (promo-discounto gctx cart ruleset code amount)
+      (== pair (list code amount))))
+  (list
+    (list "TEN" 300)
+    (list "FIVER" 500)
+    (list "B3T" 2000)
+    (list "MEM" 0)))
+
+(commerce-test
+  "applicable-guest"
+  (applicable-promos gctx cart ruleset)
+  (list
+    (list "TEN" 300)
+    (list "FIVER" 500)
+    (list "B3T" 2000)))
+
+(commerce-test
+  "applicable-member"
+  (applicable-promos mctx cart ruleset)
+  (list
+    (list "TEN" 300)
+    (list "FIVER" 500)
+    (list "B3T" 2000)
+    (list "MEM" 450)))
+
+;; --- relational enumeration: backward (the showcase) ---
+
+(commerce-test
+  "code-by-discount-2000"
+  (run* code (promo-applieso gctx cart ruleset code 2000))
+  (list "B3T"))
+
+(commerce-test
+  "code-by-discount-500"
+  (run* code (promo-applieso gctx cart ruleset code 500))
+  (list "FIVER"))
+
+(commerce-test
+  "code-by-discount-none"
+  (run* code (promo-applieso gctx cart ruleset code 9999))
+  (list))
+
+;; --- deterministic helpers ---
+
+(commerce-test
+  "amount-for-ten"
+  (promo-amount-for gctx cart ruleset "TEN")
+  300)
+(commerce-test
+  "amount-for-mem-guest"
+  (promo-amount-for gctx cart ruleset "MEM")
+  0)
+(commerce-test
+  "amount-for-mem-member"
+  (promo-amount-for mctx cart ruleset "MEM")
+  450)
+(commerce-test
+  "amount-for-absent"
+  (promo-amount-for gctx cart ruleset "NOPE")
+  0)

lib/commerce/tests/quote.sx

@@ -0,0 +1,108 @@
+;; lib/commerce/tests/quote.sx — composed priced quote (price+promo+stacking).
+;; Uses (commerce-test name got expected) provided by conformance.sh.
+
+(define
+  pcat
+  (make-catalog
+    (list
+      (list "widget" 1000 :standard)
+      (list "book" 800 :zero-rated)
+      (list "tea" 1000 :reduced))
+    (list)
+    (list)))
+
+(define
+  tax-rules
+  (list
+    (list :uk :standard :guest 2000)
+    (list :uk :reduced :guest 500)
+    (list :uk :zero-rated :guest 0)
+    (list :uk :standard :member 2000)
+    (list :uk :reduced :member 500)
+    (list :uk :zero-rated :member 0)))
+
+(define gctx (make-pricing-context pcat tax-rules :uk :guest))
+(define mctx (make-pricing-context pcat tax-rules :uk :member))
+
+(define
+  cart
+  (list
+    (list "widget" :none 3)
+    (list "book" :none 1)
+    (list "tea" :none 6)))
+
+(define
+  ruleset
+  (list
+    (list :percent "TEN" :standard 1000)
+    (list :percent "TWENTY" :standard 2000)
+    (list :fixed "FIVER" 5000 500)
+    (list :bundle "B3T" "tea" 3)
+    (list :member "MEM" :standard 2500)))
+
+(define
+  exclusions
+  (list (list "TEN" "TWENTY") (list "TEN" "MEM") (list "TWENTY" "MEM")))
+
+;; subtotal: 3000 + 800 + 6000 = 9800
+;; tax (gross): widget 600 + tea 300 + book 0 = 900
+;; guest discount: TWENTY 600 + FIVER 500 + B3T 2000 = 3100
+;; guest total: 9800 - 3100 + 900 = 7600
+
+(define gq (cart-quote gctx cart ruleset exclusions))
+
+(commerce-test "quote-subtotal" (quote-subtotal gq) 9800)
+(commerce-test "quote-tax" (quote-tax gq) 900)
+(commerce-test "quote-discount-guest" (quote-discount gq) 3100)
+(commerce-test "quote-total-guest" (quote-total gq) 7600)
+(commerce-test
+  "quote-codes-guest"
+  (quote-codes gq)
+  (list "TWENTY" "FIVER" "B3T"))
+
+(commerce-test "quote-full-guest" gq {:codes (list "TWENTY" "FIVER" "B3T") :subtotal 9800 :discount 3100 :total 7600 :tax 900})
+
+;; member discount: MEM 750 + FIVER 500 + B3T 2000 = 3250
+;; member total: 9800 - 3250 + 900 = 7450
+(define mq (cart-quote mctx cart ruleset exclusions))
+
+(commerce-test "quote-discount-member" (quote-discount mq) 3250)
+(commerce-test "quote-total-member" (quote-total mq) 7450)
+(commerce-test
+  "quote-codes-member"
+  (quote-codes mq)
+  (list "FIVER" "B3T" "MEM"))
+
+;; --- determinism: same inputs, identical quote ---
+
+(commerce-test
+  "quote-deterministic"
+  (=
+    (cart-quote gctx cart ruleset exclusions)
+    (cart-quote gctx cart ruleset exclusions))
+  true)
+
+;; --- no promos: discount 0, total = subtotal + tax ---
+
+(commerce-test
+  "quote-no-promos"
+  (cart-quote gctx cart (list) (list))
+  {:codes (list) :subtotal 9800 :discount 0 :total 10700 :tax 900})
+
+;; --- empty cart ---
+
+(commerce-test
+  "quote-empty"
+  (cart-quote gctx empty-cart ruleset exclusions)
+  {:codes (list) :subtotal 0 :discount 0 :total 0 :tax 0})
+
+;; --- session convenience ---
+
+(define
+  sess
+  (commerce-add (commerce-session gctx) "widget" :none 3))
+
+(commerce-test
+  "session-quote"
+  (quote-total (session-quote sess ruleset exclusions))
+  3000)

lib/commerce/tests/recon.sx

@@ -0,0 +1,109 @@
+;; lib/commerce/tests/recon.sx — reconciliation as relational ledger queries.
+;; Uses (commerce-test name got expected) provided by conformance.sh.
+
+(define q1 {:codes (list) :subtotal 1000 :discount 0 :total 1200 :tax 200})
+
+(define b (persist/mem-backend))
+
+;; OK1 — clean payment
+(define _ok (order-create b "OK1" 1 q1))
+(define _okp (order-pay b "OK1" "ok-ref" 2 1200))
+
+;; OVER1 — double charge under two different refs
+(define _ov (order-create b "OVER1" 1 q1))
+(define _ova (order-pay b "OVER1" "ov-a" 2 1200))
+(define _ovb (order-pay b "OVER1" "ov-b" 3 1200))
+
+;; UNDER1 — short payment
+(define _un (order-create b "UNDER1" 1 q1))
+(define _unp (order-pay b "UNDER1" "un-ref" 2 900))
+
+;; PART1 — paid in full, then partially refunded
+(define _pa (order-create b "PART1" 1 q1))
+(define _pap (order-pay b "PART1" "pa-ref" 2 1200))
+(define _par (order-refund b "PART1" "pa-rf" 3 200))
+
+;; REPLAY1 — webhook fires twice with the same ref (idempotent)
+(define _rp (order-create b "REPLAY1" 1 q1))
+(define _rpa (order-pay b "REPLAY1" "rp-ref" 2 1200))
+(define _rpb (order-pay b "REPLAY1" "rp-ref" 2 1200))
+
+;; PEND1 — created, not yet paid
+(define _pe (order-create b "PEND1" 1 q1))
+
+;; --- summaries ---
+
+(commerce-test "summary-count" (len (ledger-summaries b)) 6)
+(commerce-test
+  "summary-ok1"
+  (order-summary b "order/OK1")
+  (list "order/OK1" 1200 1200 0 1200 :ok))
+(commerce-test
+  "summary-part1"
+  (order-summary b "order/PART1")
+  (list "order/PART1" 1200 1200 200 1000 :underpaid))
+
+;; --- forward status query ---
+
+(commerce-test
+  "status-forward-ok"
+  (run* st (recon-statuso (ledger-summaries b) "order/OK1" st))
+  (list :ok))
+
+;; --- backward status queries (the showcase) ---
+
+(commerce-test
+  "settled"
+  (sort (settled-orders b))
+  (sort (list "order/OK1" "order/REPLAY1")))
+(commerce-test "overpaid" (overpaid-orders b) (list "order/OVER1"))
+(commerce-test
+  "underpaid"
+  (sort (underpaid-orders b))
+  (sort (list "order/UNDER1" "order/PART1")))
+(commerce-test "unpaid" (unpaid-orders b) (list "order/PEND1"))
+(commerce-test
+  "mismatched"
+  (sort (mismatched-orders b))
+  (sort (list "order/OVER1" "order/UNDER1" "order/PART1")))
+
+;; --- backward net-amount query ---
+
+(commerce-test
+  "net-1200"
+  (sort (orders-with-net b 1200))
+  (sort (list "order/OK1" "order/REPLAY1")))
+(commerce-test
+  "net-2400"
+  (orders-with-net b 2400)
+  (list "order/OVER1"))
+(commerce-test
+  "net-900"
+  (orders-with-net b 900)
+  (list "order/UNDER1"))
+
+;; --- discrepancy: +1200 (over) - 300 (under) - 200 (refund) = 700 ---
+
+(commerce-test "discrepancy" (ledger-discrepancy b) 700)
+
+;; --- double-charge guard ---
+
+(commerce-test "double-charge-detected" (order-recon b "OVER1") :overpaid)
+(commerce-test "double-charge-amount" (order-paid b "OVER1") 2400)
+
+;; --- partial refund ---
+
+(commerce-test "partial-refund-net" (order-recon b "PART1") :underpaid)
+(commerce-test
+  "partial-refund-amount"
+  (order-refunded-amount-of (order-events b "PART1"))
+  200)
+
+;; --- webhook replay: same ref twice records once ---
+
+(commerce-test
+  "replay-single-event"
+  (len (order-events b "REPLAY1"))
+  2)
+(commerce-test "replay-paid-once" (order-paid b "REPLAY1") 1200)
+(commerce-test "replay-settled" (order-recon b "REPLAY1") :ok)

lib/commerce/tests/refund.sx

@@ -0,0 +1,78 @@
+;; lib/commerce/tests/refund.sx — refund lifecycle as a flow-on-sx flow.
+;; Uses (commerce-test name got expected) provided by conformance.sh.
+;; Builds the (expensive) flow env once; all assertions share it.
+
+(define env (refund-make-env))
+(define b (persist/mem-backend))
+(define q1 {:codes (list) :subtotal 1000 :discount 0 :total 1200 :tax 200})
+
+;; a paid, fulfilled order to refund (set up directly via the ledger)
+(define _c (order-create b "O1" 1 q1))
+(define _p (order-pay b "O1" "pay-1" 2 1200))
+(commerce-test "setup-recon-ok" (order-recon b "O1") :ok)
+
+;; --- happy path: request -> approve -> settle ---
+
+(define rid (refund-begin! env b "O1" "rf-1" 10 500))
+
+(commerce-test "begin-waiting-approve" (order-flow-waiting env rid) "approve")
+(commerce-test
+  "begin-not-yet-refunded"
+  (order-refunded-amount-of (order-events b "O1"))
+  0)
+(commerce-test "begin-recon-unchanged" (order-recon b "O1") :ok)
+
+(define a1 (refund-approve! env rid))
+(commerce-test "approve-result" a1 :approved)
+(commerce-test "approve-waiting-settle" (order-flow-waiting env rid) "settle")
+
+(define s1 (refund-settle! env b rid "O1" "rf-1" 11 500))
+(commerce-test "settle-result" s1 :settled)
+(commerce-test "settle-flow-done" (order-flow-status env rid) "done")
+(commerce-test
+  "settle-refunded-amount"
+  (order-refunded-amount-of (order-events b "O1"))
+  500)
+;; net 1200 - 500 = 700 < total 1200 -> underpaid (partial refund)
+(commerce-test "settle-recon-underpaid" (order-recon b "O1") :underpaid)
+
+;; --- idempotent settle: replayed provider callback is a no-op ---
+
+(define s1b (refund-settle! env b rid "O1" "rf-1" 11 500))
+(commerce-test "replay-already-settled" s1b :already-settled)
+(commerce-test
+  "replay-refunded-once"
+  (order-refunded-amount-of (order-events b "O1"))
+  500)
+
+;; --- reject path: approval denied, books untouched ---
+
+(define _c2 (order-create b "O2" 1 q1))
+(define _p2 (order-pay b "O2" "pay-2" 2 1200))
+
+(define rid2 (refund-begin! env b "O2" "rf-2" 20 1200))
+(commerce-test
+  "reject-waiting-approve"
+  (order-flow-waiting env rid2)
+  "approve")
+
+(define j2 (refund-reject! env b "O2" rid2 21 "policy"))
+(commerce-test "reject-result" j2 :rejected)
+(commerce-test "reject-flow-not-waiting" (order-flow-waiting env rid2) nil)
+(commerce-test
+  "reject-no-refund"
+  (order-refunded-amount-of (order-events b "O2"))
+  0)
+(commerce-test "reject-recon-ok" (order-recon b "O2") :ok)
+
+;; settling a rejected/cancelled refund does nothing
+(define s2 (refund-settle! env b rid2 "O2" "rf-2" 22 1200))
+(commerce-test "reject-then-settle-noop" s2 :already-settled)
+(commerce-test
+  "reject-still-no-refund"
+  (order-refunded-amount-of (order-events b "O2"))
+  0)
+
+;; --- distinct flow ids ---
+
+(commerce-test "distinct-refund-ids" (not (= rid rid2)) true)

lib/commerce/tests/stack.sx

@@ -0,0 +1,127 @@
+;; lib/commerce/tests/stack.sx — stacking precedence, exclusivity, best price.
+;; Uses (commerce-test name got expected) provided by conformance.sh.
+
+(define
+  pcat
+  (make-catalog
+    (list
+      (list "widget" 1000 :standard)
+      (list "book" 800 :zero-rated)
+      (list "tea" 1000 :reduced))
+    (list)
+    (list)))
+
+(define gctx (make-pricing-context pcat (list) :uk :guest))
+(define mctx (make-pricing-context pcat (list) :uk :member))
+
+(define
+  cart
+  (list
+    (list "widget" :none 3)
+    (list "book" :none 1)
+    (list "tea" :none 6)))
+
+(define
+  ruleset
+  (list
+    (list :percent "TEN" :standard 1000)
+    (list :percent "TWENTY" :standard 2000)
+    (list :fixed "FIVER" 5000 500)
+    (list :bundle "B3T" "tea" 3)
+    (list :member "MEM" :standard 2500)))
+
+;; The three standard-class discounts are mutually exclusive.
+(define
+  exclusions
+  (list (list "TEN" "TWENTY") (list "TEN" "MEM") (list "TWENTY" "MEM")))
+
+;; --- exclusivity predicates ---
+
+(commerce-test
+  "excluded-pair-direct"
+  (excluded-pair? exclusions "TEN" "TWENTY")
+  true)
+(commerce-test
+  "excluded-pair-symmetric"
+  (excluded-pair? exclusions "TWENTY" "TEN")
+  true)
+(commerce-test
+  "excluded-pair-none"
+  (excluded-pair? exclusions "TEN" "FIVER")
+  false)
+(commerce-test
+  "compatible-yes"
+  (compatible? exclusions (list "FIVER" "B3T" "TWENTY"))
+  true)
+(commerce-test
+  "compatible-no"
+  (compatible? exclusions (list "TEN" "TWENTY" "B3T"))
+  false)
+
+;; --- powerset + valid stackings ---
+
+(commerce-test
+  "powerset-size"
+  (len (powerset (list 1 2 3 4)))
+  16)
+
+(define gappl (applicable-promos gctx cart ruleset))
+
+(commerce-test "applicable-guest-count" (len gappl) 4)
+
+;; 16 subsets minus the 4 containing both TEN and TWENTY = 12 legal.
+(commerce-test
+  "valid-stackings-count"
+  (len (valid-stackings exclusions gappl))
+  12)
+
+(commerce-test
+  "stacking-total"
+  (stacking-total (list (list "TWENTY" 600) (list "B3T" 2000)))
+  2600)
+
+;; --- best price (deterministic selection) ---
+
+(commerce-test
+  "best-discount-guest"
+  (best-promo-discount gctx cart ruleset exclusions)
+  3100)
+(commerce-test
+  "best-codes-guest"
+  (best-promo-codes gctx cart ruleset exclusions)
+  (list "TWENTY" "FIVER" "B3T"))
+
+;; exclusivity holds: the cheaper conflicting code is dropped.
+(commerce-test
+  "best-excludes-ten"
+  (some
+    (fn (c) (= c "TEN"))
+    (best-promo-codes gctx cart ruleset exclusions))
+  false)
+
+;; --- member vs guest ---
+
+(commerce-test
+  "best-discount-member"
+  (best-promo-discount mctx cart ruleset exclusions)
+  3250)
+(commerce-test
+  "best-codes-member"
+  (best-promo-codes mctx cart ruleset exclusions)
+  (list "FIVER" "B3T" "MEM"))
+
+;; --- best price backward query (the showcase) ---
+
+(commerce-test
+  "stacking-by-total-backward"
+  (run*
+    codes
+    (stacking-by-totalo (valid-stackings exclusions gappl) codes 3100))
+  (list (list "TWENTY" "FIVER" "B3T")))
+
+;; --- edge: no applicable promos ---
+
+(commerce-test
+  "best-empty"
+  (best-promo-discount gctx empty-cart ruleset exclusions)
+  0)

lib/commerce/tests/stock.sx

@@ -0,0 +1,122 @@
+;; lib/commerce/tests/stock.sx — stock-constrained reservation.
+;; Uses (commerce-test name got expected) provided by conformance.sh.
+
+(define
+  cat
+  (make-catalog
+    (list
+      (list "widget" 1000 :standard)
+      (list "gadget" 2500 :standard))
+    (list)
+    (list
+      (list "widget" :small 5)
+      (list "widget" :large 0)
+      (list "gadget" :std 12))))
+
+;; --- availability ---
+
+(commerce-test
+  "available-found"
+  (available-stock cat "widget" :small)
+  5)
+(commerce-test
+  "available-zero"
+  (available-stock cat "widget" :large)
+  0)
+(commerce-test
+  "available-absent"
+  (available-stock cat "widget" :none)
+  0)
+
+;; --- per-line reservability ---
+
+(commerce-test
+  "shortfall-fits"
+  (line-shortfall cat (list "widget" :small 5))
+  0)
+(commerce-test
+  "shortfall-over"
+  (line-shortfall cat (list "widget" :small 8))
+  3)
+(commerce-test
+  "reservable-yes"
+  (line-reservable? cat (list "gadget" :std 12))
+  true)
+(commerce-test
+  "reservable-no"
+  (line-reservable? cat (list "widget" :large 1))
+  false)
+
+;; --- cart-level reservation check ---
+
+(commerce-test
+  "can-reserve-yes"
+  (can-reserve?
+    cat
+    (list (list "widget" :small 5) (list "gadget" :std 2)))
+  true)
+
+(commerce-test
+  "can-reserve-no"
+  (can-reserve? cat (list (list "widget" :small 9)))
+  false)
+
+(commerce-test
+  "shortfalls-detail"
+  (reservation-shortfalls
+    cat
+    (list (list "widget" :small 9) (list "gadget" :std 2)))
+  (list {:requested 9 :available 5 :sku "widget" :variant :small :short 4}))
+
+(commerce-test
+  "reserve-check-ok"
+  (reserve-check cat (list (list "gadget" :std 1)))
+  :ok)
+
+(commerce-test
+  "reserve-check-rejected"
+  (reserve-check cat (list (list "widget" :large 1)))
+  {:shortfalls (list {:requested 1 :available 0 :sku "widget" :variant :large :short 1}) :rejected :insufficient-stock})
+
+;; --- reservation view: concurrent holds reduce availability ---
+
+(define held (list (list "widget" :small 3)))
+
+(commerce-test
+  "effective-after-hold"
+  (effective-available cat held "widget" :small)
+  2)
+(commerce-test
+  "effective-other-unaffected"
+  (effective-available cat held "gadget" :std)
+  12)
+(commerce-test
+  "reservable-with-fits"
+  (line-reservable-with? cat held (list "widget" :small 2))
+  true)
+(commerce-test
+  "reservable-with-over"
+  (line-reservable-with? cat held (list "widget" :small 3))
+  false)
+
+;; --- relational availability query (multidirectional) ---
+
+(commerce-test
+  "sufficient-forward"
+  (run*
+    x
+    (fresh () (sufficient-stocko cat "widget" :small 5) (== x true)))
+  (list true))
+
+(commerce-test
+  "sufficient-forward-over"
+  (run*
+    x
+    (fresh () (sufficient-stocko cat "widget" :small 6) (== x true)))
+  (list))
+
+;; backward: which variants of widget can supply 1 unit?
+(commerce-test
+  "variants-supplying-1"
+  (run* v (fresh (q) (stocko cat "widget" v q) (lteo-i 1 q)))
+  (list :small))

lib/commerce/tests/window.sx

@@ -0,0 +1,112 @@
+;; lib/commerce/tests/window.sx — time-windowed promotions.
+;; Uses (commerce-test name got expected) provided by conformance.sh.
+
+(define
+  pcat
+  (make-catalog (list (list "widget" 1000 :standard)) (list) (list)))
+
+(define gctx (make-pricing-context pcat (list) :uk :guest))
+(define cart (list (list "widget" :none 3)))
+
+(define ten (list :percent "TEN" :standard 1000))
+(define twenty (list :percent "TWENTY" :standard 2000))
+(define always (list :fixed "ALWAYS" 0 100))
+
+(define
+  windowed
+  (list
+    (windowed-promo ten 100 200)
+    (windowed-promo twenty 150 300)
+    (windowed-promo always nil nil)))
+
+(define exclusions (list (list "TEN" "TWENTY")))
+
+;; --- wp-active? boundaries (inclusive) ---
+
+(commerce-test
+  "active-at-from"
+  (wp-active? (windowed-promo ten 100 200) 100)
+  true)
+(commerce-test
+  "active-at-until"
+  (wp-active? (windowed-promo ten 100 200) 200)
+  true)
+(commerce-test
+  "inactive-before"
+  (wp-active? (windowed-promo ten 100 200) 99)
+  false)
+(commerce-test
+  "inactive-after"
+  (wp-active? (windowed-promo ten 100 200) 201)
+  false)
+(commerce-test
+  "open-ended-always"
+  (wp-active? (windowed-promo always nil nil) 99999)
+  true)
+(commerce-test
+  "open-lower"
+  (wp-active? (windowed-promo ten nil 200) 1)
+  true)
+(commerce-test
+  "open-upper"
+  (wp-active? (windowed-promo ten 100 nil) 99999)
+  true)
+
+;; --- active-ruleset filtering ---
+
+(commerce-test
+  "active-ruleset-120"
+  (active-ruleset windowed 120)
+  (list ten always))
+(commerce-test
+  "active-ruleset-160"
+  (active-ruleset windowed 160)
+  (list ten twenty always))
+(commerce-test
+  "active-ruleset-250"
+  (active-ruleset windowed 250)
+  (list twenty always))
+(commerce-test
+  "active-ruleset-50"
+  (active-ruleset windowed 50)
+  (list always))
+
+;; --- active-codes (backward query) ---
+
+(commerce-test
+  "active-codes-120"
+  (active-codes windowed 120)
+  (list "TEN" "ALWAYS"))
+(commerce-test
+  "active-codes-160"
+  (active-codes windowed 160)
+  (list "TEN" "TWENTY" "ALWAYS"))
+(commerce-test
+  "active-codes-50"
+  (active-codes windowed 50)
+  (list "ALWAYS"))
+
+;; --- windowed-quote: discount changes with time (deterministic) ---
+;; subtotal 3000, no tax. TEN=300, TWENTY=600, ALWAYS=100; TEN/TWENTY exclusive.
+
+(commerce-test
+  "quote-50"
+  (quote-discount (windowed-quote gctx cart windowed exclusions 50))
+  100)
+(commerce-test
+  "quote-120"
+  (quote-discount (windowed-quote gctx cart windowed exclusions 120))
+  400)
+(commerce-test
+  "quote-160"
+  (quote-discount (windowed-quote gctx cart windowed exclusions 160))
+  700)
+(commerce-test
+  "quote-250"
+  (quote-discount (windowed-quote gctx cart windowed exclusions 250))
+  700)
+
+(commerce-test
+  "quote-total-160"
+  (quote-total (windowed-quote gctx cart windowed exclusions 160))
+  2300)

lib/commerce/window.sx

@@ -0,0 +1,55 @@
+;; lib/commerce/window.sx — time-windowed promotions.
+;;
+;; A promo's validity window is kept SEPARATE from the promo tuple (so promo.sx
+;; is untouched): a windowed promo is (list promo from until) with inclusive
+;; integer timestamps (same time model as the ledger `at`). nil from = no lower
+;; bound; nil until = open-ended.
+;;
+;; `active-ruleset` filters a windowed ruleset to the plain promos live at a
+;; given time, which feeds straight into promo/stack/quote — so a datetime-aware
+;; quote is just the existing pipeline over the active set. Deterministic: the
+;; quote is a pure function of (ctx, cart, windowed-ruleset, exclusions, at).
+
+(define windowed-promo (fn (promo from until) (list promo from until)))
+
+(define wp-promo (fn (wp) (nth wp 0)))
+(define wp-from (fn (wp) (nth wp 1)))
+(define wp-until (fn (wp) (nth wp 2)))
+
+(define
+  wp-active?
+  (fn
+    (wp at)
+    (let
+      ((from (wp-from wp)) (until (wp-until wp)))
+      (and (or (nil? from) (>= at from)) (or (nil? until) (<= at until))))))
+
+;; Plain promo tuples live at time `at` — feed into cart-quote / best-promo-*.
+(define
+  active-ruleset
+  (fn
+    (windowed at)
+    (map wp-promo (filter (fn (wp) (wp-active? wp at)) windowed))))
+
+;; Relation: which promo codes are active at `at`? (backward query)
+(define
+  active-promoo
+  (fn
+    (windowed at code)
+    (fresh
+      (wp)
+      (membero wp windowed)
+      (project
+        (wp)
+        (if (wp-active? wp at) (== code (promo-code (wp-promo wp))) fail)))))
+
+(define
+  active-codes
+  (fn (windowed at) (run* code (active-promoo windowed at code))))
+
+;; Datetime-aware quote: the existing pipeline over the time-active ruleset.
+(define
+  windowed-quote
+  (fn
+    (ctx cart windowed exclusions at)
+    (cart-quote ctx cart (active-ruleset windowed at) exclusions)))

lib/content/api.sx

@@ -25,8 +25,13 @@
 (define content/append doc-append)
 (define content/blocks doc-blocks)
 (define content/count doc-count)
-(define content/find doc-find)
-(define content/has? doc-has?)
+;; find / has? are TREE-WIDE by id (descend into sections) — so the facade reads
+;; back any block content/edit can update or delete. content/find-top / has-top?
+;; keep the top-level-only lookup for callers that mean the ordered sequence.
+(define content/find doc-find-deep)
+(define content/has? doc-has-deep?)
+(define content/find-top doc-find)
+(define content/has-top? doc-has?)
 (define content/ids doc-ids)
 (define content/types doc-types)
 

lib/content/doc.sx

@@ -5,14 +5,19 @@
 ;; and returns a NEW document — the input is never mutated, so any version is the
 ;; head of an op stream (replay-friendly for persist + CRDT merge).
 ;;
-;; CtDoc also carries optional metadata (title/slug/tags) — see meta.sx for the
-;; ergonomic API; they default nil and do not affect block operations.
+;; By-id ops (update/delete) and by-id lookup (doc-find-deep/doc-has-deep?) are
+;; TREE-WIDE: they descend into any block carrying a `children` list (i.e.
+;; sections), since ids are unique across the tree. This keeps the persist
+;; op-log, content/edit and content/find correct for nested documents.
+;; insert/move are positional and act at the top level.
+;;
+;; CtDoc also carries optional metadata (title/slug/tags) — see meta.sx.
 ;;
 ;; Op shapes (data, not objects — they are the persist event payload):
-;;   {:op "insert" :block <blk> :after <id|nil>}   ; after nil = prepend
-;;   {:op "update" :id <id> :field <name> :value <v>}
-;;   {:op "move"   :id <id> :index <n>}
-;;   {:op "delete" :id <id>}
+;;   {:op "insert" :block <blk> :after <id|nil>}   ; after nil = prepend (top level)
+;;   {:op "update" :id <id> :field <name> :value <v>}   ; tree-wide by id
+;;   {:op "move"   :id <id> :index <n>}                 ; top level
+;;   {:op "delete" :id <id>}                            ; tree-wide by id
 
 (define
   content-bootstrap-doc!
@@ -76,17 +81,58 @@
           (first blocks)
           (ct-insert-at (rest blocks) (- i 1) x))))))
 
+;; tree-wide remove by id: drop matches at this level, recurse into children
+;; (blocks carrying a `children` list, i.e. sections).
 (define
   ct-remove-id
   (fn
     (blocks id)
-    (filter (fn (b) (if (= (blk-id b) id) false true)) blocks)))
+    (map
+      (fn
+        (b)
+        (let
+          ((ch (st-iv-get b "children")))
+          (if (list? ch) (st-iv-set! b "children" (ct-remove-id ch id)) b)))
+      (filter (fn (b) (if (= (blk-id b) id) false true)) blocks))))
 
+;; tree-wide replace by id: apply f to the match wherever it sits in the tree.
 (define
   ct-replace-id
   (fn
     (blocks id f)
-    (map (fn (b) (if (= (blk-id b) id) (f b) b)) blocks)))
+    (map
+      (fn
+        (b)
+        (if
+          (= (blk-id b) id)
+          (f b)
+          (let
+            ((ch (st-iv-get b "children")))
+            (if
+              (list? ch)
+              (st-iv-set! b "children" (ct-replace-id ch id f))
+              b))))
+      blocks)))
+
+;; tree-wide find by id: first block matching id anywhere in the tree, or nil.
+;; Descends into any `children` list, mirroring ct-replace-id/ct-remove-id.
+(define
+  ct-find-id
+  (fn
+    (blocks id)
+    (if
+      (= (len blocks) 0)
+      nil
+      (let
+        ((b (first blocks)))
+        (if
+          (= (blk-id b) id)
+          b
+          (let
+            ((ch (st-iv-get b "children")))
+            (let
+              ((nested (if (list? ch) (ct-find-id ch id) nil)))
+              (if (= nested nil) (ct-find-id (rest blocks) id) nested))))))))
 
 ;; ── query ──
 (define doc-index-of (fn (doc id) (ct-index-of (doc-blocks doc) id)))
@@ -103,6 +149,14 @@
   doc-has?
   (fn (doc id) (if (= (doc-index-of doc id) -1) false true)))
 
+;; tree-wide lookup by id — reads a nested block by the same id content/edit can
+;; update/delete (no section.sx dependency; uses the generic children descent).
+(define doc-find-deep (fn (doc id) (ct-find-id (doc-blocks doc) id)))
+
+(define
+  doc-has-deep?
+  (fn (doc id) (if (= (doc-find-deep doc id) nil) false true)))
+
 ;; ── structural edits (each returns a new document) ──
 (define doc-with-blocks (fn (doc blocks) (st-iv-set! doc "blocks" blocks)))
 

lib/content/find-replace.sx

@@ -1,10 +1,17 @@
-;; content-on-sx — global find/replace across text-bearing blocks.
+;; content-on-sx — global find/replace across every text-bearing field.
 ;;
-;; Replaces every occurrence of `from` with `to` in the text field of text /
-;; heading / code / quote blocks, tree-wide (via the transform layer). For
-;; renaming a term throughout a document. Immutable; case-sensitive.
+;; Replaces every occurrence of `from` with `to` in the text-bearing fields of
+;; a document, tree-wide (via the transform layer):
+;;   - the `text` of text / heading / code / quote / callout blocks
+;;   - the `alt` of image blocks
+;;   - each item of list blocks
+;;   - every header and cell of table blocks
+;; This is exactly the set asText / stats / summary draw prose from, so a rename
+;; via content/find-replace and a word count over asText stay consistent.
+;; Immutable; case-sensitive.
 ;;
-;; Requires (loaded by harness): block.sx, transform.sx (content/map-blocks).
+;; Requires (loaded by harness): block.sx, transform.sx (content/map-blocks),
+;; table.sx (CtTable ivars).
 
 (define
   fr-in?
@@ -15,17 +22,54 @@
       ((= (first xs) x) true)
       (else (fr-in? x (rest xs))))))
 
+(define fr-rep (fn (s from to) (replace (str s) from to)))
+
+;; Blocks whose prose content find/replace rewrites (matches asText's set).
 (define
   fr-has-text?
-  (fn (b) (fr-in? (blk-type b) (list "text" "heading" "code" "quote"))))
+  (fn
+    (b)
+    (fr-in?
+      (blk-type b)
+      (list "text" "heading" "code" "quote" "callout" "image" "list" "table"))))
+
+;; Per-type field rewrite. Each branch returns a new (copy-on-write) block.
+(define
+  fr-rewrite
+  (fn
+    (b from to)
+    (let
+      ((t (blk-type b)))
+      (cond
+        ((= t "image")
+          (blk-set b "alt" (fr-rep (blk-get b "alt") from to)))
+        ((= t "list")
+          (let
+            ((items (blk-get b "items")))
+            (if
+              (list? items)
+              (blk-set b "items" (map (fn (it) (fr-rep it from to)) items))
+              b)))
+        ((= t "table")
+          (let
+            ((hs (blk-get b "headers")) (rs (blk-get b "rows")))
+            (let
+              ((b1 (if (list? hs) (blk-set b "headers" (map (fn (h) (fr-rep h from to)) hs)) b)))
+              (if
+                (list? rs)
+                (blk-set
+                  b1
+                  "rows"
+                  (map
+                    (fn
+                      (r)
+                      (if (list? r) (map (fn (c) (fr-rep c from to)) r) r))
+                    rs))
+                b1))))
+        (else (blk-set b "text" (fr-rep (blk-get b "text") from to)))))))
 
 (define
   content/find-replace
   (fn
     (doc from to)
-    (content/map-blocks
-      doc
-      fr-has-text?
-      (fn
-        (b)
-        (blk-set b "text" (replace (str (blk-get b "text")) from to))))))
+    (content/map-blocks doc fr-has-text? (fn (b) (fr-rewrite b from to)))))

lib/content/query.sx

@@ -1,10 +1,10 @@
 ;; content-on-sx — block query + table of contents.
 ;;
 ;; Collect blocks across the whole tree (descending into sections) by predicate
-;; or type, and derive a table of contents from headings. Tree detection is
-;; inline (class + st-iv-get) so this needs no section.sx.
+;; or type, search them by prose, and derive a table of contents from headings.
+;; Tree detection is inline (class + st-iv-get) so this needs no section.sx.
 ;;
-;; Requires (loaded by harness): block.sx, doc.sx.
+;; Requires (loaded by harness): block.sx, doc.sx, text.sx (asText for search).
 
 (define
   qry-section?
@@ -45,6 +45,30 @@
   content/select-ids
   (fn (doc pred) (map (fn (b) (blk-id b)) (content/select doc pred))))
 
+;; Blocks (tree-wide, excluding section containers) whose own prose contains
+;; `term`. "Prose" is (asText b), so search covers exactly what every block
+;; exposes as text — text/heading/code/quote/callout text, image alt, list
+;; items, table headers+cells — with no separate field list to drift from
+;; asText / find-replace / stats. Case-sensitive substring match.
+(define
+  content/search-text
+  (fn
+    (doc term)
+    (content/select
+      doc
+      (fn
+        (b)
+        (and
+          (not (qry-section? b))
+          (>= (index-of (asText b) term) 0))))))
+
+;; Same search, returning matching block ids in document order.
+(define
+  content/search-text-ids
+  (fn
+    (doc term)
+    (map (fn (b) (blk-id b)) (content/search-text doc term))))
+
 ;; table of contents: {:id :level :text} for every heading, in document order.
 (define
   content/headings

lib/content/scoreboard.json

@@ -3,7 +3,7 @@
     "block": {"pass": 38, "fail": 0},
     "doc": {"pass": 40, "fail": 0},
     "render": {"pass": 42, "fail": 0},
-    "api": {"pass": 26, "fail": 0},
+    "api": {"pass": 32, "fail": 0},
     "meta": {"pass": 27, "fail": 0},
     "page": {"pass": 7, "fail": 0},
     "page-full": {"pass": 4, "fail": 0},
@@ -14,14 +14,14 @@
     "tree-edit": {"pass": 17, "fail": 0},
     "move": {"pass": 11, "fail": 0},
     "clone": {"pass": 10, "fail": 0},
-    "query": {"pass": 13, "fail": 0},
+    "query": {"pass": 20, "fail": 0},
     "toc": {"pass": 8, "fail": 0},
     "anchor": {"pass": 6, "fail": 0},
     "outline": {"pass": 14, "fail": 0},
     "flatten": {"pass": 10, "fail": 0},
     "transform": {"pass": 12, "fail": 0},
     "normalize": {"pass": 11, "fail": 0},
-    "find-replace": {"pass": 10, "fail": 0},
+    "find-replace": {"pass": 16, "fail": 0},
     "stats": {"pass": 17, "fail": 0},
     "summary": {"pass": 14, "fail": 0},
     "index": {"pass": 13, "fail": 0},
@@ -31,7 +31,7 @@
     "data": {"pass": 25, "fail": 0},
     "wire": {"pass": 11, "fail": 0},
     "validate": {"pass": 23, "fail": 0},
-    "store": {"pass": 33, "fail": 0},
+    "store": {"pass": 46, "fail": 0},
     "snapshot": {"pass": 20, "fail": 0},
     "crdt": {"pass": 34, "fail": 0},
     "crdt-tree": {"pass": 21, "fail": 0},
@@ -42,7 +42,7 @@
     "md-doc": {"pass": 12, "fail": 0},
     "fed": {"pass": 20, "fail": 0}
   },
-  "total_pass": 746,
+  "total_pass": 778,
   "total_fail": 0,
-  "total": 746
+  "total": 778
 }

lib/content/scoreboard.md

@@ -7,7 +7,7 @@ _Generated by `lib/content/conformance.sh`_
 | block | 38 | 0 | 38 |
 | doc | 40 | 0 | 40 |
 | render | 42 | 0 | 42 |
-| api | 26 | 0 | 26 |
+| api | 32 | 0 | 32 |
 | meta | 27 | 0 | 27 |
 | page | 7 | 0 | 7 |
 | page-full | 4 | 0 | 4 |
@@ -18,14 +18,14 @@ _Generated by `lib/content/conformance.sh`_
 | tree-edit | 17 | 0 | 17 |
 | move | 11 | 0 | 11 |
 | clone | 10 | 0 | 10 |
-| query | 13 | 0 | 13 |
+| query | 20 | 0 | 20 |
 | toc | 8 | 0 | 8 |
 | anchor | 6 | 0 | 6 |
 | outline | 14 | 0 | 14 |
 | flatten | 10 | 0 | 10 |
 | transform | 12 | 0 | 12 |
 | normalize | 11 | 0 | 11 |
-| find-replace | 10 | 0 | 10 |
+| find-replace | 16 | 0 | 16 |
 | stats | 17 | 0 | 17 |
 | summary | 14 | 0 | 14 |
 | index | 13 | 0 | 13 |
@@ -35,7 +35,7 @@ _Generated by `lib/content/conformance.sh`_
 | data | 25 | 0 | 25 |
 | wire | 11 | 0 | 11 |
 | validate | 23 | 0 | 23 |
-| store | 33 | 0 | 33 |
+| store | 46 | 0 | 46 |
 | snapshot | 20 | 0 | 20 |
 | crdt | 34 | 0 | 34 |
 | crdt-tree | 21 | 0 | 21 |
@@ -45,4 +45,4 @@ _Generated by `lib/content/conformance.sh`_
 | md-import | 38 | 0 | 38 |
 | md-doc | 12 | 0 | 12 |
 | fed | 20 | 0 | 20 |
-| **Total** | **746** | **0** | **746** |
+| **Total** | **778** | **0** | **778** |

lib/content/store.sx

@@ -5,9 +5,10 @@
 ;; replay of its op stream up to a sequence number; the materialised doc is a
 ;; cache, never primary state.
 ;;
-;; Requires (loaded by the harness): block.sx, doc.sx, and persist
-;; (event/backend/log/kv/api). The persist backend `b` is opened by the caller
-;; via (persist/open) and injected — content knows nothing about which backend.
+;; Requires (loaded by the harness): block.sx, doc.sx, section.sx (doc-deep-find
+;; + doc-tree-ids, for the tree-wide diff), plus persist (event/backend/log/kv/
+;; api). The persist backend `b` is opened by the caller via (persist/open) and
+;; injected — content knows nothing about which backend.
 
 (define content/-stream (fn (doc-id) (str "content:" doc-id)))
 
@@ -69,11 +70,18 @@
   (fn (b doc-id) (map (fn (ev) {:type (persist/event-type ev) :at (persist/event-at ev) :seq (persist/event-seq ev)}) (content/log b doc-id))))
 
 ;; ── diff between two materialised document versions ──
-;; Returns {:added (ids) :removed (ids) :changed (ids)} where changed = ids
-;; present in both whose block content differs.
-(define
-  content/-missing?
-  (fn (doc id) (= (ct-index-of (doc-blocks doc) id) -1)))
+;; Tree-wide: ids are enumerated across the whole block tree (descending into
+;; sections), so nested-block adds/removes/changes are detected, not just
+;; top-level ones. Returns {:added :removed :changed} (lists of ids):
+;;   :added   — ids present (anywhere) in `new` but not in `old`
+;;   :removed — ids present (anywhere) in `old` but not in `new`
+;;   :changed — content blocks present in both whose block value differs
+;; Section containers never appear in :changed (they hold no own content — a
+;; child change surfaces as that child's own entry); a whole section appearing
+;; or disappearing shows up in :added / :removed by its id.
+(define content/-all-ids (fn (doc) (doc-tree-ids doc)))
+
+(define content/-missing? (fn (doc id) (= (doc-deep-find doc id) nil)))
 
 (define
   content/-changed
@@ -83,15 +91,16 @@
       (fn
         (id)
         (let
-          ((bo (doc-find old id)) (bn (doc-find new id)))
+          ((bo (doc-deep-find old id)) (bn (doc-deep-find new id)))
           (cond
             ((= bo nil) false)
             ((= bn nil) false)
+            ((= (blk-type bo) "section") false)
             ((= bo bn) false)
             (else true))))
-      (doc-ids old))))
+      (content/-all-ids old))))
 
-(define content/diff (fn (old new) {:changed (content/-changed old new) :removed (filter (fn (id) (content/-missing? new id)) (doc-ids old)) :added (filter (fn (id) (content/-missing? old id)) (doc-ids new))}))
+(define content/diff (fn (old new) {:changed (content/-changed old new) :removed (filter (fn (id) (content/-missing? new id)) (content/-all-ids old)) :added (filter (fn (id) (content/-missing? old id)) (content/-all-ids new))}))
 
 ;; convenience: diff two persisted versions by seq.
 (define

lib/content/tests/api.sx

@@ -97,3 +97,37 @@
   "render original unchanged"
   (content/render d1 "html")
   "<h1>Hi</h1><p>World</p>")
+
+;; ── facade find/has? are TREE-WIDE (reach into sections); find-top/has-top?
+;; keep the top-level-only lookup. This makes the read-by-id surface consistent
+;; with content/edit, whose update/delete are already tree-wide. ──
+(content-bootstrap-section!)
+(define
+  nd
+  (content/append
+    (content/empty "nested")
+    (mk-section
+      "sec"
+      (list (content/block "text" "inner" (list (list "text" "deep")))))))
+(content-test
+  "find nested (deep)"
+  (blk-id (content/find nd "inner"))
+  "inner")
+(content-test "has? nested (deep)" (content/has? nd "inner") true)
+(content-test "find-top misses nested" (content/find-top nd "inner") nil)
+(content-test "has-top? misses nested" (content/has-top? nd "inner") false)
+(content-test
+  "find-top sees top-level"
+  (blk-id (content/find-top nd "sec"))
+  "sec")
+;; a nested block updated by id via content/edit is now readable by id via
+;; content/find (was impossible when find was top-level-only).
+(content-test
+  "edit-then-find nested round-trip"
+  (str
+    (blk-send
+      (content/find
+        (content/edit nd (content/update "inner" "text" "edited"))
+        "inner")
+      "text"))
+  "edited")

lib/content/tests/find-replace.sx

@@ -1,8 +1,10 @@
-;; Extension — global find/replace across text-bearing blocks.
+;; Extension — global find/replace across every text-bearing field.
 
 (st-bootstrap-classes!)
 (content/bootstrap!)
 (content-bootstrap-section!)
+(content-bootstrap-callout!)
+(content-bootstrap-table!)
 
 (define
   d
@@ -30,11 +32,12 @@
   (str (blk-send (doc-deep-find r "n") "text"))
   "nested Bar")
 
-;; ── does NOT touch image alt/src (not a text field) ──
+;; ── image alt IS a text field (asText ^ alt), so it is rewritten ──
 (content-test
-  "image alt untouched"
+  "image alt replaced"
   (str (blk-send (doc-deep-find r "img") "alt"))
-  "Foo alt")
+  "Bar alt")
+;; ── but src is a URL, not prose, so it stays put ──
 (content-test
   "image src untouched"
   (str (blk-send (doc-deep-find r "img") "src"))
@@ -76,6 +79,68 @@
   (str (blk-send (doc-find r2 "q") "text"))
   "new saying")
 
+;; ── callout text is covered (consistency with asText/stats/summary) ──
+(content-test
+  "replace callout text"
+  (str
+    (blk-send
+      (doc-find
+        (content/find-replace
+          (doc-append (doc-empty "d") (mk-callout "co" "note" "Foo here"))
+          "Foo"
+          "Bar")
+        "co")
+      "text"))
+  "Bar here")
+(content-test
+  "callout kind untouched by text replace"
+  (str
+    (blk-send
+      (doc-find
+        (content/find-replace
+          (doc-append (doc-empty "d") (mk-callout "co" "note" "x"))
+          "note"
+          "X")
+        "co")
+      "kind"))
+  "note")
+
+;; ── list items are rewritten (asText folds items) ──
+(define
+  rl
+  (content/find-replace
+    (doc-append
+      (doc-empty "d")
+      (mk-list "l" false (list "Foo one" "two Foo")))
+    "Foo"
+    "Bar"))
+(content-test
+  "replace first list item"
+  (str (first (blk-send (doc-find rl "l") "items")))
+  "Bar one")
+(content-test
+  "replace second list item"
+  (str (first (rest (blk-send (doc-find rl "l") "items"))))
+  "two Bar")
+
+;; ── table headers + cells are rewritten (asText folds rows) ──
+(define
+  rt
+  (content/find-replace
+    (doc-append
+      (doc-empty "d")
+      (mk-table "t" (list "Foo head") (list (list "a Foo" "b"))))
+    "Foo"
+    "Bar"))
+(content-test
+  "replace table header"
+  (str (first (table-headers (doc-find rt "t"))))
+  "Bar head")
+(content-test
+  "replace table cell"
+  (str (first (first (table-rows (doc-find rt "t")))))
+  "a Bar")
+
 ;; ── no match → unchanged render ──
 (content-test
   "no match"

lib/content/tests/query.sx

@@ -1,8 +1,11 @@
-;; Extension — block query + table of contents.
+;; Extension — block query + table of contents + prose search.
 
 (st-bootstrap-classes!)
 (content/bootstrap!)
+(content-bootstrap-text!)
 (content-bootstrap-section!)
+(content-bootstrap-table!)
+(content-bootstrap-callout!)
 
 (define
   d
@@ -87,3 +90,49 @@
   "deep toc level"
   (get (first (content/headings deep)) :level)
   3)
+
+;; ── prose search (content/search-text) ──
+;; "cat" appears in text, image alt, a list item, a table cell, and a callout
+;; — every text-bearing field — so search must find all five via asText.
+(define
+  sd
+  (doc-append
+    (doc-append
+      (doc-append
+        (doc-append
+          (doc-append
+            (doc-empty "sd")
+            (mk-heading "sh" 1 "Welcome aboard"))
+          (mk-text "st" "the cat sat"))
+        (mk-image "si" "/x.png" "a cat photo"))
+      (mk-list "sl" false (list "first cat" "second dog")))
+    (mk-section
+      "sec"
+      (list
+        (mk-table "stb" (list "Animal") (list (list "cat") (list "fish")))
+        (mk-callout "sc" "note" "beware of cat")))))
+
+(content-test
+  "search across every text-bearing field"
+  (content/search-text-ids sd "cat")
+  (list "st" "si" "sl" "stb" "sc"))
+(content-test "search count" (len (content/search-text sd "cat")) 5)
+(content-test
+  "search heading text"
+  (content/search-text-ids sd "Welcome")
+  (list "sh"))
+(content-test
+  "search list item only"
+  (content/search-text-ids sd "dog")
+  (list "sl"))
+(content-test "search no match" (content/search-text-ids sd "zzz") (list))
+;; section containers are excluded — a term living only inside a section's
+;; children returns the child, never the section wrapper.
+(content-test
+  "search excludes section wrapper"
+  (content/search-text-ids sd "fish")
+  (list "stb"))
+(content-test
+  "search returns block objects"
+  (blk-id (first (content/search-text sd "Welcome")))
+  "sh")

lib/content/tests/store.sx

@@ -151,3 +151,58 @@
   "op-log media type"
   (blk-type (doc-find (content/head B3 "rich") "v"))
   "media")
+
+;; ── op-log update/delete reach NESTED blocks (tree-wide by id) ──
+(content-bootstrap-section!)
+(define B4 (persist/open))
+(content/commit!
+  B4
+  "nest"
+  (op-insert (mk-section "sec" (list (mk-text "n" "orig"))) nil)
+  1)
+(content/commit! B4 "nest" (op-update "n" "text" "edited") 2)
+(content-test
+  "op-log nested update"
+  (str (blk-send (doc-deep-find (content/head B4 "nest") "n") "text"))
+  "edited")
+(content-test
+  "op-log nested update tree intact"
+  (doc-tree-ids (content/head B4 "nest"))
+  (list "sec" "n"))
+(content/commit! B4 "nest" (op-delete "n") 3)
+(content-test
+  "op-log nested delete"
+  (doc-tree-ids (content/head B4 "nest"))
+  (list "sec"))
+(content-test
+  "op-log nested delete via content/at seq2"
+  (doc-tree-ids (content/at B4 "nest" 2))
+  (list "sec" "n"))
+
+;; ── diff is TREE-WIDE: nested-block add/change/remove are detected, and
+;; section containers never appear in :changed (a top-level-only diff would miss
+;; "n" entirely and instead flag the section). ──
+(define dn01 (content/diff-versions B4 "nest" 0 1))
+(content-test
+  "diff nested added (section + child)"
+  (get dn01 :added)
+  (list "sec" "n"))
+(content-test "diff nested added removed empty" (get dn01 :removed) (list))
+(content-test "diff nested added changed empty" (get dn01 :changed) (list))
+
+(define dn12 (content/diff-versions B4 "nest" 1 2))
+(content-test
+  "diff nested changed child only"
+  (get dn12 :changed)
+  (list "n"))
+(content-test "diff nested changed no add" (get dn12 :added) (list))
+(content-test "diff nested changed no remove" (get dn12 :removed) (list))
+
+(define dn23 (content/diff-versions B4 "nest" 2 3))
+(content-test "diff nested removed child" (get dn23 :removed) (list "n"))
+(content-test "diff nested removed no change" (get dn23 :changed) (list))
+
+(content-test
+  "diff nested no-op"
+  (get (content/diff-versions B4 "nest" 1 1) :changed)
+  (list))

lib/erlang/transpile.sx

@@ -1485,9 +1485,15 @@
         (size (er-eval-binary-size (get seg :size) env)))
       (cond
         (= spec "integer")
-        (let
-          ((bits (if (= size nil) 8 size)))
-          (er-emit-int! out val bits))
+        (cond
+          (= (type-of val) "string")
+          (for-each
+            (fn (c) (er-emit-int! out (char->integer c) 8))
+            (string->list val))
+          :else
+          (let
+            ((bits (if (= size nil) 8 size)))
+            (er-emit-int! out val bits)))
         (= spec "binary")
         (cond
           (er-binary? val)

lib/events/api.sx

@@ -0,0 +1,277 @@
+;; lib/events/api.sx — public events surface over calendar + availability.
+;;
+;; A `store` is an immutable value holding scheduled events and (in-memory)
+;; bookings:
+;;
+;;   {:events (event ...) :bookings ((actor key) ...)}
+;;
+;; The in-memory `:bookings` list supports pure, value-level queries. The
+;; DURABLE booking path (ev/*-occ! and ev/*-p) keeps bookings in persist
+;; streams via booking.sx — capacity-safe, cancellable, replayable — and
+;; derives availability from those streams. Use the persist path for real
+;; bookings; the in-memory path for projections and tests.
+;;
+;; All queries are windowed: agenda/free/next-free expand recurring events into
+;; concrete occurrences within an explicit (or derived) window before running
+;; the Datalog availability rules.
+
+(define ev/store (fn (events bookings) {:bookings bookings :events events}))
+
+(define ev/empty (fn () (ev/store (list) (list))))
+
+(define ev/events (fn (store) (get store :events)))
+(define ev/bookings (fn (store) (get store :bookings)))
+
+;; Add a (constructed) event to the store.
+(define
+  ev/add-event
+  (fn
+    (store event)
+    (ev/store (cons event (ev/events store)) (ev/bookings store))))
+
+;; Schedule a fresh event from parts, returning the updated store. rrule may be
+;; nil for a one-off. (Booking is separate — see ev/book.)
+(define
+  ev/schedule
+  (fn
+    (store id dtstart duration rrule capacity)
+    (ev/add-event store (ev-event id dtstart duration rrule capacity))))
+
+;; Record that `actor` holds the occurrence with `key` (in-memory only — see
+;; ev/book-occ! for the durable, capacity-safe path).
+(define
+  ev/book
+  (fn
+    (store actor key)
+    (ev/store
+      (ev/events store)
+      (cons (list actor key) (ev/bookings store)))))
+
+;; The event with `id`, or nil.
+(define
+  ev/event-by-id
+  (fn
+    (store id)
+    (reduce
+      (fn
+        (found ev)
+        (if (nil? found) (if (= (get ev :id) id) ev found) found))
+      nil
+      (ev/events store))))
+
+;; Capacity of the event an occurrence belongs to (0 if unknown).
+(define
+  ev/capacity-of
+  (fn
+    (store occ)
+    (let
+      ((ev (ev/event-by-id store (get occ :id))))
+      (if (nil? ev) 0 (get ev :capacity)))))
+
+;; The maximum event duration in the store (0 when empty) — used to widen
+;; expansion windows so any occurrence overlapping a query is captured.
+(define
+  ev/store-max-duration
+  (fn
+    (store)
+    (reduce
+      (fn (m ev) (max m (get ev :duration)))
+      0
+      (ev/events store))))
+
+;; All occurrences across all events within [ws, we), ascending by start.
+(define
+  ev/agenda
+  (fn (store ws we) (ev-expand-all (ev/events store) ws we)))
+
+(define
+  ev-key-member?
+  (fn
+    (k keys)
+    (cond
+      ((empty? keys) false)
+      ((= k (first keys)) true)
+      (else (ev-key-member? k (rest keys))))))
+
+;; Occurrence keys `actor` has booked (in-memory store).
+(define
+  ev/actor-keys
+  (fn
+    (store actor)
+    (reduce
+      (fn
+        (acc b)
+        (if (= (first b) actor) (cons (first (rest b)) acc) acc))
+      (list)
+      (ev/bookings store))))
+
+;; The agenda restricted to occurrences `actor` is booked into (in-memory).
+(define
+  ev/agenda-for
+  (fn
+    (store actor ws we)
+    (let
+      ((keys (ev/actor-keys store actor)))
+      (filter
+        (fn (o) (ev-key-member? (ev-occ-key o) keys))
+        (ev/agenda store ws we)))))
+
+;; Build an availability db over occurrences expanded in [ws, we) using the
+;; in-memory bookings.
+(define
+  ev/avail-window-db
+  (fn
+    (store ws we)
+    (ev-avail-db (ev/agenda store ws we) (ev/bookings store))))
+
+;; Is `actor` free across [qs, qe)? Expands a window wide enough (back by the
+;; longest event) to capture any occurrence that could overlap.
+(define
+  ev/free?
+  (fn
+    (store actor qs qe)
+    (ev-free?
+      (ev/avail-window-db store (- qs (ev/store-max-duration store)) qe)
+      actor
+      qs
+      qe)))
+
+;; Earliest free slot of `duration` for `actor` in [after, horizon), or nil.
+(define
+  ev/next-free
+  (fn
+    (store actor after duration horizon)
+    (ev-next-free
+      (ev/avail-window-db
+        store
+        (- after (ev/store-max-duration store))
+        horizon)
+      actor
+      after
+      duration
+      horizon)))
+
+;; Overlapping double-bookings for `actor` among occurrences in [ws, we).
+(define
+  ev/conflicts
+  (fn
+    (store actor ws we)
+    (ev-conflicts (ev/avail-window-db store ws we) actor)))
+
+(define
+  ev/has-conflict?
+  (fn
+    (store actor ws we)
+    (> (len (ev/conflicts store actor ws we)) 0)))
+
+;; ---- durable, persist-backed booking path ----
+;; These take a persist backend `b` (persist/open) plus the schedule `store`.
+;; Bookings live in per-occurrence streams (booking.sx); availability is derived
+;; by replaying those streams for the occurrences in the query window.
+
+;; Durably book `actor` into occurrence `occ` (dict {:id :start :end}),
+;; capacity-safe. Returns the booking.sx result (:booked / :full / :already).
+(define
+  ev/book-occ!
+  (fn
+    (b store actor occ)
+    (ev/book! b (ev-occ-key occ) (ev/capacity-of store occ) actor)))
+
+;; Durably cancel `actor`'s seat on `occ`, freeing capacity.
+(define
+  ev/cancel-occ!
+  (fn (b store actor occ) (ev/cancel! b (ev-occ-key occ) actor)))
+
+;; Live roster / seats-left for a specific occurrence from persist.
+(define ev/roster-occ (fn (b occ) (ev/roster b (ev-occ-key occ))))
+
+(define
+  ev/seats-left-occ
+  (fn
+    (b store occ)
+    (ev/seats-left b (ev-occ-key occ) (ev/capacity-of store occ))))
+
+;; Derive (actor key) booking pairs from the persist rosters of `occs`.
+(define
+  ev/persist-bookings
+  (fn
+    (b occs)
+    (reduce
+      (fn
+        (acc occ)
+        (let
+          ((key (ev-occ-key occ)))
+          (append
+            acc
+            (map (fn (actor) (list actor key)) (ev/roster b key)))))
+      (list)
+      occs)))
+
+;; Availability db over [ws, we) with bookings sourced from persist streams.
+(define
+  ev/avail-db-p
+  (fn
+    (b store ws we)
+    (let
+      ((occs (ev/agenda store ws we)))
+      (ev-avail-db occs (ev/persist-bookings b occs)))))
+
+;; Persist-backed availability queries (mirror the in-memory ev/free? etc).
+(define
+  ev/free-p?
+  (fn
+    (b store actor qs qe)
+    (ev-free?
+      (ev/avail-db-p b store (- qs (ev/store-max-duration store)) qe)
+      actor
+      qs
+      qe)))
+
+(define
+  ev/next-free-p
+  (fn
+    (b store actor after duration horizon)
+    (ev-next-free
+      (ev/avail-db-p b store (- after (ev/store-max-duration store)) horizon)
+      actor
+      after
+      duration
+      horizon)))
+
+(define
+  ev/conflicts-p
+  (fn
+    (b store actor ws we)
+    (ev-conflicts (ev/avail-db-p b store ws we) actor)))
+
+(define
+  ev/has-conflict-p?
+  (fn
+    (b store actor ws we)
+    (> (len (ev/conflicts-p b store actor ws we)) 0)))
+
+;; ---- conflict-checked booking ----
+;; Capacity is per-event, but an attendee should not be double-booked against
+;; THEMSELVES across different events. Would booking `actor` into `occ` overlap
+;; an existing booking of theirs elsewhere? (Derived from persist availability;
+;; an existing booking into `occ` itself is excluded — that's idempotent.)
+(define
+  ev/would-time-conflict?
+  (fn
+    (b store actor occ)
+    (and
+      (not (ev-actor-booked? b (ev-occ-key occ) actor))
+      (not (ev/free-p? b store actor (get occ :start) (get occ :end))))))
+
+;; Book `actor` into `occ` only if it doesn't clash with their other bookings.
+;; Re-booking the same occurrence is idempotent (:already); a clash returns
+;; :time-conflict; otherwise the normal ev/book-occ! result (:booked / :full).
+(define
+  ev/book-checked!
+  (fn
+    (b store actor occ)
+    (cond
+      ((ev-actor-booked? b (ev-occ-key occ) actor) (ev/book-occ! b store actor occ))
+      ((ev/would-time-conflict? b store actor occ)
+        {:status :time-conflict :actor actor :occ-key (ev-occ-key occ)})
+      (else (ev/book-occ! b store actor occ)))))

lib/events/availability.sx

@@ -0,0 +1,177 @@
+;; lib/events/availability.sx — free/busy + conflict detection on Datalog.
+;;
+;; Availability is per-actor and is forward-chained Datalog over two EDB
+;; relations:
+;;
+;;   (occurrence Key EventId Start End)   ; an expanded calendar occurrence
+;;   (booking    Actor Key)               ; actor attends/holds that occurrence
+;;
+;; The derived relations are the whole policy:
+;;
+;;   busy(A,S,E)        — A is committed for [S,E) (a booked occurrence)
+;;   conflict(A,O1,O2)  — A double-booked into two overlapping occurrences
+;;   busy_in(A,QS,QE)   — A is busy somewhere inside query window [QS,QE)
+;;
+;; Intervals are half-open [Start,End) in epoch minutes (see calendar.sx), so
+;; adjacent slots (E == next start) do NOT conflict. Conflict pairs are
+;; canonical (O1 < O2 by key) so each overlap is reported once. The same `busy`
+;; rule answers "is A free in [QS,QE)?" (busy_in is empty) and feeds "when is A
+;; next free?" (ev-next-free probes candidate slots with the same rule).
+
+;; A stable key for an occurrence dict {:id :start :end}.
+(define ev-occ-key (fn (occ) (str (get occ :id) "@" (get occ :start))))
+
+(define
+  ev-occurrence-fact
+  (fn
+    (occ)
+    (list
+      (quote occurrence)
+      (ev-occ-key occ)
+      (get occ :id)
+      (get occ :start)
+      (get occ :end))))
+
+(define ev-occurrence-facts (fn (occs) (map ev-occurrence-fact occs)))
+
+(define ev-booking-fact (fn (actor key) (list (quote booking) actor key)))
+
+(define ev-qwindow-fact (fn (qs qe) (list (quote qwindow) qs qe)))
+
+;; Range restriction: each comparison's variables are bound by an earlier
+;; positive literal (qwindow / busy precede the < tests). Conflict uses
+;; (< O1 O2) on the keys so each overlapping pair is reported once.
+(define
+  ev-avail-rules
+  (quote
+    ((busy A S E <- (booking A O) (occurrence O _ S E))
+      (conflict
+        A
+        O1
+        O2
+        <-
+        (booking A O1)
+        (booking A O2)
+        (occurrence O1 _ S1 E1)
+        (occurrence O2 _ S2 E2)
+        (< O1 O2)
+        (< S1 E2)
+        (< S2 E1))
+      (busy_in A QS QE <- (qwindow QS QE) (busy A S E) (< S QE) (< QS E)))))
+
+;; Build a Datalog db from EDB facts under the availability ruleset.
+(define ev-build-avail (fn (facts) (dl-program-data facts ev-avail-rules)))
+
+;; Convenience: build a db from occurrence dicts + booking pairs.
+;; bookings is a list of (actor key) pairs.
+(define
+  ev-avail-db
+  (fn
+    (occs bookings)
+    (ev-build-avail
+      (append
+        (ev-occurrence-facts occs)
+        (map
+          (fn (b) (ev-booking-fact (first b) (first (rest b))))
+          bookings)))))
+
+;; Helper: insertion sort a list of (S E ...) lists ascending by S then E.
+(define
+  ev-list-before?
+  (fn
+    (a b)
+    (cond
+      ((< (first a) (first b)) true)
+      ((> (first a) (first b)) false)
+      (else (< (first (rest a)) (first (rest b)))))))
+
+(define
+  ev-list-insert
+  (fn
+    (x sorted)
+    (cond
+      ((empty? sorted) (list x))
+      ((ev-list-before? x (first sorted)) (cons x sorted))
+      (else (cons (first sorted) (ev-list-insert x (rest sorted)))))))
+
+(define
+  ev-sort-lists
+  (fn (xs) (reduce (fn (acc x) (ev-list-insert x acc)) (list) xs)))
+
+(define
+  ev-dedup-sorted
+  (fn
+    (xs)
+    (cond
+      ((empty? xs) xs)
+      ((empty? (rest xs)) xs)
+      ((= (first xs) (first (rest xs))) (ev-dedup-sorted (rest xs)))
+      (else (cons (first xs) (ev-dedup-sorted (rest xs)))))))
+
+;; All busy intervals (list S E) for an actor, ascending by start.
+(define
+  ev-busy
+  (fn
+    (db actor)
+    (let
+      ((rows (dl-query db (list (quote busy) actor (quote S) (quote E)))))
+      (ev-sort-lists (map (fn (b) (list (get b :S) (get b :E))) rows)))))
+
+;; Distinct conflicting occurrence-key pairs for an actor (each pair once).
+(define
+  ev-conflicts
+  (fn
+    (db actor)
+    (dl-query db (list (quote conflict) actor (quote O1) (quote O2)))))
+
+(define
+  ev-has-conflict?
+  (fn (db actor) (> (len (ev-conflicts db actor)) 0)))
+
+;; Is `actor` free across the whole window [qs,qe)? (no booked occurrence
+;; overlaps it). Asserts a transient qwindow fact, queries, retracts.
+(define
+  ev-free?
+  (fn
+    (db actor qs qe)
+    (do
+      (dl-assert! db (ev-qwindow-fact qs qe))
+      (let
+        ((rows (dl-query db (list (quote busy_in) actor (quote QS) (quote QE)))))
+        (begin (dl-retract! db (ev-qwindow-fact qs qe)) (empty? rows))))))
+
+;; ---- next-free slot search ----
+;; The earliest start s >= `after` such that [s, s+duration) is entirely free
+;; for `actor` and ends at or before `horizon`, or nil if none. The earliest
+;; such slot must begin either at `after` or immediately after some busy
+;; interval ends (classic interval packing), so those are the only candidates
+;; we probe — each probe reuses the busy_in rule via ev-free?.
+
+(define
+  ev-first-free
+  (fn
+    (db actor cands duration horizon)
+    (cond
+      ((empty? cands) nil)
+      (else
+        (let
+          ((s (first cands)))
+          (if
+            (and
+              (<= (+ s duration) horizon)
+              (ev-free? db actor s (+ s duration)))
+            s
+            (ev-first-free db actor (rest cands) duration horizon)))))))
+
+(define
+  ev-next-free
+  (fn
+    (db actor after duration horizon)
+    (let
+      ((ends (filter (fn (e) (>= e after)) (map (fn (iv) (first (rest iv))) (ev-busy db actor)))))
+      (ev-first-free
+        db
+        actor
+        (ev-dedup-sorted (sort (cons after ends)))
+        duration
+        horizon))))

lib/events/booking-notify.sx

@@ -0,0 +1,102 @@
+;; lib/events/booking-notify.sx — derive lifecycle notifications from the
+;; booking stream, for delivery via notify.sx.
+;;
+;; Walking the append-only booking stream yields one notification per state
+;; change, in order, classified by kind:
+;;
+;;   :booked      a confirmed booking
+;;   :promoted    a booking for an actor who was on the waitlist (auto-promote)
+;;   :held        a provisional hold (pending payment)
+;;   :confirmed   a held seat became confirmed (payment succeeded)
+;;   :released    a held seat was released (payment failed/expired)
+;;   :cancelled   a seat was given up
+;;   :waitlisted  an actor joined the waitlist
+;;
+;; Promotion is detected by folding the waitlist as we walk: a :booking for an
+;; actor currently on the waitlist is a promotion, not a fresh booking.
+;;
+;; Each notification's id is occ-key/seq (the stream seq is unique and stable),
+;; so re-deriving and re-delivering is idempotent — the notify transport dedups
+;; on this id and never double-pings.
+
+(define
+  ev-bn-kind
+  (fn
+    (typ promoted?)
+    (cond
+      ((= typ :hold) :held)
+      ((= typ :booking) (if promoted? :promoted :booked))
+      ((= typ :confirm) :confirmed)
+      ((= typ :cancel) :cancelled)
+      ((= typ :release) :released)
+      ((= typ :waitlist) :waitlisted)
+      (else nil))))
+
+(define
+  ev-bn-update-waiting
+  (fn
+    (typ actor waiting)
+    (cond
+      ((= typ :waitlist)
+        (if
+          (ev-bk-member? actor waiting)
+          waiting
+          (ev-bk-append waiting actor)))
+      ((= typ :unwaitlist) (ev-bk-remove waiting actor))
+      ((= typ :booking) (ev-bk-remove waiting actor))
+      ((= typ :hold) (ev-bk-remove waiting actor))
+      (else waiting))))
+
+(define ev-bn-mk (fn (occ-key label actor kind seq) {:id (str occ-key "/" seq) :event label :kind kind :recipient actor :seq seq}))
+
+(define
+  ev-bn-step
+  (fn
+    (occ-key label events waiting)
+    (if
+      (empty? events)
+      (list)
+      (let
+        ((e (first events)))
+        (let
+          ((typ (persist/event-type e))
+            (actor (get (persist/event-data e) :actor))
+            (seq (persist/event-seq e)))
+          (let
+            ((promoted? (and (= typ :booking) (ev-bk-member? actor waiting))))
+            (let
+              ((kind (ev-bn-kind typ promoted?))
+                (waiting2 (ev-bn-update-waiting typ actor waiting)))
+              (if
+                (nil? kind)
+                (ev-bn-step occ-key label (rest events) waiting2)
+                (cons
+                  (ev-bn-mk occ-key label actor kind seq)
+                  (ev-bn-step occ-key label (rest events) waiting2))))))))))
+
+;; The ordered lifecycle notifications for an occurrence's bookings. `label` is
+;; a human-facing event id carried on each notification.
+(define
+  ev/booking-notifications
+  (fn
+    (b occ-key label)
+    (ev-bn-step
+      occ-key
+      label
+      (persist/read b (ev-booking-stream occ-key))
+      (list))))
+
+;; Filter notifications to a single kind.
+(define
+  ev/notify-of-kind
+  (fn (notifs kind) (filter (fn (n) (= (get n :kind) kind)) notifs)))
+
+;; Project a notification to notify.sx's (id recipient body) wire shape.
+(define
+  ev/booking-notify->msg
+  (fn
+    (n)
+    (list
+      (get n :id)
+      (get n :recipient)
+      (list :booking-event (get n :kind) (get n :event)))))

lib/events/booking.sx

@@ -0,0 +1,372 @@
+;; lib/events/booking.sx — transactional, capacity-safe booking on persist.
+;;
+;; Each bookable occurrence has an append-only stream of booking events:
+;;
+;;   :booking  free booking — actor immediately holds a confirmed seat
+;;   :hold     provisional hold — seat reserved while payment is pending
+;;   :confirm  a held seat becomes confirmed (payment succeeded)
+;;   :release  a held seat is abandoned (payment failed/expired) — seat freed
+;;   :cancel   a held or confirmed seat is given up — seat freed
+;;
+;; The live state is the stream FOLDED in order into per-actor seat states
+;; (:held / :confirmed); an actor in ANY state occupies a seat, so both held and
+;; confirmed seats count toward capacity — a pending payment cannot be
+;; oversold. A freed seat (release/cancel) reopens capacity.
+;;
+;; Capacity safety is the contract: two writers racing for the last seat must
+;; NEVER both succeed. Seat-ACQUIRING writes (:booking, :hold) go through
+;; persist's optimistic concurrency — `persist/append-expect` appends only if
+;; the stream's last-seq still equals what the writer observed; else it returns
+;; a conflict the writer retries. Seat-FREEING writes (:cancel, :release) and
+;; the state transition (:confirm) never oversell, so they append directly.
+
+(define ev-booking-stream (fn (occ-key) (str "booking:" occ-key)))
+
+(define
+  ev-bk-member?
+  (fn
+    (x xs)
+    (cond
+      ((empty? xs) false)
+      ((= x (first xs)) true)
+      (else (ev-bk-member? x (rest xs))))))
+
+(define
+  ev-bk-index
+  (fn
+    (xs x i)
+    (cond
+      ((empty? xs) -1)
+      ((= (first xs) x) i)
+      (else (ev-bk-index (rest xs) x (+ i 1))))))
+
+(define ev-bk-append (fn (xs a) (append xs (list a))))
+(define ev-bk-remove (fn (xs a) (filter (fn (x) (not (= x a))) xs)))
+
+;; ---- per-actor state association list: ((actor state) ...) in join order ----
+
+(define
+  ev-state-has?
+  (fn
+    (states actor)
+    (cond
+      ((empty? states) false)
+      ((= (first (first states)) actor) true)
+      (else (ev-state-has? (rest states) actor)))))
+
+(define
+  ev-state-get
+  (fn
+    (states actor)
+    (cond
+      ((empty? states) :none)
+      ((= (first (first states)) actor) (first (rest (first states))))
+      (else (ev-state-get (rest states) actor)))))
+
+(define
+  ev-state-del
+  (fn (states actor) (filter (fn (p) (not (= (first p) actor))) states)))
+
+(define
+  ev-state-set
+  (fn
+    (states actor st)
+    (if
+      (ev-state-has? states actor)
+      (map (fn (p) (if (= (first p) actor) (list actor st) p)) states)
+      (append states (list (list actor st))))))
+
+;; Fold the booking stream into per-actor seat states (join order preserved).
+(define
+  ev-fold-states
+  (fn
+    (events)
+    (reduce
+      (fn
+        (acc e)
+        (let
+          ((typ (persist/event-type e))
+            (actor (get (persist/event-data e) :actor)))
+          (cond
+            ((= typ :booking) (ev-state-set acc actor :confirmed))
+            ((= typ :hold) (ev-state-set acc actor :held))
+            ((= typ :confirm)
+              (if
+                (ev-state-has? acc actor)
+                (ev-state-set acc actor :confirmed)
+                acc))
+            ((= typ :cancel) (ev-state-del acc actor))
+            ((= typ :release) (ev-state-del acc actor))
+            (else acc))))
+      (list)
+      events)))
+
+(define
+  ev-states-of
+  (fn
+    (b occ-key)
+    (ev-fold-states (persist/read b (ev-booking-stream occ-key)))))
+
+;; Live roster (actors holding a seat — held or confirmed), oldest active first.
+(define
+  ev-booked-actors
+  (fn (b occ-key) (map (fn (p) (first p)) (ev-states-of b occ-key))))
+
+(define
+  ev-actor-booked?
+  (fn (b occ-key actor) (ev-bk-member? actor (ev-booked-actors b occ-key))))
+
+;; Live seat count (folded roster size — both held and confirmed seats).
+(define
+  ev-booking-count
+  (fn (b occ-key) (len (ev-booked-actors b occ-key))))
+
+;; Seat state for an actor: :held / :confirmed / :none.
+(define
+  ev/seat-state
+  (fn (b occ-key actor) (ev-state-get (ev-states-of b occ-key) actor)))
+
+;; 1-based seat number for an actor on the roster (0 if not booked).
+(define
+  ev-seat-of
+  (fn
+    (actors actor)
+    (let
+      ((i (ev-bk-index actors actor 0)))
+      (if (< i 0) 0 (+ i 1)))))
+
+;; ---- seat-acquiring writes (capacity-guarded via append-expect) ----
+
+;; One seat-acquiring attempt of `kind` (:booking or :hold) against an OBSERVED
+;; snapshot (roster the writer saw + the last-seq). Returns :already / :full /
+;; :conflict, or a success dict tagged with `ok-status`. :conflict means a
+;; concurrent append landed since the snapshot — the caller must re-observe.
+(define
+  ev-acquire-with-observed
+  (fn
+    (b occ-key capacity actor observed-actors expected kind ok-status)
+    (cond
+      ((ev-bk-member? actor observed-actors) {:seat (ev-seat-of observed-actors actor) :actor actor :status :already})
+      ((>= (len observed-actors) capacity) {:actor actor :capacity capacity :status :full})
+      (else
+        (let
+          ((r (persist/append-expect b (ev-booking-stream occ-key) expected kind 0 {:actor actor})))
+          (if (persist/conflict? r) {:actual (persist/conflict-actual r) :actor actor :status :conflict} {:seat (+ (len observed-actors) 1) :actor actor :status ok-status}))))))
+
+(define
+  ev-acquire!
+  (fn
+    (b occ-key capacity actor kind ok-status)
+    (let
+      ((res (ev-acquire-with-observed b occ-key capacity actor (ev-booked-actors b occ-key) (persist/last-seq b (ev-booking-stream occ-key)) kind ok-status)))
+      (if
+        (= (get res :status) :conflict)
+        (ev-acquire! b occ-key capacity actor kind ok-status)
+        res))))
+
+;; Capacity-safe confirmed booking (retrying on conflict).
+(define
+  ev/book!
+  (fn
+    (b occ-key capacity actor)
+    (ev-acquire! b occ-key capacity actor :booking :booked)))
+
+;; Capacity-safe provisional hold (retrying on conflict). The seat is reserved
+;; (counts toward capacity) until confirmed or released.
+(define
+  ev/hold!
+  (fn
+    (b occ-key capacity actor)
+    (ev-acquire! b occ-key capacity actor :hold :held)))
+
+;; Test seam: one attempt against a caller-supplied snapshot (book or hold).
+(define
+  ev/book-with-observed
+  (fn
+    (b occ-key capacity actor observed-actors expected)
+    (ev-acquire-with-observed
+      b
+      occ-key
+      capacity
+      actor
+      observed-actors
+      expected
+      :booking :booked)))
+
+(define
+  ev/hold-with-observed
+  (fn
+    (b occ-key capacity actor observed-actors expected)
+    (ev-acquire-with-observed
+      b
+      occ-key
+      capacity
+      actor
+      observed-actors
+      expected
+      :hold :held)))
+
+;; ---- state transitions / seat-freeing writes (no oversell, append direct) ----
+
+;; Confirm a held seat (payment succeeded). :confirmed on success,
+;; :already-confirmed if it was confirmed, :not-held otherwise.
+(define
+  ev/confirm!
+  (fn
+    (b occ-key actor)
+    (let
+      ((st (ev/seat-state b occ-key actor)))
+      (cond
+        ((= st :held)
+          (begin
+            (persist/append
+              b
+              (ev-booking-stream occ-key)
+              :confirm 0
+              {:actor actor})
+            {:actor actor :status :confirmed}))
+        ((= st :confirmed) {:actor actor :status :already-confirmed})
+        (else {:actor actor :status :not-held})))))
+
+;; Release a held seat (payment failed/expired), freeing it. Only valid for a
+;; held seat — confirmed bookings are given up via ev/cancel!.
+(define
+  ev/release!
+  (fn
+    (b occ-key actor)
+    (let
+      ((st (ev/seat-state b occ-key actor)))
+      (if
+        (= st :held)
+        (begin
+          (persist/append
+            b
+            (ev-booking-stream occ-key)
+            :release 0
+            {:actor actor})
+          {:actor actor :status :released})
+        {:actor actor :status :not-held}))))
+
+;; Cancel a held or confirmed seat, freeing it. :cancelled or :not-booked.
+(define
+  ev/cancel!
+  (fn
+    (b occ-key actor)
+    (if
+      (ev-bk-member? actor (ev-booked-actors b occ-key))
+      (begin
+        (persist/append
+          b
+          (ev-booking-stream occ-key)
+          :cancel 0
+          {:actor actor})
+        {:actor actor :status :cancelled})
+      {:actor actor :status :not-booked})))
+
+;; The roster as a plain list of actors (oldest active first).
+(define ev/roster (fn (b occ-key) (ev-booked-actors b occ-key)))
+
+;; Seats remaining for an occurrence of the given capacity.
+(define
+  ev/seats-left
+  (fn
+    (b occ-key capacity)
+    (max 0 (- capacity (ev-booking-count b occ-key)))))
+
+;; ---- waitlist ----
+;; When an occurrence is full, actors join a FIFO waitlist (:waitlist /
+;; :unwaitlist events on the same stream). Taking a seat (:booking / :hold)
+;; removes an actor from the queue, so the waitlist fold is independent of the
+;; seat fold. Cancelling/releasing a seat can auto-promote the head of the
+;; queue (a :booking appended for them).
+
+(define
+  ev-fold-waiting
+  (fn
+    (events)
+    (reduce
+      (fn
+        (acc e)
+        (let
+          ((typ (persist/event-type e))
+            (actor (get (persist/event-data e) :actor)))
+          (cond
+            ((= typ :waitlist) (if (ev-bk-member? actor acc) acc (ev-bk-append acc actor)))
+            ((= typ :unwaitlist) (ev-bk-remove acc actor))
+            ((= typ :booking) (ev-bk-remove acc actor))
+            ((= typ :hold) (ev-bk-remove acc actor))
+            (else acc))))
+      (list)
+      events)))
+
+;; The current waitlist queue (FIFO, oldest first).
+(define
+  ev/waitlist
+  (fn (b occ-key) (ev-fold-waiting (persist/read b (ev-booking-stream occ-key)))))
+
+;; 1-based queue position for an actor (0 if not waiting).
+(define
+  ev/waitlist-position
+  (fn (b occ-key actor) (ev-seat-of (ev/waitlist b occ-key) actor)))
+
+;; Book if a seat is free, else join the waitlist. Idempotent: already seated →
+;; :already; already queued → :already-waiting.
+(define
+  ev/waitlist!
+  (fn
+    (b occ-key capacity actor)
+    (let
+      ((seats (ev-booked-actors b occ-key))
+        (waiting (ev/waitlist b occ-key)))
+      (cond
+        ((ev-bk-member? actor seats)
+          {:status :already :seat (ev-seat-of seats actor) :actor actor})
+        ((ev-bk-member? actor waiting)
+          {:status :already-waiting :position (ev-seat-of waiting actor) :actor actor})
+        (else
+          (let
+            ((r (ev/book! b occ-key capacity actor)))
+            (if
+              (= (get r :status) :booked)
+              r
+              (begin
+                (persist/append b (ev-booking-stream occ-key) :waitlist 0 {:actor actor})
+                {:status :waitlisted
+                  :position (+ (len waiting) 1)
+                  :actor actor}))))))))
+
+;; Leave the waitlist. :left or :not-waiting.
+(define
+  ev/leave-waitlist!
+  (fn
+    (b occ-key actor)
+    (if
+      (ev-bk-member? actor (ev/waitlist b occ-key))
+      (begin
+        (persist/append b (ev-booking-stream occ-key) :unwaitlist 0 {:actor actor})
+        {:status :left :actor actor})
+      {:status :not-waiting :actor actor})))
+
+;; Cancel a seat and, if that frees capacity, auto-promote the head of the
+;; waitlist (a confirmed booking). Returns the cancel result plus :promoted
+;; (the actor promoted, or nil).
+(define
+  ev/cancel-promote!
+  (fn
+    (b occ-key capacity actor)
+    (let
+      ((c (ev/cancel! b occ-key actor)))
+      (if
+        (= (get c :status) :cancelled)
+        (let
+          ((waiting (ev/waitlist b occ-key))
+            (seats (ev-booked-actors b occ-key)))
+          (if
+            (and (not (empty? waiting)) (< (len seats) capacity))
+            (let
+              ((promoted (first waiting)))
+              (begin
+                (persist/append b (ev-booking-stream occ-key) :booking 0 {:actor promoted})
+                {:status :cancelled :actor actor :promoted promoted}))
+            {:status :cancelled :actor actor :promoted nil}))
+        c))))

lib/events/calendar.sx

@@ -0,0 +1,614 @@
+;; lib/events/calendar.sx — civil date arithmetic + RRULE expansion in a window.
+;;
+;; Datetimes are integer "epoch minutes": days-since-1970-01-01 * 1440 plus
+;; minute-of-day. Ordering, window bounds, and durations are plain integer
+;; arithmetic. Civil <-> day-number conversion uses Howard Hinnant's algorithm
+;; (exact, branch-free, correct for the proleptic Gregorian calendar).
+;;
+;; RRULE expansion is the bridge to Datalog: a recurring event expands to a
+;; bounded list of occurrence dicts within an explicit (win-start, win-end)
+;; window. Expansion is ALWAYS windowed — an RRULE without a window is an
+;; infinite computation and is never permitted. Supported subset (RFC 5545):
+;; FREQ=DAILY|WEEKLY|MONTHLY, INTERVAL, COUNT, UNTIL, BYDAY (weekly: weekday
+;; numbers; monthly: {:ord N :wd W} ordinal weekdays), BYMONTHDAY (monthly,
+;; negative = from month end). YEARLY and the rest are deferred.
+
+;; ---- integer helpers ----
+
+;; Floored integer division (modulo is already floored, so the remainder
+;; subtraction makes the quotient exact and floor-correct for any sign).
+(define ev-floor-div (fn (a b) (quotient (- a (modulo a b)) b)))
+
+(define ev-or (fn (x d) (if (nil? x) d x)))
+
+(define ev-filter-nil (fn (xs) (filter (fn (x) (not (nil? x))) xs)))
+
+;; ---- civil date core (Hinnant) ----
+
+;; Days since 1970-01-01 for civil (y, m, d). m in [1,12], d in [1,31].
+(define
+  ev-days-from-civil
+  (fn
+    (y0 m d)
+    (let
+      ((y (if (<= m 2) (- y0 1) y0)))
+      (let
+        ((era (ev-floor-div (if (>= y 0) y (- y 399)) 400)))
+        (let
+          ((yoe (- y (* era 400)))
+            (doy
+              (+
+                (ev-floor-div
+                  (+
+                    (*
+                      153
+                      (+ m (if (> m 2) -3 9)))
+                    2)
+                  5)
+                (- d 1))))
+          (let
+            ((doe (+ (* yoe 365) (ev-floor-div yoe 4) (- (ev-floor-div yoe 100)) doy)))
+            (+ (* era 146097) doe -719468)))))))
+
+;; Civil (y m d) list from a day-number.
+(define
+  ev-civil-from-days
+  (fn
+    (z0)
+    (let
+      ((z (+ z0 719468)))
+      (let
+        ((era (ev-floor-div (if (>= z 0) z (- z 146096)) 146097)))
+        (let
+          ((doe (- z (* era 146097))))
+          (let
+            ((yoe (ev-floor-div (+ (- doe (ev-floor-div doe 1460)) (ev-floor-div doe 36524) (- (ev-floor-div doe 146096))) 365)))
+            (let
+              ((y (+ yoe (* era 400)))
+                (doy
+                  (-
+                    doe
+                    (+
+                      (* 365 yoe)
+                      (ev-floor-div yoe 4)
+                      (- (ev-floor-div yoe 100))))))
+              (let
+                ((mp (ev-floor-div (+ (* 5 doy) 2) 153)))
+                (let
+                  ((d (+ (- doy (ev-floor-div (+ (* 153 mp) 2) 5)) 1))
+                    (m
+                      (if
+                        (< mp 10)
+                        (+ mp 3)
+                        (- mp 9))))
+                  (list (if (<= m 2) (+ y 1) y) m d))))))))))
+
+;; Weekday of a day-number: 0=Mon .. 6=Sun (1970-01-01 is Thursday = 3).
+(define ev-weekday-of-days (fn (z) (modulo (+ z 3) 7)))
+
+(define
+  ev-days-in-month
+  (fn
+    (y m)
+    (-
+      (ev-days-from-civil
+        (if (= m 12) (+ y 1) y)
+        (if (= m 12) 1 (+ m 1))
+        1)
+      (ev-days-from-civil y m 1))))
+
+;; Add k months to (y,m), returning (list y2 m2).
+(define
+  ev-add-months
+  (fn
+    (y m k)
+    (let
+      ((total (+ (* y 12) (- m 1) k)))
+      (list
+        (ev-floor-div total 12)
+        (+ (modulo total 12) 1)))))
+
+;; ---- datetime (epoch minutes) ----
+
+(define
+  ev-dt
+  (fn
+    (y m d hh mm)
+    (+ (* (ev-days-from-civil y m d) 1440) (* hh 60) mm)))
+
+(define ev-date (fn (y m d) (ev-dt y m d 0 0)))
+
+(define ev-dt->days (fn (t) (ev-floor-div t 1440)))
+
+(define ev-dt->civil (fn (t) (ev-civil-from-days (ev-dt->days t))))
+
+(define ev-dt-weekday (fn (t) (ev-weekday-of-days (ev-dt->days t))))
+
+(define ev-dt-tod (fn (t) (modulo t 1440)))
+
+(define ev-civ-y (fn (c) (first c)))
+(define ev-civ-m (fn (c) (first (rest c))))
+(define ev-civ-d (fn (c) (first (rest (rest c)))))
+
+;; ---- event + occurrence constructors ----
+
+;; rrule is nil (single event) or a dict:
+;;   {:freq :daily|:weekly|:monthly :interval N :count N|nil :until DT|nil
+;;    :byday ...|nil :bymonthday (list 15 -1)|nil}
+;;   weekly  :byday -> (list 0 2 4)            weekday numbers, 0=Mon
+;;   monthly :byday -> (list {:ord 2 :wd 1})   nth weekday (ord<0 from end)
+;;   monthly :bymonthday -> (list 15 -1)       day of month (negative from end)
+(define ev-event (fn (id dtstart duration rrule capacity) {:duration duration :id id :dtstart dtstart :capacity capacity :rrule rrule}))
+
+;; Event with EXDATE/RDATE exceptions. exdate/rdate are lists of epoch-minute
+;; starts to exclude from / add to the expansion (RFC 5545 VEVENT properties).
+(define
+  ev-event-full
+  (fn
+    (id dtstart duration rrule capacity exdate rdate)
+    {:duration duration
+      :id id
+      :dtstart dtstart
+      :capacity capacity
+      :rrule rrule
+      :exdate exdate
+      :rdate rdate}))
+
+(define ev-occ (fn (id start dur) {:id id :start start :end (+ start dur)}))
+
+;; ---- DAILY expansion ----
+;; occ starts at dtstart; n counts every generated occurrence (window-
+;; independent, so COUNT/UNTIL bound the rule, not the view). Emits only
+;; occurrences inside [win-start, win-end].
+(define
+  ev-daily-loop
+  (fn
+    (id occ duration step count until dtstart win-start win-end acc n)
+    (cond
+      ((> occ win-end) acc)
+      ((and (not (nil? count)) (>= n count)) acc)
+      ((and (not (nil? until)) (> occ until)) acc)
+      (else
+        (begin
+          (when (>= occ win-start) (append! acc (ev-occ id occ duration)))
+          (ev-daily-loop
+            id
+            (+ occ step)
+            duration
+            step
+            count
+            until
+            dtstart
+            win-start
+            win-end
+            acc
+            (+ n 1)))))))
+
+;; ---- shared per-period emit ----
+;; Walk a start-ascending list of candidate occurrence datetimes for one
+;; period, generating (count toward COUNT) those >= dtstart within UNTIL, and
+;; emitting those also inside the window. Returns the updated running n.
+(define
+  ev-emit-occs
+  (fn
+    (id occs duration count until dtstart win-start win-end acc n)
+    (if
+      (empty? occs)
+      n
+      (let
+        ((occ (first occs)))
+        (let
+          ((generates? (and (>= occ dtstart) (or (nil? until) (<= occ until)) (or (nil? count) (< n count)))))
+          (begin
+            (when
+              (and generates? (>= occ win-start) (<= occ win-end))
+              (append! acc (ev-occ id occ duration)))
+            (ev-emit-occs
+              id
+              (rest occs)
+              duration
+              count
+              until
+              dtstart
+              win-start
+              win-end
+              acc
+              (if generates? (+ n 1) n))))))))
+
+;; ---- WEEKLY expansion ----
+;; Iterate week by week from the Monday of dtstart's week; within each active
+;; week emit each BYDAY (sorted). n counts every generated occurrence.
+
+(define
+  ev-week0-days
+  (fn (dtstart) (- (ev-dt->days dtstart) (ev-dt-weekday dtstart))))
+
+(define
+  ev-byday-default
+  (fn
+    (byday dtstart)
+    (if (nil? byday) (list (ev-dt-weekday dtstart)) (sort byday))))
+
+(define
+  ev-weekly-loop
+  (fn
+    (id
+      week-days
+      tod
+      duration
+      week-step
+      bd
+      count
+      until
+      dtstart
+      win-start
+      win-end
+      acc
+      n)
+    (let
+      ((week-start-dt (* week-days 1440)))
+      (cond
+        ((> week-start-dt win-end) acc)
+        ((and (not (nil? count)) (>= n count)) acc)
+        (else
+          (let
+            ((occs (map (fn (wd) (+ (* (+ week-days wd) 1440) tod)) bd)))
+            (let
+              ((n2 (ev-emit-occs id occs duration count until dtstart win-start win-end acc n)))
+              (ev-weekly-loop
+                id
+                (+ week-days week-step)
+                tod
+                duration
+                week-step
+                bd
+                count
+                until
+                dtstart
+                win-start
+                win-end
+                acc
+                n2))))))))
+
+;; ---- MONTHLY expansion ----
+;; Iterate month by month from dtstart's month, stepping by INTERVAL months.
+;; Candidate days per month come from BYMONTHDAY, then ordinal BYDAY, else the
+;; day-of-month of dtstart (skipped in months too short to contain it).
+
+;; Resolve a BYMONTHDAY value to a valid day-of-month, or nil.
+(define
+  ev-resolve-monthday
+  (fn
+    (y m bmd)
+    (let
+      ((dim (ev-days-in-month y m)))
+      (let
+        ((day (if (< bmd 0) (+ dim 1 bmd) bmd)))
+        (if (and (>= day 1) (<= day dim)) day nil)))))
+
+;; Resolve an ordinal weekday {:ord :wd} to a day-of-month, or nil.
+(define
+  ev-resolve-nth-weekday
+  (fn
+    (y m ord wd)
+    (let
+      ((dim (ev-days-in-month y m)))
+      (if
+        (> ord 0)
+        (let
+          ((first-wd (ev-weekday-of-days (ev-days-from-civil y m 1))))
+          (let
+            ((day (+ 1 (modulo (- wd first-wd) 7) (* (- ord 1) 7))))
+            (if (<= day dim) day nil)))
+        (let
+          ((last-wd (ev-weekday-of-days (ev-days-from-civil y m dim))))
+          (let
+            ((day (- dim (modulo (- last-wd wd) 7) (* (- (- ord) 1) 7))))
+            (if (>= day 1) day nil)))))))
+
+(define
+  ev-month-candidates
+  (fn
+    (y m rrule dtstart)
+    (let
+      ((bmd (get rrule :bymonthday)) (byday (get rrule :byday)))
+      (cond
+        ((not (nil? bmd))
+          (ev-filter-nil (map (fn (d) (ev-resolve-monthday y m d)) bmd)))
+        ((not (nil? byday))
+          (ev-filter-nil
+            (map
+              (fn
+                (e)
+                (ev-resolve-nth-weekday y m (get e :ord) (get e :wd)))
+              byday)))
+        (else
+          (ev-filter-nil
+            (list
+              (ev-resolve-monthday y m (ev-civ-d (ev-dt->civil dtstart))))))))))
+
+(define
+  ev-monthly-loop
+  (fn
+    (id
+      y
+      m
+      rrule
+      duration
+      tod
+      interval
+      count
+      until
+      dtstart
+      win-start
+      win-end
+      acc
+      n)
+    (let
+      ((month-start (ev-dt y m 1 0 0)))
+      (cond
+        ((> month-start win-end) acc)
+        ((and (not (nil? count)) (>= n count)) acc)
+        (else
+          (let
+            ((days (sort (ev-month-candidates y m rrule dtstart))))
+            (let
+              ((occs (map (fn (d) (+ (* (ev-days-from-civil y m d) 1440) tod)) days)))
+              (let
+                ((n2 (ev-emit-occs id occs duration count until dtstart win-start win-end acc n))
+                  (nm (ev-add-months y m interval)))
+                (ev-monthly-loop
+                  id
+                  (ev-civ-y nm)
+                  (ev-civ-m nm)
+                  rrule
+                  duration
+                  tod
+                  interval
+                  count
+                  until
+                  dtstart
+                  win-start
+                  win-end
+                  acc
+                  n2)))))))))
+
+;; ---- top-level expansion ----
+;; Raw expansion (RRULE / single event), before EXDATE/RDATE are applied.
+;; Returns a list of occurrence dicts {:id :start :end} within the window.
+(define
+  ev-expand-base
+  (fn
+    (event win-start win-end)
+    (let
+      ((id (get event :id))
+        (dtstart (get event :dtstart))
+        (duration (get event :duration))
+        (rrule (get event :rrule)))
+      (if
+        (nil? rrule)
+        (if
+          (and (>= dtstart win-start) (<= dtstart win-end))
+          (list (ev-occ id dtstart duration))
+          (list))
+        (let
+          ((freq (get rrule :freq))
+            (interval (ev-or (get rrule :interval) 1))
+            (count (get rrule :count))
+            (until (get rrule :until))
+            (byday (get rrule :byday))
+            (acc (list)))
+          (begin
+            (cond
+              ((= freq :daily)
+                (ev-daily-loop
+                  id
+                  dtstart
+                  duration
+                  (* interval 1440)
+                  count
+                  until
+                  dtstart
+                  win-start
+                  win-end
+                  acc
+                  0))
+              ((= freq :weekly)
+                (ev-weekly-loop
+                  id
+                  (ev-week0-days dtstart)
+                  (ev-dt-tod dtstart)
+                  duration
+                  (* interval 7)
+                  (ev-byday-default byday dtstart)
+                  count
+                  until
+                  dtstart
+                  win-start
+                  win-end
+                  acc
+                  0))
+              ((= freq :monthly)
+                (let
+                  ((civ (ev-dt->civil dtstart)))
+                  (ev-monthly-loop
+                    id
+                    (ev-civ-y civ)
+                    (ev-civ-m civ)
+                    rrule
+                    duration
+                    (ev-dt-tod dtstart)
+                    interval
+                    count
+                    until
+                    dtstart
+                    win-start
+                    win-end
+                    acc
+                    0)))
+              (else (error (str "ev-expand-base: unsupported freq: " freq))))
+            acc))))))
+
+;; ---- EXDATE / RDATE (RFC 5545 exceptions) ----
+;; Applied AFTER raw expansion: RDATE adds explicit occurrences within the
+;; window, EXDATE removes occurrences whose start matches (EXDATE wins over
+;; RDATE). Both are VEVENT-level: (get event :exdate) / (get event :rdate) are
+;; lists of epoch-minute starts; nil for plain events.
+
+(define
+  ev-num-member?
+  (fn
+    (n xs)
+    (cond
+      ((empty? xs) false)
+      ((= n (first xs)) true)
+      (else (ev-num-member? n (rest xs))))))
+
+;; Drop duplicate-start occurrences from a start-sorted list (keep one).
+(define
+  ev-dedupe-by-start
+  (fn
+    (occs)
+    (cond
+      ((empty? occs) occs)
+      ((empty? (rest occs)) occs)
+      ((= (get (first occs) :start) (get (first (rest occs)) :start))
+        (ev-dedupe-by-start (rest occs)))
+      (else (cons (first occs) (ev-dedupe-by-start (rest occs)))))))
+
+(define
+  ev-apply-exceptions
+  (fn
+    (event base win-start win-end)
+    (let
+      ((id (get event :id))
+        (duration (get event :duration))
+        (exdate (ev-or (get event :exdate) (list)))
+        (rdate (ev-or (get event :rdate) (list))))
+      (let
+        ((rdate-occs
+           (reduce
+             (fn
+               (acc d)
+               (if
+                 (and (>= d win-start) (<= d win-end))
+                 (cons (ev-occ id d duration) acc)
+                 acc))
+             (list)
+             rdate)))
+        (let
+          ((no-ex
+             (filter
+               (fn (o) (not (ev-num-member? (get o :start) exdate)))
+               (append base rdate-occs))))
+          (ev-dedupe-by-start (ev-sort-occs no-ex)))))))
+
+;; ---- per-occurrence overrides (RFC 5545 RECURRENCE-ID) ----
+;; A single instance of a recurring series can be detached and rescheduled. The
+;; event carries :overrides — a list of (orig-start {:start :duration}) — keyed
+;; by the occurrence's ORIGINAL start. Applied after EXDATE/RDATE. A moved
+;; instance whose new start leaves the window is dropped from this window (the
+;; original slot is vacated); an instance moved INTO the window from outside is
+;; out of scope for a windowed expansion (known stub limitation).
+
+(define
+  ev-assoc-lookup
+  (fn
+    (k pairs)
+    (cond
+      ((empty? pairs) nil)
+      ((= (first (first pairs)) k) (first (rest (first pairs))))
+      (else (ev-assoc-lookup k (rest pairs))))))
+
+(define
+  ev-apply-overrides
+  (fn
+    (id base overrides)
+    (map
+      (fn
+        (o)
+        (let
+          ((ov (ev-assoc-lookup (get o :start) overrides)))
+          (if (nil? ov) o (ev-occ id (get ov :start) (get ov :duration)))))
+      base)))
+
+;; Add an override that reschedules the occurrence originally at `orig-start`
+;; to `new-start` with `new-duration`.
+(define
+  ev-with-override
+  (fn
+    (event orig-start new-start new-duration)
+    (assoc
+      event
+      :overrides
+      (cons
+        (list orig-start {:start new-start :duration new-duration})
+        (ev-or (get event :overrides) (list))))))
+
+;; Naive (single time-domain) expansion: RRULE + EXDATE/RDATE + overrides.
+(define
+  ev-expand-naive
+  (fn
+    (event win-start win-end)
+    (let
+      ((excepted
+         (ev-apply-exceptions
+           event
+           (ev-expand-base event win-start win-end)
+           win-start
+           win-end))
+        (overrides (ev-or (get event :overrides) (list)))
+        (id (get event :id)))
+      (if
+        (empty? overrides)
+        excepted
+        (filter
+          (fn (o) (and (>= (get o :start) win-start) (<= (get o :start) win-end)))
+          (ev-sort-occs (ev-apply-overrides id excepted overrides)))))))
+
+;; Public entry point. A tz-aware event (`:tz` set) expands in local wall-clock
+;; time and converts each occurrence to UTC (ev-expand-tz, timezone.sx); a plain
+;; event expands naively in a single time domain. The window is UTC either way.
+(define
+  ev-expand
+  (fn
+    (event win-start win-end)
+    (let
+      ((tz (get event :tz)))
+      (if
+        (nil? tz)
+        (ev-expand-naive event win-start win-end)
+        (ev-expand-tz event tz win-start win-end)))))
+
+;; ---- multi-event expansion (sorted by start) ----
+
+;; Insertion of one occurrence into a start-ascending list.
+(define
+  ev-occ-insert
+  (fn
+    (o sorted)
+    (cond
+      ((empty? sorted) (list o))
+      ((<= (get o :start) (get (first sorted) :start)) (cons o sorted))
+      (else (cons (first sorted) (ev-occ-insert o (rest sorted)))))))
+
+(define
+  ev-sort-occs
+  (fn (occs) (reduce (fn (acc o) (ev-occ-insert o acc)) (list) occs)))
+
+;; Expand many events into one occurrence list, ascending by start.
+(define
+  ev-expand-all
+  (fn
+    (events win-start win-end)
+    (let
+      ((acc (list)))
+      (begin
+        (for-each
+          (fn
+            (ev)
+            (for-each
+              (fn (o) (append! acc o))
+              (ev-expand ev win-start win-end)))
+          events)
+        (ev-sort-occs acc)))))

lib/events/conformance.conf

@@ -0,0 +1,61 @@
+# events-on-sx conformance config — sourced by lib/guest/conformance.sh.
+
+LANG_NAME=events
+MODE=dict
+SCOREBOARD_DIR=lib/events
+
+PRELOADS=(
+  spec/stdlib.sx
+  lib/r7rs.sx
+  lib/datalog/tokenizer.sx
+  lib/datalog/parser.sx
+  lib/datalog/unify.sx
+  lib/datalog/db.sx
+  lib/datalog/builtins.sx
+  lib/datalog/aggregates.sx
+  lib/datalog/strata.sx
+  lib/datalog/eval.sx
+  lib/datalog/api.sx
+  lib/datalog/magic.sx
+  lib/events/calendar.sx
+  lib/events/timezone.sx
+  lib/events/availability.sx
+  lib/persist/event.sx
+  lib/persist/backend.sx
+  lib/persist/log.sx
+  lib/persist/kv.sx
+  lib/persist/concurrency.sx
+  lib/persist/api.sx
+  lib/events/booking.sx
+  lib/events/booking-notify.sx
+  lib/events/ticket.sx
+  lib/guest/lex.sx
+  lib/guest/reflective/env.sx
+  lib/guest/reflective/quoting.sx
+  lib/scheme/parser.sx
+  lib/scheme/eval.sx
+  lib/scheme/runtime.sx
+  lib/flow/spec.sx
+  lib/flow/store.sx
+  lib/flow/remote.sx
+  lib/flow/host.sx
+  lib/flow/api.sx
+  lib/events/notify.sx
+  lib/events/api.sx
+  lib/events/reminders.sx
+  lib/events/federation.sx
+)
+
+SUITES=(
+  "calendar:lib/events/tests/calendar.sx:(ev-calendar-tests-run!)"
+  "timezone:lib/events/tests/timezone.sx:(ev-timezone-tests-run!)"
+  "availability:lib/events/tests/availability.sx:(ev-availability-tests-run!)"
+  "api:lib/events/tests/api.sx:(ev-api-tests-run!)"
+  "booking:lib/events/tests/booking.sx:(ev-booking-tests-run!)"
+  "booking-notify:lib/events/tests/booking-notify.sx:(ev-booking-notify-tests-run!)"
+  "ticket:lib/events/tests/ticket.sx:(ev-ticket-tests-run!)"
+  "notify:lib/events/tests/notify.sx:(ev-notify-tests-run!)"
+  "reminders:lib/events/tests/reminders.sx:(ev-reminders-tests-run!)"
+  "federation:lib/events/tests/federation.sx:(ev-federation-tests-run!)"
+  "integration:lib/events/tests/integration.sx:(ev-integration-tests-run!)"
+)

lib/events/conformance.sh

@@ -0,0 +1,3 @@
+#!/usr/bin/env bash
+# Thin wrapper — see lib/guest/conformance.sh and lib/events/conformance.conf.
+exec bash "$(dirname "$0")/../guest/conformance.sh" "$(dirname "$0")/conformance.conf" "$@"

lib/events/federation.sx

@@ -0,0 +1,232 @@
+;; lib/events/federation.sx — cross-instance calendar federation (trust-gated).
+;;
+;; A peer is another events instance that publishes a schedule (an events
+;; store). We merge a peer's agenda into ours ONLY if we trust it — trust is a
+;; set of peer ids, re-checked on every merge, so revoking a peer takes effect
+;; immediately. Merged occurrences carry :origin provenance (:local for ours, or
+;; the peer id) so a consumer always knows where a slot came from.
+;;
+;; This is the trust-gated stub: peers publish plain schedules and we fold the
+;; trusted ones into a single sorted agenda. Real transport (fed-sx / signed
+;; fetch) slots in behind `ev/peer-agenda` without changing the merge.
+;;
+;; Federated FREE/BUSY follows the iCal model: a peer publishes BUSY intervals
+;; for an actor (not event details — privacy-preserving), and we union local +
+;; trusted-peer busy to answer "is this actor free?" across instances.
+
+(define ev/peer (fn (id store) {:id id :busy (list) :store store}))
+
+;; A peer that also publishes free/busy: `busy` is a list of
+;; (actor ((start end) ...)) pairs.
+(define ev/peer-with-busy (fn (id store busy) {:id id :busy busy :store store}))
+
+(define ev/peer-id (fn (p) (get p :id)))
+(define ev/peer-store (fn (p) (get p :store)))
+(define ev/peer-busy-table (fn (p) (get p :busy)))
+
+(define
+  ev-fed-member?
+  (fn
+    (x xs)
+    (cond
+      ((empty? xs) false)
+      ((= x (first xs)) true)
+      (else (ev-fed-member? x (rest xs))))))
+
+;; Do we trust this peer id? (trust is a list of trusted peer ids.)
+(define ev/trusts? (fn (trust peer-id) (ev-fed-member? peer-id trust)))
+
+;; The trusted subset of a peer list.
+(define
+  ev/trusted-peers
+  (fn
+    (peers trust)
+    (filter (fn (p) (ev/trusts? trust (ev/peer-id p))) peers)))
+
+;; Tag occurrences with provenance.
+(define ev-tag-origin (fn (occs origin) (map (fn (o) {:id (get o :id) :start (get o :start) :end (get o :end) :origin origin}) occs)))
+
+;; A peer's agenda over [ws, we), tagged with the peer's id as :origin.
+(define
+  ev/peer-agenda
+  (fn
+    (peer ws we)
+    (ev-tag-origin (ev/agenda (ev/peer-store peer) ws we) (ev/peer-id peer))))
+
+;; ---- merge (sorted by start, then origin for ties) ----
+
+(define
+  ev-fed-before?
+  (fn
+    (a c)
+    (cond
+      ((< (get a :start) (get c :start)) true)
+      ((> (get a :start) (get c :start)) false)
+      (else (< (str (get a :origin)) (str (get c :origin)))))))
+
+(define
+  ev-fed-insert
+  (fn
+    (x sorted)
+    (cond
+      ((empty? sorted) (list x))
+      ((ev-fed-before? x (first sorted)) (cons x sorted))
+      (else (cons (first sorted) (ev-fed-insert x (rest sorted)))))))
+
+(define
+  ev-fed-sort
+  (fn (xs) (reduce (fn (acc x) (ev-fed-insert x acc)) (list) xs)))
+
+;; Local agenda (origin :local) merged with every TRUSTED peer's agenda,
+;; sorted by start. Untrusted peers contribute nothing.
+(define
+  ev/federated-agenda
+  (fn
+    (local-store peers trust ws we)
+    (let
+      ((acc (list)))
+      (begin
+        (for-each
+          (fn (o) (append! acc o))
+          (ev-tag-origin (ev/agenda local-store ws we) :local))
+        (for-each
+          (fn
+            (peer)
+            (when
+              (ev/trusts? trust (ev/peer-id peer))
+              (for-each
+                (fn (o) (append! acc o))
+                (ev/peer-agenda peer ws we))))
+          peers)
+        (ev-fed-sort acc)))))
+
+;; Filter a federated agenda to occurrences from one origin.
+(define
+  ev/from-origin
+  (fn
+    (agenda origin)
+    (filter (fn (o) (= (get o :origin) origin)) agenda)))
+
+;; ---- federated free/busy ----
+
+;; A peer's published busy intervals for `actor` ((start end) ...), or empty.
+(define
+  ev/peer-busy
+  (fn
+    (peer actor)
+    (let
+      ((row (ev-fed-assoc actor (ev/peer-busy-table peer))))
+      (if (nil? row) (list) (first (rest row))))))
+
+(define
+  ev-fed-assoc
+  (fn
+    (k pairs)
+    (cond
+      ((empty? pairs) nil)
+      ((= (first (first pairs)) k) (first pairs))
+      (else (ev-fed-assoc k (rest pairs))))))
+
+;; All busy intervals for `actor` across the LOCAL availability db plus every
+;; TRUSTED peer's published free/busy, merged and sorted by start.
+;; `local-db` is an availability db (see availability.sx ev-build-avail).
+(define
+  ev/federated-busy
+  (fn
+    (local-db peers trust actor)
+    (let
+      ((acc (list)))
+      (begin
+        (for-each (fn (iv) (append! acc iv)) (ev-busy local-db actor))
+        (for-each
+          (fn
+            (peer)
+            (when
+              (ev/trusts? trust (ev/peer-id peer))
+              (for-each
+                (fn (iv) (append! acc iv))
+                (ev/peer-busy peer actor))))
+          peers)
+        (ev-sort-lists acc)))))
+
+;; Half-open overlap of interval (s e) with window [qs, qe).
+(define
+  ev-fed-overlaps?
+  (fn (iv qs qe) (and (< (first iv) qe) (< qs (first (rest iv))))))
+
+;; Is `actor` free across [qs, qe) considering local + trusted-peer busy?
+(define
+  ev/federated-free?
+  (fn
+    (local-db peers trust actor qs qe)
+    (not
+      (some
+        (fn (iv) (ev-fed-overlaps? iv qs qe))
+        (ev/federated-busy local-db peers trust actor)))))
+
+;; ---- injected transport (real fed-sx / signed fetch) ----
+;; The in-process merge above expands a peer's local :store directly. In
+;; production a peer's agenda arrives over a transport. `fetch` abstracts that:
+;;   (fetch peer-id ws we) -> {:status :ok :occurrences (...)} | {:status :error :reason ...}
+;; The same merge works for any transport; an unreachable peer (:error) is
+;; skipped (graceful degradation), never breaking the agenda.
+
+(define
+  ev-find-peer
+  (fn
+    (peers pid)
+    (cond
+      ((empty? peers) nil)
+      ((= (ev/peer-id (first peers)) pid) (first peers))
+      (else (ev-find-peer (rest peers) pid)))))
+
+;; In-process transport adapter: resolves a peer-id against a peer list and
+;; expands its :store. Lets the in-process model run through the same `fetch`
+;; interface a remote transport implements.
+(define
+  ev/peer-fetch
+  (fn
+    (peers)
+    (fn
+      (pid ws we)
+      (let
+        ((p (ev-find-peer peers pid)))
+        (if
+          (nil? p)
+          {:status :error :reason :unknown-peer}
+          {:status :ok :occurrences (ev/agenda (ev/peer-store p) ws we)})))))
+
+;; Local agenda (:local) merged with each trusted peer's agenda fetched via the
+;; injected `fetch` transport, sorted by start, tagged with :origin. Peers that
+;; fail to fetch contribute nothing.
+(define
+  ev/federated-agenda-via
+  (fn
+    (local-store trusted-ids ws we fetch)
+    (let
+      ((acc (list)))
+      (begin
+        (for-each
+          (fn (o) (append! acc o))
+          (ev-tag-origin (ev/agenda local-store ws we) :local))
+        (for-each
+          (fn
+            (pid)
+            (let
+              ((res (fetch pid ws we)))
+              (when
+                (= (get res :status) :ok)
+                (for-each
+                  (fn (o) (append! acc o))
+                  (ev-tag-origin (get res :occurrences) pid)))))
+          trusted-ids)
+        (ev-fed-sort acc)))))
+
+;; Reachability report: ((peer-id :ok|:error) ...) for the trusted peers.
+(define
+  ev/federation-status
+  (fn
+    (trusted-ids ws we fetch)
+    (map
+      (fn (pid) (list pid (get (fetch pid ws we) :status)))
+      trusted-ids)))

lib/events/notify.sx

@@ -0,0 +1,97 @@
+;; lib/events/notify.sx — durable notification delivery flows over an injected
+;; transport (lib/flow).
+;;
+;; Reminders and digests are durable `flow`s: a flow `request`s delivery (a
+;; suspend point), the HOST performs the actual send via an injected `dispatch`
+;; (the transport — email/push/etc.), and resumes the flow with the outcome.
+;; Because flow uses deterministic replay, a completed delivery is never re-run
+;; on recovery; the host owns IO and persistence.
+;;
+;; Delivery is AT-LEAST-ONCE with idempotency. Each message carries an id (the
+;; idempotency key). Two protections stop double-delivery:
+;;   1. The transport dedups by id — a re-send of a delivered id is a no-op
+;;      that still reports ok, so a retry never produces two pings.
+;;   2. flow's replay log records each resolved request, so recovery replays the
+;;      logged outcome instead of re-issuing the send.
+;;
+;; Retry/backoff rides flow suspend/resume: each attempt issues a request with a
+;; DISTINCT tag `(deliver <id> <n>)` — distinct tags keep deterministic replay
+;; correct across retries. The dispatch returns (ok info) to finish or
+;; (retry reason) to try again, bounded by `maxn` (then (failed id reason)).
+;;
+;; A message is a 3-element list (id recipient body). The transport is generic
+;; and injected — when feed/notify lands, both consumers share one transport,
+;; so this delivery core is a candidate for extraction to `delivery-on-sx`.
+;;
+;; The Scheme flow source below loads into a flow env (see lib/flow/api.sx).
+;; `ev/notify-run` prepends it to a caller program and evaluates in the shared
+;; flow env.
+
+(define
+  ev-notify-flows-src
+  "(define (ev-msg-id m) (car m))\n   (define (ev-msg-recipient m) (car (cdr m)))\n   (define (ev-msg-body m) (car (cdr (cdr m))))\n   (define (ev-mem x xs)\n     (if (null? xs) #f (if (equal? x (car xs)) #t (ev-mem x (cdr xs)))))\n   (define (ev-notify-attempt m n maxn)\n     (let ((r (request (list (quote deliver) (ev-msg-id m) n) m)))\n       (if (eq? (car r) (quote ok))\n           (list (quote delivered) (ev-msg-id m) n)\n           (if (>= n maxn)\n               (list (quote failed) (ev-msg-id m) (car (cdr r)))\n               (ev-notify-attempt m (+ n 1) maxn)))))\n   (define (ev-deliver-reminder maxn)\n     (flow-node (lambda (m) (ev-notify-attempt m 1 maxn))))\n   (define (ev-digest-step ms maxn)\n     (if (null? ms)\n         (list)\n         (cons (ev-notify-attempt (car ms) 1 maxn)\n               (ev-digest-step (cdr ms) maxn))))\n   (define (ev-deliver-digest maxn)\n     (flow-node (lambda (ms) (ev-digest-step ms maxn))))")
+
+;; Run a Scheme flow program with the notify flows preloaded, in the shared
+;; flow env. Returns the program's value (SX-native).
+(define
+  ev/notify-run
+  (fn (prog) (flow-run (str ev-notify-flows-src "\n" prog))))
+
+;; ---- end-to-end delivery: SX messages -> the notify flow ----
+;; Bridges the SX notification-derivation modules (reminders / booking-notify /
+;; reschedule) to the durable delivery flow. An SX message (id recipient body)
+;; is serialized to s-expression text and spliced into the Scheme program as
+;; quoted data, then the digest flow delivers the batch over an injected
+;; transport. Strings round-trip through the guest Scheme as {:scm-string ...}
+;; boxes; results are unboxed back to plain SX.
+
+;; A default transport (Scheme source): always reports delivered.
+(define ev-notify-ok-transport "(lambda (k p) (list (quote ok) (quote sent)))")
+
+(define
+  ev-notify-join
+  (fn
+    (parts sep)
+    (if
+      (empty? parts)
+      ""
+      (reduce (fn (acc p) (str acc sep p)) (first parts) (rest parts)))))
+
+(define ev-msg->quoted (fn (m) (str "(quote " (serialize m) ")")))
+
+(define
+  ev-msgs->scheme
+  (fn
+    (msgs)
+    (str "(list " (ev-notify-join (map ev-msg->quoted msgs) " ") ")")))
+
+(define
+  ev-unbox-str
+  (fn
+    (x)
+    (if (and (dict? x) (has-key? x :scm-string)) (get x :scm-string) x)))
+
+(define
+  ev-unbox-result
+  (fn (r) (map (fn (item) (map ev-unbox-str item)) r)))
+
+;; Deliver a list of SX messages through the digest flow over `transport-src`
+;; (a Scheme (kind payload) -> (ok ..)|(retry reason) lambda source). `maxn`
+;; bounds retries per message, `maxticks` bounds host service ticks. Returns the
+;; per-message outcomes unboxed: (("delivered"|"failed" <id> <n-or-reason>) ...)
+(define
+  ev/deliver-messages
+  (fn
+    (msgs transport-src maxn maxticks)
+    (ev-unbox-result
+      (ev/notify-run
+        (str
+          "(define msgs "
+          (ev-msgs->scheme msgs)
+          ") (if (null? msgs) (list) (let ((s (flow/start (ev-deliver-digest "
+          maxn
+          ") msgs))) (begin (flow-run-host "
+          transport-src
+          " "
+          maxticks
+          ") (flow/result (car (cdr s))))))")))))

lib/events/reminders.sx

@@ -0,0 +1,147 @@
+;; lib/events/reminders.sx — derive reminder + digest messages from the agenda.
+;;
+;; Bridges the schedule (calendar) and the durable roster (booking on persist)
+;; to the notification layer (notify.sx). For each booked attendee of each
+;; upcoming occurrence we derive a reminder message that fires `lead` minutes
+;; before the occurrence starts. Each message has a deterministic idempotency
+;; key — occ-key / recipient / lead — so re-deriving over an overlapping window
+;; never produces a duplicate ping (the notify transport dedups on this id).
+;;
+;; A reminder is a dict:
+;;   {:id :recipient :event :start :fire-at}
+;; `ev/reminder->msg` projects it to notify's (id recipient body) wire shape.
+
+;; Reminders for one occurrence: one per booked attendee (durable roster).
+(define
+  ev/occurrence-reminders
+  (fn
+    (b occ lead)
+    (let
+      ((occ-key (ev-occ-key occ))
+        (start (get occ :start))
+        (evid (get occ :id)))
+      (map (fn (actor) {:id (str occ-key "/" actor "/" lead) :event evid :start start :fire-at (- start lead) :recipient actor}) (ev/roster-occ b occ)))))
+
+;; Insertion sort of reminder dicts ascending by :fire-at (then :id for ties).
+(define
+  ev-rem-before?
+  (fn
+    (a c)
+    (cond
+      ((< (get a :fire-at) (get c :fire-at)) true)
+      ((> (get a :fire-at) (get c :fire-at)) false)
+      (else (< (get a :id) (get c :id))))))
+
+(define
+  ev-rem-insert
+  (fn
+    (r sorted)
+    (cond
+      ((empty? sorted) (list r))
+      ((ev-rem-before? r (first sorted)) (cons r sorted))
+      (else (cons (first sorted) (ev-rem-insert r (rest sorted)))))))
+
+(define
+  ev-rem-sort
+  (fn (rs) (reduce (fn (acc r) (ev-rem-insert r acc)) (list) rs)))
+
+;; All reminders across the agenda in [ws, we), ascending by fire-at.
+(define
+  ev/agenda-reminders
+  (fn
+    (b store ws we lead)
+    (let
+      ((acc (list)))
+      (begin
+        (for-each
+          (fn
+            (occ)
+            (for-each
+              (fn (r) (append! acc r))
+              (ev/occurrence-reminders b occ lead)))
+          (ev/agenda store ws we))
+        (ev-rem-sort acc)))))
+
+;; Reminders whose fire-at has arrived (fire-at <= now) — what a scheduler
+;; should hand to the notify transport at time `now`.
+(define
+  ev/due-reminders
+  (fn
+    (reminders now)
+    (filter (fn (r) (<= (get r :fire-at) now)) reminders)))
+
+;; Project a reminder to notify's (id recipient body) wire shape.
+(define
+  ev/reminder->msg
+  (fn
+    (r)
+    (list
+      (get r :id)
+      (get r :recipient)
+      (list :reminder (get r :event) (get r :start)))))
+
+;; ---- digests ----
+
+;; The occurrences `actor` is booked into (durable roster), within window.
+(define
+  ev/agenda-for-p
+  (fn
+    (b store actor ws we)
+    (filter
+      (fn (occ) (ev-bk-member? actor (ev/roster-occ b occ)))
+      (ev/agenda store ws we))))
+
+;; A single digest message summarising an actor's upcoming booked occurrences.
+;; :items is ({:event :start} ...); empty when the actor has nothing booked.
+(define ev/agenda-digest (fn (b store actor ws we) {:items (map (fn (occ) {:event (get occ :id) :start (get occ :start)}) (ev/agenda-for-p b store actor ws we)) :id (str actor "/digest/" ws "-" we) :recipient actor}))
+
+;; ---- reschedule notifications ----
+;; When an event carries per-occurrence overrides (ev-with-override), every
+;; attendee booked at the ORIGINAL start should be told the new time. Bookings
+;; were made against the original occ-key (id@orig-start), so we read that
+;; roster. Idempotency key encodes the original key and the new start, so
+;; re-deriving the same reschedule never double-notifies.
+(define
+  ev/reschedule-notifications
+  (fn
+    (b event)
+    (let
+      ((overrides (ev-or (get event :overrides) (list)))
+        (evid (get event :id))
+        (dur (get event :duration)))
+      (reduce
+        (fn
+          (acc entry)
+          (let
+            ((orig-start (first entry))
+              (ov (first (rest entry))))
+            (let
+              ((occ (ev-occ evid orig-start dur))
+                (new-start (get ov :start))
+                (new-duration (get ov :duration)))
+              (let
+                ((key (ev-occ-key occ)))
+                (append
+                  acc
+                  (map
+                    (fn
+                      (actor)
+                      {:id (str key "/reschedule/" new-start)
+                        :recipient actor
+                        :event evid
+                        :old-start orig-start
+                        :new-start new-start
+                        :new-duration new-duration})
+                    (ev/roster-occ b occ)))))))
+        (list)
+        overrides))))
+
+;; Project a reschedule notification to notify's (id recipient body) shape.
+(define
+  ev/reschedule-notify->msg
+  (fn
+    (r)
+    (list
+      (get r :id)
+      (get r :recipient)
+      (list :rescheduled (get r :event) (get r :old-start) (get r :new-start)))))

lib/events/scoreboard.json

@@ -0,0 +1,20 @@
+{
+  "lang": "events",
+  "total_passed": 311,
+  "total_failed": 0,
+  "total": 311,
+  "suites": [
+    {"name":"calendar","passed":51,"failed":0,"total":51},
+    {"name":"timezone","passed":17,"failed":0,"total":17},
+    {"name":"availability","passed":22,"failed":0,"total":22},
+    {"name":"api","passed":32,"failed":0,"total":32},
+    {"name":"booking","passed":82,"failed":0,"total":82},
+    {"name":"booking-notify","passed":11,"failed":0,"total":11},
+    {"name":"ticket","passed":31,"failed":0,"total":31},
+    {"name":"notify","passed":7,"failed":0,"total":7},
+    {"name":"reminders","passed":21,"failed":0,"total":21},
+    {"name":"federation","passed":29,"failed":0,"total":29},
+    {"name":"integration","passed":8,"failed":0,"total":8}
+  ],
+  "generated": "2026-06-07T13:59:09+00:00"
+}

lib/events/scoreboard.md

@@ -0,0 +1,17 @@
+# events scoreboard
+
+**311 / 311 passing** (0 failure(s)).
+
+| Suite | Passed | Total | Status |
+|-------|--------|-------|--------|
+| calendar | 51 | 51 | ok |
+| timezone | 17 | 17 | ok |
+| availability | 22 | 22 | ok |
+| api | 32 | 32 | ok |
+| booking | 82 | 82 | ok |
+| booking-notify | 11 | 11 | ok |
+| ticket | 31 | 31 | ok |
+| notify | 7 | 7 | ok |
+| reminders | 21 | 21 | ok |
+| federation | 29 | 29 | ok |
+| integration | 8 | 8 | ok |

lib/events/tests/api.sx

@@ -0,0 +1,332 @@
+;; lib/events/tests/api.sx — public events facade (schedule/agenda/free/book).
+
+(define ev-api-pass 0)
+(define ev-api-fail 0)
+(define ev-api-failures (list))
+
+(define
+  ev-api-check!
+  (fn
+    (name got expected)
+    (if
+      (= got expected)
+      (set! ev-api-pass (+ ev-api-pass 1))
+      (do
+        (set! ev-api-fail (+ ev-api-fail 1))
+        (append!
+          ev-api-failures
+          (str name "\n    expected: " expected "\n    got:      " got))))))
+
+;; A store with a weekly yoga class (Mon+Wed 18:00, 60m, 4 occurrences).
+(define
+  ev-api-store
+  (fn
+    ()
+    (ev/schedule
+      (ev/empty)
+      (quote yoga)
+      (ev-dt 2026 6 1 18 0)
+      60
+      {:freq :weekly :count 4 :byday (list 0 2)}
+      20)))
+
+(define
+  ev-api-run-all!
+  (fn
+    ()
+    (let
+      ((s0 (ev-api-store)))
+      (let
+        ((occs (ev/agenda s0 (ev-date 2026 6 1) (ev-date 2026 7 1))))
+        (let
+          ((s1 (ev/book (ev/book s0 (quote nia) (ev-occ-key (first occs))) (quote nia) (ev-occ-key (first (rest occs))))))
+          (do
+            (ev-api-check!
+              "agenda expands weekly class to four occurrences"
+              (map (fn (o) (ev-dt->civil (get o :start))) occs)
+              (list
+                (list 2026 6 1)
+                (list 2026 6 3)
+                (list 2026 6 8)
+                (list 2026 6 10)))
+            (ev-api-check!
+              "empty store has empty agenda"
+              (ev/agenda
+                (ev/empty)
+                (ev-date 2026 6 1)
+                (ev-date 2026 7 1))
+              (list))
+            (ev-api-check!
+              "max duration reflects scheduled events"
+              (ev/store-max-duration s0)
+              60)
+            (ev-api-check!
+              "max duration of empty store is zero"
+              (ev/store-max-duration (ev/empty))
+              0)
+            (ev-api-check!
+              "event-by-id finds the scheduled event"
+              (get (ev/event-by-id s0 (quote yoga)) :capacity)
+              20)
+            (ev-api-check!
+              "event-by-id is nil for unknown id"
+              (ev/event-by-id s0 (quote nope))
+              nil)
+            (ev-api-check!
+              "agenda-for lists only booked occurrences"
+              (map
+                (fn (o) (ev-dt->civil (get o :start)))
+                (ev/agenda-for
+                  s1
+                  (quote nia)
+                  (ev-date 2026 6 1)
+                  (ev-date 2026 7 1)))
+              (list
+                (list 2026 6 1)
+                (list 2026 6 3)))
+            (ev-api-check!
+              "agenda-for empty for unbooked actor"
+              (ev/agenda-for
+                s1
+                (quote zed)
+                (ev-date 2026 6 1)
+                (ev-date 2026 7 1))
+              (list))
+            (ev-api-check!
+              "free? false during a booked occurrence"
+              (ev/free?
+                s1
+                (quote nia)
+                (ev-dt 2026 6 1 18 30)
+                (ev-dt 2026 6 1 19 0))
+              false)
+            (ev-api-check!
+              "free? true in an open window"
+              (ev/free?
+                s1
+                (quote nia)
+                (ev-dt 2026 6 1 9 0)
+                (ev-dt 2026 6 1 10 0))
+              true)
+            (ev-api-check!
+              "free? half-open at occurrence end"
+              (ev/free?
+                s1
+                (quote nia)
+                (ev-dt 2026 6 1 19 0)
+                (ev-dt 2026 6 1 20 0))
+              true)
+            (ev-api-check!
+              "free? true for an actor who booked nothing"
+              (ev/free?
+                s1
+                (quote zed)
+                (ev-dt 2026 6 1 18 0)
+                (ev-dt 2026 6 1 19 0))
+              true)
+            (ev-api-check!
+              "next-free skips the booked slot to the hour after"
+              (ev-dt-tod
+                (ev/next-free
+                  s1
+                  (quote nia)
+                  (ev-dt
+                    2026
+                    6
+                    1
+                    18
+                    0)
+                  60
+                  (ev-dt
+                    2026
+                    6
+                    1
+                    23
+                    0)))
+              (* 19 60))
+            (ev-api-check!
+              "next-free returns `after` when already open"
+              (ev/next-free
+                s1
+                (quote nia)
+                (ev-dt 2026 6 1 9 0)
+                60
+                (ev-dt 2026 6 1 18 0))
+              (ev-dt 2026 6 1 9 0))
+            (ev-api-check!
+              "no conflict among disjoint bookings"
+              (ev/has-conflict?
+                s1
+                (quote nia)
+                (ev-date 2026 6 1)
+                (ev-date 2026 7 1))
+              false)
+            (let
+              ((sc (ev/book (ev/schedule s1 (quote talk) (ev-dt 2026 6 1 18 30) 60 nil 5) (quote nia) (ev-occ-key (ev-occ (quote talk) (ev-dt 2026 6 1 18 30) 60)))))
+              (ev-api-check!
+                "overlapping second booking creates a conflict"
+                (ev/has-conflict?
+                  sc
+                  (quote nia)
+                  (ev-date 2026 6 1)
+                  (ev-date 2026 7 1))
+                true))
+            (let
+              ((b (persist/open)) (occ1 (first occs)))
+              (do
+                (let
+                  ((sp (ev/schedule (ev/empty) (quote clinic) (ev-dt 2026 6 5 9 0) 30 nil 2)))
+                  (let
+                    ((occ (ev-occ (quote clinic) (ev-dt 2026 6 5 9 0) 30)))
+                    (do
+                      (ev-api-check!
+                        "durable book returns booked"
+                        (get (ev/book-occ! b sp (quote a) occ) :status)
+                        :booked)
+                      (ev/book-occ! b sp (quote c) occ)
+                      (ev-api-check!
+                        "durable book past capacity is full"
+                        (get (ev/book-occ! b sp (quote d) occ) :status)
+                        :full)
+                      (ev-api-check!
+                        "durable roster reflects persisted bookings"
+                        (ev/roster-occ b occ)
+                        (list (quote a) (quote c)))
+                      (ev-api-check!
+                        "durable seats-left honours capacity"
+                        (ev/seats-left-occ b sp occ)
+                        0)
+                      (ev-api-check!
+                        "persist free? false during a durable booking"
+                        (ev/free-p?
+                          b
+                          sp
+                          (quote a)
+                          (ev-dt
+                            2026
+                            6
+                            5
+                            9
+                            10)
+                          (ev-dt
+                            2026
+                            6
+                            5
+                            9
+                            20))
+                        false)
+                      (ev-api-check!
+                        "persist free? true in an open window"
+                        (ev/free-p?
+                          b
+                          sp
+                          (quote a)
+                          (ev-dt
+                            2026
+                            6
+                            5
+                            10
+                            0)
+                          (ev-dt
+                            2026
+                            6
+                            5
+                            10
+                            30))
+                        true)
+                      (ev/cancel-occ! b sp (quote a) occ)
+                      (ev-api-check!
+                        "durable cancel frees a seat"
+                        (ev/seats-left-occ b sp occ)
+                        1)
+                      (ev-api-check!
+                        "persist free? true after cancellation"
+                        (ev/free-p?
+                          b
+                          sp
+                          (quote a)
+                          (ev-dt
+                            2026
+                            6
+                            5
+                            9
+                            10)
+                          (ev-dt
+                            2026
+                            6
+                            5
+                            9
+                            20))
+                        true))))))))))))
+
+;; ---- conflict-checked booking ----
+(define
+  ev-api-cf-run-all!
+  (fn
+    ()
+    (let
+      ((b (persist/open))
+        (store
+          (ev/schedule
+            (ev/schedule
+              (ev/schedule (ev/empty) (quote a) (ev-dt 2026 6 1 9 0) 60 nil 10)
+              (quote bb)
+              (ev-dt 2026 6 1 9 30)
+              60
+              nil
+              10)
+            (quote c)
+            (ev-dt 2026 6 1 11 0)
+            60
+            nil
+            10)))
+      (let
+        ((oa (ev-occ (quote a) (ev-dt 2026 6 1 9 0) 60))
+          (ob (ev-occ (quote bb) (ev-dt 2026 6 1 9 30) 60))
+          (oc (ev-occ (quote c) (ev-dt 2026 6 1 11 0) 60)))
+        (do
+          (ev-api-check!
+            "first checked booking succeeds"
+            (get (ev/book-checked! b store (quote nia) oa) :status)
+            :booked)
+          (ev-api-check!
+            "overlapping different-event booking is a time conflict"
+            (get (ev/book-checked! b store (quote nia) ob) :status)
+            :time-conflict)
+          (ev-api-check!
+            "the clashing booking did not land on the roster"
+            (ev/roster-occ b ob)
+            (list))
+          (ev-api-check!
+            "a non-overlapping booking is allowed"
+            (get (ev/book-checked! b store (quote nia) oc) :status)
+            :booked)
+          (ev-api-check!
+            "re-booking the same occurrence is idempotent, not a conflict"
+            (get (ev/book-checked! b store (quote nia) oa) :status)
+            :already)
+          ;; a different actor is unaffected by nia's bookings
+          (ev-api-check!
+            "another actor may take the overlapping slot"
+            (get (ev/book-checked! b store (quote ola) ob) :status)
+            :booked)
+          (ev-api-check!
+            "would-time-conflict? predicate agrees"
+            (ev/would-time-conflict? b store (quote nia) ob)
+            true)
+          (ev-api-check!
+            "would-time-conflict? false for a free slot"
+            (ev/would-time-conflict? b store (quote zed) ob)
+            false))))))
+
+(define
+  ev-api-tests-run!
+  (fn
+    ()
+    (do
+      (set! ev-api-pass 0)
+      (set! ev-api-fail 0)
+      (set! ev-api-failures (list))
+      (ev-api-run-all!)
+      (ev-api-cf-run-all!)
+      {:failures ev-api-failures :total (+ ev-api-pass ev-api-fail) :passed ev-api-pass :failed ev-api-fail})))

lib/events/tests/availability.sx

@@ -0,0 +1,331 @@
+;; lib/events/tests/availability.sx — free/busy + conflict rules on Datalog.
+
+(define ev-av-pass 0)
+(define ev-av-fail 0)
+(define ev-av-failures (list))
+
+(define
+  ev-av-check!
+  (fn
+    (name got expected)
+    (if
+      (= got expected)
+      (set! ev-av-pass (+ ev-av-pass 1))
+      (do
+        (set! ev-av-fail (+ ev-av-fail 1))
+        (append!
+          ev-av-failures
+          (str name "\n    expected: " expected "\n    got:      " got))))))
+
+;; Fixture: three occurrences on 2026-06-01.
+;;   standup  09:00–09:30   review 09:15–10:15 (overlaps standup)
+;;   lunch    12:00–13:00
+(define
+  ev-av-occs
+  (fn
+    ()
+    (list
+      (ev-occ
+        (quote standup)
+        (ev-dt 2026 6 1 9 0)
+        30)
+      (ev-occ
+        (quote review)
+        (ev-dt 2026 6 1 9 15)
+        60)
+      (ev-occ
+        (quote lunch)
+        (ev-dt 2026 6 1 12 0)
+        60))))
+
+(define ev-av-key (fn (id start) (str id "@" start)))
+
+;; alice: standup + review (overlap → conflict). bob: lunch only.
+(define
+  ev-av-db
+  (fn
+    ()
+    (ev-avail-db
+      (ev-av-occs)
+      (list
+        (list
+          (quote alice)
+          (ev-av-key
+            (quote standup)
+            (ev-dt 2026 6 1 9 0)))
+        (list
+          (quote alice)
+          (ev-av-key
+            (quote review)
+            (ev-dt 2026 6 1 9 15)))
+        (list
+          (quote bob)
+          (ev-av-key
+            (quote lunch)
+            (ev-dt 2026 6 1 12 0)))))))
+
+;; Disjoint fixture for slot search: 09:00–10:00 then 10:30–11:30 (a 30m gap).
+(define
+  ev-av-gap-db
+  (fn
+    ()
+    (ev-avail-db
+      (list
+        (ev-occ
+          (quote a)
+          (ev-dt 2026 6 1 9 0)
+          60)
+        (ev-occ
+          (quote b)
+          (ev-dt 2026 6 1 10 30)
+          60))
+      (list
+        (list
+          (quote sam)
+          (ev-av-key
+            (quote a)
+            (ev-dt 2026 6 1 9 0)))
+        (list
+          (quote sam)
+          (ev-av-key
+            (quote b)
+            (ev-dt 2026 6 1 10 30)))))))
+
+(define
+  ev-av-run-all!
+  (fn
+    ()
+    (let
+      ((db (ev-av-db)))
+      (do
+        (ev-av-check!
+          "busy lists alice committed intervals ascending"
+          (ev-busy db (quote alice))
+          (list
+            (list
+              (ev-dt 2026 6 1 9 0)
+              (ev-dt 2026 6 1 9 30))
+            (list
+              (ev-dt 2026 6 1 9 15)
+              (ev-dt 2026 6 1 10 15))))
+        (ev-av-check!
+          "busy lists bob single interval"
+          (ev-busy db (quote bob))
+          (list
+            (list
+              (ev-dt 2026 6 1 12 0)
+              (ev-dt 2026 6 1 13 0))))
+        (ev-av-check!
+          "busy empty for unknown actor"
+          (ev-busy db (quote carol))
+          (list))
+        (ev-av-check!
+          "alice has an overlap conflict"
+          (ev-has-conflict? db (quote alice))
+          true)
+        (ev-av-check!
+          "alice conflict reported once (canonical pair)"
+          (len (ev-conflicts db (quote alice)))
+          1)
+        (ev-av-check!
+          "bob has no conflict"
+          (ev-has-conflict? db (quote bob))
+          false)
+        (ev-av-check!
+          "non-overlapping bookings do not conflict"
+          (ev-has-conflict?
+            (ev-avail-db
+              (list
+                (ev-occ
+                  (quote a)
+                  (ev-dt
+                    2026
+                    6
+                    1
+                    9
+                    0)
+                  30)
+                (ev-occ
+                  (quote b)
+                  (ev-dt
+                    2026
+                    6
+                    1
+                    9
+                    30)
+                  30))
+              (list
+                (list
+                  (quote dave)
+                  (ev-av-key
+                    (quote a)
+                    (ev-dt
+                      2026
+                      6
+                      1
+                      9
+                      0)))
+                (list
+                  (quote dave)
+                  (ev-av-key
+                    (quote b)
+                    (ev-dt
+                      2026
+                      6
+                      1
+                      9
+                      30)))))
+            (quote dave))
+          false)
+        (ev-av-check!
+          "alice free in an empty window"
+          (ev-free?
+            db
+            (quote alice)
+            (ev-dt 2026 6 1 13 0)
+            (ev-dt 2026 6 1 14 0))
+          true)
+        (ev-av-check!
+          "alice not free overlapping a booking"
+          (ev-free?
+            db
+            (quote alice)
+            (ev-dt 2026 6 1 9 20)
+            (ev-dt 2026 6 1 9 40))
+          false)
+        (ev-av-check!
+          "free? is half-open at the trailing edge"
+          (ev-free?
+            db
+            (quote alice)
+            (ev-dt 2026 6 1 10 15)
+            (ev-dt 2026 6 1 11 0))
+          true)
+        (ev-av-check!
+          "free? is half-open at the leading edge"
+          (ev-free?
+            db
+            (quote bob)
+            (ev-dt 2026 6 1 11 0)
+            (ev-dt 2026 6 1 12 0))
+          true)
+        (ev-av-check!
+          "free? false when window straddles a booking edge"
+          (ev-free?
+            db
+            (quote bob)
+            (ev-dt 2026 6 1 11 0)
+            (ev-dt 2026 6 1 12 1))
+          false)
+        (ev-av-check!
+          "free? query leaves db reusable (no leaked qwindow)"
+          (do
+            (ev-free?
+              db
+              (quote alice)
+              (ev-dt 2026 6 1 9 0)
+              (ev-dt 2026 6 1 9 30))
+            (ev-busy db (quote bob)))
+          (list
+            (list
+              (ev-dt 2026 6 1 12 0)
+              (ev-dt 2026 6 1 13 0))))
+        (let
+          ((gdb (ev-av-gap-db)))
+          (do
+            (ev-av-check!
+              "next-free finds the gap between bookings"
+              (ev-next-free
+                gdb
+                (quote sam)
+                (ev-dt 2026 6 1 9 0)
+                30
+                (ev-dt 2026 6 1 18 0))
+              (ev-dt 2026 6 1 10 0))
+            (ev-av-check!
+              "next-free skips a gap too short for the duration"
+              (ev-next-free
+                gdb
+                (quote sam)
+                (ev-dt 2026 6 1 9 0)
+                60
+                (ev-dt 2026 6 1 18 0))
+              (ev-dt 2026 6 1 11 30))
+            (ev-av-check!
+              "next-free returns `after` when already free"
+              (ev-next-free
+                gdb
+                (quote sam)
+                (ev-dt 2026 6 1 14 0)
+                60
+                (ev-dt 2026 6 1 18 0))
+              (ev-dt 2026 6 1 14 0))
+            (ev-av-check!
+              "next-free returns nil when nothing fits before horizon"
+              (ev-next-free
+                gdb
+                (quote sam)
+                (ev-dt 2026 6 1 9 0)
+                120
+                (ev-dt 2026 6 1 11 0))
+              nil)
+            (ev-av-check!
+              "next-free for actor with no bookings is `after`"
+              (ev-next-free
+                gdb
+                (quote nobody)
+                (ev-dt 2026 6 1 9 0)
+                60
+                (ev-dt 2026 6 1 18 0))
+              (ev-dt 2026 6 1 9 0))
+            (ev-av-check!
+              "next-free at exact edge of a booking (half-open)"
+              (ev-next-free
+                gdb
+                (quote sam)
+                (ev-dt 2026 6 1 10 0)
+                30
+                (ev-dt 2026 6 1 18 0))
+              (ev-dt 2026 6 1 10 0))))
+        (let
+          ((daily (ev-expand (ev-event (quote class) (ev-dt 2026 6 1 9 0) 60 {:freq :daily :count 3} 1) (ev-date 2026 6 1) (ev-date 2026 7 1))))
+          (let
+            ((db2 (ev-avail-db daily (map (fn (o) (list (quote sam) (ev-occ-key o))) daily))))
+            (do
+              (ev-av-check!
+                "expanded daily occurrences become busy intervals"
+                (len (ev-busy db2 (quote sam)))
+                3)
+              (ev-av-check!
+                "no conflicts among disjoint daily occurrences"
+                (ev-has-conflict? db2 (quote sam))
+                false)
+              (ev-av-check!
+                "busy on day two of the series"
+                (ev-free?
+                  db2
+                  (quote sam)
+                  (ev-dt
+                    2026
+                    6
+                    2
+                    9
+                    30)
+                  (ev-dt
+                    2026
+                    6
+                    2
+                    9
+                    45))
+                false))))))))
+
+(define
+  ev-availability-tests-run!
+  (fn
+    ()
+    (do
+      (set! ev-av-pass 0)
+      (set! ev-av-fail 0)
+      (set! ev-av-failures (list))
+      (ev-av-run-all!)
+      {:failures ev-av-failures :total (+ ev-av-pass ev-av-fail) :passed ev-av-pass :failed ev-av-fail})))

lib/events/tests/booking-notify.sx

@@ -0,0 +1,137 @@
+;; lib/events/tests/booking-notify.sx — lifecycle notifications from the stream.
+
+(define ev-bn-pass 0)
+(define ev-bn-fail 0)
+(define ev-bn-failures (list))
+
+(define
+  ev-bn-check!
+  (fn
+    (name got expected)
+    (if
+      (= got expected)
+      (set! ev-bn-pass (+ ev-bn-pass 1))
+      (do
+        (set! ev-bn-fail (+ ev-bn-fail 1))
+        (append!
+          ev-bn-failures
+          (str name "\n    expected: " expected "\n    got:      " got))))))
+
+(define
+  ev-bn-kinds
+  (fn
+    (notifs)
+    (map (fn (n) (list (get n :recipient) (get n :kind))) notifs)))
+
+(define
+  ev-bn-run-all!
+  (fn
+    ()
+    (do
+      (let
+        ((b (persist/open)))
+        (do
+          (ev/book! b "o" 1 (quote a))
+          (ev/waitlist! b "o" 1 (quote x))
+          (ev/cancel-promote! b "o" 1 (quote a))
+          (let
+            ((ns (ev/booking-notifications b "o" (quote yoga))))
+            (do
+              (ev-bn-check!
+                "lifecycle notifications in order"
+                (ev-bn-kinds ns)
+                (list
+                  (list (quote a) :booked)
+                  (list (quote x) :waitlisted)
+                  (list (quote a) :cancelled)
+                  (list (quote x) :promoted)))
+              (ev-bn-check!
+                "promotion targets the waitlisted actor"
+                (map
+                  (fn (n) (get n :recipient))
+                  (ev/notify-of-kind ns :promoted))
+                (list (quote x)))
+              (ev-bn-check!
+                "a fresh booking is not flagged as a promotion"
+                (len (ev/notify-of-kind ns :booked))
+                1)
+              (ev-bn-check!
+                "every notification carries the event label"
+                (get (first ns) :event)
+                (quote yoga))))))
+      (let
+        ((b (persist/open)))
+        (do
+          (ev/hold! b "p" 3 (quote q))
+          (ev/confirm! b "p" (quote q))
+          (ev-bn-check!
+            "hold then confirm notifications"
+            (ev-bn-kinds (ev/booking-notifications b "p" (quote gig)))
+            (list (list (quote q) :held) (list (quote q) :confirmed)))))
+      (let
+        ((b (persist/open)))
+        (do
+          (ev/hold! b "r" 1 (quote q))
+          (ev/release! b "r" (quote q))
+          (ev-bn-check!
+            "hold then release notifications"
+            (ev-bn-kinds (ev/booking-notifications b "r" (quote gig)))
+            (list (list (quote q) :held) (list (quote q) :released)))))
+      (let
+        ((b (persist/open)))
+        (do
+          (ev/book! b "k" 5 (quote a))
+          (ev/book! b "k" 5 (quote c))
+          (let
+            ((ns (ev/booking-notifications b "k" (quote talk))))
+            (do
+              (ev-bn-check!
+                "notification ids are occ-key/seq"
+                (map (fn (n) (get n :id)) ns)
+                (list "k/1" "k/2"))
+              (ev-bn-check!
+                "re-deriving yields identical ids (idempotent)"
+                (map
+                  (fn (n) (get n :id))
+                  (ev/booking-notifications b "k" (quote talk)))
+                (list "k/1" "k/2"))))))
+      (let
+        ((b (persist/open)))
+        (do
+          (ev/book! b "w" 5 (quote a))
+          (ev-bn-check!
+            "notification projects to (id recipient body)"
+            (ev/booking-notify->msg
+              (first (ev/booking-notifications b "w" (quote talk))))
+            (list
+              "w/1"
+              (quote a)
+              (list :booking-event :booked (quote talk))))))
+      (let
+        ((b (persist/open)))
+        (do
+          (ev/book! b "u" 1 (quote a))
+          (ev/waitlist! b "u" 1 (quote x))
+          (ev/leave-waitlist! b "u" (quote x))
+          (ev-bn-check!
+            "leaving the waitlist emits no notification"
+            (len
+              (ev/notify-of-kind
+                (ev/booking-notifications b "u" (quote e))
+                :left-waitlist))
+            0)
+          (ev-bn-check!
+            "unbooked occurrence has no notifications"
+            (ev/booking-notifications b "empty" (quote e))
+            (list)))))))
+
+(define
+  ev-booking-notify-tests-run!
+  (fn
+    ()
+    (do
+      (set! ev-bn-pass 0)
+      (set! ev-bn-fail 0)
+      (set! ev-bn-failures (list))
+      (ev-bn-run-all!)
+      {:failures ev-bn-failures :total (+ ev-bn-pass ev-bn-fail) :passed ev-bn-pass :failed ev-bn-fail})))

lib/events/tests/booking.sx

@@ -0,0 +1,431 @@
+;; lib/events/tests/booking.sx — capacity-safe booking, cancel, and holds.
+
+(define ev-bk-pass 0)
+(define ev-bk-fail 0)
+(define ev-bk-failures (list))
+
+(define
+  ev-bk-check!
+  (fn
+    (name got expected)
+    (if
+      (= got expected)
+      (set! ev-bk-pass (+ ev-bk-pass 1))
+      (do
+        (set! ev-bk-fail (+ ev-bk-fail 1))
+        (append!
+          ev-bk-failures
+          (str name "\n    expected: " expected "\n    got:      " got))))))
+
+;; Take a consistent (roster, last-seq) snapshot of an occurrence's stream.
+(define ev-bk-snap (fn (b k) (ev-booked-actors b k)))
+(define ev-bk-seq (fn (b k) (persist/last-seq b (ev-booking-stream k))))
+
+(define
+  ev-bk-run-all!
+  (fn
+    ()
+    (do
+      (let
+        ((b (persist/open)))
+        (do
+          (ev-bk-check!
+            "first booking takes seat 1"
+            (get (ev/book! b "o1" 3 (quote a)) :seat)
+            1)
+          (ev-bk-check!
+            "second booking takes seat 2"
+            (get (ev/book! b "o1" 3 (quote c)) :seat)
+            2)
+          (ev-bk-check!
+            "booked status reported"
+            (get (ev/book! b "o1" 3 (quote d)) :status)
+            :booked)
+          (ev-bk-check!
+            "roster is oldest-first"
+            (ev/roster b "o1")
+            (list (quote a) (quote c) (quote d)))
+          (ev-bk-check!
+            "seats-left is zero when full"
+            (ev/seats-left b "o1" 3)
+            0)
+          (ev-bk-check!
+            "free booking is confirmed state"
+            (ev/seat-state b "o1" (quote a))
+            :confirmed)))
+      (let
+        ((b (persist/open)))
+        (do
+          (ev/book! b "o2" 1 (quote a))
+          (ev-bk-check!
+            "booking past capacity is refused"
+            (get (ev/book! b "o2" 1 (quote c)) :status)
+            :full)
+          (ev-bk-check!
+            "full does not grow the roster"
+            (ev/roster b "o2")
+            (list (quote a)))
+          (ev-bk-check!
+            "seats-left zero at capacity"
+            (ev/seats-left b "o2" 1)
+            0)))
+      (let
+        ((b (persist/open)))
+        (do
+          (ev/book! b "o3" 5 (quote a))
+          (ev-bk-check!
+            "re-booking the same actor is idempotent"
+            (get (ev/book! b "o3" 5 (quote a)) :status)
+            :already)
+          (ev-bk-check!
+            "idempotent re-book reports existing seat"
+            (get (ev/book! b "o3" 5 (quote a)) :seat)
+            1)
+          (ev-bk-check!
+            "roster unchanged after re-book"
+            (ev/roster b "o3")
+            (list (quote a)))
+          (ev-bk-check!
+            "count unchanged after re-book"
+            (ev-booking-count b "o3")
+            1)))
+      (let
+        ((b (persist/open)))
+        (do
+          (ev/book! b "last" 2 (quote x))
+          (let
+            ((snap (ev-bk-snap b "last")) (exp (ev-bk-seq b "last")))
+            (let
+              ((ra (ev/book-with-observed b "last" 2 (quote a) snap exp))
+                (rb
+                  (ev/book-with-observed
+                    b
+                    "last"
+                    2
+                    (quote bee)
+                    snap
+                    exp)))
+              (do
+                (ev-bk-check!
+                  "race winner is booked"
+                  (get ra :status)
+                  :booked)
+                (ev-bk-check!
+                  "race winner takes the last seat"
+                  (get ra :seat)
+                  2)
+                (ev-bk-check!
+                  "race loser is rejected with a conflict"
+                  (get rb :status)
+                  :conflict)
+                (ev-bk-check!
+                  "conflict reports the advanced seq"
+                  (get rb :actual)
+                  (+ exp 1))
+                (ev-bk-check!
+                  "no overbooking: exactly two on roster"
+                  (ev-booking-count b "last")
+                  2)
+                (ev-bk-check!
+                  "race loser is NOT on the roster"
+                  (ev-bk-member? (quote bee) (ev/roster b "last"))
+                  false)
+                (ev-bk-check!
+                  "race loser retrying gets full"
+                  (get (ev/book! b "last" 2 (quote bee)) :status)
+                  :full))))))
+      (let
+        ((b (persist/open)))
+        (do
+          (ev/book! b "room" 3 (quote x))
+          (let
+            ((snap (ev-bk-snap b "room")) (exp (ev-bk-seq b "room")))
+            (let
+              ((ra (ev/book-with-observed b "room" 3 (quote a) snap exp))
+                (rb
+                  (ev/book-with-observed
+                    b
+                    "room"
+                    3
+                    (quote bee)
+                    snap
+                    exp)))
+              (do
+                (ev-bk-check!
+                  "room winner booked seat 2"
+                  (get ra :seat)
+                  2)
+                (ev-bk-check!
+                  "room loser first conflicts"
+                  (get rb :status)
+                  :conflict)
+                (ev-bk-check!
+                  "room loser retry books seat 3"
+                  (get (ev/book! b "room" 3 (quote bee)) :seat)
+                  3)
+                (ev-bk-check!
+                  "room roster is x,a,bee"
+                  (ev/roster b "room")
+                  (list (quote x) (quote a) (quote bee)))
+                (ev-bk-check!
+                  "room is now full"
+                  (ev/seats-left b "room" 3)
+                  0))))))
+      (let
+        ((b (persist/open)))
+        (do
+          (ev/book! b "cx" 2 (quote a))
+          (ev/book! b "cx" 2 (quote c))
+          (ev-bk-check!
+            "occupied to capacity before cancel"
+            (ev/seats-left b "cx" 2)
+            0)
+          (ev-bk-check!
+            "booking when full (pre-cancel) is refused"
+            (get (ev/book! b "cx" 2 (quote d)) :status)
+            :full)
+          (ev-bk-check!
+            "cancel reports cancelled"
+            (get (ev/cancel! b "cx" (quote a)) :status)
+            :cancelled)
+          (ev-bk-check!
+            "cancel removes actor from roster"
+            (ev/roster b "cx")
+            (list (quote c)))
+          (ev-bk-check!
+            "cancel frees a seat"
+            (ev/seats-left b "cx" 2)
+            1)
+          (ev-bk-check!
+            "freed seat is bookable again"
+            (get (ev/book! b "cx" 2 (quote d)) :status)
+            :booked)
+          (ev-bk-check!
+            "roster after rebook is c,d"
+            (ev/roster b "cx")
+            (list (quote c) (quote d)))))
+      (let
+        ((b (persist/open)))
+        (do
+          (ev/book! b "ce" 3 (quote a))
+          (ev-bk-check!
+            "cancelling an unbooked actor is a no-op"
+            (get (ev/cancel! b "ce" (quote z)) :status)
+            :not-booked)
+          (ev-bk-check!
+            "no-op cancel leaves roster intact"
+            (ev/roster b "ce")
+            (list (quote a)))
+          (ev/cancel! b "ce" (quote a))
+          (ev-bk-check!
+            "double cancel is not-booked the second time"
+            (get (ev/cancel! b "ce" (quote a)) :status)
+            :not-booked)
+          (ev-bk-check!
+            "empty roster after cancel"
+            (ev/roster b "ce")
+            (list))
+          (ev-bk-check!
+            "cancelled actor may re-book"
+            (get (ev/book! b "ce" 3 (quote a)) :status)
+            :booked)
+          (ev-bk-check!
+            "re-booked actor back on roster"
+            (ev/roster b "ce")
+            (list (quote a)))))
+      (let
+        ((b (persist/open)))
+        (do
+          (ev/book! b "h" 2 (quote a))
+          (ev-bk-check!
+            "hold reports held"
+            (get (ev/hold! b "h" 2 (quote p)) :status)
+            :held)
+          (ev-bk-check!
+            "held seat is :held state"
+            (ev/seat-state b "h" (quote p))
+            :held)
+          (ev-bk-check!
+            "held actor is on the roster"
+            (ev/roster b "h")
+            (list (quote a) (quote p)))
+          (ev-bk-check!
+            "held seat blocks the last booking"
+            (get (ev/book! b "h" 2 (quote x)) :status)
+            :full)
+          (ev-bk-check!
+            "no seats left with one held"
+            (ev/seats-left b "h" 2)
+            0)))
+      (let
+        ((b (persist/open)))
+        (do
+          (ev/hold! b "hc" 3 (quote p))
+          (ev-bk-check!
+            "confirm reports confirmed"
+            (get (ev/confirm! b "hc" (quote p)) :status)
+            :confirmed)
+          (ev-bk-check!
+            "confirmed seat is :confirmed state"
+            (ev/seat-state b "hc" (quote p))
+            :confirmed)
+          (ev-bk-check!
+            "re-confirm is already-confirmed"
+            (get (ev/confirm! b "hc" (quote p)) :status)
+            :already-confirmed)
+          (ev-bk-check!
+            "confirming a non-holder is not-held"
+            (get (ev/confirm! b "hc" (quote z)) :status)
+            :not-held)
+          (ev-bk-check!
+            "confirmed seat still occupies"
+            (ev/seats-left b "hc" 3)
+            2)))
+      (let
+        ((b (persist/open)))
+        (do
+          (ev/book! b "hr" 2 (quote a))
+          (ev/hold! b "hr" 2 (quote p))
+          (ev-bk-check!
+            "full while hold pending"
+            (ev/seats-left b "hr" 2)
+            0)
+          (ev-bk-check!
+            "release reports released"
+            (get (ev/release! b "hr" (quote p)) :status)
+            :released)
+          (ev-bk-check!
+            "release frees the held seat"
+            (ev/seats-left b "hr" 2)
+            1)
+          (ev-bk-check!
+            "released actor off the roster"
+            (ev/roster b "hr")
+            (list (quote a)))
+          (ev-bk-check!
+            "freed seat bookable after release"
+            (get (ev/book! b "hr" 2 (quote x)) :status)
+            :booked)
+          (ev/hold! b "hr2" 1 (quote q))
+          (ev/confirm! b "hr2" (quote q))
+          (ev-bk-check!
+            "release on a confirmed seat is not-held"
+            (get (ev/release! b "hr2" (quote q)) :status)
+            :not-held)
+          (ev-bk-check!
+            "cancel frees a confirmed-from-hold seat"
+            (get (ev/cancel! b "hr2" (quote q)) :status)
+            :cancelled)))
+      (let
+        ((b (persist/open)))
+        (do
+          (ev/book! b "hlast" 2 (quote x))
+          (let
+            ((snap (ev-bk-snap b "hlast")) (exp (ev-bk-seq b "hlast")))
+            (let
+              ((ra (ev/hold-with-observed b "hlast" 2 (quote p) snap exp))
+                (rb
+                  (ev/hold-with-observed
+                    b
+                    "hlast"
+                    2
+                    (quote q)
+                    snap
+                    exp)))
+              (do
+                (ev-bk-check! "hold race winner held" (get ra :status) :held)
+                (ev-bk-check!
+                  "hold race loser conflicts"
+                  (get rb :status)
+                  :conflict)
+                (ev-bk-check!
+                  "no oversell via concurrent holds"
+                  (ev-booking-count b "hlast")
+                  2)
+                (ev-bk-check!
+                  "hold loser retry gets full"
+                  (get (ev/hold! b "hlast" 2 (quote q)) :status)
+                  :full))))))
+      (let
+        ((b (persist/open)))
+        (do
+          (ev/hold! b "hi" 4 (quote p))
+          (ev-bk-check!
+            "re-holding the same actor is idempotent"
+            (get (ev/hold! b "hi" 4 (quote p)) :status)
+            :already)
+          (ev-bk-check!
+            "hold idempotency keeps one seat"
+            (ev-booking-count b "hi")
+            1))))))
+
+;; ---- waitlist ----
+(define
+  ev-bk-wl-run-all!
+  (fn
+    ()
+    (do
+      ;; join the waitlist when full; book directly when a seat is free
+      (let
+        ((b (persist/open)))
+        (do
+          (ev-bk-check! "waitlist! books when a seat is free" (get (ev/waitlist! b "w" 2 (quote a)) :status) :booked)
+          (ev-bk-check! "second booking still fits" (get (ev/waitlist! b "w" 2 (quote c)) :status) :booked)
+          (ev-bk-check! "third joins the waitlist when full" (get (ev/waitlist! b "w" 2 (quote x)) :status) :waitlisted)
+          (ev-bk-check! "fourth is next in line" (get (ev/waitlist! b "w" 2 (quote y)) :position) 2)
+          (ev-bk-check! "waitlist is FIFO" (ev/waitlist b "w") (list (quote x) (quote y)))
+          (ev-bk-check! "seats unaffected by waitlisting" (ev/roster b "w") (list (quote a) (quote c)))
+          (ev-bk-check! "waitlist-position reports a queued actor" (ev/waitlist-position b "w" (quote y)) 2)
+          (ev-bk-check! "waitlist-position 0 for a seated actor" (ev/waitlist-position b "w" (quote a)) 0)))
+      ;; idempotency
+      (let
+        ((b (persist/open)))
+        (do
+          (ev/waitlist! b "wi" 1 (quote a))
+          (ev/waitlist! b "wi" 1 (quote x))
+          (ev-bk-check! "re-joining as a seated actor is :already" (get (ev/waitlist! b "wi" 1 (quote a)) :status) :already)
+          (ev-bk-check! "re-joining the queue is :already-waiting" (get (ev/waitlist! b "wi" 1 (quote x)) :status) :already-waiting)
+          (ev-bk-check! "queue did not grow on re-join" (ev/waitlist b "wi") (list (quote x)))))
+      ;; leaving the waitlist
+      (let
+        ((b (persist/open)))
+        (do
+          (ev/waitlist! b "wl" 1 (quote a))
+          (ev/waitlist! b "wl" 1 (quote x))
+          (ev/waitlist! b "wl" 1 (quote y))
+          (ev-bk-check! "leave-waitlist reports left" (get (ev/leave-waitlist! b "wl" (quote x)) :status) :left)
+          (ev-bk-check! "leaving removes from the queue" (ev/waitlist b "wl") (list (quote y)))
+          (ev-bk-check! "leaving when not queued is not-waiting" (get (ev/leave-waitlist! b "wl" (quote z)) :status) :not-waiting)))
+      ;; auto-promotion on cancel
+      (let
+        ((b (persist/open)))
+        (do
+          (ev/waitlist! b "wp" 1 (quote a))
+          (ev/waitlist! b "wp" 1 (quote x))
+          (ev/waitlist! b "wp" 1 (quote y))
+          (let
+            ((r (ev/cancel-promote! b "wp" 1 (quote a))))
+            (do
+              (ev-bk-check! "cancel-promote cancels the seat holder" (get r :status) :cancelled)
+              (ev-bk-check! "cancel-promote promotes the head of the queue" (get r :promoted) (quote x))))
+          (ev-bk-check! "promoted actor now holds the seat" (ev/roster b "wp") (list (quote x)))
+          (ev-bk-check! "promoted actor left the queue" (ev/waitlist b "wp") (list (quote y)))
+          (ev-bk-check! "promoted seat is confirmed" (ev/seat-state b "wp" (quote x)) :confirmed)
+          ;; cancelling with an empty waitlist promotes nobody
+          (ev/leave-waitlist! b "wp" (quote y))
+          (let
+            ((r2 (ev/cancel-promote! b "wp" 1 (quote x))))
+            (ev-bk-check! "cancel with empty waitlist promotes nobody" (get r2 :promoted) nil))
+          (ev-bk-check! "seat is free after the last cancel" (ev/seats-left b "wp" 1) 1))))))
+
+(define
+  ev-booking-tests-run!
+  (fn
+    ()
+    (do
+      (set! ev-bk-pass 0)
+      (set! ev-bk-fail 0)
+      (set! ev-bk-failures (list))
+      (ev-bk-run-all!)
+      (ev-bk-wl-run-all!)
+      {:failures ev-bk-failures :total (+ ev-bk-pass ev-bk-fail) :passed ev-bk-pass :failed ev-bk-fail})))

lib/events/tests/calendar.sx

@@ -0,0 +1,592 @@
+;; lib/events/tests/calendar.sx — civil date core + RRULE window expansion.
+
+(define ev-cal-pass 0)
+(define ev-cal-fail 0)
+(define ev-cal-failures (list))
+
+(define
+  ev-cal-check!
+  (fn
+    (name got expected)
+    (if
+      (= got expected)
+      (set! ev-cal-pass (+ ev-cal-pass 1))
+      (do
+        (set! ev-cal-fail (+ ev-cal-fail 1))
+        (append!
+          ev-cal-failures
+          (str name "\n    expected: " expected "\n    got:      " got))))))
+
+;; Project occurrences to (civil weekday) pairs for legible assertions.
+(define
+  ev-cal-shape
+  (fn
+    (occs)
+    (map
+      (fn
+        (o)
+        (list (ev-dt->civil (get o :start)) (ev-dt-weekday (get o :start))))
+      occs)))
+
+(define
+  ev-cal-starts
+  (fn (occs) (map (fn (o) (ev-dt->civil (get o :start))) occs)))
+
+(define
+  ev-cal-run-all!
+  (fn
+    ()
+    (do
+      (ev-cal-check!
+        "epoch day zero"
+        (ev-days-from-civil 1970 1 1)
+        0)
+      (ev-cal-check!
+        "y2k day number"
+        (ev-days-from-civil 2000 1 1)
+        10957)
+      (ev-cal-check!
+        "leap day round trip"
+        (ev-civil-from-days
+          (ev-days-from-civil 2024 2 29))
+        (list 2024 2 29))
+      (ev-cal-check!
+        "pre-epoch round trip"
+        (ev-civil-from-days
+          (ev-days-from-civil 1969 12 31))
+        (list 1969 12 31))
+      (ev-cal-check!
+        "epoch is thursday"
+        (ev-weekday-of-days 0)
+        3)
+      (ev-cal-check!
+        "2026-06-06 is saturday"
+        (ev-dt-weekday (ev-date 2026 6 6))
+        5)
+      (ev-cal-check!
+        "dt carries time of day"
+        (ev-dt-tod
+          (ev-dt 2026 6 1 9 30))
+        570)
+      (ev-cal-check!
+        "civil from dt"
+        (ev-dt->civil
+          (ev-dt 2026 12 25 8 0))
+        (list 2026 12 25))
+      (ev-cal-check!
+        "days in feb 2024 (leap)"
+        (ev-days-in-month 2024 2)
+        29)
+      (ev-cal-check!
+        "days in feb 2026"
+        (ev-days-in-month 2026 2)
+        28)
+      (ev-cal-check!
+        "add months wraps year"
+        (ev-add-months 2026 11 3)
+        (list 2027 2))
+      (ev-cal-check!
+        "add months within year"
+        (ev-add-months 2026 1 5)
+        (list 2026 6))
+      (let
+        ((ev (ev-event (quote one) (ev-dt 2026 6 10 14 0) 60 nil 1)))
+        (do
+          (ev-cal-check!
+            "single inside window emits once"
+            (len
+              (ev-expand
+                ev
+                (ev-date 2026 6 1)
+                (ev-date 2026 7 1)))
+            1)
+          (ev-cal-check!
+            "single before window omitted"
+            (len
+              (ev-expand
+                ev
+                (ev-date 2026 7 1)
+                (ev-date 2026 8 1)))
+            0)
+          (ev-cal-check!
+            "single after window omitted"
+            (len
+              (ev-expand
+                ev
+                (ev-date 2026 1 1)
+                (ev-date 2026 2 1)))
+            0)
+          (ev-cal-check!
+            "occurrence end is start plus duration"
+            (get
+              (first
+                (ev-expand
+                  ev
+                  (ev-date 2026 6 1)
+                  (ev-date 2026 7 1)))
+              :end)
+            (+
+              (ev-dt 2026 6 10 14 0)
+              60))))
+      (let
+        ((daily (ev-event (quote d) (ev-dt 2026 6 1 9 0) 30 {:freq :daily :count 5} 1)))
+        (do
+          (ev-cal-check!
+            "daily count caps occurrences"
+            (ev-cal-starts
+              (ev-expand
+                daily
+                (ev-date 2026 6 1)
+                (ev-date 2026 7 1)))
+            (list
+              (list 2026 6 1)
+              (list 2026 6 2)
+              (list 2026 6 3)
+              (list 2026 6 4)
+              (list 2026 6 5)))
+          (ev-cal-check!
+            "daily preserves time of day"
+            (ev-dt-tod
+              (get
+                (first
+                  (ev-expand
+                    daily
+                    (ev-date 2026 6 1)
+                    (ev-date 2026 7 1)))
+                :start))
+            540)))
+      (let
+        ((di (ev-event (quote di) (ev-dt 2026 6 1 0 0) 30 {:interval 3 :freq :daily :until (ev-date 2026 6 30)} 1)))
+        (ev-cal-check!
+          "daily interval 3 steps by three days"
+          (ev-cal-starts
+            (ev-expand
+              di
+              (ev-date 2026 6 1)
+              (ev-date 2026 6 13)))
+          (list
+            (list 2026 6 1)
+            (list 2026 6 4)
+            (list 2026 6 7)
+            (list 2026 6 10)
+            (list 2026 6 13))))
+      (let
+        ((dc (ev-event (quote dc) (ev-dt 2026 6 1 0 0) 30 {:freq :daily :count 10} 1)))
+        (ev-cal-check!
+          "count is window-independent (clip middle)"
+          (ev-cal-starts
+            (ev-expand
+              dc
+              (ev-date 2026 6 5)
+              (ev-date 2026 6 8)))
+          (list
+            (list 2026 6 5)
+            (list 2026 6 6)
+            (list 2026 6 7)
+            (list 2026 6 8))))
+      (let
+        ((dc2 (ev-event (quote dc2) (ev-dt 2026 6 1 0 0) 30 {:freq :daily :count 3} 1)))
+        (ev-cal-check!
+          "count exhausted before window yields nothing"
+          (len
+            (ev-expand
+              dc2
+              (ev-date 2026 6 10)
+              (ev-date 2026 6 20)))
+          0))
+      (let
+        ((wk (ev-event (quote w) (ev-dt 2026 6 1 18 0) 90 {:freq :weekly :byday (list 0 2 4)} 1)))
+        (ev-cal-check!
+          "weekly byday mon/wed/fri first two weeks"
+          (ev-cal-shape
+            (ev-expand
+              wk
+              (ev-date 2026 6 1)
+              (ev-date 2026 6 13)))
+          (list
+            (list (list 2026 6 1) 0)
+            (list (list 2026 6 3) 2)
+            (list (list 2026 6 5) 4)
+            (list (list 2026 6 8) 0)
+            (list (list 2026 6 10) 2)
+            (list (list 2026 6 12) 4))))
+      (let
+        ((wu (ev-event (quote wu) (ev-dt 2026 6 1 18 0) 90 {:freq :weekly :until (ev-dt 2026 6 10 23 0) :byday (list 0 2)} 1)))
+        (ev-cal-check!
+          "weekly until clips trailing occurrences"
+          (ev-cal-starts
+            (ev-expand
+              wu
+              (ev-date 2026 6 1)
+              (ev-date 2026 7 1)))
+          (list
+            (list 2026 6 1)
+            (list 2026 6 3)
+            (list 2026 6 8)
+            (list 2026 6 10))))
+      (let
+        ((wi (ev-event (quote wi) (ev-dt 2026 6 1 18 0) 90 {:interval 2 :freq :weekly :byday (list 0)} 1)))
+        (ev-cal-check!
+          "weekly interval 2 skips alternate weeks"
+          (ev-cal-starts
+            (ev-expand
+              wi
+              (ev-date 2026 6 1)
+              (ev-date 2026 7 6)))
+          (list
+            (list 2026 6 1)
+            (list 2026 6 15)
+            (list 2026 6 29))))
+      (let
+        ((wd (ev-event (quote wd) (ev-dt 2026 6 3 12 0) 60 {:freq :weekly :count 3} 1)))
+        (ev-cal-check!
+          "weekly default byday is dtstart weekday"
+          (ev-cal-shape
+            (ev-expand
+              wd
+              (ev-date 2026 6 1)
+              (ev-date 2026 8 1)))
+          (list
+            (list (list 2026 6 3) 2)
+            (list (list 2026 6 10) 2)
+            (list (list 2026 6 17) 2))))
+      (let
+        ((wc (ev-event (quote wc) (ev-dt 2026 6 1 18 0) 90 {:freq :weekly :count 10 :byday (list 0 2)} 1)))
+        (ev-cal-check!
+          "weekly count window-independent (clip middle)"
+          (ev-cal-starts
+            (ev-expand
+              wc
+              (ev-date 2026 6 15)
+              (ev-date 2026 7 5)))
+          (list
+            (list 2026 6 15)
+            (list 2026 6 17)
+            (list 2026 6 22)
+            (list 2026 6 24)
+            (list 2026 6 29)
+            (list 2026 7 1))))
+      (let
+        ((wf (ev-event (quote wf) (ev-dt 2026 6 3 18 0) 90 {:freq :weekly :count 4 :byday (list 0 2 4)} 1)))
+        (ev-cal-check!
+          "first week skips byday earlier than dtstart"
+          (ev-cal-starts
+            (ev-expand
+              wf
+              (ev-date 2026 6 1)
+              (ev-date 2026 7 1)))
+          (list
+            (list 2026 6 3)
+            (list 2026 6 5)
+            (list 2026 6 8)
+            (list 2026 6 10))))
+      (let
+        ((md (ev-event (quote md) (ev-dt 2026 1 15 9 0) 60 {:bymonthday (list 15) :freq :monthly} 1)))
+        (do
+          (ev-cal-check!
+            "monthly bymonthday 15th"
+            (ev-cal-starts
+              (ev-expand
+                md
+                (ev-date 2026 1 1)
+                (ev-date 2026 4 1)))
+            (list
+              (list 2026 1 15)
+              (list 2026 2 15)
+              (list 2026 3 15)))
+          (ev-cal-check!
+            "monthly preserves time of day"
+            (ev-dt-tod
+              (get
+                (first
+                  (ev-expand
+                    md
+                    (ev-date 2026 1 1)
+                    (ev-date 2026 4 1)))
+                :start))
+            540)))
+      (let
+        ((mm (ev-event (quote mm) (ev-dt 2026 1 1 9 0) 60 {:bymonthday (list 1 15) :freq :monthly :count 4} 1)))
+        (ev-cal-check!
+          "monthly multiple bymonthday sorted within month"
+          (ev-cal-starts
+            (ev-expand
+              mm
+              (ev-date 2026 1 1)
+              (ev-date 2026 12 1)))
+          (list
+            (list 2026 1 1)
+            (list 2026 1 15)
+            (list 2026 2 1)
+            (list 2026 2 15))))
+      (let
+        ((ml (ev-event (quote ml) (ev-dt 2026 1 31 9 0) 60 {:bymonthday (list -1) :freq :monthly} 1)))
+        (ev-cal-check!
+          "monthly bymonthday -1 is last day"
+          (ev-cal-starts
+            (ev-expand
+              ml
+              (ev-date 2026 1 1)
+              (ev-date 2026 4 1)))
+          (list
+            (list 2026 1 31)
+            (list 2026 2 28)
+            (list 2026 3 31))))
+      (let
+        ((mn (ev-event (quote mn) (ev-dt 2026 1 1 9 0) 60 {:freq :monthly :byday (list {:ord 2 :wd 1})} 1)))
+        (ev-cal-check!
+          "monthly 2nd tuesday"
+          (ev-cal-shape
+            (ev-expand
+              mn
+              (ev-date 2026 1 1)
+              (ev-date 2026 4 1)))
+          (list
+            (list (list 2026 1 13) 1)
+            (list (list 2026 2 10) 1)
+            (list (list 2026 3 10) 1))))
+      (let
+        ((mz (ev-event (quote mz) (ev-dt 2026 1 1 9 0) 60 {:freq :monthly :byday (list {:ord -1 :wd 4})} 1)))
+        (ev-cal-check!
+          "monthly last friday"
+          (ev-cal-shape
+            (ev-expand
+              mz
+              (ev-date 2026 1 1)
+              (ev-date 2026 4 1)))
+          (list
+            (list (list 2026 1 30) 4)
+            (list (list 2026 2 27) 4)
+            (list (list 2026 3 27) 4))))
+      (let
+        ((m31 (ev-event (quote m31) (ev-dt 2026 1 31 9 0) 60 {:freq :monthly :count 4} 1)))
+        (ev-cal-check!
+          "monthly default day-of-month skips short months"
+          (ev-cal-starts
+            (ev-expand
+              m31
+              (ev-date 2026 1 1)
+              (ev-date 2026 12 1)))
+          (list
+            (list 2026 1 31)
+            (list 2026 3 31)
+            (list 2026 5 31)
+            (list 2026 7 31))))
+      (let
+        ((mi (ev-event (quote mi) (ev-dt 2026 1 10 9 0) 60 {:interval 3 :freq :monthly :count 3} 1)))
+        (ev-cal-check!
+          "monthly interval 3 steps by quarter"
+          (ev-cal-starts
+            (ev-expand
+              mi
+              (ev-date 2026 1 1)
+              (ev-date 2027 1 1)))
+          (list
+            (list 2026 1 10)
+            (list 2026 4 10)
+            (list 2026 7 10))))
+      (let
+        ((mc (ev-event (quote mc) (ev-dt 2026 1 5 9 0) 60 {:freq :monthly :count 12} 1)))
+        (ev-cal-check!
+          "monthly count window-independent (clip middle)"
+          (ev-cal-starts
+            (ev-expand
+              mc
+              (ev-date 2026 4 1)
+              (ev-date 2026 6 30)))
+          (list
+            (list 2026 4 5)
+            (list 2026 5 5)
+            (list 2026 6 5))))
+      (let
+        ((a (ev-event (quote a) (ev-dt 2026 6 2 10 0) 30 {:freq :daily :count 2} 1))
+          (b
+            (ev-event
+              (quote b)
+              (ev-dt 2026 6 1 9 0)
+              30
+              {:freq :daily :count 2}
+              1)))
+        (ev-cal-check!
+          "expand-all sorts merged occurrences by start"
+          (map
+            (fn (o) (list (get o :id) (ev-dt->civil (get o :start))))
+            (ev-expand-all
+              (list a b)
+              (ev-date 2026 6 1)
+              (ev-date 2026 7 1)))
+          (list
+            (list (quote b) (list 2026 6 1))
+            (list (quote b) (list 2026 6 2))
+            (list (quote a) (list 2026 6 2))
+            (list (quote a) (list 2026 6 3))))))))
+
+;; ---- EXDATE / RDATE exceptions ----
+(define
+  ev-cal-ex-run-all!
+  (fn
+    ()
+    (do
+      ;; EXDATE removes a matching occurrence from the recurrence
+      (let
+        ((ex
+           (ev-event-full
+             (quote standup)
+             (ev-dt 2026 6 1 9 0)
+             30
+             {:freq :daily :count 5}
+             1
+             (list (ev-dt 2026 6 3 9 0))
+             (list))))
+        (ev-cal-check!
+          "EXDATE excludes the matching occurrence"
+          (ev-cal-starts (ev-expand ex (ev-date 2026 6 1) (ev-date 2026 7 1)))
+          (list (list 2026 6 1) (list 2026 6 2) (list 2026 6 4) (list 2026 6 5))))
+      ;; EXDATE that matches nothing is a no-op
+      (let
+        ((ex2
+           (ev-event-full
+             (quote s)
+             (ev-dt 2026 6 1 9 0)
+             30
+             {:freq :daily :count 3}
+             1
+             (list (ev-dt 2026 6 9 9 0))
+             (list))))
+        (ev-cal-check!
+          "EXDATE not matching any occurrence is a no-op"
+          (len (ev-expand ex2 (ev-date 2026 6 1) (ev-date 2026 7 1)))
+          3))
+      ;; RDATE adds an explicit occurrence (within the window)
+      (let
+        ((rd
+           (ev-event-full
+             (quote s)
+             (ev-dt 2026 6 1 9 0)
+             30
+             {:freq :daily :count 3}
+             1
+             (list)
+             (list (ev-dt 2026 6 10 9 0)))))
+        (do
+          (ev-cal-check!
+            "RDATE adds an explicit occurrence, sorted in"
+            (ev-cal-starts (ev-expand rd (ev-date 2026 6 1) (ev-date 2026 7 1)))
+            (list (list 2026 6 1) (list 2026 6 2) (list 2026 6 3) (list 2026 6 10)))
+          (ev-cal-check!
+            "RDATE outside the window is dropped"
+            (len (ev-expand rd (ev-date 2026 6 1) (ev-date 2026 6 5)))
+            3)))
+      ;; RDATE coinciding with an rrule occurrence is de-duplicated
+      (let
+        ((rdup
+           (ev-event-full
+             (quote s)
+             (ev-dt 2026 6 1 9 0)
+             30
+             {:freq :daily :count 3}
+             1
+             (list)
+             (list (ev-dt 2026 6 2 9 0)))))
+        (ev-cal-check!
+          "RDATE duplicating an occurrence does not double it"
+          (len (ev-expand rdup (ev-date 2026 6 1) (ev-date 2026 7 1)))
+          3))
+      ;; EXDATE wins over RDATE for the same datetime
+      (let
+        ((both
+           (ev-event-full
+             (quote s)
+             (ev-dt 2026 6 1 9 0)
+             30
+             {:freq :daily :count 3}
+             1
+             (list (ev-dt 2026 6 2 9 0))
+             (list (ev-dt 2026 6 2 9 0)))))
+        (ev-cal-check!
+          "EXDATE wins over RDATE and the rrule for the same date"
+          (ev-cal-starts (ev-expand both (ev-date 2026 6 1) (ev-date 2026 7 1)))
+          (list (list 2026 6 1) (list 2026 6 3))))
+      ;; RDATE-only event (no rrule)
+      (let
+        ((ronly
+           (ev-event-full
+             (quote s)
+             (ev-dt 2026 6 1 9 0)
+             30
+             nil
+             1
+             (list)
+             (list (ev-dt 2026 6 5 9 0) (ev-dt 2026 6 3 9 0)))))
+        (ev-cal-check!
+          "RDATE-only event yields dtstart plus the extra dates, sorted"
+          (ev-cal-starts (ev-expand ronly (ev-date 2026 6 1) (ev-date 2026 7 1)))
+          (list (list 2026 6 1) (list 2026 6 3) (list 2026 6 5))))
+      ;; plain ev-event (no exception keys) is unaffected
+      (let
+        ((plain (ev-event (quote p) (ev-dt 2026 6 1 9 0) 30 {:freq :daily :count 3} 1)))
+        (ev-cal-check!
+          "plain event without exceptions expands unchanged"
+          (len (ev-expand plain (ev-date 2026 6 1) (ev-date 2026 7 1)))
+          3)))))
+
+;; ---- per-occurrence overrides (reschedule one instance) ----
+(define
+  ev-cal-ov-run-all!
+  (fn
+    ()
+    (let
+      ((base (ev-event (quote standup) (ev-dt 2026 6 1 9 0) 30 {:freq :daily :count 4} 1)))
+      (do
+        ;; reschedule one instance to a new time + duration
+        (let
+          ((moved (ev-with-override base (ev-dt 2026 6 2 9 0) (ev-dt 2026 6 2 14 0) 45)))
+          (let
+            ((occs (ev-expand moved (ev-date 2026 6 1) (ev-date 2026 6 5))))
+            (do
+              (ev-cal-check!
+                "override moves only the targeted instance"
+                (map (fn (o) (ev-dt-tod (get o :start))) occs)
+                (list 540 840 540 540))
+              (ev-cal-check!
+                "override applies the new duration"
+                (map (fn (o) (- (get o :end) (get o :start))) occs)
+                (list 30 45 30 30))
+              (ev-cal-check!
+                "override keeps the series length"
+                (len occs)
+                4))))
+        ;; an instance moved out of the window vacates its slot
+        (let
+          ((movedout (ev-with-override base (ev-dt 2026 6 2 9 0) (ev-dt 2026 6 20 9 0) 30)))
+          (ev-cal-check!
+            "instance moved out of window is dropped, slot vacated"
+            (ev-cal-starts (ev-expand movedout (ev-date 2026 6 1) (ev-date 2026 6 5)))
+            (list (list 2026 6 1) (list 2026 6 3) (list 2026 6 4))))
+        ;; override for a non-existent original start is a no-op
+        (let
+          ((noop (ev-with-override base (ev-dt 2026 6 9 9 0) (ev-dt 2026 6 9 14 0) 45)))
+          (ev-cal-check!
+            "override for a non-occurring start is a no-op"
+            (len (ev-expand noop (ev-date 2026 6 1) (ev-date 2026 6 5)))
+            4))
+        ;; overrides re-sort the agenda when an instance moves earlier
+        (let
+          ((early (ev-with-override base (ev-dt 2026 6 3 9 0) (ev-dt 2026 6 1 7 0) 30)))
+          (ev-cal-check!
+            "an instance moved earlier re-sorts into place"
+            (map (fn (o) (ev-dt-tod (get o :start))) (ev-expand early (ev-date 2026 6 1) (ev-date 2026 6 5)))
+            (list 420 540 540 540)))))))
+
+(define
+  ev-calendar-tests-run!
+  (fn
+    ()
+    (do
+      (set! ev-cal-pass 0)
+      (set! ev-cal-fail 0)
+      (set! ev-cal-failures (list))
+      (ev-cal-run-all!)
+      (ev-cal-ex-run-all!)
+      (ev-cal-ov-run-all!)
+      {:failures ev-cal-failures :total (+ ev-cal-pass ev-cal-fail) :passed ev-cal-pass :failed ev-cal-fail})))

lib/events/tests/federation.sx

@@ -0,0 +1,289 @@
+;; lib/events/tests/federation.sx — trust-gated cross-instance agenda merge.
+
+(define ev-fd-pass 0)
+(define ev-fd-fail 0)
+(define ev-fd-failures (list))
+
+(define
+  ev-fd-check!
+  (fn
+    (name got expected)
+    (if
+      (= got expected)
+      (set! ev-fd-pass (+ ev-fd-pass 1))
+      (do
+        (set! ev-fd-fail (+ ev-fd-fail 1))
+        (append!
+          ev-fd-failures
+          (str name "\n    expected: " expected "\n    got:      " got))))))
+
+;; Local schedule + two peers. Distinct start times make ordering legible.
+(define
+  ev-fd-local
+  (fn
+    ()
+    (ev/schedule
+      (ev/empty)
+      (quote yoga)
+      (ev-dt 2026 6 1 9 0)
+      60
+      nil
+      20)))
+
+(define
+  ev-fd-berlin
+  (fn
+    ()
+    (ev/peer
+      (quote berlin)
+      (ev/schedule
+        (ev/empty)
+        (quote meetup)
+        (ev-dt 2026 6 1 12 0)
+        90
+        nil
+        100)))) 
+
+(define
+  ev-fd-paris
+  (fn
+    ()
+    (ev/peer
+      (quote paris)
+      (ev/schedule
+        (ev/empty)
+        (quote salon)
+        (ev-dt 2026 6 1 15 0)
+        60
+        nil
+        30))))
+
+(define
+  ev-fd-run-all!
+  (fn
+    ()
+    (let
+      ((local (ev-fd-local))
+        (peers (list (ev-fd-berlin) (ev-fd-paris)))
+        (ws (ev-date 2026 6 1))
+        (we (ev-date 2026 6 2)))
+      (do
+        (ev-fd-check!
+          "trusts a peer in the trust set"
+          (ev/trusts? (list (quote berlin)) (quote berlin))
+          true)
+        (ev-fd-check!
+          "does not trust a peer outside the set"
+          (ev/trusts? (list (quote berlin)) (quote paris))
+          false)
+        (ev-fd-check!
+          "trusted-peers filters to the trust set"
+          (map ev/peer-id (ev/trusted-peers peers (list (quote berlin))))
+          (list (quote berlin)))
+        (let
+          ((fed (ev/federated-agenda local peers (list (quote berlin)) ws we)))
+          (do
+            (ev-fd-check!
+              "merge includes local + trusted peer only"
+              (map (fn (o) (list (get o :origin) (get o :id))) fed)
+              (list
+                (list :local (quote yoga))
+                (list (quote berlin) (quote meetup))))
+            (ev-fd-check!
+              "merge is sorted by start"
+              (map (fn (o) (get o :start)) fed)
+              (list
+                (ev-dt 2026 6 1 9 0)
+                (ev-dt 2026 6 1 12 0)))
+            (ev-fd-check!
+              "untrusted peer (paris) contributes nothing"
+              (len (ev/from-origin fed (quote paris)))
+              0)
+            (ev-fd-check!
+              "local occurrences tagged :local"
+              (map (fn (o) (get o :id)) (ev/from-origin fed :local))
+              (list (quote yoga)))
+            (ev-fd-check!
+              "peer occurrences tagged with the peer id"
+              (map
+                (fn (o) (get o :id))
+                (ev/from-origin fed (quote berlin)))
+              (list (quote meetup)))))
+        (let
+          ((fed2 (ev/federated-agenda local peers (list (quote berlin) (quote paris)) ws we)))
+          (ev-fd-check!
+            "trusting both peers merges all three, sorted"
+            (map (fn (o) (list (get o :origin) (get o :id))) fed2)
+            (list
+              (list :local (quote yoga))
+              (list (quote berlin) (quote meetup))
+              (list (quote paris) (quote salon)))))
+        (let
+          ((fed3 (ev/federated-agenda local peers (list) ws we)))
+          (do
+            (ev-fd-check!
+              "empty trust yields only local occurrences"
+              (map (fn (o) (get o :origin)) fed3)
+              (list :local))
+            (ev-fd-check!
+              "empty trust still includes local"
+              (len fed3)
+              1)))
+        (let
+          ((rpeer (ev/peer (quote tokyo) (ev/schedule (ev/empty) (quote standup) (ev-dt 2026 6 1 8 0) 15 {:freq :daily :count 3} 5))))
+          (let
+            ((pa (ev/peer-agenda rpeer ws (ev-date 2026 6 4))))
+            (do
+              (ev-fd-check!
+                "peer recurrence expands in the window"
+                (len pa)
+                3)
+              (ev-fd-check!
+                "every peer occurrence is tagged with the peer id"
+                (map (fn (o) (get o :origin)) pa)
+                (list (quote tokyo) (quote tokyo) (quote tokyo))))))))))
+
+;; ---- federated free/busy ----
+(define
+  ev-fd-fb-run-all!
+  (fn
+    ()
+    (let
+      ((local-db
+         (ev-avail-db
+           (list (ev-occ (quote yoga) (ev-dt 2026 6 1 9 0) 60))
+           (list (list (quote nia) (str (quote yoga) "@" (ev-dt 2026 6 1 9 0))))))
+        (berlin
+          (ev/peer-with-busy
+            (quote berlin)
+            (ev/empty)
+            (list
+              (list (quote nia)
+                (list (list (ev-dt 2026 6 1 14 0) (ev-dt 2026 6 1 15 0)))))))
+        (paris
+          (ev/peer-with-busy
+            (quote paris)
+            (ev/empty)
+            (list
+              (list (quote nia)
+                (list (list (ev-dt 2026 6 1 11 0) (ev-dt 2026 6 1 12 0))))))))
+      (let
+        ((peers (list berlin paris)))
+        (do
+          ;; peer-busy reads a peer's published intervals
+          (ev-fd-check!
+            "peer-busy returns published intervals for an actor"
+            (ev/peer-busy berlin (quote nia))
+            (list (list (ev-dt 2026 6 1 14 0) (ev-dt 2026 6 1 15 0))))
+          (ev-fd-check!
+            "peer-busy empty for an actor with nothing published"
+            (ev/peer-busy berlin (quote zed))
+            (list))
+          ;; federated-busy unions local + trusted-peer busy, sorted
+          (ev-fd-check!
+            "federated-busy unions local + trusted peer, sorted"
+            (ev/federated-busy local-db (list berlin) (list (quote berlin)) (quote nia))
+            (list
+              (list (ev-dt 2026 6 1 9 0) (ev-dt 2026 6 1 10 0))
+              (list (ev-dt 2026 6 1 14 0) (ev-dt 2026 6 1 15 0))))
+          (ev-fd-check!
+            "untrusted peer busy is excluded from federated-busy"
+            (ev/federated-busy local-db peers (list (quote berlin)) (quote nia))
+            (list
+              (list (ev-dt 2026 6 1 9 0) (ev-dt 2026 6 1 10 0))
+              (list (ev-dt 2026 6 1 14 0) (ev-dt 2026 6 1 15 0))))
+          ;; federated-free? considers both local and trusted-peer commitments
+          (ev-fd-check!
+            "free locally and on peers in an open window"
+            (ev/federated-free? local-db peers (list (quote berlin)) (quote nia) (ev-dt 2026 6 1 16 0) (ev-dt 2026 6 1 17 0))
+            true)
+          (ev-fd-check!
+            "not free during a LOCAL booking"
+            (ev/federated-free? local-db peers (list (quote berlin)) (quote nia) (ev-dt 2026 6 1 9 30) (ev-dt 2026 6 1 9 45))
+            false)
+          (ev-fd-check!
+            "not free during a TRUSTED PEER busy interval"
+            (ev/federated-free? local-db peers (list (quote berlin)) (quote nia) (ev-dt 2026 6 1 14 30) (ev-dt 2026 6 1 14 45))
+            false)
+          (ev-fd-check!
+            "free during an UNTRUSTED peer's busy interval (paris not trusted)"
+            (ev/federated-free? local-db peers (list (quote berlin)) (quote nia) (ev-dt 2026 6 1 11 15) (ev-dt 2026 6 1 11 45))
+            true)
+          (ev-fd-check!
+            "not free once paris is trusted too"
+            (ev/federated-free? local-db peers (list (quote berlin) (quote paris)) (quote nia) (ev-dt 2026 6 1 11 15) (ev-dt 2026 6 1 11 45))
+            false)
+          (ev-fd-check!
+            "federated-free? half-open at a busy edge"
+            (ev/federated-free? local-db peers (list (quote berlin)) (quote nia) (ev-dt 2026 6 1 15 0) (ev-dt 2026 6 1 16 0))
+            true))))))
+
+;; ---- injected transport (fed-sx) ----
+(define
+  ev-fd-tx-run-all!
+  (fn
+    ()
+    (let
+      ((local (ev/schedule (ev/empty) (quote yoga) (ev-dt 2026 6 1 9 0) 60 nil 20))
+        (berlin (ev/peer (quote berlin) (ev/schedule (ev/empty) (quote meetup) (ev-dt 2026 6 1 12 0) 90 nil 100)))
+        (ws (ev-date 2026 6 1))
+        (we (ev-date 2026 6 2)))
+      (let
+        ((fetch (ev/peer-fetch (list berlin))))
+        (do
+          ;; in-process adapter merges through the transport interface
+          (ev-fd-check!
+            "federated-agenda-via merges local + fetched peer"
+            (map (fn (o) (list (get o :origin) (get o :id)))
+              (ev/federated-agenda-via local (list (quote berlin)) ws we fetch))
+            (list (list :local (quote yoga)) (list (quote berlin) (quote meetup))))
+          ;; an unreachable / unknown peer degrades gracefully
+          (ev-fd-check!
+            "an unreachable peer is skipped, agenda still served"
+            (map (fn (o) (get o :origin))
+              (ev/federated-agenda-via local (list (quote berlin) (quote ghost)) ws we fetch))
+            (list :local (quote berlin)))
+          ;; reachability report
+          (ev-fd-check!
+            "federation-status reports per-peer reachability"
+            (ev/federation-status (list (quote berlin) (quote ghost)) ws we fetch)
+            (list (list (quote berlin) :ok) (list (quote ghost) :error)))
+          ;; an explicit remote transport (returns occurrences directly)
+          (let
+            ((remote-fetch
+               (fn
+                 (pid rws rwe)
+                 (if (= pid (quote tokyo))
+                   {:status :ok
+                     :occurrences (list (ev-occ (quote standup) (ev-dt 2026 6 1 8 0) 15))}
+                   {:status :error :reason :unreachable}))))
+            (do
+              (ev-fd-check!
+                "a remote transport's occurrences merge with origin tags"
+                (map (fn (o) (list (get o :origin) (get o :id)))
+                  (ev/federated-agenda-via local (list (quote tokyo)) ws we remote-fetch))
+                (list (list (quote tokyo) (quote standup)) (list :local (quote yoga))))
+              (ev-fd-check!
+                "remote transport error degrades to local only"
+                (map (fn (o) (get o :origin))
+                  (ev/federated-agenda-via local (list (quote osaka)) ws we remote-fetch))
+                (list :local))))
+          ;; no trusted peers -> only local
+          (ev-fd-check!
+            "no trusted peer ids yields only local"
+            (map (fn (o) (get o :origin))
+              (ev/federated-agenda-via local (list) ws we fetch))
+            (list :local)))))))
+
+(define
+  ev-federation-tests-run!
+  (fn
+    ()
+    (do
+      (set! ev-fd-pass 0)
+      (set! ev-fd-fail 0)
+      (set! ev-fd-failures (list))
+      (ev-fd-run-all!)
+      (ev-fd-fb-run-all!)
+      (ev-fd-tx-run-all!)
+      {:failures ev-fd-failures :total (+ ev-fd-pass ev-fd-fail) :passed ev-fd-pass :failed ev-fd-fail})))

lib/events/tests/integration.sx

@@ -0,0 +1,144 @@
+;; lib/events/tests/integration.sx — end-to-end pipeline: derive notification
+;; messages (SX) -> deliver them through the durable notify flow (Scheme).
+
+(define ev-it-pass 0)
+(define ev-it-fail 0)
+(define ev-it-failures (list))
+
+(define
+  ev-it-check!
+  (fn
+    (name got expected)
+    (if
+      (= got expected)
+      (set! ev-it-pass (+ ev-it-pass 1))
+      (do
+        (set! ev-it-fail (+ ev-it-fail 1))
+        (append!
+          ev-it-failures
+          (str name "\n    expected: " expected "\n    got:      " got))))))
+
+(define ev-it-status (fn (outcome) (first outcome)))
+(define ev-it-id (fn (outcome) (first (rest outcome))))
+
+;; A store with a weekly class; nia + ola booked into the first occurrence.
+(define
+  ev-it-setup
+  (fn
+    (b)
+    (let
+      ((store (ev/schedule (ev/empty) (quote yoga) (ev-dt 2026 6 1 18 0) 60 {:freq :weekly :count 4 :byday (list 0 2)} 20)))
+      (let
+        ((occ1 (ev-occ (quote yoga) (ev-dt 2026 6 1 18 0) 60)))
+        (do
+          (ev/book-occ! b store (quote nia) occ1)
+          (ev/book-occ! b store (quote ola) occ1)
+          store)))))
+
+(define
+  ev-it-run-all!
+  (fn
+    ()
+    (do
+      (let
+        ((b (persist/open)))
+        (let
+          ((store (ev-it-setup b)))
+          (let
+            ((reminders (ev/agenda-reminders b store (ev-date 2026 6 1) (ev-date 2026 7 1) 60)))
+            (let
+              ((msgs (map ev/reminder->msg reminders))
+                (outcomes
+                  (ev/deliver-messages
+                    (map ev/reminder->msg reminders)
+                    ev-notify-ok-transport
+                    3
+                    20)))
+              (do
+                (ev-it-check!
+                  "every booked attendee's reminder is delivered"
+                  (map ev-it-status outcomes)
+                  (list "delivered" "delivered"))
+                (ev-it-check!
+                  "one delivery per derived reminder"
+                  (len outcomes)
+                  (len msgs))
+                (ev-it-check!
+                  "delivered ids match the reminder idempotency keys"
+                  (map ev-it-id outcomes)
+                  (map (fn (r) (get r :id)) reminders)))))))
+      (let
+        ((b (persist/open)))
+        (let
+          ((store (ev-it-setup b)))
+          (let
+            ((msgs (map ev/reminder->msg (ev/agenda-reminders b store (ev-date 2026 6 1) (ev-date 2026 7 1) 60))))
+            (ev-it-check!
+              "a permanently-failing transport reports failed deliveries"
+              (map
+                ev-it-status
+                (ev/deliver-messages
+                  msgs
+                  "(lambda (k p) (list (quote retry) (quote down)))"
+                  2
+                  20))
+              (list "failed" "failed")))))
+      (let
+        ((b (persist/open)))
+        (do
+          (ev/book! b "occ" 1 (quote nia))
+          (ev/waitlist! b "occ" 1 (quote ola))
+          (ev/cancel-promote! b "occ" 1 (quote nia))
+          (let
+            ((promoted (ev/notify-of-kind (ev/booking-notifications b "occ" (quote yoga)) :promoted)))
+            (let
+              ((outcomes (ev/deliver-messages (map ev/booking-notify->msg promoted) ev-notify-ok-transport 3 12)))
+              (do
+                (ev-it-check!
+                  "the waitlist-promotion notification is delivered"
+                  (map ev-it-status outcomes)
+                  (list "delivered"))
+                (ev-it-check!
+                  "exactly one promotion was delivered"
+                  (len outcomes)
+                  1))))))
+      (let
+        ((b (persist/open)))
+        (let
+          ((ev (ev-event (quote yoga) (ev-dt 2026 6 1 18 0) 60 {:freq :daily :count 3} 20)))
+          (do
+            (ev/book-occ!
+              b
+              (ev/add-event (ev/empty) ev)
+              (quote nia)
+              (ev-occ
+                (quote yoga)
+                (ev-dt 2026 6 2 18 0)
+                60))
+            (let
+              ((moved (ev-with-override ev (ev-dt 2026 6 2 18 0) (ev-dt 2026 6 2 20 0) 60)))
+              (let
+                ((outcomes (ev/deliver-messages (map ev/reschedule-notify->msg (ev/reschedule-notifications b moved)) ev-notify-ok-transport 3 12)))
+                (ev-it-check!
+                  "the reschedule notice is delivered to the booked attendee"
+                  (map ev-it-status outcomes)
+                  (list "delivered")))))))
+      (ev-it-check!
+        "delivering no messages yields no outcomes"
+        (ev/deliver-messages
+          (list)
+          ev-notify-ok-transport
+          3
+          12)
+        (list)))))
+
+(define
+  ev-integration-tests-run!
+  (fn
+    ()
+    (do
+      (set! ev-it-pass 0)
+      (set! ev-it-fail 0)
+      (set! ev-it-failures (list))
+      (ev-it-run-all!)
+      {:failures ev-it-failures :total (+ ev-it-pass ev-it-fail) :passed ev-it-pass :failed ev-it-fail})))

lib/events/tests/notify.sx

@@ -0,0 +1,77 @@
+;; lib/events/tests/notify.sx — durable notification delivery flows.
+
+(define ev-nt-pass 0)
+(define ev-nt-fail 0)
+(define ev-nt-failures (list))
+
+(define
+  ev-nt-check!
+  (fn
+    (name got expected)
+    (if
+      (= got expected)
+      (set! ev-nt-pass (+ ev-nt-pass 1))
+      (do
+        (set! ev-nt-fail (+ ev-nt-fail 1))
+        (append!
+          ev-nt-failures
+          (str name "\n    expected: " expected "\n    got:      " got))))))
+
+;; Each case runs a Scheme flow program (notify flows preloaded) and asserts on
+;; the SX-native result. Scheme symbols come back as strings.
+(define
+  ev-nt-run-all!
+  (fn
+    ()
+    (do
+      (ev-nt-check!
+        "reminder delivers on the first attempt"
+        (ev/notify-run
+          "(define s (flow/start (ev-deliver-reminder 3) (list (quote m1) (quote alice) (quote hello))))\n           (flow-run-host (lambda (k p) (list (quote ok) (quote sent))) 5)\n           (list (flow/status (car (cdr s))) (flow/result (car (cdr s))))")
+        (list "done" (list "delivered" "m1" 1)))
+      (ev-nt-check!
+        "reminder retries a transient failure then delivers"
+        (ev/notify-run
+          "(define hits 0)\n           (define s (flow/start (ev-deliver-reminder 3) (list (quote m1) (quote bob) (quote hi))))\n           (flow-run-host (lambda (k p) (begin (set! hits (+ hits 1)) (if (< hits 2) (list (quote retry) (quote down)) (list (quote ok) (quote sent))))) 10)\n           (list (flow/result (car (cdr s))) hits)")
+        (list (list "delivered" "m1" 2) 2))
+      (ev-nt-check!
+        "reminder gives up after maxn attempts"
+        (ev/notify-run
+          "(define s (flow/start (ev-deliver-reminder 2) (list (quote m1) (quote x) (quote y))))\n           (flow-run-host (lambda (k p) (list (quote retry) (quote down))) 10)\n           (flow/result (car (cdr s)))")
+        (list "failed" "m1" "down"))
+      (ev-nt-check!
+        "redelivery of the same id sends only once (at-least-once, idempotent)"
+        (ev/notify-run
+          "(define sent (list)) (define deliveries 0)\n           (define (xport k p)\n             (let ((id (ev-msg-id p)))\n               (if (ev-mem id sent)\n                   (list (quote ok) (quote duplicate))\n                   (begin (set! sent (cons id sent)) (set! deliveries (+ deliveries 1)) (list (quote ok) (quote sent))))))\n           (define s1 (flow/start (ev-deliver-reminder 3) (list (quote m1) (quote a) (quote hi))))\n           (flow-run-host xport 5)\n           (define s2 (flow/start (ev-deliver-reminder 3) (list (quote m1) (quote a) (quote hi))))\n           (flow-run-host xport 5)\n           (list deliveries (flow/result (car (cdr s2))))")
+        (list 1 (list "delivered" "m1" 1)))
+      (ev-nt-check!
+        "digest delivers every message in the batch"
+        (ev/notify-run
+          "(define s (flow/start (ev-deliver-digest 3) (list (list (quote a) (quote u1) (quote hi)) (list (quote b) (quote u2) (quote yo)))))\n           (flow-run-host (lambda (k p) (list (quote ok) (quote sent))) 10)\n           (flow/result (car (cdr s)))")
+        (list
+          (list "delivered" "a" 1)
+          (list "delivered" "b" 1)))
+      (ev-nt-check!
+        "digest reports per-message outcomes independently"
+        (ev/notify-run
+          "(define (xport k p)\n             (let ((id (ev-msg-id p)))\n               (if (equal? id (quote b)) (list (quote retry) (quote flaky)) (list (quote ok) (quote sent)))))\n           (define s (flow/start (ev-deliver-digest 2) (list (list (quote a) (quote u1) (quote hi)) (list (quote b) (quote u2) (quote yo)) (list (quote c) (quote u3) (quote ya)))))\n           (flow-run-host xport 12)\n           (flow/result (car (cdr s)))")
+        (list
+          (list "delivered" "a" 1)
+          (list "failed" "b" "flaky")
+          (list "delivered" "c" 1)))
+      (ev-nt-check!
+        "delivery suspends until the transport responds"
+        (ev/notify-run
+          "(define s (flow/start (ev-deliver-reminder 3) (list (quote m1) (quote a) (quote hi))))\n           (flow/status (car (cdr s)))")
+        "suspended"))))
+
+(define
+  ev-notify-tests-run!
+  (fn
+    ()
+    (do
+      (set! ev-nt-pass 0)
+      (set! ev-nt-fail 0)
+      (set! ev-nt-failures (list))
+      (ev-nt-run-all!)
+      {:failures ev-nt-failures :total (+ ev-nt-pass ev-nt-fail) :passed ev-nt-pass :failed ev-nt-fail})))