giles
2378056cb3
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 47s
The chisel. lib/maude/matching.sx: multi-valued matcher mau/mm returning ALL substitutions, dispatching on op theory (free/comm/assoc/AC). Identity lets variables grab empty blocks. AC-canonical form (mau/canon) powers ac-equal? and deterministic printout. AC rewriting extends f-AC equations with rest vars so a rule fires on any sub-multiset/subword; mau/first-change only commits rewrites that change the canonical form (idempotency/identity terminate). Verified on multiset rewriting, set theory, group equations. Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
566 lines
15 KiB
Plaintext
566 lines
15 KiB
Plaintext
;; lib/maude/matching.sx — equational matching modulo assoc/comm/id (Phase 3).
|
|
;;
|
|
;; The chisel. Syntactic matching (reduce.sx) returns at most one substitution;
|
|
;; matching modulo a theory is MULTI-VALUED — `X + Y` against `a + b + c` (with
|
|
;; _+_ assoc comm) has several solutions. `mau/mm` returns the full list of
|
|
;; substitutions; callers (rule application) pick.
|
|
;;
|
|
;; Operator theories come from the signature attributes, collected into a dict
|
|
;; OP-NAME -> {:assoc B :comm B :id ELT}. Matching dispatches on the head op's
|
|
;; theory:
|
|
;; free positional, exact arity
|
|
;; comm binary, try both argument orderings
|
|
;; assoc flatten the f-spine, match the pattern sequence against the
|
|
;; subject sequence (variables grab contiguous blocks)
|
|
;; assoc+comm flatten, match as multisets (variables grab sub-multisets)
|
|
;; Identity (id: e) lets a variable grab the empty block, contributing e.
|
|
;;
|
|
;; Equational rewriting (mau/ac-reduce) extends each f-AC equation l=r to
|
|
;; f(REST..., l) -> f(REST..., r) so a rule fires on any sub-multiset of an
|
|
;; AC term, then renormalises to a fixpoint. A candidate rewrite is taken only
|
|
;; if it changes the AC-canonical form (mau/canon) — idempotency/identity
|
|
;; matches that would re-fire forever are skipped, guaranteeing progress.
|
|
|
|
;; ---------- theory table ----------
|
|
|
|
(define
|
|
mau/build-theory
|
|
(fn
|
|
(m)
|
|
(let
|
|
((th {}))
|
|
(for-each
|
|
(fn
|
|
(op)
|
|
(let
|
|
((a (get op :attrs)))
|
|
(dict-set! th (get op :name) {:id (get a :id) :assoc (= (get a :assoc) true) :comm (= (get a :comm) true)})))
|
|
(mau/module-ops m))
|
|
th)))
|
|
|
|
(define
|
|
mau/th-of
|
|
(fn
|
|
(theory op)
|
|
(let ((e (get theory op))) (if (= e nil) {:id nil :assoc false :comm false} e))))
|
|
|
|
;; ---------- small list utilities ----------
|
|
|
|
(define
|
|
mau/concat-map
|
|
(fn
|
|
(f xs)
|
|
(if
|
|
(empty? xs)
|
|
(list)
|
|
(mau/append2 (f (first xs)) (mau/concat-map f (rest xs))))))
|
|
|
|
(define
|
|
mau/remove-at
|
|
(fn (xs i) (mau/append2 (mau/take xs i) (mau/drop xs (+ i 1)))))
|
|
|
|
;; All (chosen complement) pairs over every subset of xs.
|
|
(define
|
|
mau/all-splits
|
|
(fn
|
|
(xs)
|
|
(if
|
|
(empty? xs)
|
|
(list (list (list) (list)))
|
|
(let
|
|
((subsplits (mau/all-splits (rest xs))) (x (first xs)))
|
|
(mau/concat-map
|
|
(fn
|
|
(pair)
|
|
(let
|
|
((c (first pair)) (r (nth pair 1)))
|
|
(list (list (cons x c) r) (list c (cons x r)))))
|
|
subsplits)))))
|
|
|
|
;; ---------- flattening of associative spines ----------
|
|
|
|
(define
|
|
mau/flatten-op
|
|
(fn
|
|
(theory f term)
|
|
(if
|
|
(and (mau/app? term) (= (mau/op term) f))
|
|
(mau/flatten-op-list theory f (mau/args term))
|
|
(list term))))
|
|
|
|
(define
|
|
mau/flatten-op-list
|
|
(fn
|
|
(theory f args)
|
|
(if
|
|
(empty? args)
|
|
(list)
|
|
(mau/append2
|
|
(mau/flatten-op theory f (first args))
|
|
(mau/flatten-op-list theory f (rest args))))))
|
|
|
|
(define
|
|
mau/foldr-app
|
|
(fn
|
|
(f block)
|
|
(if
|
|
(empty? (rest block))
|
|
(first block)
|
|
(mau/app f (list (first block) (mau/foldr-app f (rest block)))))))
|
|
|
|
(define
|
|
mau/rebuild
|
|
(fn
|
|
(f block id)
|
|
(cond
|
|
((empty? block) (if (= id nil) (mau/const "$EMPTY") (mau/const id)))
|
|
((empty? (rest block)) (first block))
|
|
(else (mau/foldr-app f block)))))
|
|
|
|
(define mau/ac-build (fn (theory f els id) (mau/rebuild f els id)))
|
|
|
|
;; ---------- AC-canonical form / equality ----------
|
|
|
|
(define
|
|
mau/insert-str
|
|
(fn
|
|
(x ys)
|
|
(cond
|
|
((empty? ys) (list x))
|
|
((<= x (first ys)) (cons x ys))
|
|
(else (cons (first ys) (mau/insert-str x (rest ys)))))))
|
|
|
|
(define
|
|
mau/sort-strings
|
|
(fn
|
|
(xs)
|
|
(if
|
|
(empty? xs)
|
|
xs
|
|
(mau/insert-str (first xs) (mau/sort-strings (rest xs))))))
|
|
|
|
(define
|
|
mau/drop-identity
|
|
(fn
|
|
(theory f els id)
|
|
(if
|
|
(= id nil)
|
|
els
|
|
(let
|
|
((idc (mau/canon theory (mau/const id))))
|
|
(filter (fn (e) (not (= (mau/canon theory e) idc))) els)))))
|
|
|
|
(define
|
|
mau/canon
|
|
(fn
|
|
(theory term)
|
|
(cond
|
|
((mau/var? term) (str "?" (mau/vname term)))
|
|
((mau/const? term) (mau/op term))
|
|
((mau/app? term)
|
|
(let
|
|
((f (mau/op term)) (th (mau/th-of theory (mau/op term))))
|
|
(if
|
|
(get th :assoc)
|
|
(let
|
|
((els (mau/drop-identity theory f (mau/flatten-op theory f term) (get th :id))))
|
|
(cond
|
|
((empty? els)
|
|
(if (= (get th :id) nil) "$EMPTY" (get th :id)))
|
|
((empty? (rest els)) (mau/canon theory (first els)))
|
|
(else
|
|
(let
|
|
((cs (map (fn (e) (mau/canon theory e)) els)))
|
|
(let
|
|
((cs2 (if (get th :comm) (mau/sort-strings cs) cs)))
|
|
(str f "(" (join "," cs2) ")"))))))
|
|
(if
|
|
(get th :comm)
|
|
(str
|
|
f
|
|
"("
|
|
(join
|
|
","
|
|
(mau/sort-strings
|
|
(map (fn (e) (mau/canon theory e)) (mau/args term))))
|
|
")")
|
|
(str
|
|
f
|
|
"("
|
|
(join
|
|
","
|
|
(map (fn (e) (mau/canon theory e)) (mau/args term)))
|
|
")")))))
|
|
(else (str term)))))
|
|
|
|
(define
|
|
mau/ac-equal?
|
|
(fn (theory a b) (= (mau/canon theory a) (mau/canon theory b))))
|
|
|
|
;; ---------- variable block bounds ----------
|
|
|
|
(define
|
|
mau/rest-var?
|
|
(fn
|
|
(name)
|
|
(and
|
|
(> (len name) 0)
|
|
(= (slice name 0 1) "$"))))
|
|
|
|
(define
|
|
mau/var-kmin
|
|
(fn
|
|
(name id)
|
|
(if (or (mau/rest-var? name) (not (= id nil))) 0 1)))
|
|
|
|
(define
|
|
mau/bind-check
|
|
(fn
|
|
(theory s name val)
|
|
(let
|
|
((b (get s name)))
|
|
(if
|
|
(= b nil)
|
|
(assoc s name val)
|
|
(if (mau/ac-equal? theory b val) s nil)))))
|
|
|
|
;; ---------- core multi-valued matcher ----------
|
|
|
|
(define
|
|
mau/mm
|
|
(fn
|
|
(theory pat subj s)
|
|
(cond
|
|
((mau/var? pat)
|
|
(let
|
|
((bound (get s (mau/vname pat))))
|
|
(if
|
|
(= bound nil)
|
|
(list (assoc s (mau/vname pat) subj))
|
|
(if (mau/ac-equal? theory bound subj) (list s) (list)))))
|
|
((mau/app? pat)
|
|
(if (mau/app? subj) (mau/mm-app theory pat subj s) (list)))
|
|
(else (list)))))
|
|
|
|
(define
|
|
mau/extend-all
|
|
(fn
|
|
(theory p subj substs)
|
|
(mau/concat-map (fn (s) (mau/mm theory p subj s)) substs)))
|
|
|
|
(define
|
|
mau/mm-args
|
|
(fn
|
|
(theory ps ss substs)
|
|
(cond
|
|
((and (empty? ps) (empty? ss)) substs)
|
|
((or (empty? ps) (empty? ss)) (list))
|
|
(else
|
|
(mau/mm-args
|
|
theory
|
|
(rest ps)
|
|
(rest ss)
|
|
(mau/extend-all theory (first ps) (first ss) substs))))))
|
|
|
|
(define
|
|
mau/mm-comm
|
|
(fn
|
|
(theory pat subj s)
|
|
(let
|
|
((p1 (nth (mau/args pat) 0))
|
|
(p2 (nth (mau/args pat) 1))
|
|
(q1 (nth (mau/args subj) 0))
|
|
(q2 (nth (mau/args subj) 1)))
|
|
(mau/append2
|
|
(mau/mm-args theory (list p1 p2) (list q1 q2) (list s))
|
|
(mau/mm-args theory (list p1 p2) (list q2 q1) (list s))))))
|
|
|
|
(define
|
|
mau/mm-assoc
|
|
(fn
|
|
(theory f pat subj s)
|
|
(let
|
|
((pels (mau/flatten-op theory f pat))
|
|
(sels (mau/flatten-op theory f subj))
|
|
(th (mau/th-of theory f)))
|
|
(if
|
|
(get th :comm)
|
|
(mau/match-multiset theory f pels sels s (get th :id))
|
|
(mau/match-sequence theory f pels sels s (get th :id))))))
|
|
|
|
(define
|
|
mau/mm-app
|
|
(fn
|
|
(theory pat subj s)
|
|
(let
|
|
((f (mau/op pat))
|
|
(g (mau/op subj))
|
|
(th (mau/th-of theory (mau/op pat))))
|
|
(cond
|
|
((get th :assoc) (mau/mm-assoc theory f pat subj s))
|
|
((get th :comm)
|
|
(if
|
|
(and
|
|
(= f g)
|
|
(= (mau/arity pat) 2)
|
|
(= (mau/arity subj) 2))
|
|
(mau/mm-comm theory pat subj s)
|
|
(list)))
|
|
(else
|
|
(if
|
|
(and (= f g) (= (mau/arity pat) (mau/arity subj)))
|
|
(mau/mm-args theory (mau/args pat) (mau/args subj) (list s))
|
|
(list)))))))
|
|
|
|
;; ---------- associative (ordered) sequence matching ----------
|
|
|
|
(define
|
|
mau/match-sequence
|
|
(fn
|
|
(theory f pels sels s id)
|
|
(cond
|
|
((empty? pels) (if (empty? sels) (list s) (list)))
|
|
(else
|
|
(let
|
|
((p (first pels)) (prest (rest pels)))
|
|
(if
|
|
(mau/var? p)
|
|
(mau/seq-var-loop
|
|
theory
|
|
f
|
|
prest
|
|
sels
|
|
s
|
|
(mau/vname p)
|
|
id
|
|
(mau/var-kmin (mau/vname p) id))
|
|
(if
|
|
(empty? sels)
|
|
(list)
|
|
(mau/concat-map
|
|
(fn
|
|
(s2)
|
|
(mau/match-sequence theory f prest (rest sels) s2 id))
|
|
(mau/mm theory p (first sels) s)))))))))
|
|
|
|
(define
|
|
mau/seq-var-loop
|
|
(fn
|
|
(theory f prest sels s name id k)
|
|
(if
|
|
(> k (len sels))
|
|
(list)
|
|
(let
|
|
((block (mau/take sels k)) (rests (mau/drop sels k)))
|
|
(let
|
|
((val (mau/rebuild f block id)))
|
|
(let
|
|
((s2 (mau/bind-check theory s name val)))
|
|
(mau/append2
|
|
(if
|
|
(= s2 nil)
|
|
(list)
|
|
(mau/match-sequence theory f prest rests s2 id))
|
|
(mau/seq-var-loop
|
|
theory
|
|
f
|
|
prest
|
|
sels
|
|
s
|
|
name
|
|
id
|
|
(+ k 1)))))))))
|
|
|
|
;; ---------- associative-commutative (multiset) matching ----------
|
|
|
|
(define
|
|
mau/match-multiset
|
|
(fn
|
|
(theory f pels sels s id)
|
|
(cond
|
|
((empty? pels) (if (empty? sels) (list s) (list)))
|
|
(else
|
|
(let
|
|
((p (first pels)) (prest (rest pels)))
|
|
(if
|
|
(mau/var? p)
|
|
(mau/ms-var-splits theory f prest sels s (mau/vname p) id)
|
|
(mau/ms-nonvar-loop theory f p prest sels s id 0)))))))
|
|
|
|
(define
|
|
mau/ms-nonvar-loop
|
|
(fn
|
|
(theory f p prest sels s id i)
|
|
(if
|
|
(>= i (len sels))
|
|
(list)
|
|
(let
|
|
((elem (nth sels i)) (others (mau/remove-at sels i)))
|
|
(mau/append2
|
|
(mau/concat-map
|
|
(fn (s2) (mau/match-multiset theory f prest others s2 id))
|
|
(mau/mm theory p elem s))
|
|
(mau/ms-nonvar-loop theory f p prest sels s id (+ i 1)))))))
|
|
|
|
(define
|
|
mau/ms-var-splits
|
|
(fn
|
|
(theory f prest sels s name id)
|
|
(let
|
|
((kmin (mau/var-kmin name id)))
|
|
(mau/concat-map
|
|
(fn
|
|
(pair)
|
|
(let
|
|
((chosen (first pair)) (rests (nth pair 1)))
|
|
(if
|
|
(< (len chosen) kmin)
|
|
(list)
|
|
(let
|
|
((val (mau/rebuild f chosen id)))
|
|
(let
|
|
((s2 (mau/bind-check theory s name val)))
|
|
(if
|
|
(= s2 nil)
|
|
(list)
|
|
(mau/match-multiset theory f prest rests s2 id)))))))
|
|
(mau/all-splits sels)))))
|
|
|
|
;; ---------- public matching entry ----------
|
|
|
|
(define
|
|
mau/match-all
|
|
(fn (m pat subj) (mau/mm (mau/build-theory m) pat subj {})))
|
|
|
|
;; ---------- AC-aware equational rewriting ----------
|
|
|
|
(define
|
|
mau/restv
|
|
(fn
|
|
(theory f s name)
|
|
(let
|
|
((v (get s name)))
|
|
(cond
|
|
((= v nil) (list))
|
|
((and (mau/app? v) (= (mau/op v) "$EMPTY")) (list))
|
|
(else (mau/flatten-op theory f v))))))
|
|
|
|
(define
|
|
mau/ac-eq-result
|
|
(fn
|
|
(theory f th eq s)
|
|
(if
|
|
(get th :comm)
|
|
(mau/ac-build
|
|
theory
|
|
f
|
|
(mau/append2
|
|
(mau/flatten-op theory f (mau/subst-apply s (get eq :rhs)))
|
|
(mau/restv theory f s "$R"))
|
|
(get th :id))
|
|
(mau/ac-build
|
|
theory
|
|
f
|
|
(mau/append2
|
|
(mau/restv theory f s "$L")
|
|
(mau/append2
|
|
(mau/flatten-op theory f (mau/subst-apply s (get eq :rhs)))
|
|
(mau/restv theory f s "$R")))
|
|
(get th :id)))))
|
|
|
|
;; Walk the candidate matches and return the first rewrite that actually
|
|
;; changes the term's canonical form (skips idempotency/identity no-ops).
|
|
(define
|
|
mau/first-change
|
|
(fn
|
|
(theory f th eq term matches)
|
|
(if
|
|
(empty? matches)
|
|
nil
|
|
(let
|
|
((result (mau/ac-eq-result theory f th eq (first matches))))
|
|
(if
|
|
(mau/ac-equal? theory result term)
|
|
(mau/first-change theory f th eq term (rest matches))
|
|
result)))))
|
|
|
|
(define
|
|
mau/ac-rewrite-eq
|
|
(fn
|
|
(theory f th eq term)
|
|
(let
|
|
((id (get th :id))
|
|
(pels (mau/flatten-op theory f (get eq :lhs)))
|
|
(sels (mau/flatten-op theory f term)))
|
|
(let
|
|
((matches (if (get th :comm) (mau/match-multiset theory f (mau/append2 pels (list (mau/var "$R" ""))) sels {} id) (mau/match-sequence theory f (mau/append2 (list (mau/var "$L" "")) (mau/append2 pels (list (mau/var "$R" "")))) sels {} id))))
|
|
(mau/first-change theory f th eq term matches)))))
|
|
|
|
(define
|
|
mau/ac-rewrite-top
|
|
(fn
|
|
(theory eqs term)
|
|
(cond
|
|
((empty? eqs) nil)
|
|
(else
|
|
(let
|
|
((eq (first eqs)))
|
|
(if
|
|
(= (get eq :cond) nil)
|
|
(let
|
|
((lhs (get eq :lhs)))
|
|
(let
|
|
((th (if (mau/app? lhs) (mau/th-of theory (mau/op lhs)) {:id nil :assoc false :comm false})))
|
|
(let
|
|
((r (if (and (mau/app? lhs) (get th :assoc)) (mau/ac-rewrite-eq theory (mau/op lhs) th eq term) (let ((ss (mau/mm theory lhs term {}))) (if (empty? ss) nil (mau/subst-apply (first ss) (get eq :rhs)))))))
|
|
(cond
|
|
((= r nil) (mau/ac-rewrite-top theory (rest eqs) term))
|
|
((mau/ac-equal? theory r term)
|
|
(mau/ac-rewrite-top theory (rest eqs) term))
|
|
(else r)))))
|
|
(mau/ac-rewrite-top theory (rest eqs) term)))))))
|
|
|
|
(define
|
|
mau/ac-normalize
|
|
(fn
|
|
(theory eqs term fuel)
|
|
(if
|
|
(<= fuel 0)
|
|
term
|
|
(cond
|
|
((mau/var? term) term)
|
|
((mau/app? term)
|
|
(let
|
|
((nargs (map (fn (a) (mau/ac-normalize theory eqs a fuel)) (mau/args term))))
|
|
(let
|
|
((t2 (mau/app (mau/op term) nargs)))
|
|
(let
|
|
((r (mau/ac-rewrite-top theory eqs t2)))
|
|
(if
|
|
(= r nil)
|
|
t2
|
|
(mau/ac-normalize theory eqs r (- fuel 1)))))))
|
|
(else term)))))
|
|
|
|
(define
|
|
mau/ac-reduce
|
|
(fn
|
|
(m term)
|
|
(mau/ac-normalize
|
|
(mau/build-theory m)
|
|
(mau/module-eqs m)
|
|
term
|
|
mau/reduce-fuel)))
|
|
|
|
(define
|
|
mau/ac-reduce-term
|
|
(fn (m src) (mau/ac-reduce m (mau/parse-term-in m src))))
|
|
|
|
(define
|
|
mau/ac-reduce->str
|
|
(fn (m src) (mau/term->str (mau/ac-reduce-term m src))))
|
|
|
|
(define
|
|
mau/ac-canon
|
|
(fn (m src) (mau/canon (mau/build-theory m) (mau/ac-reduce-term m src))))
|