giles
d964f58c48
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 56s
dl-saturate! is now semi-naive: tracks a per-relation delta dict, and on each iteration walks every positive body-literal position, substituting the delta of its relation while joining the rest against the previous-iteration DB. Candidates are collected before mutating the DB so the "full" sides see a consistent snapshot. Rules with no positive body literal (e.g. (p X) :- (= X 5).) fall back to a one-shot naive pass via dl-collect-rule-candidates. dl-saturate-naive! retained as the reference implementation; 8 differential tests compare per-relation tuple counts on every recursive program. Switched dl-tuple-member? to indexed iteration instead of recursive rest (eliminates per-step list copy). Larger chains under bundled conformance trip O(n) membership × CPU sharing — added a Blocker to swap relations to hash-set membership.
354 lines
9.8 KiB
Plaintext
354 lines
9.8 KiB
Plaintext
;; lib/datalog/eval.sx — fixpoint evaluator (naive + semi-naive).
|
|
;;
|
|
;; Two saturators are exposed:
|
|
;; `dl-saturate-naive!` — re-joins each rule against the full DB every
|
|
;; iteration. Reference implementation; useful for differential tests.
|
|
;; `dl-saturate!` — semi-naive default. Tracks per-relation delta
|
|
;; sets and substitutes one positive body literal per rule with the
|
|
;; delta of its relation, joining the rest against the previous-
|
|
;; iteration DB. Same fixpoint, dramatically less work on recursive
|
|
;; rules.
|
|
;;
|
|
;; Body literal kinds:
|
|
;; positive (rel arg ... arg) → match against EDB+IDB tuples
|
|
;; built-in (< X Y), (is X e) → constraint via dl-eval-builtin
|
|
;; negation {:neg lit} → Phase 7
|
|
|
|
(define
|
|
dl-match-positive
|
|
(fn
|
|
(lit db subst)
|
|
(let
|
|
((rel (dl-rel-name lit)) (results (list)))
|
|
(cond
|
|
((nil? rel) (error (str "dl-match-positive: bad literal " lit)))
|
|
(else
|
|
(let
|
|
((tuples (dl-rel-tuples db rel)))
|
|
(do
|
|
(for-each
|
|
(fn
|
|
(tuple)
|
|
(let
|
|
((s (dl-unify lit tuple subst)))
|
|
(when (not (nil? s)) (append! results s))))
|
|
tuples)
|
|
results)))))))
|
|
|
|
;; Match a positive literal against the delta set for its relation only.
|
|
(define
|
|
dl-match-positive-delta
|
|
(fn
|
|
(lit delta subst)
|
|
(let
|
|
((rel (dl-rel-name lit)) (results (list)))
|
|
(let
|
|
((tuples (if (has-key? delta rel) (get delta rel) (list))))
|
|
(do
|
|
(for-each
|
|
(fn
|
|
(tuple)
|
|
(let
|
|
((s (dl-unify lit tuple subst)))
|
|
(when (not (nil? s)) (append! results s))))
|
|
tuples)
|
|
results)))))
|
|
|
|
;; Naive matcher (for dl-saturate-naive! and dl-query post-saturation).
|
|
(define
|
|
dl-match-lit
|
|
(fn
|
|
(lit db subst)
|
|
(cond
|
|
((and (dict? lit) (has-key? lit :neg))
|
|
(error "datalog: negation not yet supported (Phase 7)"))
|
|
((dl-builtin? lit)
|
|
(let
|
|
((s (dl-eval-builtin lit subst)))
|
|
(if (nil? s) (list) (list s))))
|
|
((and (list? lit) (> (len lit) 0))
|
|
(dl-match-positive lit db subst))
|
|
(else (error (str "datalog: unknown body-literal shape: " lit))))))
|
|
|
|
(define
|
|
dl-find-bindings
|
|
(fn
|
|
(lits db subst)
|
|
(cond
|
|
((nil? subst) (list))
|
|
((= (len lits) 0) (list subst))
|
|
(else
|
|
(let
|
|
((options (dl-match-lit (first lits) db subst))
|
|
(results (list)))
|
|
(do
|
|
(for-each
|
|
(fn
|
|
(s)
|
|
(for-each
|
|
(fn (s2) (append! results s2))
|
|
(dl-find-bindings (rest lits) db s)))
|
|
options)
|
|
results))))))
|
|
|
|
;; Naive: apply each rule against full DB until no new tuples.
|
|
(define
|
|
dl-apply-rule!
|
|
(fn
|
|
(db rule)
|
|
(let
|
|
((head (get rule :head)) (body (get rule :body)) (new? false))
|
|
(do
|
|
(for-each
|
|
(fn
|
|
(s)
|
|
(let
|
|
((derived (dl-apply-subst head s)))
|
|
(when (dl-add-fact! db derived) (set! new? true))))
|
|
(dl-find-bindings body db (dl-empty-subst)))
|
|
new?))))
|
|
|
|
(define
|
|
dl-saturate-naive!
|
|
(fn
|
|
(db)
|
|
(let
|
|
((changed true))
|
|
(do
|
|
(define
|
|
dl-snloop
|
|
(fn
|
|
()
|
|
(when
|
|
changed
|
|
(do
|
|
(set! changed false)
|
|
(for-each
|
|
(fn (r) (when (dl-apply-rule! db r) (set! changed true)))
|
|
(dl-rules db))
|
|
(dl-snloop)))))
|
|
(dl-snloop)
|
|
db))))
|
|
|
|
;; ── Semi-naive ───────────────────────────────────────────────────
|
|
|
|
;; Take a snapshot dict {rel -> tuples} of every relation currently in
|
|
;; the DB. Used as initial delta for the first iteration.
|
|
(define
|
|
dl-snapshot-facts
|
|
(fn
|
|
(db)
|
|
(let
|
|
((facts (get db :facts)) (out {}))
|
|
(do
|
|
(for-each
|
|
(fn (k) (dict-set! out k (dl-copy-list (get facts k))))
|
|
(keys facts))
|
|
out))))
|
|
|
|
(define
|
|
dl-copy-list
|
|
(fn
|
|
(xs)
|
|
(let
|
|
((out (list)))
|
|
(do (for-each (fn (x) (append! out x)) xs) out))))
|
|
|
|
;; Does any relation in `delta` have ≥1 tuple?
|
|
(define
|
|
dl-delta-empty?
|
|
(fn
|
|
(delta)
|
|
(let
|
|
((ks (keys delta)) (any-non-empty false))
|
|
(do
|
|
(for-each
|
|
(fn
|
|
(k)
|
|
(when
|
|
(> (len (get delta k)) 0)
|
|
(set! any-non-empty true)))
|
|
ks)
|
|
(not any-non-empty)))))
|
|
|
|
;; Find substitutions such that `lits` are all satisfied AND `delta-idx`
|
|
;; is matched against the per-relation delta only. The other positive
|
|
;; literals match against the snapshot DB (db.facts read at iteration
|
|
;; start). Built-ins and negations behave as in `dl-match-lit`.
|
|
(define
|
|
dl-find-bindings-semi
|
|
(fn
|
|
(lits db delta delta-idx subst)
|
|
(dl-fbs-aux lits db delta delta-idx 0 subst)))
|
|
|
|
(define
|
|
dl-fbs-aux
|
|
(fn
|
|
(lits db delta delta-idx i subst)
|
|
(cond
|
|
((nil? subst) (list))
|
|
((>= i (len lits)) (list subst))
|
|
(else
|
|
(let
|
|
((lit (nth lits i))
|
|
(options
|
|
(cond
|
|
((and (dict? lit) (has-key? lit :neg))
|
|
(error "datalog: negation in semi-naive (Phase 7)"))
|
|
((dl-builtin? lit)
|
|
(let
|
|
((s (dl-eval-builtin lit subst)))
|
|
(if (nil? s) (list) (list s))))
|
|
((and (list? lit) (> (len lit) 0))
|
|
(if
|
|
(= i delta-idx)
|
|
(dl-match-positive-delta lit delta subst)
|
|
(dl-match-positive lit db subst)))
|
|
(else (error (str "datalog: unknown body-lit: " lit)))))
|
|
(results (list)))
|
|
(do
|
|
(for-each
|
|
(fn
|
|
(s)
|
|
(for-each
|
|
(fn (s2) (append! results s2))
|
|
(dl-fbs-aux lits db delta delta-idx (+ i 1) s)))
|
|
options)
|
|
results))))))
|
|
|
|
;; Collect candidate head tuples from a rule using delta. Walks every
|
|
;; positive body position and unions the resulting heads. For rules
|
|
;; with no positive body literal, falls back to a naive single-pass
|
|
;; (so static facts like `(p X) :- (= X 5).` derive on iteration 1).
|
|
(define
|
|
dl-collect-rule-candidates
|
|
(fn
|
|
(rule db delta)
|
|
(let
|
|
((head (get rule :head))
|
|
(body (get rule :body))
|
|
(out (list))
|
|
(saw-pos false))
|
|
(do
|
|
(define
|
|
dl-cri
|
|
(fn
|
|
(i)
|
|
(when
|
|
(< i (len body))
|
|
(do
|
|
(let
|
|
((lit (nth body i)))
|
|
(when
|
|
(dl-positive-lit? lit)
|
|
(do
|
|
(set! saw-pos true)
|
|
(for-each
|
|
(fn (s) (append! out (dl-apply-subst head s)))
|
|
(dl-find-bindings-semi
|
|
body
|
|
db
|
|
delta
|
|
i
|
|
(dl-empty-subst))))))
|
|
(dl-cri (+ i 1))))))
|
|
(dl-cri 0)
|
|
(when
|
|
(not saw-pos)
|
|
(for-each
|
|
(fn (s) (append! out (dl-apply-subst head s)))
|
|
(dl-find-bindings body db (dl-empty-subst))))
|
|
out))))
|
|
|
|
;; Add a list of candidate tuples to db; collect newly-added ones into
|
|
;; the new-delta dict (keyed by relation name).
|
|
(define
|
|
dl-commit-candidates!
|
|
(fn
|
|
(db candidates new-delta)
|
|
(for-each
|
|
(fn
|
|
(lit)
|
|
(when
|
|
(dl-add-fact! db lit)
|
|
(let
|
|
((rel (dl-rel-name lit)))
|
|
(do
|
|
(when
|
|
(not (has-key? new-delta rel))
|
|
(dict-set! new-delta rel (list)))
|
|
(append! (get new-delta rel) lit)))))
|
|
candidates)))
|
|
|
|
(define
|
|
dl-saturate!
|
|
(fn
|
|
(db)
|
|
(let
|
|
((delta (dl-snapshot-facts db)))
|
|
(do
|
|
(define
|
|
dl-sn-step
|
|
(fn
|
|
()
|
|
(let
|
|
((pending (list)) (new-delta {}))
|
|
(do
|
|
(for-each
|
|
(fn
|
|
(rule)
|
|
(for-each
|
|
(fn (cand) (append! pending cand))
|
|
(dl-collect-rule-candidates rule db delta)))
|
|
(dl-rules db))
|
|
(dl-commit-candidates! db pending new-delta)
|
|
(cond
|
|
((dl-delta-empty? new-delta) nil)
|
|
(else (do (set! delta new-delta) (dl-sn-step))))))))
|
|
(dl-sn-step)
|
|
db))))
|
|
|
|
;; ── Querying ─────────────────────────────────────────────────────
|
|
|
|
(define
|
|
dl-query
|
|
(fn
|
|
(db goal)
|
|
(do
|
|
(dl-saturate! db)
|
|
(let
|
|
((substs (dl-find-bindings (list goal) db (dl-empty-subst)))
|
|
(vars (dl-vars-of goal))
|
|
(results (list)))
|
|
(do
|
|
(for-each
|
|
(fn
|
|
(s)
|
|
(let
|
|
((proj (dl-project-subst s vars)))
|
|
(when
|
|
(not (dl-tuple-member? proj results))
|
|
(append! results proj))))
|
|
substs)
|
|
results)))))
|
|
|
|
(define
|
|
dl-project-subst
|
|
(fn
|
|
(subst names)
|
|
(let
|
|
((out {}))
|
|
(do
|
|
(for-each
|
|
(fn
|
|
(n)
|
|
(let
|
|
((sym (string->symbol n)))
|
|
(let
|
|
((v (dl-walk sym subst)))
|
|
(dict-set! out n (dl-apply-subst v subst)))))
|
|
names)
|
|
out))))
|
|
|
|
(define dl-relation (fn (db name) (dl-rel-tuples db name)))
|