;; lib/datalog/tests/builtins.sx — comparison + arithmetic body literals.

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

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

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

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

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

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

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

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

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

(define
  dl-bt-throws?
  (fn
    (thunk)
    (let
      ((threw false))
      (do (guard (e (#t (set! threw true))) (thunk)) threw))))

(define
  dl-bt-run-all!
  (fn
    ()
    (do
      (dl-bt-test-set!
        "less than filter"
        (dl-query
          (dl-program
            "age(alice, 30). age(bob, 17). age(carol, 22).\n             adult(X) :- age(X, A), >=(A, 18).")
          (list (quote adult) (quote X)))
        (list {:X (quote alice)} {:X (quote carol)}))
      (dl-bt-test-set!
        "less-equal filter"
        (dl-query
          (dl-program
            "n(1). n(2). n(3). n(4). n(5).\n             small(X) :- n(X), <=(X, 3).")
          (list (quote small) (quote X)))
        (list {:X 1} {:X 2} {:X 3}))
      (dl-bt-test-set!
        "not-equal filter"
        (dl-query
          (dl-program
            "p(1, 2). p(2, 2). p(3, 4).\n             diff(X, Y) :- p(X, Y), !=(X, Y).")
          (list (quote diff) (quote X) (quote Y)))
        (list {:X 1 :Y 2} {:X 3 :Y 4}))
      (dl-bt-test-set!
        "is plus"
        (dl-query
          (dl-program
            "n(1). n(2). n(3).\n             succ(X, Y) :- n(X), is(Y, +(X, 1)).")
          (list (quote succ) (quote X) (quote Y)))
        (list {:X 1 :Y 2} {:X 2 :Y 3} {:X 3 :Y 4}))
      (dl-bt-test-set!
        "is multiply"
        (dl-query
          (dl-program
            "n(2). n(3). n(4).\n             square(X, Y) :- n(X), is(Y, *(X, X)).")
          (list (quote square) (quote X) (quote Y)))
        (list {:X 2 :Y 4} {:X 3 :Y 9} {:X 4 :Y 16}))
      (dl-bt-test-set!
        "is nested expr"
        (dl-query
          (dl-program
            "n(1). n(2). n(3).\n             f(X, Y) :- n(X), is(Y, *(+(X, 1), 2)).")
          (list (quote f) (quote X) (quote Y)))
        (list {:X 1 :Y 4} {:X 2 :Y 6} {:X 3 :Y 8}))
      (dl-bt-test-set!
        "is bound LHS — equality"
        (dl-query
          (dl-program
            "n(1, 2). n(2, 5). n(3, 4).\n             succ(X, Y) :- n(X, Y), is(Y, +(X, 1)).")
          (list (quote succ) (quote X) (quote Y)))
        (list {:X 1 :Y 2} {:X 3 :Y 4}))
      (dl-bt-test-set!
        "triple via is"
        (dl-query
          (dl-program
            "n(1). n(2). n(3).\n             triple(X, Y) :- n(X), is(Y, *(X, 3)).")
          (list (quote triple) (quote X) (quote Y)))
        (list {:X 1 :Y 3} {:X 2 :Y 6} {:X 3 :Y 9}))
      (dl-bt-test-set!
        "= unifies var with constant"
        (dl-query
          (dl-program "p(a). p(b).\n             qual(X) :- p(X), =(X, a).")
          (list (quote qual) (quote X)))
        (list {:X (quote a)}))
      (dl-bt-test-set!
        "= unifies two vars (one bound)"
        (dl-query
          (dl-program "p(a). p(b).\n             twin(X, Y) :- p(X), =(Y, X).")
          (list (quote twin) (quote X) (quote Y)))
        (list {:X (quote a) :Y (quote a)} {:X (quote b) :Y (quote b)}))
      (dl-bt-test!
        "big count"
        (let
          ((db (dl-program "n(0). n(1). n(2). n(3). n(4). n(5). n(6). n(7). n(8). n(9).\n                  big(X) :- n(X), >=(X, 5).")))
          (do (dl-saturate! db) (len (dl-relation db "big"))))
        5)
      ;; Built-in / arithmetic literals work as standalone query goals
      ;; (without needing a wrapper rule).
      (dl-bt-test-set! "comparison-only goal true"
        (dl-eval "" "?- <(1, 2).")
        (list {}))

      (dl-bt-test-set! "comparison-only goal false"
        (dl-eval "" "?- <(2, 1).")
        (list))

      (dl-bt-test-set! "is goal binds"
        (dl-eval "" "?- is(N, +(2, 3)).")
        (list {:N 5}))

      ;; Bounded successor: a recursive rule with a comparison
      ;; guard terminates because the Herbrand base is effectively
      ;; bounded.
      (dl-bt-test-set! "bounded successor"
        (dl-query
          (dl-program
            "nat(0).
             nat(Y) :- nat(X), is(Y, +(X, 1)), <(Y, 5).")
          (list (quote nat) (quote X)))
        (list {:X 0} {:X 1} {:X 2} {:X 3} {:X 4}))

      (dl-bt-test!
        "unsafe — comparison without binder"
        (dl-bt-throws? (fn () (dl-program "p(X) :- <(X, 5).")))
        true)
      (dl-bt-test!
        "unsafe — comparison both unbound"
        (dl-bt-throws? (fn () (dl-program "p(X, Y) :- <(X, Y), q(X).")))
        true)
      (dl-bt-test!
        "unsafe — is uses unbound RHS var"
        (dl-bt-throws?
          (fn () (dl-program "p(X, Y) :- q(X), is(Y, +(X, Z)).")))
        true)
      (dl-bt-test!
        "unsafe — is on its own"
        (dl-bt-throws? (fn () (dl-program "p(Y) :- is(Y, +(X, 1)).")))
        true)
      (dl-bt-test!
        "unsafe — = between two unbound"
        (dl-bt-throws? (fn () (dl-program "p(X, Y) :- =(X, Y).")))
        true)
      (dl-bt-test!
        "safe — is binds head var"
        (dl-bt-throws?
          (fn () (dl-program "n(1). p(Y) :- n(X), is(Y, +(X, 1)).")))
        false)
      (dl-bt-test!
        "safe — comparison after binder"
        (dl-bt-throws?
          (fn () (dl-program "n(1). big(X) :- n(X), >=(X, 0).")))
        false)
      (dl-bt-test!
        "safe — = binds head var"
        (dl-bt-throws?
          (fn () (dl-program "p(a). p(b). x(Y) :- p(X), =(Y, X).")))
        false)

      ;; Division by zero raises with a clear error. Without this guard
      ;; SX's `/` returned IEEE infinity, which then silently flowed
      ;; through comparisons and aggregations.
      (dl-bt-test!
        "is — division by zero raises"
        (dl-bt-throws?
          (fn ()
            (dl-eval "p(10). q(R) :- p(X), is(R, /(X, 0))." "?- q(R).")))
        true)

      ;; Comparison ops `<`, `<=`, `>`, `>=` require both operands to
      ;; have the same primitive type. Cross-type comparisons used to
      ;; silently return false (for some pairs) or raise a confusing
      ;; host-level error (for others) — now they all raise with a
      ;; message that names the offending values.
      (dl-bt-test!
        "comparison — string vs number raises"
        (dl-bt-throws?
          (fn ()
            (dl-eval "p(\"hello\"). q(X) :- p(X), <(X, 5)." "?- q(X).")))
        true)

      ;; `!=` is the exception — it's a polymorphic inequality test
      ;; (uses dl-tuple-equal? underneath) so cross-type pairs are
      ;; legitimate (and trivially unequal).
      (dl-bt-test-set! "!= works across types"
        (dl-query
          (dl-program
            "p(1). p(\"1\"). q(X) :- p(X), !=(X, 1).")
          (quote (q X)))
        (list {:X "1"})))))

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