radar: pass 38 — migration plan DRAFTED (5 specs + open-questions); decision point: review + start implementation loop? branch stays local

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

.claude/scheduled_tasks.lock

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

hosts/ocaml/bin/sx_server.ml

@@ -571,12 +571,9 @@ and cek_run_with_io state =
           Hashtbl.replace d "descent" (Number desc);
           Dict d
         | _ ->
-          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)
+          let args = let a = Sx_runtime.get_val request (String "args") in
+            (match a with List l -> l | _ -> [a]) in
+          io_request op args
       in
       s := Sx_ref.cek_resume !s response;
       loop ()
@@ -858,164 +855,6 @@ let setup_evaluator_bridge env =
       done;
       Nil
     | _ -> raise (Eval_error "http-listen: (port handler)"));
-
-  (* fed-sx Milestone 1 client direction (Phase J). NATIVE ONLY —
-     Unix sockets + DNS; absent from the WASM kernel. HTTP/1.1
-     request: TCP connect, write request line + headers + body,
-     read status + headers + body, return {:status :headers :body}.
-     URL must be http://...; HTTPS is a later phase (needs TLS).
-     Body read: Content-Length first, else read to EOF (we send
-     Connection: close). Transfer-Encoding: chunked is rejected —
-     fed-sx Phase 8 wires this for inter-server POSTs which will
-     all carry Content-Length. *)
-  Sx_primitives.register "http-request" (fun args ->
-    let strip_cr s =
-      let n = String.length s in
-      if n > 0 && s.[n - 1] = '\r' then String.sub s 0 (n - 1) else s
-    in
-    match args with
-    | [String meth; String url; headers_v; body_v] ->
-      let body = match body_v with
-        | String s -> s
-        | Nil -> ""
-        | v -> Sx_types.value_to_string v in
-      let prefix = "http://" in
-      let plen = String.length prefix in
-      let ulen = String.length url in
-      if ulen < plen || String.sub url 0 plen <> prefix
-      then raise (Eval_error "http-request: URL must start with http://");
-      let rest = String.sub url plen (ulen - plen) in
-      let host_port, path =
-        match String.index_opt rest '/' with
-        | Some i ->
-          String.sub rest 0 i,
-          String.sub rest i (String.length rest - i)
-        | None -> rest, "/" in
-      if host_port = "" then
-        raise (Eval_error "http-request: missing host");
-      let host, port =
-        match String.index_opt host_port ':' with
-        | Some i ->
-          let h = String.sub host_port 0 i in
-          let ps = String.sub host_port (i + 1)
-                     (String.length host_port - i - 1) in
-          (h,
-           (try int_of_string ps with _ ->
-              raise (Eval_error "http-request: bad port")))
-        | None -> host_port, 80 in
-      let addr =
-        (try (Unix.gethostbyname host).h_addr_list.(0)
-         with Not_found ->
-           raise (Eval_error ("http-request: dns: " ^ host))) in
-      let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
-      let cleanup () = try Unix.close sock with _ -> () in
-      let result =
-        (try
-          (try Unix.connect sock (Unix.ADDR_INET (addr, port))
-           with Unix.Unix_error (e, _, _) ->
-             raise (Eval_error
-                      ("http-request: connect: " ^ Unix.error_message e)));
-          let oc = Unix.out_channel_of_descr sock in
-          let ic = Unix.in_channel_of_descr sock in
-          let buf = Buffer.create 256 in
-          Buffer.add_string buf
-            (Printf.sprintf "%s %s HTTP/1.1\r\n" meth path);
-          let host_hdr_sent = ref false in
-          let clen_sent = ref false in
-          let conn_sent = ref false in
-          (match headers_v with
-           | Dict h ->
-             Hashtbl.iter (fun k v ->
-               let kl = String.lowercase_ascii k in
-               if kl = "host" then host_hdr_sent := true;
-               if kl = "content-length" then clen_sent := true;
-               if kl = "connection" then conn_sent := true;
-               let vs = match v with
-                 | String s -> s
-                 | x -> Sx_types.value_to_string x in
-               Buffer.add_string buf
-                 (Printf.sprintf "%s: %s\r\n" k vs)) h
-           | Nil -> ()
-           | _ -> raise (Eval_error "http-request: headers must be dict"));
-          if not !host_hdr_sent then
-            Buffer.add_string buf
-              (Printf.sprintf "Host: %s\r\n" host_port);
-          if not !clen_sent then
-            Buffer.add_string buf
-              (Printf.sprintf "Content-Length: %d\r\n"
-                 (String.length body));
-          if not !conn_sent then
-            Buffer.add_string buf "Connection: close\r\n";
-          Buffer.add_string buf "\r\n";
-          Buffer.add_string buf body;
-          output_string oc (Buffer.contents buf);
-          flush oc;
-          let sl =
-            (try strip_cr (input_line ic)
-             with End_of_file ->
-               raise (Eval_error
-                        "http-request: connection closed before status")) in
-          let status =
-            match String.split_on_char ' ' sl with
-            | _ver :: code :: _ ->
-              (try int_of_string code with _ ->
-                 raise (Eval_error "http-request: bad status code"))
-            | _ -> raise (Eval_error "http-request: bad status line") in
-          let rhdrs = Sx_types.make_dict () in
-          let clen = ref (-1) in
-          let chunked = ref false in
-          let rec rdh () =
-            let h =
-              (try strip_cr (input_line ic)
-               with End_of_file -> "") in
-            if h = "" then ()
-            else begin
-              (match String.index_opt h ':' with
-               | Some i ->
-                 let name =
-                   String.lowercase_ascii
-                     (String.trim (String.sub h 0 i)) in
-                 let value =
-                   String.trim
-                     (String.sub h (i + 1)
-                        (String.length h - i - 1)) in
-                 Hashtbl.replace rhdrs name (String value);
-                 if name = "content-length" then
-                   (try clen := int_of_string value with _ -> ())
-                 else if name = "transfer-encoding" &&
-                         String.lowercase_ascii value = "chunked"
-                 then chunked := true
-               | None -> ());
-              rdh ()
-            end in
-          rdh ();
-          if !chunked then
-            raise (Eval_error
-                     "http-request: chunked transfer-encoding not supported");
-          let rbody =
-            if !clen >= 0 then begin
-              let b = Bytes.create !clen in
-              really_input ic b 0 !clen;
-              Bytes.unsafe_to_string b
-            end else begin
-              let b = Buffer.create 256 in
-              (try
-                 while true do
-                   Buffer.add_channel b ic 4096
-                 done; assert false
-               with End_of_file -> ());
-              Buffer.contents b
-            end in
-          let resp = Sx_types.make_dict () in
-          Hashtbl.replace resp "status" (Integer status);
-          Hashtbl.replace resp "headers" (Dict rhdrs);
-          Hashtbl.replace resp "body" (String rbody);
-          Dict resp
-        with e -> cleanup (); raise e) in
-      cleanup ();
-      result
-    | _ -> raise (Eval_error "http-request: (method url headers body)"));
-
   bind "trampoline" (fun args ->
     match args with
     | [v] ->
@@ -1701,12 +1540,7 @@ let rec dispatch env cmd =
                | Some path -> load_library_file path | None -> ());
               Nil
             end
-          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
+          end else Nil (* non-import IO: resume with nil *) in
           s := Sx_ref.cek_resume !s response
         done;
         Sx_ref.cek_value !s
@@ -4059,10 +3893,7 @@ let http_mode port =
       Dict d
     | "io-sleep" | "sleep" -> Nil
     | "import" -> Nil
-    | _ ->
-      (match Sx_persist_store.handle_op op args with
-       | Some resp -> resp
-       | None -> Nil));
+    | _ -> 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/bin/test_http_client.sh

@@ -1,80 +0,0 @@
-#!/usr/bin/env bash
-# Phase J test — native-only http-request client primitive.
-# Reuses Phase H's http-listen to spin up an echo server, then drives
-# a separate sx_server via the epoch protocol to issue http-request
-# calls and assert response shape + headers + body.
-set -u
-cd "$(dirname "$0")/.."
-
-SRV=_build/default/bin/sx_server.exe
-PORT=${HTTP_CLIENT_TEST_PORT:-8921}
-PASS=0
-FAIL=0
-ok()  { echo "  PASS: $1"; PASS=$((PASS+1)); }
-bad() { echo "  FAIL: $1 — $2"; FAIL=$((FAIL+1)); }
-
-if [ ! -x "$SRV" ]; then
-  echo "build sx_server.exe first (dune build bin/sx_server.exe)"; exit 1
-fi
-
-# /echo echoes method/path/query/body and reflects request X-Custom
-# back as response X-Got; /missing-test → 404.
-H='(begin (define (h req) (if (= (get req "path") "/echo") {:status 200 :headers {"X-Echo" (get req "method") "X-Got" (get (get req "headers") "x-custom")} :body (str "M=" (get req "method") " P=" (get req "path") " Q=" (get req "query") " B=" (get req "body"))} (if (= (get req "path") "/missing-test") {:status 404 :body "nope"} {:status 500 :body "err"}))) (http-listen '"$PORT"' h))'
-ESC=${H//\"/\\\"}
-
-{ printf '(epoch 1)\n(eval "%s")\n' "$ESC"; sleep 60; } | "$SRV" >/tmp/test_http_client_srv.out 2>&1 &
-SVPID=$!
-trap 'kill $SVPID 2>/dev/null; wait 2>/dev/null' EXIT
-
-up=0
-for _ in $(seq 1 50); do
-  curl -s -o /dev/null "http://127.0.0.1:$PORT/echo" 2>/dev/null && { up=1; break; }
-  sleep 0.2
-done
-[ "$up" = 1 ] || { echo "  FAIL: server did not start"; cat /tmp/test_http_client_srv.out; exit 1; }
-
-emit() {
-  # $1 = epoch num, $2 = raw SX form. Wraps in (eval "...") with quotes escaped.
-  local esc=${2//\"/\\\"}
-  printf '(epoch %s)\n(eval "%s")\n' "$1" "$esc"
-}
-
-DRV_OUT=/tmp/test_http_client_drv.out
-{
-  emit 1 '(let ((r (http-request "GET" "http://127.0.0.1:'"$PORT"'/echo?x=1" {} ""))) (str "S=" (get r "status") " E=" (get (get r "headers") "x-echo") " B=" (get r "body")))'
-  emit 2 '(let ((r (http-request "POST" "http://127.0.0.1:'"$PORT"'/echo" {} "hello"))) (str "S=" (get r "status") " B=" (get r "body")))'
-  emit 3 '(let ((r (http-request "GET" "http://127.0.0.1:'"$PORT"'/missing-test" {} ""))) (str "S=" (get r "status") " B=" (get r "body")))'
-  emit 4 '(let ((r (http-request "GET" "http://127.0.0.1:'"$PORT"'/echo" {"X-Custom" "myval"} ""))) (get (get r "headers") "x-got"))'
-  emit 5 '(http-request "GET" "ftp://nope" {} "")'
-  emit 6 '(let ((r (http-request "GET" "http://127.0.0.1:'"$PORT"'/echo" {} ""))) (get r "status"))'
-} | "$SRV" >"$DRV_OUT" 2>&1
-
-# eval results come back as (ok-len N L)\n<body>\n — grep the body content.
-grep -q '^"S=200 E=GET B=M=GET P=/echo Q=x=1 B="$' "$DRV_OUT" \
-  && ok "GET status + echo header + body" \
-  || bad "GET" "$(grep -A1 '^(ok-len 1 ' "$DRV_OUT" | tail -1)"
-
-grep -q '^"S=200 B=M=POST P=/echo Q= B=hello"$' "$DRV_OUT" \
-  && ok "POST body roundtrip" \
-  || bad "POST" "$(grep -A1 '^(ok-len 2 ' "$DRV_OUT" | tail -1)"
-
-grep -q '^"S=404 B=nope"$' "$DRV_OUT" \
-  && ok "404 status + body" \
-  || bad "404" "$(grep -A1 '^(ok-len 3 ' "$DRV_OUT" | tail -1)"
-
-grep -q '^"myval"$' "$DRV_OUT" \
-  && ok "custom request header reaches server" \
-  || bad "custom-header" "$(grep -A1 '^(ok-len 4 ' "$DRV_OUT" | tail -1)"
-
-R5=$(grep '^(error 5 ' "$DRV_OUT" | head -1)
-echo "$R5" | grep -q 'URL must start with http' \
-  && ok "non-http scheme rejected" \
-  || bad "bad-url" "$R5"
-
-# Status is an Integer (200), serialized bare without quotes.
-grep -q '^200$' "$DRV_OUT" \
-  && ok "response status is integer 200" \
-  || bad "status-integer" "$(grep -A1 '^(ok-len 6 ' "$DRV_OUT" | tail -1)"
-
-echo "Results: $PASS passed, $FAIL failed"
-[ "$FAIL" = 0 ]

hosts/ocaml/lib/sx_persist_store.ml

@@ -1,293 +0,0 @@
-(* 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

@@ -1,144 +0,0 @@
-#!/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/acl/api.sx

@@ -1,45 +0,0 @@
-;; lib/acl/api.sx — public ACL surface over an implicit current db.
-;;
-;; Callers load a fact set once, then issue decisions without threading the db
-;; through every call. The current db is module state; (acl/load! facts) rebuilds
-;; it. This is the boundary the rest of rose-ash imports.
-
-(define acl-current-db nil)
-
-;; Replace the current fact base. Rebuilds the Datalog db under the active
-;; ruleset (see lib/acl/engine.sx).
-(define
-  acl/load!
-  (fn
-    (facts)
-    (do (set! acl-current-db (acl-build-db facts)) acl-current-db)))
-
-;; Ensure a db exists, building an empty one on first use.
-(define
-  acl-ensure-db!
-  (fn
-    ()
-    (do
-      (when
-        (= acl-current-db nil)
-        (set! acl-current-db (acl-build-db (list))))
-      acl-current-db)))
-
-;; Public decision against the current db (pure, no logging).
-(define
-  acl/permit?
-  (fn (subj act res) (acl-permit? (acl-ensure-db!) subj act res)))
-
-;; Decision-with-proof against the current db. See lib/acl/explain.sx.
-(define
-  acl/explain
-  (fn (subj act res) (acl-explain (acl-ensure-db!) subj act res)))
-
-;; Audited decision: logs the outcome to the append-only audit log and returns
-;; the boolean. See lib/acl/audit.sx.
-(define
-  acl/audit
-  (fn (subj act res) (acl-audit-decide! (acl-ensure-db!) subj act res)))
-
-;; Recent audited decisions (chronological).
-(define acl/audit-tail (fn (n) (acl-audit-tail n)))

lib/acl/audit.sx

@@ -1,110 +0,0 @@
-;; lib/acl/audit.sx — append-only decision log.
-;;
-;; Every decision routed through acl-audit-decide! is appended to an in-memory
-;; log with a monotonic sequence number (no wall-clock — deterministic and
-;; testable; a host can stamp time at the serializer boundary). The log is
-;; append-only: there is no mutate or delete, only append, tail, clear,
-;; snapshot/restore, and serialize-for-disk.
-
-(define acl-audit-log (list))
-(define acl-audit-seq 0)
-
-;; Copy a list into a fresh, append!-able list. `map`/`rest`-derived lists are
-;; NOT extensible by append! in this runtime (it silently no-ops), so the live
-;; log must always be a list built with `list` + `append!`.
-(define
-  acl-audit-copy
-  (fn
-    (xs)
-    (let
-      ((fresh (list)))
-      (do (for-each (fn (e) (append! fresh e)) xs) fresh))))
-
-(define
-  acl-audit-clear!
-  (fn
-    ()
-    (do (set! acl-audit-log (list)) (set! acl-audit-seq 0) nil)))
-
-;; Append a decision record. Returns the record.
-(define
-  acl-audit-record!
-  (fn
-    (subj act res allowed?)
-    (let
-      ((entry {:allowed? allowed? :act act :subj subj :res res :seq acl-audit-seq}))
-      (do
-        (set! acl-audit-seq (+ acl-audit-seq 1))
-        (append! acl-audit-log entry)
-        entry))))
-
-;; Decide against db, log the outcome, and return the boolean. This is the
-;; audited path; acl-permit? remains the pure, side-effect-free decision.
-(define
-  acl-audit-decide!
-  (fn
-    (db subj act res)
-    (let
-      ((allowed? (acl-permit? db subj act res)))
-      (do (acl-audit-record! subj act res allowed?) allowed?))))
-
-(define acl-audit-count (fn () (len acl-audit-log)))
-
-;; Most recent n entries (in chronological order). n >= log size returns all.
-(define
-  acl-audit-tail
-  (fn
-    (n)
-    (let
-      ((total (len acl-audit-log)))
-      (if
-        (<= total n)
-        acl-audit-log
-        (acl-audit-drop acl-audit-log (- total n))))))
-
-(define
-  acl-audit-drop
-  (fn
-    (xs k)
-    (if (<= k 0) xs (acl-audit-drop (rest xs) (- k 1)))))
-
-;; Structured snapshot for save/restore — a {:seq :entries} value carrying a
-;; copy of the log (so later appends don't mutate a held snapshot).
-(define acl-audit-snapshot (fn () {:seq acl-audit-seq :entries (acl-audit-copy acl-audit-log)}))
-
-;; Replace the live log from a snapshot. Restores both entries and the seq
-;; counter so subsequent records continue numbering correctly. The log is
-;; rebuilt as a fresh append!-able list (see acl-audit-copy).
-(define
-  acl-audit-restore!
-  (fn
-    (snap)
-    (do
-      (set! acl-audit-log (acl-audit-copy (get snap :entries)))
-      (set! acl-audit-seq (get snap :seq))
-      nil)))
-
-;; Serialize the whole log to a disk-ready string: one record per line,
-;; "seq\tsubj\tact\tres\tallowed?". A host writes this; structured reload is via
-;; snapshot/restore.
-(define
-  acl-audit-serialize
-  (fn
-    ()
-    (reduce
-      (fn
-        (acc e)
-        (str
-          acc
-          (get e :seq)
-          "\t"
-          (get e :subj)
-          "\t"
-          (get e :act)
-          "\t"
-          (get e :res)
-          "\t"
-          (get e :allowed?)
-          "\n"))
-      ""
-      acl-audit-log)))

lib/acl/conformance.conf

@@ -1,32 +0,0 @@
-# ACL conformance config — sourced by lib/guest/conformance.sh.
-
-LANG_NAME=acl
-MODE=dict
-
-PRELOADS=(
-  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/acl/schema.sx
-  lib/acl/facts.sx
-  lib/acl/engine.sx
-  lib/acl/explain.sx
-  lib/acl/audit.sx
-  lib/acl/federation.sx
-  lib/acl/api.sx
-)
-
-SUITES=(
-  "direct:lib/acl/tests/direct.sx:(acl-direct-tests-run!)"
-  "inherit:lib/acl/tests/inherit.sx:(acl-inherit-tests-run!)"
-  "explain:lib/acl/tests/explain.sx:(acl-explain-tests-run!)"
-  "fed:lib/acl/tests/fed.sx:(acl-fed-tests-run!)"
-  "harden:lib/acl/tests/harden.sx:(acl-harden-tests-run!)"
-)

lib/acl/conformance.sh

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

lib/acl/engine.sx

@@ -1,72 +0,0 @@
-;; lib/acl/engine.sx — ACL ruleset + decision reducer over lib/datalog/.
-;;
-;; The engine is a thin layer: it owns the permit ruleset (SX data rules) and
-;; reduces a (subject, action, resource) decision to a Datalog query against a
-;; db built from EDB facts. The rule engine itself is Datalog's.
-;;
-;; Policy — inheritance + federation with deny-overrides:
-;;
-;;   eff_grant(S,A,R) :- grant(S,A,R).                         ; direct
-;;   eff_grant(S,A,R) :- member_of(S,G), eff_grant(G,A,R).     ; group/role chain
-;;   eff_grant(S,A,R) :- child_of(R,P), eff_grant(S,A,P).      ; resource tree
-;;   eff_grant(S,A,R) :- member_of(S,Role), role_grant(Role,A,R). ; role expansion
-;;   eff_grant(S,A,R) :- delegate(Peer,S,A,R),                 ; federated grant
-;;                       trust(Peer,L), level_covers(L,A).
-;;
-;;   eff_deny(S,A,R)  :- deny(S,A,R).                          ; direct
-;;   eff_deny(S,A,R)  :- member_of(S,G), eff_deny(G,A,R).      ; group chain
-;;   eff_deny(S,A,R)  :- child_of(R,P), eff_deny(S,A,P).       ; resource tree
-;;
-;;   permit(S,A,R)    :- eff_grant(S,A,R), not eff_deny(S,A,R).
-;;
-;; DENY-OVERRIDES: an effective deny anywhere in the inheritance closure of
-;; (S,A,R) defeats any effective grant — including federated grants. Deny
-;; inherits through the *same* group and resource chains as grant, so a
-;; group-level or ancestor-resource deny is authoritative for members/
-;; descendants. This is the principled, fail-safe reading of "deny wins".
-;;
-;; FEDERATION — non-transitive trust: a peer's `delegate` fact only grants if a
-;; *local* `trust(Peer, L)` exists AND that level `level_covers` the action.
-;; Trust is re-checked on every query (it is a body literal), never baked in at
-;; fact-ingestion time, so revoking trust or narrowing a level takes effect
-;; immediately on the next decision.
-;;
-;; Termination & stratification:
-;;   - eff_grant/eff_deny recurse only over member_of and child_of, which are
-;;     EDB relations with no function symbols, so the closure is finite (cyclic
-;;     membership/containment just reaches a fixpoint, never loops). The
-;;     federation rule is non-recursive.
-;;   - permit negates eff_deny; neither eff_grant nor eff_deny depends on
-;;     permit, so the program is stratifiable (permit sits in a higher stratum).
-
-(define
-  acl-rules
-  (quote
-    ((eff_grant S A R <- (grant S A R))
-      (eff_grant S A R <- (member_of S G) (eff_grant G A R))
-      (eff_grant S A R <- (child_of R P) (eff_grant S A P))
-      (eff_grant S A R <- (member_of S Role) (role_grant Role A R))
-      (eff_grant
-        S
-        A
-        R
-        <-
-        (delegate Peer S A R)
-        (trust Peer L)
-        (level_covers L A))
-      (eff_deny S A R <- (deny S A R))
-      (eff_deny S A R <- (member_of S G) (eff_deny G A R))
-      (eff_deny S A R <- (child_of R P) (eff_deny S A P))
-      (permit S A R <- (eff_grant S A R) {:neg (eff_deny S A R)}))))
-
-;; Build a Datalog db from a list of EDB facts under the ACL ruleset.
-(define acl-build-db (fn (facts) (dl-program-data facts acl-rules)))
-
-;; Core decision: does the db permit subject S to perform action A on
-;; resource R? Reduces to a ground Datalog query on the derived `permit`
-;; relation — non-empty result means permitted.
-(define
-  acl-permit?
-  (fn
-    (db subj act res)
-    (> (len (dl-query db (list (quote permit) subj act res))) 0)))

lib/acl/explain.sx

@@ -1,125 +0,0 @@
-;; lib/acl/explain.sx — proof-tree reconstruction over the saturated db.
-;;
-;; lib/datalog/ records derived facts but not their provenance, so the proof is
-;; reconstructed here by goal-directed search over the *saturated* db: for a
-;; ground goal we find the first ACL rule (in rule order) whose body holds, take
-;; the first solution binding its remaining variables, and recurse on each body
-;; literal. Negated literals are recorded as verified `:neg-ok` leaves.
-;;
-;; CANONICAL DERIVATION: the Datalog derivation graph is a DAG (a fact may hold
-;; many ways). We pick ONE canonical proof — first matching rule, first solution
-;; — matching the rule order in lib/acl/engine.sx (direct/EDB rules first). A
-;; depth cap guards against pathological cyclic data producing unbounded search.
-;;
-;; A proof node is one of:
-;;   {:fact <lit> :via "edb"}                       — base EDB fact
-;;   {:fact <lit> :rule <head> :body (<node|negleaf> ...)}  — derived
-;;   {:neg-ok <lit>}                                — negation verified to fail
-;;   {:fact <lit> :truncated true}                  — depth cap hit
-
-(define acl-proof-max-depth 64)
-
-;; Substitute a body literal, descending into {:neg ...} dicts (dl-apply-subst
-;; does not recurse into dicts, which would leak the neg's free vars).
-(define
-  acl-subst-lit
-  (fn
-    (lit s)
-    (if
-      (and (dict? lit) (has-key? lit :neg))
-      {:neg (dl-apply-subst (get lit :neg) s)}
-      (dl-apply-subst lit s))))
-
-(define
-  acl-lit-edb?
-  (fn
-    (lit)
-    (and
-      (list? lit)
-      (> (len lit) 0)
-      (symbol? (first lit))
-      (has-key? acl-edb-arity (symbol->string (first lit))))))
-
-(define
-  acl-subst-zip!
-  (fn
-    (d ks vs)
-    (when
-      (> (len ks) 0)
-      (do
-        (dict-set! d (symbol->string (first ks)) (first vs))
-        (acl-subst-zip! d (rest ks) (rest vs))))))
-
-;; Bind a rule head's variables to a ground goal's arguments (positional).
-(define
-  acl-bind-head
-  (fn
-    (head goal)
-    (let
-      ((d {}))
-      (do (acl-subst-zip! d (rest head) (rest goal)) d))))
-
-(define
-  acl-subst-union
-  (fn
-    (a b)
-    (let
-      ((d {}))
-      (do
-        (for-each (fn (k) (dict-set! d k (get a k))) (keys a))
-        (for-each (fn (k) (dict-set! d k (get b k))) (keys b))
-        d))))
-
-(define acl-prove (fn (db goal) (acl-prove-d db goal 0)))
-
-(define
-  acl-prove-d
-  (fn
-    (db goal depth)
-    (cond
-      ((> depth acl-proof-max-depth) {:truncated true :fact goal})
-      ((acl-lit-edb? goal)
-        (if (> (len (dl-query db goal)) 0) {:via "edb" :fact goal} nil))
-      (else (acl-prove-rules db goal acl-rules depth)))))
-
-(define
-  acl-prove-rules
-  (fn
-    (db goal rules depth)
-    (if
-      (= (len rules) 0)
-      nil
-      (let
-        ((p (dl-rule-from-list (first rules))))
-        (if
-          (= (first (get p :head)) (first goal))
-          (let
-            ((hs (acl-bind-head (get p :head) goal)))
-            (let
-              ((qbody (map (fn (l) (acl-subst-lit l hs)) (get p :body))))
-              (let
-                ((sols (dl-query db qbody)))
-                (if
-                  (> (len sols) 0)
-                  (acl-prove-build db goal p hs (first sols) depth)
-                  (acl-prove-rules db goal (rest rules) depth)))))
-          (acl-prove-rules db goal (rest rules) depth))))))
-
-(define
-  acl-prove-build
-  (fn
-    (db goal p hs sol depth)
-    (let ((full (acl-subst-union hs sol))) {:body (map (fn (l) (let ((g (acl-subst-lit l full))) (if (and (dict? g) (has-key? g :neg)) {:neg-ok (get g :neg)} (acl-prove-d db g (+ depth 1))))) (get p :body)) :rule (get p :head) :fact goal})))
-
-;; Public decision-with-proof. Returns:
-;;   {:allowed? <bool> :proof <node|nil> :reason <eff_deny proof|nil>}
-;; When permitted, :proof is the permit derivation. When denied, :proof is nil
-;; and :reason carries the blocking eff_deny proof if one exists (an explicit or
-;; inherited deny), else nil (simply no grant).
-(define
-  acl-explain
-  (fn
-    (db subj act res)
-    (let
-      ((proof (acl-prove db (list (quote permit) subj act res))))
-      (if (= proof nil) {:allowed? false :proof nil :reason (acl-prove db (list (quote eff_deny) subj act res))} {:allowed? true :proof proof :reason nil}))))

lib/acl/facts.sx

@@ -1,47 +0,0 @@
-;; lib/acl/facts.sx — EDB fact constructors.
-;;
-;; Each constructor returns a Datalog fact tuple (a list whose head is the
-;; predicate symbol). These are the only shapes lib/acl/engine.sx feeds to
-;; lib/datalog/.
-;;   Phase 1: actor/resource/grant/deny.
-;;   Phase 2: member_of (subject -> group/role), child_of (resource -> parent),
-;;            role_grant (role -> action,resource capability).
-;;   Phase 4: peer/trust/delegate/level_covers (federation).
-
-(define acl-actor (fn (id kind) (list (quote actor) id kind)))
-
-(define acl-resource-fact (fn (id kind) (list (quote resource) id kind)))
-
-(define acl-grant (fn (subj act res) (list (quote grant) subj act res)))
-
-(define acl-deny (fn (subj act res) (list (quote deny) subj act res)))
-
-;; subject S is a member of group/role G (one hop; transitivity is derived).
-(define acl-member-of (fn (subj grp) (list (quote member_of) subj grp)))
-
-;; resource R is a child of parent P (one hop; transitivity is derived).
-(define acl-child-of (fn (res parent) (list (quote child_of) res parent)))
-
-;; role confers capability (act on res) to every member of the role.
-(define
-  acl-role-grant
-  (fn (role act res) (list (quote role_grant) role act res)))
-
-;; --- federation ---
-
-;; a known peer instance at addr, of some kind (e.g. peer).
-(define acl-peer (fn (addr kind) (list (quote peer) addr kind)))
-
-;; local trust in a peer at a named level. Gates delegated grants at query time.
-(define acl-trust (fn (peer level) (list (quote trust) peer level)))
-
-;; a peer asserts that subject S may A on R. Only takes effect if local trust in
-;; that peer covers action A (see level_covers).
-(define
-  acl-delegate
-  (fn (peer subj act res) (list (quote delegate) peer subj act res)))
-
-;; local policy: trust `level` authorises delegated grants for action `act`.
-(define
-  acl-level-covers
-  (fn (level act) (list (quote level_covers) level act)))

lib/acl/federation.sx

@@ -1,61 +0,0 @@
-;; lib/acl/federation.sx — cross-instance ACL facts + revocation.
-;;
-;; fed-sx replicates ACL facts between instances; this module models the local
-;; side. A peer's authority arrives as `delegate(Peer, S, A, R)` facts, which
-;; only take effect when a local `trust(Peer, L)` and `level_covers(L, A)`
-;; authorise them (enforced by the engine rule, re-checked every query). The
-;; actual network transport is fed-sx's job and is mocked in tests as a dict.
-;;
-;; Trust is NOT transitive: trusting peer α does not extend to peers α trusts.
-;; Only delegate facts that α itself asserts, and that local trust covers, flow.
-
-;; Mock fed-sx pull: `transport` is a dict mapping a peer address (its string
-;; name) to the list of delegate facts that peer asserts. Returns the facts for
-;; `addr`, or an empty list if the peer is unknown / unreachable.
-(define
-  acl-fed-fetch
-  (fn
-    (transport addr)
-    (let
-      ((k (if (symbol? addr) (symbol->string addr) addr)))
-      (if (has-key? transport k) (get transport k) (list)))))
-
-;; Gather delegate facts from every peer in `addrs` via the transport.
-(define
-  acl-fed-collect
-  (fn
-    (transport addrs)
-    (let
-      ((acc (list)))
-      (do
-        (for-each
-          (fn
-            (addr)
-            (for-each
-              (fn (f) (append! acc f))
-              (acl-fed-fetch transport addr)))
-          addrs)
-        acc))))
-
-;; Build a db from local facts plus delegate facts pulled from `peers`. Local
-;; facts must include the `trust`/`level_covers` policy; replicated delegate
-;; facts are gated against it by the engine rule at query time.
-(define
-  acl-fed-build-db
-  (fn
-    (local-facts transport peers)
-    (let
-      ((all (list)))
-      (do
-        (for-each (fn (f) (append! all f)) local-facts)
-        (for-each
-          (fn (f) (append! all f))
-          (acl-fed-collect transport peers))
-        (acl-build-db all)))))
-
-;; Propagated revocation: retract a replicated fact (e.g. a peer's delegate, or
-;; local trust) from a live db. The next decision re-saturates and reflects it.
-(define acl-revoke! (fn (db fact) (do (dl-retract! db fact) db)))
-
-;; Propagated assertion: ingest a newly replicated fact into a live db.
-(define acl-fed-assert! (fn (db fact) (do (dl-assert! db fact) db)))

lib/acl/schema.sx

@@ -1,71 +0,0 @@
-;; lib/acl/schema.sx — ACL sorts and EDB predicate vocabulary.
-;;
-;; Datalog is untyped; this module is the schema-as-data layer. It declares
-;; the subject/resource/action sorts and the arity of every EDB predicate the
-;; ACL engine recognises, plus light validators. Facts that pass these checks
-;; are well-formed inputs to lib/acl/engine.sx.
-
-(define acl-subject-kinds (quote (user group role service)))
-(define acl-resource-kinds (quote (page post thread peer)))
-
-;; Actions are open-ended (a grant may name any action symbol), but these are
-;; the platform's well-known verbs.
-(define acl-actions (quote (read edit comment moderate federate)))
-
-;; EDB predicate name -> arity.
-;;   Phase 1: actor/resource/grant/deny.
-;;   Phase 2: member_of (subject->group/role), child_of (resource->parent),
-;;            role_grant (role->action,resource).
-;;   Phase 4: peer (addr->kind), trust (peer->level),
-;;            delegate (peer->subj,action,resource), level_covers (level->action).
-(define acl-edb-arity {:role_grant 3 :child_of 2 :trust 2 :peer 2 :actor 2 :level_covers 2 :delegate 4 :member_of 2 :deny 3 :grant 3 :resource 2})
-
-(define
-  acl-member?
-  (fn
-    (x xs)
-    (cond
-      ((= (len xs) 0) false)
-      ((= (first xs) x) true)
-      (else (acl-member? x (rest xs))))))
-
-(define acl-subject-kind? (fn (k) (acl-member? k acl-subject-kinds)))
-
-(define acl-resource-kind? (fn (k) (acl-member? k acl-resource-kinds)))
-
-(define acl-known-action? (fn (a) (acl-member? a acl-actions)))
-
-;; A fact is a list whose head is a predicate symbol. Valid when the predicate
-;; is known and the argument count matches the declared arity.
-(define
-  acl-fact-valid?
-  (fn
-    (f)
-    (and
-      (list? f)
-      (> (len f) 0)
-      (symbol? (first f))
-      (let
-        ((pred (symbol->string (first f))))
-        (and
-          (has-key? acl-edb-arity pred)
-          (= (- (len f) 1) (get acl-edb-arity pred)))))))
-
-;; Return the sublist of facts that fail acl-fact-valid?. Empty list means the
-;; whole set is well-formed. acl-build-db stays lenient (Datalog accepts any
-;; tuple, and custom action symbols are allowed); callers opt in to checking.
-(define
-  acl-validate-facts
-  (fn
-    (facts)
-    (let
-      ((bad (list)))
-      (do
-        (for-each
-          (fn (f) (when (not (acl-fact-valid? f)) (append! bad f)))
-          facts)
-        bad))))
-
-(define
-  acl-facts-valid?
-  (fn (facts) (= (len (acl-validate-facts facts)) 0)))

lib/acl/scoreboard.json

@@ -1,14 +0,0 @@
-{
-  "lang": "acl",
-  "total_passed": 145,
-  "total_failed": 0,
-  "total": 145,
-  "suites": [
-    {"name":"direct","passed":24,"failed":0,"total":24},
-    {"name":"inherit","passed":30,"failed":0,"total":30},
-    {"name":"explain","passed":35,"failed":0,"total":35},
-    {"name":"fed","passed":31,"failed":0,"total":31},
-    {"name":"harden","passed":25,"failed":0,"total":25}
-  ],
-  "generated": "2026-06-06T22:43:27+00:00"
-}

lib/acl/scoreboard.md

@@ -1,11 +0,0 @@
-# acl scoreboard
-
-**145 / 145 passing** (0 failure(s)).
-
-| Suite | Passed | Total | Status |
-|-------|--------|-------|--------|
-| direct | 24 | 24 | ok |
-| inherit | 30 | 30 | ok |
-| explain | 35 | 35 | ok |
-| fed | 31 | 31 | ok |
-| harden | 25 | 25 | ok |

lib/acl/tests/direct.sx

@@ -1,170 +0,0 @@
-;; lib/acl/tests/direct.sx — Phase 1: direct grants + deny-overrides.
-
-(define acl-dt-pass 0)
-(define acl-dt-fail 0)
-(define acl-dt-failures (list))
-
-(define
-  acl-dt-check!
-  (fn
-    (name got expected)
-    (if
-      (= got expected)
-      (set! acl-dt-pass (+ acl-dt-pass 1))
-      (do
-        (set! acl-dt-fail (+ acl-dt-fail 1))
-        (append!
-          acl-dt-failures
-          (str name "\n    expected: " expected "\n    got:      " got))))))
-
-;; A small fixture used by most cases: alice can read page1, is denied edit on
-;; page1, and a service may federate peer1.
-(define
-  acl-dt-fixture
-  (fn
-    ()
-    (acl-build-db
-      (list
-        (acl-actor (quote alice) (quote user))
-        (acl-actor (quote svc1) (quote service))
-        (acl-resource-fact (quote page1) (quote page))
-        (acl-resource-fact (quote peer1) (quote peer))
-        (acl-grant (quote alice) (quote read) (quote page1))
-        (acl-grant (quote alice) (quote edit) (quote page1))
-        (acl-deny (quote alice) (quote edit) (quote page1))
-        (acl-grant (quote svc1) (quote federate) (quote peer1))))))
-
-(define
-  acl-dt-run-all!
-  (fn
-    ()
-    (let
-      ((db (acl-dt-fixture)))
-      (do
-        (acl-dt-check!
-          "direct grant permits"
-          (acl-permit? db (quote alice) (quote read) (quote page1))
-          true)
-        (acl-dt-check!
-          "service grant permits federate"
-          (acl-permit? db (quote svc1) (quote federate) (quote peer1))
-          true)
-        (acl-dt-check!
-          "missing action denied"
-          (acl-permit? db (quote alice) (quote comment) (quote page1))
-          false)
-        (acl-dt-check!
-          "missing resource denied"
-          (acl-permit? db (quote alice) (quote read) (quote page2))
-          false)
-        (acl-dt-check!
-          "missing subject denied"
-          (acl-permit? db (quote bob) (quote read) (quote page1))
-          false)
-        (acl-dt-check!
-          "wrong subject for service grant denied"
-          (acl-permit? db (quote alice) (quote federate) (quote peer1))
-          false)
-        (acl-dt-check!
-          "grant plus deny -> deny wins"
-          (acl-permit? db (quote alice) (quote edit) (quote page1))
-          false)
-        (acl-dt-check!
-          "deny alone still denies"
-          (acl-permit?
-            (acl-build-db
-              (list (acl-deny (quote alice) (quote read) (quote page1))))
-            (quote alice)
-            (quote read)
-            (quote page1))
-          false)
-        (acl-dt-check!
-          "deny on edit does not block read"
-          (acl-permit? db (quote alice) (quote read) (quote page1))
-          true)
-        (acl-dt-check!
-          "empty db denies"
-          (acl-permit?
-            (acl-build-db (list))
-            (quote alice)
-            (quote read)
-            (quote page1))
-          false)
-        (let
-          ((db2 (acl-build-db (list (acl-grant (quote a) (quote read) (quote r)) (acl-grant (quote b) (quote read) (quote r)) (acl-deny (quote b) (quote read) (quote r))))))
-          (do
-            (acl-dt-check!
-              "subject a allowed"
-              (acl-permit? db2 (quote a) (quote read) (quote r))
-              true)
-            (acl-dt-check!
-              "subject b denied by override"
-              (acl-permit? db2 (quote b) (quote read) (quote r))
-              false)))
-        (let
-          ((db3 (acl-build-db (list (acl-actor (quote editors) (quote role)) (acl-grant (quote editors) (quote edit) (quote post1))))))
-          (acl-dt-check!
-            "role subject direct grant"
-            (acl-permit? db3 (quote editors) (quote edit) (quote post1))
-            true))
-        (do
-          (acl/load!
-            (list
-              (acl-grant (quote carol) (quote moderate) (quote thread1))))
-          (acl-dt-check!
-            "api permit via current db"
-            (acl/permit? (quote carol) (quote moderate) (quote thread1))
-            true)
-          (acl-dt-check!
-            "api deny via current db"
-            (acl/permit? (quote carol) (quote read) (quote thread1))
-            false))
-        (do
-          (acl/load! (list))
-          (acl-dt-check!
-            "api reload clears prior grants"
-            (acl/permit? (quote carol) (quote moderate) (quote thread1))
-            false))
-        (acl-dt-check!
-          "schema grant arity valid"
-          (acl-fact-valid? (acl-grant (quote x) (quote read) (quote y)))
-          true)
-        (acl-dt-check!
-          "schema bad arity invalid"
-          (acl-fact-valid? (list (quote grant) (quote x)))
-          false)
-        (acl-dt-check!
-          "schema unknown predicate invalid"
-          (acl-fact-valid? (list (quote frobnicate) (quote x)))
-          false)
-        (acl-dt-check!
-          "schema subject kind known"
-          (acl-subject-kind? (quote service))
-          true)
-        (acl-dt-check!
-          "schema resource kind unknown"
-          (acl-resource-kind? (quote galaxy))
-          false)
-        (acl-dt-check!
-          "schema known action"
-          (acl-known-action? (quote moderate))
-          true)
-        (acl-dt-check!
-          "grant constructor shape"
-          (acl-grant (quote u) (quote read) (quote p))
-          (list (quote grant) (quote u) (quote read) (quote p)))
-        (acl-dt-check!
-          "actor constructor shape"
-          (acl-actor (quote u) (quote user))
-          (list (quote actor) (quote u) (quote user)))))))
-
-(define
-  acl-direct-tests-run!
-  (fn
-    ()
-    (do
-      (set! acl-dt-pass 0)
-      (set! acl-dt-fail 0)
-      (set! acl-dt-failures (list))
-      (acl-dt-run-all!)
-      {:failures acl-dt-failures :total (+ acl-dt-pass acl-dt-fail) :passed acl-dt-pass :failed acl-dt-fail})))

lib/acl/tests/explain.sx

@@ -1,316 +0,0 @@
-;; lib/acl/tests/explain.sx — Phase 3: proof correctness + audit completeness.
-
-(define acl-et-pass 0)
-(define acl-et-fail 0)
-(define acl-et-failures (list))
-
-;; Name-based deep equality. The host `=` compares symbols by interned
-;; identity, which is unstable across substitution/saturation; comparing by
-;; name (as the datalog suite does) makes structural assertions deterministic.
-(define
-  acl-et-eq?
-  (fn
-    (a b)
-    (cond
-      ((and (list? a) (list? b))
-        (and (= (len a) (len b)) (acl-et-eq-l? a b 0)))
-      ((and (dict? a) (dict? b))
-        (let
-          ((ka (keys a)) (kb (keys b)))
-          (and (= (len ka) (len kb)) (acl-et-eq-d? a b ka 0))))
-      ((and (symbol? a) (symbol? b))
-        (= (symbol->string a) (symbol->string b)))
-      (else (= a b)))))
-
-(define
-  acl-et-eq-l?
-  (fn
-    (a b i)
-    (cond
-      ((>= i (len a)) true)
-      ((not (acl-et-eq? (nth a i) (nth b i))) false)
-      (else (acl-et-eq-l? a b (+ i 1))))))
-
-(define
-  acl-et-eq-d?
-  (fn
-    (a b ka i)
-    (cond
-      ((>= i (len ka)) true)
-      ((let ((k (nth ka i))) (not (acl-et-eq? (get a k) (get b k))))
-        false)
-      (else (acl-et-eq-d? a b ka (+ i 1))))))
-
-(define
-  acl-et-check!
-  (fn
-    (name got expected)
-    (if
-      (acl-et-eq? got expected)
-      (set! acl-et-pass (+ acl-et-pass 1))
-      (do
-        (set! acl-et-fail (+ acl-et-fail 1))
-        (append!
-          acl-et-failures
-          (str name "\n    expected: " expected "\n    got:      " got))))))
-
-;; --- proof-tree walkers ---
-
-;; True if EDB fact `target` appears as a base leaf anywhere in the proof.
-(define
-  acl-et-has-leaf?
-  (fn
-    (node target)
-    (cond
-      ((= node nil) false)
-      ((and (dict? node) (has-key? node :via))
-        (acl-et-eq? (get node :fact) target))
-      ((and (dict? node) (has-key? node :body))
-        (acl-et-any-leaf? (get node :body) target))
-      (else false))))
-
-(define
-  acl-et-any-leaf?
-  (fn
-    (nodes target)
-    (cond
-      ((= (len nodes) 0) false)
-      ((acl-et-has-leaf? (first nodes) target) true)
-      (else (acl-et-any-leaf? (rest nodes) target)))))
-
-;; True if the proof records a verified negation (deny did not fire).
-(define
-  acl-et-has-negok?
-  (fn
-    (node)
-    (cond
-      ((= node nil) false)
-      ((and (dict? node) (has-key? node :neg-ok)) true)
-      ((and (dict? node) (has-key? node :body))
-        (acl-et-any-negok? (get node :body)))
-      (else false))))
-
-(define
-  acl-et-any-negok?
-  (fn
-    (nodes)
-    (cond
-      ((= (len nodes) 0) false)
-      ((acl-et-has-negok? (first nodes)) true)
-      (else (acl-et-any-negok? (rest nodes))))))
-
-(define
-  acl-et-run-all!
-  (fn
-    ()
-    (do
-      (let
-        ((db (acl-build-db (list (acl-grant (quote u) (quote read) (quote p))))))
-        (let
-          ((e (acl-explain db (quote u) (quote read) (quote p))))
-          (do
-            (acl-et-check! "direct: allowed?" (get e :allowed?) true)
-            (acl-et-check!
-              "direct: proof root fact"
-              (get (get e :proof) :fact)
-              (list (quote permit) (quote u) (quote read) (quote p)))
-            (acl-et-check!
-              "direct: grant leaf present"
-              (acl-et-has-leaf?
-                (get e :proof)
-                (list (quote grant) (quote u) (quote read) (quote p)))
-              true)
-            (acl-et-check!
-              "direct: negation verified"
-              (acl-et-has-negok? (get e :proof))
-              true)
-            (acl-et-check!
-              "direct: reason nil when allowed"
-              (get e :reason)
-              nil))))
-      (let
-        ((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-member-of (quote team) (quote org)) (acl-grant (quote org) (quote read) (quote doc))))))
-        (let
-          ((e (acl-explain db (quote alice) (quote read) (quote doc))))
-          (do
-            (acl-et-check! "group: allowed?" (get e :allowed?) true)
-            (acl-et-check!
-              "group: member_of alice leaf"
-              (acl-et-has-leaf?
-                (get e :proof)
-                (list (quote member_of) (quote alice) (quote team)))
-              true)
-            (acl-et-check!
-              "group: member_of team leaf"
-              (acl-et-has-leaf?
-                (get e :proof)
-                (list (quote member_of) (quote team) (quote org)))
-              true)
-            (acl-et-check!
-              "group: grant org leaf at base"
-              (acl-et-has-leaf?
-                (get e :proof)
-                (list (quote grant) (quote org) (quote read) (quote doc)))
-              true))))
-      (let
-        ((db (acl-build-db (list (acl-child-of (quote sec) (quote book)) (acl-grant (quote u) (quote read) (quote book))))))
-        (let
-          ((e (acl-explain db (quote u) (quote read) (quote sec))))
-          (do
-            (acl-et-check! "resource: allowed?" (get e :allowed?) true)
-            (acl-et-check!
-              "resource: child_of leaf"
-              (acl-et-has-leaf?
-                (get e :proof)
-                (list (quote child_of) (quote sec) (quote book)))
-              true)
-            (acl-et-check!
-              "resource: grant on parent leaf"
-              (acl-et-has-leaf?
-                (get e :proof)
-                (list (quote grant) (quote u) (quote read) (quote book)))
-              true))))
-      (let
-        ((db (acl-build-db (list (acl-member-of (quote bob) (quote editor)) (acl-role-grant (quote editor) (quote edit) (quote page1))))))
-        (let
-          ((e (acl-explain db (quote bob) (quote edit) (quote page1))))
-          (do
-            (acl-et-check! "role: allowed?" (get e :allowed?) true)
-            (acl-et-check!
-              "role: member_of leaf"
-              (acl-et-has-leaf?
-                (get e :proof)
-                (list (quote member_of) (quote bob) (quote editor)))
-              true)
-            (acl-et-check!
-              "role: role_grant leaf"
-              (acl-et-has-leaf?
-                (get e :proof)
-                (list
-                  (quote role_grant)
-                  (quote editor)
-                  (quote edit)
-                  (quote page1)))
-              true))))
-      (let
-        ((db (acl-build-db (list (acl-grant (quote u) (quote edit) (quote p)) (acl-deny (quote u) (quote edit) (quote p))))))
-        (let
-          ((e (acl-explain db (quote u) (quote edit) (quote p))))
-          (do
-            (acl-et-check! "deny: not allowed" (get e :allowed?) false)
-            (acl-et-check! "deny: no proof" (get e :proof) nil)
-            (acl-et-check!
-              "deny: reason root is eff_deny"
-              (get (get e :reason) :fact)
-              (list (quote eff_deny) (quote u) (quote edit) (quote p)))
-            (acl-et-check!
-              "deny: reason has deny leaf"
-              (acl-et-has-leaf?
-                (get e :reason)
-                (list (quote deny) (quote u) (quote edit) (quote p)))
-              true))))
-      (let
-        ((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-grant (quote alice) (quote read) (quote doc)) (acl-deny (quote team) (quote read) (quote doc))))))
-        (let
-          ((e (acl-explain db (quote alice) (quote read) (quote doc))))
-          (do
-            (acl-et-check!
-              "inherited deny: not allowed"
-              (get e :allowed?)
-              false)
-            (acl-et-check!
-              "inherited deny: reason has member_of leaf"
-              (acl-et-has-leaf?
-                (get e :reason)
-                (list (quote member_of) (quote alice) (quote team)))
-              true)
-            (acl-et-check!
-              "inherited deny: reason has group deny leaf"
-              (acl-et-has-leaf?
-                (get e :reason)
-                (list (quote deny) (quote team) (quote read) (quote doc)))
-              true))))
-      (let
-        ((db (acl-build-db (list))))
-        (let
-          ((e (acl-explain db (quote u) (quote read) (quote p))))
-          (do
-            (acl-et-check! "no grant: not allowed" (get e :allowed?) false)
-            (acl-et-check! "no grant: proof nil" (get e :proof) nil)
-            (acl-et-check! "no grant: reason nil" (get e :reason) nil))))
-      (let
-        ((db (acl-build-db (list (acl-grant (quote u) (quote read) (quote p)) (acl-deny (quote u) (quote edit) (quote p))))))
-        (do
-          (acl-audit-clear!)
-          (acl-et-check! "audit: starts empty" (acl-audit-count) 0)
-          (acl-et-check!
-            "audit decide allowed returns true"
-            (acl-audit-decide! db (quote u) (quote read) (quote p))
-            true)
-          (acl-et-check!
-            "audit decide denied returns false"
-            (acl-audit-decide! db (quote u) (quote edit) (quote p))
-            false)
-          (acl-audit-decide! db (quote u) (quote comment) (quote p))
-          (acl-et-check!
-            "audit: count after three decisions"
-            (acl-audit-count)
-            3)
-          (acl-et-check!
-            "audit: tail size respects n"
-            (len (acl-audit-tail 2))
-            2)
-          (acl-et-check!
-            "audit: tail returns most recent"
-            (get (first (acl-audit-tail 1)) :act)
-            (quote comment))
-          (acl-et-check!
-            "audit: first record seq is 0"
-            (get (first (acl-audit-tail 3)) :seq)
-            0)
-          (acl-et-check!
-            "audit: allowed flag recorded"
-            (get (first (acl-audit-tail 3)) :allowed?)
-            true)
-          (acl-et-check!
-            "audit: serialize line count"
-            (len (acl-et-lines (acl-audit-serialize)))
-            3)
-          (acl-audit-clear!)
-          (acl-et-check!
-            "audit: clear resets count"
-            (acl-audit-count)
-            0))))))
-
-;; count newline-terminated lines in a serialized log
-(define acl-et-lines (fn (s) (acl-et-count-nl s 0 0)))
-(define
-  acl-et-count-nl
-  (fn
-    (s i n)
-    (if
-      (>= i (len s))
-      (if (= n 0) (list) (acl-et-rangelist n))
-      (acl-et-count-nl
-        s
-        (+ i 1)
-        (if (= (slice s i (+ i 1)) "\n") (+ n 1) n)))))
-(define
-  acl-et-rangelist
-  (fn
-    (n)
-    (if
-      (<= n 0)
-      (list)
-      (cons n (acl-et-rangelist (- n 1))))))
-
-(define
-  acl-explain-tests-run!
-  (fn
-    ()
-    (do
-      (set! acl-et-pass 0)
-      (set! acl-et-fail 0)
-      (set! acl-et-failures (list))
-      (acl-et-run-all!)
-      {:failures acl-et-failures :total (+ acl-et-pass acl-et-fail) :passed acl-et-pass :failed acl-et-fail})))

lib/acl/tests/fed.sx

@@ -1,273 +0,0 @@
-;; lib/acl/tests/fed.sx — Phase 4: federation (peer trust, delegation,
-;; cross-instance chains, revocation). fed-sx transport is mocked as a dict.
-
-(define acl-ft-pass 0)
-(define acl-ft-fail 0)
-(define acl-ft-failures (list))
-
-;; Name-based deep equality (host `=` compares symbols by unstable interned
-;; identity; see lib/acl/tests/explain.sx).
-(define
-  acl-ft-eq?
-  (fn
-    (a b)
-    (cond
-      ((and (list? a) (list? b))
-        (and (= (len a) (len b)) (acl-ft-eq-l? a b 0)))
-      ((and (symbol? a) (symbol? b))
-        (= (symbol->string a) (symbol->string b)))
-      (else (= a b)))))
-(define
-  acl-ft-eq-l?
-  (fn
-    (a b i)
-    (cond
-      ((>= i (len a)) true)
-      ((not (acl-ft-eq? (nth a i) (nth b i))) false)
-      (else (acl-ft-eq-l? a b (+ i 1))))))
-
-(define
-  acl-ft-check!
-  (fn
-    (name got expected)
-    (if
-      (acl-ft-eq? got expected)
-      (set! acl-ft-pass (+ acl-ft-pass 1))
-      (do
-        (set! acl-ft-fail (+ acl-ft-fail 1))
-        (append!
-          acl-ft-failures
-          (str name "\n    expected: " expected "\n    got:      " got))))))
-
-;; proof leaf walker (federated proofs reconstruct through the engine rule).
-(define
-  acl-ft-has-leaf?
-  (fn
-    (node target)
-    (cond
-      ((= node nil) false)
-      ((and (dict? node) (has-key? node :via))
-        (acl-ft-eq? (get node :fact) target))
-      ((and (dict? node) (has-key? node :body))
-        (acl-ft-any-leaf? (get node :body) target))
-      (else false))))
-(define
-  acl-ft-any-leaf?
-  (fn
-    (nodes target)
-    (cond
-      ((= (len nodes) 0) false)
-      ((acl-ft-has-leaf? (first nodes) target) true)
-      (else (acl-ft-any-leaf? (rest nodes) target)))))
-
-(define acl-ft-p? (fn (db s a r) (acl-permit? db s a r)))
-
-;; A standard federation fixture: local trusts peer alpha at "readonly", which
-;; covers read+comment. alpha delegates several capabilities to alice.
-(define
-  acl-ft-fixture
-  (fn
-    ()
-    (acl-build-db
-      (list
-        (acl-trust (quote alpha) (quote readonly))
-        (acl-level-covers (quote readonly) (quote read))
-        (acl-level-covers (quote readonly) (quote comment))
-        (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc))
-        (acl-delegate (quote alpha) (quote alice) (quote edit) (quote doc))))))
-
-(define
-  acl-ft-run-all!
-  (fn
-    ()
-    (do
-      (let
-        ((db (acl-ft-fixture)))
-        (do
-          (acl-ft-check!
-            "trusted delegate, level covers action -> permit"
-            (acl-ft-p? db (quote alice) (quote read) (quote doc))
-            true)
-          (acl-ft-check!
-            "trusted delegate, level does NOT cover action -> deny"
-            (acl-ft-p? db (quote alice) (quote edit) (quote doc))
-            false)
-          (acl-ft-check!
-            "delegated but action class uncovered (comment has no delegate)"
-            (acl-ft-p? db (quote alice) (quote comment) (quote doc))
-            false)))
-      (let
-        ((db (acl-build-db (list (acl-level-covers (quote readonly) (quote read)) (acl-delegate (quote beta) (quote bob) (quote read) (quote doc))))))
-        (acl-ft-check!
-          "untrusted peer delegate -> deny"
-          (acl-ft-p? db (quote bob) (quote read) (quote doc))
-          false))
-      (let
-        ((db (acl-build-db (list (acl-trust (quote alpha) (quote readonly)) (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc))))))
-        (acl-ft-check!
-          "trust but no level_covers -> deny"
-          (acl-ft-p? db (quote alice) (quote read) (quote doc))
-          false))
-      (let
-        ((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc)) (acl-delegate (quote beta) (quote bob) (quote read) (quote doc))))))
-        (do
-          (acl-ft-check!
-            "trust is per-peer: alpha's delegate applies"
-            (acl-ft-p? db (quote alice) (quote read) (quote doc))
-            true)
-          (acl-ft-check!
-            "trust not transitive: beta's delegate does not apply"
-            (acl-ft-p? db (quote bob) (quote read) (quote doc))
-            false)))
-      (let
-        ((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc)) (acl-deny (quote alice) (quote read) (quote doc))))))
-        (acl-ft-check!
-          "local deny overrides federated grant"
-          (acl-ft-p? db (quote alice) (quote read) (quote doc))
-          false))
-      (let
-        ((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-member-of (quote alice) (quote team)) (acl-delegate (quote alpha) (quote team) (quote read) (quote doc))))))
-        (acl-ft-check!
-          "federated grant to group reaches member"
-          (acl-ft-p? db (quote alice) (quote read) (quote doc))
-          true))
-      (let
-        ((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-child-of (quote sec) (quote book)) (acl-delegate (quote alpha) (quote u) (quote read) (quote book))))))
-        (acl-ft-check!
-          "federated grant on parent resource reaches child"
-          (acl-ft-p? db (quote u) (quote read) (quote sec))
-          true))
-      (let
-        ((transport {:gamma (list (acl-delegate (quote gamma) (quote carol) (quote read) (quote post))) :alpha (list (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc)))}))
-        (do
-          (acl-ft-check!
-            "fetch known peer returns its delegates"
-            (len (acl-fed-fetch transport (quote alpha)))
-            1)
-          (acl-ft-check!
-            "fetch unknown peer returns empty"
-            (len (acl-fed-fetch transport (quote delta)))
-            0)
-          (acl-ft-check!
-            "collect across peers"
-            (len
-              (acl-fed-collect transport (list (quote alpha) (quote gamma))))
-            2)
-          (let
-            ((db (acl-fed-build-db (list (acl-trust (quote alpha) (quote readonly)) (acl-trust (quote gamma) (quote readonly)) (acl-level-covers (quote readonly) (quote read))) transport (list (quote alpha) (quote gamma)))))
-            (do
-              (acl-ft-check!
-                "fed-build-db: alpha delegate permits"
-                (acl-ft-p? db (quote alice) (quote read) (quote doc))
-                true)
-              (acl-ft-check!
-                "fed-build-db: gamma delegate permits"
-                (acl-ft-p? db (quote carol) (quote read) (quote post))
-                true)
-              (acl-ft-check!
-                "fed-build-db: untrusted action still denied"
-                (acl-ft-p? db (quote alice) (quote edit) (quote doc))
-                false)))))
-      (let
-        ((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc))))))
-        (do
-          (acl-ft-check!
-            "before revoke: permitted"
-            (acl-ft-p? db (quote alice) (quote read) (quote doc))
-            true)
-          (acl-revoke!
-            db
-            (acl-delegate
-              (quote alpha)
-              (quote alice)
-              (quote read)
-              (quote doc)))
-          (acl-ft-check!
-            "after delegate revoked: denied"
-            (acl-ft-p? db (quote alice) (quote read) (quote doc))
-            false)))
-      (let
-        ((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc))))))
-        (do
-          (acl-ft-check!
-            "before trust revoke: permitted"
-            (acl-ft-p? db (quote alice) (quote read) (quote doc))
-            true)
-          (acl-revoke! db (acl-trust (quote alpha) (quote full)))
-          (acl-ft-check!
-            "after trust revoked: denied"
-            (acl-ft-p? db (quote alice) (quote read) (quote doc))
-            false)))
-      (let
-        ((db (acl-build-db (list (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc))))))
-        (do
-          (acl-ft-check!
-            "delegate without trust: denied"
-            (acl-ft-p? db (quote alice) (quote read) (quote doc))
-            false)
-          (acl-fed-assert! db (acl-trust (quote alpha) (quote full)))
-          (acl-ft-check!
-            "trust ingested then re-checked: permitted"
-            (acl-ft-p? db (quote alice) (quote read) (quote doc))
-            true)))
-      (let
-        ((db (acl-ft-fixture)))
-        (let
-          ((e (acl-explain db (quote alice) (quote read) (quote doc))))
-          (do
-            (acl-ft-check! "federated proof allowed?" (get e :allowed?) true)
-            (acl-ft-check!
-              "federated proof has delegate leaf"
-              (acl-ft-has-leaf?
-                (get e :proof)
-                (list
-                  (quote delegate)
-                  (quote alpha)
-                  (quote alice)
-                  (quote read)
-                  (quote doc)))
-              true)
-            (acl-ft-check!
-              "federated proof has trust leaf"
-              (acl-ft-has-leaf?
-                (get e :proof)
-                (list (quote trust) (quote alpha) (quote readonly)))
-              true)
-            (acl-ft-check!
-              "federated proof has level_covers leaf"
-              (acl-ft-has-leaf?
-                (get e :proof)
-                (list (quote level_covers) (quote readonly) (quote read)))
-              true))))
-      (acl-ft-check!
-        "schema delegate arity valid"
-        (acl-fact-valid?
-          (acl-delegate (quote p) (quote s) (quote a) (quote r)))
-        true)
-      (acl-ft-check!
-        "schema trust arity valid"
-        (acl-fact-valid? (acl-trust (quote p) (quote l)))
-        true)
-      (acl-ft-check!
-        "schema peer arity valid"
-        (acl-fact-valid? (acl-peer (quote p) (quote peer)))
-        true)
-      (acl-ft-check!
-        "schema level_covers arity valid"
-        (acl-fact-valid? (acl-level-covers (quote l) (quote read)))
-        true)
-      (acl-ft-check!
-        "schema delegate bad arity invalid"
-        (acl-fact-valid? (list (quote delegate) (quote p) (quote s)))
-        false))))
-
-(define
-  acl-fed-tests-run!
-  (fn
-    ()
-    (do
-      (set! acl-ft-pass 0)
-      (set! acl-ft-fail 0)
-      (set! acl-ft-failures (list))
-      (acl-ft-run-all!)
-      {:failures acl-ft-failures :total (+ acl-ft-pass acl-ft-fail) :passed acl-ft-pass :failed acl-ft-fail})))

lib/acl/tests/harden.sx

@@ -1,228 +0,0 @@
-;; lib/acl/tests/harden.sx — adversarial / cross-phase hardening.
-;;
-;; Diamond hierarchies, conflict resolution where deny must win through every
-;; path, chain inheritance, cycle termination, multi-peer delegation, fact
-;; validation, and audit save/restore.
-;;
-;; PROVER-FREE BY DESIGN: this suite calls only acl-permit? (which runs in
-;; compiled Datalog, safe at any depth) plus pure data ops — never acl-explain /
-;; acl-prove-d. The SX-side proof reconstructor recurses, and once the kernel
-;; JIT-compiles it (after the explain/fed suites warm the process) it loops on
-;; chains deeper than ~3 (substrate JIT bug — see plan Blockers). Proof
-;; reconstruction is covered by tests/explain.sx (and federated proofs by
-;; tests/fed.sx), both of which stay under the warm-process depth threshold.
-
-(define acl-hd-pass 0)
-(define acl-hd-fail 0)
-(define acl-hd-failures (list))
-
-(define
-  acl-hd-check!
-  (fn
-    (name got expected)
-    (if
-      (= got expected)
-      (set! acl-hd-pass (+ acl-hd-pass 1))
-      (do
-        (set! acl-hd-fail (+ acl-hd-fail 1))
-        (append!
-          acl-hd-failures
-          (str name "\n    expected: " expected "\n    got:      " got))))))
-
-(define acl-hd-p? (fn (db s a r) (acl-permit? db s a r)))
-
-(define
-  acl-hd-run-all!
-  (fn
-    ()
-    (do
-      (let
-        ((grant-deny (acl-build-db (list (acl-child-of (quote r) (quote p1)) (acl-child-of (quote r) (quote p2)) (acl-grant (quote u) (quote read) (quote p1)) (acl-deny (quote u) (quote read) (quote p2)))))
-          (both-grant
-            (acl-build-db
-              (list
-                (acl-child-of (quote r) (quote p1))
-                (acl-child-of (quote r) (quote p2))
-                (acl-grant (quote u) (quote read) (quote p1))
-                (acl-grant (quote u) (quote read) (quote p2))))))
-        (do
-          (acl-hd-check!
-            "diamond resource: grant+deny parents -> deny wins"
-            (acl-hd-p? grant-deny (quote u) (quote read) (quote r))
-            false)
-          (acl-hd-check!
-            "diamond resource: both grant -> permit"
-            (acl-hd-p? both-grant (quote u) (quote read) (quote r))
-            true)
-          (acl-hd-check!
-            "diamond resource: deny does not leak to other parent"
-            (acl-hd-p? grant-deny (quote u) (quote read) (quote p1))
-            true)))
-      (let
-        ((grant-deny (acl-build-db (list (acl-member-of (quote alice) (quote g1)) (acl-member-of (quote alice) (quote g2)) (acl-grant (quote g1) (quote read) (quote doc)) (acl-deny (quote g2) (quote read) (quote doc)))))
-          (both-grant
-            (acl-build-db
-              (list
-                (acl-member-of (quote alice) (quote g1))
-                (acl-member-of (quote alice) (quote g2))
-                (acl-grant (quote g1) (quote read) (quote doc))
-                (acl-grant (quote g2) (quote read) (quote doc))))))
-        (do
-          (acl-hd-check!
-            "diamond group: grant+deny groups -> deny wins"
-            (acl-hd-p? grant-deny (quote alice) (quote read) (quote doc))
-            false)
-          (acl-hd-check!
-            "diamond group: both grant -> permit"
-            (acl-hd-p? both-grant (quote alice) (quote read) (quote doc))
-            true)))
-      (let
-        ((chain (acl-build-db (list (acl-member-of (quote a0) (quote a1)) (acl-member-of (quote a1) (quote a2)) (acl-member-of (quote a2) (quote a3)) (acl-member-of (quote a3) (quote a4)) (acl-grant (quote a4) (quote read) (quote res)))))
-          (chain-deny
-            (acl-build-db
-              (list
-                (acl-member-of (quote a0) (quote a1))
-                (acl-member-of (quote a1) (quote a2))
-                (acl-member-of (quote a2) (quote a3))
-                (acl-member-of (quote a3) (quote a4))
-                (acl-grant (quote a4) (quote read) (quote res))
-                (acl-deny (quote a0) (quote read) (quote res))))))
-        (do
-          (acl-hd-check!
-            "chain: top-group grant reaches leaf member"
-            (acl-hd-p? chain (quote a0) (quote read) (quote res))
-            true)
-          (acl-hd-check!
-            "chain: intermediate also covered"
-            (acl-hd-p? chain (quote a2) (quote read) (quote res))
-            true)
-          (acl-hd-check!
-            "chain: leaf-member deny overrides top grant"
-            (acl-hd-p? chain-deny (quote a0) (quote read) (quote res))
-            false)
-          (acl-hd-check!
-            "chain: deny on leaf does not block sibling level"
-            (acl-hd-p? chain-deny (quote a1) (quote read) (quote res))
-            true)))
-      (let
-        ((self-member (acl-build-db (list (acl-member-of (quote a) (quote a)) (acl-grant (quote a) (quote read) (quote r)))))
-          (self-child
-            (acl-build-db
-              (list
-                (acl-child-of (quote r) (quote r))
-                (acl-grant (quote u) (quote read) (quote r)))))
-          (two-cycle
-            (acl-build-db
-              (list
-                (acl-member-of (quote x) (quote y))
-                (acl-member-of (quote y) (quote x))
-                (acl-grant (quote y) (quote read) (quote r))))))
-        (do
-          (acl-hd-check!
-            "self-membership cycle terminates and grants"
-            (acl-hd-p? self-member (quote a) (quote read) (quote r))
-            true)
-          (acl-hd-check!
-            "self-child cycle terminates and grants"
-            (acl-hd-p? self-child (quote u) (quote read) (quote r))
-            true)
-          (acl-hd-check!
-            "two-node membership cycle terminates"
-            (acl-hd-p? two-cycle (quote x) (quote read) (quote r))
-            true)))
-      (let
-        ((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-member-of (quote alice) (quote team)) (acl-delegate (quote alpha) (quote team) (quote read) (quote doc)) (acl-deny (quote alice) (quote read) (quote doc))))))
-        (acl-hd-check!
-          "federated group grant, local member deny -> deny wins"
-          (acl-hd-p? db (quote alice) (quote read) (quote doc))
-          false))
-      (let
-        ((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote bob) (quote read) (quote doc)) (acl-delegate (quote beta) (quote bob) (quote read) (quote doc))))))
-        (acl-hd-check!
-          "two peers delegate, one trusted -> permit"
-          (acl-hd-p? db (quote bob) (quote read) (quote doc))
-          true))
-      (let
-        ((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-trust (quote beta) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote bob) (quote read) (quote doc)) (acl-delegate (quote beta) (quote bob) (quote read) (quote doc))))))
-        (acl-hd-check!
-          "two peers both trusted -> permit"
-          (acl-hd-p? db (quote bob) (quote read) (quote doc))
-          true))
-      (let
-        ((empty (acl-build-db (list))))
-        (acl-hd-check!
-          "empty db: nothing permitted"
-          (acl-hd-p? empty (quote u) (quote read) (quote r))
-          false))
-      (do
-        (acl-hd-check!
-          "validate: clean set has no bad facts"
-          (len
-            (acl-validate-facts
-              (list
-                (acl-grant (quote u) (quote read) (quote p))
-                (acl-member-of (quote u) (quote g))
-                (acl-delegate (quote pe) (quote u) (quote read) (quote p)))))
-          0)
-        (acl-hd-check!
-          "validate: facts-valid? true on clean set"
-          (acl-facts-valid?
-            (list (acl-grant (quote u) (quote read) (quote p))))
-          true)
-        (acl-hd-check!
-          "validate: surfaces wrong-arity and unknown predicate"
-          (len
-            (acl-validate-facts
-              (list
-                (acl-grant (quote u) (quote read) (quote p))
-                (list (quote grant) (quote u))
-                (list (quote bogus) (quote x) (quote y)))))
-          2)
-        (acl-hd-check!
-          "validate: empty set is valid"
-          (acl-facts-valid? (list))
-          true))
-      (let
-        ((db (acl-build-db (list (acl-grant (quote u) (quote read) (quote p)) (acl-deny (quote u) (quote edit) (quote p))))))
-        (do
-          (acl-audit-clear!)
-          (acl-audit-decide! db (quote u) (quote read) (quote p))
-          (acl-audit-decide! db (quote u) (quote edit) (quote p))
-          (let
-            ((snap (acl-audit-snapshot)))
-            (do
-              (acl-audit-clear!)
-              (acl-hd-check!
-                "audit: cleared count is 0"
-                (acl-audit-count)
-                0)
-              (acl-audit-restore! snap)
-              (acl-hd-check!
-                "audit: restored count"
-                (acl-audit-count)
-                2)
-              (acl-hd-check!
-                "audit: restored last act"
-                (get (first (acl-audit-tail 1)) :act)
-                (quote edit))
-              (acl-audit-decide! db (quote u) (quote comment) (quote p))
-              (acl-hd-check!
-                "audit: seq continues after restore"
-                (get (first (acl-audit-tail 1)) :seq)
-                2)
-              (acl-hd-check!
-                "audit: snapshot is an immutable copy"
-                (len (get snap :entries))
-                2)
-              (acl-audit-clear!))))))))
-
-(define
-  acl-harden-tests-run!
-  (fn
-    ()
-    (do
-      (set! acl-hd-pass 0)
-      (set! acl-hd-fail 0)
-      (set! acl-hd-failures (list))
-      (acl-hd-run-all!)
-      {:failures acl-hd-failures :total (+ acl-hd-pass acl-hd-fail) :passed acl-hd-pass :failed acl-hd-fail})))

lib/acl/tests/inherit.sx

@@ -1,202 +0,0 @@
-;; lib/acl/tests/inherit.sx — Phase 2: inheritance (groups, resource trees,
-;; role expansion) with deny-overrides.
-
-(define acl-it-pass 0)
-(define acl-it-fail 0)
-(define acl-it-failures (list))
-
-(define
-  acl-it-check!
-  (fn
-    (name got expected)
-    (if
-      (= got expected)
-      (set! acl-it-pass (+ acl-it-pass 1))
-      (do
-        (set! acl-it-fail (+ acl-it-fail 1))
-        (append!
-          acl-it-failures
-          (str name "\n    expected: " expected "\n    got:      " got))))))
-
-(define acl-it-p? (fn (db s a r) (acl-permit? db s a r)))
-
-(define
-  acl-it-run-all!
-  (fn
-    ()
-    (do
-      (let
-        ((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-grant (quote team) (quote read) (quote doc))))))
-        (do
-          (acl-it-check!
-            "group grant reaches member"
-            (acl-it-p? db (quote alice) (quote read) (quote doc))
-            true)
-          (acl-it-check!
-            "group grant: non-member excluded"
-            (acl-it-p? db (quote bob) (quote read) (quote doc))
-            false)
-          (acl-it-check!
-            "group grant: wrong action"
-            (acl-it-p? db (quote alice) (quote edit) (quote doc))
-            false)))
-      (let
-        ((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-member-of (quote team) (quote org)) (acl-member-of (quote org) (quote company)) (acl-grant (quote company) (quote read) (quote doc))))))
-        (do
-          (acl-it-check!
-            "deep nested group grant reaches leaf member"
-            (acl-it-p? db (quote alice) (quote read) (quote doc))
-            true)
-          (acl-it-check!
-            "intermediate group also covered"
-            (acl-it-p? db (quote team) (quote read) (quote doc))
-            true)
-          (acl-it-check!
-            "mid group org covered"
-            (acl-it-p? db (quote org) (quote read) (quote doc))
-            true)))
-      (let
-        ((db (acl-build-db (list (acl-member-of (quote a) (quote b)) (acl-member-of (quote b) (quote a)) (acl-grant (quote b) (quote read) (quote r))))))
-        (do
-          (acl-it-check!
-            "cyclic membership terminates and grants"
-            (acl-it-p? db (quote a) (quote read) (quote r))
-            true)
-          (acl-it-check!
-            "cyclic membership covers both"
-            (acl-it-p? db (quote b) (quote read) (quote r))
-            true)))
-      (let
-        ((db (acl-build-db (list (acl-child-of (quote sec) (quote chap)) (acl-child-of (quote chap) (quote book)) (acl-grant (quote u) (quote read) (quote book))))))
-        (do
-          (acl-it-check!
-            "parent grant reaches direct child"
-            (acl-it-p? db (quote u) (quote read) (quote chap))
-            true)
-          (acl-it-check!
-            "parent grant reaches deep descendant"
-            (acl-it-p? db (quote u) (quote read) (quote sec))
-            true)
-          (acl-it-check!
-            "parent grant covers parent itself"
-            (acl-it-p? db (quote u) (quote read) (quote book))
-            true)
-          (acl-it-check!
-            "child grant does not climb to parent"
-            (acl-it-p?
-              (acl-build-db
-                (list
-                  (acl-child-of (quote sec) (quote book))
-                  (acl-grant (quote u) (quote read) (quote sec))))
-              (quote u)
-              (quote read)
-              (quote book))
-            false)))
-      (let
-        ((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-child-of (quote post1) (quote board)) (acl-grant (quote team) (quote comment) (quote board))))))
-        (do
-          (acl-it-check!
-            "group + resource: member on child resource"
-            (acl-it-p? db (quote alice) (quote comment) (quote post1))
-            true)
-          (acl-it-check!
-            "group + resource: member on parent resource"
-            (acl-it-p? db (quote alice) (quote comment) (quote board))
-            true)))
-      (let
-        ((db (acl-build-db (list (acl-member-of (quote bob) (quote editor)) (acl-role-grant (quote editor) (quote edit) (quote page1)) (acl-role-grant (quote editor) (quote read) (quote page1))))))
-        (do
-          (acl-it-check!
-            "role confers edit to member"
-            (acl-it-p? db (quote bob) (quote edit) (quote page1))
-            true)
-          (acl-it-check!
-            "role confers read to member"
-            (acl-it-p? db (quote bob) (quote read) (quote page1))
-            true)
-          (acl-it-check!
-            "role: capability not in tuple denied"
-            (acl-it-p? db (quote bob) (quote moderate) (quote page1))
-            false)
-          (acl-it-check!
-            "role: non-member excluded"
-            (acl-it-p? db (quote eve) (quote edit) (quote page1))
-            false)))
-      (let
-        ((db (acl-build-db (list (acl-member-of (quote bob) (quote editor)) (acl-child-of (quote draft) (quote page1)) (acl-role-grant (quote editor) (quote edit) (quote page1))))))
-        (acl-it-check!
-          "role grant flows to child resource"
-          (acl-it-p? db (quote bob) (quote edit) (quote draft))
-          true))
-      (let
-        ((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-grant (quote team) (quote read) (quote doc)) (acl-deny (quote alice) (quote read) (quote doc))))))
-        (acl-it-check!
-          "explicit deny beats inherited group allow"
-          (acl-it-p? db (quote alice) (quote read) (quote doc))
-          false))
-      (let
-        ((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-grant (quote alice) (quote read) (quote doc)) (acl-deny (quote team) (quote read) (quote doc))))))
-        (do
-          (acl-it-check!
-            "group deny inherits and overrides direct grant"
-            (acl-it-p? db (quote alice) (quote read) (quote doc))
-            false)
-          (acl-it-check!
-            "group deny: another member also blocked"
-            (acl-it-p? db (quote team) (quote read) (quote doc))
-            false)))
-      (let
-        ((db (acl-build-db (list (acl-child-of (quote sec) (quote book)) (acl-grant (quote u) (quote read) (quote sec)) (acl-deny (quote u) (quote read) (quote book))))))
-        (acl-it-check!
-          "ancestor deny overrides descendant grant"
-          (acl-it-p? db (quote u) (quote read) (quote sec))
-          false))
-      (let
-        ((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-grant (quote team) (quote read) (quote doc)) (acl-grant (quote team) (quote edit) (quote doc)) (acl-deny (quote alice) (quote edit) (quote doc))))))
-        (do
-          (acl-it-check!
-            "deny on edit leaves inherited read intact"
-            (acl-it-p? db (quote alice) (quote read) (quote doc))
-            true)
-          (acl-it-check!
-            "deny on edit blocks edit"
-            (acl-it-p? db (quote alice) (quote edit) (quote doc))
-            false)))
-      (let
-        ((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-deny (quote team) (quote read) (quote doc))))))
-        (acl-it-check!
-          "inherited deny, no grant: denied"
-          (acl-it-p? db (quote alice) (quote read) (quote doc))
-          false))
-      (let
-        ((db (acl-build-db (list (acl-child-of (quote a) (quote root)) (acl-child-of (quote b) (quote root)) (acl-grant (quote u) (quote read) (quote root)) (acl-deny (quote u) (quote read) (quote a))))))
-        (do
-          (acl-it-check!
-            "deny on sibling a blocks a"
-            (acl-it-p? db (quote u) (quote read) (quote a))
-            false)
-          (acl-it-check!
-            "deny on sibling a leaves b permitted"
-            (acl-it-p? db (quote u) (quote read) (quote b))
-            true)
-          (acl-it-check!
-            "root itself still permitted"
-            (acl-it-p? db (quote u) (quote read) (quote root))
-            true)))
-      (let
-        ((db (acl-build-db (list (acl-grant (quote x) (quote read) (quote y))))))
-        (acl-it-check!
-          "direct grant under inheritance ruleset"
-          (acl-it-p? db (quote x) (quote read) (quote y))
-          true)))))
-
-(define
-  acl-inherit-tests-run!
-  (fn
-    ()
-    (do
-      (set! acl-it-pass 0)
-      (set! acl-it-fail 0)
-      (set! acl-it-failures (list))
-      (acl-it-run-all!)
-      {:failures acl-it-failures :total (+ acl-it-pass acl-it-fail) :passed acl-it-pass :failed acl-it-fail})))

lib/artdag/analyze.sx

@@ -1,88 +0,0 @@
-; 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

@@ -1,91 +0,0 @@
-; 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

@@ -1,131 +0,0 @@
-#!/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)
-
-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)
-  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")
-(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")
-(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

@@ -1,66 +0,0 @@
-; 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

@@ -1,226 +0,0 @@
-; 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

@@ -1,82 +0,0 @@
-; 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

@@ -1,56 +0,0 @@
-; 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

@@ -1,75 +0,0 @@
-; 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/optimize.sx

@@ -1,202 +0,0 @@
-; 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

@@ -1,100 +0,0 @@
-; 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

@@ -1,17 +0,0 @@
-{
-  "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}
-  },
-  "total_pass": 158,
-  "total_fail": 0,
-  "total": 158
-}

lib/artdag/scoreboard.md

@@ -1,17 +0,0 @@
-# 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 |
-| **Total** | **158** | **0** | **158** |

lib/artdag/serialize.sx

@@ -1,62 +0,0 @@
-; 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

@@ -1,51 +0,0 @@
-; 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

@@ -1,119 +0,0 @@
-; 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

@@ -1,117 +0,0 @@
-; 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

@@ -1,182 +0,0 @@
-; 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

@@ -1,188 +0,0 @@
-; 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

@@ -1,144 +0,0 @@
-; 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

@@ -1,157 +0,0 @@
-; 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/optimize.sx

@@ -1,215 +0,0 @@
-; 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

@@ -1,122 +0,0 @@
-; 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

@@ -1,115 +0,0 @@
-; 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

@@ -1,150 +0,0 @@
-; 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

@@ -1,56 +0,0 @@
-;; 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

@@ -1,100 +0,0 @@
-;; 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

@@ -1,86 +0,0 @@
-;; 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

@@ -1,83 +0,0 @@
-;; 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

@@ -1,153 +0,0 @@
-#!/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

@@ -1,86 +0,0 @@
-;; 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

@@ -1,176 +0,0 @@
-;; 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

@@ -1,80 +0,0 @@
-;; 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

@@ -1,119 +0,0 @@
-;; 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

@@ -1,41 +0,0 @@
-;; 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

@@ -1,110 +0,0 @@
-;; 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

@@ -1,153 +0,0 @@
-;; 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

@@ -1,36 +0,0 @@
-;; 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

@@ -1,100 +0,0 @@
-;; 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

@@ -1,97 +0,0 @@
-;; 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

@@ -1,25 +0,0 @@
-{
-  "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

@@ -1,25 +0,0 @@
-# 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

@@ -1,121 +0,0 @@
-;; 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

@@ -1,106 +0,0 @@
-;; 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

@@ -1,73 +0,0 @@
-;; 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

@@ -1,124 +0,0 @@
-;; 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

@@ -1,103 +0,0 @@
-;; 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

@@ -1,93 +0,0 @@
-;; 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

@@ -1,88 +0,0 @@
-;; 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

@@ -1,104 +0,0 @@
-;; 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

@@ -1,80 +0,0 @@
-;; 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

@@ -1,92 +0,0 @@
-;; 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

@@ -1,74 +0,0 @@
-;; 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

@@ -1,43 +0,0 @@
-;; 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

@@ -1,100 +0,0 @@
-;; 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

@@ -1,142 +0,0 @@
-;; 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

@@ -1,108 +0,0 @@
-;; 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

@@ -1,109 +0,0 @@
-;; 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

@@ -1,78 +0,0 @@
-;; 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

@@ -1,127 +0,0 @@
-;; 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

@@ -1,122 +0,0 @@
-;; 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

@@ -1,112 +0,0 @@
-;; 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

@@ -1,55 +0,0 @@
-;; 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/common-lisp/conformance.conf

@@ -1,67 +0,0 @@
-# Common-Lisp-on-SX conformance config — sourced by lib/guest/conformance.sh.
-#
-# CL suites run their tests at *load* time, mutating per-suite global counters
-# (different variable names per suite), and each suite needs a different
-# preload chain. Both are expressed via the extended MODE=counters SUITES
-# format: "name:file:pass-var:fail-var:extra-preload ...".
-
-LANG_NAME=common-lisp
-MODE=counters
-# No global counter defaults — every suite names its own pair below.
-COUNTERS_PASS=
-COUNTERS_FAIL=
-TIMEOUT_PER_SUITE=180
-
-# Base preloads common to every suite (loaded before each suite's own chain).
-PRELOADS=(
-  spec/stdlib.sx
-  lib/guest/prefix.sx
-)
-
-# name:file:pass-var:fail-var:extra-preloads(space-separated)
-SUITES=(
-  "read:lib/common-lisp/tests/read.sx:cl-test-pass:cl-test-fail:lib/common-lisp/reader.sx"
-  "lambda:lib/common-lisp/tests/lambda.sx:cl-test-pass:cl-test-fail:lib/common-lisp/reader.sx lib/common-lisp/parser.sx"
-  "eval:lib/common-lisp/tests/eval.sx:cl-test-pass:cl-test-fail:lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/eval.sx"
-  "conditions:lib/common-lisp/tests/conditions.sx:passed:failed:lib/common-lisp/runtime.sx"
-  "restart-demo:lib/common-lisp/tests/programs/restart-demo.sx:demo-passed:demo-failed:lib/common-lisp/runtime.sx"
-  "parse-recover:lib/common-lisp/tests/programs/parse-recover.sx:parse-passed:parse-failed:lib/common-lisp/runtime.sx"
-  "interactive-debugger:lib/common-lisp/tests/programs/interactive-debugger.sx:debugger-passed:debugger-failed:lib/common-lisp/runtime.sx"
-  "clos:lib/common-lisp/tests/clos.sx:passed:failed:lib/common-lisp/runtime.sx lib/common-lisp/clos.sx"
-  "geometry:lib/common-lisp/tests/programs/geometry.sx:geo-passed:geo-failed:lib/common-lisp/runtime.sx lib/common-lisp/clos.sx"
-  "mop-trace:lib/common-lisp/tests/programs/mop-trace.sx:mop-passed:mop-failed:lib/common-lisp/runtime.sx lib/common-lisp/clos.sx"
-  "macros:lib/common-lisp/tests/macros.sx:macro-passed:macro-failed:lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/eval.sx lib/common-lisp/loop.sx"
-  "stdlib:lib/common-lisp/tests/stdlib.sx:stdlib-passed:stdlib-failed:lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/eval.sx"
-)
-
-# Preserve the historical scoreboard schema (total_pass/total_fail, suites with
-# name/pass/fail) so any consumer of lib/common-lisp/scoreboard.json keeps working.
-emit_scoreboard_json() {
-  local n=${#GC_NAMES[@]} i
-  printf '{\n'
-  printf '  "generated": "%s",\n' "$(date -u +%Y-%m-%dT%H:%M:%SZ)"
-  printf '  "total_pass": %d,\n' "$GC_TOTAL_PASS"
-  printf '  "total_fail": %d,\n' "$GC_TOTAL_FAIL"
-  printf '  "suites": [\n'
-  for ((i=0; i<n; i++)); do
-    [ "$i" -gt 0 ] && printf ',\n'
-    printf '    {"name": "%s", "pass": %d, "fail": %d}' \
-      "${GC_NAMES[$i]}" "${GC_PASS[$i]}" "${GC_FAIL[$i]}"
-  done
-  printf '\n  ]\n'
-  printf '}\n'
-}
-
-emit_scoreboard_md() {
-  local n=${#GC_NAMES[@]} i p f status
-  printf '# Common Lisp on SX — Scoreboard\n\n'
-  printf '_Generated: %s_\n\n' "$(date -u '+%Y-%m-%d %H:%M UTC')"
-  printf '| Suite | Pass | Fail | Status |\n'
-  printf '|-------|------|------|--------|\n'
-  for ((i=0; i<n; i++)); do
-    p="${GC_PASS[$i]}"; f="${GC_FAIL[$i]}"
-    if [ "$f" = "0" ] && [ "${p:-0}" -gt 0 ] 2>/dev/null; then status="pass"; else status="FAIL"; fi
-    printf '| %s | %s | %s | %s |\n' "${GC_NAMES[$i]}" "$p" "$f" "$status"
-  done
-  printf '\n**Total: %d passed, %d failed**\n' "$GC_TOTAL_PASS" "$GC_TOTAL_FAIL"
-}

lib/common-lisp/conformance.sh

@@ -1,3 +1,161 @@
 #!/usr/bin/env bash
-# Thin wrapper — see lib/guest/conformance.sh and lib/common-lisp/conformance.conf.
-exec bash "$(dirname "$0")/../guest/conformance.sh" "$(dirname "$0")/conformance.conf" "$@"
+# lib/common-lisp/conformance.sh — CL-on-SX conformance test runner
+#
+# Runs all Common Lisp test suites and writes scoreboard.json + scoreboard.md.
+#
+# Usage:
+#   bash lib/common-lisp/conformance.sh
+#   bash lib/common-lisp/conformance.sh -v
+
+set -uo pipefail
+cd "$(git rev-parse --show-toplevel)"
+
+SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}"
+if [ ! -x "$SX_SERVER" ]; then
+  SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe"
+fi
+if [ ! -x "$SX_SERVER" ]; then
+  echo "ERROR: sx_server.exe not found."
+  exit 1
+fi
+
+VERBOSE="${1:-}"
+TOTAL_PASS=0; TOTAL_FAIL=0
+SUITE_NAMES=()
+SUITE_PASS=()
+SUITE_FAIL=()
+
+# run_suite NAME "file1 file2 ..." PASS_VAR FAIL_VAR FAILURES_VAR
+run_suite() {
+  local name="$1" load_files="$2" pass_var="$3" fail_var="$4" failures_var="$5"
+  local TMP; TMP=$(mktemp)
+  {
+    printf '(epoch 1)\n(load "spec/stdlib.sx")\n(load "lib/guest/prefix.sx")\n'
+    local i=2
+    for f in $load_files; do
+      printf '(epoch %d)\n(load "%s")\n' "$i" "$f"
+      i=$((i+1))
+    done
+    printf '(epoch 100)\n(eval "%s")\n' "$pass_var"
+    printf '(epoch 101)\n(eval "%s")\n' "$fail_var"
+  } > "$TMP"
+  local OUT; OUT=$(timeout 30 "$SX_SERVER" < "$TMP" 2>/dev/null)
+  rm -f "$TMP"
+  local P F
+  P=$(echo "$OUT" | grep -A1 "^(ok-len 100 " | tail -1 | tr -d ' ()' || true)
+  F=$(echo "$OUT" | grep -A1 "^(ok-len 101 " | tail -1 | tr -d ' ()' || true)
+  # Also try plain (ok 100 N) format
+  [ -z "$P" ] && P=$(echo "$OUT" | grep "^(ok 100 " | awk '{print $3}' | tr -d ')' || true)
+  [ -z "$F" ] && F=$(echo "$OUT" | grep "^(ok 101 " | awk '{print $3}' | tr -d ')' || true)
+  [ -z "$P" ] && P=0; [ -z "$F" ] && F=0
+  SUITE_NAMES+=("$name")
+  SUITE_PASS+=("$P")
+  SUITE_FAIL+=("$F")
+  TOTAL_PASS=$((TOTAL_PASS + P))
+  TOTAL_FAIL=$((TOTAL_FAIL + F))
+  if [ "$F" = "0" ] && [ "${P:-0}" -gt 0 ] 2>/dev/null; then
+    echo "  PASS  $name ($P tests)"
+  else
+    echo "  FAIL  $name ($P passed, $F failed)"
+  fi
+}
+
+echo "=== Common Lisp on SX — Conformance Run ==="
+echo ""
+
+run_suite "Phase 1: tokenizer/reader" \
+  "lib/common-lisp/reader.sx lib/common-lisp/tests/read.sx" \
+  "cl-test-pass" "cl-test-fail" "cl-test-fails"
+
+run_suite "Phase 1: parser/lambda-lists" \
+  "lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/tests/lambda.sx" \
+  "cl-test-pass" "cl-test-fail" "cl-test-fails"
+
+run_suite "Phase 2: evaluator" \
+  "lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/eval.sx lib/common-lisp/tests/eval.sx" \
+  "cl-test-pass" "cl-test-fail" "cl-test-fails"
+
+run_suite "Phase 3: condition system" \
+  "lib/common-lisp/runtime.sx lib/common-lisp/tests/conditions.sx" \
+  "passed" "failed" "failures"
+
+run_suite "Phase 3: restart-demo" \
+  "lib/common-lisp/runtime.sx lib/common-lisp/tests/programs/restart-demo.sx" \
+  "demo-passed" "demo-failed" "demo-failures"
+
+run_suite "Phase 3: parse-recover" \
+  "lib/common-lisp/runtime.sx lib/common-lisp/tests/programs/parse-recover.sx" \
+  "parse-passed" "parse-failed" "parse-failures"
+
+run_suite "Phase 3: interactive-debugger" \
+  "lib/common-lisp/runtime.sx lib/common-lisp/tests/programs/interactive-debugger.sx" \
+  "debugger-passed" "debugger-failed" "debugger-failures"
+
+run_suite "Phase 4: CLOS" \
+  "lib/common-lisp/runtime.sx lib/common-lisp/clos.sx lib/common-lisp/tests/clos.sx" \
+  "passed" "failed" "failures"
+
+run_suite "Phase 4: geometry" \
+  "lib/common-lisp/runtime.sx lib/common-lisp/clos.sx lib/common-lisp/tests/programs/geometry.sx" \
+  "geo-passed" "geo-failed" "geo-failures"
+
+run_suite "Phase 4: mop-trace" \
+  "lib/common-lisp/runtime.sx lib/common-lisp/clos.sx lib/common-lisp/tests/programs/mop-trace.sx" \
+  "mop-passed" "mop-failed" "mop-failures"
+
+run_suite "Phase 5: macros+LOOP" \
+  "lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/eval.sx lib/common-lisp/loop.sx lib/common-lisp/tests/macros.sx" \
+  "macro-passed" "macro-failed" "macro-failures"
+
+run_suite "Phase 6: stdlib" \
+  "lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/eval.sx lib/common-lisp/tests/stdlib.sx" \
+  "stdlib-passed" "stdlib-failed" "stdlib-failures"
+
+echo ""
+echo "=== Total: $TOTAL_PASS passed, $TOTAL_FAIL failed ==="
+
+# ── write scoreboard.json ─────────────────────────────────────────────────
+
+SCORE_DIR="lib/common-lisp"
+JSON="$SCORE_DIR/scoreboard.json"
+{
+  printf '{\n'
+  printf '  "generated": "%s",\n' "$(date -u +%Y-%m-%dT%H:%M:%SZ)"
+  printf '  "total_pass": %d,\n' "$TOTAL_PASS"
+  printf '  "total_fail": %d,\n' "$TOTAL_FAIL"
+  printf '  "suites": [\n'
+  first=true
+  for i in "${!SUITE_NAMES[@]}"; do
+    if [ "$first" = "true" ]; then first=false; else printf ',\n'; fi
+    printf '    {"name": "%s", "pass": %d, "fail": %d}' \
+      "${SUITE_NAMES[$i]}" "${SUITE_PASS[$i]}" "${SUITE_FAIL[$i]}"
+  done
+  printf '\n  ]\n'
+  printf '}\n'
+} > "$JSON"
+
+# ── write scoreboard.md ───────────────────────────────────────────────────
+
+MD="$SCORE_DIR/scoreboard.md"
+{
+  printf '# Common Lisp on SX — Scoreboard\n\n'
+  printf '_Generated: %s_\n\n' "$(date -u '+%Y-%m-%d %H:%M UTC')"
+  printf '| Suite | Pass | Fail | Status |\n'
+  printf '|-------|------|------|--------|\n'
+  for i in "${!SUITE_NAMES[@]}"; do
+    p="${SUITE_PASS[$i]}" f="${SUITE_FAIL[$i]}"
+    status=""
+    if [ "$f" = "0" ] && [ "${p:-0}" -gt 0 ] 2>/dev/null; then
+      status="pass"
+    else
+      status="FAIL"
+    fi
+    printf '| %s | %s | %s | %s |\n' "${SUITE_NAMES[$i]}" "$p" "$f" "$status"
+  done
+  printf '\n**Total: %d passed, %d failed**\n' "$TOTAL_PASS" "$TOTAL_FAIL"
+} > "$MD"
+
+echo ""
+echo "Scoreboard written to $JSON and $MD"
+
+[ "$TOTAL_FAIL" -eq 0 ]

lib/common-lisp/scoreboard.json

@@ -1,19 +1,19 @@
 {
-  "generated": "2026-06-07T09:35:38Z",
-  "total_pass": 487,
+  "generated": "2026-05-06T22:55:42Z",
+  "total_pass": 518,
   "total_fail": 0,
   "suites": [
-    {"name": "read", "pass": 79, "fail": 0},
-    {"name": "lambda", "pass": 31, "fail": 0},
-    {"name": "eval", "pass": 182, "fail": 0},
-    {"name": "conditions", "pass": 59, "fail": 0},
-    {"name": "restart-demo", "pass": 7, "fail": 0},
-    {"name": "parse-recover", "pass": 6, "fail": 0},
-    {"name": "interactive-debugger", "pass": 7, "fail": 0},
-    {"name": "clos", "pass": 35, "fail": 0},
-    {"name": "geometry", "pass": 0, "fail": 0},
-    {"name": "mop-trace", "pass": 0, "fail": 0},
-    {"name": "macros", "pass": 27, "fail": 0},
-    {"name": "stdlib", "pass": 54, "fail": 0}
+    {"name": "Phase 1: tokenizer/reader", "pass": 79, "fail": 0},
+    {"name": "Phase 1: parser/lambda-lists", "pass": 31, "fail": 0},
+    {"name": "Phase 2: evaluator", "pass": 182, "fail": 0},
+    {"name": "Phase 3: condition system", "pass": 59, "fail": 0},
+    {"name": "Phase 3: restart-demo", "pass": 7, "fail": 0},
+    {"name": "Phase 3: parse-recover", "pass": 6, "fail": 0},
+    {"name": "Phase 3: interactive-debugger", "pass": 7, "fail": 0},
+    {"name": "Phase 4: CLOS", "pass": 41, "fail": 0},
+    {"name": "Phase 4: geometry", "pass": 12, "fail": 0},
+    {"name": "Phase 4: mop-trace", "pass": 13, "fail": 0},
+    {"name": "Phase 5: macros+LOOP", "pass": 27, "fail": 0},
+    {"name": "Phase 6: stdlib", "pass": 54, "fail": 0}
   ]
 }

lib/common-lisp/scoreboard.md

@@ -1,20 +1,20 @@
 # Common Lisp on SX — Scoreboard
 
-_Generated: 2026-06-07 09:35 UTC_
+_Generated: 2026-05-06 22:55 UTC_
 
 | Suite | Pass | Fail | Status |
 |-------|------|------|--------|
-| read | 79 | 0 | pass |
-| lambda | 31 | 0 | pass |
-| eval | 182 | 0 | pass |
-| conditions | 59 | 0 | pass |
-| restart-demo | 7 | 0 | pass |
-| parse-recover | 6 | 0 | pass |
-| interactive-debugger | 7 | 0 | pass |
-| clos | 35 | 0 | pass |
-| geometry | 0 | 0 | FAIL |
-| mop-trace | 0 | 0 | FAIL |
-| macros | 27 | 0 | pass |
-| stdlib | 54 | 0 | pass |
+| Phase 1: tokenizer/reader | 79 | 0 | pass |
+| Phase 1: parser/lambda-lists | 31 | 0 | pass |
+| Phase 2: evaluator | 182 | 0 | pass |
+| Phase 3: condition system | 59 | 0 | pass |
+| Phase 3: restart-demo | 7 | 0 | pass |
+| Phase 3: parse-recover | 6 | 0 | pass |
+| Phase 3: interactive-debugger | 7 | 0 | pass |
+| Phase 4: CLOS | 41 | 0 | pass |
+| Phase 4: geometry | 12 | 0 | pass |
+| Phase 4: mop-trace | 13 | 0 | pass |
+| Phase 5: macros+LOOP | 27 | 0 | pass |
+| Phase 6: stdlib | 54 | 0 | pass |
 
-**Total: 487 passed, 0 failed**
+**Total: 518 passed, 0 failed**

lib/content/anchor.sx

@@ -1,51 +0,0 @@
-;; content-on-sx — anchored-heading HTML render.
-;;
-;; Like asHTML, but headings carry an id attribute (the block id), so the TOC's
-;; #id links resolve. A separate render so the plain asHTML stays unchanged.
-;; Tree-aware (sections recurse); other blocks use their normal asHTML.
-;;
-;; Requires (loaded by harness): block.sx, doc.sx, render.sx (asHTML +
-;; htmlEscaped).
-
-(define
-  anch-section?
-  (fn (b) (and (st-instance? b) (= (get b :class) "CtSection"))))
-(define anch-esc (fn (s) (str (st-send s "htmlEscaped" (list)))))
-
-(define
-  anchor-block
-  (fn
-    (b)
-    (cond
-      ((= (blk-type b) "heading")
-        (let
-          ((l (str (blk-get b "level"))) (id (blk-id b)))
-          (str
-            "<h"
-            l
-            " id=\""
-            id
-            "\">"
-            (anch-esc (str (blk-get b "text")))
-            "</h"
-            l
-            ">")))
-      ((anch-section? b)
-        (let
-          ((ch (st-iv-get b "children")))
-          (str
-            "<section>"
-            (anchor-blocks (if (list? ch) ch (list)))
-            "</section>")))
-      (else (str (st-send b "asHTML" (list)))))))
-
-(define
-  anchor-blocks
-  (fn
-    (blocks)
-    (if
-      (= (len blocks) 0)
-      ""
-      (str (anchor-block (first blocks)) (anchor-blocks (rest blocks))))))
-
-(define content/html-anchored (fn (doc) (anchor-blocks (doc-blocks doc))))

lib/content/api.sx

@@ -1,67 +0,0 @@
-;; content-on-sx — public API facade.
-;;
-;; The stable surface other code calls. Composes block + doc + render. Document
-;; values are immutable; every edit returns a new document, so callers hold
-;; explicit versions (the persist op log in Phase 2 becomes the source of truth).
-;;
-;; Requires (loaded by the harness): block.sx, doc.sx, render.sx and a base
-;; Smalltalk class table (st-bootstrap-classes!).
-
-;; Register the content class hierarchy + render methods. Caller bootstraps the
-;; base Smalltalk classes first; this only adds content classes (idempotent).
-(define
-  content/bootstrap!
-  (fn
-    ()
-    (begin
-      (content-bootstrap-blocks!)
-      (content-bootstrap-doc!)
-      (content-bootstrap-render!)
-      true)))
-
-;; ── documents ──
-(define content/new doc-new)
-(define content/empty doc-empty)
-(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?)
-(define content/ids doc-ids)
-(define content/types doc-types)
-
-;; ── blocks ──
-(define content/block mk-block)
-
-;; ── edit ops (data payload) ──
-(define content/insert op-insert)
-(define content/update op-update)
-(define content/move op-move)
-(define content/delete op-delete)
-
-(define content/op? (fn (x) (and (dict? x) (has-key? x :op))))
-
-;; edit — apply one op or a stream of ops; returns a new document.
-(define
-  content/edit
-  (fn
-    (doc ops)
-    (if (content/op? ops) (doc-apply doc ops) (doc-apply-all doc ops))))
-
-;; ── render boundary ──
-;; fmt is "html"/"sx"/"md"/"text" (or the matching keyword). "md" needs
-;; markdown.sx loaded; "text" needs text.sx loaded.
-(define
-  content/render
-  (fn
-    (doc fmt)
-    (cond
-      ((= fmt "html") (asHTML doc))
-      ((= fmt "sx") (asSx doc))
-      ((= fmt "md") (asMarkdown doc))
-      ((= fmt "markdown") (asMarkdown doc))
-      ((= fmt "text") (asText doc))
-      (else (error (str "unknown render format: " fmt))))))
-
-(define content/html asHTML)
-(define content/sx asSx)

lib/content/block.sx

@@ -1,171 +0,0 @@
-;; content-on-sx — typed block objects on Smalltalk-on-SX.
-;;
-;; A block is a Smalltalk instance. Behaviour (type tag, later render) is a
-;; message, not a property switch. Fields are immutable: blk-set / mk-* build a
-;; fresh instance via the functional st-iv-set!, so old versions are never
-;; clobbered (history-safe for the persist op log and CRDT merge).
-;;
-;; Hierarchy:
-;;   CtBlock (id)
-;;     CtText (text)
-;;       CtHeading (level)
-;;       CtCode (language)
-;;       CtQuote (cite)
-;;     CtImage (src alt)
-;;     CtEmbed (url provider)
-;;     CtDivider
-;;     CtList (ordered items)
-;; Plus self-contained blocks registered by their own files: CtSection,
-;; CtTable, CtCallout, CtMedia. ct-class-for-type maps every tag (so mk-block,
-;; content/from-data and CRDT materialise build them uniformly); the classes
-;; themselves are registered by content-bootstrap-section!/table!/callout!/media!.
-
-(define
-  ct-def-method!
-  (fn (cls sel src) (st-class-add-method! cls sel (st-parse-method src))))
-
-;; Register the block hierarchy in the Smalltalk class table. Call AFTER
-;; st-bootstrap-classes! (which resets the table). Idempotent.
-(define
-  content-bootstrap-blocks!
-  (fn
-    ()
-    (begin
-      (st-class-define! "CtBlock" "Object" (list "id"))
-      (ct-def-method! "CtBlock" "id" "id ^ id")
-      (ct-def-method! "CtBlock" "type" "type ^ #block")
-      (ct-def-method! "CtBlock" "isBlock" "isBlock ^ true")
-      (st-class-define! "CtText" "CtBlock" (list "text"))
-      (ct-def-method! "CtText" "text" "text ^ text")
-      (ct-def-method! "CtText" "type" "type ^ #text")
-      (st-class-define! "CtHeading" "CtText" (list "level"))
-      (ct-def-method! "CtHeading" "level" "level ^ level")
-      (ct-def-method! "CtHeading" "type" "type ^ #heading")
-      (st-class-define! "CtCode" "CtText" (list "language"))
-      (ct-def-method! "CtCode" "language" "language ^ language")
-      (ct-def-method! "CtCode" "type" "type ^ #code")
-      (st-class-define! "CtQuote" "CtText" (list "cite"))
-      (ct-def-method! "CtQuote" "cite" "cite ^ cite")
-      (ct-def-method! "CtQuote" "type" "type ^ #quote")
-      (st-class-define! "CtImage" "CtBlock" (list "src" "alt"))
-      (ct-def-method! "CtImage" "src" "src ^ src")
-      (ct-def-method! "CtImage" "alt" "alt ^ alt")
-      (ct-def-method! "CtImage" "type" "type ^ #image")
-      (st-class-define! "CtEmbed" "CtBlock" (list "url" "provider"))
-      (ct-def-method! "CtEmbed" "url" "url ^ url")
-      (ct-def-method! "CtEmbed" "provider" "provider ^ provider")
-      (ct-def-method! "CtEmbed" "type" "type ^ #embed")
-      (st-class-define! "CtDivider" "CtBlock" (list))
-      (ct-def-method! "CtDivider" "type" "type ^ #divider")
-      (st-class-define! "CtList" "CtBlock" (list "ordered" "items"))
-      (ct-def-method! "CtList" "ordered" "ordered ^ ordered")
-      (ct-def-method! "CtList" "items" "items ^ items")
-      (ct-def-method! "CtList" "type" "type ^ #list")
-      true)))
-
-;; Apply (name value) pairs functionally onto a fresh instance.
-(define
-  ct-apply-fields
-  (fn
-    (inst pairs)
-    (if
-      (= (len pairs) 0)
-      inst
-      (ct-apply-fields
-        (st-iv-set!
-          inst
-          (first (first pairs))
-          (first (rest (first pairs))))
-        (rest pairs)))))
-
-(define
-  ct-class-for-type
-  (fn
-    (tag)
-    (cond
-      ((= tag "text") "CtText")
-      ((= tag "heading") "CtHeading")
-      ((= tag "code") "CtCode")
-      ((= tag "quote") "CtQuote")
-      ((= tag "image") "CtImage")
-      ((= tag "embed") "CtEmbed")
-      ((= tag "divider") "CtDivider")
-      ((= tag "list") "CtList")
-      ((= tag "section") "CtSection")
-      ((= tag "table") "CtTable")
-      ((= tag "callout") "CtCallout")
-      ((= tag "media") "CtMedia")
-      (else (error (str "unknown block type: " tag))))))
-
-;; Generic constructor — wire tag + id + (name value) field pairs.
-(define
-  mk-block
-  (fn
-    (type-tag id fields)
-    (ct-apply-fields
-      (st-iv-set! (st-make-instance (ct-class-for-type type-tag)) "id" id)
-      fields)))
-
-(define
-  mk-text
-  (fn (id text) (mk-block "text" id (list (list "text" text)))))
-
-(define
-  mk-heading
-  (fn
-    (id level text)
-    (mk-block "heading" id (list (list "level" level) (list "text" text)))))
-
-(define
-  mk-code
-  (fn
-    (id language text)
-    (mk-block
-      "code"
-      id
-      (list (list "language" language) (list "text" text)))))
-
-(define
-  mk-quote
-  (fn
-    (id cite text)
-    (mk-block "quote" id (list (list "cite" cite) (list "text" text)))))
-
-(define
-  mk-image
-  (fn
-    (id src alt)
-    (mk-block "image" id (list (list "src" src) (list "alt" alt)))))
-
-(define
-  mk-embed
-  (fn
-    (id url provider)
-    (mk-block "embed" id (list (list "url" url) (list "provider" provider)))))
-
-(define mk-divider (fn (id) (mk-block "divider" id (list))))
-
-(define
-  mk-list
-  (fn
-    (id ordered items)
-    (mk-block
-      "list"
-      id
-      (list (list "ordered" ordered) (list "items" items)))))
-
-;; Accessors. blk-type / blk-id go through message dispatch (polymorphic);
-;; blk-get reads any ivar directly; blk-set is copy-on-write.
-(define blk-id (fn (b) (st-send b "id" (list))))
-(define blk-type (fn (b) (str (st-send b "type" (list)))))
-(define blk-send (fn (b sel) (st-send b sel (list))))
-(define blk-get (fn (b field) (st-iv-get b field)))
-(define blk-set (fn (b field val) (st-iv-set! b field val)))
-
-(define
-  block?
-  (fn
-    (v)
-    (and
-      (st-instance? v)
-      (st-class-inherits-from? (get v :class) "CtBlock"))))

lib/content/callout.sx

@@ -1,49 +0,0 @@
-;; content-on-sx — callout / admonition block.
-;;
-;; CtCallout holds a `kind` (note/warning/tip/…) and `text`. Self-contained: it
-;; answers asHTML/asSx/asText/asMarkdown: so it composes with the render boundary
-;; with no changes elsewhere. HTML text is htmlEscaped, SX text sxEscaped.
-;;
-;; Requires (loaded by harness): block.sx, doc.sx, render.sx (escapers);
-;; markdown.sx / text.sx for those formats.
-
-(define
-  content-bootstrap-callout!
-  (fn
-    ()
-    (begin
-      (st-class-define! "CtCallout" "CtBlock" (list "kind" "text"))
-      (ct-def-method! "CtCallout" "kind" "kind ^ kind")
-      (ct-def-method! "CtCallout" "text" "text ^ text")
-      (ct-def-method! "CtCallout" "type" "type ^ #callout")
-      (ct-def-method!
-        "CtCallout"
-        "asHTML"
-        "asHTML ^ '<aside class=\"callout callout-' , kind htmlEscaped , '\">' , text htmlEscaped , '</aside>'")
-      (ct-def-method!
-        "CtCallout"
-        "asSx"
-        "asSx ^ '(aside :class \"callout callout-' , kind sxEscaped , '\" \"' , text sxEscaped , '\")'")
-      (ct-def-method! "CtCallout" "asText" "asText ^ text")
-      (ct-def-method!
-        "CtCallout"
-        "asMarkdown:"
-        "asMarkdown: nl ^ '> **' , kind , ':** ' , text")
-      true)))
-
-(define
-  mk-callout
-  (fn
-    (id kind text)
-    (st-iv-set!
-      (st-iv-set!
-        (st-iv-set! (st-make-instance "CtCallout") "id" id)
-        "kind"
-        kind)
-      "text"
-      text)))
-
-(define
-  callout?
-  (fn (b) (and (st-instance? b) (= (get b :class) "CtCallout"))))
-(define callout-kind (fn (b) (st-send b "kind" (list))))

lib/content/clone.sx

@@ -1,34 +0,0 @@
-;; content-on-sx — block id remapping / clone.
-;;
-;; Deep-rewrite every block id in the tree (descending into sections) by applying
-;; a function. Enables collision-free composition: prefix one document's ids
-;; before concatenating it with another. Immutable; content is unchanged, only
-;; ids.
-;;
-;; Requires (loaded by harness): doc.sx, section.sx (section? /
-;; section-children / section-with-children).
-
-(define
-  block-remap-id
-  (fn
-    (b f)
-    (let
-      ((nb (blk-set b "id" (f (blk-id b)))))
-      (if
-        (section? nb)
-        (section-with-children
-          nb
-          (map (fn (c) (block-remap-id c f)) (section-children nb)))
-        nb))))
-
-(define
-  content/remap-ids
-  (fn
-    (doc f)
-    (doc-with-blocks
-      doc
-      (map (fn (b) (block-remap-id b f)) (doc-blocks doc)))))
-
-(define
-  content/prefix-ids
-  (fn (doc prefix) (content/remap-ids doc (fn (id) (str prefix id)))))

lib/content/compose.sx

@@ -1,42 +0,0 @@
-;; content-on-sx — document composition.
-;;
-;; Combine documents (header + body + footer, templates, partials) into a new
-;; document. The result keeps the FIRST document's id and metadata; blocks are
-;; concatenated. Immutable — inputs are untouched. Block-id collisions across
-;; combined docs are the caller's concern (content/validate flags duplicates).
-;;
-;; Requires (loaded by harness): doc.sx.
-
-(define
-  content/concat
-  (fn (a b) (doc-with-blocks a (append (doc-blocks a) (doc-blocks b)))))
-
-(define
-  content/prepend
-  (fn (a b) (doc-with-blocks a (append (doc-blocks b) (doc-blocks a)))))
-
-(define
-  content/-concat-fold
-  (fn
-    (acc more)
-    (if
-      (= (len more) 0)
-      acc
-      (content/-concat-fold (content/concat acc (first more)) (rest more)))))
-
-(define
-  content/concat-all
-  (fn
-    (docs)
-    (if
-      (= (len docs) 0)
-      (doc-empty "merged")
-      (content/-concat-fold (first docs) (rest docs)))))
-
-;; wrap a document's blocks inside a single section (collapse to a subtree).
-;; Requires section.sx (mk-section) when used.
-(define
-  content/wrap-section
-  (fn
-    (doc section-id)
-    (doc-with-blocks doc (list (mk-section section-id (doc-blocks doc))))))

lib/content/conformance.sh

@@ -1,158 +0,0 @@
-#!/usr/bin/env bash
-# lib/content/conformance.sh — run content-on-sx suites, emit scoreboard.
-
-set -uo pipefail
-cd "$(git rev-parse --show-toplevel)"
-
-SX_SERVER="hosts/ocaml/_build/default/bin/sx_server.exe"
-if [ ! -x "$SX_SERVER" ]; then
-  MAIN_ROOT=$(git worktree list | head -1 | awk '{print $1}')
-  if [ -x "$MAIN_ROOT/$SX_SERVER" ]; then
-    SX_SERVER="$MAIN_ROOT/$SX_SERVER"
-  else
-    echo "ERROR: sx_server.exe not found." >&2
-    exit 1
-  fi
-fi
-
-SUITES=(block doc render api meta page page-full markdown text section compose tree-edit move clone query toc anchor outline flatten transform normalize find-replace stats summary index table callout media data wire validate store snapshot crdt crdt-tree crdt-blocks crdt-store sync md-import md-doc fed)
-
-OUT_JSON="lib/content/scoreboard.json"
-OUT_MD="lib/content/scoreboard.md"
-
-run_suite() {
-  local suite=$1
-  local file="lib/content/tests/${suite}.sx"
-  local TMP
-  TMP=$(mktemp)
-  cat > "$TMP" << EPOCHS
-(epoch 1)
-(load "lib/smalltalk/tokenizer.sx")
-(load "lib/smalltalk/parser.sx")
-(load "lib/guest/reflective/class-chain.sx")
-(load "lib/smalltalk/runtime.sx")
-(load "lib/guest/reflective/env.sx")
-(load "lib/smalltalk/eval.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")
-(load "lib/content/block.sx")
-(load "lib/content/doc.sx")
-(load "lib/content/render.sx")
-(load "lib/content/api.sx")
-(load "lib/content/meta.sx")
-(load "lib/content/text.sx")
-(load "lib/content/section.sx")
-(load "lib/content/compose.sx")
-(load "lib/content/tree-edit.sx")
-(load "lib/content/move.sx")
-(load "lib/content/clone.sx")
-(load "lib/content/query.sx")
-(load "lib/content/toc.sx")
-(load "lib/content/anchor.sx")
-(load "lib/content/outline.sx")
-(load "lib/content/flatten.sx")
-(load "lib/content/transform.sx")
-(load "lib/content/normalize.sx")
-(load "lib/content/find-replace.sx")
-(load "lib/content/stats.sx")
-(load "lib/content/summary.sx")
-(load "lib/content/index.sx")
-(load "lib/content/table.sx")
-(load "lib/content/callout.sx")
-(load "lib/content/media.sx")
-(load "lib/content/data.sx")
-(load "lib/content/wire.sx")
-(load "lib/content/page.sx")
-(load "lib/content/page-full.sx")
-(load "lib/content/markdown.sx")
-(load "lib/content/validate.sx")
-(load "lib/content/store.sx")
-(load "lib/content/snapshot.sx")
-(load "lib/content/crdt.sx")
-(load "lib/content/crdt-tree.sx")
-(load "lib/content/crdt-store.sx")
-(load "lib/content/sync.sx")
-(load "lib/content/md-import.sx")
-(load "lib/content/md-doc.sx")
-(load "lib/content/fed.sx")
-(epoch 2)
-(eval "(define content-test-pass 0)")
-(eval "(define content-test-fail 0)")
-(eval "(define content-test-fails (list))")
-(eval "(define content-test (fn (name got expected) (if (= got expected) (set! content-test-pass (+ content-test-pass 1)) (begin (set! content-test-fail (+ content-test-fail 1)) (set! content-test-fails (cons name content-test-fails))))))")
-(epoch 3)
-(load "${file}")
-(epoch 4)
-(eval "(list content-test-pass content-test-fail)")
-EPOCHS
-
-  local OUTPUT
-  OUTPUT=$(timeout 240 "$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 content 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 '# content-on-sx Conformance Scoreboard\n\n'
-  printf '_Generated by `lib/content/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/content/crdt-store.sx

@@ -1,71 +0,0 @@
-;; content-on-sx — durable collaborative replication: CRDT ops on persist.
-;;
-;; Each replica appends its CRDT ops to its own persist stream
-;; (crdt:<doc>:<replica>). Any node reconstructs the converged document by
-;; replaying every replica's log into a CvRDT state and merging them. Because
-;; the merge is a join and crdt-apply is order/duplicate-insensitive, the
-;; converged result is identical regardless of replica order or re-delivery —
-;; the durable log + CRDT give offline-capable, eventually-consistent editing.
-;;
-;; Requires (loaded by harness): crdt.sx (+ deps) and persist
-;; (event/backend/log/kv/api). Backend `b` injected via (persist/open).
-
-(define crdt/-stream (fn (doc-id replica) (str "crdt:" doc-id ":" replica)))
-
-;; ── commit ops to a replica's durable log ──
-(define
-  crdt/commit!
-  (fn
-    (b doc-id replica op at)
-    (persist/append b (crdt/-stream doc-id replica) (get op :op) at op)))
-
-(define
-  crdt/commit-all!
-  (fn
-    (b doc-id replica ops at)
-    (if
-      (= (len ops) 0)
-      nil
-      (begin
-        (crdt/commit! b doc-id replica (first ops) at)
-        (crdt/commit-all! b doc-id replica (rest ops) at)))))
-
-;; ── read a replica's log ──
-(define
-  crdt/log
-  (fn (b doc-id replica) (persist/read b (crdt/-stream doc-id replica))))
-
-(define
-  crdt/replica-ops
-  (fn
-    (b doc-id replica)
-    (map (fn (ev) (persist/event-data ev)) (crdt/log b doc-id replica))))
-
-(define
-  crdt/replica-version
-  (fn (b doc-id replica) (persist/last-seq b (crdt/-stream doc-id replica))))
-
-;; ── replay one replica's log into a CvRDT state ──
-(define
-  crdt/replay
-  (fn
-    (b doc-id replica)
-    (crdt-apply-all (crdt-empty) (crdt/replica-ops b doc-id replica))))
-
-;; ── converge: merge every replica's replayed state ──
-(define
-  crdt/converge
-  (fn
-    (b doc-id replicas)
-    (crdt-merge-all (map (fn (r) (crdt/replay b doc-id r)) replicas))))
-
-;; ── converged, materialised document ──
-(define
-  crdt/document
-  (fn
-    (b doc-id replicas)
-    (crdt-materialize doc-id (crdt/converge b doc-id replicas))))
-
-(define
-  crdt/order
-  (fn (b doc-id replicas) (crdt-order (crdt/converge b doc-id replicas))))

lib/content/crdt-tree.sx

@@ -1,193 +0,0 @@
-;; content-on-sx — nested-tree CvRDT.
-;;
-;; Extends the flat CvRDT (crdt.sx) to a TREE: each element carries a `parent`
-;; (the id of its containing section, "" = root) alongside its Logoot position.
-;; Merge is still a join — it reuses crdt.sx's position/register/field merges and
-;; adds parent (immutable, set once at insert). Materialisation rebuilds the
-;; ordered tree: root = elements with parent "" (plus ORPHANS — elements whose
-;; parent is not a live section, e.g. after a concurrent delete-section +
-;; insert-child, so content is never silently lost); a section's children =
-;; elements whose parent is that section's id. Commutative/associative/idempotent
-;; like the flat layer.
-;;
-;; Requires (loaded by harness): crdt.sx (merge helpers + live/sort/materialise
-;; bits + crdt-member?), block.sx, doc.sx, section.sx (mk-section).
-
-(define ctt-merge-parent (fn (p1 p2) (if (= p1 nil) p2 p1)))
-
-(define ctt-merge-element (fn (e1 e2) {:fields (crdt-merge-fields (get e1 :fields) (get e2 :fields)) :parent (ctt-merge-parent (get e1 :parent) (get e2 :parent)) :id (get e1 :id) :type (crdt-merge-type (get e1 :type) (get e2 :type)) :deleted (or (= (get e1 :deleted) true) (= (get e2 :deleted) true)) :pos (crdt-merge-pos (get e1 :pos) (get e2 :pos))}))
-
-(define
-  ctt-add-element
-  (fn
-    (state elem)
-    (let
-      ((elems (get state :elements)) (id (get elem :id)))
-      (let
-        ((existing (get elems id)))
-        (assoc
-          state
-          :elements (assoc
-            elems
-            id
-            (if (= existing nil) elem (ctt-merge-element existing elem))))))))
-
-;; ── ops as partial-element contributions ──
-(define
-  crdt-tree-insert
-  (fn
-    (state id type pos parent fields ts actor)
-    (ctt-add-element state {:fields (crdt-build-fields fields ts actor) :parent parent :id id :type type :deleted false :pos pos})))
-
-(define
-  crdt-tree-update
-  (fn (state id fname value ts actor) (ctt-add-element state {:fields (assoc {} fname {:ts ts :actor actor :value value}) :parent nil :id id :type nil :deleted false :pos nil})))
-
-(define crdt-tree-delete (fn (state id) (ctt-add-element state {:fields {} :parent nil :id id :type nil :deleted true :pos nil})))
-
-;; ── state merge (join) ──
-(define
-  ctt-merge-loop
-  (fn
-    (ids ea eb acc)
-    (if
-      (= (len ids) 0)
-      acc
-      (let
-        ((id (first ids)))
-        (let
-          ((x (get ea id)) (y (get eb id)))
-          (ctt-merge-loop
-            (rest ids)
-            ea
-            eb
-            (assoc
-              acc
-              id
-              (cond
-                ((= x nil) y)
-                ((= y nil) x)
-                (else (ctt-merge-element x y))))))))))
-
-(define crdt-tree-merge (fn (a b) {:elements (ctt-merge-loop (crdt-union-keys (get a :elements) (get b :elements)) (get a :elements) (get b :elements) {})}))
-
-(define
-  crdt-tree-merge-all
-  (fn
-    (states)
-    (if
-      (= (len states) 0)
-      (crdt-empty)
-      (if
-        (= (len states) 1)
-        (first states)
-        (crdt-tree-merge (first states) (crdt-tree-merge-all (rest states)))))))
-
-;; ── op interpreter ──
-(define
-  crdt-tree-op-insert
-  (fn (id type pos parent fields ts actor) {:ts ts :fields fields :parent parent :id id :type type :op "insert" :actor actor :pos pos}))
-
-(define crdt-tree-op-update (fn (id field value ts actor) {:ts ts :field field :id id :op "update" :actor actor :value value}))
-
-(define crdt-tree-op-delete (fn (id) {:id id :op "delete"}))
-
-(define
-  crdt-tree-apply
-  (fn
-    (state op)
-    (let
-      ((k (get op :op)))
-      (cond
-        ((= k "insert")
-          (crdt-tree-insert
-            state
-            (get op :id)
-            (get op :type)
-            (get op :pos)
-            (get op :parent)
-            (get op :fields)
-            (get op :ts)
-            (get op :actor)))
-        ((= k "update")
-          (crdt-tree-update
-            state
-            (get op :id)
-            (get op :field)
-            (get op :value)
-            (get op :ts)
-            (get op :actor)))
-        ((= k "delete") (crdt-tree-delete state (get op :id)))
-        (else (error (str "unknown crdt-tree op: " k)))))))
-
-(define
-  crdt-tree-apply-all
-  (fn
-    (state ops)
-    (if
-      (= (len ops) 0)
-      state
-      (crdt-tree-apply-all (crdt-tree-apply state (first ops)) (rest ops)))))
-
-;; ── materialise to a Phase-1 document (rebuild the ordered tree) ──
-(define
-  ctt-live-section-ids
-  (fn
-    (state)
-    (map
-      (fn (e) (get e :id))
-      (filter
-        (fn (e) (= (get e :type) "section"))
-        (crdt-live-elements state)))))
-
-;; an element belongs at root if its parent is "" or its parent is not a live
-;; section (orphan-reparenting: don't lose content when its section is deleted).
-(define
-  ctt-roots
-  (fn
-    (state)
-    (let
-      ((secids (ctt-live-section-ids state)))
-      (crdt-sort-by-pos
-        (filter
-          (fn
-            (e)
-            (if
-              (= (get e :parent) "")
-              true
-              (if (crdt-member? (get e :parent) secids) false true)))
-          (crdt-live-elements state))))))
-
-(define
-  ctt-children
-  (fn
-    (state parent-id)
-    (crdt-sort-by-pos
-      (filter
-        (fn (e) (= (get e :parent) parent-id))
-        (crdt-live-elements state)))))
-
-(define
-  ctt-element->block
-  (fn
-    (state e)
-    (if
-      (= (get e :type) "section")
-      (mk-section
-        (get e :id)
-        (map
-          (fn (c) (ctt-element->block state c))
-          (ctt-children state (get e :id))))
-      (crdt-element->block e))))
-
-(define
-  crdt-tree-materialize
-  (fn
-    (doc-id state)
-    (doc-new
-      doc-id
-      (map (fn (e) (ctt-element->block state e)) (ctt-roots state)))))
-
-(define
-  crdt-tree-order
-  (fn (state) (map (fn (e) (get e :id)) (ctt-roots state))))

lib/content/crdt.sx

@@ -1,378 +0,0 @@
-;; content-on-sx — collaborative merge (state-based CvRDT).
-;;
-;; The merge is a join (least upper bound) on a semilattice, so it is
-;; commutative, associative and idempotent BY CONSTRUCTION — applying ops in any
-;; order, or merging replicas in any order / twice, converges to the same
-;; document. This is NOT last-write-wins-as-cop-out: ordering uses unique dense
-;; position keys (Logoot), presence uses OR-tombstones (remove-wins), and each
-;; field is an LWW-Register keyed by a logical (ts, actor) clock — an explicit,
-;; deterministic per-field conflict policy.
-;;
-;; Every op (insert/update/delete) contributes a PARTIAL element; the per-id
-;; state is the join of all contributions. So update-before-insert and
-;; delete-before-insert are not lost — they merge when the rest arrives.
-;;
-;; Shapes:
-;;   state    = {:elements <dict id -> element>}
-;;   element  = {:id :pos :type :deleted :fields <dict fname -> register>}
-;;   register = {:value v :ts <int> :actor <int>}
-;;   position = list of cells; cell = (list digit actor); lexicographic order
-;;
-;; Requires (loaded by harness): block.sx, doc.sx.
-
-(define CRDT-BASE 65536)
-
-;; ── position order (Logoot) ──
-(define
-  crdt-cell-cmp
-  (fn
-    (c1 c2)
-    (let
-      ((d1 (first c1)) (d2 (first c2)))
-      (cond
-        ((< d1 d2) -1)
-        ((> d1 d2) 1)
-        (else
-          (let
-            ((a1 (first (rest c1))) (a2 (first (rest c2))))
-            (cond
-              ((< a1 a2) -1)
-              ((> a1 a2) 1)
-              (else 0))))))))
-
-(define
-  crdt-pos-compare
-  (fn
-    (p1 p2)
-    (cond
-      ((and (= (len p1) 0) (= (len p2) 0)) 0)
-      ((= (len p1) 0) -1)
-      ((= (len p2) 0) 1)
-      (else
-        (let
-          ((c (crdt-cell-cmp (first p1) (first p2))))
-          (if (= c 0) (crdt-pos-compare (rest p1) (rest p2)) c))))))
-
-;; single-cell position constructor (handy for explicit tests)
-(define crdt-pos (fn (digit actor) (list (list digit actor))))
-
-;; allocate a position strictly between left and right (nil = unbounded)
-(define
-  cr-alloc
-  (fn
-    (left right actor i acc)
-    (let
-      ((ld (if (< i (len left)) (first (nth left i)) 0))
-        (rd (if (< i (len right)) (first (nth right i)) CRDT-BASE)))
-      (if
-        (> (- rd ld) 1)
-        (append
-          acc
-          (list
-            (list
-              (+
-                ld
-                (+
-                  1
-                  (floor (/ (- (- rd ld) 1) 2))))
-              actor)))
-        (cr-alloc
-          left
-          right
-          actor
-          (+ i 1)
-          (append
-            acc
-            (list
-              (list
-                ld
-                (if (< i (len left)) (first (rest (nth left i))) actor)))))))))
-
-(define
-  crdt-pos-between
-  (fn
-    (left right actor)
-    (cr-alloc
-      (if (= left nil) (list) left)
-      (if (= right nil) (list) right)
-      actor
-      0
-      (list))))
-
-;; ── register (LWW by logical (ts, actor)) ──
-(define
-  crdt-reg-max
-  (fn
-    (r1 r2)
-    (cond
-      ((= r1 nil) r2)
-      ((= r2 nil) r1)
-      (else
-        (let
-          ((t1 (get r1 :ts)) (t2 (get r2 :ts)))
-          (cond
-            ((> t1 t2) r1)
-            ((< t1 t2) r2)
-            (else (if (>= (get r1 :actor) (get r2 :actor)) r1 r2))))))))
-
-;; ── small set/dict helpers ──
-(define
-  crdt-member?
-  (fn
-    (x xs)
-    (cond
-      ((= (len xs) 0) false)
-      ((= (first xs) x) true)
-      (else (crdt-member? x (rest xs))))))
-
-(define
-  crdt-dedup-loop
-  (fn
-    (xs seen)
-    (if
-      (= (len xs) 0)
-      (reverse seen)
-      (if
-        (crdt-member? (first xs) seen)
-        (crdt-dedup-loop (rest xs) seen)
-        (crdt-dedup-loop (rest xs) (cons (first xs) seen))))))
-
-(define crdt-dedup (fn (xs) (crdt-dedup-loop xs (list))))
-
-(define
-  crdt-union-keys
-  (fn (d1 d2) (crdt-dedup (append (keys d1) (keys d2)))))
-
-;; ── element join ──
-(define
-  crdt-merge-pos
-  (fn
-    (p1 p2)
-    (cond
-      ((= p1 nil) p2)
-      ((= p2 nil) p1)
-      ((<= (crdt-pos-compare p1 p2) 0) p1)
-      (else p2))))
-
-(define crdt-merge-type (fn (t1 t2) (if (= t1 nil) t2 t1)))
-
-(define
-  crdt-merge-fields-loop
-  (fn
-    (names f1 f2 acc)
-    (if
-      (= (len names) 0)
-      acc
-      (let
-        ((nm (first names)))
-        (crdt-merge-fields-loop
-          (rest names)
-          f1
-          f2
-          (assoc acc nm (crdt-reg-max (get f1 nm) (get f2 nm))))))))
-
-(define
-  crdt-merge-fields
-  (fn
-    (f1 f2)
-    (crdt-merge-fields-loop (crdt-union-keys f1 f2) f1 f2 {})))
-
-(define crdt-merge-element (fn (e1 e2) {:fields (crdt-merge-fields (get e1 :fields) (get e2 :fields)) :id (get e1 :id) :type (crdt-merge-type (get e1 :type) (get e2 :type)) :deleted (or (= (get e1 :deleted) true) (= (get e2 :deleted) true)) :pos (crdt-merge-pos (get e1 :pos) (get e2 :pos))}))
-
-;; ── state ──
-(define crdt-empty (fn () {:elements {}}))
-
-(define
-  crdt-add-element
-  (fn
-    (state elem)
-    (let
-      ((elems (get state :elements)) (id (get elem :id)))
-      (let
-        ((existing (get elems id)))
-        (assoc
-          state
-          :elements (assoc
-            elems
-            id
-            (if (= existing nil) elem (crdt-merge-element existing elem))))))))
-
-(define
-  crdt-build-fields-loop
-  (fn
-    (pairs ts actor acc)
-    (if
-      (= (len pairs) 0)
-      acc
-      (crdt-build-fields-loop
-        (rest pairs)
-        ts
-        actor
-        (assoc acc (first (first pairs)) {:ts ts :actor actor :value (first (rest (first pairs)))})))))
-
-(define
-  crdt-build-fields
-  (fn (pairs ts actor) (crdt-build-fields-loop pairs ts actor {})))
-
-;; ── ops as partial-element contributions ──
-(define
-  crdt-insert
-  (fn
-    (state id type pos fields ts actor)
-    (crdt-add-element state {:fields (crdt-build-fields fields ts actor) :id id :type type :deleted false :pos pos})))
-
-(define
-  crdt-update
-  (fn (state id fname value ts actor) (crdt-add-element state {:fields (assoc {} fname {:ts ts :actor actor :value value}) :id id :type nil :deleted false :pos nil})))
-
-(define crdt-delete (fn (state id) (crdt-add-element state {:fields {} :id id :type nil :deleted true :pos nil})))
-
-;; ── state merge (join) ──
-(define
-  crdt-merge-loop
-  (fn
-    (ids ea eb acc)
-    (if
-      (= (len ids) 0)
-      acc
-      (let
-        ((id (first ids)))
-        (let
-          ((x (get ea id)) (y (get eb id)))
-          (crdt-merge-loop
-            (rest ids)
-            ea
-            eb
-            (assoc
-              acc
-              id
-              (cond
-                ((= x nil) y)
-                ((= y nil) x)
-                (else (crdt-merge-element x y))))))))))
-
-(define crdt-merge (fn (a b) {:elements (crdt-merge-loop (crdt-union-keys (get a :elements) (get b :elements)) (get a :elements) (get b :elements) {})}))
-
-(define
-  crdt-merge-all
-  (fn
-    (states)
-    (if
-      (= (len states) 0)
-      (crdt-empty)
-      (if
-        (= (len states) 1)
-        (first states)
-        (crdt-merge (first states) (crdt-merge-all (rest states)))))))
-
-;; ── op interpreter ──
-(define crdt-op-insert (fn (id type pos fields ts actor) {:ts ts :fields fields :id id :type type :op "insert" :actor actor :pos pos}))
-
-(define crdt-op-update (fn (id field value ts actor) {:ts ts :field field :id id :op "update" :actor actor :value value}))
-
-(define crdt-op-delete (fn (id) {:id id :op "delete"}))
-
-(define
-  crdt-apply
-  (fn
-    (state op)
-    (let
-      ((k (get op :op)))
-      (cond
-        ((= k "insert")
-          (crdt-insert
-            state
-            (get op :id)
-            (get op :type)
-            (get op :pos)
-            (get op :fields)
-            (get op :ts)
-            (get op :actor)))
-        ((= k "update")
-          (crdt-update
-            state
-            (get op :id)
-            (get op :field)
-            (get op :value)
-            (get op :ts)
-            (get op :actor)))
-        ((= k "delete") (crdt-delete state (get op :id)))
-        (else (error (str "unknown crdt op: " k)))))))
-
-(define
-  crdt-apply-all
-  (fn
-    (state ops)
-    (if
-      (= (len ops) 0)
-      state
-      (crdt-apply-all (crdt-apply state (first ops)) (rest ops)))))
-
-;; ── materialise to a Phase-1 document ──
-(define
-  crdt-elements-list
-  (fn
-    (state)
-    (map
-      (fn (id) (get (get state :elements) id))
-      (keys (get state :elements)))))
-
-(define
-  crdt-live?
-  (fn
-    (e)
-    (and
-      (= (get e :deleted) false)
-      (if (= (get e :pos) nil) false true)
-      (if (= (get e :type) nil) false true))))
-
-(define
-  crdt-live-elements
-  (fn (state) (filter crdt-live? (crdt-elements-list state))))
-
-(define
-  crdt-insert-sorted
-  (fn
-    (e sorted)
-    (cond
-      ((= (len sorted) 0) (list e))
-      ((< (crdt-pos-compare (get e :pos) (get (first sorted) :pos)) 0)
-        (cons e sorted))
-      (else (cons (first sorted) (crdt-insert-sorted e (rest sorted)))))))
-
-(define
-  crdt-sort-by-pos
-  (fn
-    (elems)
-    (if
-      (= (len elems) 0)
-      (list)
-      (crdt-insert-sorted (first elems) (crdt-sort-by-pos (rest elems))))))
-
-(define
-  crdt-field-pairs
-  (fn
-    (fields)
-    (map (fn (nm) (list nm (get (get fields nm) :value))) (keys fields))))
-
-(define
-  crdt-element->block
-  (fn
-    (e)
-    (mk-block (get e :type) (get e :id) (crdt-field-pairs (get e :fields)))))
-
-(define
-  crdt-order
-  (fn
-    (state)
-    (map
-      (fn (e) (get e :id))
-      (crdt-sort-by-pos (crdt-live-elements state)))))
-
-(define
-  crdt-materialize
-  (fn
-    (doc-id state)
-    (doc-new
-      doc-id
-      (map crdt-element->block (crdt-sort-by-pos (crdt-live-elements state))))))

lib/content/data.sx

@@ -1,79 +0,0 @@
-;; content-on-sx — portable data serialization.
-;;
-;; Converts documents to/from a plain SX data form, decoupling storage and
-;; transport from the Smalltalk instance shape. A document becomes
-;;   {:id :title :slug :tags :blocks (list block-data)}
-;; and a block becomes {:id :type :fields {...}} (section children recurse).
-;; content/from-data reconstructs real block objects.
-;;
-;; Requires (loaded by harness): block.sx, doc.sx, meta.sx, section.sx
-;; (mk-section), table.sx (mk-table).
-
-;; ── to-data ──
-(define
-  content/-fd-loop
-  (fn
-    (ks ivs acc)
-    (if
-      (= (len ks) 0)
-      acc
-      (let
-        ((k (first ks)))
-        (if
-          (= k "id")
-          (content/-fd-loop (rest ks) ivs acc)
-          (content/-fd-loop
-            (rest ks)
-            ivs
-            (assoc
-              acc
-              k
-              (if
-                (= k "children")
-                (map block->data (get ivs k))
-                (get ivs k)))))))))
-
-(define block->data (fn (b) {:fields (content/-fd-loop (keys (get b :ivars)) (get b :ivars) {}) :id (blk-id b) :type (blk-type b)}))
-
-(define content/to-data (fn (doc) {:blocks (map block->data (doc-blocks doc)) :slug (doc-slug doc) :id (doc-id doc) :title (doc-title doc) :tags (doc-tags doc)}))
-
-;; ── from-data ──
-(define
-  content/-field-pairs
-  (fn (fields) (map (fn (k) (list k (get fields k))) (keys fields))))
-
-(define
-  data->block
-  (fn
-    (d)
-    (let
-      ((type (get d :type)) (id (get d :id)) (fields (get d :fields)))
-      (cond
-        ((= type "section")
-          (mk-section id (map data->block (get fields "children"))))
-        ((= type "table")
-          (mk-table id (get fields "headers") (get fields "rows")))
-        (else (mk-block type id (content/-field-pairs fields)))))))
-
-(define
-  content/-meta-of
-  (fn
-    (data)
-    (let
-      ((m1 (if (= (get data :title) nil) {} (assoc {} :title (get data :title)))))
-      (let
-        ((m2 (if (= (get data :slug) nil) m1 (assoc m1 :slug (get data :slug)))))
-        (let
-          ((tags (get data :tags)))
-          (if
-            (or (= tags nil) (= (len tags) 0))
-            m2
-            (assoc m2 :tags tags)))))))
-
-(define
-  content/from-data
-  (fn
-    (data)
-    (doc-with-meta
-      (doc-new (get data :id) (map data->block (get data :blocks)))
-      (content/-meta-of data))))

lib/content/doc.sx

@@ -1,203 +0,0 @@
-;; content-on-sx — ordered block document on Smalltalk-on-SX.
-;;
-;; A document (CtDoc) is a Smalltalk object holding an ordered sequence of block
-;; objects. Editing is a stream of ops (data dicts); doc-apply interprets one op
-;; 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.
-;;
-;; 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>}
-
-(define
-  content-bootstrap-doc!
-  (fn
-    ()
-    (begin
-      (st-class-define!
-        "CtDoc"
-        "Object"
-        (list "id" "blocks" "title" "slug" "tags"))
-      (ct-def-method! "CtDoc" "id" "id ^ id")
-      (ct-def-method! "CtDoc" "blocks" "blocks ^ blocks")
-      (ct-def-method! "CtDoc" "type" "type ^ #document")
-      (ct-def-method! "CtDoc" "title" "title ^ title")
-      (ct-def-method! "CtDoc" "slug" "slug ^ slug")
-      (ct-def-method! "CtDoc" "tags" "tags ^ tags")
-      true)))
-
-;; ── construction ──
-(define
-  doc-new
-  (fn
-    (id blocks)
-    (st-iv-set!
-      (st-iv-set! (st-make-instance "CtDoc") "id" id)
-      "blocks"
-      blocks)))
-
-(define doc-empty (fn (id) (doc-new id (list))))
-
-;; ── accessors (message dispatch) ──
-(define doc-id (fn (doc) (st-send doc "id" (list))))
-(define doc-type (fn (doc) (str (st-send doc "type" (list)))))
-(define doc-blocks (fn (doc) (st-send doc "blocks" (list))))
-(define doc-count (fn (doc) (len (doc-blocks doc))))
-(define doc-block-at (fn (doc i) (nth (doc-blocks doc) i)))
-
-(define doc? (fn (v) (and (st-instance? v) (= (get v :class) "CtDoc"))))
-
-;; ── list helpers over block sequences ──
-(define
-  ct-index-loop
-  (fn
-    (blocks id i)
-    (cond
-      ((= (len blocks) 0) -1)
-      ((= (blk-id (first blocks)) id) i)
-      (else (ct-index-loop (rest blocks) id (+ i 1))))))
-
-(define ct-index-of (fn (blocks id) (ct-index-loop blocks id 0)))
-
-(define
-  ct-insert-at
-  (fn
-    (blocks i x)
-    (cond
-      ((= i 0) (cons x blocks))
-      ((= (len blocks) 0) (list x))
-      (else
-        (cons
-          (first blocks)
-          (ct-insert-at (rest blocks) (- i 1) x))))))
-
-(define
-  ct-remove-id
-  (fn
-    (blocks id)
-    (filter (fn (b) (if (= (blk-id b) id) false true)) blocks)))
-
-(define
-  ct-replace-id
-  (fn
-    (blocks id f)
-    (map (fn (b) (if (= (blk-id b) id) (f b) b)) blocks)))
-
-;; ── query ──
-(define doc-index-of (fn (doc id) (ct-index-of (doc-blocks doc) id)))
-
-(define
-  doc-find
-  (fn
-    (doc id)
-    (let
-      ((hits (filter (fn (b) (= (blk-id b) id)) (doc-blocks doc))))
-      (if (= (len hits) 0) nil (first hits)))))
-
-(define
-  doc-has?
-  (fn (doc id) (if (= (doc-index-of doc id) -1) false true)))
-
-;; ── structural edits (each returns a new document) ──
-(define doc-with-blocks (fn (doc blocks) (st-iv-set! doc "blocks" blocks)))
-
-(define
-  doc-append
-  (fn
-    (doc block)
-    (doc-with-blocks doc (append (doc-blocks doc) (list block)))))
-
-(define
-  doc-insert-at
-  (fn
-    (doc block i)
-    (doc-with-blocks doc (ct-insert-at (doc-blocks doc) i block))))
-
-(define
-  doc-insert-after
-  (fn
-    (doc block after-id)
-    (let
-      ((blocks (doc-blocks doc)))
-      (if
-        (= after-id nil)
-        (doc-with-blocks doc (cons block blocks))
-        (let
-          ((idx (ct-index-of blocks after-id)))
-          (if
-            (= idx -1)
-            (doc-with-blocks doc (append blocks (list block)))
-            (doc-with-blocks
-              doc
-              (ct-insert-at blocks (+ idx 1) block))))))))
-
-(define
-  doc-update
-  (fn
-    (doc id field value)
-    (doc-with-blocks
-      doc
-      (ct-replace-id (doc-blocks doc) id (fn (b) (blk-set b field value))))))
-
-(define
-  doc-delete
-  (fn (doc id) (doc-with-blocks doc (ct-remove-id (doc-blocks doc) id))))
-
-(define
-  doc-move
-  (fn
-    (doc id i)
-    (let
-      ((blk (doc-find doc id)))
-      (if
-        (= blk nil)
-        doc
-        (doc-with-blocks
-          doc
-          (ct-insert-at (ct-remove-id (doc-blocks doc) id) i blk))))))
-
-;; ── op constructors (data payload, reused by persist op log) ──
-(define op-insert (fn (block after) {:after after :op "insert" :block block}))
-
-(define op-update (fn (id field value) {:field field :id id :op "update" :value value}))
-
-(define op-move (fn (id index) {:id id :op "move" :index index}))
-
-(define op-delete (fn (id) {:id id :op "delete"}))
-
-;; ── op interpreter ──
-(define
-  doc-apply
-  (fn
-    (doc op)
-    (let
-      ((kind (get op :op)))
-      (cond
-        ((= kind "insert")
-          (doc-insert-after doc (get op :block) (get op :after)))
-        ((= kind "update")
-          (doc-update doc (get op :id) (get op :field) (get op :value)))
-        ((= kind "move") (doc-move doc (get op :id) (get op :index)))
-        ((= kind "delete") (doc-delete doc (get op :id)))
-        (else (error (str "unknown op: " kind)))))))
-
-(define
-  doc-apply-all
-  (fn
-    (doc ops)
-    (if
-      (= (len ops) 0)
-      doc
-      (doc-apply-all (doc-apply doc (first ops)) (rest ops)))))
-
-;; ── render-agnostic snapshot: list of (id . type) for assertions/debug ──
-(define doc-ids (fn (doc) (map (fn (b) (blk-id b)) (doc-blocks doc))))
-
-(define
-  doc-types
-  (fn (doc) (map (fn (b) (blk-type b)) (doc-blocks doc))))

lib/content/fed.sx

@@ -1,68 +0,0 @@
-;; content-on-sx — federated documents: trust-gated peer-authored ops.
-;;
-;; A peer-authored op carries provenance (:author, and a :sig stub). We never
-;; auto-accept: a peer op is applied only if it passes a trust gate. The gate is
-;; a predicate (fn op -> bool) so acl-on-sx can inject real trust facts later;
-;; the convenience form takes an explicit trusted-actor list (the stub).
-;;
-;; Accepted ops flow through the CvRDT merge (Phase 3), so concurrent local and
-;; external edits reconcile deterministically (same-field LWW, order-independent).
-;;
-;; Requires (loaded by harness): crdt.sx (and its deps).
-
-;; tag an op with provenance
-(define content/authored (fn (op author) (assoc op :author author)))
-
-(define
-  content/signed
-  (fn (op author sig) (assoc (assoc op :author author) :sig sig)))
-
-;; explicit trust stub: membership in a trusted-actor list
-(define content/trusted? (fn (trust author) (crdt-member? author trust)))
-
-;; general form: accept? is a predicate (fn op -> bool). Applies accepted ops
-;; through the CRDT; quarantines the rest. Returns
-;; {:state :accepted (ops) :rejected (ops)}.
-(define
-  content/-merge-peer-loop
-  (fn
-    (state accept? ops accepted rejected)
-    (if
-      (= (len ops) 0)
-      {:state state :accepted (reverse accepted) :rejected (reverse rejected)}
-      (let
-        ((op (first ops)))
-        (if
-          (accept? op)
-          (content/-merge-peer-loop
-            (crdt-apply state op)
-            accept?
-            (rest ops)
-            (cons op accepted)
-            rejected)
-          (content/-merge-peer-loop
-            state
-            accept?
-            (rest ops)
-            accepted
-            (cons op rejected)))))))
-
-(define
-  content/merge-peer-with
-  (fn
-    (state accept? ops)
-    (content/-merge-peer-loop state accept? ops (list) (list))))
-
-;; convenience: trust = list of trusted actor ids
-(define
-  content/merge-peer
-  (fn
-    (state trust ops)
-    (content/merge-peer-with
-      state
-      (fn (op) (content/trusted? trust (get op :author)))
-      ops)))
-
-(define content/accepted (fn (res) (get res :accepted)))
-(define content/rejected (fn (res) (get res :rejected)))
-(define content/peer-state (fn (res) (get res :state)))