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