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

;; lib/prolog/tests/findall.sx — findall/3, bagof/3, setof/3.

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

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

(define
  pl-fb-term-to-sx
  (fn
    (t)
    (cond
      ((pl-num? t) (pl-num-val t))
      ((pl-atom? t) (pl-atom-name t))
      (true (list :complex)))))

(define
  pl-fb-list-walked
  (fn
    (w)
    (cond
      ((and (pl-atom? w) (= (pl-atom-name w) "[]")) (list))
      ((and (pl-compound? w) (= (pl-fun w) ".") (= (len (pl-args w)) 2))
        (cons
          (pl-fb-term-to-sx (first (pl-args w)))
          (pl-fb-list-walked (nth (pl-args w) 1))))
      (true (list :not-list)))))

(define pl-fb-list-to-sx (fn (t) (pl-fb-list-walked (pl-walk-deep t))))

(define
  pl-fb-goal
  (fn
    (src env)
    (pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))

(define pl-fb-prog-src "member(X, [X|_]). member(X, [_|T]) :- member(X, T).")

(define pl-fb-db (pl-mk-db))
(pl-db-load! pl-fb-db (pl-parse pl-fb-prog-src))

;; ── findall ──

(define pl-fb-env-1 {})
(pl-solve-once!
  pl-fb-db
  (pl-fb-goal "findall(X, member(X, [a, b, c]), L)" pl-fb-env-1)
  (pl-mk-trail))
(pl-fb-test!
  "findall member [a, b, c]"
  (pl-fb-list-to-sx (dict-get pl-fb-env-1 "L"))
  (list "a" "b" "c"))

(define pl-fb-env-2 {})
(pl-solve-once!
  pl-fb-db
  (pl-fb-goal "findall(X, (member(X, [1, 2, 3]), X >= 2), L)" pl-fb-env-2)
  (pl-mk-trail))
(pl-fb-test!
  "findall with comparison filter"
  (pl-fb-list-to-sx (dict-get pl-fb-env-2 "L"))
  (list 2 3))

(define pl-fb-env-3 {})
(pl-solve-once!
  pl-fb-db
  (pl-fb-goal "findall(X, fail, L)" pl-fb-env-3)
  (pl-mk-trail))
(pl-fb-test!
  "findall on fail succeeds with empty list"
  (pl-fb-list-to-sx (dict-get pl-fb-env-3 "L"))
  (list))

(pl-fb-test!
  "findall(X, fail, L) the goal succeeds"
  (pl-solve-once!
    pl-fb-db
    (pl-fb-goal "findall(X, fail, L)" {})
    (pl-mk-trail))
  true)

(define pl-fb-env-4 {})
(pl-solve-once!
  pl-fb-db
  (pl-fb-goal
    "findall(p(X, Y), (member(X, [1, 2]), member(Y, [a, b])), L)"
    pl-fb-env-4)
  (pl-mk-trail))
(pl-fb-test!
  "findall over compound template — count = 4"
  (len (pl-fb-list-to-sx (dict-get pl-fb-env-4 "L")))
  4)

;; ── bagof ──

(pl-fb-test!
  "bagof succeeds when results exist"
  (pl-solve-once!
    pl-fb-db
    (pl-fb-goal "bagof(X, member(X, [1, 2, 3]), L)" {})
    (pl-mk-trail))
  true)

(pl-fb-test!
  "bagof fails on empty"
  (pl-solve-once!
    pl-fb-db
    (pl-fb-goal "bagof(X, fail, L)" {})
    (pl-mk-trail))
  false)

(define pl-fb-env-5 {})
(pl-solve-once!
  pl-fb-db
  (pl-fb-goal "bagof(X, member(X, [c, a, b]), L)" pl-fb-env-5)
  (pl-mk-trail))
(pl-fb-test!
  "bagof preserves order"
  (pl-fb-list-to-sx (dict-get pl-fb-env-5 "L"))
  (list "c" "a" "b"))

;; ── setof ──

(define pl-fb-env-6 {})
(pl-solve-once!
  pl-fb-db
  (pl-fb-goal "setof(X, member(X, [c, a, b, a, c]), L)" pl-fb-env-6)
  (pl-mk-trail))
(pl-fb-test!
  "setof sorts + dedupes atoms"
  (pl-fb-list-to-sx (dict-get pl-fb-env-6 "L"))
  (list "a" "b" "c"))

(pl-fb-test!
  "setof fails on empty"
  (pl-solve-once!
    pl-fb-db
    (pl-fb-goal "setof(X, fail, L)" {})
    (pl-mk-trail))
  false)

(define pl-fb-env-7 {})
(pl-solve-once!
  pl-fb-db
  (pl-fb-goal "setof(X, member(X, [3, 1, 2, 1, 3]), L)" pl-fb-env-7)
  (pl-mk-trail))
(pl-fb-test!
  "setof sorts + dedupes nums"
  (pl-fb-list-to-sx (dict-get pl-fb-env-7 "L"))
  (list 1 2 3))

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