giles
e6ffc60040
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 50s
lib/relations/tree.sx over reach/ancestors/rnode — no new Datalog closures. 126/126. Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
119 lines
3.2 KiB
Plaintext
119 lines
3.2 KiB
Plaintext
;; lib/relations/tree.sx — tree/DAG queries: common ancestors, LCA, topo order.
|
|
;;
|
|
;; All computed in SX over the engine's fast `reach`/`ancestors`/`rnode` queries
|
|
;; — no new Datalog closures (every dl-query re-saturates, so derived graph
|
|
;; algorithms stay in SX). Kind-parameterised throughout, like the rest of the
|
|
;; engine. LCA returns a SET (a DAG may have several lowest common ancestors; a
|
|
;; tree yields exactly one). topo-order returns nil for a cyclic kind.
|
|
|
|
(define
|
|
relations-tree-any?
|
|
(fn
|
|
(pred xs)
|
|
(cond
|
|
((= (len xs) 0) false)
|
|
((pred (first xs)) true)
|
|
(else (relations-tree-any? pred (rest xs))))))
|
|
|
|
(define
|
|
relations-intersect
|
|
(fn (xs ys) (filter (fn (x) (relations-eng-member? x ys)) xs)))
|
|
|
|
(define
|
|
relations-subset?
|
|
(fn
|
|
(xs ys)
|
|
(cond
|
|
((= (len xs) 0) true)
|
|
((relations-eng-member? (first xs) ys)
|
|
(relations-subset? (rest xs) ys))
|
|
(else false))))
|
|
|
|
;; All nodes touched by a kind (the materialised rnode relation — one query).
|
|
(define
|
|
relations-nodes
|
|
(fn
|
|
(db kind)
|
|
(relations-dedup
|
|
(relations-pluck
|
|
(dl-query db (list (quote rnode) kind (quote X)))
|
|
:X))))
|
|
|
|
;; Common ancestors of a and b under kind (set intersection of the two
|
|
;; ancestor sets).
|
|
(define
|
|
relations-common-ancestors
|
|
(fn
|
|
(db a b kind)
|
|
(relations-intersect
|
|
(relations-ancestors db a kind)
|
|
(relations-ancestors db b kind))))
|
|
|
|
;; Lowest common ancestors: common ancestors with no other common ancestor
|
|
;; strictly below them (none reachable from them). A tree gives a singleton; a
|
|
;; DAG may give several. Empty when a and b share no ancestor.
|
|
(define
|
|
relations-lca
|
|
(fn
|
|
(db a b kind)
|
|
(let
|
|
((common (relations-common-ancestors db a b kind)))
|
|
(filter
|
|
(fn
|
|
(x)
|
|
(not
|
|
(relations-tree-any?
|
|
(fn
|
|
(y)
|
|
(and (not (= x y)) (relations-reachable? db x y kind)))
|
|
common)))
|
|
common))))
|
|
|
|
;; Kahn-style topological order: repeatedly place every node whose parents are
|
|
;; all already placed. Returns the node list in topological order, or nil if the
|
|
;; kind has a cycle.
|
|
(define
|
|
relations-topo-kahn
|
|
(fn
|
|
(db kind remaining placed)
|
|
(if
|
|
(= (len remaining) 0)
|
|
placed
|
|
(let
|
|
((ready (filter (fn (n) (relations-subset? (relations-parents-of db n kind) placed)) remaining)))
|
|
(if
|
|
(= (len ready) 0)
|
|
placed
|
|
(relations-topo-kahn
|
|
db
|
|
kind
|
|
(filter
|
|
(fn (n) (not (relations-eng-member? n ready)))
|
|
remaining)
|
|
(append placed ready)))))))
|
|
|
|
(define
|
|
relations-topo-order
|
|
(fn
|
|
(db kind)
|
|
(if
|
|
(relations-acyclic? db kind)
|
|
(relations-topo-kahn db kind (relations-nodes db kind) (list))
|
|
nil)))
|
|
|
|
;; --- current-db convenience layer ---
|
|
|
|
(define
|
|
relations/common-ancestors
|
|
(fn
|
|
(a b kind)
|
|
(relations-common-ancestors (relations-ensure-db!) a b kind)))
|
|
|
|
(define
|
|
relations/lca
|
|
(fn (a b kind) (relations-lca (relations-ensure-db!) a b kind)))
|
|
|
|
(define
|
|
relations/topo-order
|
|
(fn (kind) (relations-topo-order (relations-ensure-db!) kind)))
|