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

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

      ;; Magic predicate naming.
      (dl-mt-test! "magic-rel-name"
        (dl-magic-rel-name "ancestor" "bf")
        "magic_ancestor^bf")

      ;; Bound-args extraction.
      (dl-mt-test! "bound-args bf"
        (dl-bound-args (list (quote ancestor) (quote tom) (quote X)) "bf")
        (list (quote tom)))

      (dl-mt-test! "bound-args mixed"
        (dl-bound-args (list (quote p) 1 (quote Y) 3) "bfb")
        (list 1 3))

      (dl-mt-test! "bound-args all-free"
        (dl-bound-args (list (quote p) (quote X) (quote Y)) "ff")
        (list))

      ;; Magic literal construction.
      (dl-mt-test! "magic-lit"
        (dl-magic-lit "ancestor" "bf" (list (quote tom)))
        (list (string->symbol "magic_ancestor^bf") (quote tom))))))

(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})))