rose-ash/lib/artdag/optimize-rules.sx

; lib/artdag/optimize-rules.sx — Phase 7: optimisation laws as a confluent maude module.
; The optimised effect pipeline IS the normal form of the rule set, so confluence
; (mau/confluent?) is exactly content-id stability: every rewrite order reaches the
; same normal form. Media ops (blur/bright/id/over) are the opaque-op model from
; lib/maude/tests/effects.sx — the engine reasons about the pipeline algebra, never
; pixels. The radius algebra is an AC operator with identity 0 (unary 1s): Peano
; successor rules (s M + N = s(M+N), 0 + N = N) are NOT confluent here (the symbolic
; critical pairs M + 0 and (A+B)+C vs A+(B+C) stick), whereas [assoc comm id: 0]
; joins them via canonical form. maude (lib/maude) is a READ-ONLY consumed substrate:
; mau/parse-module, mau/creduce, mau/creduce->str, mau/ccanon, mau/confluent?,
; mau/non-joinable-pairs, mau/cp->str, mau/app/const/op/args/app?.

(define
  artdag/opt-module-src
  (str
    "fmod ARTDAGOPT is\n"
    "  sorts Img Num .\n"
    "  op 0 : -> Num .\n"
    "  op 1 : -> Num .\n"
    "  op _+_ : Num Num -> Num [assoc comm id: 0] .\n"
    "  op blur : Img Num -> Img .\n"
    "  op bright : Img Num -> Img .\n"
    "  op id : Img -> Img .\n"
    "  op over : Img Img -> Img [comm] .\n"
    "  vars I J : Img .\n"
    "  vars M N : Num .\n"
    "  eq id(I) = I .\n"
    "  eq blur(I, 0) = I .\n"
    "  eq bright(I, 0) = I .\n"
    "  eq blur(blur(I, M), N) = blur(I, M + N) .\n"
    "  eq bright(bright(I, M), N) = bright(I, M + N) .\n"
    "  eq over(I, I) = I .\n"
    "endfm"))

(define artdag/opt-module (mau/parse-module artdag/opt-module-src))

; ops whose last term arg is the radius (Num); other args are image inputs.
(define artdag/opt-radius-ops (list "blur" "bright"))
; commutative ops (mirror the content-id's order-insensitivity).
(define artdag/opt-comm-ops (list "over"))

; ---- reduce a surface pipeline (source string) to its optimised normal form ----

(define
  artdag/opt-reduce-term
  (fn (src) (mau/creduce-term artdag/opt-module src)))

(define
  artdag/opt-normal-form
  (fn (src) (mau/creduce->str artdag/opt-module src)))

(define artdag/opt-canon (fn (src) (mau/ccanon artdag/opt-module src)))

; two surface pipelines optimise to the same pipeline (=> same content id) iff
; their normal forms coincide.
(define
  artdag/opt-same-form?
  (fn (a b) (= (artdag/opt-normal-form a) (artdag/opt-normal-form b))))

; ---- confluence / content-id stability (consume lib/maude/confluence.sx) ----

(define artdag/opt-confluent? (fn () (mau/confluent? artdag/opt-module)))

(define
  artdag/opt-non-joinable
  (fn () (mau/non-joinable-pairs artdag/opt-module)))

(define
  artdag/opt-non-joinable->strs
  (fn
    ()
    (map
      (fn (cp) (mau/cp->str artdag/opt-module cp))
      (artdag/opt-non-joinable))))

; ---- radius <-> unary Num term ----

(define
  artdag/num->unary
  (fn
    (n)
    (if
      (<= n 0)
      (mau/const "0")
      (reduce
        (fn (acc i) (mau/app "_+_" (list acc (mau/const "1"))))
        (mau/const "1")
        (range 1 n)))))

(define
  artdag/unary->num
  (fn
    (t)
    (let
      ((op (mau/op t)))
      (cond
        ((= op "1") 1)
        ((= op "_+_")
          (reduce
            (fn (a x) (+ a (artdag/unary->num x)))
            0
            (mau/args t)))
        (else 0)))))

; ---- dag cone -> opt-term ----
; leaves -> nullary const (op name); a :radius node -> op(inputs..., unary radius);
; any other op -> op(inputs...). over (commutative) maps to the module's comm op.

(define
  artdag/dag->opt-term
  (fn
    (dag id)
    (let
      ((node (artdag/dag-get dag id)))
      (let
        ((op (artdag/node-op node))
          (ins
            (map
              (fn (i) (artdag/dag->opt-term dag i))
              (artdag/node-inputs node)))
          (params (artdag/node-params node)))
        (if
          (empty? ins)
          (mau/const op)
          (if
            (artdag/member? op artdag/opt-radius-ops)
            (mau/app
              op
              (concat ins (list (artdag/num->unary (get params :radius)))))
            (mau/app op ins)))))))

; ---- opt-term -> build entries (synthesized names; build recomputes content-ids) ----

(define
  artdag/opt-last
  (fn
    (xs)
    (if (empty? (rest xs)) (first xs) (artdag/opt-last (rest xs)))))

(define
  artdag/opt-but-last
  (fn
    (xs)
    (if
      (empty? (rest xs))
      (list)
      (cons (first xs) (artdag/opt-but-last (rest xs))))))

(define
  artdag/opt-term->build
  (fn
    (t counter acc)
    (if
      (not (mau/app? t))
      (let ((nm (str "ob" counter))) {:name nm :acc (concat acc (list (list nm (mau/op t) (list) {}))) :counter (+ counter 1)})
      (let
        ((op (mau/op t))
          (radius? (artdag/member? (mau/op t) artdag/opt-radius-ops)))
        (let
          ((in-terms (if radius? (artdag/opt-but-last (mau/args t)) (mau/args t)))
            (params (if radius? {:radius (artdag/unary->num (artdag/opt-last (mau/args t)))} {}))
            (comm? (artdag/member? op artdag/opt-comm-ops)))
          (let
            ((built (reduce (fn (st ct) (let ((r (artdag/opt-term->build ct (get st :counter) (get st :acc)))) {:acc (get r :acc) :counter (get r :counter) :names (concat (get st :names) (list (get r :name)))})) {:acc acc :counter counter :names (list)} in-terms)))
            (let ((nm (str "ob" (get built :counter)))) {:name nm :acc (concat (get built :acc) (list (list nm op (get built :names) params comm?))) :counter (+ (get built :counter) 1)})))))))

(define
  artdag/opt-term->entries
  (fn (t) (get (artdag/opt-term->build t 0 (list)) :acc)))

; ---- optimise a DAG via maude: encode -> creduce -> decode -> rebuild ----
; result-preserving: the optimised DAG executes to the same result as the original.
(define
  artdag/opt-reduce
  (fn
    (dag id)
    (artdag/build
      (artdag/opt-term->entries
        (mau/creduce artdag/opt-module (artdag/dag->opt-term dag id))))))

; content-id of the optimised sink (the head of the reduced term's rebuilt DAG).
(define
  artdag/opt-reduce-sink
  (fn
    (dag id)
    (let
      ((o (artdag/opt-reduce dag id)))
      (artdag/opt-last (artdag/dag-order o)))))

; ---- cost-directed: the maude-optimised cone never costs more than the original ----
; compares the original output cone (dce to id) against the maude-reduced DAG under an
; injected cost-fn (op params). Monotone per-node costs => optimisation is never a
; pessimisation: fewer nodes (DCE/dedup) and fused ops (one blur(M+N) for two blurs).

(define
  artdag/opt-improvement
  (fn
    (dag id cost-fn)
    (let
      ((orig (artdag/dce dag (list id))) (opt (artdag/opt-reduce dag id)))
      {:before (artdag/total-work orig cost-fn)
        :after (artdag/total-work opt cost-fn)
        :before-path (artdag/critical-path orig cost-fn)
        :after-path (artdag/critical-path opt cost-fn)
        :optimized opt})))

(define
  artdag/opt-cheaper?
  (fn
    (dag id cost-fn)
    (let
      ((imp (artdag/opt-improvement dag id cost-fn)))
      (<= (get imp :after) (get imp :before)))))