rose-ash/lib/datalog/tests/api.sx

;; lib/datalog/tests/api.sx — SX-data embedding API.

(define dl-api-pass 0)
(define dl-api-fail 0)
(define dl-api-failures (list))

(define
  dl-api-deep=?
  (fn
    (a b)
    (cond
      ((and (list? a) (list? b))
        (and (= (len a) (len b)) (dl-api-deq-l? a b 0)))
      ((and (dict? a) (dict? b))
        (let ((ka (keys a)) (kb (keys b)))
          (and (= (len ka) (len kb)) (dl-api-deq-d? a b ka 0))))
      ((and (number? a) (number? b)) (= a b))
      (else (equal? a b)))))

(define
  dl-api-deq-l?
  (fn
    (a b i)
    (cond
      ((>= i (len a)) true)
      ((not (dl-api-deep=? (nth a i) (nth b i))) false)
      (else (dl-api-deq-l? a b (+ i 1))))))

(define
  dl-api-deq-d?
  (fn
    (a b ka i)
    (cond
      ((>= i (len ka)) true)
      ((let ((k (nth ka i)))
         (not (dl-api-deep=? (get a k) (get b k))))
        false)
      (else (dl-api-deq-d? a b ka (+ i 1))))))

(define
  dl-api-set=?
  (fn
    (a b)
    (and
      (= (len a) (len b))
      (dl-api-subset? a b)
      (dl-api-subset? b a))))

(define
  dl-api-subset?
  (fn
    (xs ys)
    (cond
      ((= (len xs) 0) true)
      ((not (dl-api-contains? ys (first xs))) false)
      (else (dl-api-subset? (rest xs) ys)))))

(define
  dl-api-contains?
  (fn
    (xs target)
    (cond
      ((= (len xs) 0) false)
      ((dl-api-deep=? (first xs) target) true)
      (else (dl-api-contains? (rest xs) target)))))

(define
  dl-api-test!
  (fn
    (name got expected)
    (if
      (dl-api-deep=? got expected)
      (set! dl-api-pass (+ dl-api-pass 1))
      (do
        (set! dl-api-fail (+ dl-api-fail 1))
        (append!
          dl-api-failures
          (str
            name
            "\n    expected: " expected
            "\n    got:      " got))))))

(define
  dl-api-test-set!
  (fn
    (name got expected)
    (if
      (dl-api-set=? got expected)
      (set! dl-api-pass (+ dl-api-pass 1))
      (do
        (set! dl-api-fail (+ dl-api-fail 1))
        (append!
          dl-api-failures
          (str
            name
            "\n    expected (set): " expected
            "\n    got:            " got))))))

(define
  dl-api-run-all!
  (fn
    ()
    (do
      ;; dl-program-data with arrow form.
      (dl-api-test-set! "data API ancestor closure"
        (dl-query
          (dl-program-data
            (quote ((parent tom bob) (parent bob ann) (parent ann pat)))
            (quote
              ((ancestor X Y <- (parent X Y))
               (ancestor X Z <- (parent X Y) (ancestor Y Z)))))
          (quote (ancestor tom X)))
        (list {:X (quote bob)} {:X (quote ann)} {:X (quote pat)}))

      ;; dl-program-data with dict rules.
      (dl-api-test-set! "data API with dict rules"
        (dl-query
          (dl-program-data
            (quote ((p a) (p b) (p c)))
            (list
              {:head (quote (q X)) :body (quote ((p X)))}))
          (quote (q X)))
        (list {:X (quote a)} {:X (quote b)} {:X (quote c)}))

      ;; dl-rule helper.
      (dl-api-test-set! "dl-rule constructor"
        (dl-query
          (dl-program-data
            (quote ((p 1) (p 2)))
            (list (dl-rule (quote (q X)) (quote ((p X))))))
          (quote (q X)))
        (list {:X 1} {:X 2}))

      ;; dl-assert! adds and re-derives.
      (dl-api-test-set! "dl-assert! incremental"
        (let
          ((db (dl-program-data
                 (quote ((parent tom bob) (parent bob ann)))
                 (quote
                   ((ancestor X Y <- (parent X Y))
                    (ancestor X Z <- (parent X Y) (ancestor Y Z)))))))
          (do
            (dl-saturate! db)
            (dl-assert! db (quote (parent ann pat)))
            (dl-query db (quote (ancestor tom X)))))
        (list {:X (quote bob)} {:X (quote ann)} {:X (quote pat)}))

      ;; dl-retract! removes a fact and recomputes IDB.
      (dl-api-test-set! "dl-retract! removes derived"
        (let
          ((db (dl-program-data
                 (quote ((parent tom bob) (parent bob ann) (parent ann pat)))
                 (quote
                   ((ancestor X Y <- (parent X Y))
                    (ancestor X Z <- (parent X Y) (ancestor Y Z)))))))
          (do
            (dl-saturate! db)
            (dl-retract! db (quote (parent bob ann)))
            (dl-query db (quote (ancestor tom X)))))
        (list {:X (quote bob)}))

      ;; dl-program-data + dl-query with constants in head.
      (dl-api-test-set! "constant-in-head data"
        (dl-query
          (dl-program-data
            (quote ((edge a b) (edge b c) (edge c a)))
            (quote
              ((reach X Y <- (edge X Y))
               (reach X Z <- (edge X Y) (reach Y Z)))))
          (quote (reach a X)))
        (list {:X (quote a)} {:X (quote b)} {:X (quote c)}))

      ;; Assert into empty db.
      (dl-api-test-set! "assert into empty"
        (let
          ((db (dl-program-data (list) (list))))
          (do
            (dl-assert! db (quote (p 1)))
            (dl-assert! db (quote (p 2)))
            (dl-query db (quote (p X)))))
        (list {:X 1} {:X 2}))

      ;; Multi-goal query: pass list of literals.
      (dl-api-test-set! "multi-goal query"
        (dl-query
          (dl-program-data
            (quote ((p 1) (p 2) (p 3) (q 2) (q 3)))
            (list))
          (list (quote (p X)) (quote (q X))))
        (list {:X 2} {:X 3}))

      ;; Multi-goal with comparison.
      (dl-api-test-set! "multi-goal with comparison"
        (dl-query
          (dl-program-data
            (quote ((n 1) (n 2) (n 3) (n 4) (n 5)))
            (list))
          (list (quote (n X)) (list (string->symbol ">") (quote X) 2)))
        (list {:X 3} {:X 4} {:X 5}))

      ;; dl-eval: single-call source + query.
      (dl-api-test-set! "dl-eval ancestor"
        (dl-eval
          "parent(a, b). parent(b, c).
           ancestor(X, Y) :- parent(X, Y).
           ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z)."
          "?- ancestor(a, X).")
        (list {:X (quote b)} {:X (quote c)}))

      (dl-api-test-set! "dl-eval multi-goal"
        (dl-eval
          "p(1). p(2). p(3). q(2). q(3)."
          "?- p(X), q(X).")
        (list {:X 2} {:X 3}))

      ;; dl-rules-of: rules with head matching a relation name.
      (dl-api-test! "dl-rules-of count"
        (let
          ((db (dl-program
                 "p(1). q(X) :- p(X). r(X) :- p(X). q(2).")))
          (len (dl-rules-of db "q")))
        1)

      (dl-api-test! "dl-rules-of empty"
        (let
          ((db (dl-program "p(1). p(2).")))
          (len (dl-rules-of db "q")))
        0)

      ;; dl-clear-idb!: wipe rule-headed relations.
      (dl-api-test! "dl-clear-idb! wipes IDB"
        (let
          ((db (dl-program
                 "parent(a, b). parent(b, c).
                  ancestor(X, Y) :- parent(X, Y).
                  ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
          (do
            (dl-saturate! db)
            (dl-clear-idb! db)
            (len (dl-relation db "ancestor"))))
        0)

      (dl-api-test! "dl-clear-idb! preserves EDB"
        (let
          ((db (dl-program
                 "parent(a, b). parent(b, c).
                  ancestor(X, Y) :- parent(X, Y).")))
          (do
            (dl-saturate! db)
            (dl-clear-idb! db)
            (len (dl-relation db "parent"))))
        2)

      ;; dl-eval-magic — routes single-goal queries through
      ;; magic-sets evaluation.
      (dl-api-test-set! "dl-eval-magic ancestor"
        (dl-eval-magic
          "parent(a, b). parent(b, c).
           ancestor(X, Y) :- parent(X, Y).
           ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z)."
          "?- ancestor(a, X).")
        (list {:X (quote b)} {:X (quote c)}))

      ;; Equivalence: dl-eval and dl-eval-magic produce the same
      ;; answers for any well-formed query (magic-sets is a perf
      ;; alternative, not a semantic change).
      (dl-api-test! "dl-eval ≡ dl-eval-magic on ancestor"
        (let
          ((source "parent(a, b). parent(b, c). parent(c, d).
                    ancestor(X, Y) :- parent(X, Y).
                    ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z)."))
          (let
            ((semi (dl-eval source "?- ancestor(a, X)."))
              (magic (dl-eval-magic source "?- ancestor(a, X).")))
            (= (len semi) (len magic))))
        true)

      ;; Comprehensive integration: recursion + stratified negation
      ;; + aggregation + comparison composed in a single program.
      ;; (Uses _Anything as a regular var instead of `_` so the
      ;;  outer rule binds via the reach lit.)
      (dl-api-test-set! "integration"
        (dl-eval
          (str
            "edge(a, b). edge(b, c). edge(c, d). edge(a, d). "
            "banned(c). "
            "reach(X, Y) :- edge(X, Y). "
            "reach(X, Z) :- edge(X, Y), reach(Y, Z). "
            "safe(X, Y) :- reach(X, Y), not(banned(Y)). "
            "reach_count(X, N) :- reach(X, Z), count(N, Y, safe(X, Y)). "
            "popular(X) :- reach_count(X, N), >=(N, 2).")
          "?- popular(X).")
        (list {:X (quote a)}))

      ;; dl-rule-from-list with no arrow → fact-style.
      (dl-api-test-set! "no arrow → fact-like rule"
        (let
          ((rule (dl-rule-from-list (quote (foo X Y)))))
          (list rule))
        (list {:head (quote (foo X Y)) :body (list)}))

      ;; dl-coerce-rule on dict passes through.
      (dl-api-test-set! "coerce dict rule"
        (let
          ((d {:head (quote (h X)) :body (quote ((b X)))}))
          (list (dl-coerce-rule d)))
        (list {:head (quote (h X)) :body (quote ((b X)))})))))

(define
  dl-api-tests-run!
  (fn
    ()
    (do
      (set! dl-api-pass 0)
      (set! dl-api-fail 0)
      (set! dl-api-failures (list))
      (dl-api-run-all!)
      {:passed dl-api-pass
       :failed dl-api-fail
       :total (+ dl-api-pass dl-api-fail)
       :failures dl-api-failures})))