coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

relations: Phase 3 path explanation + distance + mixed-kind reachability (explain.sx, reach_any) + 24 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 53s
Details

Browse Source 
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-06-07 12:06:04 +00:00
parent 7a1696490c
commit ffe3ec25ac
7 changed files with 331 additions and 10 deletions
Download Patch File Download Diff File Expand all files Collapse all files

192
lib/relations/tests/path.sx Normal file
View File

@@ -0,0 +1,192 @@
;; lib/relations/tests/path.sx — Phase 3: typed relations, path, distance.
(define relations-pt-pass 0)
(define relations-pt-fail 0)
(define relations-pt-failures (list))
(define
relations-pt-check!
(fn
(name got expected)
(if
(= got expected)
(set! relations-pt-pass (+ relations-pt-pass 1))
(do
(set! relations-pt-fail (+ relations-pt-fail 1))
(append!
relations-pt-failures
(str name "\n expected: " expected "\n got: " got))))))
(define
relations-pt-subset?
(fn
(xs ys)
(cond
((= (len xs) 0) true)
((relations-member? (first xs) ys)
(relations-pt-subset? (rest xs) ys))
(else false))))
(define
relations-pt-set=?
(fn
(xs ys)
(and
(= (len xs) (len ys))
(relations-pt-subset? xs ys)
(relations-pt-subset? ys xs))))
;; Two kinds coexisting in one db.
;; parent: a->b, b->c, c->d, a->c (shortcut), x->y (disconnected)
;; member: c->m, m->n (crosses into a different kind)
(define
relations-pt-fixture
(fn
()
(relations-build-db
(list
(relations-rel (quote a) (quote b) (quote parent))
(relations-rel (quote b) (quote c) (quote parent))
(relations-rel (quote c) (quote d) (quote parent))
(relations-rel (quote a) (quote c) (quote parent))
(relations-rel (quote x) (quote y) (quote parent))
(relations-rel (quote c) (quote m) (quote member))
(relations-rel (quote m) (quote n) (quote member))))))
;; A cycle with an exit: u->v->w->u, w->exit.
(define
relations-pt-cyc-fixture
(fn
()
(relations-build-db
(list
(relations-rel (quote u) (quote v) (quote parent))
(relations-rel (quote v) (quote w) (quote parent))
(relations-rel (quote w) (quote u) (quote parent))
(relations-rel (quote w) (quote exit) (quote parent))))))
(define
relations-pt-run-all!
(fn
()
(let
((db (relations-pt-fixture)) (cyc (relations-pt-cyc-fixture)))
(do
(relations-pt-check!
"shortest path a->d"
(relations-path db (quote a) (quote d) (quote parent))
(list (quote a) (quote c) (quote d)))
(relations-pt-check!
"distance a->d is 2"
(relations-distance db (quote a) (quote d) (quote parent))
2)
(relations-pt-check!
"direct edge path a->c"
(relations-path db (quote a) (quote c) (quote parent))
(list (quote a) (quote c)))
(relations-pt-check!
"distance a->c is 1"
(relations-distance db (quote a) (quote c) (quote parent))
1)
(relations-pt-check!
"path b->d"
(relations-path db (quote b) (quote d) (quote parent))
(list (quote b) (quote c) (quote d)))
(relations-pt-check!
"self path"
(relations-path db (quote a) (quote a) (quote parent))
(list (quote a)))
(relations-pt-check!
"self distance is 0"
(relations-distance db (quote a) (quote a) (quote parent))
0)
(relations-pt-check!
"unknown target -> nil path"
(relations-path db (quote a) (quote zzz) (quote parent))
nil)
(relations-pt-check!
"unknown target -> nil distance"
(relations-distance db (quote a) (quote zzz) (quote parent))
nil)
(relations-pt-check!
"disconnected -> nil path"
(relations-path db (quote a) (quote y) (quote parent))
nil)
(relations-pt-check!
"no parent path crosses into member edge"
(relations-path db (quote a) (quote m) (quote parent))
nil)
(relations-pt-check!
"member path c->m"
(relations-path db (quote c) (quote m) (quote member))
(list (quote c) (quote m)))
(relations-pt-check!
"member path c->n"
(relations-path db (quote c) (quote n) (quote member))
(list (quote c) (quote m) (quote n)))
(relations-pt-check!
"mixed-kind reachable a->m"
(relations-reachable-any? db (quote a) (quote m))
true)
(relations-pt-check!
"mixed-kind reachable a->n"
(relations-reachable-any? db (quote a) (quote n))
true)
(relations-pt-check!
"single-kind a->m not reachable under parent"
(relations-reachable? db (quote a) (quote m) (quote parent))
false)
(relations-pt-check!
"mixed-kind descendants of a include cross-kind nodes"
(relations-pt-set=?
(relations-descendants-any db (quote a))
(list (quote b) (quote c) (quote d) (quote m) (quote n)))
true)
(relations-pt-check!
"single-kind descendants of a under parent only"
(relations-pt-set=?
(relations-descendants db (quote a) (quote parent))
(list (quote b) (quote c) (quote d)))
true)
(relations-pt-check!
"path out of a cycle"
(relations-path cyc (quote u) (quote exit) (quote parent))
(list (quote u) (quote v) (quote w) (quote exit)))
(relations-pt-check!
"distance out of a cycle is 3"
(relations-distance cyc (quote u) (quote exit) (quote parent))
3)
(do
(relations/load!
(list
(relations-rel (quote r1) (quote r2) (quote parent))
(relations-rel (quote r2) (quote r3) (quote parent))
(relations-rel (quote r3) (quote r4) (quote link))))
(relations-pt-check!
"api path"
(relations/path (quote r1) (quote r3) (quote parent))
(list (quote r1) (quote r2) (quote r3)))
(relations-pt-check!
"api distance"
(relations/distance (quote r1) (quote r3) (quote parent))
2)
(relations-pt-check!
"api mixed-kind reachable across parent+link"
(relations/reachable-any? (quote r1) (quote r4))
true)
(relations-pt-check!
"api single-kind not reachable across kinds"
(relations/reachable? (quote r1) (quote r4) (quote parent))
false)
(relations/load! (list)))))))
(define
relations-path-tests-run!
(fn
()
(do
(set! relations-pt-pass 0)
(set! relations-pt-fail 0)
(set! relations-pt-failures (list))
(relations-pt-run-all!)
{:failures relations-pt-failures :total (+ relations-pt-pass relations-pt-fail) :passed relations-pt-pass :failed relations-pt-fail})))