;; lib/maude/tests/meta.sx — Phase 7: reflection (META-LEVEL).

(define mmtt-pass 0)
(define mmtt-fail 0)
(define mmtt-failures (list))

(define
  mmtt-check!
  (fn
    (name got expected)
    (if
      (= got expected)
      (set! mmtt-pass (+ mmtt-pass 1))
      (do
        (set! mmtt-fail (+ mmtt-fail 1))
        (append!
          mmtt-failures
          (str name "  expected: " expected "  got: " got))))))

(define
  mmtt-peano
  (mau/parse-module
    "fmod PEANO is\n  sort Nat .\n  op 0 : -> Nat .\n  op s_ : Nat -> Nat .\n  op _+_ : Nat Nat -> Nat [assoc comm] .\n  vars X Y : Nat .\n  eq 0 + Y = Y .\n  eq s X + Y = s (X + Y) .\nendfm"))

(define
  mmtt-ndet
  (mau/parse-module
    "mod NDET is\n  sort S .\n  ops a b c : -> S .\n  rl [r1] : a => b .\n  rl [r2] : b => c .\nendm"))

;; ---- terms-as-data: up / down ----

(mmtt-check!
  "up-const"
  (mau/term->str (mau/meta-up mmtt-peano "0"))
  "mt-app(0)")
(mmtt-check!
  "up-s0"
  (mau/term->str (mau/meta-up mmtt-peano "s 0"))
  "mt-app(s_, mt-app(0))")
(mmtt-check!
  "up-var"
  (mau/term->str (mau/up-term (mau/var "X" "Nat")))
  "mt-var(X, Nat)")
(mmtt-check!
  "up-plus"
  (mau/term->str (mau/meta-up mmtt-peano "s 0 + 0"))
  "mt-app(_+_, mt-app(s_, mt-app(0)), mt-app(0))")

;; round trip: down(up(t)) = t
(mmtt-check!
  "roundtrip-const"
  (mau/term=?
    (mau/down-term (mau/meta-up mmtt-peano "0"))
    (mau/parse-term-in mmtt-peano "0"))
  true)
(mmtt-check!
  "roundtrip-nested"
  (mau/term=?
    (mau/down-term (mau/meta-up mmtt-peano "s (s 0 + 0)"))
    (mau/parse-term-in mmtt-peano "s (s 0 + 0)"))
  true)
(mmtt-check!
  "roundtrip-var"
  (mau/term=?
    (mau/down-term (mau/up-term (mau/var "X" "Nat")))
    (mau/var "X" "Nat"))
  true)

;; ---- reflective metaReduce ----

(mmtt-check!
  "meta-reduce"
  (mau/term->str (mau/meta-reduce-src mmtt-peano "s 0 + s s 0"))
  "s_(s_(s_(0)))")
;; metaReduce returns a REPRESENTED result (a meta-term)
(mmtt-check!
  "meta-reduce-is-meta"
  (=
    (mau/op (mau/meta-reduce mmtt-peano (mau/meta-up mmtt-peano "s 0 + 0")))
    "mt-app")
  true)

;; ---- meta-circular law: down(metaReduce(up t)) =AC= reduce t ----

(mmtt-check!
  "meta-circular-1"
  (mau/meta-circular? mmtt-peano "s 0 + s s 0")
  true)
(mmtt-check!
  "meta-circular-2"
  (mau/meta-circular? mmtt-peano "s (s 0 + s 0)")
  true)
(mmtt-check!
  "meta-reduce-eq-up"
  (mau/term=?
    (mau/meta-reduce mmtt-peano (mau/meta-up mmtt-peano "s 0 + s 0"))
    (mau/up-term (mau/creduce-term mmtt-peano "s 0 + s 0")))
  true)

;; ---- metaApply: reflect a single rule step ----

(mmtt-check!
  "meta-apply-r1"
  (mau/term=?
    (mau/down-term
      (mau/meta-apply mmtt-ndet "r1" (mau/meta-up mmtt-ndet "a")))
    (mau/parse-term-in mmtt-ndet "b"))
  true)
(mmtt-check!
  "meta-apply-fail"
  (mau/meta-apply mmtt-ndet "r2" (mau/meta-up mmtt-ndet "a"))
  nil)

;; ---- generic theorem helper: equational proof by reduction ----

;; commutativity instance: 1 + 2 and 2 + 1 reduce to the same normal form.
(mmtt-check!
  "prove-comm-instance"
  (mau/meta-prove-equal? mmtt-peano "s 0 + s s 0" "s s 0 + s 0")
  true)
;; associativity instance
(mmtt-check!
  "prove-assoc-instance"
  (mau/meta-prove-equal? mmtt-peano "(s 0 + s 0) + s 0" "s 0 + (s 0 + s 0)")
  true)
;; a non-theorem
(mmtt-check!
  "prove-false"
  (mau/meta-prove-equal? mmtt-peano "s 0 + s 0" "s 0")
  false)

;; ---- build a program meta-level, then run it ----

;; construct the meta-representation of s(s(0)) by hand, down it, reduce.
(define
  mmtt-built
  (mau/up-term
    (mau/app "s_" (list (mau/app "s_" (list (mau/const "0")))))))
(mmtt-check!
  "built-down-reduce"
  (mau/term->str (mau/creduce mmtt-peano (mau/down-term mmtt-built)))
  "s_(s_(0))")

(define mau-meta-tests-run! (fn () {:failures mmtt-failures :total (+ mmtt-pass mmtt-fail) :passed mmtt-pass :failed mmtt-fail}))