relations: Phase 2 reachability + roots/leaves + cycles (engine.sx, kind-parameterized closure) + 24 tests

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

lib/relations/tests/reach.sx

@@ -0,0 +1,204 @@
+;; lib/relations/tests/reach.sx — Phase 2: reachability, roots/leaves, cycles.
+
+(define relations-rt-pass 0)
+(define relations-rt-fail 0)
+(define relations-rt-failures (list))
+
+(define
+  relations-rt-check!
+  (fn
+    (name got expected)
+    (if
+      (= got expected)
+      (set! relations-rt-pass (+ relations-rt-pass 1))
+      (do
+        (set! relations-rt-fail (+ relations-rt-fail 1))
+        (append!
+          relations-rt-failures
+          (str name "\n    expected: " expected "\n    got:      " got))))))
+
+(define
+  relations-rt-subset?
+  (fn
+    (xs ys)
+    (cond
+      ((= (len xs) 0) true)
+      ((relations-member? (first xs) ys)
+        (relations-rt-subset? (rest xs) ys))
+      (else false))))
+
+(define
+  relations-rt-set=?
+  (fn
+    (xs ys)
+    (and
+      (= (len xs) (len ys))
+      (relations-rt-subset? xs ys)
+      (relations-rt-subset? ys xs))))
+
+;; Diamond + a disconnected pair under parent, plus a reply cross-edge.
+;;   parent: a->b, a->c, b->d, c->d ; e->f
+;;   reply:  b->z
+(define
+  relations-rt-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 c) (quote d) (quote parent))
+        (relations-rel (quote e) (quote f) (quote parent))
+        (relations-rel (quote b) (quote z) (quote reply))))))
+
+;; Cycles: c1<->c2, self-loop s->s, plus acyclic t->u, all under parent.
+(define
+  relations-rt-cyc-fixture
+  (fn
+    ()
+    (relations-build-db
+      (list
+        (relations-rel (quote c1) (quote c2) (quote parent))
+        (relations-rel (quote c2) (quote c1) (quote parent))
+        (relations-rel (quote s) (quote s) (quote parent))
+        (relations-rel (quote t) (quote u) (quote parent))))))
+
+(define
+  relations-rt-run-all!
+  (fn
+    ()
+    (let
+      ((db (relations-rt-fixture)) (cyc (relations-rt-cyc-fixture)))
+      (do
+        (relations-rt-check!
+          "descendants of a (diamond)"
+          (relations-rt-set=?
+            (relations-descendants db (quote a) (quote parent))
+            (list (quote b) (quote c) (quote d)))
+          true)
+        (relations-rt-check!
+          "ancestors of d (diamond)"
+          (relations-rt-set=?
+            (relations-ancestors db (quote d) (quote parent))
+            (list (quote a) (quote b) (quote c)))
+          true)
+        (relations-rt-check!
+          "reachable a->d"
+          (relations-reachable? db (quote a) (quote d) (quote parent))
+          true)
+        (relations-rt-check!
+          "not reachable d->a"
+          (relations-reachable? db (quote d) (quote a) (quote parent))
+          false)
+        (relations-rt-check!
+          "disconnected components"
+          (relations-reachable? db (quote a) (quote f) (quote parent))
+          false)
+        (relations-rt-check!
+          "leaf has no descendants"
+          (relations-descendants db (quote d) (quote parent))
+          (list))
+        (relations-rt-check!
+          "root has no ancestors"
+          (relations-ancestors db (quote a) (quote parent))
+          (list))
+        (relations-rt-check!
+          "roots under parent"
+          (relations-rt-set=?
+            (relations-roots db (quote parent))
+            (list (quote a) (quote e)))
+          true)
+        (relations-rt-check!
+          "leaves under parent"
+          (relations-rt-set=?
+            (relations-leaves db (quote parent))
+            (list (quote d) (quote f)))
+          true)
+        (relations-rt-check!
+          "parent descendants exclude reply target"
+          (relations-member?
+            (quote z)
+            (relations-descendants db (quote a) (quote parent)))
+          false)
+        (relations-rt-check!
+          "reply reachable b->z"
+          (relations-reachable? db (quote b) (quote z) (quote reply))
+          true)
+        (relations-rt-check!
+          "parent unreachable a->z"
+          (relations-reachable? db (quote a) (quote z) (quote parent))
+          false)
+        (relations-rt-check!
+          "diamond is acyclic"
+          (relations-acyclic? db (quote parent))
+          true)
+        (relations-rt-check!
+          "no node cycles in diamond"
+          (relations-cycle? db (quote a) (quote parent))
+          false)
+        (relations-rt-check!
+          "c1 is on a cycle"
+          (relations-cycle? cyc (quote c1) (quote parent))
+          true)
+        (relations-rt-check!
+          "self-loop counts as cycle"
+          (relations-cycle? cyc (quote s) (quote parent))
+          true)
+        (relations-rt-check!
+          "acyclic node t not on cycle"
+          (relations-cycle? cyc (quote t) (quote parent))
+          false)
+        (relations-rt-check!
+          "kind with a cycle is not acyclic"
+          (relations-acyclic? cyc (quote parent))
+          false)
+        (relations-rt-check!
+          "cycle reachable both ways"
+          (and
+            (relations-reachable? cyc (quote c1) (quote c2) (quote parent))
+            (relations-reachable? cyc (quote c2) (quote c1) (quote parent)))
+          true)
+        (relations-rt-check!
+          "node in cycle reaches itself"
+          (relations-member?
+            (quote c1)
+            (relations-descendants cyc (quote c1) (quote parent)))
+          true)
+        (do
+          (relations/load!
+            (list
+              (relations-rel (quote r) (quote m) (quote parent))
+              (relations-rel (quote m) (quote n) (quote parent))))
+          (relations-rt-check!
+            "api descendants"
+            (relations-rt-set=?
+              (relations/descendants (quote r) (quote parent))
+              (list (quote m) (quote n)))
+            true)
+          (relations-rt-check!
+            "api reachable"
+            (relations/reachable? (quote r) (quote n) (quote parent))
+            true)
+          (relations-rt-check!
+            "api roots"
+            (relations-rt-set=?
+              (relations/roots (quote parent))
+              (list (quote r)))
+            true)
+          (relations-rt-check!
+            "api acyclic"
+            (relations/acyclic? (quote parent))
+            true)
+          (relations/load! (list)))))))
+
+(define
+  relations-reach-tests-run!
+  (fn
+    ()
+    (do
+      (set! relations-rt-pass 0)
+      (set! relations-rt-fail 0)
+      (set! relations-rt-failures (list))
+      (relations-rt-run-all!)
+      {:failures relations-rt-failures :total (+ relations-rt-pass relations-rt-fail) :passed relations-rt-pass :failed relations-rt-fail})))