giles
7ce723f732
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 50s
New lib/datalog/builtins.sx: (< <= > >= = !=) and (is X expr) with + - * /. dl-eval-arith recursively evaluates nested compounds. Safety analysis now walks body left-to-right tracking the bound set: comparisons require all args bound, is RHS vars must be bound (LHS becomes bound), = special-cases the var/non-var combos. db.sx keeps the simple safety check as a forward-reference fallback; builtins.sx redefines dl-rule-check-safety to the comprehensive version. eval.sx dispatches built-ins through dl-eval-builtin instead of erroring. 19 new tests.
148 lines
3.7 KiB
Plaintext
148 lines
3.7 KiB
Plaintext
;; lib/datalog/eval.sx — naive bottom-up fixpoint evaluator.
|
|
;;
|
|
;; (dl-saturate! db) iterates rules until no new tuples are derived.
|
|
;; The Herbrand base is finite (no function symbols) so termination is
|
|
;; guaranteed by the language.
|
|
;;
|
|
;; Body literal kinds handled here:
|
|
;; positive (rel arg ... arg) → match against EDB+IDB tuples (dl-match-positive)
|
|
;; built-in (< X Y), (is X e) → constraint via dl-eval-builtin (Phase 4)
|
|
;; 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)))))))
|
|
|
|
(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))))))
|
|
|
|
(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!
|
|
(fn
|
|
(db)
|
|
(let
|
|
((changed true))
|
|
(do
|
|
(define
|
|
dl-sat-loop
|
|
(fn
|
|
()
|
|
(when
|
|
changed
|
|
(do
|
|
(set! changed false)
|
|
(for-each
|
|
(fn (r) (when (dl-apply-rule! db r) (set! changed true)))
|
|
(dl-rules db))
|
|
(dl-sat-loop)))))
|
|
(dl-sat-loop)
|
|
db))))
|
|
|
|
(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)))
|