rose-ash/lib/maude/strategy.sx

;; lib/maude/strategy.sx — strategy language (Phase 6).
;;
;; A strategy controls HOW rules are applied. Strategies are first-class values
;; (tagged dicts) and SET-VALUED: applying a strategy to a term yields the set
;; (deduped by canonical form) of result terms. The same rule set under
;; different strategies computes different things — `;` sequences, `|` unions,
;; `*`/`+` iterate, `!` normalises.
;;
;; Constructors:
;;   (mau/s-idle)            identity (the term itself)
;;   (mau/s-fail)            empty set
;;   (mau/s-all)             apply any rule once, anywhere
;;   (mau/s-rule LABEL)      apply a named rule once, anywhere
;;   (mau/s-seq A B)         A ; B   (apply B to every result of A)
;;   (mau/s-alt A B)         A | B   (union of results)
;;   (mau/s-star A)          A *     (reflexive-transitive closure)
;;   (mau/s-plus A)          A +     (one or more)
;;   (mau/s-bang A)          A !     (normal forms: results where A can't apply)
;;   (mau/s-name N)          look up named strategy N in the env
;;
;; Run with (mau/srun M STRATS STRAT SRC): STRATS is a dict NAME -> strategy.

(define mau/s-idle (fn () {:s :idle}))
(define mau/s-fail (fn () {:s :fail}))
(define mau/s-all (fn () {:s :all}))
(define mau/s-rule (fn (label) {:label label :s :rule}))
(define mau/s-seq (fn (a b) {:a a :b b :s :seq}))
(define mau/s-alt (fn (a b) {:a a :b b :s :alt}))
(define mau/s-star (fn (a) {:a a :s :star}))
(define mau/s-plus (fn (a) {:a a :s :plus}))
(define mau/s-bang (fn (a) {:a a :s :bang}))
(define mau/s-name (fn (n) {:n n :s :name}))

(define
  mau/rules-with-label
  (fn (rules label) (filter (fn (r) (= (get r :label) label)) rules)))

(define
  mau/dedup-loop
  (fn
    (theory ts seen acc)
    (if
      (empty? ts)
      acc
      (let
        ((c (mau/canon theory (first ts))))
        (if
          (mau/member? c seen)
          (mau/dedup-loop theory (rest ts) seen acc)
          (mau/dedup-loop
            theory
            (rest ts)
            (cons c seen)
            (mau/append2 acc (list (first ts)))))))))

(define
  mau/dedup-canon
  (fn (theory ts) (mau/dedup-loop theory ts (list) (list))))

;; ---- strategy interpreter ----

(define
  mau/sapply
  (fn
    (ctx strat term)
    (let
      ((k (get strat :s)) (theory (get ctx :theory)))
      (cond
        ((= k "idle") (list term))
        ((= k "fail") (list))
        ((= k "all")
          (mau/dedup-canon
            theory
            (mau/all-successors theory (get ctx :eqs) (get ctx :rules) term)))
        ((= k "rule")
          (mau/dedup-canon
            theory
            (mau/all-successors
              theory
              (get ctx :eqs)
              (mau/rules-with-label (get ctx :rules) (get strat :label))
              term)))
        ((= k "seq")
          (mau/dedup-canon
            theory
            (mau/concat-map
              (fn (t) (mau/sapply ctx (get strat :b) t))
              (mau/sapply ctx (get strat :a) term))))
        ((= k "alt")
          (mau/dedup-canon
            theory
            (mau/append2
              (mau/sapply ctx (get strat :a) term)
              (mau/sapply ctx (get strat :b) term))))
        ((= k "star") (mau/sstar ctx (get strat :a) term))
        ((= k "plus")
          (mau/dedup-canon
            theory
            (mau/concat-map
              (fn (t) (mau/sstar ctx (get strat :a) t))
              (mau/sapply ctx (get strat :a) term))))
        ((= k "bang")
          (mau/dedup-canon theory (mau/sbang ctx (get strat :a) term)))
        ((= k "name")
          (mau/sapply ctx (get (get ctx :strats) (get strat :n)) term))
        (else (list))))))

;; reflexive-transitive closure: term plus everything reachable via A
(define
  mau/sstar
  (fn
    (ctx a term)
    (mau/sstar-loop
      ctx
      a
      (list term)
      (list (mau/canon (get ctx :theory) term))
      (list term))))

(define
  mau/sstar-loop
  (fn
    (ctx a frontier seen acc)
    (if
      (empty? frontier)
      acc
      (let
        ((newf (list))
          (newseen seen)
          (newacc acc)
          (theory (get ctx :theory)))
        (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)
                      (append! newacc succ)))))
              (mau/sapply ctx a t)))
          frontier)
        (mau/sstar-loop ctx a newf newseen newacc)))))

;; normal forms: terms reachable via A where A yields nothing more
(define
  mau/sbang
  (fn
    (ctx a term)
    (mau/sbang-loop
      ctx
      a
      (list term)
      (list (mau/canon (get ctx :theory) term))
      (list))))

(define
  mau/sbang-loop
  (fn
    (ctx a frontier seen acc)
    (if
      (empty? frontier)
      acc
      (let
        ((newf (list))
          (newseen seen)
          (newacc acc)
          (theory (get ctx :theory)))
        (for-each
          (fn
            (t)
            (let
              ((succs (mau/sapply ctx a t)))
              (if
                (empty? succs)
                (append! newacc 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)))))
                  succs))))
          frontier)
        (mau/sbang-loop ctx a newf newseen newacc)))))

;; ---- public API ----

(define mau/make-sctx (fn (m strats) {:eqs (mau/module-eqs m) :theory (mau/build-theory m) :strats strats :rules (mau/module-rules m)}))

(define
  mau/srun
  (fn
    (m strats strat src)
    (let
      ((ctx (mau/make-sctx m strats)))
      (let
        ((t0 (mau/cnormalize (get ctx :theory) (get ctx :eqs) (mau/parse-term-in m src) mau/reduce-fuel)))
        (mau/dedup-canon (get ctx :theory) (mau/sapply ctx strat t0))))))

(define
  mau/srun-canon
  (fn
    (m strats strat src)
    (let
      ((theory (mau/build-theory m)))
      (mau/sort-strings
        (map (fn (t) (mau/canon theory t)) (mau/srun m strats strat src))))))