rose-ash/lib/maude/tests/matching.sx

;; lib/maude/tests/matching.sx — Phase 3: matching modulo assoc/comm/id.

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

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

;; ---- multi-valued matching enumeration ----

(define
  mmt-acg
  (mau/parse-module
    "fmod ACG is\n  sort S .\n  op a : -> S .\n  op b : -> S .\n  op c : -> S .\n  op _+_ : S S -> S [assoc comm] .\n  op _._ : S S -> S [assoc] .\n  vars X Y : S .\nendfm"))

;; X + Y against a + b + c (AC, no id): 6 solutions (each non-empty 2-split).
(mmt-check!
  "ac-match-count"
  (len
    (mau/match-all
      mmt-acg
      (mau/parse-term-in mmt-acg "X + Y")
      (mau/parse-term-in mmt-acg "a + b + c")))
  6)
;; X + a against a + b + c: X must be b + c (one solution, multiset).
(mmt-check!
  "ac-match-partial"
  (len
    (mau/match-all
      mmt-acg
      (mau/parse-term-in mmt-acg "X + a")
      (mau/parse-term-in mmt-acg "a + b + c")))
  1)
;; assoc-only X . Y against a . b . c: ordered 2-splits -> 2 solutions.
(mmt-check!
  "assoc-match-count"
  (len
    (mau/match-all
      mmt-acg
      (mau/parse-term-in mmt-acg "X . Y")
      (mau/parse-term-in mmt-acg "a . b . c")))
  2)
;; no match: a + a pattern against a + b
(mmt-check!
  "ac-no-match"
  (len
    (mau/match-all
      mmt-acg
      (mau/parse-term-in mmt-acg "a + a")
      (mau/parse-term-in mmt-acg "a + b")))
  0)

;; ---- comm (non-assoc) matching ----

(define
  mmt-pair
  (mau/parse-module
    "fmod PAIR is\n  sort S .\n  op a : -> S .\n  op b : -> S .\n  op p : S S -> S [comm] .\n  op fst : S -> S .\n  vars X Y : S .\n  eq fst(p(X, a)) = X .\nendfm"))

(mmt-check!
  "comm-both-orders"
  (mau/ac-reduce->str mmt-pair "fst(p(b, a))")
  "b")
(mmt-check! "comm-swapped" (mau/ac-reduce->str mmt-pair "fst(p(a, b))") "b")

;; ---- identity ----

(define
  mmt-id
  (mau/parse-module
    "fmod IDMOD is\n  sort S .\n  op a : -> S .\n  op b : -> S .\n  op e : -> S .\n  op _*_ : S S -> S [assoc comm id: e] .\n  vars X Y : S .\nendfm"))

(mmt-check! "id-drop" (mau/ac-canon mmt-id "a * e") "a")
(mmt-check! "id-drop-mid" (mau/ac-canon mmt-id "a * e * b") "_*_(a,b)")
(mmt-check! "id-only" (mau/ac-canon mmt-id "e * e") "e")
;; with id, X * Y matching a (singleton) succeeds (one var empty)
(mmt-check!
  "id-match-singleton"
  (>
    (len
      (mau/match-all
        mmt-id
        (mau/parse-term-in mmt-id "X * Y")
        (mau/parse-term-in mmt-id "a")))
    0)
  true)

;; ---- multiset / bag rewriting ----

(define
  mmt-bag
  (mau/parse-module
    "fmod BAG is\n  sort S .\n  op a : -> S .\n  op b : -> S .\n  op c : -> S .\n  op _+_ : S S -> S [assoc comm] .\n  eq a + a = a .\nendfm"))

(mmt-check! "bag-collapse" (mau/ac-canon mmt-bag "a + b + a") "_+_(a,b)")
(mmt-check! "bag-deep" (mau/ac-canon mmt-bag "a + a + a") "a")
(mmt-check! "bag-reorder" (mau/ac-canon mmt-bag "c + a + b + a") "_+_(a,b,c)")
(mmt-check!
  "bag-flatten-assoc"
  (mau/ac-canon mmt-bag "(a + b) + (a + c)")
  "_+_(a,b,c)")

;; ---- set theory: idempotent union with empty (identity) ----

(define
  mmt-set
  (mau/parse-module
    "fmod SET is\n  sort Set .\n  op empty : -> Set .\n  op a : -> Set .\n  op b : -> Set .\n  op c : -> Set .\n  op _U_ : Set Set -> Set [assoc comm id: empty] .\n  var X : Set .\n  eq X U X = X .\nendfm"))

(mmt-check! "set-dedup" (mau/ac-canon mmt-set "a U b U a") "_U_(a,b)")
(mmt-check! "set-triple" (mau/ac-canon mmt-set "a U a U a") "a")
(mmt-check!
  "set-union"
  (mau/ac-canon mmt-set "a U b U c U a U b")
  "_U_(a,b,c)")
(mmt-check! "set-empty" (mau/ac-canon mmt-set "a U empty") "a")
(mmt-check! "set-empty-only" (mau/ac-canon mmt-set "empty U empty") "empty")

;; ---- group equations (assoc, non-comm, identity + inverse) ----

(define
  mmt-group
  (mau/parse-module
    "fmod GROUP is\n  sort G .\n  op e : -> G .\n  op a : -> G .\n  op b : -> G .\n  op _*_ : G G -> G [assoc] .\n  op i : G -> G .\n  var X : G .\n  eq e * X = X .\n  eq X * e = X .\n  eq i(X) * X = e .\n  eq X * i(X) = e .\n  eq i(e) = e .\n  eq i(i(X)) = X .\nendfm"))

(mmt-check! "group-inverse" (mau/ac-canon mmt-group "i(a) * a") "e")
(mmt-check! "group-cancel" (mau/ac-canon mmt-group "i(a) * a * b") "b")
(mmt-check! "group-cancel-mid" (mau/ac-canon mmt-group "b * i(a) * a") "b")
(mmt-check! "group-double-inv" (mau/ac-canon mmt-group "i(i(a))") "a")
(mmt-check! "group-id-left" (mau/ac-canon mmt-group "e * a") "a")
(mmt-check! "group-right-inv" (mau/ac-canon mmt-group "a * i(a) * b") "b")

;; ---- AC equality (canonical form) ----

(define mmt-th (mau/build-theory mmt-acg))

(mmt-check!
  "ac-equal-reorder"
  (mau/ac-equal?
    mmt-th
    (mau/parse-term-in mmt-acg "a + b + c")
    (mau/parse-term-in mmt-acg "c + a + b"))
  true)
(mmt-check!
  "ac-equal-renest"
  (mau/ac-equal?
    mmt-th
    (mau/parse-term-in mmt-acg "(a + b) + c")
    (mau/parse-term-in mmt-acg "a + (b + c)"))
  true)
(mmt-check!
  "ac-noncomm-order"
  (mau/ac-equal?
    mmt-th
    (mau/parse-term-in mmt-acg "a . b")
    (mau/parse-term-in mmt-acg "b . a"))
  false)

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