rose-ash/lib/datalog/magic.sx

;; lib/datalog/magic.sx — adornment analysis + sideways info passing.
;;
;; First step of the magic-sets transformation (Phase 6). Right now
;; the saturator does not consume these — they are introspection
;; helpers that future magic-set rewriting will build on top of.
;;
;; Definitions:
;;   - An *adornment* of an n-ary literal is an n-character string
;;     of "b" (bound — value already known at the call site) and
;;     "f" (free — to be derived).
;;   - SIPS (Sideways Information Passing Strategy) walks the body
;;     of an adorned rule left-to-right tracking which variables
;;     have been bound so far, computing each body literal's
;;     adornment in turn.
;;
;; Usage:
;;
;;   (dl-adorn-goal '(ancestor tom X))
;;     => "bf"
;;
;;   (dl-rule-sips
;;     {:head (ancestor X Z)
;;      :body ((parent X Y) (ancestor Y Z))}
;;     "bf")
;;   => ({:lit (parent X Y) :adornment "bf"}
;;       {:lit (ancestor Y Z) :adornment "bf"})

;; Per-arg adornment under the current bound-var name set.
(define
  dl-adorn-arg
  (fn
    (arg bound)
    (cond
      ((dl-var? arg)
        (if (dl-member-string? (symbol->string arg) bound) "b" "f"))
      (else "b"))))

;; Adornment for the args of a literal (after the relation name).
(define
  dl-adorn-args
  (fn
    (args bound)
    (cond
      ((= (len args) 0) "")
      (else
        (str
          (dl-adorn-arg (first args) bound)
          (dl-adorn-args (rest args) bound))))))

;; Adornment of a top-level goal under the empty bound-var set.
(define
  dl-adorn-goal
  (fn (goal) (dl-adorn-args (rest goal) (list))))

;; Adornment of a literal under an explicit bound set.
(define
  dl-adorn-lit
  (fn (lit bound) (dl-adorn-args (rest lit) bound)))

;; The set of variable names made bound by walking a positive
;; literal whose adornment is known. Free positions add their
;; vars to the bound set.
(define
  dl-vars-bound-by-lit
  (fn
    (lit bound)
    (let ((args (rest lit)) (out (list)))
      (do
        (for-each
          (fn (a)
            (when
              (and (dl-var? a)
                   (not (dl-member-string? (symbol->string a) bound))
                   (not (dl-member-string? (symbol->string a) out)))
              (append! out (symbol->string a))))
          args)
        out))))

;; Walk the rule body left-to-right tracking bound vars seeded by the
;; head adornment. Returns a list of {:lit :adornment} entries.
;;
;; Negation, comparison, and built-ins are passed through with their
;; adornment computed from the current bound set; they don't add new
;; bindings (except `is`, which binds its left arg if a var). Aggregates
;; are treated like is — the result var becomes bound.
(define
  dl-init-head-bound
  (fn
    (head adornment)
    (let ((args (rest head)) (out (list)))
      (do
        (define
          dl-ihb-loop
          (fn
            (i)
            (when
              (< i (len args))
              (do
                (let
                  ((c (slice adornment i (+ i 1)))
                    (a (nth args i)))
                  (when
                    (and (= c "b") (dl-var? a))
                    (let ((n (symbol->string a)))
                      (when
                        (not (dl-member-string? n out))
                        (append! out n)))))
                (dl-ihb-loop (+ i 1))))))
        (dl-ihb-loop 0)
        out))))

(define
  dl-rule-sips
  (fn
    (rule head-adornment)
    (let
      ((bound (dl-init-head-bound (get rule :head) head-adornment))
        (out (list)))
      (do
        (for-each
          (fn
            (lit)
            (cond
              ((and (dict? lit) (has-key? lit :neg))
                (let ((target (get lit :neg)))
                  (append!
                    out
                    {:lit lit :adornment (dl-adorn-lit target bound)})))
              ((dl-builtin? lit)
                (let ((adn (dl-adorn-lit lit bound)))
                  (do
                    (append! out {:lit lit :adornment adn})
                    ;; `is` binds its left arg (if var) once RHS is ground.
                    (when
                      (and (= (dl-rel-name lit) "is") (dl-var? (nth lit 1)))
                      (let ((n (symbol->string (nth lit 1))))
                        (when
                          (not (dl-member-string? n bound))
                          (append! bound n)))))))
              ((and (list? lit) (dl-aggregate? lit))
                (let ((adn (dl-adorn-lit lit bound)))
                  (do
                    (append! out {:lit lit :adornment adn})
                    ;; Result var (first arg) becomes bound.
                    (when (dl-var? (nth lit 1))
                      (let ((n (symbol->string (nth lit 1))))
                        (when
                          (not (dl-member-string? n bound))
                          (append! bound n)))))))
              ((and (list? lit) (> (len lit) 0))
                (let ((adn (dl-adorn-lit lit bound)))
                  (do
                    (append! out {:lit lit :adornment adn})
                    (for-each
                      (fn (n)
                        (when (not (dl-member-string? n bound))
                          (append! bound n)))
                      (dl-vars-bound-by-lit lit bound)))))))
          (get rule :body))
        out))))