datalog: Phase 6 adornments + SIPS analysis (194/194)

New lib/datalog/magic.sx — first piece of magic-sets:

  dl-adorn-arg arg bound          → "b" or "f"
  dl-adorn-args args bound        → adornment string
  dl-adorn-goal goal              → adornment under empty bound set
  dl-adorn-lit lit bound          → adornment of any literal
  dl-vars-bound-by-lit lit bound  → free vars this lit will bind
  dl-init-head-bound head adn     → bound set seeded from head adornment
  dl-rule-sips rule head-adn      → ({:lit :adornment} ...) per body lit

SIPS walks left-to-right tracking the bound set; recognises `is` and
aggregate result-vars as new binders, lets comparisons and negation
pass through with computed adornments.

Inspection-only — saturator doesn't yet consume these. Lays
groundwork for a future magic-sets transformation.

10 new tests cover pure adornment, SIPS over a chain rule,
head-fully-bound rules, comparisons, and `is`. Total 194/194.

lib/datalog/conformance.conf

@@ -13,6 +13,7 @@ PRELOADS=(
   lib/datalog/strata.sx
   lib/datalog/eval.sx
   lib/datalog/api.sx
+  lib/datalog/magic.sx
   lib/datalog/demo.sx
 )
 
@@ -26,5 +27,6 @@ SUITES=(
   "negation:lib/datalog/tests/negation.sx:(dl-negation-tests-run!)"
   "aggregates:lib/datalog/tests/aggregates.sx:(dl-aggregates-tests-run!)"
   "api:lib/datalog/tests/api.sx:(dl-api-tests-run!)"
+  "magic:lib/datalog/tests/magic.sx:(dl-magic-tests-run!)"
   "demo:lib/datalog/tests/demo.sx:(dl-demo-tests-run!)"
 )

lib/datalog/magic.sx

@@ -0,0 +1,160 @@
+;; 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))))

lib/datalog/scoreboard.json

@@ -1,8 +1,8 @@
 {
   "lang": "datalog",
-  "total_passed": 184,
+  "total_passed": 194,
   "total_failed": 0,
-  "total": 184,
+  "total": 194,
   "suites": [
     {"name":"tokenize","passed":26,"failed":0,"total":26},
     {"name":"parse","passed":18,"failed":0,"total":18},
@@ -13,7 +13,8 @@
     {"name":"negation","passed":10,"failed":0,"total":10},
     {"name":"aggregates","passed":18,"failed":0,"total":18},
     {"name":"api","passed":14,"failed":0,"total":14},
+    {"name":"magic","passed":10,"failed":0,"total":10},
     {"name":"demo","passed":18,"failed":0,"total":18}
   ],
-  "generated": "2026-05-08T09:47:44+00:00"
+  "generated": "2026-05-08T09:50:50+00:00"
 }

lib/datalog/scoreboard.md

@@ -1,6 +1,6 @@
 # datalog scoreboard
 
-**184 / 184 passing** (0 failure(s)).
+**194 / 194 passing** (0 failure(s)).
 
 | Suite | Passed | Total | Status |
 |-------|--------|-------|--------|
@@ -13,4 +13,5 @@
 | negation | 10 | 10 | ok |
 | aggregates | 18 | 18 | ok |
 | api | 14 | 14 | ok |
+| magic | 10 | 10 | ok |
 | demo | 18 | 18 | ok |

lib/datalog/tests/magic.sx

@@ -0,0 +1,141 @@
+;; lib/datalog/tests/magic.sx — adornment + SIPS analysis tests.
+
+(define dl-mt-pass 0)
+(define dl-mt-fail 0)
+(define dl-mt-failures (list))
+
+(define
+  dl-mt-deep=?
+  (fn
+    (a b)
+    (cond
+      ((and (list? a) (list? b))
+        (and (= (len a) (len b)) (dl-mt-deq-l? a b 0)))
+      ((and (dict? a) (dict? b))
+        (let ((ka (keys a)) (kb (keys b)))
+          (and (= (len ka) (len kb)) (dl-mt-deq-d? a b ka 0))))
+      ((and (number? a) (number? b)) (= a b))
+      (else (equal? a b)))))
+
+(define
+  dl-mt-deq-l?
+  (fn
+    (a b i)
+    (cond
+      ((>= i (len a)) true)
+      ((not (dl-mt-deep=? (nth a i) (nth b i))) false)
+      (else (dl-mt-deq-l? a b (+ i 1))))))
+
+(define
+  dl-mt-deq-d?
+  (fn
+    (a b ka i)
+    (cond
+      ((>= i (len ka)) true)
+      ((let ((k (nth ka i)))
+         (not (dl-mt-deep=? (get a k) (get b k))))
+        false)
+      (else (dl-mt-deq-d? a b ka (+ i 1))))))
+
+(define
+  dl-mt-test!
+  (fn
+    (name got expected)
+    (if
+      (dl-mt-deep=? got expected)
+      (set! dl-mt-pass (+ dl-mt-pass 1))
+      (do
+        (set! dl-mt-fail (+ dl-mt-fail 1))
+        (append!
+          dl-mt-failures
+          (str
+            name
+            "\n    expected: " expected
+            "\n    got:      " got))))))
+
+(define
+  dl-mt-run-all!
+  (fn
+    ()
+    (do
+      ;; Goal adornment.
+      (dl-mt-test! "adorn 0-ary"
+        (dl-adorn-goal (list (quote ready)))
+        "")
+      (dl-mt-test! "adorn all bound"
+        (dl-adorn-goal (list (quote p) 1 2 3))
+        "bbb")
+      (dl-mt-test! "adorn all free"
+        (dl-adorn-goal (list (quote p) (quote X) (quote Y)))
+        "ff")
+      (dl-mt-test! "adorn mixed"
+        (dl-adorn-goal (list (quote ancestor) (quote tom) (quote X)))
+        "bf")
+      (dl-mt-test! "adorn const var const"
+        (dl-adorn-goal (list (quote p) (quote a) (quote X) (quote b)))
+        "bfb")
+
+      ;; dl-adorn-lit with explicit bound set.
+      (dl-mt-test! "adorn lit with bound"
+        (dl-adorn-lit (list (quote p) (quote X) (quote Y)) (list "X"))
+        "bf")
+
+      ;; Rule SIPS — chain ancestor.
+      (dl-mt-test! "sips chain ancestor bf"
+        (dl-rule-sips
+          {:head (list (quote ancestor) (quote X) (quote Z))
+           :body (list (list (quote parent) (quote X) (quote Y))
+                       (list (quote ancestor) (quote Y) (quote Z)))}
+          "bf")
+        (list
+          {:lit (list (quote parent) (quote X) (quote Y)) :adornment "bf"}
+          {:lit (list (quote ancestor) (quote Y) (quote Z)) :adornment "bf"}))
+
+      ;; SIPS — head fully bound.
+      (dl-mt-test! "sips head bb"
+        (dl-rule-sips
+          {:head (list (quote q) (quote X) (quote Y))
+           :body (list (list (quote p) (quote X) (quote Z))
+                       (list (quote r) (quote Z) (quote Y)))}
+          "bb")
+        (list
+          {:lit (list (quote p) (quote X) (quote Z)) :adornment "bf"}
+          {:lit (list (quote r) (quote Z) (quote Y)) :adornment "bb"}))
+
+      ;; SIPS — comparison; vars must be bound by prior body lit.
+      (dl-mt-test! "sips with comparison"
+        (dl-rule-sips
+          {:head (list (quote q) (quote X))
+           :body (list (list (quote p) (quote X))
+                       (list (string->symbol "<") (quote X) 5))}
+          "f")
+        (list
+          {:lit (list (quote p) (quote X)) :adornment "f"}
+          {:lit (list (string->symbol "<") (quote X) 5) :adornment "bb"}))
+
+      ;; SIPS — `is` binds its left arg.
+      (dl-mt-test! "sips with is"
+        (dl-rule-sips
+          {:head (list (quote q) (quote X) (quote Y))
+           :body (list (list (quote p) (quote X))
+                       (list (quote is) (quote Y) (list (string->symbol "+") (quote X) 1)))}
+          "ff")
+        (list
+          {:lit (list (quote p) (quote X)) :adornment "f"}
+          {:lit (list (quote is) (quote Y)
+                      (list (string->symbol "+") (quote X) 1))
+           :adornment "fb"})))))
+
+(define
+  dl-magic-tests-run!
+  (fn
+    ()
+    (do
+      (set! dl-mt-pass 0)
+      (set! dl-mt-fail 0)
+      (set! dl-mt-failures (list))
+      (dl-mt-run-all!)
+      {:passed dl-mt-pass
+       :failed dl-mt-fail
+       :total (+ dl-mt-pass dl-mt-fail)
+       :failures dl-mt-failures})))