datalog: db + naive eval + safety analysis (Phase 3, 87/87)

db.sx: facts indexed by relation name, rules list, dl-add-fact!
(rejects non-ground), dl-add-rule! (rejects unsafe — head vars
not in positive body). eval.sx: dl-saturate! fixpoint, dl-query
with deduped projected results. Negation and arithmetic raise
clear errors (Phase 4/7 to follow). 15 eval tests: transitive
closure, sibling, same-gen, grandparent, cyclic reach, safety.

lib/datalog/eval.sx

@@ -0,0 +1,153 @@
+;; 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.
+;;
+;; Phase 3 handles only positive EDB literals. Negation (Phase 7) and
+;; arithmetic built-ins (Phase 4) raise a clear error if encountered.
+
+;; Match a positive literal against every tuple in the relation; return
+;; a list of extended substitutions, one per successful unification.
+(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)
+        (error "datalog: built-in predicate not yet supported (Phase 4)"))
+      ((and (list? lit) (> (len lit) 0))
+        (dl-match-positive lit db subst))
+      (else (error (str "datalog: unknown body-literal shape: " lit))))))
+
+;; Recursively find all substitutions satisfying a list of body literals
+;; under `subst`. Returns a list of substitutions.
+(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))))))
+
+;; Apply a rule once. Returns true if any new tuple was derived.
+(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?))))
+
+;; Iterate rules to fixpoint.
+(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))))
+
+;; Run a goal against the saturated db. Returns a list of substitutions
+;; (each restricted to the variables that appeared in `goal`). Duplicate
+;; projections are deduplicated so users get the set of answers.
+(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)))))
+
+;; Project a subst down to a given set of variable names.
+(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)))