giles
858d35a68c
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 48s
lib/maude/rewrite.sx: rl/crl transitions interleaved with eq normalisation. mau/rewrite = default strategy (top-down, leftmost-outermost, first rule); mau/rew bounded; mau/search = BFS reachability over all successors. lib/maude/fire.sx: short-circuiting matcher (mau/fire-eq) — finds the first productive match instead of enumerating the whole solution set. Fixes the exponential blowup of AC rewriting on many identical elements (8 coins: 60s+ to <1s). Eager match-multiset kept only for match-all / search. Verified on AC coin-change, traffic light, branching search, crl clock. Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
251 lines
6.3 KiB
Plaintext
251 lines
6.3 KiB
Plaintext
;; lib/maude/fire.sx — short-circuiting rule/equation firing.
|
|
;;
|
|
;; The eager matcher (mau/match-multiset) enumerates EVERY substitution, which
|
|
;; is what `mau/match-all` and `search` need. But for a single rewrite step we
|
|
;; only need the FIRST usable match — and eager enumeration is exponential when
|
|
;; an AC argument has many identical elements (q ; q ; ... ; q). These
|
|
;; find-matchers thread a predicate and stop at the first complete match for
|
|
;; which it returns non-nil; the predicate builds the rewritten term and checks
|
|
;; "progresses AND condition holds", so firing short-circuits on the first
|
|
;; productive match instead of materialising the whole solution set.
|
|
;;
|
|
;; pred : subst -> result-term-or-nil (result is always a term, never nil)
|
|
|
|
(define
|
|
mau/try-list
|
|
(fn
|
|
(substs cont)
|
|
(if
|
|
(empty? substs)
|
|
nil
|
|
(let
|
|
((r (cont (first substs))))
|
|
(if (= r nil) (mau/try-list (rest substs) cont) r)))))
|
|
|
|
;; ---- multiset (assoc+comm) find ----
|
|
|
|
(define
|
|
mau/ms-find
|
|
(fn
|
|
(theory f pels sels s id pred)
|
|
(cond
|
|
((empty? pels) (if (empty? sels) (pred s) nil))
|
|
(else
|
|
(let
|
|
((p (first pels)) (prest (rest pels)))
|
|
(if
|
|
(mau/var? p)
|
|
(mau/ms-find-var
|
|
theory
|
|
f
|
|
prest
|
|
sels
|
|
s
|
|
(mau/vname p)
|
|
id
|
|
pred
|
|
(mau/var-kmin (mau/vname p) id)
|
|
(mau/all-splits sels))
|
|
(mau/ms-find-nonvar theory f p prest sels s id pred 0)))))))
|
|
|
|
(define
|
|
mau/ms-find-nonvar
|
|
(fn
|
|
(theory f p prest sels s id pred i)
|
|
(if
|
|
(>= i (len sels))
|
|
nil
|
|
(let
|
|
((others (mau/remove-at sels i)))
|
|
(let
|
|
((r (mau/try-list (mau/mm theory p (nth sels i) s) (fn (s2) (mau/ms-find theory f prest others s2 id pred)))))
|
|
(if
|
|
(not (= r nil))
|
|
r
|
|
(mau/ms-find-nonvar
|
|
theory
|
|
f
|
|
p
|
|
prest
|
|
sels
|
|
s
|
|
id
|
|
pred
|
|
(+ i 1))))))))
|
|
|
|
(define
|
|
mau/ms-find-var
|
|
(fn
|
|
(theory f prest sels s name id pred kmin splits)
|
|
(if
|
|
(empty? splits)
|
|
nil
|
|
(let
|
|
((chosen (first (first splits)))
|
|
(rests (nth (first splits) 1)))
|
|
(if
|
|
(< (len chosen) kmin)
|
|
(mau/ms-find-var
|
|
theory
|
|
f
|
|
prest
|
|
sels
|
|
s
|
|
name
|
|
id
|
|
pred
|
|
kmin
|
|
(rest splits))
|
|
(let
|
|
((s2 (mau/bind-check theory s name (mau/rebuild f chosen id))))
|
|
(let
|
|
((r (if (= s2 nil) nil (mau/ms-find theory f prest rests s2 id pred))))
|
|
(if
|
|
(not (= r nil))
|
|
r
|
|
(mau/ms-find-var
|
|
theory
|
|
f
|
|
prest
|
|
sels
|
|
s
|
|
name
|
|
id
|
|
pred
|
|
kmin
|
|
(rest splits))))))))))
|
|
|
|
;; ---- sequence (assoc, ordered) find ----
|
|
|
|
(define
|
|
mau/seq-find
|
|
(fn
|
|
(theory f pels sels s id pred)
|
|
(cond
|
|
((empty? pels) (if (empty? sels) (pred s) nil))
|
|
(else
|
|
(let
|
|
((p (first pels)) (prest (rest pels)))
|
|
(if
|
|
(mau/var? p)
|
|
(mau/seq-find-var
|
|
theory
|
|
f
|
|
prest
|
|
sels
|
|
s
|
|
(mau/vname p)
|
|
id
|
|
pred
|
|
(mau/var-kmin (mau/vname p) id))
|
|
(if
|
|
(empty? sels)
|
|
nil
|
|
(mau/try-list
|
|
(mau/mm theory p (first sels) s)
|
|
(fn
|
|
(s2)
|
|
(mau/seq-find theory f prest (rest sels) s2 id pred))))))))))
|
|
|
|
(define
|
|
mau/seq-find-var
|
|
(fn
|
|
(theory f prest sels s name id pred k)
|
|
(if
|
|
(> k (len sels))
|
|
nil
|
|
(let
|
|
((s2 (mau/bind-check theory s name (mau/rebuild f (mau/take sels k) id))))
|
|
(let
|
|
((r (if (= s2 nil) nil (mau/seq-find theory f prest (mau/drop sels k) s2 id pred))))
|
|
(if
|
|
(not (= r nil))
|
|
r
|
|
(mau/seq-find-var
|
|
theory
|
|
f
|
|
prest
|
|
sels
|
|
s
|
|
name
|
|
id
|
|
pred
|
|
(+ k 1))))))))
|
|
|
|
;; ---- firing an equation/rule (returns rewritten term or nil) ----
|
|
|
|
(define
|
|
mau/fire-plain
|
|
(fn
|
|
(theory eqs eq term cnd substs)
|
|
(if
|
|
(empty? substs)
|
|
nil
|
|
(let
|
|
((res (mau/subst-apply (first substs) (get eq :rhs))))
|
|
(if
|
|
(and
|
|
(not (mau/ac-equal? theory res term))
|
|
(mau/cond-holds? theory eqs cnd (first substs)))
|
|
res
|
|
(mau/fire-plain theory eqs eq term cnd (rest substs)))))))
|
|
|
|
(define
|
|
mau/fire-ac
|
|
(fn
|
|
(theory eqs f th eq term cnd)
|
|
(let
|
|
((id (get th :id))
|
|
(pels (mau/flatten-op theory f (get eq :lhs)))
|
|
(sels (mau/flatten-op theory f term)))
|
|
(let
|
|
((pred (fn (s) (let ((res (mau/ac-eq-result theory f th eq s))) (if (and (not (mau/ac-equal? theory res term)) (mau/cond-holds? theory eqs cnd s)) res nil)))))
|
|
(if
|
|
(get th :comm)
|
|
(mau/ms-find
|
|
theory
|
|
f
|
|
(mau/append2 pels (list (mau/var "$R" "")))
|
|
sels
|
|
{}
|
|
id
|
|
pred)
|
|
(mau/seq-find
|
|
theory
|
|
f
|
|
(mau/append2
|
|
(list (mau/var "$L" ""))
|
|
(mau/append2 pels (list (mau/var "$R" ""))))
|
|
sels
|
|
{}
|
|
id
|
|
pred))))))
|
|
|
|
(define
|
|
mau/fire-eq
|
|
(fn
|
|
(theory eqs eq term)
|
|
(let
|
|
((lhs (get eq :lhs)) (cnd (get eq :cond)))
|
|
(if
|
|
(mau/app? lhs)
|
|
(let
|
|
((th (mau/th-of theory (mau/op lhs))))
|
|
(if
|
|
(get th :assoc)
|
|
(mau/fire-ac theory eqs (mau/op lhs) th eq term cnd)
|
|
(mau/fire-plain
|
|
theory
|
|
eqs
|
|
eq
|
|
term
|
|
cnd
|
|
(mau/mm theory lhs term {}))))
|
|
(mau/fire-plain
|
|
theory
|
|
eqs
|
|
eq
|
|
term
|
|
cnd
|
|
(mau/mm theory lhs term {}))))))
|