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>
285 lines
6.9 KiB
Plaintext
285 lines
6.9 KiB
Plaintext
;; lib/maude/rewrite.sx — system modules + rewrite rules (Phase 5).
|
|
;;
|
|
;; Equations (eq/ceq) are applied to a fixpoint to NORMALISE (confluent by
|
|
;; intent). Rules (rl/crl) are TRANSITIONS: asymmetric (=>), possibly
|
|
;; nondeterministic, NOT applied to a fixpoint. Maude's `rew` interleaves
|
|
;; the two: normalise with equations, fire one rule, renormalise, repeat.
|
|
;;
|
|
;; Rule firing reuses the shared firing machinery — a rule dict carries
|
|
;; :lhs/:rhs/:cond exactly like an equation, so `mau/fire-eq` (short-circuit,
|
|
;; fire.sx) applies unchanged (matching modulo the AC theory; crl guards
|
|
;; evaluated with the equations). A rule fires only if it both progresses and
|
|
;; its condition holds.
|
|
;;
|
|
;; `mau/rewrite` follows the default strategy (top-down, leftmost-outermost,
|
|
;; first applicable rule) for one path. `mau/search` does breadth-first reach
|
|
;; over ALL one-step successors — for puzzle solvers / protocol simulators
|
|
;; where the answer is on a branch `rew` would not take.
|
|
|
|
(define mau/rew-fuel 100000)
|
|
|
|
;; ---- single-step, default strategy (first applicable, leftmost-outermost) ----
|
|
|
|
(define
|
|
mau/rules-at-top
|
|
(fn
|
|
(theory eqs rules term)
|
|
(if
|
|
(empty? rules)
|
|
nil
|
|
(let
|
|
((r (mau/fire-eq theory eqs (first rules) term)))
|
|
(if (= r nil) (mau/rules-at-top theory eqs (rest rules) term) r)))))
|
|
|
|
(define
|
|
mau/apply-rule-once
|
|
(fn
|
|
(theory eqs rules term)
|
|
(let
|
|
((top (mau/rules-at-top theory eqs rules term)))
|
|
(if
|
|
(not (= top nil))
|
|
top
|
|
(if
|
|
(mau/app? term)
|
|
(mau/apply-rule-in-args
|
|
theory
|
|
eqs
|
|
rules
|
|
(mau/op term)
|
|
(mau/args term)
|
|
(list))
|
|
nil)))))
|
|
|
|
(define
|
|
mau/apply-rule-in-args
|
|
(fn
|
|
(theory eqs rules op done todo)
|
|
(if
|
|
(empty? todo)
|
|
nil
|
|
(let
|
|
((r (mau/apply-rule-once theory eqs rules (first todo))))
|
|
(if
|
|
(= r nil)
|
|
(mau/apply-rule-in-args
|
|
theory
|
|
eqs
|
|
rules
|
|
op
|
|
(mau/append2 done (list (first todo)))
|
|
(rest todo))
|
|
(mau/app op (mau/append2 done (cons r (rest todo)))))))))
|
|
|
|
(define
|
|
mau/rewrite-steps
|
|
(fn
|
|
(theory eqs rules term steps)
|
|
(if
|
|
(<= steps 0)
|
|
(mau/cnormalize theory eqs term mau/reduce-fuel)
|
|
(let
|
|
((nf (mau/cnormalize theory eqs term mau/reduce-fuel)))
|
|
(let
|
|
((r (mau/apply-rule-once theory eqs rules nf)))
|
|
(if
|
|
(= r nil)
|
|
nf
|
|
(mau/rewrite-steps theory eqs rules r (- steps 1))))))))
|
|
|
|
(define
|
|
mau/rewrite
|
|
(fn
|
|
(m term)
|
|
(mau/rewrite-steps
|
|
(mau/build-theory m)
|
|
(mau/module-eqs m)
|
|
(mau/module-rules m)
|
|
term
|
|
mau/rew-fuel)))
|
|
|
|
(define
|
|
mau/rew
|
|
(fn
|
|
(m src n)
|
|
(mau/rewrite-steps
|
|
(mau/build-theory m)
|
|
(mau/module-eqs m)
|
|
(mau/module-rules m)
|
|
(mau/parse-term-in m src)
|
|
n)))
|
|
|
|
(define
|
|
mau/rewrite-term
|
|
(fn (m src) (mau/rewrite m (mau/parse-term-in m src))))
|
|
|
|
(define
|
|
mau/rewrite->str
|
|
(fn (m src) (mau/term->str (mau/rewrite-term m src))))
|
|
|
|
(define
|
|
mau/rewrite-canon
|
|
(fn (m src) (mau/canon (mau/build-theory m) (mau/rewrite-term m src))))
|
|
|
|
(define mau/rew->str (fn (m src n) (mau/term->str (mau/rew m src n))))
|
|
|
|
(define
|
|
mau/rew-canon
|
|
(fn (m src n) (mau/canon (mau/build-theory m) (mau/rew m src n))))
|
|
|
|
;; ---- all one-step successors (for search; eager enumeration) ----
|
|
|
|
(define
|
|
mau/cands-results
|
|
(fn
|
|
(theory eqs cond term cands)
|
|
(mau/concat-map
|
|
(fn
|
|
(c)
|
|
(if
|
|
(and
|
|
(not (mau/ac-equal? theory (get c :result) term))
|
|
(mau/cond-holds? theory eqs cond (get c :s)))
|
|
(list (mau/cnormalize theory eqs (get c :result) mau/reduce-fuel))
|
|
(list)))
|
|
cands)))
|
|
|
|
(define
|
|
mau/top-successors
|
|
(fn
|
|
(theory eqs rules term)
|
|
(mau/concat-map
|
|
(fn
|
|
(rule)
|
|
(mau/cands-results
|
|
theory
|
|
eqs
|
|
(get rule :cond)
|
|
term
|
|
(mau/eq-candidates theory rule term)))
|
|
rules)))
|
|
|
|
(define
|
|
mau/arg-successors
|
|
(fn
|
|
(theory eqs rules op done todo)
|
|
(if
|
|
(empty? todo)
|
|
(list)
|
|
(mau/append2
|
|
(map
|
|
(fn
|
|
(sub)
|
|
(mau/app op (mau/append2 done (cons sub (rest todo)))))
|
|
(mau/all-successors theory eqs rules (first todo)))
|
|
(mau/arg-successors
|
|
theory
|
|
eqs
|
|
rules
|
|
op
|
|
(mau/append2 done (list (first todo)))
|
|
(rest todo))))))
|
|
|
|
(define
|
|
mau/all-successors
|
|
(fn
|
|
(theory eqs rules term)
|
|
(mau/append2
|
|
(mau/top-successors theory eqs rules term)
|
|
(if
|
|
(mau/app? term)
|
|
(mau/arg-successors
|
|
theory
|
|
eqs
|
|
rules
|
|
(mau/op term)
|
|
(mau/args term)
|
|
(list))
|
|
(list)))))
|
|
|
|
(define
|
|
mau/successors
|
|
(fn
|
|
(m src)
|
|
(let
|
|
((theory (mau/build-theory m)) (eqs (mau/module-eqs m)))
|
|
(map
|
|
(fn (t) (mau/canon theory t))
|
|
(mau/all-successors
|
|
theory
|
|
eqs
|
|
(mau/module-rules m)
|
|
(mau/cnormalize
|
|
theory
|
|
eqs
|
|
(mau/parse-term-in m src)
|
|
mau/reduce-fuel))))))
|
|
|
|
;; ---- breadth-first reachability search ----
|
|
|
|
(define
|
|
mau/canon-list
|
|
(fn (theory ts) (map (fn (t) (mau/canon theory t)) ts)))
|
|
|
|
(define
|
|
mau/bfs-search
|
|
(fn
|
|
(theory eqs rules frontier seen goal depth)
|
|
(cond
|
|
((mau/member? goal (mau/canon-list theory frontier)) true)
|
|
((<= depth 0) false)
|
|
((empty? frontier) false)
|
|
(else
|
|
(let
|
|
((newf (list)) (newseen seen))
|
|
(for-each
|
|
(fn
|
|
(t)
|
|
(for-each
|
|
(fn
|
|
(succ)
|
|
(let
|
|
((c (mau/canon theory succ)))
|
|
(when
|
|
(not (mau/member? c newseen))
|
|
(do
|
|
(set! newseen (cons c newseen))
|
|
(append! newf succ)))))
|
|
(mau/all-successors theory eqs rules t)))
|
|
frontier)
|
|
(mau/bfs-search
|
|
theory
|
|
eqs
|
|
rules
|
|
newf
|
|
newseen
|
|
goal
|
|
(- depth 1)))))))
|
|
|
|
(define
|
|
mau/search
|
|
(fn
|
|
(m start-src goal-src max-depth)
|
|
(let
|
|
((theory (mau/build-theory m))
|
|
(eqs (mau/module-eqs m))
|
|
(rules (mau/module-rules m)))
|
|
(let
|
|
((start (mau/cnormalize theory eqs (mau/parse-term-in m start-src) mau/reduce-fuel))
|
|
(goal
|
|
(mau/canon
|
|
theory
|
|
(mau/cnormalize
|
|
theory
|
|
eqs
|
|
(mau/parse-term-in m goal-src)
|
|
mau/reduce-fuel))))
|
|
(mau/bfs-search
|
|
theory
|
|
eqs
|
|
rules
|
|
(list start)
|
|
(list (mau/canon theory start))
|
|
goal
|
|
max-depth)))))
|