;; 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))))