rose-ash/lib/prolog/tests/operators.sx

;; lib/prolog/tests/operators.sx — operator-table parsing + comparison built-ins.

(define pl-op-test-count 0)
(define pl-op-test-pass 0)
(define pl-op-test-fail 0)
(define pl-op-test-failures (list))

(define
  pl-op-test!
  (fn
    (name got expected)
    (begin
      (set! pl-op-test-count (+ pl-op-test-count 1))
      (if
        (= got expected)
        (set! pl-op-test-pass (+ pl-op-test-pass 1))
        (begin
          (set! pl-op-test-fail (+ pl-op-test-fail 1))
          (append!
            pl-op-test-failures
            (str name "\n    expected: " expected "\n    got:      " got)))))))

(define pl-op-empty-db (pl-mk-db))

(define
  pl-op-body
  (fn (src) (nth (first (pl-parse (str "g :- " src "."))) 2)))

(define pl-op-goal (fn (src env) (pl-instantiate (pl-op-body src) env)))

;; ── parsing tests ──

(pl-op-test!
  "infix +"
  (pl-op-body "a + b")
  (list "compound" "+" (list (list "atom" "a") (list "atom" "b"))))

(pl-op-test!
  "infix * tighter than +"
  (pl-op-body "a + b * c")
  (list
    "compound"
    "+"
    (list
      (list "atom" "a")
      (list "compound" "*" (list (list "atom" "b") (list "atom" "c"))))))

(pl-op-test!
  "parens override precedence"
  (pl-op-body "(a + b) * c")
  (list
    "compound"
    "*"
    (list
      (list "compound" "+" (list (list "atom" "a") (list "atom" "b")))
      (list "atom" "c"))))

(pl-op-test!
  "+ is yfx (left-assoc)"
  (pl-op-body "a + b + c")
  (list
    "compound"
    "+"
    (list
      (list "compound" "+" (list (list "atom" "a") (list "atom" "b")))
      (list "atom" "c"))))

(pl-op-test!
  "; is xfy (right-assoc)"
  (pl-op-body "a ; b ; c")
  (list
    "compound"
    ";"
    (list
      (list "atom" "a")
      (list "compound" ";" (list (list "atom" "b") (list "atom" "c"))))))

(pl-op-test!
  "= folds at 700"
  (pl-op-body "X = 5")
  (list "compound" "=" (list (list "var" "X") (list "num" 5))))

(pl-op-test!
  "is + nests via 700>500>400"
  (pl-op-body "X is 2 + 3 * 4")
  (list
    "compound"
    "is"
    (list
      (list "var" "X")
      (list
        "compound"
        "+"
        (list
          (list "num" 2)
          (list "compound" "*" (list (list "num" 3) (list "num" 4))))))))

(pl-op-test!
  "< parses at 700"
  (pl-op-body "2 < 3")
  (list "compound" "<" (list (list "num" 2) (list "num" 3))))

(pl-op-test!
  "mod parses as yfx 400"
  (pl-op-body "10 mod 3")
  (list "compound" "mod" (list (list "num" 10) (list "num" 3))))

(pl-op-test!
  "comma in body folds right-assoc"
  (pl-op-body "a, b, c")
  (list
    "compound"
    ","
    (list
      (list "atom" "a")
      (list "compound" "," (list (list "atom" "b") (list "atom" "c"))))))

;; ── solver tests via infix ──

(pl-op-test!
  "X is 2 + 3 binds X = 5"
  (let
    ((env {}) (trail (pl-mk-trail)))
    (begin
      (pl-solve-once! pl-op-empty-db (pl-op-goal "X is 2 + 3" env) trail)
      (pl-num-val (pl-walk-deep (dict-get env "X")))))
  5)

(pl-op-test!
  "infix conjunction parses + solves"
  (pl-solve-once!
    pl-op-empty-db
    (pl-op-goal "X = 5, X = 5" {})
    (pl-mk-trail))
  true)

(pl-op-test!
  "infix mismatch fails"
  (pl-solve-once!
    pl-op-empty-db
    (pl-op-goal "X = 5, X = 6" {})
    (pl-mk-trail))
  false)

(pl-op-test!
  "infix disjunction picks left"
  (pl-solve-once!
    pl-op-empty-db
    (pl-op-goal "true ; fail" {})
    (pl-mk-trail))
  true)

(pl-op-test!
  "2 < 5 succeeds"
  (pl-solve-once!
    pl-op-empty-db
    (pl-op-goal "2 < 5" {})
    (pl-mk-trail))
  true)

(pl-op-test!
  "5 < 2 fails"
  (pl-solve-once!
    pl-op-empty-db
    (pl-op-goal "5 < 2" {})
    (pl-mk-trail))
  false)

(pl-op-test!
  "5 >= 5 succeeds"
  (pl-solve-once!
    pl-op-empty-db
    (pl-op-goal "5 >= 5" {})
    (pl-mk-trail))
  true)

(pl-op-test!
  "3 =< 5 succeeds"
  (pl-solve-once!
    pl-op-empty-db
    (pl-op-goal "3 =< 5" {})
    (pl-mk-trail))
  true)

(pl-op-test!
  "infix < with arithmetic both sides"
  (pl-solve-once!
    pl-op-empty-db
    (pl-op-goal "1 + 2 < 2 * 3" {})
    (pl-mk-trail))
  true)

(define pl-operators-tests-run! (fn () {:failed pl-op-test-fail :passed pl-op-test-pass :total pl-op-test-count :failures pl-op-test-failures}))