;; lib/maude/fire.sx — short-circuiting rule/equation firing.
;;
;; The eager matcher (mau/match-multiset) enumerates EVERY substitution, which
;; is what `mau/match-all` and `search` need. But for a single rewrite step we
;; only need the FIRST usable match — and eager enumeration is exponential when
;; an AC argument has many identical elements (q ; q ; ... ; q). These
;; find-matchers thread a predicate and stop at the first complete match for
;; which it returns non-nil; the predicate builds the rewritten term and checks
;; "progresses AND condition holds", so firing short-circuits on the first
;; productive match instead of materialising the whole solution set.
;;
;; pred : subst -> result-term-or-nil   (result is always a term, never nil)

(define
  mau/try-list
  (fn
    (substs cont)
    (if
      (empty? substs)
      nil
      (let
        ((r (cont (first substs))))
        (if (= r nil) (mau/try-list (rest substs) cont) r)))))

;; ---- multiset (assoc+comm) find ----

(define
  mau/ms-find
  (fn
    (theory f pels sels s id pred)
    (cond
      ((empty? pels) (if (empty? sels) (pred s) nil))
      (else
        (let
          ((p (first pels)) (prest (rest pels)))
          (if
            (mau/var? p)
            (mau/ms-find-var
              theory
              f
              prest
              sels
              s
              (mau/vname p)
              id
              pred
              (mau/var-kmin (mau/vname p) id)
              (mau/all-splits sels))
            (mau/ms-find-nonvar theory f p prest sels s id pred 0)))))))

(define
  mau/ms-find-nonvar
  (fn
    (theory f p prest sels s id pred i)
    (if
      (>= i (len sels))
      nil
      (let
        ((others (mau/remove-at sels i)))
        (let
          ((r (mau/try-list (mau/mm theory p (nth sels i) s) (fn (s2) (mau/ms-find theory f prest others s2 id pred)))))
          (if
            (not (= r nil))
            r
            (mau/ms-find-nonvar
              theory
              f
              p
              prest
              sels
              s
              id
              pred
              (+ i 1))))))))

(define
  mau/ms-find-var
  (fn
    (theory f prest sels s name id pred kmin splits)
    (if
      (empty? splits)
      nil
      (let
        ((chosen (first (first splits)))
          (rests (nth (first splits) 1)))
        (if
          (< (len chosen) kmin)
          (mau/ms-find-var
            theory
            f
            prest
            sels
            s
            name
            id
            pred
            kmin
            (rest splits))
          (let
            ((s2 (mau/bind-check theory s name (mau/rebuild f chosen id))))
            (let
              ((r (if (= s2 nil) nil (mau/ms-find theory f prest rests s2 id pred))))
              (if
                (not (= r nil))
                r
                (mau/ms-find-var
                  theory
                  f
                  prest
                  sels
                  s
                  name
                  id
                  pred
                  kmin
                  (rest splits))))))))))

;; ---- sequence (assoc, ordered) find ----

(define
  mau/seq-find
  (fn
    (theory f pels sels s id pred)
    (cond
      ((empty? pels) (if (empty? sels) (pred s) nil))
      (else
        (let
          ((p (first pels)) (prest (rest pels)))
          (if
            (mau/var? p)
            (mau/seq-find-var
              theory
              f
              prest
              sels
              s
              (mau/vname p)
              id
              pred
              (mau/var-kmin (mau/vname p) id))
            (if
              (empty? sels)
              nil
              (mau/try-list
                (mau/mm theory p (first sels) s)
                (fn
                  (s2)
                  (mau/seq-find theory f prest (rest sels) s2 id pred))))))))))

(define
  mau/seq-find-var
  (fn
    (theory f prest sels s name id pred k)
    (if
      (> k (len sels))
      nil
      (let
        ((s2 (mau/bind-check theory s name (mau/rebuild f (mau/take sels k) id))))
        (let
          ((r (if (= s2 nil) nil (mau/seq-find theory f prest (mau/drop sels k) s2 id pred))))
          (if
            (not (= r nil))
            r
            (mau/seq-find-var
              theory
              f
              prest
              sels
              s
              name
              id
              pred
              (+ k 1))))))))

;; ---- firing an equation/rule (returns rewritten term or nil) ----

(define
  mau/fire-plain
  (fn
    (theory eqs eq term cnd substs)
    (if
      (empty? substs)
      nil
      (let
        ((res (mau/subst-apply (first substs) (get eq :rhs))))
        (if
          (and
            (not (mau/ac-equal? theory res term))
            (mau/cond-holds? theory eqs cnd (first substs)))
          res
          (mau/fire-plain theory eqs eq term cnd (rest substs)))))))

(define
  mau/fire-ac
  (fn
    (theory eqs f th eq term cnd)
    (let
      ((id (get th :id))
        (pels (mau/flatten-op theory f (get eq :lhs)))
        (sels (mau/flatten-op theory f term)))
      (let
        ((pred (fn (s) (let ((res (mau/ac-eq-result theory f th eq s))) (if (and (not (mau/ac-equal? theory res term)) (mau/cond-holds? theory eqs cnd s)) res nil)))))
        (if
          (get th :comm)
          (mau/ms-find
            theory
            f
            (mau/append2 pels (list (mau/var "$R" "")))
            sels
            {}
            id
            pred)
          (mau/seq-find
            theory
            f
            (mau/append2
              (list (mau/var "$L" ""))
              (mau/append2 pels (list (mau/var "$R" ""))))
            sels
            {}
            id
            pred))))))

(define
  mau/fire-eq
  (fn
    (theory eqs eq term)
    (let
      ((lhs (get eq :lhs)) (cnd (get eq :cond)))
      (if
        (mau/app? lhs)
        (let
          ((th (mau/th-of theory (mau/op lhs))))
          (if
            (get th :assoc)
            (mau/fire-ac theory eqs (mau/op lhs) th eq term cnd)
            (mau/fire-plain
              theory
              eqs
              eq
              term
              cnd
              (mau/mm theory lhs term {}))))
        (mau/fire-plain
          theory
          eqs
          eq
          term
          cnd
          (mau/mm theory lhs term {}))))))