add support for fromProb and and_

add support for fromProb and and_

# Haskell -- this is a "to Haskell" 'printing' module.
#
# A single export
# This prints our AST representation of linear operators

Haskell := module ()
  export ModuleApply;
  local b, p, d, bi,
      parens, resolve, sp, comma, ufunc, bfunc, lbrack, rbrack, seqp,
      lparen, rparen,
      fix_binds;
  uses StringTools;

  # this is to make things more efficient.  Note that it makes
  # things non-reentrant between Expr and p.
  b := StringBuffer();

  # for the long-term, go right to the 'right' way to do this,
  # which is to use the Inert form.  The flip-side of doing things
  # the right way would involve a proper pretty-printer, but that
  # can be added later easily enough.
  ModuleApply := proc(e)
      local rts, pows, expr, binds, unsafes;

      b:-clear();

      unsafes := indets(e, specfunc(anything, 'unsafeProb'));
      expr := subs(map((x -> x = unsafeProb(freeze(op(1,x)))), unsafes), e);
      # expr := eval(e, unsafeProb = (x -> unsafeProb(freeze(x))));

      # some last-minute patching; this will need hardened, 'anything' is
      # wrong.
      pows := indets(expr, anything ^ identical(-1));
      if pows <> {} then
        expr := subs(map((x -> x = recip(op(1,x))), pows), expr);
      end if;

      # catch sqrt(2) and other sqrt calls
      rts := indets(expr, anything ^ identical(1/2));
      pows, rts := selectremove(x -> evalb(signum(op(1,x))=1), rts);
      if pows <> {} then
        expr := subs(map((x -> x = sqrt_ (op(1,x))), pows), expr);
      end if;
      expr := subs(map((x -> x = Sqrt(op(1,x))), rts), expr);

      # catch 1/sqrt(Pi)
      pows := select(x -> evalb(signum(op(1,x))=1),
               indets(expr, realcons ^ identical(-1/2)));
      if pows <> {} then
        expr := subs(map((x -> x = recip (sqrt_ (op(1,x)))), pows), expr);
      end if;

      pows := indets(expr, anything ^ integer);
      if pows <> {} then
        expr := subs(map((x -> x = IntPow(op(x))), pows), expr);
      end if;
      expr := thaw(expr);

      # deal with Domain hack in Bind
      binds := indets(expr, 'Bind'(anything, name = `..`, anything));
      expr := subs(map(fix_binds, binds), expr);

      # and now actually translate
      p(ToInert(expr));
      b:-value();
  end;

  p := proc(e)
    if assigned(d[op(0,e)]) then
      d[op(0,e)](op(e))
    else
      error "Haskell: %1 not implemented yet (%2)", op(0,e), e
    end if;
  end;

# things get silly with too much indentation, so for this table, we cheat
d[_Inert_INTPOS] := proc(x) b:-appendf("%d",x) end;
d[_Inert_INTNEG] := proc(x) b:-appendf("(%d)",-x) end;
d[_Inert_RATIONAL] := proc(n,d)
  parens(proc() p(n); b:-append(" / "); p(d); end)
end;
d[_Inert_FUNCTION] := proc(f, s)
  local nm;
  nm := resolve(f);
  if assigned(bi[nm]) then
    bi[nm](op(s))
  else
    error "Haskell: cannot resolve function %1", f
  end if;
end proc;
# ignore a2 and subsequent things below
d[_Inert_ASSIGNEDNAME] := proc(a1, a2)
  if assigned(bi[a1]) then
    bi[a1]()
  else
    b:-append(a1);
  end if;
end proc;
d[_Inert_NAME] := proc(a1)
  if assigned(bi[a1]) then
    bi[a1]()
  else
    b:-append(a1);
  end if;
end proc;
# SUM is n-ary
d[_Inert_SUM] := proc()
  lparen(); seqp(" + ", [_passed]); rparen();
end;
# PROD is n-ary
d[_Inert_PROD] := proc()
  lparen(); seqp(" * ", [_passed]); rparen();
end;
d[_Inert_POWER] := proc(a1,a2)
  # should be Int "^" Int
  #        or Real "^^" Int
  #        or Prob "^^" Int
  #        or Real "**" Real
  #        or Prob "`pow_`" Real
  #
  # Note that the two cases for ^^, when the rhs is a literal, is now ok
  parens(proc() p(a1); b:-append(" ** "); p(a2) end);
end;
d[_Inert_LESSTHAN] := proc(a1, a2)
  lparen(); b:-append("less"); sp(); p(a1); sp(); p(a2); rparen();
end proc;
d[_Inert_LESSEQ] := proc(a1, a2)
  lparen(); b:-append("or_"); sp(); lbrack();
     b:-append("less_"); sp(); p(a1); sp(); p(a2);
     comma();
     b:-append("equal_"); sp(); p(a1); sp(); p(a2);
     rbrack();
  rparen();
end proc;

# this is the table of known internal functions
bi["Bind_"] := proc(a1, a2) p(a1); b:-append(" `bind_` "); p(a2) end;
bi["Return"] := ufunc("dirac");
bi["Factor"] := ufunc("factor");
bi["unsafeProb"] := ufunc("unsafeProb");
bi["fromProb"] := ufunc("fromProb");
bi["Unit"] := proc() b:-append("unit") end;
bi["Uniform"] := bfunc("uniform ");
bi["Lebesgue"] := proc() b:-append("lebesgue") end;
bi["Pi"] := proc() b:-append("pi_") end;
bi["Fst"] := ufunc("fst_");
bi["Snd"] := ufunc("snd_");

# be careful what you ask for!
bi["undefined"] := proc() b:-append("42") end;

bi["Bind"] := proc(meas, var, rest)
  local rng;
  p(meas);
  b:-append(" `bind` \\");
  if type(var, specfunc(anything,'_Inert_NAME')) then
    b:-append(op(1,var));
    b:-append(" -> ");
  else
    ASSERT(type(var, specfunc(anything, '_Inert_EQUATION')));
    rng := FromInert(op(2,var));
    if rng = -infinity .. infinity then
      b:-append(op([1,1],var));
      b:-append(" -> ");
    else
      error "variable range in `bind` not yet handled";
    end if;
  end if;
  p(rest);
end;

bi["And"] := proc() b:-append("and_"); sp();
  lbrack(); seqp(", ", [_passed]); rbrack();
end;

bi["SUPERPOSE"] := proc() b:-append("superpose"); sp();
  lbrack(); seqp(", ", [_passed]); rbrack();
end;

# will always be called in the context of a superpose
bi["WM"] := proc(w, m)
  b:-append("("); p(w); b:-append(","); p(m); b:-append(")");
end;

# this is a stand-alone superpose
bi["WeightedM"] := proc(w, m)
  b:-append("superpose"); sp(); lbrack();
  b:-append("("); p(w); b:-append(","); p(m); b:-append(")");
  rbrack();
end;

bi["Pair"] := bfunc("pair");
bi["NormalD"] := bfunc("normal");
bi["BetaD"] := bfunc("beta");
bi["GammaD"] := bfunc("gamma");

bi["IntPow"] := proc(l, r)
  b:-append("("); p(l); b:-append(" ^^ "); p(r); b:-append(")");
end;

# nm should be a name!
bi["Lambda"] := proc(nm, expr)
  b:-append("lam (\\");
  b:-append(op(1,nm));
  b:-append(" -> ");
  p(expr);
  b:-append(")");
end proc;

bi["exp"] := ufunc("exp");
bi["exp_"] := ufunc("exp_");
bi["sqrt_"] := ufunc("sqrt_");
bi["Sqrt"] := ufunc("sqrt");
bi["recip"] := ufunc("recip");
bi["ln"] := ufunc("log");
bi["ln_"] := ufunc("log_");
bi["cos"] := ufunc("cos");
bi["sin"] := ufunc("sin");
bi["erf"] := ufunc("erf");
bi["GAMMA"] := ufunc("gammaFunc");

bi["If"] := proc()
  ASSERT(_npassed>0);
  if _npassed = 1 then p(_passed[1])
  elif _npassed = 2 then
    b:-append("if_ ");
    p(_passed[1]);
    sp();
    lparen(); p(_passed[2]); rparen();
    sp();
    b:-append("0");
  else
    b:-append("if_ ");
    p(_passed[1]);
    sp();
    lparen(); p(_passed[2]); rparen();
    sp();
    lparen(); thisproc(_passed[3..-1]); rparen();
  end if;
end;

# utility routines:
# =================

# printing
  sp := proc() b:-append(" ") end;
  comma := proc() b:-append(",") end;
  lbrack := proc() b:-append("[") end;
  rbrack := proc() b:-append("]") end;
  lparen := proc() b:-append("(") end;
  rparen := proc() b:-append(")") end;
  parens := proc(c) b:-append("("); c(); b:-append(")") end;
  ufunc := proc(f) proc(c) parens(proc() b:-append(f); sp(); p(c) end) end; end;
  bfunc := f -> ((x,y) -> parens(proc() b:-append(f); sp(); p(x); sp(); p(y); end));
  seqp := proc(s, l)
    if nops(l)=0 then NULL
    elif nops(l)=1 then p(l[1])
    else
      p(l[1]);
      b:-append(s);
      seqp(s, l[2..-1]);
    end if;
  end proc;

# resolve name
  resolve := proc(inrt)
    local s, nm;
    nm := eval(inrt, _Inert_ATTRIBUTE=NULL); # crude but effective
    if typematch(nm, specfunc('s'::'string', '_Inert_NAME')) then
      s
    elif type(nm, specfunc('string', '_Inert_ASSIGNEDNAME')) then
      op(1,nm)
    else
      error "cannot resolve an %1, namely %2", op(0,nm), nm;
    end if;
  end proc;

# patching routines.  ToDo: better design.
  fix_binds := proc(bind)
    local var, rng, meas, rest, lower, upper;
    (var, rng) := op(op(2,bind));
    meas := op(1,bind);
    rest := op(3,bind);
    if rng = -infinity..infinity then
      bind = 'Bind'(meas, var, rest)
    elif typematch(rng, identical(-infinity) .. (upper::Non(infinity))) then
      bind = 'Bind'(meas, var, If(upper <= var, rest, SUPERPOSE()))
    elif typematch(rng, (lower::Non(infinity)) .. identical(infinity)) then
      bind = 'Bind'(meas, var, If(var >= lower, rest, SUPERPOSE()))
    else # both finite
      (lower, upper) := op(rng);
      bind = 'Bind'(meas, var, If(var < lower, SUPERPOSE(),
                                 If(upper <= var, rest, Superpose())))
    end if;
  end
end module:

# Haskell -- this is a "to Haskell" 'printing' module.
#
# A single export
# This prints our AST representation of linear operators

Haskell := module ()
  export ModuleApply;
  local b, p, d, bi,
      parens, resolve, sp, comma, ufunc, bfunc, lbrack, rbrack, seqp,
      lparen, rparen,
      fix_binds;
  uses StringTools;

  # this is to make things more efficient.  Note that it makes
  # things non-reentrant between Expr and p.
  b := StringBuffer();

  # for the long-term, go right to the 'right' way to do this,
  # which is to use the Inert form.  The flip-side of doing things
  # the right way would involve a proper pretty-printer, but that
  # can be added later easily enough.
  ModuleApply := proc(e)
      local rts, pows, expr, binds, unsafes;

      b:-clear();

      unsafes := indets(e, specfunc(anything, 'unsafeProb'));
      expr := subs(map((x -> x = unsafeProb(freeze(op(1,x)))), unsafes), e);
      # expr := eval(e, unsafeProb = (x -> unsafeProb(freeze(x))));

      # some last-minute patching; this will need hardened, 'anything' is
      # wrong.
      pows := indets(expr, anything ^ identical(-1));
      if pows <> {} then
        expr := subs(map((x -> x = recip(op(1,x))), pows), expr);
      end if;

      # catch sqrt(2) and other sqrt calls
      rts := indets(expr, anything ^ identical(1/2));
      pows, rts := selectremove(x -> evalb(signum(op(1,x))=1), rts);
      if pows <> {} then
        expr := subs(map((x -> x = sqrt_ (op(1,x))), pows), expr);
      end if;
      expr := subs(map((x -> x = Sqrt(op(1,x))), rts), expr);

      # catch 1/sqrt(Pi)
      pows := select(x -> evalb(signum(op(1,x))=1),
               indets(expr, realcons ^ identical(-1/2)));
      if pows <> {} then
        expr := subs(map((x -> x = recip (sqrt_ (op(1,x)))), pows), expr);
      end if;

      pows := indets(expr, anything ^ integer);
      if pows <> {} then
        expr := subs(map((x -> x = IntPow(op(x))), pows), expr);
      end if;
      expr := thaw(expr);

      # deal with Domain hack in Bind
      binds := indets(expr, 'Bind'(anything, name = `..`, anything));
      expr := subs(map(fix_binds, binds), expr);

      # and now actually translate
      p(ToInert(expr));
      b:-value();
  end;

  p := proc(e)
    if assigned(d[op(0,e)]) then
      d[op(0,e)](op(e))
    else
      error "Haskell: %1 not implemented yet (%2)", op(0,e), e
    end if;
  end;

# things get silly with too much indentation, so for this table, we cheat
d[_Inert_INTPOS] := proc(x) b:-appendf("%d",x) end;
d[_Inert_INTNEG] := proc(x) b:-appendf("(%d)",-x) end;
d[_Inert_RATIONAL] := proc(n,d)
  parens(proc() p(n); b:-append(" / "); p(d); end)
end;
d[_Inert_FUNCTION] := proc(f, s)
  local nm;
  nm := resolve(f);
  if assigned(bi[nm]) then
    bi[nm](op(s))
  else
    error "Haskell: cannot resolve function %1", f
  end if;
end proc;
# ignore a2 and subsequent things below
d[_Inert_ASSIGNEDNAME] := proc(a1, a2)
  if assigned(bi[a1]) then
    bi[a1]()
  else
    b:-append(a1);
  end if;
end proc;
d[_Inert_NAME] := proc(a1)
  if assigned(bi[a1]) then
    bi[a1]()
  else
    b:-append(a1);
  end if;
end proc;
# SUM is n-ary
d[_Inert_SUM] := proc()
  lparen(); seqp(" + ", [_passed]); rparen();
end;
# PROD is n-ary
d[_Inert_PROD] := proc()
  lparen(); seqp(" * ", [_passed]); rparen();
end;
d[_Inert_POWER] := proc(a1,a2)
  # should be Int "^" Int
  #        or Real "^^" Int
  #        or Prob "^^" Int
  #        or Real "**" Real
  #        or Prob "`pow_`" Real
  #
  # Note that the two cases for ^^, when the rhs is a literal, is now ok
  parens(proc() p(a1); b:-append(" ** "); p(a2) end);
end;
d[_Inert_LESSTHAN] := proc(a1, a2)
  lparen(); b:-append("less"); sp(); p(a1); sp(); p(a2); rparen();
end proc;
d[_Inert_LESSEQ] := proc(a1, a2)
  lparen(); b:-append("or_"); sp(); lbrack();
     b:-append("less_"); sp(); p(a1); sp(); p(a2);
     comma();
     b:-append("equal_"); sp(); p(a1); sp(); p(a2);
     rbrack();
  rparen();
end proc;

# this is the table of known internal functions
bi["Bind_"] := proc(a1, a2) p(a1); b:-append(" `bind_` "); p(a2) end;
bi["Return"] := ufunc("dirac");
bi["Factor"] := ufunc("factor");
bi["unsafeProb"] := ufunc("unsafeProb");
bi["Unit"] := proc() b:-append("unit") end;
bi["Uniform"] := bfunc("uniform ");
bi["Lebesgue"] := proc() b:-append("lebesgue") end;
bi["Pi"] := proc() b:-append("pi_") end;
bi["Fst"] := ufunc("fst_");
bi["Snd"] := ufunc("snd_");

# be careful what you ask for!
bi["undefined"] := proc() b:-append("42") end;

bi["Bind"] := proc(meas, var, rest)
  local rng;
  p(meas);
  b:-append(" `bind` \\");
  if type(var, specfunc(anything,'_Inert_NAME')) then
    b:-append(op(1,var));
    b:-append(" -> ");
  else
    ASSERT(type(var, specfunc(anything, '_Inert_EQUATION')));
    rng := FromInert(op(2,var));
    if rng = -infinity .. infinity then
      b:-append(op([1,1],var));
      b:-append(" -> ");
    else
      error "variable range in `bind` not yet handled";
    end if;
  end if;
  p(rest);
end;

bi["SUPERPOSE"] := proc() b:-append("superpose"); sp();
  lbrack(); seqp(", ", [_passed]); rbrack();
end;

# will always be called in the context of a superpose
bi["WM"] := proc(w, m)
  b:-append("("); p(w); b:-append(","); p(m); b:-append(")");
end;

# this is a stand-alone superpose
bi["WeightedM"] := proc(w, m)
  b:-append("superpose"); sp(); lbrack();
  b:-append("("); p(w); b:-append(","); p(m); b:-append(")");
  rbrack();
end;

bi["Pair"] := bfunc("pair");
bi["NormalD"] := bfunc("normal");
bi["BetaD"] := bfunc("beta");
bi["GammaD"] := bfunc("gamma");

bi["IntPow"] := proc(l, r)
  b:-append("("); p(l); b:-append(" ^^ "); p(r); b:-append(")");
end;

# nm should be a name!
bi["Lambda"] := proc(nm, expr)
  b:-append("lam (\\");
  b:-append(op(1,nm));
  b:-append(" -> ");
  p(expr);
  b:-append(")");
end proc;

bi["exp"] := ufunc("exp");
bi["exp_"] := ufunc("exp_");
bi["sqrt_"] := ufunc("sqrt_");
bi["Sqrt"] := ufunc("sqrt");
bi["recip"] := ufunc("recip");
bi["ln"] := ufunc("log");
bi["ln_"] := ufunc("log_");
bi["cos"] := ufunc("cos");
bi["sin"] := ufunc("sin");
bi["erf"] := ufunc("erf");
bi["GAMMA"] := ufunc("gammaFunc");

bi["If"] := proc()
  ASSERT(_npassed>0);
  if _npassed = 1 then p(_passed[1])
  elif _npassed = 2 then
    b:-append("if_ ");
    p(_passed[1]);
    sp();
    lparen(); p(_passed[2]); rparen();
    sp();
    b:-append("0");
  else
    b:-append("if_ ");
    p(_passed[1]);
    sp();
    lparen(); p(_passed[2]); rparen();
    sp();
    lparen(); thisproc(_passed[3..-1]); rparen();
  end if;
end;

# utility routines:
# =================

# printing
  sp := proc() b:-append(" ") end;
  comma := proc() b:-append(",") end;
  lbrack := proc() b:-append("[") end;
  rbrack := proc() b:-append("]") end;
  lparen := proc() b:-append("(") end;
  rparen := proc() b:-append(")") end;
  parens := proc(c) b:-append("("); c(); b:-append(")") end;
  ufunc := proc(f) proc(c) parens(proc() b:-append(f); sp(); p(c) end) end; end;
  bfunc := f -> ((x,y) -> parens(proc() b:-append(f); sp(); p(x); sp(); p(y); end));
  seqp := proc(s, l)
    if nops(l)=0 then NULL
    elif nops(l)=1 then p(l[1])
    else
      p(l[1]);
      b:-append(s);
      seqp(s, l[2..-1]);
    end if;
  end proc;

# resolve name
  resolve := proc(inrt)
    local s, nm;
    nm := eval(inrt, _Inert_ATTRIBUTE=NULL); # crude but effective
    if typematch(nm, specfunc('s'::'string', '_Inert_NAME')) then
      s
    elif type(nm, specfunc('string', '_Inert_ASSIGNEDNAME')) then
      op(1,nm)
    else
      error "cannot resolve an %1, namely %2", op(0,nm), nm;
    end if;
  end proc;

# patching routines.  ToDo: better design.
  fix_binds := proc(bind)
    local var, rng, meas, rest, lower, upper;
    (var, rng) := op(op(2,bind));
    meas := op(1,bind);
    rest := op(3,bind);
    if rng = -infinity..infinity then
      bind = 'Bind'(meas, var, rest)
    elif typematch(rng, identical(-infinity) .. (upper::Non(infinity))) then
      bind = 'Bind'(meas, var, If(upper <= var, rest, SUPERPOSE()))
    elif typematch(rng, (lower::Non(infinity)) .. identical(infinity)) then
      bind = 'Bind'(meas, var, If(var >= lower, rest, SUPERPOSE()))
    else # both finite
      (lower, upper) := op(rng);
      bind = 'Bind'(meas, var, If(var < lower, SUPERPOSE(),
                                 If(upper <= var, rest, Superpose())))
    end if;
  end
end module:


Fix bug in summarize

Fix bug in summarize

I forgot to copy the mutated variable r.

`depends/Bucket` := proc(mr, r::(name=range), x, $)
  depends(rhs(r), x) or depends(mr, x minus {lhs(r)})
end proc:

`depends/Index` := proc(n, o::name, e, mr, x, $)
  depends({n,e}, x) or depends(mr, x minus {o})
end proc:

`eval/Bucket` := proc(e::anyfunc(anything,name=range), eqs, $)
  local bvar, body;
  bvar, body := BindingTools:-generic_evalat(op([2,1],e), op(1,e), eqs);
  eval(op(0,e), eqs)(body, bvar = eval(op([2,2],e), eqs))
end proc:

`eval/Index` := proc(e::anyfunc(anything,name,anything,anything), eqs, $)
  local o, mr;
  o, mr := BindingTools:-generic_evalat(op(2,e), op(4,e), eqs);
  eval(op(0,e), eqs)(eval(op(1,e), eqs), o, eval(op(3,e), eqs), mr)
end proc:

Summary := module ()
  option package;
  export bucket, summarize;
  global Bucket, Fanout, Index, Split, Nop, Add;
  uses Hakaru, KB;

  bucket := proc(mr, r::(name=range), cond::list:=[], $)
    if mr :: 'Fanout(anything,anything)' then
      Pair(op(map(procname, _passed)))
    elif mr :: 'Split(anything,anything,anything)' then
      Pair(bucket(op(2,mr), r, [    op(1,mr) ,op(cond)]),
           bucket(op(3,mr), r, [Not(op(1,mr)),op(cond)]))
    elif mr :: 'Index(anything,name,anything,anything)' then
      ary(op(1,mr), op(2,mr),
          bucket(op(4,mr), r, [op(2,mr)=op(3,mr),op(cond)]));
    elif mr :: 'Nop()' then
      _Unit
    elif mr :: 'Add(anything)' then
      sum(piecewise_And(cond, op(1,mr), 0), r)
    else
      'procname(_passed)'
    end if;
  end proc;

  summarize := proc(ee,
                    kb :: t_kb,
                    i :: {name,list(name),set(name)},
                    summary, $)
    local e, r, s,
          e1, mr1, f1, e2, mr2, f2,
          variables, var_outerness, outermost, thunk, consider,
          o, t, lo, hi, b, a;
    e := simplify_assuming(ee, kb);
    # Nop rule
    if Testzero(e) then return Nop(), 0 end if;

    r := indets(e, '{relation, logical, specfunc({And,Or})}');
    s, r := selectremove(depends, r, i);
    # Fanout rule
    r := sort(convert(r, 'list'), 'length');
    while nops(r) > 0 do
      e1 := eval(e, r[-1]=true);  if e = e1 then r := r[1..-2]; next end if;
      e2 := eval(e, r[-1]=false); if e = e2 then r := r[1..-2]; next end if;
      mr1, f1 := summarize(e1, kb, i, 'fst(summary)');
      mr2, f2 := summarize(e2, kb, i, 'snd(summary)');
      return Fanout(mr1, mr2), 'piecewise'(r[-1], f1, f2);
    end do;

    variables     := kb_to_variables(kb);
    var_outerness := table(variables =~ [seq(1..nops(variables))]);
    outermost     := -infinity;
    consider      := proc(expr, th, $)
      local outerness;
      outerness := map((n -> var_outerness[n]), indets(expr, 'name'));
      outerness := min(select(type, outerness, 'integer'));
      if outermost < outerness then
        outermost := outerness;
        thunk     := th;
      end if;
    end proc;
    for r in s do
      e1 := eval(e, r=true);  if e = e1 then next end if;
      e2 := eval(e, r=false); if e = e2 then next end if;
      # Index rule
      if r :: `=` and Testzero(e2) then
        for o in indets(r, 'name') minus convert(i, 'set') do
          if not (var_outerness[o] :: integer) then next end if;
          t := getType(kb, o);
          if not (t :: specfunc(HInt)) then next end if;
          lo := op(select(type, t, 'Bound(identical(`>=`), anything)'));
          if lo = NULL then next else lo := op(2,lo) end if;
          hi := op(select(type, t, 'Bound(identical(`<=`), anything)'));
          if hi = NULL then next else hi := op(2,hi) end if;
          if not ispoly(`-`(op(r)), 'linear', o, 'b', 'a') then next end if;
          b := Normalizer(-b/a);
          consider(b, ((e1, o, lo, hi, b) -> proc($)
            local mr, f;
            mr, f := summarize(e1, kb, i, 'idx'(summary, o-lo));
            Index(hi-lo+1, o, b, mr),
              'piecewise'(And(o::integer, lo<=o, o<=hi), f, 0);
          end proc)(e1, o, lo, hi, b));
        end do;
      end if;
      # Split rule
      consider(r, ((e1, e2, r) -> proc($)
        local mr1, f1, mr2, f2;
        mr1, f1 := summarize(e1, kb, i, 'fst(summary)');
        mr2, f2 := summarize(e2, kb, i, 'snd(summary)');
        Split(r, mr1, mr2), f1 + f2;
      end proc)(e1, e2, r));
    end do;
    if thunk :: procedure then
      return thunk();
    else
      # Add rule
      return Add(e), summary;
    end if;
  end proc;
end module; # Summary

`depends/Bucket` := proc(mr, r::(name=range), x, $)
  depends(rhs(r), x) or depends(mr, x minus {lhs(r)})
end proc:

`depends/Index` := proc(n, o::name, e, mr, x, $)
  depends({n,e}, x) or depends(mr, x minus {o})
end proc:

`eval/Bucket` := proc(e::anyfunc(anything,name=range), eqs, $)
  local bvar, body;
  bvar, body := BindingTools:-generic_evalat(op([2,1],e), op(1,e), eqs);
  eval(op(0,e), eqs)(body, bvar = eval(op([2,2],e), eqs))
end proc:

`eval/Index` := proc(e::anyfunc(anything,name,anything,anything), eqs, $)
  local o, mr;
  o, mr := BindingTools:-generic_evalat(op(2,e), op(4,e), eqs);
  eval(op(0,e), eqs)(eval(op(1,e), eqs), o, eval(op(3,e), eqs), mr)
end proc:

Summary := module ()
  option package;
  export bucket, summarize;
  global Bucket, Fanout, Index, Split, Nop, Add;
  uses Hakaru, KB;

  bucket := proc(mr, r::(name=range), cond::list:=[], $)
    if mr :: 'Fanout(anything,anything)' then
      Pair(op(map(procname, _passed)))
    elif mr :: 'Split(anything,anything,anything)' then
      Pair(bucket(op(2,mr), r, [    op(1,mr) ,op(cond)]),
           bucket(op(3,mr), r, [Not(op(1,mr)),op(cond)]))
    elif mr :: 'Index(anything,name,anything,anything)' then
      ary(op(1,mr), op(2,mr),
          bucket(op(4,mr), r, [op(2,mr)=op(3,mr),op(cond)]));
    elif mr :: 'Nop()' then
      _Unit
    elif mr :: 'Add(anything)' then
      sum(piecewise_And(cond, op(1,mr), 0), r)
    else
      'procname(_passed)'
    end if;
  end proc;

  summarize := proc(ee,
                    kb :: t_kb,
                    i :: {name,list(name),set(name)},
                    summary, $)
    local e, r, s,
          e1, mr1, f1, e2, mr2, f2,
          variables, var_outerness, outermost, thunk, consider,
          o, t, lo, hi, b, a;
    e := simplify_assuming(ee, kb);
    # Nop rule
    if Testzero(e) then return Nop(), 0 end if;

    r := indets(e, '{relation, logical, specfunc({And,Or})}');
    s, r := selectremove(depends, r, i);
    # Fanout rule
    r := sort(convert(r, 'list'), 'length');
    while nops(r) > 0 do
      e1 := eval(e, r[-1]=true);  if e = e1 then r := r[1..-2]; next end if;
      e2 := eval(e, r[-1]=false); if e = e2 then r := r[1..-2]; next end if;
      mr1, f1 := summarize(e1, kb, i, 'fst(summary)');
      mr2, f2 := summarize(e2, kb, i, 'snd(summary)');
      return Fanout(mr1, mr2), 'piecewise'(r[-1], f1, f2);
    end do;

    variables     := kb_to_variables(kb);
    var_outerness := table(variables =~ [seq(1..nops(variables))]);
    outermost     := -infinity;
    consider      := proc(expr, th, $)
      local outerness;
      outerness := map((n -> var_outerness[n]), indets(expr, 'name'));
      outerness := min(select(type, outerness, 'integer'));
      if outermost < outerness then
        outermost := outerness;
        thunk     := th;
      end if;
    end proc;
    for r in s do
      e1 := eval(e, r=true);  if e = e1 then next end if;
      e2 := eval(e, r=false); if e = e2 then next end if;
      # Index rule
      if r :: `=` and Testzero(e2) then
        for o in indets(r, 'name') minus convert(i, 'set') do
          if not (var_outerness[o] :: integer) then next end if;
          t := getType(kb, o);
          if not (t :: specfunc(HInt)) then next end if;
          lo := op(select(type, t, 'Bound(identical(`>=`), anything)'));
          if lo = NULL then next else lo := op(2,lo) end if;
          hi := op(select(type, t, 'Bound(identical(`<=`), anything)'));
          if hi = NULL then next else hi := op(2,hi) end if;
          if not ispoly(`-`(op(r)), 'linear', o, 'b', 'a') then next end if;
          b := Normalizer(-b/a);
          consider(b, ((e1, o, lo, hi, b) -> proc($)
            local mr, f;
            mr, f := summarize(e1, kb, i, 'idx'(summary, o-lo));
            Index(hi-lo+1, o, b, mr),
              'piecewise'(And(o::integer, lo<=o, o<=hi), f, 0);
          end proc)(e1, o, lo, hi, b));
        end do;
      end if;
      # Split rule
      consider(r, ((e1, e2) -> proc($)
        local mr1, f1, mr2, f2;
        mr1, f1 := summarize(e1, kb, i, 'fst(summary)');
        mr2, f2 := summarize(e2, kb, i, 'snd(summary)');
        Split(r, mr1, mr2), f1 + f2;
      end proc)(e1, e2));
    end do;
    if thunk :: procedure then
      return thunk();
    else
      # Add rule
      return Add(e), summary;
    end if;
  end proc;
end module; # Summary


Just in case, start to summarize generated Bucket expressions recursively

`depends/Bucket` := proc(mr, r::(name=range), x, $)
  depends(rhs(r), x) or depends(mr, x minus {lhs(r)})
end proc:

`depends/Index` := proc(n, o::name, e, mr, x, $)
  depends({n,e}, x) or depends(mr, x minus {o})
end proc:

`eval/Bucket` := proc(e::anyfunc(anything,name=range), eqs, $)
  local bvar, body;
  bvar, body := BindingTools:-generic_evalat(op([2,1],e), op(1,e), eqs);
  eval(op(0,e), eqs)(body, bvar = eval(op([2,2],e), eqs))
end proc:

`eval/Index` := proc(e::anyfunc(anything,name,anything,anything), eqs, $)
  local o, mr;
  o, mr := BindingTools:-generic_evalat(op(2,e), op(4,e), eqs);
  eval(op(0,e), eqs)(eval(op(1,e), eqs), o, eval(op(3,e), eqs), mr)
end proc:

Summary := module ()
  option package;
  export bucket, summarize, summarize_throughout;
  global Bucket, Fanout, Index, Split, Nop, Add;
  uses Hakaru, KB;

  bucket := proc(mr, r::(name=range), cond::list:=[], $)
    if mr :: 'Fanout(anything,anything)' then
      Pair(op(map(procname, _passed)))
    elif mr :: 'Split(anything,anything,anything)' then
      Pair(bucket(op(2,mr), r, [    op(1,mr) ,op(cond)]),
           bucket(op(3,mr), r, [Not(op(1,mr)),op(cond)]))
    elif mr :: 'Index(anything,name,anything,anything)' then
      ary(op(1,mr), op(2,mr),
          bucket(op(4,mr), r, [op(2,mr)=op(3,mr),op(cond)]));
    elif mr :: 'Nop()' then
      _Unit
    elif mr :: 'Add(anything)' then
      sum(piecewise_And(cond, op(1,mr), 0), r)
    else
      'procname(_passed)'
    end if;
  end proc;

  summarize := proc(ee,
                    kb :: t_kb,
                    i :: {name,list(name),set(name)},
                    summary, $)
    local e, r, s,
          e1, mr1, f1, e2, mr2, f2,
          variables, var_outerness, outermost, thunk, consider,
          o, t, lo, hi, b, a;

    # Try to ensure termination
    e := simplify_assuming(ee, kb);
    if length(e) >= length(ee) then e := ee end if;

    # Nop rule
    if Testzero(e) then return Nop(), 0 end if;

    r := indets(e, '{relation, logical, specfunc({And,Or})}');
    s, r := selectremove(depends, r, i);
    # Fanout rule
    r := sort(convert(r, 'list'), 'length');
    while nops(r) > 0 do
      e1 := eval(e, r[-1]=true);  if e = e1 then r := r[1..-2]; next end if;
      e2 := eval(e, r[-1]=false); if e = e2 then r := r[1..-2]; next end if;
      mr1, f1 := summarize(e1, kb, i, 'fst(summary)');
      mr2, f2 := summarize(e2, kb, i, 'snd(summary)');
      return Fanout(mr1, mr2), 'piecewise'(r[-1], f1, f2);
    end do;

    variables     := kb_to_variables(kb);
    var_outerness := table(variables =~ [seq(1..nops(variables))]);
    outermost     := -infinity;
    consider      := proc(expr, th, $)
      local outerness;
      outerness := map((n -> var_outerness[n]), indets(expr, 'name'));
      outerness := min(select(type, outerness, 'integer'));
      if outermost < outerness then
        outermost := outerness;
        thunk     := th;
      end if;
    end proc;
    if has(variables, i) then
      error "The loop to be summarized shadows the variable %1", i;
    end if;
    for r in s do
      e1 := eval(e, r=true);  if e = e1 then next end if;
      e2 := eval(e, r=false); if e = e2 then next end if;
      # Index rule
      if r :: `=` and Testzero(e2) then
        for o in indets(r, 'name') minus convert(i, 'set') do
          if not (var_outerness[o] :: integer) then next end if;
          t := getType(kb, o);
          if not (t :: specfunc(HInt)) then next end if;
          lo := op(select(type, t, 'Bound(identical(`>=`), anything)'));
          if lo = NULL then next else lo := op(2,lo) end if;
          hi := op(select(type, t, 'Bound(identical(`<=`), anything)'));
          if hi = NULL then next else hi := op(2,hi) end if;
          if not ispoly(`-`(op(r)), 'linear', o, 'b', 'a') then next end if;
          b := Normalizer(-b/a);
          consider(b, ((e1, o, lo, hi, b) -> proc($)
            local mr, f;
            mr, f := summarize(e1, kb, i, 'idx'(summary, o-lo));
            Index(hi-lo+1, o, b, mr),
              'piecewise'(And(o::integer, lo<=o, o<=hi), f, 0);
          end proc)(e1, o, lo, hi, b));
        end do;
      end if;
      # Split rule
      consider(r, ((e1, e2, r) -> proc($)
        local mr1, f1, mr2, f2;
        mr1, f1 := summarize(e1, kb, i, 'fst(summary)');
        mr2, f2 := summarize(e2, kb, i, 'snd(summary)');
        Split(r, mr1, mr2), f1 + f2;
      end proc)(e1, e2, r));
    end do;
    if thunk :: procedure then
      return thunk();
    else
      # Add rule
      return Add(e), summary;
    end if;
  end proc;

  summarize_throughout := proc(e, kb :: t_kb, $)
    local x, kb1, e1, rng, summary, mr, f;
    if not hasfun(e, '{Sum,sum}', 'piecewise') then
      e;
    elif e :: '{specfunc({Weight, Categorical,
                          Fanout, Split, Nop, Add,
                          exp, log, idx, And, Or, Not}),
                `+`, `*`, `^`, `..`, boolean, indexed, list}' then
      map(procname, _passed);
    elif e :: 'Context(anything, anything)' then
      kb1 := assert(op(1,e), kb);
      applyop(procname, 2, e, kb1);
    elif e :: 'specfunc(piecewise)' then
      kb_piecewise(e, kb, ((lhs, kb) -> lhs), summarize_throughout);
    elif e :: 'lam(name, anything, anything)' then
      x, kb1 := genType(op(1,e), op(2,e), kb);
      e1 := summarize_throughout(eval(op(3,e), op(1,e)=x), kb1);
      subsop(1=x, 3=e1, e);
    elif e :: 'ary(anything, name, anything)' then
      x, kb1 := genType(op(2,e), HInt(closed_bounds(0..op(1,e)-1)), kb);
      e1 := summarize_throughout(eval(op(3,e), op(2,e)=x), kb1);
      subsop(2=x, 3=e1, e);
    elif e :: 'And(specfunc({sum, Sum, product, Product}),
                   anyfunc(anything, name=range))' then
      rng := map(summarize_throughout, op([2,2],e), kb);
      x, kb1 := genType(op([2,1],e), HInt(closed_bounds(rng)), kb);
      e1 := eval(op(1,e), op([2,1],e)=x);
      if op(0, e) in '{sum, Sum}' and has(e1, 'piecewise') then
        mr, f := summarize(e1, kb, x, summary);
        if hasfun(mr, '{Fanout, Index}') then
          mr := summarize_throughout(mr, kb1);
          return Eval(simplify_factor_assuming(f, kb),
                      summary = Bucket(mr, x=rng));
        end if;
      end if;
      e1 := summarize_throughout(e1, kb1);
      subsop(2=(x=rng), 1=e1, e);
    else
      error "summarize_throughout doesn't know how to handle %1", e;
    end if;
  end proc;
end module; # Summary

`depends/Bucket` := proc(mr, r::(name=range), x, $)
  depends(rhs(r), x) or depends(mr, x minus {lhs(r)})
end proc:

`depends/Index` := proc(n, o::name, e, mr, x, $)
  depends({n,e}, x) or depends(mr, x minus {o})
end proc:

`eval/Bucket` := proc(e::anyfunc(anything,name=range), eqs, $)
  local bvar, body;
  bvar, body := BindingTools:-generic_evalat(op([2,1],e), op(1,e), eqs);
  eval(op(0,e), eqs)(body, bvar = eval(op([2,2],e), eqs))
end proc:

`eval/Index` := proc(e::anyfunc(anything,name,anything,anything), eqs, $)
  local o, mr;
  o, mr := BindingTools:-generic_evalat(op(2,e), op(4,e), eqs);
  eval(op(0,e), eqs)(eval(op(1,e), eqs), o, eval(op(3,e), eqs), mr)
end proc:

Summary := module ()
  option package;
  export bucket, summarize, summarize_throughout;
  global Bucket, Fanout, Index, Split, Nop, Add;
  uses Hakaru, KB;

  bucket := proc(mr, r::(name=range), cond::list:=[], $)
    if mr :: 'Fanout(anything,anything)' then
      Pair(op(map(procname, _passed)))
    elif mr :: 'Split(anything,anything,anything)' then
      Pair(bucket(op(2,mr), r, [    op(1,mr) ,op(cond)]),
           bucket(op(3,mr), r, [Not(op(1,mr)),op(cond)]))
    elif mr :: 'Index(anything,name,anything,anything)' then
      ary(op(1,mr), op(2,mr),
          bucket(op(4,mr), r, [op(2,mr)=op(3,mr),op(cond)]));
    elif mr :: 'Nop()' then
      _Unit
    elif mr :: 'Add(anything)' then
      sum(piecewise_And(cond, op(1,mr), 0), r)
    else
      'procname(_passed)'
    end if;
  end proc;

  summarize := proc(ee,
                    kb :: t_kb,
                    i :: {name,list(name),set(name)},
                    summary, $)
    local e, r, s,
          e1, mr1, f1, e2, mr2, f2,
          variables, var_outerness, outermost, thunk, consider,
          o, t, lo, hi, b, a;

    # Try to ensure termination
    e := simplify_assuming(ee, kb);
    if length(e) >= length(ee) then e := ee end if;

    # Nop rule
    if Testzero(e) then return Nop(), 0 end if;

    r := indets(e, '{relation, logical, specfunc({And,Or})}');
    s, r := selectremove(depends, r, i);
    # Fanout rule
    r := sort(convert(r, 'list'), 'length');
    while nops(r) > 0 do
      e1 := eval(e, r[-1]=true);  if e = e1 then r := r[1..-2]; next end if;
      e2 := eval(e, r[-1]=false); if e = e2 then r := r[1..-2]; next end if;
      mr1, f1 := summarize(e1, kb, i, 'fst(summary)');
      mr2, f2 := summarize(e2, kb, i, 'snd(summary)');
      return Fanout(mr1, mr2), 'piecewise'(r[-1], f1, f2);
    end do;

    variables     := kb_to_variables(kb);
    var_outerness := table(variables =~ [seq(1..nops(variables))]);
    outermost     := -infinity;
    consider      := proc(expr, th, $)
      local outerness;
      outerness := map((n -> var_outerness[n]), indets(expr, 'name'));
      outerness := min(select(type, outerness, 'integer'));
      if outermost < outerness then
        outermost := outerness;
        thunk     := th;
      end if;
    end proc;
    if has(variables, i) then
      error "The loop to be summarized shadows the variable %1", i;
    end if;
    for r in s do
      e1 := eval(e, r=true);  if e = e1 then next end if;
      e2 := eval(e, r=false); if e = e2 then next end if;
      # Index rule
      if r :: `=` and Testzero(e2) then
        for o in indets(r, 'name') minus convert(i, 'set') do
          if not (var_outerness[o] :: integer) then next end if;
          t := getType(kb, o);
          if not (t :: specfunc(HInt)) then next end if;
          lo := op(select(type, t, 'Bound(identical(`>=`), anything)'));
          if lo = NULL then next else lo := op(2,lo) end if;
          hi := op(select(type, t, 'Bound(identical(`<=`), anything)'));
          if hi = NULL then next else hi := op(2,hi) end if;
          if not ispoly(`-`(op(r)), 'linear', o, 'b', 'a') then next end if;
          b := Normalizer(-b/a);
          consider(b, ((e1, o, lo, hi, b) -> proc($)
            local mr, f;
            mr, f := summarize(e1, kb, i, 'idx'(summary, o-lo));
            Index(hi-lo+1, o, b, mr),
              'piecewise'(And(o::integer, lo<=o, o<=hi), f, 0);
          end proc)(e1, o, lo, hi, b));
        end do;
      end if;
      # Split rule
      consider(r, ((e1, e2, r) -> proc($)
        local mr1, f1, mr2, f2;
        mr1, f1 := summarize(e1, kb, i, 'fst(summary)');
        mr2, f2 := summarize(e2, kb, i, 'snd(summary)');
        Split(r, mr1, mr2), f1 + f2;
      end proc)(e1, e2, r));
    end do;
    if thunk :: procedure then
      return thunk();
    else
      # Add rule
      return Add(e), summary;
    end if;
  end proc;

  summarize_throughout := proc(e, kb :: t_kb, $)
    local x, kb1, e1, rng, summary, mr, f;
    if not hasfun(e, '{Sum,sum}', 'piecewise') then
      e;
    elif e :: '{specfunc({Weight, Categorical, exp, log, idx, And, Or, Not}),
                `+`, `*`, `^`, `..`, boolean, indexed, list}' then
      map(procname, _passed);
    elif e :: 'Context(anything, anything)' then
      kb1 := assert(op(1,e), kb);
      applyop(procname, 2, e, kb1);
    elif e :: 'specfunc(piecewise)' then
      kb_piecewise(e, kb, ((lhs, kb) -> lhs), summarize_throughout);
    elif e :: 'lam(name, anything, anything)' then
      x, kb1 := genType(op(1,e), op(2,e), kb);
      e1 := summarize_throughout(eval(op(3,e), op(1,e)=x), kb1);
      subsop(1=x, 3=e1, e);
    elif e :: 'ary(anything, name, anything)' then
      x, kb1 := genType(op(2,e), HInt(closed_bounds(0..op(1,e)-1)), kb);
      e1 := summarize_throughout(eval(op(3,e), op(2,e)=x), kb1);
      subsop(2=x, 3=e1, e);
    elif e :: 'And(specfunc({sum, Sum, product, Product}),
                   anyfunc(anything, name=range))' then
      rng := map(summarize_throughout, op([2,2],e), kb);
      x, kb1 := genType(op([2,1],e), HInt(closed_bounds(rng)), kb);
      e1 := eval(op(1,e), op([2,1],e)=x);
      if op(0, e) in '{sum, Sum}' and has(e1, 'piecewise') then
        mr, f := summarize(e1, kb, x, summary);
        if hasfun(mr, '{Fanout, Index}') then
          return Eval(simplify_factor_assuming(f, kb),
                      summary = Bucket(mr, x=rng));
        end if;
      end if;
      e1 := summarize_throughout(e1, kb1);
      subsop(2=(x=rng), 1=e1, e);
    else
      error "summarize_throughout doesn't know how to handle %1", e;
    end if;
  end proc;
end module; # Summary