giles
10906d4ffc
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 36s
lib/maude/reduce.sx — one-sided syntactic matching (non-linear patterns via bound-var equality), immutable substitutions, innermost fixpoint normalisation. Tested on Peano arithmetic, list ops, a propositional logic simplifier, and non-linear matching. Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
144 lines
3.5 KiB
Plaintext
144 lines
3.5 KiB
Plaintext
;; lib/maude/reduce.sx — syntactic equational reduction (Phase 2).
|
|
;;
|
|
;; Apply unconditional equations left-to-right to a fixpoint, using strict
|
|
;; one-sided syntactic matching (no theories yet — assoc/comm/id come in
|
|
;; Phase 3). Reduction is innermost: arguments are normalised before the
|
|
;; enclosing operator is rewritten.
|
|
;;
|
|
;; A substitution is a dict VAR-NAME -> term, extended immutably via `assoc`.
|
|
;; Matching is one-sided: only the pattern (equation LHS) carries variables;
|
|
;; the subject is treated structurally.
|
|
|
|
;; ---------- matching ----------
|
|
|
|
(define
|
|
mau/match
|
|
(fn
|
|
(pat subj s)
|
|
(cond
|
|
((= s nil) nil)
|
|
((mau/var? pat)
|
|
(let
|
|
((bound (get s (mau/vname pat))))
|
|
(if
|
|
(= bound nil)
|
|
(assoc s (mau/vname pat) subj)
|
|
(if (mau/term=? bound subj) s nil))))
|
|
((and (mau/app? pat) (mau/app? subj))
|
|
(if
|
|
(and
|
|
(= (mau/op pat) (mau/op subj))
|
|
(= (mau/arity pat) (mau/arity subj)))
|
|
(mau/match-args (mau/args pat) (mau/args subj) s)
|
|
nil))
|
|
(else nil))))
|
|
|
|
(define
|
|
mau/match-args
|
|
(fn
|
|
(ps ss s)
|
|
(cond
|
|
((= s nil) nil)
|
|
((and (empty? ps) (empty? ss)) s)
|
|
((or (empty? ps) (empty? ss)) nil)
|
|
(else
|
|
(mau/match-args
|
|
(rest ps)
|
|
(rest ss)
|
|
(mau/match (first ps) (first ss) s))))))
|
|
|
|
;; ---------- substitution application ----------
|
|
|
|
(define
|
|
mau/subst-apply-list
|
|
(fn
|
|
(s args)
|
|
(if
|
|
(empty? args)
|
|
(list)
|
|
(cons
|
|
(mau/subst-apply s (first args))
|
|
(mau/subst-apply-list s (rest args))))))
|
|
|
|
(define
|
|
mau/subst-apply
|
|
(fn
|
|
(s term)
|
|
(cond
|
|
((mau/var? term)
|
|
(let ((b (get s (mau/vname term)))) (if (= b nil) term b)))
|
|
((mau/app? term)
|
|
(mau/app (mau/op term) (mau/subst-apply-list s (mau/args term))))
|
|
(else term))))
|
|
|
|
;; ---------- top-level rewrite ----------
|
|
|
|
;; Try each unconditional equation in order; on the first whose LHS matches
|
|
;; the term, return the instantiated RHS. nil if none apply.
|
|
(define
|
|
mau/rewrite-top
|
|
(fn
|
|
(eqs term)
|
|
(cond
|
|
((empty? eqs) nil)
|
|
(else
|
|
(let
|
|
((eq (first eqs)))
|
|
(if
|
|
(= (get eq :cond) nil)
|
|
(let
|
|
((s (mau/match (get eq :lhs) term {})))
|
|
(if
|
|
(= s nil)
|
|
(mau/rewrite-top (rest eqs) term)
|
|
(mau/subst-apply s (get eq :rhs))))
|
|
(mau/rewrite-top (rest eqs) term)))))))
|
|
|
|
;; ---------- normalisation (innermost to fixpoint) ----------
|
|
|
|
(define
|
|
mau/normalize-args
|
|
(fn
|
|
(eqs args fuel)
|
|
(if
|
|
(empty? args)
|
|
(list)
|
|
(cons
|
|
(mau/normalize eqs (first args) fuel)
|
|
(mau/normalize-args eqs (rest args) fuel)))))
|
|
|
|
(define
|
|
mau/normalize
|
|
(fn
|
|
(eqs term fuel)
|
|
(if
|
|
(<= fuel 0)
|
|
term
|
|
(cond
|
|
((mau/var? term) term)
|
|
((mau/app? term)
|
|
(let
|
|
((nargs (mau/normalize-args eqs (mau/args term) fuel)))
|
|
(let
|
|
((t2 (mau/app (mau/op term) nargs)))
|
|
(let
|
|
((r (mau/rewrite-top eqs t2)))
|
|
(if (= r nil) t2 (mau/normalize eqs r (- fuel 1)))))))
|
|
(else term)))))
|
|
|
|
;; ---------- module-level API ----------
|
|
|
|
(define mau/reduce-fuel 1000000)
|
|
|
|
(define
|
|
mau/reduce
|
|
(fn (m term) (mau/normalize (mau/module-eqs m) term mau/reduce-fuel)))
|
|
|
|
(define
|
|
mau/reduce-term
|
|
(fn (m src) (mau/reduce m (mau/parse-term-in m src))))
|
|
|
|
(define
|
|
mau/reduce->str
|
|
(fn (m src) (mau/term->str (mau/reduce-term m src))))
|