one more simplification that is special because of the piecewise created by unproduct.

# 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, $)
  local xx, i;
  if depends(body, x minus {bvar}) then return true end if;
  xx := x; # don't remove bvar from xx!
  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` := `depends/Ints`:
`depends/ints` := `depends/Ints`:
`depends/sums` := `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(e);
  bvar, body := BindingTools:-generic_evalat(bvar, body, eqs);
  eval(op(0,e), eqs)(body, bvar,
                     BindingTools:-generic_evalatstar(rng, loops, eqs))
end proc:
`eval/Sums` := `eval/Ints`:
`eval/ints` := `eval/Ints`:
`eval/sums` := `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/Int`:
`eval/int` := `eval/Int`:
`eval/sum` := `eval/Int`:

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

Loop := module ()
  option package;
  local intssums, wrap, Binder, Stmt, t_binder, t_stmt, t_exp,
        ModuleLoad, ModuleUnload, csgnOld, csgnNew;
  export
     # These first few are smart constructors (for themselves):
         ints, sums,
     # while these are "proper functions"
         mk_HArray, genLoop, unproducts, unproduct;
  # these names are not assigned (and should not be).  But they are
  # used as global names, so document that here.
  global Ints, Sums, csgn;
  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, xx;
    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 products, as they might have different
      # variable dependencies, which can be exploited by other routines
      w2 := convert(w1, 'list', '`*`');
      w2 := map[2](foldl, product, w2, op(j+1..-1, loops));
      w0 := w0 * `*`(op(w2));
      # w0 := w0 * foldl(product, w1, op(j+1..-1, loops));
    end do;
    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, Hakaru:-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), Hakaru:-idx(identical(var), anything))
         = {Hakaru:-idx(var, eval(ind, s))} then
        kb  := assert(lhs(loop)=ind, kb1);
        res := subs(Hakaru:-idx(var,ind) = Hakaru:-idx(var,lhs(loop)), w);
        res := wrap(heap, res, mode, kb, kb0);
        res := subs(Hakaru:-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;
    return [wrap(heap, w, mode, kb1, kb0), 1]
  end proc;

  wrap := proc(heap::list, e1, mode1::identical(`*`,`+`),
               kb1::t_kb, kb0::t_kb, $)
    local e, kb, mode, i, entry, rest, var, new_var, new_rng, make,
       dom_spec, w, arrrgs, cond;
    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;
        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);
        e := simplify_assuming(`*`(op(e)), op(2,entry));
        w := simplify_assuming(`*`(op(w)), op(2,entry));
        if nops(dom_spec) > 0 then
          cond := op(dom_spec);
          # if e = mode(), don't bother with the piecewise
          if not (e = mode()) then
            # if e itself is a piecewise of the right shape, merge
            if e :: 'specfunc(piecewise)' and nops(e)=3 and op(3,e) = mode() then
              cond := op(1,e), cond;
              e := op(2,e);
            end if;
            e := piecewise(And(cond), e, mode())
          end if;
        end if;
        if mode=`+` then
          e  := w * make(e, var=new_rng);
        elif mode=`*` then
          if make = genLet then
            e := w * make(e, var = new_rng);
          elif nops(dom_spec) > 0 then
            new_var := gensym(var);
            # another special case which seems to occur; note that make=product
            # is an invariant here
            if e :: 'specfunc(piecewise)' and nops(e)=3 and op(3,e)=mode()
              and not(depends(op(2,e), var)) then
              e := op(2,e) ^ sum(eval(piecewise(And(op(dom_spec)), 1, 0), var = new_var), new_var = new_rng);
            else
              e := make(e, var = new_rng);
            end if;
            e := w ^ sum(eval(piecewise(And(op(dom_spec)), 1, 0), var = new_var), new_var = new_rng) * e;

          else
            e := w ^ sum(1, var = new_rng) * make(e, var = new_rng);
          end if;
        end if;
        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;
    rest := kb_subtract(kb, kb0);
    rest := map(proc(a::[identical(assert),anything],$) op(2,a) end proc, rest);
    if nops(rest) > 0 and not (e = mode ()) then
      e := piecewise(And(op(rest)),e,mode())
    end if;
    e
  end 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)
  csgnNew := proc(a)
    local r, i;
    # Handle if the csgn of a piecewise doesn't depend on which branch
    if nargs=1 and a::'specfunc(piecewise)'
       and (not assigned(_Envsignum0) or _Envsignum0 = 0) then
      r := {seq(`if`(i::even or i=nops(a), csgn(op(i,a)), NULL), i=1..nops(a))}
           minus {0};
      if nops(r)=1 then
        return op(r)
      end if
    end if;
    # Handle if the csgn of a sum doesn't depend on the bound variable
    if nargs=1 and a::'And(specfunc({sum, Sum}),
                           anyfunc(anything,name=range))' then
      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
    end if;
    csgnOld(_passed)
  end proc;
  ModuleLoad := proc($)
    local c;
    if not(csgnOld :: procedure) then
      c := eval(csgn);
      if c :: procedure then
        csgnOld := c;
        unprotect(csgn);
        csgn := csgnNew;
        protect(csgn);
      end if;
    end if;
  end proc;
  ModuleUnload := proc($)
    if csgnOld :: procedure then
      unprotect(csgn);
      csgn := csgnOld;
      protect(csgn);
    end if;
  end proc;

end module; # NewSLO

# 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, $)
  local xx, i;
  if depends(body, x minus {bvar}) then return true end if;
  xx := x; # don't remove bvar from xx!
  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` := `depends/Ints`:
`depends/ints` := `depends/Ints`:
`depends/sums` := `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(e);
  bvar, body := BindingTools:-generic_evalat(bvar, body, eqs);
  eval(op(0,e), eqs)(body, bvar,
                     BindingTools:-generic_evalatstar(rng, loops, eqs))
end proc:
`eval/Sums` := `eval/Ints`:
`eval/ints` := `eval/Ints`:
`eval/sums` := `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/Int`:
`eval/int` := `eval/Int`:
`eval/sum` := `eval/Int`:

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

Loop := module ()
  option package;
  local intssums, wrap, Binder, Stmt, t_binder, t_stmt, t_exp,
        ModuleLoad, ModuleUnload, csgnOld, csgnNew;
  export
     # These first few are smart constructors (for themselves):
         ints, sums,
     # while these are "proper functions"
         mk_HArray, genLoop, unproducts, unproduct;
  # these names are not assigned (and should not be).  But they are
  # used as global names, so document that here.
  global Ints, Sums, csgn;
  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, xx;
    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 products, as they might have different
      # variable dependencies, which can be exploited by other routines
      w2 := convert(w1, 'list', '`*`');
      w2 := map[2](foldl, product, w2, op(j+1..-1, loops));
      w0 := w0 * `*`(op(w2));
      # w0 := w0 * foldl(product, w1, op(j+1..-1, loops));
    end do;
    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, Hakaru:-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), Hakaru:-idx(identical(var), anything))
         = {Hakaru:-idx(var, eval(ind, s))} then
        kb  := assert(lhs(loop)=ind, kb1);
        res := subs(Hakaru:-idx(var,ind) = Hakaru:-idx(var,lhs(loop)), w);
        res := wrap(heap, res, mode, kb, kb0);
        res := subs(Hakaru:-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;
    return [wrap(heap, w, mode, kb1, kb0), 1]
  end proc;

  wrap := proc(heap::list, e1, mode1::identical(`*`,`+`),
               kb1::t_kb, kb0::t_kb, $)
    local e, kb, mode, i, entry, rest, var, new_var, new_rng, make,
       dom_spec, w, arrrgs, cond;
    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;
        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);
        e := simplify_assuming(`*`(op(e)), op(2,entry));
        w := simplify_assuming(`*`(op(w)), op(2,entry));
        if nops(dom_spec) > 0 then
          cond := op(dom_spec);
          # if e = mode(), don't bother with the piecewise
          if not (e = mode()) then
            # if e itself is a piecewise of the right shape, merge
            if e :: 'specfunc(piecewise)' and nops(e)=3 and op(3,e) = mode() then
              cond := op(1,e), cond;
              e := op(2,e);
            end if;
            e := piecewise(And(cond), e, mode())
          end if;
        end if;
        if mode=`+` then
          e  := w * make(e, var=new_rng);
        elif mode=`*` then
          if make = genLet then
            e := w * make(e, var = new_rng);
          elif nops(dom_spec) > 0 then
            new_var := gensym(var);
            e := w ^ sum(eval(piecewise(And(op(dom_spec)), 1, 0), var = new_var), new_var = new_rng) *
                 make(e, var = new_rng);
          else
            e := w ^ sum(1, var = new_rng) * make(e, var = new_rng);
          end if;
        end if;
        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;
    rest := kb_subtract(kb, kb0);
    rest := map(proc(a::[identical(assert),anything],$) op(2,a) end proc, rest);
    if nops(rest) > 0 and not (e = mode ()) then
      e := piecewise(And(op(rest)),e,mode())
    end if;
    e
  end 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)
  csgnNew := proc(a)
    local r, i;
    # Handle if the csgn of a piecewise doesn't depend on which branch
    if nargs=1 and a::'specfunc(piecewise)'
       and (not assigned(_Envsignum0) or _Envsignum0 = 0) then
      r := {seq(`if`(i::even or i=nops(a), csgn(op(i,a)), NULL), i=1..nops(a))}
           minus {0};
      if nops(r)=1 then
        return op(r)
      end if
    end if;
    # Handle if the csgn of a sum doesn't depend on the bound variable
    if nargs=1 and a::'And(specfunc({sum, Sum}),
                           anyfunc(anything,name=range))' then
      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
    end if;
    csgnOld(_passed)
  end proc;
  ModuleLoad := proc($)
    local c;
    if not(csgnOld :: procedure) then
      c := eval(csgn);
      if c :: procedure then
        csgnOld := c;
        unprotect(csgn);
        csgn := csgnNew;
        protect(csgn);
      end if;
    end if;
  end proc;
  ModuleUnload := proc($)
    if csgnOld :: procedure then
      unprotect(csgn);
      csgn := csgnOld;
      protect(csgn);
    end if;
  end proc;

end module; # NewSLO


Export a symbol which should be exported

# Checks if an expression has domain bounds/shape, and check for either one.
export Has := module ()
    export ModuleApply := proc(e, $)::truefalse;
        Bound(e) or Shape(e);
    end proc;

    export Bound := proc(e, $)::truefalse;
        assigned(Domain:-ExtBound[op(0,e)]) and
        evalb(e :: Domain:-ExtBound[op(0,e)]:-MapleType);
    end proc;

    export Shape := proc(e, $)::truefalse;
        assigned(Domain:-ExtShape[op(0,e)]) and
        evalb(e :: Domain:-ExtShape[op(0,e)]:-MapleType);
    end proc;
end module;

# Checks if an expression has domain bounds/shape, and check for either one.
local Has := module ()
    export ModuleApply := proc(e, $)::truefalse;
        Bound(e) or Shape(e);
    end proc;

    export Bound := proc(e, $)::truefalse;
        assigned(Domain:-ExtBound[op(0,e)]) and
        evalb(e :: Domain:-ExtBound[op(0,e)]:-MapleType);
    end proc;

    export Shape := proc(e, $)::truefalse;
        assigned(Domain:-ExtShape[op(0,e)]) and
        evalb(e :: Domain:-ExtShape[op(0,e)]:-MapleType);
    end proc;
end module;


Formatting

Formatting

#This module implements `Partition`---Hakaru's replacement for Maple's
#endogenous and unwieldy `piecewise`.

#The outer data structure for a Partition is a function, PARTITION(...), (just like it
#is for piecewise.
Partition:= module()
  option package;

  # Constructor for Partition pieces
  global Piece;

local
  Umap := proc(f,x,$)
    f(op(0,x))( map( p -> Piece(f(condOf(p)),f(valOf(p))), piecesOf(x) )
              , `if`(nops(x)>1,map(f,[op(2..-1,x)]),[])[] )
  end proc,

  isPartitionPieceOf := proc( p, elem_t := anything )
    type(p, 'Piece(PartitionCond, elem_t)');
  end proc,

  isPartitionOf := proc( e, elem_t := anything )
    type(e, 'PARTITION(list(PartitionPiece(elem_t)))' ) or
    type(e, 'PARTITION(list(PartitionPiece(Or(elem_t,PieceRef))),list(elem_t))' );
  end proc,

  TYPES := table(
    [(PieceRef = 'And(specfunc(nonnegint,PieceRef),satisfies(x->nops(x)>0))')
    ,(PartitionCond = '{relation, boolean, `::`, specfunc({`And`,`Or`,`Not`}), `and`, `or`, `not`}')
    ,(PartitionPiece = 'isPartitionPieceOf')
    ,(Partition = 'isPartitionOf')
    ]),

  ModuleLoad::static:= proc()
    :-`print/PARTITION`:= proc()
      local SetOfRecords, branch;
      SetOfRecords := piecesOf(PARTITION(args));
      `print/%piecewise`(
        seq([ condOf(eval(branch)), valOf(eval(branch))][], branch= SetOfRecords))
    end proc;

    BindingTools:-load_types_from_table(TYPES);

    # global extensions to maple functionality
    :-`eval/PARTITION` :=
    proc(p, eqs, $)
      Umap(x->eval(x,eqs), p);
    end proc;

    # :-`depends/PARTITION` :=
    # proc(parts, nms, $)
    # local dp := (x -> depends(x, nms));
    #   # `or`(op ( map(p-> dp(condOf(p)) or dp(valOf(p)), parts) ), dp(x,);
    # end proc;

    :-`diff/PARTITION` := proc()
      local pw, wrt, dpw, r, r0, r1;
      wrt := args[-1];
      pw := PARTITION(args[1..-2]);
      pw  := PartitionToPW(pw);
      dpw := diff(pw, wrt);
      r   := PWToPartition(dpw, 'do_solve');
      r   := Pmap(simplify, r);
    end proc;

    :-`simplify/PARTITION` := Simpl;

    :-`convert/piecewise` := overload(
      [proc(p::Partition)
         option overload(callseq_only);
         PartitionToPW(p);
       end proc, :-`convert/piecewise`]);

    unprotect(:-solve);
    :-`solve` := overload([
      proc(x:: Not(freeof(`PARTITION`))  )
        option overload(callseq_only); FAIL;
      end proc, :-`solve`]);
    protect(:-solve);

    VerifyTools[AddVerification](same_partition = proc(a,b,$) evalb(a=b) or SamePartition((x,y)->evalb(x=y),(x,y)->evalb(x=y),a,b) end proc);

    NULL
  end proc,

  ModuleUnload::static:= proc()
    NULL
  end proc,

  # abstract out all argument checking for map-like functions
  map_check := proc(p)
  local pos, err;
    if p::indexed then
      pos:= op(p);
      if not [pos]::[posint] then
        err := sprintf("Expected positive integer index; received %a", [pos]);
        return err;
      end if
    else
      pos:= 1
    end if;
    if nargs-1 <= pos then
      err := sprintf("Expected at least %d arguments; received %d", pos+1, nargs-1);
      return err;
    end if;
    if not args[pos+2]::Partition then
      err := sprintf("Expected a Partition; received %a", args[pos+2]);
      return err;
    end if;
    return pos;
  end proc,

  extr_conjs := proc(x,$)
    if x::{specfunc(`And`), `and`} then
      map(extr_conjs, [op(x)])[];
    else
      x
    end if
  end proc;
export
  piecesOf := proc(x, $)
    local ps, rs;
    ps := op(1,x);
    if nops(x)=2 then
      rs := op(2,x);
      ps := map(mapPiece(proc(c0,v0)
                  local c,c1,v,s; c,v := c0,v0; s := (x->x);
                  if v::PieceRef then
                    c1 := is_lhs(type,c,name);
                    if c1<>FAIL then s := x->subs(c1,x) end if;
                    c, s(op(op(1,v),rs))
                  else
                    c, v
                  end if; end proc), ps );
    elif has(x,PieceRef) then
      error "found piece references (%1) but no table of pieces: %2", indets(x,PieceRef), x
    end if;
    ps;
  end proc,

  condOf := proc(x::specfunc(`Piece`),$)
    op(1,x);
  end proc,

  valOf := proc(x::specfunc(`Piece`),$)
    op(2,x);
  end proc,

  mapPiece := proc(f,$) proc(x::PartitionPiece,$) Piece(f(condOf(x), valOf(x))) end proc; end proc,
  unPiece := mapPiece(ident),
  ident := proc() args end proc,
  is_lhs := proc(test,x0)
    local x := x0;
    if test(rhs(x),_rest) then x := op(0,x)(rhs(x),lhs(x)) end if;
    if test(lhs(x),_rest) then return x
    else                       return FAIL
    end if;
  end proc,

  # This is an alternate (to PARTITION) constructor for partition, which has the
  # same call convention as piecewise, except there are no implicit cases. if
  # there is an otherwise case, its condition is the conjunction of negations of
  # the other conditions.
  ModuleApply := proc()::Partition;
    local ps, as, ops_r;
    if nargs=0 then
      error "empty partition";
    end if;
    ps := [args]; ops_r := iquo(nops(ps),2);
    if nops(ps)::odd then
      ps := [op(1..-2,ps), Not(bool_Or(seq(op(2*i-1,ps),i=1..ops_r))), op(-1,ps)];
      ops_r := ops_r+1;
    end if;
    ps := [seq(Piece(op(2*i-1,ps),op(2*i,ps)),i=1..ops_r)];
    PARTITION(ps);
  end proc,

  Pieces := proc(cs0,es0)::list(PartitionPiece);
    local es, cs;
    es := `if`(es0::{set,list},x->x,x->{x})(es0);
    cs := `if`(cs0::{set,list,specfunc(`And`),`and`},x->x,x->{x})(cs0);
    [seq(seq(Piece(c,e),c=cs),e=es)];
  end proc,

  #This is just `map` for Partitions.
  #Allow additional args, just like `map`
  Pmap::static:= proc(f)::Partition;
    local pair,pos,res;
    res := map_check(procname, args);
    if res::string then error res else pos := res; end if;
    PARTITION([seq(
      Piece(condOf(pair)
            ,f(args[2..pos], valOf(pair), args[pos+2..])
         ),pair= piecesOf(args[pos+1]))])
  end proc,

  # a more complex mapping combinator which works on all 3 parts
  # not fully general, but made to work with KB
  # also, does not handle extra arguments (on purpose!)
  Amap::static:= proc(
    funcs::[anything, anything, anything], #`appliable` not inclusive enough.
    part::Partition)::Partition;
    local pair,pos,f,g,h,doIt;
    (f,g,h) := op(funcs);
    #sigh, we don't have a decent 'let', need to use a local proc
    doIt := proc(pair)
    local kb0 := h(condOf(pair));
      Piece( f(condOf(pair), kb0),
             g(valOf(pair), kb0));
    end proc;
    PARTITION(map(doIt,piecesOf(part)));
  end proc,

  Foldr := proc( cons, nil, prt :: Partition, $ )
    foldr(proc(p, x) cons(condOf(p), valOf(p), x); end proc,nil,op(piecesOf(prt)));
  end proc,

  Case := proc(ty,f,g) proc(x) if x::ty then f(x) else g(x) end if end proc end proc,
  Foldr_mb := proc(cons,nil,prt) Case(Partition, x->Foldr(cons,nil,x), x->cons(true,x,nil)) end proc,
  PartitionToPW_mb := Case(Partition, PartitionToPW, x->x),
  PWToPartition_mb := Case(specfunc(piecewise), PWToPartition, x->x),

  PartitionToPW := module()
    export ModuleApply; local pw_cond_ctx;
    ModuleApply := proc(x::Partition, $)
      local parts := piecesOf(x);
      if nops(parts) = 1 and is(op([1,1],parts)) then return op([1,2], parts) end if;
      parts := foldl(pw_cond_ctx, [ [], {} ], op(parts) );
      parts := [seq([condOf(p), valOf(p)][], p=op(1,parts))];
      if op(-2, parts) :: identical(true) then
        parts := subsop(-2=NULL, parts);
      end if;
      piecewise(op(parts));
    end proc;

    pw_cond_ctx := proc(ctx_, p, $)
    local ps, ctx, ctxN, cond, ncond;
      ps, ctx := op(ctx_); cond := condOf(p);
      cond := {extr_conjs(cond)};
      cond := remove(x->x in ctx, cond);
      ncond := `if`(nops(cond)=1
                    , KB:-negate_rel(op(1,cond))
                    , `Not`(bool_And(op(cond))) );
      cond := bool_And(op(cond));
      ctx := ctx union { ncond };
      [ [ op(ps), Piece(cond, valOf(p)) ], ctx ]
    end proc;
  end module,

  isShape := kind ->
  module()
    option record;

    export MakeCtx := proc(p0,_rec)
      local p := p0, pw, p1, wps, ws, vs, cs, w, ps;
      if kind='piecewise' then
        p := Partition:-PWToPartition(p);
      end if;
      w, p1 := Partition:-Simpl:-single_nonzero_piece(p);
      if not w :: identical(true) or p1 <> p then
        [ w, p1 ]
      else
        ps := piecesOf(p);
        wps := map(_rec@valOf, ps);
        ws, vs, cs := map2(op, 1, wps), map2(op, 2, wps), map(condOf, ps);
        if nops(vs) > 0 and
          andmap(v->op(1,vs)=v, vs) and
          ormap(a->a<>{}, ws)
        then
          [ `bool_Or`( op( zip(`bool_And`, ws, cs) ) ) , op(1,vs) ];
        else
          [ true, p0 ];
        end if;
      end if;
    end proc;
    export MapleType := `if`(kind=`PARTITION`,'Partition','specfunc(piecewise)');
  end module,

  # Checks if the given Partition is semantically valid, i.e. the conditions are
  # all disjoint. This exploits the property that if each adjacent pair of
  # conditions is pairwise disjoint, then they are all disjoint
  # (i.e. disjointness is transitive).
  IsValid := proc(p::Partition,$)
    local i, cs; cs := map(condOf, piecesOf(p));
    for i from 2 to nops(cs) do
      if not(is(bool_Not(op(i  ,cs))) assuming op(i-1,cs)) or
         not(is(bool_Not(op(i-1,cs))) assuming op(i  ,cs)) then
        return false; end if;
    end do;
    return true;
  end proc,

  # convert a piecewise to a partition, which is straightforward except:
  # - if any of the branches are unreachable, they are removed
  # - if the last clause is (implicitly) `otherwise`, that clause is filled in
  #     appropriately
  # note that if the piecewise does not cover the entire domain,
  #   then this Partition will be 'invalid' (in the sense that it also
  #   will not cover the entire domain) - the 'correct' thing to do would
  #   probably be to add a new clause whose value is 'undefined'
  # the logic of this function is already essentially implemented, by KB
  # in fact, kb_piecewise does something extremely similar to this
  PWToPartition := proc(x::specfunc(piecewise), {_kb::t_kb:=KB:-empty})::Partition;
    # each clause evaluated under the context so far, which is the conjunction
    # of the negations of all clauses so far
    local ctx := true, n := nops(x), cls := [], cnd, ncnd, i, q, ctxC, cl, p;

    # Checks if the piecewise is valid when translated literally to a Partition
    # if so, that Partition can be returned directly. This is not done by
    # default because the check calls `coulditbe' many times which is
    # potentially much more expensive than just building the Partition from
    # scratch. This should only be used when the piecewise comes from a solver
    # which may or may not already return a 'partition', and when it does return
    # a 'partition', the set of conditions is typically so complicated that
    # rebuilding it produces an unwieldy monster (e.g. SemiAlgebraic in the case
    # of e.g. RoundTrip/t62).
    if 'check_valid' in {_rest} then
      p := Partition(op(x));
      if IsValid(p) then return p end if;
    end if;

    # handles all but the `otherwise` case if there is such a case
    for i in seq(q, q = 1 .. iquo(n, 2)) do
      cnd := op(2*i-1,x); # the clause as given
      # if this clause is unreachable, then every subsequent clause will be as well
      if ctx :: identical(false) then return PARTITION( cls );
      else
        ctxC := `And`(cnd, ctx);              # the condition, along with the context (which is implicit in pw)
        ctxC := Simpl:-condition(ctxC, _kb, _rest);

        if cnd :: `=` then ncnd := lhs(cnd) <> rhs(cnd);
        else               ncnd := Not(cnd) end if;

        ctx  := `And`(ncnd, ctx);             # the context for the next clause

        if ctx :: identical(false,[]) then    # this clause is actually unreachable
          return(PARTITION(cls));
        else
          cls := [ op(cls), op(Pieces(ctxC,[op(2*i,x)])) ];
        end if;
      end if;
    end do;

    # if there is an otherwise case, handle that.
    if n::odd then
      ctx := Simpl:-condition(ctx, _kb, _rest);
      if not ctx :: identical(false,[]) then
        cls := [ op(cls), op(Pieces(ctx,[op(n,x)])) ];
      end if;
    end if;

    if nops(cls) = 0 then
      WARNING("PWToPartition: the piecewise %1 produced an empty partition", x);
      return 0;
    end if;
    PARTITION( cls );
  end proc,

  # applies a function to the arg if arg::Partition,
  # and if arg::piecewise, then converts the piecewise to a partition,
  # applies the function, then converts back to piecewise
  # this mainly acts as a sanity check
  AppPartOrPw := proc(f,x::Or(Partition,specfunc(piecewise)))
    if x::Partition then f(x);
    else                 PartitionToPW(f(PWToPartition(x))) end if;
  end proc,

  #Check whether the conditions of a Partition satisfy a type (or a proc return
  #truefalse)
  ConditionsSatisfy := proc(P::Partition, test, $)
    local p, ty; ty := `if`(test::type,test,satisfies(test));
    for p in piecesOf(P) do if condOf(p)::ty then return true end if end do;
    false
  end proc,

  #Check whether the conditions of a Partition depend on any of a set of names.
  ConditionsDepend:= proc(P::Partition, V::{name, list(name), set(name)}, $)
    ConditionsSatisfy(P, x->depends(x,V));
  end proc,

  # The cartesian product of two Partitions
  PProd := proc(p0::Partition,p1::Partition,{_add := `+`})::Partition;
  local ps0, ps1, cs, rs, rs0, rs1;
    ps0,ps1 := map(ps -> sort(piecesOf(ps), key=(z->condOf(z))), [p0,p1])[];
    cs := zip(proc(p0,p1)
                if condOf(p0)=condOf(p1) then
                  Piece(condOf(p0),_add(valOf(p0),valOf(p1))) ;
                else [p0,p1];
                end if;
              end proc, ps0,ps1);
    rs, cs := selectremove(c->type(c,list),cs);
    rs0, rs1 := map(k->map(r->op(k,r),rs),[1,2])[];
    rs := map(r0->map(r1-> Piece( bool_And(condOf(r0),condOf(r1)), _add(valOf(r0),valOf(r1)) )
                      ,rs1)[],rs0);
    PARTITION([op(cs),op(rs)]);
  end proc,

  Simpl := module()
    export ModuleApply := proc(p)
      option remember, system;
      local ps, qs, qs1, mk, as; as := _rest;
      if p :: Partition then
        foldr((f,x)->f(x,as), p,
              reduce_branches,
              remove_false_pieces,
              flatten,
              singular_pts);
      elif not hastype(p, Partition) then
        p;
      elif assigned(distrib_op_Partition[op(0,p)]) then
        mk := distrib_op_Partition[op(0,p)];
        ps := [op(p)];
        ps := map(x->Simpl(x,as), ps);
        ps, qs := selectremove(type, ps, Partition);
        if nops(ps)=0 then return p end if;
        mk(op(qs),foldr(((a,b)->
                         remove_false_pieces(Partition:-PProd(a,b,_add=mk))),
                        op(ps)));
      else
        subsindets(p,{Partition,indices(distrib_op_Partition,nolist)},x->Simpl(x,_rest));
      end if;
    end proc;
    export distrib_op_Partition := table([`+`=`+`,`*`=`*`]);

    export flatten := module()
      export ModuleApply;
      local unpiece, unpart, flatten_with;

      ModuleApply := proc(pr0, { _with := [ 'Partition', unpart ] } )
        local ty, un_ty, pr1, pr2;
        ty, un_ty := op(_with);

        pr1 := subsindets(pr0, ty, un_ty);
        if pr0 <> pr1 then
          ModuleApply(pr1, _with=[ Or('Partiton',`*`), unpart ]);
        else
          pr0
        end if;
      end proc;

      # like Piece, but tries to not be a Piece
      unpiece := proc(c, pr, $)
        flatten_with(proc(mk_q, ps)
                       map(q -> Piece(bool_And(condOf(q),c),mk_q(valOf(q))), ps)[]
                     end proc,
                     x->Piece(c,x),
                     pr);
      end proc;

      unpart := curry(
        flatten_with,proc(mk_q, ps)
                       PARTITION(map(q -> unpiece(condOf(q),valOf(q)), ps))
                     end proc, x->x);

      flatten_with := proc(rec, fail, pr, $)
      local ps, ws;
        if pr :: Partition then
          ps := piecesOf(pr); ws := [];
        elif pr :: `*` then
          ps, ws := selectremove(q->type(q,Partition), [op(pr)]);
          if nops(ps) = 1 then
            ps := piecesOf(op(1,ps));
          else return fail(pr) end if;
        else
          return fail(pr);
        end if;
        rec(x->`*`(op(ws),x), ps);
      end proc;
    end module;

    export single_nonzero_piece_cps := proc(k)
      local r,p; r, p := single_nonzero_piece(_rest);
      if r :: identical(true) then
        args[2]
      else
        k(r, p);
      end if;
    end proc;

    export single_nonzero_piece := proc(e, { _testzero := Testzero })
      local zs, nzs;
      if e :: Partition then
        zs, nzs := selectremove(p -> _testzero(valOf(p)), piecesOf(e));
        if nops(nzs) = 1 then
          return condOf(op(1,nzs)) , valOf(op(1,nzs))
        end if;
      end if;
      true, e
    end proc;

    export remove_false_pieces := proc(e::Partition, kb := KB:-empty)
      PARTITION(remove(p -> type(KB:-assert(condOf(p), kb), t_not_a_kb), piecesOf(e)));
    end proc;

    local `&on` := proc(f,k,$) proc(a,b,$) f(k(a),k(b)) end proc end proc;
    local condition_complexity := proc(x)
      nops(indets(x,PartitionCond)) + nops(indets(x,specfunc({exp, ln})))
    end proc;

    export reduce_branches := proc(e::Partition, kb := KB:-empty, { _testequal := ((a,b) -> Testzero(a-b)) })
      local k, ks, i, vs, ps1, ps; ps := piecesOf(e); vs := map(valOf,ps);
      userinfo(3, :-reduce_branches, printf("Input: %a\n", ps));

      if nops(ps)=1 then return op([1,2],ps); end if;

      # Categorize(group) by equality of piece values
      ps1 := [ListTools:-Categorize(_testequal &on valOf, ps)];
      # unless there are fewer groups than original pieces ...

      ks  := map(nops, ps1); # number of pieces per group

      # build the result
      ps1 := map(p->Piece(bool_Or(condition(bool_Or(map(condOf,p)[]), kb,
                                            'do_solve', 'do_kb', 'do_check')[])
                          ,valOf(op(1,p)))
                 ,ps1);
      userinfo(3, :-reduce_branches, printf("condition: %a\n", ps1));

      # replace the condition of each piece built from many others
      if nops(ps1) < nops(ps) and nops(ps1)>1 then
        for i in select(x->op(1,x)>1,sort(zip(`[]`,ks,[seq(1..nops(ks))]), key=(x->-op(1,x)))) do
          ps1 := piecesOf( replace_piece_cond(PARTITION(ps1), op(2,i)) );
        end do;
      end if;

      return PARTITION(ps1);
    end proc;

    # Replaces a piece (at given index) condition with the logically equivalent
    # one formed from the other pieces.
    export replace_piece_cond := proc(e::Partition, n::integer := -1, failure:=(x->x), cmp_score := [ (x->x), (x->x+1) ], $)
      local p_n, p_n1,ps,cmp; ps := piecesOf(e);
      if abs(n)>nops(ps) then
        error "index out of bound: %1", n;
      elif nops(ps)=1 then
        error "cannot replace in single piece Partition: %1", e
      end if;
      p_n := condOf(op(n, ps));                              # old condition
      p_n1 := Not(bool_Or(map(condOf,subsop(n=NULL,ps))[])); # new condition
      cmp := map(condition_complexity, [p_n1, p_n]);

      # a cheap metric for determining if the new condition is an improvement
      if `<=`(zip(apply, cmp_score, cmp)[]) then
        ps := subsop([n,1]=p_n1, ps);
        PARTITION(ps);
      else
        failure(PARTITION(ps));
      end if;
    end proc;

    # Removal of singular points from partitions
    # works with other things too!
    export singular_pts := module()
      local t_constant := (ns->x->(indets(x,And(name,Not(constant))) minus ns)={});
      local can_remove := proc(ns)
        local t1, t2;
        t1 := satisfies(t_constant(ns));
        t2 := satisfies(n->n in ns);
        'Or'(`=`(t2,{t1,t2}),`=`(t1,t2));
      end proc;

      local weakening := {`<=`=`<`, `>=`=`>`};
      local can_replace := proc(ns)
        local t := satisfies(n->n in ns);
        'And'('specfunc'(map(lhs,weakening)),
              {'anyfunc'('anything',t),'anyfunc'(t,'anything')});
      end proc;
      local do_replace := proc(c)
        table([op(weakening)])[op(0,c)](op(c));
      end proc;

      export ModuleApply := proc(sh, kb::t_kb:=KB:-empty,{_name_cands::list := [] })
        local ns, sh1; sh1 := sh;
        # todo: work with array types as well?
        ns := select(type, [op(kb)], And(KB:-t_kb_Introduce,anyfunc(anything,specfunc(`AlmostEveryReal`))));
        ns := map(curry(op,1), ns);
        ns := { op(ns), op(_name_cands) };
        if ns={} then return sh end if;

        sh1 := subsindets(sh1, can_remove(ns), _->false);
        sh1 := eval(eval(sh1, [`And`=bool_And,`Or`=bool_Or]));
        sh1 := subsindets(sh1, 'specfunc'('specfunc'(map(op,weakening)),Not), bool_Not@op);
        sh1 := subsindets(sh1, can_replace(ns), do_replace);
        subsindets[flat](sh1, Partition, pr->remove_false_pieces(pr,kb));
      end proc;
    end module; # singular_pts

    export condition := module()
      local is_extra_sol := x -> (x :: `=` and rhs(x)=lhs(x) and lhs(x) :: name);
      local postproc_for_solve := proc(ctx, ctxSlv)
                               ::{identical(false), list({boolean,relation,specfunc(boolean,And),`and`(boolean)})};
        local ctxC := ctxSlv;
        if ctxC = [] then
          ctxC := [] ;
        elif nops(ctxC)> 1 then
          ctxC := map(x -> postproc_for_solve(ctx, [x], _rest)[], ctxC);
        elif nops(ctxC) = 1 then
          ctxC := op(1,ctxC);
          if ctxC :: set then
            if ctxC :: identical('{}') then
              ctxC := NULL;
            else
              ctxC := remove(is_extra_sol, ctxC);
               # if all the solutions are 'extra', the solution is actually just
               # garbage. Maple can't really tell and doesn't just return the
               # empty set (no solutions) for these cases.
              if ctxC = {} then
                ctxC := ctx;
              else
                ctxC := bool_And(op(ctxC));
              end if;
            end if ;
            ctxC := [ctxC];
          elif ctxC :: specfunc('piecewise') then
            ctxC := PWToPartition(ctxC, _rest);
            ctxC := [ seq( map( o -> condOf(c) and o
                                , postproc_for_solve(ctx, valOf(c), _rest))[]
                           , c=piecesOf(ctxC) )] ;
          else
            ctxC := FAIL;
          end if;
        else
          ctxC := FAIL;
        end if;
        if ctxC = FAIL then
          error "don't know what to do with %1", ctxSlv;
        else
          ctxC;
        end if;
      end proc;

      # For some reason, solve just disregards these sorts of conditions
      # altogether, but not when they appear on their own! e.g.
      #  solve( {a<>b} )       = {a=a,a<>b}
      #  solve( {Not(a<>b)} )  = {a=a,b=b}  -- but should be {..,a=b}
      local can_solve := proc(c,$)
        local neq_nn := `<>`(name,name);
        evalb(indets(c, neq_nn) = {} or not has(c,`idx`))
      end proc;

      export ModuleApply := proc(ctx, kb::t_kb := KB:-empty)::list(PartitionCond);
        option remember, system;
        local ctxC, ctxC1, ctxC_c, ctxC1_c;
        ctxC := ctx;
        if ctx :: identical(true) then
          error "Simpl:-condition: don't know what to do with %1", ctxC;
        end if;
        if 'do_kb' in {_rest} then
          ctxC1 := KB:-kb_subtract( KB:-assert( ctxC, kb ), kb );
          if nops(ctxC1)=1 and op([1,1], ctxC1)=KB:-assert then
            ctxC1 := op([1,2], ctxC1);
            ctxC1_c, ctxC_c := map(condition_complexity, [ctxC1,ctxC])[];
            if ctxC1_c < ctxC_c then
              ctxC := ctxC1;
            end if;
          end if;
        end if;
        if condition_complexity(ctxC)=1 then
          return [ctxC];
        end if;

        ctxC := KB:-chill(ctxC);

        if 'do_solve' in {_rest} and _Env_HakaruSolve<>false and can_solve(ctxC) then
          ctxC1 := solve({ctxC}, 'useassumptions'=true);
          if ctxC1 = ctxC then
            # sometimes solve returns unevaluated which confuses postproc because
            # it expects the typical output of solve
            ctxC := [ctxC];
          elif ctxC1 = NULL and indets(ctx, specfunc(`exp`)) <> {} then
            ctxC := [ctxC];
          else
            ctxC1 := postproc_for_solve(ctxC, [ctxC1], _rest);
            if 'do_check' in {_rest} and condition_complexity(ctxC)>condition_complexity(ctxC1) then
              ctxC := ctxC1;
            end if;
          end if;
          if indets(ctxC, specfunc({`Or`, `or`})) <> {} then
            userinfo(10, 'Simpl:-condition',
                     printf("output: \n"
                            "  %a\n\n"
                            , ctxC ));
          end if;
        else
          ctxC1 := ctxC;
          ctxC := [seq(Domain:-simpl_relation(ctxC1, norty=t), t=['DNF','CNF'])];
          ctxC := eval(ctxC,`And`=bool_And);
          ctxC := op(1, sort(ctxC, key=condition_complexity));
          if ctxC :: specfunc(`Or`) then
            ctxC := [op(ctxC)]
          else
            ctxC := [ctxC];
          end if;
        end if;
        if 'no_split_disj' in {_rest} then
          ctxC := [ bool_Or(op(ctxC)) ];
        end if;
        ctxC := KB:-warm(ctxC);
        `if`(ctxC::list, ctxC, [ctxC]);
      end proc;
    end module; #Simpl:-condition
  end module, #Simpl

  SamePartition := proc(eqCond, eqPart, p0 :: Partition, p1 :: Partition, $)
    local ps0, ps1, pc0, the;
    ps0, ps1 := map(piecesOf,[p0,p1])[];
    if nops(ps0) <> nops(ps1) then return false end if;
    for pc0 in ps0 do
      the, ps1 :=
        selectremove(pc1 ->
          eqCond( condOf(pc1), condOf(pc0) ) and
          eqPart( valOf(pc1) , valOf(pc0)  )     ,ps1);
      if nops(the) <> 1 then
        return false;
      end if;
    end do;
    true;
  end proc
;
  uses Hakaru;
  ModuleLoad();
end module:


Avoid reversing list

Avoid reversing list

  #Disintegration *
  #---------------*
  #Abbreviations:
  #     wrt = "with respect to".
  #     wrt var = "a variable wrt which disintegration is performed". There may be
  #          more than one of these, in which case they are passed (in the 2nd arg)
  #          as Pairs, possibly nested.
  #     wrt-var type: Each wrt var may be continuous (Lebesgue), discrete (Counting),
  #          point evaluation (Dirac), and there may be other types added later.
  disint:= module()
  export ModuleApply, `do`;
  local
    #Dispatch table for wrt-var types. For each, there is a "cond constructor",
    #a "disintegrator", and a "disintegrator_arg_extractor". The cond constructor
    #builds the associated relation in the master piecewise; the disintegrator
    #does the differentiation or whatever operator is analogous to differentiation
    #for that type after the measure has been `improve`d; and the
    #disintegrator_arg_extractor builds the 2nd arg to the disintegrator from
    #the t_disint_var passed in the 2nd arg of disint.
    #
    #APIs:
    #     Indices:
    #          Must be the op(0, ...) of the expression passed with the
    #          wrt var.
    #     cond_constructor: (algebraic,name)-> boolean (most likely, a relation)
    #     disintegrator: (algebraic, {name, name=anything})-> algebraic
    #     disintegrator_arg_extractor:
    #          (`&M`(name, t_wrt_var_type))-> {name, name= anything}
    Wrt_var_types::static:= table([
         Lebesgue= Record(
              cond_constructor= `<=`,
              disintegrator= diff,
              disintegrator_arg_extractor= (A-> op(1,A)),
              disintegrator_type_extractor= [ (ll-> kb-> KB:-genLebesgue(op(1,ll), op(op(2,ll)), kb)), AlmostEveryReal ]
         ),
         Counting= Record(
              cond_constructor= `<=`,
              disintegrator= LREtools[delta],
              disintegrator_arg_extractor= (A-> op(1,A)),
              disintegrator_type_extractor= [ (ll-> kb-> KB:-genSummation(op(1,ll), op(op(2,ll)), kb)), HInt ]
         ),
         #Ret is aka Dirac.
         Ret= Record(
              cond_constructor= `=`,
              disintegrator='eval',
              disintegrator_arg_extractor= (A-> op(1,A)= op([2,1], A)),
              #E.g., (x &M Ret(3)) --> (x= 3).

              disintegrator_type_extractor= [ (ll -> kb -> (op(1,ll), kb)) ]
              # disintegrator_type_extractor= (ll-> kb-> KB:-genLet(op(1,ll), op([2,1],ll), kb))
         )
    ]),

    #types for disint wrt vars (2nd arg to disint)
    t_wrt_var_type,
    t_disint_var, #Curiosity: giving this a type `type` causes a kernel crash
                  #during update-archive.
    t_disint_var_pair,
    ModuleLoad::static:= proc($) #Needed to declare types.
         TypeTools:-AddType(
              t_wrt_var_type,
              satisfies(t-> assigned(Wrt_var_types[op(0,t)]))
         );
         TypeTools:-AddType(t_disint_var, {name, name &M t_wrt_var_type});
         TypeTools:-AddType(     #Caution: recursive type: Make sure base cases
           t_disint_var_pair, #are on left (a la McCarthy rule).
              'Pair'(Or(t_disint_var, t_disint_var_pair) $ 2)
         )
    end proc,
    #end of types for disint

    DV::table,  #wrt vars, with their types and conditions
    p::symbol,  #"pair"--abstract representation
    #`path` is layers of fst(...) and snd(...) built by traversing tree
    #(Weird Maple syntax note: Module prefixes seem to be required for
    #assertion type checking. Failure to include them causes kernel crash
    #during execution.)
    path::{specfunc({Hakaru:-fst, Hakaru:-snd}), symbol},

    #Parses the 2nd arg---the wrt vars.
    # works by side-effect: accumulates "paths" to variables in T
    # via the module variable DV.
    traverse_var_tree::static:= proc(
         T::{t_disint_var, t_disint_var_pair}, $
    )::identical(NULL);
    local
         v::name, #the wrt var
         M::NewSLO:-disint:-t_wrt_var_type,
         pp, #iterator over [fst, snd]---the deconstructors of Pair
         vM, vK, mks, mk_ty, mk_ctx
    ;
         if T::t_disint_var then
              #Add a default wrt-var type if none appears.
              (v,M):= op(`if`(T::name, T &M 'Lebesgue'((-1,1)*~infinity), T));
              vK   := op(0,M);
              vM   := v &M M;
              mks := Wrt_var_types[vK]:-disintegrator_type_extractor;
              mk_ty := op(1,mks);
              if nops(mks)=2 then mk_ctx := ((e)->lam(v,op(2,mks)(),e));
              else                mk_ctx := ((e)->e);
              end if;
              DV[v]:= Record(
                   'wrt_var_type'= M,
                   'path'= path,
                   'disintegrator_arg'=
                        Wrt_var_types[vK]:-disintegrator_arg_extractor(vM),
                   'disintegrator_mktype'=mk_ty(vM),
                   'disintegrator_mkctx' =mk_ctx
              );
              path:= op(path) #Peel off outer layer: fst or snd.
         else #T::Pair(..., ...)---deconstruct recursively.
              for pp in [fst, snd] do path:= pp(path); thisproc(pp(T)) end do
         end if;
         NULL
    end proc, #disint:-traverse_var_tree

    subs_disint_data := proc(sub_vars, expr, $)
        local V:= [indices(DV, 'nolist')], v
            , vars := [indices(sub_vars, 'nolist')]
            , eqns := [seq(v=sub_vars[v], v=vars)]
            , sb := (x->subs(eqns,x));

        for v in V do
            DV[v]:-disintegrator_arg := sb(DV[v]:-disintegrator_arg);
        end do;

        sb(expr);
    end proc;

  ;
    ModuleApply := proc()::t_Hakaru;
      local todo,expr,t;
      expr, todo := disint:-`do`(args)[];
      for t in todo do expr := t(expr); end do; expr;
    end proc;

   `do` := proc(
    m::t_Hakaru,
    #var &M wrt-var type, or Pairs thereof
    A::{t_disint_var, t_disint_var_pair},
    ctx::t_kb_atoms:= [] #context: parameter assumptions, "knowledge"
   ):: [t_Hakaru, list(appliable)];
   local
    mc,  #final integral to be passed to improve @ toLO; then result
         #of each disintegration step
    kb, var_rn := table(), mc_prts,
    V, #wrt vars
    v::name, #iterator over V
    improve_opts := [],
    todo := NULL,
    atodo := proc(z) todo := eval(todo), z; end proc,
    di, da
   ;
    if not {_rest} in {{'do_lam'},{}} then
      error "bad extra args: %1", {_rest};
    end if;

    #Init module variables.
    DV:= table();
    p:= gensym('p');
    path:= fst(p);

    traverse_var_tree(A); # collect information about A in DV
    V:= [indices(DV, 'nolist')];

    mc:= Bind(
         m, p,
         #The piecewise condition is a conjunction of conditions, each
         #condition formed from a (var,path) pair from DV.
         piecewise(
          And(seq(
               Wrt_var_types[op(0, DV[v]:-wrt_var_type)]:-
                cond_constructor(DV[v]:-path, v),
               v= V
          )),
          Ret(snd(p)),
          Msum()
         ));

    kb := empty;
    for v in ListTools[Reverse](V) do
        var_rn[v], kb := DV[v]:-disintegrator_mktype(kb);
    end do;
    kb := build_kb(ctx,"disint",kb);
    mc := subs_disint_data(var_rn, mc);

    atodo(x->toLO(x));
    atodo(x->improve(x, _ctx=kb,improve_opts));
    #Does the order of application of the disintegrators matter?
    #Theoretically, I think not, it's just like differentiation. As far
    #as Maple's ability to do the computation, maybe it matters.
    for v in V do
      di   := Wrt_var_types[op(0, DV[v]:-wrt_var_type)]:-disintegrator;
      da   := DV[v]:-disintegrator_arg;
      atodo(x->applyop(di, 2, x, da));
      atodo(x->improve(x, _ctx=kb,improve_opts));
    end do;

    atodo(x->fromLO(x, _ctx= kb));
    ## simplify integrals which do not mention the LO var (i.e. integrals in
    ## weights). this is a hack, we should do this inside of `improve'* in
    ## the correct place.  It is required to see the correct output for
    ## d7_normalFB1.
    #
    ## * Or, some other simplifier, which does only specific things - note
    ## the simplification we hope to see here (in d7) can only be done after
    ## the application of the `diff'. So just chucking it into `improve'
    ## might not be the correct thing to do. Calling `improve' at all might
    ## be wrong since we roundtrip through pulling off domains and replacing
    ## them (this is sort of expensive..), although we may also want such
    ## simplifications here - the application of the `diff' might give a new
    ## domain problem that can be improved significanly.
    # 'Simplify' partitions in weights by converting them to piecewise and
    # letting piecewise simplify do the work; and evaluate integrals in weights
    atodo(x->
          subsindets( x, 'Weight(anything, anything)'
                    , mw -> applyop(x->simplify_assuming(
                        subsindets( subsindets(x,Partition,PartitionToPW)
                                  , And(specfunc(`Int`)
                                       ,satisfies(e->indets(e,specfunc(`exp`))<>{})
                                       )
                                  , value
                                  )
                        , kb ), 1, mw)));

    atodo(x->subs_disint_data( table([seq(var_rn[v]=v, v=V)]), x));

    if 'do_lam' in {_rest} then
      for v in ListTools[Reverse](V) do
        atodo(x->DV[v]:-disintegrator_mkctx(x));
      end do;
    end if;

    [mc, [todo]];
   end proc; #disint:-ModuleApply
   ModuleLoad();
  end module; #disint
  ###################### end of Carl's code ######################

  #Disintegration *
  #---------------*
  #Abbreviations:
  #     wrt = "with respect to".
  #     wrt var = "a variable wrt which disintegration is performed". There may be
  #          more than one of these, in which case they are passed (in the 2nd arg)
  #          as Pairs, possibly nested.
  #     wrt-var type: Each wrt var may be continuous (Lebesgue), discrete (Counting),
  #          point evaluation (Dirac), and there may be other types added later.
  disint:= module()
  export ModuleApply, `do`;
  local
    #Dispatch table for wrt-var types. For each, there is a "cond constructor",
    #a "disintegrator", and a "disintegrator_arg_extractor". The cond constructor
    #builds the associated relation in the master piecewise; the disintegrator
    #does the differentiation or whatever operator is analogous to differentiation
    #for that type after the measure has been `improve`d; and the
    #disintegrator_arg_extractor builds the 2nd arg to the disintegrator from
    #the t_disint_var passed in the 2nd arg of disint.
    #
    #APIs:
    #     Indices:
    #          Must be the op(0, ...) of the expression passed with the
    #          wrt var.
    #     cond_constructor: (algebraic,name)-> boolean (most likely, a relation)
    #     disintegrator: (algebraic, {name, name=anything})-> algebraic
    #     disintegrator_arg_extractor:
    #          (`&M`(name, t_wrt_var_type))-> {name, name= anything}
    Wrt_var_types::static:= table([
         Lebesgue= Record(
              cond_constructor= `<=`,
              disintegrator= diff,
              disintegrator_arg_extractor= (A-> op(1,A)),
              disintegrator_type_extractor= [ (ll-> kb-> KB:-genLebesgue(op(1,ll), op(op(2,ll)), kb)), AlmostEveryReal ]
         ),
         Counting= Record(
              cond_constructor= `<=`,
              disintegrator= LREtools[delta],
              disintegrator_arg_extractor= (A-> op(1,A)),
              disintegrator_type_extractor= [ (ll-> kb-> KB:-genSummation(op(1,ll), op(op(2,ll)), kb)), HInt ]
         ),
         #Ret is aka Dirac.
         Ret= Record(
              cond_constructor= `=`,
              disintegrator='eval',
              disintegrator_arg_extractor= (A-> op(1,A)= op([2,1], A)),
              #E.g., (x &M Ret(3)) --> (x= 3).

              disintegrator_type_extractor= [ (ll -> kb -> (op(1,ll), kb)) ]
              # disintegrator_type_extractor= (ll-> kb-> KB:-genLet(op(1,ll), op([2,1],ll), kb))
         )
    ]),

    #types for disint wrt vars (2nd arg to disint)
    t_wrt_var_type,
    t_disint_var, #Curiosity: giving this a type `type` causes a kernel crash
                  #during update-archive.
    t_disint_var_pair,
    ModuleLoad::static:= proc($) #Needed to declare types.
         TypeTools:-AddType(
              t_wrt_var_type,
              satisfies(t-> assigned(Wrt_var_types[op(0,t)]))
         );
         TypeTools:-AddType(t_disint_var, {name, name &M t_wrt_var_type});
         TypeTools:-AddType(     #Caution: recursive type: Make sure base cases
           t_disint_var_pair, #are on left (a la McCarthy rule).
              'Pair'(Or(t_disint_var, t_disint_var_pair) $ 2)
         )
    end proc,
    #end of types for disint

    DV::table,  #wrt vars, with their types and conditions
    p::symbol,  #"pair"--abstract representation
    #`path` is layers of fst(...) and snd(...) built by traversing tree
    #(Weird Maple syntax note: Module prefixes seem to be required for
    #assertion type checking. Failure to include them causes kernel crash
    #during execution.)
    path::{specfunc({Hakaru:-fst, Hakaru:-snd}), symbol},

    #Parses the 2nd arg---the wrt vars.
    # works by side-effect: accumulates "paths" to variables in T
    # via the module variable DV.
    traverse_var_tree::static:= proc(
         T::{t_disint_var, t_disint_var_pair}, $
    )::identical(NULL);
    local
         v::name, #the wrt var
         M::NewSLO:-disint:-t_wrt_var_type,
         pp, #iterator over [fst, snd]---the deconstructors of Pair
         vM, vK, mks, mk_ty, mk_ctx
    ;
         if T::t_disint_var then
              #Add a default wrt-var type if none appears.
              (v,M):= op(`if`(T::name, T &M 'Lebesgue'((-1,1)*~infinity), T));
              vK   := op(0,M);
              vM   := v &M M;
              mks := Wrt_var_types[vK]:-disintegrator_type_extractor;
              mk_ty := op(1,mks);
              if nops(mks)=2 then mk_ctx := ((e)->lam(v,op(2,mks)(),e));
              else                mk_ctx := ((e)->e);
              end if;
              DV[v]:= Record(
                   'wrt_var_type'= M,
                   'path'= path,
                   'disintegrator_arg'=
                        Wrt_var_types[vK]:-disintegrator_arg_extractor(vM),
                   'disintegrator_mktype'=mk_ty(vM),
                   'disintegrator_mkctx' =mk_ctx
              );
              path:= op(path) #Peel off outer layer: fst or snd.
         else #T::Pair(..., ...)---deconstruct recursively.
              for pp in [fst, snd] do path:= pp(path); thisproc(pp(T)) end do
         end if;
         NULL
    end proc, #disint:-traverse_var_tree

    subs_disint_data := proc(sub_vars, expr, $)
        local V:= [indices(DV, 'nolist')], v
            , vars := [indices(sub_vars, 'nolist')]
            , eqns := [seq(v=sub_vars[v], v=vars)]
            , sb := (x->subs(eqns,x));

        for v in V do
            DV[v]:-disintegrator_arg := sb(DV[v]:-disintegrator_arg);
        end do;

        sb(expr);
    end proc;

  ;
    ModuleApply := proc()::t_Hakaru;
      local todo,expr;
      expr, todo := disint:-`do`(args)[];
      foldr(`@`,_->_,op(ListTools[Reverse](todo)))(expr);
    end proc;

   `do` := proc(
    m::t_Hakaru,
    #var &M wrt-var type, or Pairs thereof
    A::{t_disint_var, t_disint_var_pair},
    ctx::t_kb_atoms:= [] #context: parameter assumptions, "knowledge"
   ):: [t_Hakaru, list(appliable)];
   local
    mc,  #final integral to be passed to improve @ toLO; then result
         #of each disintegration step
    kb, var_rn := table(), mc_prts,
    V, #wrt vars
    v::name, #iterator over V
    improve_opts := [],
    todo := NULL,
    atodo := proc(z) todo := eval(todo), z; end proc,
    di, da
   ;
    if not {_rest} in {{'do_lam'},{}} then
      error "bad extra args: %1", {_rest};
    end if;

    #Init module variables.
    DV:= table();
    p:= gensym('p');
    path:= fst(p);

    traverse_var_tree(A); # collect information about A in DV
    V:= [indices(DV, 'nolist')];

    mc:= Bind(
         m, p,
         #The piecewise condition is a conjunction of conditions, each
         #condition formed from a (var,path) pair from DV.
         piecewise(
          And(seq(
               Wrt_var_types[op(0, DV[v]:-wrt_var_type)]:-
                cond_constructor(DV[v]:-path, v),
               v= V
          )),
          Ret(snd(p)),
          Msum()
         ));

    kb := empty;
    for v in ListTools[Reverse](V) do
        var_rn[v], kb := DV[v]:-disintegrator_mktype(kb);
    end do;
    kb := build_kb(ctx,"disint",kb);
    mc := subs_disint_data(var_rn, mc);

    atodo(x->toLO(x));
    atodo(x->improve(x, _ctx=kb,improve_opts));
    #Does the order of application of the disintegrators matter?
    #Theoretically, I think not, it's just like differentiation. As far
    #as Maple's ability to do the computation, maybe it matters.
    for v in V do
      di   := Wrt_var_types[op(0, DV[v]:-wrt_var_type)]:-disintegrator;
      da   := DV[v]:-disintegrator_arg;
      atodo(x->applyop(di, 2, x, da));
      atodo(x->improve(x, _ctx=kb,improve_opts));
    end do;

    atodo(x->fromLO(x, _ctx= kb));
    ## simplify integrals which do not mention the LO var (i.e. integrals in
    ## weights). this is a hack, we should do this inside of `improve'* in
    ## the correct place.  It is required to see the correct output for
    ## d7_normalFB1.
    #
    ## * Or, some other simplifier, which does only specific things - note
    ## the simplification we hope to see here (in d7) can only be done after
    ## the application of the `diff'. So just chucking it into `improve'
    ## might not be the correct thing to do. Calling `improve' at all might
    ## be wrong since we roundtrip through pulling off domains and replacing
    ## them (this is sort of expensive..), although we may also want such
    ## simplifications here - the application of the `diff' might give a new
    ## domain problem that can be improved significanly.
    # 'Simplify' partitions in weights by converting them to piecewise and
    # letting piecewise simplify do the work; and evaluate integrals in weights
    atodo(x->
          subsindets( x, 'Weight(anything, anything)'
                    , mw -> applyop(x->simplify_assuming(
                        subsindets( subsindets(x,Partition,PartitionToPW)
                                  , And(specfunc(`Int`)
                                       ,satisfies(e->indets(e,specfunc(`exp`))<>{})
                                       )
                                  , value
                                  )
                        , kb ), 1, mw)));

    atodo(x->subs_disint_data( table([seq(var_rn[v]=v, v=V)]), x));

    if 'do_lam' in {_rest} then
      for v in ListTools[Reverse](V) do
        atodo(x->DV[v]:-disintegrator_mkctx(x));
      end do;
    end if;

    [mc, [todo]];
   end proc; #disint:-ModuleApply
   ModuleLoad();
  end module; #disint
  ###################### end of Carl's code ######################