Fix over-zealous fail-faster

Fix over-zealous fail-faster

sum(idx(a,i),i=n..n) should evaluate to idx(a,n)

# Teach Maple (through depends and eval) about our new binding forms.
# forall bind from 1st arg to 2nd arg.
# Ints,Sums,ints,sums bind from 2nd arg to 1st arg, and also from each element
#   of the 4th arg to the other elements on the left and to the 3rd arg.

`depends/forall` := proc(bvar, pred, x, $)
  depends(pred, x minus convert(bvar, 'set'))
end proc:

`depends/Ints` := proc(body, bvar, rng, loops, x, y, $)
  local xx, i;
  if nargs = 5 then
    xx := x; # y is ununsed and x lists the variables to look for
  else
    xx := y; # x is some KB and y lists the variables to look for
    if depends(x, y) then return true end if;
  end if;
  # don't remove bvar from xx!
  if depends(body, xx minus {bvar}) then return true end if;
  for i from nops(loops) to 1 by -1 do
    if depends(op([i,2],loops), xx) then return true end if;
    xx := xx minus {op([i,1],loops)};
  end do;
  depends(rng, xx)
end proc:
`depends/Sums` := eval(`depends/Ints`):
`depends/ints` := eval(`depends/Ints`):
`depends/sums` := eval(`depends/Ints`):

`eval/forall` := proc(e, eqs, $)
  local bvar, pred;
  bvar, pred := op(e);
  eval(op(0,e), eqs)(BindingTools:-generic_evalat(bvar, pred, eqs))
end proc:

`eval/Ints` := proc(e, eqs, $)
  local body, bvar, rng, loops, n, i;
  body, bvar, rng, loops := op(1..4, e);
  bvar, body := BindingTools:-generic_evalat(bvar, body, eqs);
  eval(op(0,e), eqs)(body, bvar,
                     BindingTools:-generic_evalatstar(rng, loops, eqs),
                     op(5..-1,e))
end proc:
`eval/Sums` := eval(`eval/Ints`):
`eval/ints` := eval(`eval/Ints`):
`eval/sums` := eval(`eval/Ints`):

`eval/Int` := proc(e, eqs, $)
  local body, bound, bvar;
  body, bound := op(1..2, e);
  if bound :: name then
    bound, body := BindingTools:-generic_evalat(bound, body, eqs);
  elif bound :: `=` then
    bvar := lhs(bound);
    bvar, body := BindingTools:-generic_evalat(bvar, body, eqs);
    bound := bvar = eval(rhs(bound), eqs);
  else
    body, bound := BindingTools:-generic_evalatstar(body, bound, eqs);
  end if;
  eval(op(0,e), eqs)(body, bound, op(eval([op(3..-1,e)], eqs)))
end proc:
`eval/Sum`     := eval(`eval/Int`):
`eval/Product` := eval(`eval/Int`):
`eval/int`     := eval(`eval/Int`):
`eval/sum`     := eval(`eval/Int`):
`eval/product` := eval(`eval/Int`):

#############################################################################

Loop := module ()
  option package;
  local intssums, enter_piecewise, wrap,
        Binder, Stmt, t_binder, t_stmt, t_exp,
        ModuleLoad;
  export
     # These first few are smart constructors (for themselves):
         ints, sums,
     # while these are "proper functions"
         mk_HArray, genLoop, unproducts, unproduct,
         peel, split, graft, rebase_lower, rebase_upper;
  # these names are not assigned (and should not be).  But they are
  # used as global names, so document that here.
  global Ints, Sums, csgn, sum;
  uses Hakaru, KB;

  t_binder := 'Binder(identical(product, Product, sum, Sum), t_kb)';
  t_stmt   := 'Stmt(anything, list, list)';
  t_exp    := '{Stmt(identical(exp), [], []),
                Stmt(identical(`^`), [anything], [])}';

  ints := proc() intssums('ints', 'int', _passed) end proc;
  sums := proc() intssums('sums', 'sum', _passed) end proc;

  intssums := proc(makes::name, make::name,
                   ee::anything, xx::name, rr::range, ll::list(name=range),
                   kb::t_kb:=empty, $)
    local t, x, e, r, l, kb1, w0, pp;
    t := `if`(make=int, HReal(open_bounds(rr)), HInt(closed_bounds(rr)));
    x, kb1 := genType(xx, mk_HArray(t, ll), kb);
    e := eval(ee, xx=x);
    if nops(ll) > 0 then
      kb1 := assert(size(x)=op([-1,2,2],ll)-op([-1,2,1],ll)+1, kb1);
    end if;
    e := simplify_assuming(e, kb1);
    r, l, kb1 := genLoop(rr, ll, kb, 'Integrand'(x,e));
    w0, pp := unproducts(e, x, l, kb1);
    if depends(w0, x) then
      'makes'(e, x, rr, ll)
    else
      w0 * foldl(''product'', 'make'(pp,x=r), op(l))
    end if
  end proc;

  mk_HArray := proc(t::t_type, loops::list(name=range), $)
    local res, i;
    res := t;
    for i in loops do res := HArray(res) end do;
    res
  end proc;

  genLoop := proc(e, loops::list(name=range), kb::t_kb)
    local kb1, rng, ind, do_subst, i;
    kb1 := kb;
    rng := table();
    ind := table();
    do_subst := e -> foldl(((e,eq) -> eval(e, op([lhs(eq),1],loops)=rhs(eq))),
                           e, entries(ind, 'pairs'));
    for i from nops(loops) to 1 by -1 do
      rng[i] := do_subst(op([i,2],loops));
      ind[i], kb1 := genType(op([i,1],loops), HInt(closed_bounds(rng[i])),
                               kb1, _rest);
    end do;
    do_subst(e), zip(`=`, [entries(ind, 'nolist')],
                          [entries(rng, 'nolist')]), kb1
  end proc;

  unproducts := proc(w, x::name, loops::list(name=range), kb::t_kb, $)
    local w0, pp, j, w1, w2, loop;
    w0 := 1;
    pp := w;
    for j from nops(loops) to 1 by -1 do
      w1, pp := op(unproduct(pp, x, op(j,loops), [], `*`, kb, kb));
      # separate out each of the factors in w1, as they might have different
      # variable dependencies, which can be exploited by other routines
      w2 := convert(w1, 'list', '`*`');
      for loop in [op(j+1..-1, loops)] do
        w2 := map((w -> product(eval(w, x=idx(x,lhs(loop))), loop)), w2);
      end do;
      w0 := w0 * `*`(op(w2));
      # w0 := w0 * foldl(product, w1, op(j+1..-1, loops));
    end do;
    # Rewrite ... * piecewise(i<=kk-1, xs^2, 1)
    #      to ... * xs ^ (2*piecewise(i<=kk-1, 1))
    # because the latter is easier to integrate and recognize with respect to xs
    pp := maptype(`*`,
      proc (p)
        local n, s, r;
        if p :: 'And(specfunc(piecewise), anyfunc(freeof(x), anything, 1))' then
          n := indets(op(1,p),name);
          if op(2,p) :: {'exp(anything)', '`^`'('freeof'(n),'anything')} then
            s, r := selectremove(depends, convert(op([2,-1],p),'list','`*`'), n);
            subsop(-1 = `*`(piecewise(op(1,p), `*`(op(s))), op(r)), op(2,p))
          else
            s, r := selectremove(depends, convert(op(2,p),'list','`*`'), n);
            `*`(op(r)) ^ piecewise(op(1,p), 1)
              * `if`(nops(s) > 0, piecewise(op(1,p), `*`(op(s)), 1), 1)
          end if
        else
          p
        end if
      end proc,
      pp);
    w0, pp
  end proc;

  # Find [w1,pp] so that
  #   wrap(heap,w,mode,kb1,kb0)
  #   = w1*product(eval(pp,var=idx(var,lhs(loop))),loop)
  # making w1 depend on var as little as possible.
  # The flag "mode" should be `+` if "heap" contains an entry of the form
  # t_exp, or `*` otherwise.
  unproduct := proc(w, var::name, loop::(name=range),
                    heap::list, mode::identical(`*`,`+`),
                    kb1::t_kb, kb0::t_kb, $)
    local ind, res, dummy, kb, kbThen, i, w1, pp, s, r, x;
    if not depends(w, var) then
      return [wrap(heap, w, mode, kb1, kb0), 1]
    end if;
    ind := map2(op, 2, indets(w, idx(identical(var), anything)));
    if nops(ind) = 1 then
      ind := op(ind);
      # Make sure ind contains no bound variables before lifting it!
      # So, check that "extract using indets" and "rename using eval" commute.
      s := indets(ind, 'name');
      s := map(proc(x,$) local y; `if`(depends(ind,x), x=y, NULL) end proc, s);
      if indets(eval(w, s), idx(identical(var), anything))
                = {idx(var, eval(ind, s))} then
        kb  := assert(lhs(loop)=ind, kb1); # BUG! bijectivity assumed!
        res := subs(idx(var,ind) = idx(var,lhs(loop)), w);
        res := wrap(heap, res, mode, kb, kb0);
        res := subs(idx(var,lhs(loop))=dummy, res);
        if not depends(res, var) then
          return [1, subs(dummy=var, res)]
        end if
      end if
    end if;
    if w :: mode then
      res := map(unproduct, `if`(mode=`*`, list_of_mul(w,kb1), [op(w)]),
                 var, loop, heap, mode, kb1, kb0);
      return [`*`(op(map2(op,1,res))), `*`(op(map2(op,2,res)))]
    end if;
    if w :: 'specfunc(piecewise)' then
      kb := kb1;
      for i from 1 to nops(w) do
        if i :: even then
          kbThen := assert(    op(i-1,w) , kb);
          kb     := assert(Not(op(i-1,w)), kb);
          w1[i], pp[i] := op(unproduct(op(i,w),var,loop,heap,mode,kbThen,kb0))
        elif i = nops(w) then
          w1[i], pp[i] := op(unproduct(op(i,w),var,loop,heap,mode,kb    ,kb0))
        end if
      end do;
      return [`*`(entries(w1,'nolist')), `*`(entries(pp,'nolist'))]
    end if;
    if mode = `*` then
      if w :: (anything^freeof(var)) then
        return unproduct(op(1,w), var, loop,
                         [op(heap), Stmt(`^`, [], [op(2,w)])], `*`, kb1, kb0)
      elif w :: exp(anything) then
        return unproduct(op(1,w), var, loop,
                         [op(heap), Stmt(exp, [], [])], `+`, kb1, kb0)
      elif w :: (freeof(var)^anything) then
        return unproduct(op(2,w), var, loop,
                         [op(heap), Stmt(`^`, [op(1,w)], [])], `+`, kb1, kb0)
      end if
    end if;
    if mode = `+` and w :: `*` then
      s, r := selectremove(depends, w, var);
      if s :: `*` then
        # Nonlinear %1 (time to reread kiselyov-lifted?)
      else
        return unproduct(s, var, loop,
                         [op(heap), Stmt(`*`, [], [r])], `+`, kb1, kb0)
      end if
    end if;
    if w :: And(specfunc(`if`(mode = `*`, {product, Product}, {sum, Sum})),
                anyfunc(anything, name=range(freeof(var)))) then
      x, kb := genType(op([2,1],w),
                       HInt(Bound(`>=`,op([2,2,1],w)),
                            Bound(`<=`,op([2,2,2],w))),
                       kb1,
                       w, var, loop, heap);
      return unproduct(eval(op(1,w), op([2,1],w)=x), var, loop,
                       [op(heap), Binder(op(0,w), kb1)], mode, kb, kb0)
    end if;
    if mode = `*` and w :: '{`+`, specfunc({sum, Sum})}' then
      # Maybe this w is one of those big sums involving products that are
      # always equal to 1, left behind by the density of Categorical
      w1 := graft(split(peel(lift_piecewise(w))));
      w1 := combine(rebase_upper(w1));
      w1 := combine(rebase_lower(w1));
      return [wrap(heap, w1, mode, kb1, kb0), 1]
    end if;
    return [wrap(heap, w, mode, kb1, kb0), 1]
  end proc;

  enter_piecewise := proc(ee, kb0::t_kb, mode::identical(`*`,`+`), $)
    local e, kb, mo;
    e  := ee;
    kb := kb0;
    mo := mode();
    while e :: 'specfunc(piecewise)' and nops(e) = 3 do
      if op(3,e) = mo then
        kb := assert(op(1,e), kb);
        e := op(2,e);
      elif op(2,e) = mo then
        kb := assert(Not(op(1,e)), kb);
        e := op(3,e);
      else
        break;
      end if;
    end do;
    e, kb
  end proc;

  wrap := proc(heap::list, e1, mode1::identical(`*`,`+`),
               kb1::t_kb, kb0::t_kb, $)
    local e, kb, mode, i, entry, rest, var, new_rng, make,
       dom_spec, w, arrrgs;
    e    := e1;
    kb   := kb1;
    mode := mode1;
    for i from nops(heap) to 1 by -1 do
      entry := op(i,heap);
      if entry :: t_binder then
        if not (op(1,entry) in `if`(mode=`+`, {sum,Sum},
                                              {product,Product})) then
          print("Warning: heap mode inconsistency", heap, mode1)
        end if;
        e := simplify_assuming(e, op(2,entry));
        e, kb := enter_piecewise(e, kb, mode);
        rest := kb_subtract(kb, op(2,entry));
        new_rng, rest := selectremove(type, rest,
          {[identical(genType), name, specfunc(HInt)],
           [identical(genLet), name, anything]});
        if not (new_rng :: [list]) then
          error "kb_subtract should return exactly one gen*"
        end if;
        new_rng := op(new_rng);
        var     := op(2,new_rng);
        if op(1,new_rng) = genType then
          make    := op(1,entry);
          new_rng := range_of_HInt(op(3,new_rng));
        else # op(1,new_rng) = genLet
          make    := eval;
          new_rng := op(3,new_rng);
        end if;
        dom_spec, rest := selectremove(depends,
          map(proc(a::[identical(assert),anything],$) op(2,a) end proc, rest),
          var);
        (e, w) := selectremove(depends, convert(e, 'list', `*`), var);
        w := `*`(op(w));
        if mode = `*` and not (w = 1) then
          w := w ^ `if`(make=eval,eval,Sum)
                       (piecewise_And(dom_spec, 1, 0), var=new_rng);
        end if;
        e := w * make(piecewise_And(dom_spec, `*`(op(e)), mode()), var=new_rng);
        kb := foldr(assert, op(2,entry), op(rest));
      elif entry :: t_stmt then
        # We evaluate arrrgs first, in case op(1,stmt) is an operation (such as
        # piecewise) that looks ahead at how many arguments it is passed before
        # they are evaluated.
        arrrgs := op(op(2,entry)), e, op(op(3,entry));
        e      := op(1,entry)(arrrgs);
        if entry :: t_exp then
          if mode <> `+` then
            print("Warning: heap mode inconsistency?", heap, mode1)
          end if;
          mode := `*`;
        end if
      else error "Malformed heap entry %1", entry end if
    end do;
    if mode <> `*` then
      print("Warning: heap mode inconsistency??", heap, mode1)
    end if;
    e, kb := enter_piecewise(e, kb, mode);
    rest := kb_subtract(kb, kb0);
    rest := map(proc(a::[identical(assert),anything],$) op(2,a) end proc, rest);
    piecewise_And(rest,e,mode())
  end proc;

  # Rewrite product(piecewise(i+42=lo+42,th,el),i=lo..hi)
  # to eval(th,i=lo)*product(el,i=lo+1..hi)
  peel := proc(ee, $)
    subsindets(ee, 'And(specfunc({sum,Sum,product,Product}),
                        anyfunc(specfunc(piecewise), name=range))',
    proc(e, $)
      local body, x, r, line, test, make, here, rest, res;
      body := op(1,e);
      if not (1<nops(body) and op(1,body)::{`=`,`<`,`<=`}) then return e end if;
      x, r := op(op(2,e));
      line := op([1,1],body) - op([1,2],body);
      if 1 = degree(line, x) then
        if op(1,body) :: `=`  then
          test := proc (y,z,$)
            if Testzero(eval(line, x=y)) then true
            else FAIL end if
          end proc;
        elif op(1,body) :: `<` then
          test := proc (y,z,$)
            local l;
            l := [eval(line, x=y), eval(line, x=z)];
            if   l :: [negative, nonnegative] then true
            elif l :: [nonnegative, negative] then false
            else FAIL end if
          end proc;
        elif op(1,body) :: `<=` then
          test := proc (y,z,$)
            local l;
            l := [eval(line, x=y), eval(line, x=z)];
            if   l :: [nonpositive, positive] then true
            elif l :: [positive, nonpositive] then false
            else FAIL end if
          end proc;
        end if;
        if op(0,e) in {sum,Sum} then
          make := `+`;
        elif op(0,e) in {product,Product} then
          make := `*`;
        end if;
        here := op(2,body);
        if nops(body)=2 then
          rest := 0;
        elif nops(body)=3 then
          rest := op(3,body);
        elif {op([1,0],body) , op([3,0],body)} = {`<`, `<=`}
          and op([1,1],body) = op([3,2],body)
          and op([1,2],body) = op([3,1],body) then
          rest := op(4,body);
        else
          rest := subsop(1=NULL,2=NULL,body);
        end if;
        res := test(lhs(r), lhs(r)+1);
        if res <> FAIL then
          return make(eval(`if`(res, here, rest), x=lhs(r)),
                      subsop(1 = `if`(res, rest, here), [2,2,1]=lhs(r)+1, e));
        end if;
        res := test(rhs(r), rhs(r)-1);
        if res <> FAIL then
          return make(eval(`if`(res, here, rest), x=rhs(r)),
                      subsop(1 = `if`(res, rest, here), [2,2,2]=rhs(r)-1, e));
        end if;
      end if;
      e
    end proc);
  end proc:

  # Expand sum(a*(b-c),q) to sum(a*b,q)-sum(a*c,q)
  split := proc(ee, $)
    subsindets(ee, 'And(specfunc({sum,Sum}),
                        anyfunc(And(`*`,Not(`*`(Not(`+`)))),name=anything))',
    proc(e, $)
      local terms, x;
      terms := convert(expand(op(1,e), op(indets(op(1,e), function))),
                       'list', `+`);
      x := op([2,1],e);
      `+`(op(map(proc(term, $)
        local s, r;
        s, r := selectremove(depends, convert(term, 'list', `*`), x);
        `*`(op(r), subsop(1=`*`(op(s)),e))
      end proc, terms)))
    end proc)
  end proc:

  # Simplify f(lo-1)*product(f(i),i=lo..hi) to product(f(i),i=lo-1..hi)
  graft := proc(ee, $)
    subsindets(ee, 'Or(And(`*`,Not(`*`(Not(specfunc({product,Product}))))),
                       And(`+`,Not(`+`(Not(specfunc({sum    ,Sum    }))))))',
    proc(e, $)
      local produce, factors, i, j;
      produce := `if`(e::`*`, '{product,Product}',
                              '{sum    ,Sum    }');
      factors := sort(convert(e,'list'),
                      key = (factor -> -numboccur(factor,produce)));
      for i from nops(factors) to 2 by -1 do
        for j from i-1 to 1 by -1 do
          if op(j,factors) :: 'And'('specfunc'(produce),
                                    'anyfunc(anything,name=range)') then
            if Testzero(op(i,factors) - eval(op([j,1],factors),
                 op([j,2,1],factors)=op([j,2,2,1],factors)-1)) then
              factors := subsop(i=NULL,applyop(`-`,[j,2,2,1],factors,1));
              break
            elif Testzero(op(i,factors) - eval(op([j,1],factors),
                   op([j,2,1],factors)=op([j,2,2,2],factors)+1)) then
              factors := subsop(i=NULL,applyop(`+`,[j,2,2,2],factors,1));
              break
            end if
          end if
        end do
      end do;
      op(0,e)(op(factors))
    end proc)
  end proc:

  # Normalize sum(f(i),i=2..hi) to sum(f(i+2),i=0..hi-2)
  rebase_lower := proc(ee, $)
    subsindets(ee, 'And(specfunc({sum,Sum,product,Product}),
                        anyfunc(anything,
                          name=Not({0,SymbolicInfinity,undefined})..anything))',
    proc(e, $)
      subsop([2,2,1]=0,
             applyop(`-`,
                     [2,2,2],
                     applyop(eval, 1, e, op([2,1],e)=op([2,1],e)+op([2,2,1],e)),
                     op([2,2,1],e)))
    end proc)
  end proc:

  # Normalize sum(f(i),i=lo..2) to sum(f(i+2),i=lo-2..0)
  rebase_upper := proc(ee, $)
    subsindets(ee, 'And(specfunc({sum,Sum,product,Product}),
                        anyfunc(anything,
                          name=anything..Not({0,SymbolicInfinity,undefined})))',
    proc(e, $)
      subsop([2,2,2]=0,
             applyop(`-`,
                     [2,2,1],
                     applyop(eval, 1, e, op([2,1],e)=op([2,1],e)+op([2,2,2],e)),
                     op([2,2,2],e)))
    end proc)
  end proc:

  ModuleLoad := proc($)
    # Override csgn to work a little bit harder on piecewise and sum
    # (to get rid of csgn(1/2+1/2*sum(piecewise(...,1,0),...))
    #  produced by int on a Gaussian mixture model)
    unprotect(csgn);
    csgn := overload([
      # Handle if the csgn of a piecewise doesn't depend on which branch
      proc(a :: specfunc(piecewise), $)
        option overload;
        local r, i;
        r := {seq(`if`(i::even or i=nops(a), csgn(op(i,a)), NULL),
                  i=1..nops(a))};
        if nops(r)=1 then return op(r) end if;
        if not assigned(_Envsignum0) then
          r := r minus {0};
          if nops(r)=1 then return op(r) end if;
        end if;
        error "invalid input: cannot csgn %1", a;
      end proc,
      # Handle if the csgn of a sum doesn't depend on the bound variable
      proc(a :: And(specfunc({sum, Sum}), anyfunc(anything, name=range)), $)
        option overload;
        local r;
        r := csgn(op(1,a));
        if not depends(r,op([2,1],a)) then
          return signum(op([2,2,2],a)+1-op([2,2,1],a)) * r
        end if;
        error "invalid input: cannot csgn %1", a;
      end proc,
      csgn]);
    protect(csgn);

    # Override sum to fail faster
    unprotect(sum);
    sum := overload([
      proc(f :: Not({`+`,`+`^integer}),
           k :: name=And(range,Not(range(rational))), $)
        option overload;
        if not (`-`(op(rhs(k))) :: 'rational')
           and not (subsindets(f, 'anything^integer', f->op(1,f))
                    :: '{`+`,And(`*`,Not(`*`(Not(`+`))))}')
           and depends(indets(f, 'specfunc(idx)'), op(1,k)) then
          'procname(_passed)'
        else
          error "invalid input: cannot fast-fail sum(%1, %2)", _passed
        end if
      end proc,
      sum]);
    protect(sum);
  end proc;

  ModuleLoad();

end module; # Loop

# Teach Maple (through depends and eval) about our new binding forms.
# forall bind from 1st arg to 2nd arg.
# Ints,Sums,ints,sums bind from 2nd arg to 1st arg, and also from each element
#   of the 4th arg to the other elements on the left and to the 3rd arg.

`depends/forall` := proc(bvar, pred, x, $)
  depends(pred, x minus convert(bvar, 'set'))
end proc:

`depends/Ints` := proc(body, bvar, rng, loops, x, y, $)
  local xx, i;
  if nargs = 5 then
    xx := x; # y is ununsed and x lists the variables to look for
  else
    xx := y; # x is some KB and y lists the variables to look for
    if depends(x, y) then return true end if;
  end if;
  # don't remove bvar from xx!
  if depends(body, xx minus {bvar}) then return true end if;
  for i from nops(loops) to 1 by -1 do
    if depends(op([i,2],loops), xx) then return true end if;
    xx := xx minus {op([i,1],loops)};
  end do;
  depends(rng, xx)
end proc:
`depends/Sums` := eval(`depends/Ints`):
`depends/ints` := eval(`depends/Ints`):
`depends/sums` := eval(`depends/Ints`):

`eval/forall` := proc(e, eqs, $)
  local bvar, pred;
  bvar, pred := op(e);
  eval(op(0,e), eqs)(BindingTools:-generic_evalat(bvar, pred, eqs))
end proc:

`eval/Ints` := proc(e, eqs, $)
  local body, bvar, rng, loops, n, i;
  body, bvar, rng, loops := op(1..4, e);
  bvar, body := BindingTools:-generic_evalat(bvar, body, eqs);
  eval(op(0,e), eqs)(body, bvar,
                     BindingTools:-generic_evalatstar(rng, loops, eqs),
                     op(5..-1,e))
end proc:
`eval/Sums` := eval(`eval/Ints`):
`eval/ints` := eval(`eval/Ints`):
`eval/sums` := eval(`eval/Ints`):

`eval/Int` := proc(e, eqs, $)
  local body, bound, bvar;
  body, bound := op(1..2, e);
  if bound :: name then
    bound, body := BindingTools:-generic_evalat(bound, body, eqs);
  elif bound :: `=` then
    bvar := lhs(bound);
    bvar, body := BindingTools:-generic_evalat(bvar, body, eqs);
    bound := bvar = eval(rhs(bound), eqs);
  else
    body, bound := BindingTools:-generic_evalatstar(body, bound, eqs);
  end if;
  eval(op(0,e), eqs)(body, bound, op(eval([op(3..-1,e)], eqs)))
end proc:
`eval/Sum`     := eval(`eval/Int`):
`eval/Product` := eval(`eval/Int`):
`eval/int`     := eval(`eval/Int`):
`eval/sum`     := eval(`eval/Int`):
`eval/product` := eval(`eval/Int`):

#############################################################################

Loop := module ()
  option package;
  local intssums, enter_piecewise, wrap,
        Binder, Stmt, t_binder, t_stmt, t_exp,
        ModuleLoad;
  export
     # These first few are smart constructors (for themselves):
         ints, sums,
     # while these are "proper functions"
         mk_HArray, genLoop, unproducts, unproduct,
         peel, split, graft, rebase_lower, rebase_upper;
  # these names are not assigned (and should not be).  But they are
  # used as global names, so document that here.
  global Ints, Sums, csgn, sum;
  uses Hakaru, KB;

  t_binder := 'Binder(identical(product, Product, sum, Sum), t_kb)';
  t_stmt   := 'Stmt(anything, list, list)';
  t_exp    := '{Stmt(identical(exp), [], []),
                Stmt(identical(`^`), [anything], [])}';

  ints := proc() intssums('ints', 'int', _passed) end proc;
  sums := proc() intssums('sums', 'sum', _passed) end proc;

  intssums := proc(makes::name, make::name,
                   ee::anything, xx::name, rr::range, ll::list(name=range),
                   kb::t_kb:=empty, $)
    local t, x, e, r, l, kb1, w0, pp;
    t := `if`(make=int, HReal(open_bounds(rr)), HInt(closed_bounds(rr)));
    x, kb1 := genType(xx, mk_HArray(t, ll), kb);
    e := eval(ee, xx=x);
    if nops(ll) > 0 then
      kb1 := assert(size(x)=op([-1,2,2],ll)-op([-1,2,1],ll)+1, kb1);
    end if;
    e := simplify_assuming(e, kb1);
    r, l, kb1 := genLoop(rr, ll, kb, 'Integrand'(x,e));
    w0, pp := unproducts(e, x, l, kb1);
    if depends(w0, x) then
      'makes'(e, x, rr, ll)
    else
      w0 * foldl(''product'', 'make'(pp,x=r), op(l))
    end if
  end proc;

  mk_HArray := proc(t::t_type, loops::list(name=range), $)
    local res, i;
    res := t;
    for i in loops do res := HArray(res) end do;
    res
  end proc;

  genLoop := proc(e, loops::list(name=range), kb::t_kb)
    local kb1, rng, ind, do_subst, i;
    kb1 := kb;
    rng := table();
    ind := table();
    do_subst := e -> foldl(((e,eq) -> eval(e, op([lhs(eq),1],loops)=rhs(eq))),
                           e, entries(ind, 'pairs'));
    for i from nops(loops) to 1 by -1 do
      rng[i] := do_subst(op([i,2],loops));
      ind[i], kb1 := genType(op([i,1],loops), HInt(closed_bounds(rng[i])),
                               kb1, _rest);
    end do;
    do_subst(e), zip(`=`, [entries(ind, 'nolist')],
                          [entries(rng, 'nolist')]), kb1
  end proc;

  unproducts := proc(w, x::name, loops::list(name=range), kb::t_kb, $)
    local w0, pp, j, w1, w2, loop;
    w0 := 1;
    pp := w;
    for j from nops(loops) to 1 by -1 do
      w1, pp := op(unproduct(pp, x, op(j,loops), [], `*`, kb, kb));
      # separate out each of the factors in w1, as they might have different
      # variable dependencies, which can be exploited by other routines
      w2 := convert(w1, 'list', '`*`');
      for loop in [op(j+1..-1, loops)] do
        w2 := map((w -> product(eval(w, x=idx(x,lhs(loop))), loop)), w2);
      end do;
      w0 := w0 * `*`(op(w2));
      # w0 := w0 * foldl(product, w1, op(j+1..-1, loops));
    end do;
    # Rewrite ... * piecewise(i<=kk-1, xs^2, 1)
    #      to ... * xs ^ (2*piecewise(i<=kk-1, 1))
    # because the latter is easier to integrate and recognize with respect to xs
    pp := maptype(`*`,
      proc (p)
        local n, s, r;
        if p :: 'And(specfunc(piecewise), anyfunc(freeof(x), anything, 1))' then
          n := indets(op(1,p),name);
          if op(2,p) :: {'exp(anything)', '`^`'('freeof'(n),'anything')} then
            s, r := selectremove(depends, convert(op([2,-1],p),'list','`*`'), n);
            subsop(-1 = `*`(piecewise(op(1,p), `*`(op(s))), op(r)), op(2,p))
          else
            s, r := selectremove(depends, convert(op(2,p),'list','`*`'), n);
            `*`(op(r)) ^ piecewise(op(1,p), 1)
              * `if`(nops(s) > 0, piecewise(op(1,p), `*`(op(s)), 1), 1)
          end if
        else
          p
        end if
      end proc,
      pp);
    w0, pp
  end proc;

  # Find [w1,pp] so that
  #   wrap(heap,w,mode,kb1,kb0)
  #   = w1*product(eval(pp,var=idx(var,lhs(loop))),loop)
  # making w1 depend on var as little as possible.
  # The flag "mode" should be `+` if "heap" contains an entry of the form
  # t_exp, or `*` otherwise.
  unproduct := proc(w, var::name, loop::(name=range),
                    heap::list, mode::identical(`*`,`+`),
                    kb1::t_kb, kb0::t_kb, $)
    local ind, res, dummy, kb, kbThen, i, w1, pp, s, r, x;
    if not depends(w, var) then
      return [wrap(heap, w, mode, kb1, kb0), 1]
    end if;
    ind := map2(op, 2, indets(w, idx(identical(var), anything)));
    if nops(ind) = 1 then
      ind := op(ind);
      # Make sure ind contains no bound variables before lifting it!
      # So, check that "extract using indets" and "rename using eval" commute.
      s := indets(ind, 'name');
      s := map(proc(x,$) local y; `if`(depends(ind,x), x=y, NULL) end proc, s);
      if indets(eval(w, s), idx(identical(var), anything))
                = {idx(var, eval(ind, s))} then
        kb  := assert(lhs(loop)=ind, kb1); # BUG! bijectivity assumed!
        res := subs(idx(var,ind) = idx(var,lhs(loop)), w);
        res := wrap(heap, res, mode, kb, kb0);
        res := subs(idx(var,lhs(loop))=dummy, res);
        if not depends(res, var) then
          return [1, subs(dummy=var, res)]
        end if
      end if
    end if;
    if w :: mode then
      res := map(unproduct, `if`(mode=`*`, list_of_mul(w,kb1), [op(w)]),
                 var, loop, heap, mode, kb1, kb0);
      return [`*`(op(map2(op,1,res))), `*`(op(map2(op,2,res)))]
    end if;
    if w :: 'specfunc(piecewise)' then
      kb := kb1;
      for i from 1 to nops(w) do
        if i :: even then
          kbThen := assert(    op(i-1,w) , kb);
          kb     := assert(Not(op(i-1,w)), kb);
          w1[i], pp[i] := op(unproduct(op(i,w),var,loop,heap,mode,kbThen,kb0))
        elif i = nops(w) then
          w1[i], pp[i] := op(unproduct(op(i,w),var,loop,heap,mode,kb    ,kb0))
        end if
      end do;
      return [`*`(entries(w1,'nolist')), `*`(entries(pp,'nolist'))]
    end if;
    if mode = `*` then
      if w :: (anything^freeof(var)) then
        return unproduct(op(1,w), var, loop,
                         [op(heap), Stmt(`^`, [], [op(2,w)])], `*`, kb1, kb0)
      elif w :: exp(anything) then
        return unproduct(op(1,w), var, loop,
                         [op(heap), Stmt(exp, [], [])], `+`, kb1, kb0)
      elif w :: (freeof(var)^anything) then
        return unproduct(op(2,w), var, loop,
                         [op(heap), Stmt(`^`, [op(1,w)], [])], `+`, kb1, kb0)
      end if
    end if;
    if mode = `+` and w :: `*` then
      s, r := selectremove(depends, w, var);
      if s :: `*` then
        # Nonlinear %1 (time to reread kiselyov-lifted?)
      else
        return unproduct(s, var, loop,
                         [op(heap), Stmt(`*`, [], [r])], `+`, kb1, kb0)
      end if
    end if;
    if w :: And(specfunc(`if`(mode = `*`, {product, Product}, {sum, Sum})),
                anyfunc(anything, name=range(freeof(var)))) then
      x, kb := genType(op([2,1],w),
                       HInt(Bound(`>=`,op([2,2,1],w)),
                            Bound(`<=`,op([2,2,2],w))),
                       kb1,
                       w, var, loop, heap);
      return unproduct(eval(op(1,w), op([2,1],w)=x), var, loop,
                       [op(heap), Binder(op(0,w), kb1)], mode, kb, kb0)
    end if;
    if mode = `*` and w :: '{`+`, specfunc({sum, Sum})}' then
      # Maybe this w is one of those big sums involving products that are
      # always equal to 1, left behind by the density of Categorical
      w1 := graft(split(peel(lift_piecewise(w))));
      w1 := combine(rebase_upper(w1));
      w1 := combine(rebase_lower(w1));
      return [wrap(heap, w1, mode, kb1, kb0), 1]
    end if;
    return [wrap(heap, w, mode, kb1, kb0), 1]
  end proc;

  enter_piecewise := proc(ee, kb0::t_kb, mode::identical(`*`,`+`), $)
    local e, kb, mo;
    e  := ee;
    kb := kb0;
    mo := mode();
    while e :: 'specfunc(piecewise)' and nops(e) = 3 do
      if op(3,e) = mo then
        kb := assert(op(1,e), kb);
        e := op(2,e);
      elif op(2,e) = mo then
        kb := assert(Not(op(1,e)), kb);
        e := op(3,e);
      else
        break;
      end if;
    end do;
    e, kb
  end proc;

  wrap := proc(heap::list, e1, mode1::identical(`*`,`+`),
               kb1::t_kb, kb0::t_kb, $)
    local e, kb, mode, i, entry, rest, var, new_rng, make,
       dom_spec, w, arrrgs;
    e    := e1;
    kb   := kb1;
    mode := mode1;
    for i from nops(heap) to 1 by -1 do
      entry := op(i,heap);
      if entry :: t_binder then
        if not (op(1,entry) in `if`(mode=`+`, {sum,Sum},
                                              {product,Product})) then
          print("Warning: heap mode inconsistency", heap, mode1)
        end if;
        e := simplify_assuming(e, op(2,entry));
        e, kb := enter_piecewise(e, kb, mode);
        rest := kb_subtract(kb, op(2,entry));
        new_rng, rest := selectremove(type, rest,
          {[identical(genType), name, specfunc(HInt)],
           [identical(genLet), name, anything]});
        if not (new_rng :: [list]) then
          error "kb_subtract should return exactly one gen*"
        end if;
        new_rng := op(new_rng);
        var     := op(2,new_rng);
        if op(1,new_rng) = genType then
          make    := op(1,entry);
          new_rng := range_of_HInt(op(3,new_rng));
        else # op(1,new_rng) = genLet
          make    := eval;
          new_rng := op(3,new_rng);
        end if;
        dom_spec, rest := selectremove(depends,
          map(proc(a::[identical(assert),anything],$) op(2,a) end proc, rest),
          var);
        (e, w) := selectremove(depends, convert(e, 'list', `*`), var);
        w := `*`(op(w));
        if mode = `*` and not (w = 1) then
          w := w ^ `if`(make=eval,eval,Sum)
                       (piecewise_And(dom_spec, 1, 0), var=new_rng);
        end if;
        e := w * make(piecewise_And(dom_spec, `*`(op(e)), mode()), var=new_rng);
        kb := foldr(assert, op(2,entry), op(rest));
      elif entry :: t_stmt then
        # We evaluate arrrgs first, in case op(1,stmt) is an operation (such as
        # piecewise) that looks ahead at how many arguments it is passed before
        # they are evaluated.
        arrrgs := op(op(2,entry)), e, op(op(3,entry));
        e      := op(1,entry)(arrrgs);
        if entry :: t_exp then
          if mode <> `+` then
            print("Warning: heap mode inconsistency?", heap, mode1)
          end if;
          mode := `*`;
        end if
      else error "Malformed heap entry %1", entry end if
    end do;
    if mode <> `*` then
      print("Warning: heap mode inconsistency??", heap, mode1)
    end if;
    e, kb := enter_piecewise(e, kb, mode);
    rest := kb_subtract(kb, kb0);
    rest := map(proc(a::[identical(assert),anything],$) op(2,a) end proc, rest);
    piecewise_And(rest,e,mode())
  end proc;

  # Rewrite product(piecewise(i+42=lo+42,th,el),i=lo..hi)
  # to eval(th,i=lo)*product(el,i=lo+1..hi)
  peel := proc(ee, $)
    subsindets(ee, 'And(specfunc({sum,Sum,product,Product}),
                        anyfunc(specfunc(piecewise), name=range))',
    proc(e, $)
      local body, x, r, line, test, make, here, rest, res;
      body := op(1,e);
      if not (1<nops(body) and op(1,body)::{`=`,`<`,`<=`}) then return e end if;
      x, r := op(op(2,e));
      line := op([1,1],body) - op([1,2],body);
      if 1 = degree(line, x) then
        if op(1,body) :: `=`  then
          test := proc (y,z,$)
            if Testzero(eval(line, x=y)) then true
            else FAIL end if
          end proc;
        elif op(1,body) :: `<` then
          test := proc (y,z,$)
            local l;
            l := [eval(line, x=y), eval(line, x=z)];
            if   l :: [negative, nonnegative] then true
            elif l :: [nonnegative, negative] then false
            else FAIL end if
          end proc;
        elif op(1,body) :: `<=` then
          test := proc (y,z,$)
            local l;
            l := [eval(line, x=y), eval(line, x=z)];
            if   l :: [nonpositive, positive] then true
            elif l :: [positive, nonpositive] then false
            else FAIL end if
          end proc;
        end if;
        if op(0,e) in {sum,Sum} then
          make := `+`;
        elif op(0,e) in {product,Product} then
          make := `*`;
        end if;
        here := op(2,body);
        if nops(body)=2 then
          rest := 0;
        elif nops(body)=3 then
          rest := op(3,body);
        elif {op([1,0],body) , op([3,0],body)} = {`<`, `<=`}
          and op([1,1],body) = op([3,2],body)
          and op([1,2],body) = op([3,1],body) then
          rest := op(4,body);
        else
          rest := subsop(1=NULL,2=NULL,body);
        end if;
        res := test(lhs(r), lhs(r)+1);
        if res <> FAIL then
          return make(eval(`if`(res, here, rest), x=lhs(r)),
                      subsop(1 = `if`(res, rest, here), [2,2,1]=lhs(r)+1, e));
        end if;
        res := test(rhs(r), rhs(r)-1);
        if res <> FAIL then
          return make(eval(`if`(res, here, rest), x=rhs(r)),
                      subsop(1 = `if`(res, rest, here), [2,2,2]=rhs(r)-1, e));
        end if;
      end if;
      e
    end proc);
  end proc:

  # Expand sum(a*(b-c),q) to sum(a*b,q)-sum(a*c,q)
  split := proc(ee, $)
    subsindets(ee, 'And(specfunc({sum,Sum}),
                        anyfunc(And(`*`,Not(`*`(Not(`+`)))),name=anything))',
    proc(e, $)
      local terms, x;
      terms := convert(expand(op(1,e), op(indets(op(1,e), function))),
                       'list', `+`);
      x := op([2,1],e);
      `+`(op(map(proc(term, $)
        local s, r;
        s, r := selectremove(depends, convert(term, 'list', `*`), x);
        `*`(op(r), subsop(1=`*`(op(s)),e))
      end proc, terms)))
    end proc)
  end proc:

  # Simplify f(lo-1)*product(f(i),i=lo..hi) to product(f(i),i=lo-1..hi)
  graft := proc(ee, $)
    subsindets(ee, 'Or(And(`*`,Not(`*`(Not(specfunc({product,Product}))))),
                       And(`+`,Not(`+`(Not(specfunc({sum    ,Sum    }))))))',
    proc(e, $)
      local produce, factors, i, j;
      produce := `if`(e::`*`, '{product,Product}',
                              '{sum    ,Sum    }');
      factors := sort(convert(e,'list'),
                      key = (factor -> -numboccur(factor,produce)));
      for i from nops(factors) to 2 by -1 do
        for j from i-1 to 1 by -1 do
          if op(j,factors) :: 'And'('specfunc'(produce),
                                    'anyfunc(anything,name=range)') then
            if Testzero(op(i,factors) - eval(op([j,1],factors),
                 op([j,2,1],factors)=op([j,2,2,1],factors)-1)) then
              factors := subsop(i=NULL,applyop(`-`,[j,2,2,1],factors,1));
              break
            elif Testzero(op(i,factors) - eval(op([j,1],factors),
                   op([j,2,1],factors)=op([j,2,2,2],factors)+1)) then
              factors := subsop(i=NULL,applyop(`+`,[j,2,2,2],factors,1));
              break
            end if
          end if
        end do
      end do;
      op(0,e)(op(factors))
    end proc)
  end proc:

  # Normalize sum(f(i),i=2..hi) to sum(f(i+2),i=0..hi-2)
  rebase_lower := proc(ee, $)
    subsindets(ee, 'And(specfunc({sum,Sum,product,Product}),
                        anyfunc(anything,
                          name=Not({0,SymbolicInfinity,undefined})..anything))',
    proc(e, $)
      subsop([2,2,1]=0,
             applyop(`-`,
                     [2,2,2],
                     applyop(eval, 1, e, op([2,1],e)=op([2,1],e)+op([2,2,1],e)),
                     op([2,2,1],e)))
    end proc)
  end proc:

  # Normalize sum(f(i),i=lo..2) to sum(f(i+2),i=lo-2..0)
  rebase_upper := proc(ee, $)
    subsindets(ee, 'And(specfunc({sum,Sum,product,Product}),
                        anyfunc(anything,
                          name=anything..Not({0,SymbolicInfinity,undefined})))',
    proc(e, $)
      subsop([2,2,2]=0,
             applyop(`-`,
                     [2,2,1],
                     applyop(eval, 1, e, op([2,1],e)=op([2,1],e)+op([2,2,2],e)),
                     op([2,2,2],e)))
    end proc)
  end proc:

  ModuleLoad := proc($)
    # Override csgn to work a little bit harder on piecewise and sum
    # (to get rid of csgn(1/2+1/2*sum(piecewise(...,1,0),...))
    #  produced by int on a Gaussian mixture model)
    unprotect(csgn);
    csgn := overload([
      # Handle if the csgn of a piecewise doesn't depend on which branch
      proc(a :: specfunc(piecewise), $)
        option overload;
        local r, i;
        r := {seq(`if`(i::even or i=nops(a), csgn(op(i,a)), NULL),
                  i=1..nops(a))};
        if nops(r)=1 then return op(r) end if;
        if not assigned(_Envsignum0) then
          r := r minus {0};
          if nops(r)=1 then return op(r) end if;
        end if;
        error "invalid input: cannot csgn %1", a;
      end proc,
      # Handle if the csgn of a sum doesn't depend on the bound variable
      proc(a :: And(specfunc({sum, Sum}), anyfunc(anything, name=range)), $)
        option overload;
        local r;
        r := csgn(op(1,a));
        if not depends(r,op([2,1],a)) then
          return signum(op([2,2,2],a)+1-op([2,2,1],a)) * r
        end if;
        error "invalid input: cannot csgn %1", a;
      end proc,
      csgn]);
    protect(csgn);

    # Override sum to fail faster
    unprotect(sum);
    sum := overload([
      proc(f :: Not({`+`,`+`^integer}), k :: name=Not(range(rational)), $)
        option overload;
        if not (subsindets(f, 'anything^integer', f->op(1,f))
                :: '{`+`,And(`*`,Not(`*`(Not(`+`))))}')
           and depends(indets(f, 'specfunc(idx)'), op(1,k)) then
          'procname(_passed)'
        else
          error "invalid input: cannot fast-fail sum(%1, %2)", _passed
        end if
      end proc,
      sum]);
    protect(sum);
  end proc;

  ModuleLoad();

end module; # Loop


Minor bug fix; most tests currently failing

# Step 2 of 3: computer algebra

  improve := proc(lo :: LO(name, anything), {_ctx :: t_kb := empty}, $)
  local r, `&context`;
       userinfo(3, improve, "input: ", print(lo &context _ctx));
       userinfo(3, improve, NoName, fflush(terminal));
       r:= LO(op(1,lo), reduce(op(2,lo), op(1,lo), _ctx));
       userinfo(3, improve, "output: ", print(r));
       r
  end proc;

  # Walk through integrals and simplify, recursing through grammar
  # h - name of the linear operator above us
  # kb - domain information
  reduce := proc(ee, h :: name, kb :: t_kb, $)
    local e, subintegral, w, ww, x, c, kb1;
    e := ee;
    if e :: 'And(specfunc({Int,Sum}), anyfunc(anything,name=range))' then
      x, kb1 := `if`(op(0,e)=Int,
        genLebesgue(op([2,1],e), op([2,2,1],e), op([2,2,2],e), kb),
        genType(op([2,1],e), HInt(closed_bounds(op([2,2],e))), kb));
      reduce_IntSum(op(0,e),
        reduce(subs(op([2,1],e)=x, op(1,e)), h, kb1), h, kb1, kb)
    elif e :: 'And(specfunc({Ints,Sums}),
                   anyfunc(anything, name, range, list(name=range)))' then
      x, kb1 := genType(op(2,e),
                        mk_HArray(`if`(op(0,e)=Ints,
                                       HReal(open_bounds(op(3,e))),
                                       HInt(closed_bounds(op(3,e)))),
                                  op(4,e)),
                        kb);
      if nops(op(4,e)) > 0 then
        kb1 := assert(size(x)=op([4,-1,2,2],e)-op([4,-1,2,1],e)+1, kb1);
      end if;
      reduce_IntsSums(op(0,e), reduce(subs(op(2,e)=x, op(1,e)), h, kb1), x,
        op(3,e), op(4,e), h, kb1)
    elif e :: 'applyintegrand(anything, anything)' then
      map(simplify_assuming, e, kb)
    elif e :: `+` then
      map(reduce, e, h, kb)
    elif e :: `*` then
      (subintegral, w) := selectremove(depends, e, h);
      if subintegral :: `*` then error "Nonlinear integral %1", e end if;
      subintegral := convert(reduce(subintegral, h, kb), 'list', `*`);
      (subintegral, ww) := selectremove(depends, subintegral, h);
      reduce_pw(simplify_factor_assuming(`*`(w, op(ww)), kb))
        * `*`(op(subintegral));
    elif e :: t_pw then
      e:= flatten_piecewise(e);
      e := kb_piecewise(e, kb, simplify_assuming,
                        ((rhs, kb) -> %reduce(rhs, h, kb)));
      e := eval(e, %reduce=reduce);
      # big hammer: simplify knows about bound variables, amongst many
      # other things
      Testzero := x -> evalb(simplify(x) = 0);
      reduce_pw(e)
    elif e :: t_case then
      subsop(2=map(proc(b :: Branch(anything, anything))
                     eval(subsop(2='reduce'(op(2,b),x,c),b),
                          {x=h, c=kb})
                   end proc,
                   op(2,e)),
             e);
    elif e :: 'Context(anything, anything)' then
      kb1 := assert(op(1,e), kb);
      # A contradictory `Context' implies anything, so produce 'anything'
      # In particular, 42 :: t_Hakaru = false, so a term under a false
      # assumption should never be inspected in any way.
      if kb1 :: t_not_a_kb then
          return 42
      end if;
      applyop(reduce, 2, e, h, kb1);
    elif e :: 'integrate(anything, Integrand(name, anything), list)' then
      x := gensym(op([2,1],e));
      # If we had HType information for op(1,e),
      # then we could use it to tell kb about x.
      subsop(2=Integrand(x, reduce(subs(op([2,1],e)=x, op([2,2],e)), h, kb)), e)
    else
      simplify_assuming(e, kb)
    end if;
  end proc;

  extract_bound :=
    proc( side, rels, v, $ )
      local lhs_f, rhs_f, lhs_r, rhs_r;

      lhs_f, rhs_f := op(side);
      lhs_r, rhs_r := op(rels);

      proc(x,$)
          if x :: relation then
              if lhs_f(x) = evaln(v) and
                 op(0,x) in lhs_r then
                  rhs_f(x);
              elif rhs_f(x) = evaln(v) and
                 op(0,x) in rhs_r then
                  lhs_f(x);
              else
                  NULL
              end if;
          else NULL end if;
      end proc;
  end proc;

  extract_bound_hi := v -> extract_bound( [lhs,rhs]
                                        , [ {`<`, `<=`}, {`>`, `>=`} ]
                                        , v
                                        );
  extract_bound_lo := v -> extract_bound( [rhs,lhs]
                                        , [ {`<`, `<=`}, {`>`, `>=`} ]
                                        , v
                                        );

  app_dom_spec_IntSum_LMS :=
   proc( mk :: identical(Int, Sum), ee, h
       , sol_, vs_
       , $)

      local sol := sol_, vs := vs_, e := ee, kb1, i
          , sol1, op_rng
          , v, v_t, lo, hi, lo_s, hi_s
          , vnms, countVs, countVsInRels, solOrder ;

      # vnms := map(x->op(1,x), indets(vs, 'Introduce(name, anything)'));
      vnms    := [op(map(i->op(1,i), op(1, kb_extract(vs))))] ;
      countVs := (c-> nops(indets(c, name) intersect {op(vnms)} ));
      countVsInRels :=
        (c-> nops(indets(map(o-> op(1..2,o), indets(c, relation)), name)));

      if sol :: identical({}) then
          # an empty solution
          0;

      elif sol :: set(list) then
          # a disjunction of solutions. we need to pick one, or try them
          # all
          ASSERT(nops(sol)>0);
          sol := [ op(sol) ];

          # just pick the solution which mentions 'fewest' integration
          # variables (fewest as in the sum of counts for each solution is
          # smallest). not a great heuristic, but it maximizes the chances
          # of the assert in `::list` case matching.
          sol :=
              op(1, sort( sol, key=(z-> `+`(map(countVsInRels,z)))
                        ));

          app_dom_spec_IntSum_LMS(mk, e, h, sol, vs);

      elif sol :: set({relation,boolean}) then
          # a single atomic solution, with (hopefully) at most two conjuncts
          # one which becomes incorporated into the lower bound, and the other
          # into the upper bound

          ASSERT(nops(vs)=1);
          v := op([1,1],vs); # KB(Introduce(v,..))

          kb1 := foldl(proc(a,b) assert(b,a) end proc
                      ,vs
                      ,op(sol)
                      );

          hi := subsindets( sol , {relation,boolean} , extract_bound_hi(v) );
          lo := subsindets( sol , {relation,boolean} , extract_bound_lo(v) );

          # this logic should really be inside KB
          if `and`(nops(sol) = 2
                  ,nops(hi) = 1
                  ,nops(lo) = 1
                  ) then
              v_t := op(1,lo) .. op(1,hi) ;

          else
              # TODO: should probably check that `mk` matches the type,
              # otherwise we are solving something we weren't asked to solve (?)
              v_t := getType(kb1, v);
              v_t := kb_range_of_var(v_t);

          end if;

          reduce_on_prod( p -> mk(p, v=v_t)
                        , e, v, kb1 );

      elif sol :: list then
          # a (nonempty, hopefully) conjunction of constraints which
          # are hopefully in a nice form...

          # if we have fewer conjuncts than variables, pad the conjunts
          # with trivial solutions (for the recursive call)
          if nops(sol) < nops(vs) then
              sol := [ seq( {true} , _=1..(nops(vs) - nops(sol)) )  , sol ];
          end if;

          op_rng := seq(1..nops(sol));

          # sort the conjs by the number of variables which they mention
          sol, solOrder :=
              sort( sol, key= (x-> -(countVs(x)))
                       , output=[sorted,permutation]
                  );

          # check that the `k'th (from 1) conjunct mentions at most `k'
          # variables. we can (hopefully) integrate these things in
          # a way that differentiation (due to disintegration) eliminates
          # the integral, by making the body free of that integration variable

          # when nops(sol) is 1, then "i in 1..1" gives us "1,1". but "seq(1,1)"
          # is "1".
          for i in op_rng do
              ASSERT(countVs(op(-i,sol)) <= i);
          end do;

          # get the list of variables in the order we hope to integrate
          vnms := vnms[solOrder];

          # to each variable, the range of integration is given in the
          # context. the range will be contracted as we apply the solution
          # starting with the leftmost solution, apply them all
          # hopefully this should only produce valid integrals (i.e. we've done
          # enough checks to guarantee it)
          for i in op_rng do
              sol1 := op(i, sol);

              e := app_dom_spec_IntSum_LMS
                     ( mk, e, h
                     , sol1
                     , select(c->depends(c, vnms[i]), vs)
                     ) ;

          end do;

          # maybe simplify here...
          e

      elif sol :: Partition then

          e := `+`(op(
            map(cl->
                Indicator(cl:-cond) *
                app_dom_spec_IntSum_LMS
                  ( mk, e, h
                  , cl:-val
                  , vs # assert(cl:-cond, vs)
                  )
                , op(1,sol) )
              ));

          e;

      else
          # can't deal with such solutions (what are they?)
          FAIL

      end if;

  end proc;

  app_dom_spec_IntSum :=
    proc(mk :: identical(Int, Sum), ee, h, kb0 :: t_kb
        ,dom_spec_
        ,$)
    local new_rng, make, var, elim, w,
          dom_spec := dom_spec_, e := ee ;

    new_rng, dom_spec := selectremove(type, dom_spec,
      {`if`(mk=Int, [identical(genLebesgue), name, anything, anything], NULL),
       `if`(mk=Sum, [identical(genType), name, specfunc(HInt)], NULL),
       [identical(genLet), name, anything]});
    if not (new_rng :: [list]) then
      error "kb_subtract should return exactly one gen*"
    end if;
    make    := mk;
    new_rng := op(new_rng);
    var     := op(2,new_rng);
    if op(1,new_rng) = genLebesgue then
      new_rng := op(3,new_rng)..op(4,new_rng);
    elif op(1,new_rng) = genType then
      new_rng := range_of_HInt(op(3,new_rng));
    else # op(1,new_rng) = genLet
      if mk=Int then
          # this was just a return, but now is in its own
          # local function and the control flow must be handled
          # up above. although calling 'reduce' on 0 will probably
          # return immediately anyways(?)
          return DONE(0)
      else
          make := eval;
          new_rng := op(3,new_rng)
      end if;
    end if;

    userinfo(3, 'LMS',
        printf("    dom-spec        : %a\n"
               "    dom-var         : %a\n"
         , dom_spec, var ));

    e := `*`(e, op(map(proc(a::[identical(assert),anything], $)
                         Indicator(op(2,a))
                       end proc,
                       dom_spec)));

    userinfo(3, 'LMS',
        printf("    expr-ind        : %a\n"
         , e ));

    elim := elim_intsum(make(e, var=new_rng), h, kb0);

    userinfo(3, 'LMS',
        printf("    expr-elimed     : %a\n"
         , elim ));

    if elim = FAIL then
      DONE( reduce_on_prod(p->make(p,var=new_rng), e, var, kb0) );
    else
      elim
    end if;

  end proc;

  do_app_dom_spec := proc(mk, e, h, kb0, kb2)
      local e2, dom_spec;

      dom_spec := kb_subtract(kb2, kb0);

      # apply the domain restrictions, which can produce
      #   DONE(x) - produced something which can't be simplified further
      #   x       - more work to be done
      e2 := app_dom_spec_IntSum(mk, e, h, kb0, dom_spec);

      userinfo(3, 'LMS',
               printf("    expr            : %a\n"
                      "    expr after dom  : %a\n"
                      , e, e2 ));

      if e2 :: specfunc('DONE') then
          e2 := op(1,e2);
      else
          e2 := reduce(e2, h, kb0);
          userinfo(3, 'LMS',
                   printf("    expr-reduced    : %a\n"
                          , e2 ));
      end if;

      e2;

  end proc;

  # Helper function for performing reductions
  # given an "ee" and a "var", pulls the portion
  # of "ee" not depending on "var" out, and applies "f"
  # to the portion depending on "var".
  # the 'weights' (factors not depending on "var") are simplified
  # under the given assumption context, "kb0"
  reduce_on_prod := proc(f,ee,var::name,kb0::t_kb,$)
      local e := ee, w;
      e, w := selectremove(depends, list_of_mul(e), var);
      reduce_pw(simplify_factor_assuming(`*`(op(w)), kb0)) * f(`*`(op(e))) ;
  end proc;

  reduce_IntSum := proc(mk :: identical(Int, Sum),
                        ee, h :: name, kb1 :: t_kb, kb0 :: t_kb, $)
    local e, dom_spec, kb2, lmss, vs, e2, e3, _, dom_specw;

    # if there are domain restrictions, try to apply them
    (dom_specw, e) := get_indicators(ee);

    kb2 := foldr(assert, kb1, op(dom_specw));

    ASSERT(type(kb2,t_kb), "reduce_IntSum : domain spec KB contains a contradiction.");

    lmss := kb_LMS(kb2);

    userinfo(3, 'LMS',
         printf("    LMS     : %a\n"
                "    kb Big  : %a\n"
                "    kb small: %a\n"
                "    domain  : %a\n"
                "    var     : %a\n"
         , lmss, kb2, kb0, dom_spec, h ));

    try
          if not lmss :: specfunc('NoSol') then
              lmss, vs, _ := op(lmss);

              if lmss :: 'piecewise' then
                  lmss := PWToPartition(lmss) ;
              end if;

              userinfo(3, 'LMS',
                       printf("    LMS-pp   : %a\n"
                              "    LMS-vs   : %a\n"
                              , lmss, vs ));

              e2 := app_dom_spec_IntSum_LMS( mk, e, h, lmss, vs );

              e2 := eval(e2, [Int=`int`]); # ,Sum=`sum`
              e2 := subs([`int`=Int], e2); # ,`sum`=Sum

              userinfo(3, 'LMS',
                       printf("    expr LMS     : %a\n"
                              "    expr LMS - s : %a\n"
                              , e2, simplify(e2) ));

              if e2 :: identical('FAIL') then
                  error "LMS: failed to apply (%a, %a)", lmss, vs
              end if;

              e3 := elim_intsum(e2, h, kb0);

              if e3 <> FAIL then
                  e2 := reduce(e3, h, kb0);
              end if;

          else
              error "LMS: no solution(%s)", op(1,lmss), ""
          end if;
    catch:
          userinfo(3, 'LMS',
                   printf("    LMS threw an error: %a\n"
                          , lastexception ));

          e2 := do_app_dom_spec( mk, e, h, kb0, kb2 );
    end try;

    e2;

  end proc;

  reduce_IntsSums := proc(makes, ee, var::name, rng, bds, h::name, kb::t_kb, $)
    local e, elim;
    # TODO we should apply domain restrictions like reduce_IntSum does.
    e := makes(ee, var, rng, bds);
    elim := elim_intsum(e, h, kb);
    if elim = FAIL then e else reduce(elim, h, kb) end if
  end proc;

  get_indicators := proc(e, $)
    local sub, inds, rest;
    if e::`*` then
      sub := map((s -> [get_indicators(s)]), [op(e)]);
      `union`(op(map2(op,1,sub))), `*`(op(map2(op,2,sub)))
    elif e::`^` then
      inds, rest := get_indicators(op(1,e));
      inds, subsop(1=rest, e)
    elif e::'Indicator(anything)' then
      {op(1,e)}, 1
    else
      {}, e
    end if
  end proc;

  elim_intsum := proc(e, h :: name, kb :: t_kb, $)
    local t, var, f, elim;
    t := 'applyintegrand'('identical'(h), 'anything');
    if e :: Int(anything, name=anything) and
       not depends(indets(op(1,e), t), op([2,1],e)) then
      var := op([2,1],e);
      f := 'int_assuming';
    elif e :: Sum(anything, name=anything) and
       not depends(indets(op(1,e), t), op([2,1],e)) then
      var := op([2,1],e);
      f := 'sum_assuming';
    elif e :: Ints(anything, name, range, list(name=range)) and
         not depends(indets(op(1,e), t), op(2,e)) then
      var := op(2,e);
      f := 'ints';
    elif e :: Sums(anything, name, range, list(name=range)) and
         not depends(indets(op(1,e), t), op(2,e)) then
      var := op(2,e);
      f := 'sums';
    else
      return FAIL;
    end if;
    # try to eliminate unused var
    elim := banish(op(1,e), h, kb, infinity, var,
      proc (kb,g,$) do_elim_intsum(kb, f, g, op(2..-1,e)) end proc);
    if has(elim, {MeijerG, undefined, FAIL}) or e = elim or elim :: SymbolicInfinity then
      return FAIL;
    end if;
    elim
  end proc;

  do_elim_intsum := proc(kb, f, ee, v::{name,name=anything})
    local w, e, x, g, t, r;
    w, e := get_indicators(ee);
    e := piecewise_And(w, e, 0);
    e := f(e,v,_rest,kb);
    x := `if`(v::name, v, lhs(v));
    g := '{sum, sum_assuming, sums}';
    if f in g then
      t := {'identical'(x),
            'identical'(x) = 'Not(range(Not({SymbolicInfinity, undefined})))'};
    else
      g := '{int, int_assuming, ints}';
      t := {'identical'(x),
            'identical'(x) = 'anything'};
      if not f in g then g := {f} end if;
    end if;
    for r in indets(e, 'specfunc'(g)) do
      if 1<nops(r) and op(2,r)::t then return FAIL end if
    end do;
    e
  end proc;

  int_assuming := proc(e, v::name=anything, kb::t_kb, $)
    simplify_factor_assuming('int'(e, v), kb);
  end proc;

  sum_assuming := proc(e, v::name=anything, kb::t_kb)
    simplify_factor_assuming('sum'(e, v), kb);
  end proc;

  reduce_pw := proc(ee, $) # ee may or may not be piecewise
    local e;
    e := nub_piecewise(ee);
    if e :: t_pw then
      if nops(e) = 2 then
        return Indicator(op(1,e)) * op(2,e)
      elif nops(e) = 3 and Testzero(op(2,e)) then
        return Indicator(Not(op(1,e))) * op(3,e)
      elif nops(e) = 3 and Testzero(op(3,e)) then
        return Indicator(op(1,e))*op(2,e)
      elif nops(e) = 4 and Testzero(op(2,e)) then
        return Indicator(And(Not(op(1,e)),op(3,e))) * op(4,e)
      end if
    end if;
    return e
  end proc;

  nub_piecewise := proc(pw, $) # pw may or may not be piecewise
    foldr_piecewise(piecewise_if, 0, pw)
  end proc;

  piecewise_if := proc(cond, th, el, $)
    # piecewise_if should be equivalent to `if`, but it produces
    # 'piecewise' and optimizes for when the 3rd argument is 'piecewise'
    if cond = true then
      th
    elif cond = false or Testzero(th - el) then
      el
    elif el :: t_pw then
      if nops(el) >= 2 and Testzero(th - op(2,el)) then
        applyop(Or, 1, el, cond)
      else
        piecewise(cond, th, op(el))
      end if
    elif Testzero(el) then
      piecewise(cond, th)
    else
      piecewise(cond, th, el)
    end if
  end proc;

# Step 2 of 3: computer algebra

  improve := proc(lo :: LO(name, anything), {_ctx :: t_kb := empty}, $)
  local r, `&context`;
       userinfo(3, improve, "input: ", print(lo &context _ctx));
       userinfo(3, improve, NoName, fflush(terminal));
       r:= LO(op(1,lo), reduce(op(2,lo), op(1,lo), _ctx));
       userinfo(3, improve, "output: ", print(r));
       r
  end proc;

  # Walk through integrals and simplify, recursing through grammar
  # h - name of the linear operator above us
  # kb - domain information
  reduce := proc(ee, h :: name, kb :: t_kb, $)
    local e, subintegral, w, ww, x, c, kb1;
    e := ee;
    if e :: 'And(specfunc({Int,Sum}), anyfunc(anything,name=range))' then
      x, kb1 := `if`(op(0,e)=Int,
        genLebesgue(op([2,1],e), op([2,2,1],e), op([2,2,2],e), kb),
        genType(op([2,1],e), HInt(closed_bounds(op([2,2],e))), kb));
      reduce_IntSum(op(0,e),
        reduce(subs(op([2,1],e)=x, op(1,e)), h, kb1), h, kb1, kb)
    elif e :: 'And(specfunc({Ints,Sums}),
                   anyfunc(anything, name, range, list(name=range)))' then
      x, kb1 := genType(op(2,e),
                        mk_HArray(`if`(op(0,e)=Ints,
                                       HReal(open_bounds(op(3,e))),
                                       HInt(closed_bounds(op(3,e)))),
                                  op(4,e)),
                        kb);
      if nops(op(4,e)) > 0 then
        kb1 := assert(size(x)=op([4,-1,2,2],e)-op([4,-1,2,1],e)+1, kb1);
      end if;
      reduce_IntsSums(op(0,e), reduce(subs(op(2,e)=x, op(1,e)), h, kb1), x,
        op(3,e), op(4,e), h, kb1)
    elif e :: 'applyintegrand(anything, anything)' then
      map(simplify_assuming, e, kb)
    elif e :: `+` then
      map(reduce, e, h, kb)
    elif e :: `*` then
      (subintegral, w) := selectremove(depends, e, h);
      if subintegral :: `*` then error "Nonlinear integral %1", e end if;
      subintegral := convert(reduce(subintegral, h, kb), 'list', `*`);
      (subintegral, ww) := selectremove(depends, subintegral, h);
      reduce_pw(simplify_factor_assuming(`*`(w, op(ww)), kb))
        * `*`(op(subintegral));
    elif e :: t_pw then
      e:= flatten_piecewise(e);
      e := kb_piecewise(e, kb, simplify_assuming,
                        ((rhs, kb) -> %reduce(rhs, h, kb)));
      e := eval(e, %reduce=reduce);
      # big hammer: simplify knows about bound variables, amongst many
      # other things
      Testzero := x -> evalb(simplify(x) = 0);
      reduce_pw(e)
    elif e :: t_case then
      subsop(2=map(proc(b :: Branch(anything, anything))
                     eval(subsop(2='reduce'(op(2,b),x,c),b),
                          {x=h, c=kb})
                   end proc,
                   op(2,e)),
             e);
    elif e :: 'Context(anything, anything)' then
      kb1 := assert(op(1,e), kb);
      # A contradictory `Context' implies anything, so produce 'anything'
      # In particular, 42 :: t_Hakaru = false, so a term under a false
      # assumption should never be inspected in any way.
      if kb1 :: t_not_a_kb then
          return 42
      end if;
      applyop(reduce, 2, e, h, kb1);
    elif e :: 'integrate(anything, Integrand(name, anything), list)' then
      x := gensym(op([2,1],e));
      # If we had HType information for op(1,e),
      # then we could use it to tell kb about x.
      subsop(2=Integrand(x, reduce(subs(op([2,1],e)=x, op([2,2],e)), h, kb)), e)
    else
      simplify_assuming(e, kb)
    end if;
  end proc;

  extract_bound :=
    proc( side, rels, v, $ )
      local lhs_f, rhs_f, lhs_r, rhs_r;

      lhs_f, rhs_f := op(side);
      lhs_r, rhs_r := op(rels);

      proc(x,$)
          if x :: relation then
              if lhs_f(x) = evaln(v) and
                 op(0,x) in lhs_r then
                  rhs_f(x);
              elif rhs_f(x) = evaln(v) and
                 op(0,x) in rhs_r then
                  lhs_f(x);
              else
                  NULL
              end if;
          else NULL end if;
      end proc;
  end proc;

  extract_bound_hi := v -> extract_bound( [lhs,rhs]
                                        , [ {`<`, `<=`}, {`>`, `>=`} ]
                                        , v
                                        );
  extract_bound_lo := v -> extract_bound( [rhs,lhs]
                                        , [ {`<`, `<=`}, {`>`, `>=`} ]
                                        , v
                                        );

  app_dom_spec_IntSum_LMS :=
   proc( mk :: identical(Int, Sum), ee, h
       , sol_, vs_
       , $)

      local sol := sol_, vs := vs_, e := ee, kb1, i
          , sol1, op_rng
          , v, v_t, lo, hi, lo_s, hi_s
          , vnms, countVs, countVsInRels, solOrder ;

      # vnms := map(x->op(1,x), indets(vs, 'Introduce(name, anything)'));
      vnms    := [op(map(i->op(1,i), op(1, kb_extract(vs))))] ;
      countVs := (c-> nops(indets(c, name) intersect {op(vnms)} ));
      countVsInRels :=
        (c-> nops(indets(map(o-> op(1..2,o), indets(c, relation)), name)));

      if sol :: identical({}) then
          # an empty solution
          0;

      elif sol :: set(list) then
          # a disjunction of solutions. we need to pick one, or try them
          # all
          ASSERT(nops(sol)>0);
          sol := [ op(sol) ];

          # just pick the solution which mentions 'fewest' integration
          # variables (fewest as in the sum of counts for each solution is
          # smallest). not a great heuristic, but it maximizes the chances
          # of the assert in `::list` case matching.
          sol :=
              op(1, sort( sol, key=(z-> `+`(map(countVsInRels,z)))
                        ));

          app_dom_spec_IntSum_LMS(mk, e, h, sol, vs);

      elif sol :: set({relation,boolean}) then
          # a single atomic solution, with (hopefully) at most two conjuncts
          # one which becomes incorporated into the lower bound, and the other
          # into the upper bound

          ASSERT(nops(vs)=1);
          v := op([1,1],vs); # KB(Introduce(v,..))

          kb1 := foldl(proc(a,b) assert(b,a) end proc
                      ,vs
                      ,op(sol)
                      );

          hi := subsindets( sol , {relation,boolean} , extract_bound_hi(v) );
          lo := subsindets( sol , {relation,boolean} , extract_bound_lo(v) );

          # this logic should really be inside KB
          if `and`(nops(sol) = 2
                  ,nops(hi) = 1
                  ,nops(lo) = 1
                  ) then
              v_t := op(1,lo) .. op(1,hi) ;

          else
              # TODO: should probably check that `mk` matches the type,
              # otherwise we are solving something we weren't asked to solve (?)
              v_t := getType(kb1, v);
              v_t := kb_range_of_var(v_t);

          end if;

          reduce_on_prod( p -> mk(p, v=v_t)
                        , e, v, kb1 );

      elif sol :: list then
          # a (nonempty, hopefully) conjunction of constraints which
          # are hopefully in a nice form...

          # if we have fewer conjuncts than variables, pad the conjunts
          # with trivial solutions (for the recursive call)
          if nops(sol) < nops(vs) then
              sol := [ seq( {true} , _=1..(nops(vs) - nops(sol)) )  , sol ];
          end if;

          op_rng := seq(1..nops(sol));

          # sort the conjs by the number of variables which they mention
          sol, solOrder :=
              sort( sol, key= (x-> -(countVs(x)))
                       , output=[sorted,permutation]
                  );

          # check that the `k'th (from 1) conjunct mentions at most `k'
          # variables. we can (hopefully) integrate these things in
          # a way that differentiation (due to disintegration) eliminates
          # the integral, by making the body free of that integration variable

          # when nops(sol) is 1, then "i in 1..1" gives us "1,1". but "seq(1,1)"
          # is "1".
          for i in op_rng do
              ASSERT(countVs(op(-i,sol)) <= i);
          end do;

          # get the list of variables in the order we hope to integrate
          vnms := vnms[solOrder];

          # to each variable, the range of integration is given in the
          # context. the range will be contracted as we apply the solution
          # starting with the leftmost solution, apply them all
          # hopefully this should only produce valid integrals (i.e. we've done
          # enough checks to guarantee it)
          for i in op_rng do
              sol1 := op(i, sol);

              e := app_dom_spec_IntSum_LMS
                     ( mk, e, h
                     , sol1
                     , select(c->depends(c, vnms[i]), vs)
                     ) ;

          end do;

          # maybe simplify here...
          e

      elif sol :: Partition then

          e := `+`(op(
            map(cl->
                Indicator(cl:-cond) *
                app_dom_spec_IntSum_LMS
                  ( mk, e, h
                  , cl:-val
                  , vs # assert(cl:-cond, vs)
                  )
                , op(1,sol) )
              ));

          e;

      else
          # can't deal with such solutions (what are they?)
          FAIL

      end if;

  end proc;

  app_dom_spec_IntSum :=
    proc(mk :: identical(Int, Sum), ee, h, kb0 :: t_kb
        ,dom_spec_
        ,$)
    local new_rng, make, var, elim, w,
          dom_spec := dom_spec_, e := ee ;

    new_rng, dom_spec := selectremove(type, dom_spec,
      {`if`(mk=Int, [identical(genLebesgue), name, anything, anything], NULL),
       `if`(mk=Sum, [identical(genType), name, specfunc(HInt)], NULL),
       [identical(genLet), name, anything]});
    if not (new_rng :: [list]) then
      error "kb_subtract should return exactly one gen*"
    end if;
    make    := mk;
    new_rng := op(new_rng);
    var     := op(2,new_rng);
    if op(1,new_rng) = genLebesgue then
      new_rng := op(3,new_rng)..op(4,new_rng);
    elif op(1,new_rng) = genType then
      new_rng := range_of_HInt(op(3,new_rng));
    else # op(1,new_rng) = genLet
      if mk=Int then
          # this was just a return, but now is in its own
          # local function and the control flow must be handled
          # up above. although calling 'reduce' on 0 will probably
          # return immediately anyways(?)
          return DONE(0)
      else
          make := eval;
          new_rng := op(3,new_rng)
      end if;
    end if;

    userinfo(3, 'LMS',
        printf("    dom-spec        : %a\n"
               "    dom-var         : %a\n"
         , dom_spec, var ));

    e := `*`(e, op(map(proc(a::[identical(assert),anything], $)
                         Indicator(op(2,a))
                       end proc,
                       dom_spec)));

    userinfo(3, 'LMS',
        printf("    expr-ind        : %a\n"
         , e ));

    elim := elim_intsum(make(e, var=new_rng), h, kb0);

    userinfo(3, 'LMS',
        printf("    expr-elimed     : %a\n"
         , elim ));

    if elim = FAIL then
      DONE( reduce_on_prod(p->make(p,var=new_rng), e, var, kb0) );
    else
      elim
    end if;

  end proc;

  do_app_dom_spec := proc(mk, e, h, kb0, kb2)
      local e2, dom_spec;

      dom_spec := kb_subtract(kb2, kb0);

      # apply the domain restrictions, which can produce
      #   DONE(x) - produced something which can't be simplified further
      #   x       - more work to be done
      e2 := app_dom_spec_IntSum(mk, e, h, kb0, dom_spec);

      userinfo(3, 'LMS',
               printf("    expr            : %a\n"
                      "    expr after dom  : %a\n"
                      , e, e2 ));

      if e2 :: specfunc('DONE') then
          e2 := op(1,e2);
      else
          e2 := reduce(e2, h, kb0);
          userinfo(3, 'LMS',
                   printf("    expr-reduced    : %a\n"
                          , e2 ));
      end if;

  end proc;

  # Helper function for performing reductions
  # given an "ee" and a "var", pulls the portion
  # of "ee" not depending on "var" out, and applies "f"
  # to the portion depending on "var".
  # the 'weights' (factors not depending on "var") are simplified
  # under the given assumption context, "kb0"
  reduce_on_prod := proc(f,ee,var::name,kb0::t_kb,$)
      local e := ee, w;
      e, w := selectremove(depends, list_of_mul(e), var);
      reduce_pw(simplify_factor_assuming(`*`(op(w)), kb0)) * f(`*`(op(e))) ;
  end proc;

  reduce_IntSum := proc(mk :: identical(Int, Sum),
                        ee, h :: name, kb1 :: t_kb, kb0 :: t_kb, $)
    local e, dom_spec, kb2, lmss, vs, e2, e3, _, dom_specw;

    # if there are domain restrictions, try to apply them
    (dom_specw, e) := get_indicators(ee);

    kb2 := foldr(assert, kb1, op(dom_specw));

    ASSERT(type(kb2,t_kb), "reduce_IntSum : domain spec KB contains a contradiction.");

    lmss := kb_LMS(kb2);

    userinfo(3, 'LMS',
         printf("    LMS     : %a\n"
                "    kb Big  : %a\n"
                "    kb small: %a\n"
                "    domain  : %a\n"
                "    var     : %a\n"
         , lmss, kb2, kb0, dom_spec, h ));

    try
          if not lmss :: specfunc('NoSol') then
              lmss, vs, _ := op(lmss);

              if lmss :: 'piecewise' then
                  lmss := PWToPartition(lmss) ;
              end if;

              userinfo(3, 'LMS',
                       printf("    LMS-pp   : %a\n"
                              "    LMS-vs   : %a\n"
                              , lmss, vs ));

              e2 := app_dom_spec_IntSum_LMS( mk, e, h, lmss, vs );

              userinfo(3, 'LMS',
                       printf("    expr LMS     : %a\n"
                              "    expr LMS - s : %a\n"
                              , e2, simplify(e2) ));

              if e2 :: identical('FAIL') then
                  error "LMS: failed to apply (%a, %a)", lmss, vs
              end if;

              e3 := elim_intsum(e2, h, kb0);

              if e3 <> FAIL then
                  e2 := reduce(e3, h, kb0);
              end if;

          else
              error "LMS: no solution(%s)", op(1,lmss), ""
          end if;
    catch:
          userinfo(3, 'LMS',
                   printf("    LMS threw an error: %a\n"
                          , lastexception ));

          e2 := do_app_dom_spec( mk, e, h, kb0, kb2 );

    end try;

    e2;

  end proc;

  reduce_IntsSums := proc(makes, ee, var::name, rng, bds, h::name, kb::t_kb, $)
    local e, elim;
    # TODO we should apply domain restrictions like reduce_IntSum does.
    e := makes(ee, var, rng, bds);
    elim := elim_intsum(e, h, kb);
    if elim = FAIL then e else reduce(elim, h, kb) end if
  end proc;

  get_indicators := proc(e, $)
    local sub, inds, rest;
    if e::`*` then
      sub := map((s -> [get_indicators(s)]), [op(e)]);
      `union`(op(map2(op,1,sub))), `*`(op(map2(op,2,sub)))
    elif e::`^` then
      inds, rest := get_indicators(op(1,e));
      inds, subsop(1=rest, e)
    elif e::'Indicator(anything)' then
      {op(1,e)}, 1
    else
      {}, e
    end if
  end proc;

  elim_intsum := proc(e, h :: name, kb :: t_kb, $)
    local t, var, f, elim;
    t := 'applyintegrand'('identical'(h), 'anything');
    if e :: Int(anything, name=anything) and
       not depends(indets(op(1,e), t), op([2,1],e)) then
      var := op([2,1],e);
      f := 'int_assuming';
    elif e :: Sum(anything, name=anything) and
       not depends(indets(op(1,e), t), op([2,1],e)) then
      var := op([2,1],e);
      f := 'sum_assuming';
    elif e :: Ints(anything, name, range, list(name=range)) and
         not depends(indets(op(1,e), t), op(2,e)) then
      var := op(2,e);
      f := 'ints';
    elif e :: Sums(anything, name, range, list(name=range)) and
         not depends(indets(op(1,e), t), op(2,e)) then
      var := op(2,e);
      f := 'sums';
    else
      return FAIL;
    end if;
    # try to eliminate unused var
    elim := banish(op(1,e), h, kb, infinity, var,
      proc (kb,g,$) do_elim_intsum(kb, f, g, op(2..-1,e)) end proc);
    if has(elim, {MeijerG, undefined, FAIL}) or e = elim or elim :: SymbolicInfinity then
      return FAIL;
    end if;
    elim
  end proc;

  do_elim_intsum := proc(kb, f, ee, v::{name,name=anything})
    local w, e, x, g, t, r;
    w, e := get_indicators(ee);
    e := piecewise_And(w, e, 0);
    e := f(e,v,_rest,kb);
    x := `if`(v::name, v, lhs(v));
    g := '{sum, sum_assuming, sums}';
    if f in g then
      t := {'identical'(x),
            'identical'(x) = 'Not(range(Not({SymbolicInfinity, undefined})))'};
    else
      g := '{int, int_assuming, ints}';
      t := {'identical'(x),
            'identical'(x) = 'anything'};
      if not f in g then g := {f} end if;
    end if;
    for r in indets(e, 'specfunc'(g)) do
      if 1<nops(r) and op(2,r)::t then return FAIL end if
    end do;
    e
  end proc;

  int_assuming := proc(e, v::name=anything, kb::t_kb, $)
    simplify_factor_assuming('int'(e, v), kb);
  end proc;

  sum_assuming := proc(e, v::name=anything, kb::t_kb)
    simplify_factor_assuming('sum'(e, v), kb);
  end proc;

  reduce_pw := proc(ee, $) # ee may or may not be piecewise
    local e;
    e := nub_piecewise(ee);
    if e :: t_pw then
      if nops(e) = 2 then
        return Indicator(op(1,e)) * op(2,e)
      elif nops(e) = 3 and Testzero(op(2,e)) then
        return Indicator(Not(op(1,e))) * op(3,e)
      elif nops(e) = 3 and Testzero(op(3,e)) then
        return Indicator(op(1,e))*op(2,e)
      elif nops(e) = 4 and Testzero(op(2,e)) then
        return Indicator(And(Not(op(1,e)),op(3,e))) * op(4,e)
      end if
    end if;
    return e
  end proc;

  nub_piecewise := proc(pw, $) # pw may or may not be piecewise
    foldr_piecewise(piecewise_if, 0, pw)
  end proc;

  piecewise_if := proc(cond, th, el, $)
    # piecewise_if should be equivalent to `if`, but it produces
    # 'piecewise' and optimizes for when the 3rd argument is 'piecewise'
    if cond = true then
      th
    elif cond = false or Testzero(th - el) then
      el
    elif el :: t_pw then
      if nops(el) >= 2 and Testzero(th - op(2,el)) then
        applyop(Or, 1, el, cond)
      else
        piecewise(cond, th, op(el))
      end if
    elif Testzero(el) then
      piecewise(cond, th)
    else
      piecewise(cond, th, el)
    end if
  end proc;


be more discriminating in the power case

  # Like simplify_assuming, but does a lot of hack-y things
  simplify_factor_assuming := module ()

    export ModuleApply;
    local graft_pw, GAMMAratio, wrap, hack_Beta, hackier_Beta,
          bounds_are_simple, eval_piecewise, eval_factor;

$include "NewSLO/Beta.mpl"
$include "NewSLO/Piecewise.mpl"

    bounds_are_simple := proc(bounds :: range, $)
      local bound, term, i;
      if `-`(op(bounds)) :: integer then return true end if;
      for bound in bounds do
        for term in convert(bound, 'list', `+`) do
          if term :: `*` then term := remove(type, term, integer) end if;
          if term :: 'specfunc(piecewise)' then
            for i from 2 by 2 to nops(term)-1 do
              if not(op(i,term) :: integer) then return false end if
            end do;
            if not(op(-1,term) :: integer) then return false end if
          elif not(term :: integer) then return false end if
        end do
      end do;
      true
    end proc;

    # eval_factor is a simplifier.  It maintains the following invariants:
    #   eval_factor(e, kb, mode, []) = e
    #   eval_factor(e, kb, `*` , [...,[product,i=lo..hi]])
    #     = product(eval_factor(e, kb, `*`, [...]), i=lo..hi)
    #   eval_factor(e, kb, `+` , [...,[sum    ,i=lo..hi]])
    #     = sum    (eval_factor(e, kb, `+`, [...]), i=lo..hi)
    # It recursively traverses e while "remembering" the loops traversed,
    # as ``context'' information, to help with transformations.
    eval_factor := proc(e, kb :: t_kb, mode :: identical(`*`,`+`), loops, $)
      local o, body, x, bounds, res, go, y, kb1, i, j, k, s, r;
      if not (loops :: 'list'([`if`(mode=`*`, 'identical(product,Product)',
                                              'identical(sum    ,Sum    )'),
                               'name=range'])) then
        error "invalid input: mode=%1, loops=%2", mode, loops;
      end if;
      if e :: mode then
        # Transform product(a*b,...) to product(a,...)*product(b,...)
        # (where e=a*b and loops=[[product,...]])
        return map(eval_factor, e, kb, mode, loops);
      end if;
      if e = mode () then
        return e;
      end if;
      if e :: And(specfunc(`if`(mode=`*`, '{product,Product}', '{sum,Sum}')),
                    'anyfunc(anything, name=range)') then
        o := op(0,e);
        body, bounds := op(e);
        x, bounds := op(bounds);
        bounds := map(eval_factor, bounds, kb, `+`, []);
        if bounds_are_simple(bounds) then
          # Expand {product,sum} to {mul,add}
          if o=Product then o:=product elif o=Sum then o:=sum end if;
          bounds := lift_piecewise(bounds,
                      'And(range, Not(range(Not(specfunc(piecewise)))))');
          res := `if`(bounds :: 'specfunc(piecewise)', map_piecewiselike, apply)
                     ((b -> o(go(x), x=b)), bounds);
          # Work around this bug:
          # > product(Sum(f(j),j=0..n-1),j=0..0)
          # Sum(f(0),0=0..n-1)
          res := eval(res, go = (i -> eval(body, x=i)));
          return eval_factor(res, kb, mode, loops);
        end if;
        y, kb1 := genType(x, HInt(closed_bounds(bounds)), kb);
        return eval_factor(subs(x=y,body), kb1, mode, [[o,y=bounds],op(loops)]);
      end if;
      if e :: 'specfunc(piecewise)' then
        return eval_piecewise(e, kb, mode, loops);
      end if;
      if e :: `*` then
        # If we're here, then mode=`+` (else "e :: mode" above would be true)
        s, r := selectremove(depends, e, map2(op,[2,1],loops));
        # Transform sum(a*b(i),i=...) to a*sum(b(i),i=...)
        if r <> 1 then
          return eval_factor(s, kb, `+`, loops)
               * maptype(`*`, eval_factor, r, kb, `+`, []);
        end if;
      end if;
      if mode = `*` then
	i := map2(op,[2,1],loops);
        if e :: '`^`' then
          # Transform product(a(i)^b,i=...) to product(a(i),i=...)^b
          if not depends(op(2,e), i) then
            return eval_factor(op(1,e), kb, `*`, loops)
                 ^ eval_factor(op(2,e), kb, `+`, []);
          end if;
        end if;
        if e :: 'exp(anything)' or e :: '`^`' and not depends(op(1,e), i) then
          # Transform product(a^((b(i)+c(i))^2),i=...)
          #        to a^   sum(b(i)^2   ,i=...)
          #         * a^(2*sum(b(i)*c(i),i=...))
          #         * a^   sum(c(i)^2   ,i=...)
          return mul(subsop(-1=j,e),
                     j in convert(eval_factor(expand(op(-1,e)), kb, `+`,
                                              map2(subsop,1=sum,loops)),
                                  'list', `+`));
        end if;
        # power, but both parts depend on the variable, but maybe not all
        # sub-parts.  In other words, catch (a*b(i))^c(i) and split product
        if e :: '`^`' and op(1,e)::`*` then
          (s,r) := selectremove(depends, op(1,e), i);
          if not (r = 1) then
            return eval_factor(s^op(2,e), kb, `*`, loops)
                 * eval_factor(r^op(2,e), kb, `*`, loops)
          end if;
        end if;
        # Rewrite ... * idx([p,1-p],i)
        #      to ... * p^idx([1,0],i) * (1-p)^idx([0,1],i)
        # because the latter is easier to integrate and recognize with respect to p
        if e :: 'idx(list, anything)' and not depends(op(1,e), i) then
          return mul(op([1,j],e)
                     ^ eval_factor(idx([seq(`if`(k=j,1,0), k=1..nops(op(1,e)))],
                                       op(2,e)),
                                   kb, `+`, map2(subsop,1=sum,loops)),
                     j=1..nops(op(1,e)));
        end if;
      end if;

      # Try not to use hack_beta for now...

      if mode = `*` and e :: 'specfunc(Beta)' then
        res := hack_Beta(e, kb, loops);
        if res <> FAIL then
          userinfo(3, `beta_hack`,
                   printf("Beta hack was applied to %a, %a, %a\n"
                          "\tto produce %a\n", e, kb, loops, res));
          return res
        end if;
      end if;

      if nops(loops) > 0 then
        # Emit outermost loop as last resort
        return op([-1,1],loops)(eval_factor(e, kb, mode, loops[1..-2]),
                                op([-1,2],loops));
      end if;
      # In the remainder of this function, assume loops=[] and recur in
      if e :: '{specfunc({GAMMA, Beta, exp, And, Or, Not}), relation, logical}' then
        return map(eval_factor, e, kb, `+`, []);
      end if;
      if e :: `^` then
        return eval_factor(op(1,e), kb, mode, [])
             ^ eval_factor(op(2,e), kb, `+` , []);
      end if;
      if e :: `+` then
        return map(eval_factor, e, kb, mode, []);
      end if;
      return e;
    end proc;

    ModuleApply := proc(e, kb::t_kb, $)
      simplify_assuming(eval_factor(convert(Partition:-PartitionToPW_mb(e), 'Beta'), kb, `*`, []), kb);
    end proc;
  end module; # simplify_factor_assuming

  # Like simplify_assuming, but does a lot of hack-y things
  simplify_factor_assuming := module ()

    export ModuleApply;
    local graft_pw, GAMMAratio, wrap, hack_Beta, hackier_Beta,
          bounds_are_simple, eval_piecewise, eval_factor;

$include "NewSLO/Beta.mpl"
$include "NewSLO/Piecewise.mpl"

    bounds_are_simple := proc(bounds :: range, $)
      local bound, term, i;
      if `-`(op(bounds)) :: integer then return true end if;
      for bound in bounds do
        for term in convert(bound, 'list', `+`) do
          if term :: `*` then term := remove(type, term, integer) end if;
          if term :: 'specfunc(piecewise)' then
            for i from 2 by 2 to nops(term)-1 do
              if not(op(i,term) :: integer) then return false end if
            end do;
            if not(op(-1,term) :: integer) then return false end if
          elif not(term :: integer) then return false end if
        end do
      end do;
      true
    end proc;

    # eval_factor is a simplifier.  It maintains the following invariants:
    #   eval_factor(e, kb, mode, []) = e
    #   eval_factor(e, kb, `*` , [...,[product,i=lo..hi]])
    #     = product(eval_factor(e, kb, `*`, [...]), i=lo..hi)
    #   eval_factor(e, kb, `+` , [...,[sum    ,i=lo..hi]])
    #     = sum    (eval_factor(e, kb, `+`, [...]), i=lo..hi)
    # It recursively traverses e while "remembering" the loops traversed,
    # as ``context'' information, to help with transformations.
    eval_factor := proc(e, kb :: t_kb, mode :: identical(`*`,`+`), loops, $)
      local o, body, x, bounds, res, go, y, kb1, i, j, k, s, r;
      if not (loops :: 'list'([`if`(mode=`*`, 'identical(product,Product)',
                                              'identical(sum    ,Sum    )'),
                               'name=range'])) then
        error "invalid input: mode=%1, loops=%2", mode, loops;
      end if;
      if e :: mode then
        # Transform product(a*b,...) to product(a,...)*product(b,...)
        # (where e=a*b and loops=[[product,...]])
        return map(eval_factor, e, kb, mode, loops);
      end if;
      if e = mode () then
        return e;
      end if;
      if e :: And(specfunc(`if`(mode=`*`, '{product,Product}', '{sum,Sum}')),
                    'anyfunc(anything, name=range)') then
        o := op(0,e);
        body, bounds := op(e);
        x, bounds := op(bounds);
        bounds := map(eval_factor, bounds, kb, `+`, []);
        if bounds_are_simple(bounds) then
          # Expand {product,sum} to {mul,add}
          if o=Product then o:=product elif o=Sum then o:=sum end if;
          bounds := lift_piecewise(bounds,
                      'And(range, Not(range(Not(specfunc(piecewise)))))');
          res := `if`(bounds :: 'specfunc(piecewise)', map_piecewiselike, apply)
                     ((b -> o(go(x), x=b)), bounds);
          # Work around this bug:
          # > product(Sum(f(j),j=0..n-1),j=0..0)
          # Sum(f(0),0=0..n-1)
          res := eval(res, go = (i -> eval(body, x=i)));
          return eval_factor(res, kb, mode, loops);
        end if;
        y, kb1 := genType(x, HInt(closed_bounds(bounds)), kb);
        return eval_factor(subs(x=y,body), kb1, mode, [[o,y=bounds],op(loops)]);
      end if;
      if e :: 'specfunc(piecewise)' then
        return eval_piecewise(e, kb, mode, loops);
      end if;
      if e :: `*` then
        # If we're here, then mode=`+` (else "e :: mode" above would be true)
        s, r := selectremove(depends, e, map2(op,[2,1],loops));
        # Transform sum(a*b(i),i=...) to a*sum(b(i),i=...)
        if r <> 1 then
          return eval_factor(s, kb, `+`, loops)
               * maptype(`*`, eval_factor, r, kb, `+`, []);
        end if;
      end if;
      if mode = `*` then
	i := map2(op,[2,1],loops);
        if e :: '`^`' then
          # Transform product(a(i)^b,i=...) to product(a(i),i=...)^b
          if not depends(op(2,e), i) then
            return eval_factor(op(1,e), kb, `*`, loops)
                 ^ eval_factor(op(2,e), kb, `+`, []);
          end if;
        end if;
        if e :: 'exp(anything)' or e :: '`^`' and not depends(op(1,e), i) then
          # Transform product(a^((b(i)+c(i))^2),i=...)
          #        to a^   sum(b(i)^2   ,i=...)
          #         * a^(2*sum(b(i)*c(i),i=...))
          #         * a^   sum(c(i)^2   ,i=...)
          return mul(subsop(-1=j,e),
                     j in convert(eval_factor(expand(op(-1,e)), kb, `+`,
                                              map2(subsop,1=sum,loops)),
                                  'list', `+`));
        end if;
        # Rewrite ... * idx([p,1-p],i)
        #      to ... * p^idx([1,0],i) * (1-p)^idx([0,1],i)
        # because the latter is easier to integrate and recognize with respect to p
        if e :: 'idx(list, anything)' and not depends(op(1,e), i) then
          return mul(op([1,j],e)
                     ^ eval_factor(idx([seq(`if`(k=j,1,0), k=1..nops(op(1,e)))],
                                       op(2,e)),
                                   kb, `+`, map2(subsop,1=sum,loops)),
                     j=1..nops(op(1,e)));
        end if;
      end if;

      # Try not to use hack_beta for now...

      if mode = `*` and e :: 'specfunc(Beta)' then
        res := hack_Beta(e, kb, loops);
        if res <> FAIL then
          userinfo(3, `beta_hack`,
                   printf("Beta hack was applied to %a, %a, %a\n"
                          "\tto produce %a\n", e, kb, loops, res));
          return res
        end if;
      end if;

      if nops(loops) > 0 then
        # Emit outermost loop as last resort
        return op([-1,1],loops)(eval_factor(e, kb, mode, loops[1..-2]),
                                op([-1,2],loops));
      end if;
      # In the remainder of this function, assume loops=[] and recur in
      if e :: '{specfunc({GAMMA, Beta, exp, And, Or, Not}), relation, logical}' then
        return map(eval_factor, e, kb, `+`, []);
      end if;
      if e :: `^` then
        return eval_factor(op(1,e), kb, mode, [])
             ^ eval_factor(op(2,e), kb, `+` , []);
      end if;
      if e :: `+` then
        return map(eval_factor, e, kb, mode, []);
      end if;
      return e;
    end proc;

    ModuleApply := proc(e, kb::t_kb, $)
      simplify_assuming(eval_factor(convert(Partition:-PartitionToPW_mb(e), 'Beta'), kb, `*`, []), kb);
    end proc;
  end module; # simplify_factor_assuming