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

;; lib/prolog/tests/compiler.sx — compiled clause dispatch tests

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

(define
  pl-cmp-test!
  (fn
    (name got expected)
    (set! pl-cmp-test-count (+ pl-cmp-test-count 1))
    (if
      (= got expected)
      (set! pl-cmp-test-pass (+ pl-cmp-test-pass 1))
      (begin
        (set! pl-cmp-test-fail (+ pl-cmp-test-fail 1))
        (append! pl-cmp-test-failures name)))))

;; Load src, compile, return DB.
(define
  pl-cmp-mk
  (fn
    (src)
    (let
      ((db (pl-mk-db)))
      (pl-db-load! db (pl-parse src))
      (pl-compile-db! db)
      db)))

;; Run goal string against compiled DB; return bool (instantiates vars).
(define
  pl-cmp-once
  (fn
    (db src)
    (pl-solve-once!
      db
      (pl-instantiate (pl-parse-goal src) {})
      (pl-mk-trail))))

;; Count solutions for goal string against compiled DB.
(define
  pl-cmp-count
  (fn
    (db src)
    (pl-solve-count!
      db
      (pl-instantiate (pl-parse-goal src) {})
      (pl-mk-trail))))

;; ── 1. Simple facts ──────────────────────────────────────────────

(define pl-cmp-db1 (pl-cmp-mk "color(red). color(green). color(blue)."))

(pl-cmp-test! "compiled fact hit" (pl-cmp-once pl-cmp-db1 "color(red)") true)
(pl-cmp-test!
  "compiled fact miss"
  (pl-cmp-once pl-cmp-db1 "color(yellow)")
  false)
(pl-cmp-test! "compiled fact count" (pl-cmp-count pl-cmp-db1 "color(X)") 3)

;; ── 2. Recursive rule: append ────────────────────────────────────

(define
  pl-cmp-db2
  (pl-cmp-mk "append([], L, L). append([H|T], L, [H|R]) :- append(T, L, R)."))

(pl-cmp-test!
  "compiled append build"
  (pl-cmp-once pl-cmp-db2 "append([1,2],[3],[1,2,3])")
  true)
(pl-cmp-test!
  "compiled append fail"
  (pl-cmp-once pl-cmp-db2 "append([1,2],[3],[1,2])")
  false)
(pl-cmp-test!
  "compiled append split count"
  (pl-cmp-count pl-cmp-db2 "append(X, Y, [a,b])")
  3)

;; ── 3. Cut ───────────────────────────────────────────────────────

(define
  pl-cmp-db3
  (pl-cmp-mk "first(X, [X|_]) :- !. first(X, [_|T]) :- first(X, T)."))

(pl-cmp-test!
  "compiled cut: only one solution"
  (pl-cmp-count pl-cmp-db3 "first(X, [a,b,c])")
  1)

(let
  ((db pl-cmp-db3) (trail (pl-mk-trail)) (env {}))
  (let
    ((x (pl-mk-rt-var "X")))
    (dict-set! env "X" x)
    (pl-solve-once!
      db
      (pl-instantiate (pl-parse-goal "first(X, [a,b,c])") env)
      trail)
    (pl-cmp-test!
      "compiled cut: correct binding"
      (pl-atom-name (pl-walk x))
      "a")))

;; ── 4. member ────────────────────────────────────────────────────

(define
  pl-cmp-db4
  (pl-cmp-mk "member(X, [X|_]). member(X, [_|T]) :- member(X, T)."))

(pl-cmp-test!
  "compiled member hit"
  (pl-cmp-once pl-cmp-db4 "member(b, [a,b,c])")
  true)
(pl-cmp-test!
  "compiled member miss"
  (pl-cmp-once pl-cmp-db4 "member(d, [a,b,c])")
  false)
(pl-cmp-test!
  "compiled member count"
  (pl-cmp-count pl-cmp-db4 "member(X, [a,b,c])")
  3)

;; ── 5. Arithmetic in body ────────────────────────────────────────

(define pl-cmp-db5 (pl-cmp-mk "double(X, Y) :- Y is X * 2."))

(let
  ((db pl-cmp-db5) (trail (pl-mk-trail)) (env {}))
  (let
    ((y (pl-mk-rt-var "Y")))
    (dict-set! env "Y" y)
    (pl-solve-once!
      db
      (pl-instantiate (pl-parse-goal "double(5, Y)") env)
      trail)
    (pl-cmp-test! "compiled arithmetic in body" (pl-num-val (pl-walk y)) 10)))

;; ── 6. Transitive ancestor ───────────────────────────────────────

(define
  pl-cmp-db6
  (pl-cmp-mk
    (str
      "parent(a,b). parent(b,c). parent(c,d)."
      "ancestor(X,Y) :- parent(X,Y)."
      "ancestor(X,Y) :- parent(X,Z), ancestor(Z,Y).")))

(pl-cmp-test!
  "compiled ancestor direct"
  (pl-cmp-once pl-cmp-db6 "ancestor(a,b)")
  true)
(pl-cmp-test!
  "compiled ancestor 3-step"
  (pl-cmp-once pl-cmp-db6 "ancestor(a,d)")
  true)
(pl-cmp-test!
  "compiled ancestor fail"
  (pl-cmp-once pl-cmp-db6 "ancestor(d,a)")
  false)

;; ── 7. Fallback: uncompiled predicate calls compiled sub-predicate

(define
  pl-cmp-db7
  (let
    ((db (pl-mk-db)))
    (pl-db-load! db (pl-parse "q(1). q(2)."))
    (pl-compile-db! db)
    (pl-db-load! db (pl-parse "r(X) :- q(X)."))
    db))

(pl-cmp-test!
  "uncompiled predicate resolves"
  (pl-cmp-once pl-cmp-db7 "r(1)")
  true)
(pl-cmp-test!
  "uncompiled calls compiled sub-pred count"
  (pl-cmp-count pl-cmp-db7 "r(X)")
  2)

;; ── Runner ───────────────────────────────────────────────────────

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