rose-ash/lib/maude/conditional.sx

;; lib/maude/conditional.sx — conditional equations (Phase 4) + owise.
;;
;; A condition-aware superset of the Phase 3 reducer. `ceq L = R if COND` fires
;; only when COND holds under the matching substitution. Conditions come from
;; the parser as:
;;   {:kind :eq :lhs L :rhs R}   — holds iff reduce(s L) =AC= reduce(s R)
;;   {:kind :bool :term T}       — holds iff reduce(s T) =AC= true
;; Condition evaluation recurses through the SAME reducer (mau/cnormalize), so
;; a ceq whose guard mentions other (possibly conditional) equations Just Works
;; — termination rests on the guard reducing on structurally smaller arguments
;; (and the global fuel guard).
;;
;; `owise` (otherwise): an equation tagged [owise] fires at a redex only when
;; NO ordinary equation applies there. crewrite-top is two-pass: ordinary
;; equations first, owise equations last.
;;
;; Single-step firing uses the short-circuiting matcher in fire.sx
;; (mau/fire-eq). The eager candidate enumeration (mau/eq-candidates) is
;; retained for `search` (rewrite.sx), which genuinely needs every successor.

(define
  mau/ac-candidates
  (fn
    (theory f th eq term)
    (let
      ((id (get th :id))
        (pels (mau/flatten-op theory f (get eq :lhs)))
        (sels (mau/flatten-op theory f term)))
      (let
        ((matches (if (get th :comm) (mau/match-multiset theory f (mau/append2 pels (list (mau/var "$R" ""))) sels {} id) (mau/match-sequence theory f (mau/append2 (list (mau/var "$L" "")) (mau/append2 pels (list (mau/var "$R" "")))) sels {} id))))
        (map (fn (s) {:s s :result (mau/ac-eq-result theory f th eq s)}) matches)))))

(define
  mau/eq-candidates
  (fn
    (theory eq term)
    (let
      ((lhs (get eq :lhs)))
      (let
        ((th (if (mau/app? lhs) (mau/th-of theory (mau/op lhs)) {:id nil :assoc false :comm false})))
        (if
          (and (mau/app? lhs) (get th :assoc))
          (mau/ac-candidates theory (mau/op lhs) th eq term)
          (map (fn (s) {:s s :result (mau/subst-apply s (get eq :rhs))}) (mau/mm theory lhs term {})))))))

(define
  mau/cond-holds?
  (fn
    (theory eqs cond s)
    (if
      (= cond nil)
      true
      (if
        (= (get cond :kind) "eq")
        (mau/ac-equal?
          theory
          (mau/cnormalize
            theory
            eqs
            (mau/subst-apply s (get cond :lhs))
            mau/reduce-fuel)
          (mau/cnormalize
            theory
            eqs
            (mau/subst-apply s (get cond :rhs))
            mau/reduce-fuel))
        (mau/ac-equal?
          theory
          (mau/cnormalize
            theory
            eqs
            (mau/subst-apply s (get cond :term))
            mau/reduce-fuel)
          (mau/const "true"))))))

(define
  mau/try-candidates
  (fn
    (theory all-eqs cond term cands)
    (if
      (empty? cands)
      nil
      (let
        ((c (first cands)))
        (if
          (and
            (not (mau/ac-equal? theory (get c :result) term))
            (mau/cond-holds? theory all-eqs cond (get c :s)))
          (get c :result)
          (mau/try-candidates theory all-eqs cond term (rest cands)))))))

;; ---- owise partitioning ----

(define mau/eq-owise? (fn (e) (= (get e :owise) true)))
(define mau/filter-owise (fn (eqs) (filter mau/eq-owise? eqs)))
(define
  mau/filter-noowise
  (fn (eqs) (filter (fn (e) (not (mau/eq-owise? e))) eqs)))

(define
  mau/crewrite-loop
  (fn
    (theory all-eqs eqs term)
    (if
      (empty? eqs)
      nil
      (let
        ((r (mau/fire-eq theory all-eqs (first eqs) term)))
        (if (= r nil) (mau/crewrite-loop theory all-eqs (rest eqs) term) r)))))

(define
  mau/crewrite-top
  (fn
    (theory eqs term)
    (let
      ((r (mau/crewrite-loop theory eqs (mau/filter-noowise eqs) term)))
      (if
        (= r nil)
        (mau/crewrite-loop theory eqs (mau/filter-owise eqs) term)
        r))))

(define
  mau/cnormalize
  (fn
    (theory eqs term fuel)
    (if
      (<= fuel 0)
      term
      (cond
        ((mau/var? term) term)
        ((mau/app? term)
          (let
            ((nargs (map (fn (a) (mau/cnormalize theory eqs a fuel)) (mau/args term))))
            (let
              ((t2 (mau/app (mau/op term) nargs)))
              (let
                ((r (mau/crewrite-top theory eqs t2)))
                (if
                  (= r nil)
                  t2
                  (mau/cnormalize theory eqs r (- fuel 1)))))))
        (else term)))))

(define
  mau/creduce
  (fn
    (m term)
    (mau/cnormalize
      (mau/build-theory m)
      (mau/module-eqs m)
      term
      mau/reduce-fuel)))

(define
  mau/creduce-term
  (fn (m src) (mau/creduce m (mau/parse-term-in m src))))

(define
  mau/creduce->str
  (fn (m src) (mau/term->str (mau/creduce-term m src))))

(define
  mau/ccanon
  (fn (m src) (mau/canon (mau/build-theory m) (mau/creduce-term m src))))