rose-ash/lib/datalog/eval.sx

;; 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)))