From c67aefa211ea778f4a0c4f68a0cd5cb1a2105fa7 Mon Sep 17 00:00:00 2001 From: giles Date: Sun, 7 Jun 2026 11:42:32 +0000 Subject: [PATCH] relations: Phase 1 schema + direct relations (rel facts, relate/unrelate, children/parents/related) + 22 tests Co-Authored-By: Claude Opus 4.8 (1M context) --- lib/relations/api.sx | 96 ++++++++++++++++ lib/relations/conformance.conf | 23 ++++ lib/relations/conformance.sh | 3 + lib/relations/schema.sx | 40 +++++++ lib/relations/scoreboard.json | 10 ++ lib/relations/scoreboard.md | 7 ++ lib/relations/tests/direct.sx | 197 +++++++++++++++++++++++++++++++++ plans/relations-on-sx.md | 23 +++- 8 files changed, 393 insertions(+), 6 deletions(-) create mode 100644 lib/relations/api.sx create mode 100644 lib/relations/conformance.conf create mode 100755 lib/relations/conformance.sh create mode 100644 lib/relations/schema.sx create mode 100644 lib/relations/scoreboard.json create mode 100644 lib/relations/scoreboard.md create mode 100644 lib/relations/tests/direct.sx diff --git a/lib/relations/api.sx b/lib/relations/api.sx new file mode 100644 index 00000000..ac9ae314 --- /dev/null +++ b/lib/relations/api.sx @@ -0,0 +1,96 @@ +;; lib/relations/api.sx — relationship lifecycle + direct queries over lib/datalog/. +;; +;; A relations db is a live Datalog db holding rel(Src,Dst,Kind) facts. Phase 1 +;; uses no rules — direct children/parents are plain queries on the rel +;; relation. Phase 2's engine.sx adds recursive reachability rules; build-db +;; will fold them in then. +;; +;; Two surfaces: db-threading core fns (relations-children-of db ...) and a +;; current-db convenience layer (relations/relate ...) for callers that load a +;; fact base once and query without passing the db around. This mirrors lib/acl. + +(define relations-rules (list)) + +(define + relations-build-db + (fn (facts) (dl-program-data facts relations-rules))) + +;; Pull one column (by keyword key) out of a list of substitution dicts. +(define + relations-pluck + (fn (substs key) (map (fn (s) (get s key)) substs))) + +;; Direct children: every Dst with rel(node, Dst, kind). +(define + relations-children-of + (fn + (db node kind) + (relations-pluck + (dl-query db (list (quote rel) node (quote Dst) kind)) + :Dst))) + +;; Direct parents: every Src with rel(Src, node, kind). +(define + relations-parents-of + (fn + (db node kind) + (relations-pluck + (dl-query db (list (quote rel) (quote Src) node kind)) + :Src))) + +;; Directly related: neighbours in either direction under kind. +(define + relations-related + (fn + (db node kind) + (append + (relations-children-of db node kind) + (relations-parents-of db node kind)))) + +;; --- current-db convenience layer --- + +(define relations-current-db nil) + +(define + relations/load! + (fn + (facts) + (do + (set! relations-current-db (relations-build-db facts)) + relations-current-db))) + +(define + relations-ensure-db! + (fn + () + (do + (when + (= relations-current-db nil) + (set! relations-current-db (relations-build-db (list)))) + relations-current-db))) + +;; Add a relationship to the current db (re-saturates). +(define + relations/relate + (fn + (src dst kind) + (dl-assert! (relations-ensure-db!) (relations-rel src dst kind)))) + +;; Remove a relationship from the current db (re-saturates). +(define + relations/unrelate + (fn + (src dst kind) + (dl-retract! (relations-ensure-db!) (relations-rel src dst kind)))) + +(define + relations/children + (fn (node kind) (relations-children-of (relations-ensure-db!) node kind))) + +(define + relations/parents + (fn (node kind) (relations-parents-of (relations-ensure-db!) node kind))) + +(define + relations/related + (fn (node kind) (relations-related (relations-ensure-db!) node kind))) diff --git a/lib/relations/conformance.conf b/lib/relations/conformance.conf new file mode 100644 index 00000000..3acbb50d --- /dev/null +++ b/lib/relations/conformance.conf @@ -0,0 +1,23 @@ +# relations conformance config — sourced by lib/guest/conformance.sh. + +LANG_NAME=relations +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/relations/schema.sx + lib/relations/api.sx +) + +SUITES=( + "direct:lib/relations/tests/direct.sx:(relations-direct-tests-run!)" +) diff --git a/lib/relations/conformance.sh b/lib/relations/conformance.sh new file mode 100755 index 00000000..ab291ba3 --- /dev/null +++ b/lib/relations/conformance.sh @@ -0,0 +1,3 @@ +#!/usr/bin/env bash +# Thin wrapper — see lib/guest/conformance.sh and lib/relations/conformance.conf. +exec bash "$(dirname "$0")/../guest/conformance.sh" "$(dirname "$0")/conformance.conf" "$@" diff --git a/lib/relations/schema.sx b/lib/relations/schema.sx new file mode 100644 index 00000000..8656387e --- /dev/null +++ b/lib/relations/schema.sx @@ -0,0 +1,40 @@ +;; lib/relations/schema.sx — relationship fact vocabulary over lib/datalog/. +;; +;; relations is content-agnostic: a node is an opaque id (a symbol or string); +;; domains own what ids mean. A relationship is a single Datalog fact +;; +;; rel(Src, Dst, Kind) +;; +;; meaning "Src is related to Dst under Kind" (read directionally: Src is the +;; parent/owner/origin, Dst the child/member/reply). Kind is an open vocabulary; +;; the names below are the platform's well-known kinds but relate accepts any +;; kind symbol — Datalog is untyped and domains may coin their own. + +(define relations-kinds (quote (parent member reply variant origin link))) + +(define relations-rel (fn (src dst kind) (list (quote rel) src dst kind))) + +(define relations-rel-src (fn (f) (nth f 1))) + +(define relations-rel-dst (fn (f) (nth f 2))) + +(define relations-rel-kind (fn (f) (nth f 3))) + +(define + relations-member? + (fn + (x xs) + (cond + ((= (len xs) 0) false) + ((= (first xs) x) true) + (else (relations-member? x (rest xs)))))) + +(define + relations-known-kind? + (fn (k) (relations-member? k relations-kinds))) + +(define + relations-fact-valid? + (fn + (f) + (and (list? f) (= (len f) 4) (= (first f) (quote rel))))) diff --git a/lib/relations/scoreboard.json b/lib/relations/scoreboard.json new file mode 100644 index 00000000..725f41bd --- /dev/null +++ b/lib/relations/scoreboard.json @@ -0,0 +1,10 @@ +{ + "lang": "relations", + "total_passed": 22, + "total_failed": 0, + "total": 22, + "suites": [ + {"name":"direct","passed":22,"failed":0,"total":22} + ], + "generated": "2026-06-07T11:41:50+00:00" +} diff --git a/lib/relations/scoreboard.md b/lib/relations/scoreboard.md new file mode 100644 index 00000000..f46f795f --- /dev/null +++ b/lib/relations/scoreboard.md @@ -0,0 +1,7 @@ +# relations scoreboard + +**22 / 22 passing** (0 failure(s)). + +| Suite | Passed | Total | Status | +|-------|--------|-------|--------| +| direct | 22 | 22 | ok | diff --git a/lib/relations/tests/direct.sx b/lib/relations/tests/direct.sx new file mode 100644 index 00000000..af01641b --- /dev/null +++ b/lib/relations/tests/direct.sx @@ -0,0 +1,197 @@ +;; lib/relations/tests/direct.sx — Phase 1: schema + direct relations. + +(define relations-dt-pass 0) +(define relations-dt-fail 0) +(define relations-dt-failures (list)) + +(define + relations-dt-check! + (fn + (name got expected) + (if + (= got expected) + (set! relations-dt-pass (+ relations-dt-pass 1)) + (do + (set! relations-dt-fail (+ relations-dt-fail 1)) + (append! + relations-dt-failures + (str name "\n expected: " expected "\n got: " got)))))) + +;; Order-insensitive membership: every x in xs is in ys. +(define + relations-dt-subset? + (fn + (xs ys) + (cond + ((= (len xs) 0) true) + ((relations-member? (first xs) ys) + (relations-dt-subset? (rest xs) ys)) + (else false)))) + +(define + relations-dt-set=? + (fn + (xs ys) + (and + (= (len xs) (len ys)) + (relations-dt-subset? xs ys) + (relations-dt-subset? ys xs)))) + +;; Fixture: a small forest with two kinds. +;; parent: a -> b, a -> c, b -> d +;; reply: p -> q +(define + relations-dt-fixture + (fn + () + (relations-build-db + (list + (relations-rel (quote a) (quote b) (quote parent)) + (relations-rel (quote a) (quote c) (quote parent)) + (relations-rel (quote b) (quote d) (quote parent)) + (relations-rel (quote p) (quote q) (quote reply)))))) + +(define + relations-dt-run-all! + (fn + () + (let + ((db (relations-dt-fixture))) + (do + (relations-dt-check! + "direct children of a" + (relations-dt-set=? + (relations-children-of db (quote a) (quote parent)) + (list (quote b) (quote c))) + true) + (relations-dt-check! + "direct children of b" + (relations-dt-set=? + (relations-children-of db (quote b) (quote parent)) + (list (quote d))) + true) + (relations-dt-check! + "leaf has no children" + (relations-children-of db (quote d) (quote parent)) + (list)) + (relations-dt-check! + "direct parents of b" + (relations-dt-set=? + (relations-parents-of db (quote b) (quote parent)) + (list (quote a))) + true) + (relations-dt-check! + "root has no parents" + (relations-parents-of db (quote a) (quote parent)) + (list)) + (relations-dt-check! + "related is both directions" + (relations-dt-set=? + (relations-related db (quote b) (quote parent)) + (list (quote d) (quote a))) + true) + (relations-dt-check! + "kind isolation: parent query skips reply edge" + (relations-children-of db (quote p) (quote parent)) + (list)) + (relations-dt-check! + "reply children of p" + (relations-dt-set=? + (relations-children-of db (quote p) (quote reply)) + (list (quote q))) + true) + (relations-dt-check! + "unknown node -> empty" + (relations-children-of db (quote zzz) (quote parent)) + (list)) + (let + ((db2 (relations-build-db (list (relations-rel (quote x) (quote y) (quote parent)))))) + (do + (relations-dt-check! + "before retract: y is a child of x" + (relations-dt-set=? + (relations-children-of db2 (quote x) (quote parent)) + (list (quote y))) + true) + (dl-retract! + db2 + (relations-rel (quote x) (quote y) (quote parent))) + (relations-dt-check! + "after retract: x has no children" + (relations-children-of db2 (quote x) (quote parent)) + (list)))) + (do + (relations/load! (list)) + (relations/relate (quote o1) (quote li1) (quote member)) + (relations/relate (quote o1) (quote li2) (quote member)) + (relations-dt-check! + "api relate then children" + (relations-dt-set=? + (relations/children (quote o1) (quote member)) + (list (quote li1) (quote li2))) + true) + (relations-dt-check! + "api parents" + (relations-dt-set=? + (relations/parents (quote li1) (quote member)) + (list (quote o1))) + true) + (relations/unrelate (quote o1) (quote li1) (quote member)) + (relations-dt-check! + "api unrelate removes one child" + (relations-dt-set=? + (relations/children (quote o1) (quote member)) + (list (quote li2))) + true) + (relations/load! (list)) + (relations-dt-check! + "api reload clears prior facts" + (relations/children (quote o1) (quote member)) + (list))) + (relations-dt-check! + "rel constructor shape" + (relations-rel (quote s) (quote d) (quote parent)) + (list (quote rel) (quote s) (quote d) (quote parent))) + (relations-dt-check! + "fact valid" + (relations-fact-valid? + (relations-rel (quote s) (quote d) (quote parent))) + true) + (relations-dt-check! + "fact bad arity invalid" + (relations-fact-valid? (list (quote rel) (quote s))) + false) + (relations-dt-check! + "fact wrong head invalid" + (relations-fact-valid? + (list (quote edge) (quote s) (quote d) (quote parent))) + false) + (relations-dt-check! + "known kind" + (relations-known-kind? (quote parent)) + true) + (relations-dt-check! + "unknown kind" + (relations-known-kind? (quote frobnicate)) + false) + (relations-dt-check! + "accessors" + (list + (relations-rel-src + (relations-rel (quote s) (quote d) (quote k))) + (relations-rel-dst + (relations-rel (quote s) (quote d) (quote k))) + (relations-rel-kind + (relations-rel (quote s) (quote d) (quote k)))) + (list (quote s) (quote d) (quote k))))))) + +(define + relations-direct-tests-run! + (fn + () + (do + (set! relations-dt-pass 0) + (set! relations-dt-fail 0) + (set! relations-dt-failures (list)) + (relations-dt-run-all!) + {:failures relations-dt-failures :total (+ relations-dt-pass relations-dt-fail) :passed relations-dt-pass :failed relations-dt-fail}))) diff --git a/plans/relations-on-sx.md b/plans/relations-on-sx.md index fcc35a67..2436d83f 100644 --- a/plans/relations-on-sx.md +++ b/plans/relations-on-sx.md @@ -18,7 +18,7 @@ links. Reuses `lib/datalog/` — does not reimplement the engine. ## Status (rolling) -`bash lib/relations/conformance.sh` → **0/0** (not yet started) +`bash lib/relations/conformance.sh` → **22/22** (Phase 1 complete) ## Ground rules @@ -61,14 +61,14 @@ lib/relations/federation.sx ## Phase 1 — Schema + direct relations -- [ ] `lib/relations/schema.sx` — `rel(Src, Dst, Kind)` fact projection; a small +- [x] `lib/relations/schema.sx` — `rel(Src, Dst, Kind)` fact projection; a small kind vocabulary (`parent`, `member`, `reply`, `variant`, `origin`, …) kept open -- [ ] `lib/relations/api.sx` — `(relations/relate src dst kind)` / `(unrelate …)` +- [x] `lib/relations/api.sx` — `(relations/relate src dst kind)` / `(unrelate …)` over a live Datalog db (assert/retract); `(children-of db node kind)`, `(parents-of db node kind)`, `(related db node kind)` -- [ ] `lib/relations/tests/direct.sx` — assert/retract, direct children/parents, +- [x] `lib/relations/tests/direct.sx` — assert/retract, direct children/parents, kind filtering, unknown node → empty -- [ ] `lib/relations/conformance.sh` + scoreboard +- [x] `lib/relations/conformance.sh` + scoreboard ## Phase 2 — Reachability + cycles @@ -100,7 +100,18 @@ lib/relations/federation.sx ## Progress log -(loop fills this in) +- **Phase 1 — schema + direct relations** (22/22). `schema.sx`: `rel(Src,Dst,Kind)` + fact constructor + accessors, open kind vocabulary (`parent member reply variant + origin link`), `relations-fact-valid?`/`relations-known-kind?`. `api.sx`: db built + via `dl-program-data facts relations-rules` (Phase 1 rules empty — direct queries + need none); `relations-children-of`/`-parents-of`/`-related` are plain `dl-query` + on the `rel` relation, plucking the bound column from substitution dicts; + current-db convenience layer (`relations/load!`, `relations/relate`, + `relations/unrelate`, `relations/children`/`parents`/`related`) over `dl-assert!`/ + `dl-retract!`, mirroring lib/acl/api.sx. Tests cover direct children/parents, leaf/ + root empties, kind isolation (parent query skips reply edge), retract, the api + layer, and schema/constructor shape. Note: query result order is nondeterministic + — tests use an order-insensitive `set=?`. ## Blockers