Extract a DomBound from a sum of DomBounds

# Extract a domain from an expression
export Extract := module ()
  uses Domain_Type;
  export ModuleApply := proc(e, kb, $) :: [ HDomain, anything ];
    local b, eb, s, es;
    b, eb := op(Bound(e));
    s, es := op(Shape(eb, kb ));
    [ DOMAIN(b, s), es ];
  end proc;

  # Extract a domain bound from an expression
  # This pops off the integration constructors recursively, keeping
  # track of the bounds in a KB (which literally become the DBound).
  export Bound := module ()
    export ModuleApply := proc(e, $) :: [ DomBound, anything ];
      local arg, vars, kb;
      arg, vars := do_extract(e)[];
      vars := Domain:-Bound:-withVarsIxs(DBound(vars));
      [ vars , arg ];
    end proc;

    local do_extract_arg := proc(kind, arg_)
      local x0, x, vars, arg := arg_, rng;
      x0  := ExtBound[kind]:-ExtractVar(_rest);   # variable name
      rng := ExtBound[kind]:-ExtractRange(_rest); # variable range
      x   := DInto(x0, rng, kind);                # the variable spec
      arg, vars := do_extract(arg)[];
      [ arg, [ op(vars), x ] ];
    end proc;

    local do_extract := proc(arg, $)
      local sub, prod, svars, vs;
      if arg :: `*` then
        sub := map(do_extract, [op(arg)]);
        prod, svars := selectremove(x->op(2,x)=[],sub);
        if nops(svars) = 1 then
          [ `*`(op([1,1],svars),op(map2(op,1,prod)))
            , op([1,2], svars) ];
        else
          [ arg, [] ];
        end if;
      elif arg :: `+` then
        sub := map(do_extract, [op(arg)]);
        svars := map2(op,2,sub);
        if the(map(nops,svars)) then
          vs[0] := map(sv->map2(op,1,sv), svars);      # a list of lists of variables
          vs[1] := map2(op,1, op(1,svars));            # a list of 'fresh' variables
          vs[2] := map(v->zip(`=`,v,vs[1]), vs[0]);    # variable renamings
          svars := zip(subs,vs[2], svars);             # dombounds renamed
          if the(svars) then
            [ `+`( op(zip(subs,vs[2], map2(op,1, sub))) ),
              op(1, svars) ];
          else
            [ arg, [] ]
          end if;
        else
          [ arg, [] ]
        end if;
      elif Domain:-Has:-Bound(arg) then
        do_extract_arg(op(0,arg), op(arg));
      else
        [ arg, [] ]
      end if;
    end proc;
  end module;

  # Extract a domain shape from an expression
  # This extracts the domain shape from individual multiplicands of
  # expressions, and multiplies the subexpressions back together.
  # essentially this assumes a distributive law (of domain shapes over
  # products)
  export Shape := module ()
    export ModuleApply := proc(e) :: [ anything, anything ];
      local ixs, w, e1;
      ixs := [indices(ExtShape, 'nolist')];
      w, e1 := do_gets(ixs, true, e) [];
      if not ('no_simpl' in {_rest}) then
        w := simpl_shape(w);
      end if;
      [ w, e1 ];
    end proc;

    local do_get := proc(f, f_ty, e, $)
      local sub, inds, rest;
      if e::`*` then
        sub := map(x->do_get(f, f_ty,x), [op(e)]);
        [ `And`(op(map2(op,1,sub))), `*`(op(map2(op,2,sub))) ]
      elif e::`^` then
        inds, rest := do_get(f, f_ty, op(1,e)) [] ;
        [ inds, subsop(1=rest, e) ]
      elif e:: f_ty then
        f(e,z->ModuleApply(z,'no_simpl'))
      else
        [ true, e ]
      end if
    end proc;

    # apply a list of extractors, in order, until all fail to produce
    # any output .
    local do_gets := proc(todo::list, w, e, $)
      local t0, ts, w1, e1;
      if nops(todo) = 0 then
        [ w, e ]
      else
        t0 := op(1, todo);
        ts := op(subsop(1=NULL, todo));
        w1, e1 := do_get(ExtShape[t0]:-MakeCtx
                         ,ExtShape[t0]:-MapleType
                         ,e) [] ;
        ts := `if`(is(w1), [ts], [ts, t0]);
        do_gets( ts, bool_And(w1, w), e1 );
      end if;
    end proc;

    # todo: simplify the shape
    local simpl_shape := proc(e0,$)
      local e := Domain:-simpl_relation(e0);
      e := subsindets(e, specfunc(`Or`) , x->DSum(op(x)));
      e := subsindets(e, specfunc(`And`), x->DConstrain(op(x)));
      e;
    end proc;
  end module;
end module;

# Extract a domain from an expression
export Extract := module ()
  uses Domain_Type;
  export ModuleApply := proc(e, kb, $) :: [ HDomain, anything ];
    local b, eb, s, es;
    b, eb := op(Bound(e));
    s, es := op(Shape(eb, kb ));
    [ DOMAIN(b, s), es ];
  end proc;

  # Extract a domain bound from an expression
  # This pops off the integration constructors recursively, keeping
  # track of the bounds in a KB (which literally become the DBound).
  export Bound := module ()
    export ModuleApply := proc(e, $) :: [ DomBound, anything ];
      local arg, vars, kb;
      arg, vars := do_extract(e)[];
      vars := Domain:-Bound:-withVarsIxs(DBound(vars));
      [ vars , arg ];
    end proc;

    local do_extract_arg := proc(kind, arg_)
      local x0, x, vars, arg := arg_, rng;
      x0  := ExtBound[kind]:-ExtractVar(_rest);   # variable name
      rng := ExtBound[kind]:-ExtractRange(_rest); # variable range
      x   := DInto(x0, rng, kind);                # the variable spec
      arg, vars := do_extract(arg)[];
      [ arg, [ op(vars), x ] ];
    end proc;

    local do_extract := proc(arg, $)
      local sub, prod, svars;
      if arg :: `*` then
        sub := map(do_extract, [op(arg)]);
        prod, svars := selectremove(x->op(2,x)=[],sub);
        if nops(svars) = 1 then
          [ `*`(op([1,1],svars),op(map2(op,1,prod)))
            , op([1,2], svars) ];
        else
          [ arg, [] ];
        end if;
      elif Domain:-Has:-Bound(arg) then
        do_extract_arg(op(0,arg), op(arg));
      else
        [ arg, [] ]
      end if;
    end proc;
  end module;

  # Extract a domain shape from an expression
  # This extracts the domain shape from individual multiplicands of
  # expressions, and multiplies the subexpressions back together.
  # essentially this assumes a distributive law (of domain shapes over
  # products)
  export Shape := module ()
    export ModuleApply := proc(e) :: [ anything, anything ];
      local ixs, w, e1;
      ixs := [indices(ExtShape, 'nolist')];
      w, e1 := do_gets(ixs, true, e) [];
      if not ('no_simpl' in {_rest}) then
        w := simpl_shape(w);
      end if;
      [ w, e1 ];
    end proc;

    local do_get := proc(f, f_ty, e, $)
      local sub, inds, rest;
      if e::`*` then
        sub := map(x->do_get(f, f_ty,x), [op(e)]);
        [ `And`(op(map2(op,1,sub))), `*`(op(map2(op,2,sub))) ]
      elif e::`^` then
        inds, rest := do_get(f, f_ty, op(1,e)) [] ;
        [ inds, subsop(1=rest, e) ]
      elif e:: f_ty then
        f(e,z->ModuleApply(z,'no_simpl'))
      else
        [ true, e ]
      end if
    end proc;

    # apply a list of extractors, in order, until all fail to produce
    # any output .
    local do_gets := proc(todo::list, w, e, $)
      local t0, ts, w1, e1;
      if nops(todo) = 0 then
        [ w, e ]
      else
        t0 := op(1, todo);
        ts := op(subsop(1=NULL, todo));
        w1, e1 := do_get(ExtShape[t0]:-MakeCtx
                         ,ExtShape[t0]:-MapleType
                         ,e) [] ;
        ts := `if`(is(w1), [ts], [ts, t0]);
        do_gets( ts, bool_And(w1, w), e1 );
      end if;
    end proc;

    # todo: simplify the shape
    local simpl_shape := proc(e0,$)
      local e := Domain:-simpl_relation(e0);
      e := subsindets(e, specfunc(`Or`) , x->DSum(op(x)));
      e := subsindets(e, specfunc(`And`), x->DConstrain(op(x)));
      e;
    end proc;
  end module;
end module;


Label the patch with its source and purpose in a comment


Pass KB directly

Pass KB directly

# Step 2 of 3: computer algebra

improve := proc(lo :: LO(name, anything), {_ctx :: t_kb := empty}, opts := [], $)
local r, `&context`;
  userinfo(5, improve, "input: ", print(lo &context _ctx));
  _Env_HakaruSolve := true;
  r:= LO(op(1,lo), reduce(op(2,lo), op(1,lo), _ctx, opts));
  userinfo(5, 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, opts := [], $)
  local e, elim, subintegral, w, ww, x, c, kb1, with_kb1, dom_specw, dom_specb
       , body, dom_spec, ed, mkDom, vars, rr;
  e := ee;

  rr := reduce_Integrals(e, h, kb, opts);
  if rr <> FAIL then return rr end if;
  if e :: 'applyintegrand(anything, anything)' then
    applyop(simplify_assuming, 2, e, kb)
  elif can_reduce_Partition(e) then
    reduce_Partition(e, h, kb, opts, false);
  elif e :: `+` then
    map(reduce, e, h, kb, opts)
  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, opts), 'list', `*`);
    (subintegral, ww) := selectremove(depends, subintegral, h);
    simplify_factor_assuming(`*`(w, op(ww)), kb)
      * reduce_Partition(`*`(op(subintegral)), h, kb, opts, true);
  elif e :: t_case then
    subsop(2=map(proc(b :: Branch(anything, anything))
                   eval(subsop(2='reduce'(op(2,b),x,c,opts),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, opts);
  elif e :: 'toLO:-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, opts)), e)
  else
    simplify_assuming(e, kb)
  end if;
end proc;

# Returns true for expressions for which we could conceivably
# do a Partition simplification.
can_reduce_Partition := proc(e,$)
  if   type(e,Or(Partition,t_pw)) then true
  elif type(e,{indices(Partition:-Simpl:-distrib_op_Partition,nolist)}) then
    nops(select(can_reduce_Partition, convert(e,list)))>1
    # in this case, we hope to apply PProd and then maybe do some cleanup;
    # this is only possible if the expression has at least two sub-Partitions
  else false
  end if;
end proc;

# Same as reduce, but for Partitions; and contains an additional flag which,
# when true, checks `can_reduce_Partition' (when the check is false, there is a
# great chance this function will throw an error!)
reduce_Partition := proc(ee,h::name,kb::t_kb,opts::list,do_check::truefalse, $)
  local e := ee;
  if do_check and not(can_reduce_Partition(e)) then return e end if;

  e := subsindets(e, t_pw, PWToPartition);
  e := Partition:-Simpl(e);

  # This is necessary because subsequent calls to kb_Partition do not work on
  # nested Partitions; but Simpl calls flatten, which should gives us a
  # Partition on the top level.
  if not(e::Partition) then
    error "simplifying %1 should have produced a Partition", ee;
  end if;
  e := kb_Partition(e, kb, simplify_assuming,
                    ((rhs, kb) -> %reduce(rhs, h, kb, opts)));
  e := eval(e, %reduce=reduce);
  # big hammer: simplify knows about bound variables, amongst many
  # other things
  Testzero := x -> evalb(simplify(x) = 0);
  e := Partition:-Simpl(e);
  if ee::t_pw and e :: Partition then
    e := Partition:-PartitionToPW(e);
  end if;
  e;
end proc;

# "Integrals" refers to any types of "integrals" understood by domain (Int,
# Sum currently)
reduce_Integrals := module()
  export ModuleApply;
  local
  # The callbacks passed by reduce_Integrals to Domain:-Reduce
    reduce_Integrals_body, reduce_Integrals_into
  # tries to evaluate a RootOf
  , try_eval_Root
  # tries to evaluate Int/Sum/Ints/Sums
  , elim_intsum;

  reduce_Integrals_body := proc(h,opts,x,kb1) reduce(x,h,kb1,opts) end proc;
  reduce_Integrals_into := proc(h,opts,kind,e,vn,vt,kb,$)
    local rr;
    rr := elim_intsum(Domain:-Apply:-do_mk(args[3..-1]), h, kb,opts);
    rr := subsindets(rr, specfunc(RootOf), x->try_eval_Root(x,a->a));
    return rr;
  end proc;

  ModuleApply := proc(expr, h, kb, opts, $)
    local rr;
    rr := Domain:-Reduce(expr, kb
      ,curry(reduce_Integrals_into,h,opts)
      ,curry(reduce_Integrals_body,h,opts)
      ,(_->:-DOM_FAIL), opts);
    rr := Partition:-Simpl(rr, kb);
    if has(rr, :-DOM_FAIL) then
      return FAIL;
    elif has(rr, FAIL) then
      error "Something strange happened in reduce_Integral(%a, %a, %a, %a)\n%a"
           , expr, kb, kb, opts, rr;
    end if;
    rr;
  end proc;

  try_eval_Root := proc(e0::specfunc(`RootOf`),on_fail := (_->FAIL), $)
    local ix,e := e0;
    try
      if nops(e)=2 or nops(e)=3
      and op(-1,e) :: `=`(identical(index),{specindex(real),nonnegint}) then
        ix := op([2,-1],e);
        if ix :: specindex(real) then ix := op(ix); end if;
        e := op(0,e)(op(1,e));
      else
        ix := NULL;
      end if;
      e := convert(e, 'radical', ix);
      if e :: specfunc(RootOf) then return on_fail(e) end if;
      return e;
    catch: return on_fail(e0); end try;
  end proc;

  # Try to find an eliminate (by evaluation, or simplification) integrals which
  # are free of `applyintegrand`s.
  elim_intsum := module ()
    export ModuleApply := proc(inert0, h :: name, kb :: t_kb, opts, $)
       local ex, e, inert := inert0;
       ex := extract_elim(inert, h, kb);
       e[0] := apply_elim(h, kb, ex);
       e[1] := check_elim(inert, e[0]);
       if e[1] = FAIL then inert
       else
         e[2] := reduce(e[1],h,kb,opts);
         if has(e[2], {csgn}) then
           WARNING("Throwing away an eliminated result result containing csgn (this "
                   "could be a bug!):\n%1\n(while running %2)", e[2], ex);
           inert;
         else e[2] end if;
       end if
    end proc;

    local known_tys := table([Int=int_assuming,Sum=sum_assuming,Ints=ints,Sums=sums]);
    local extract_elim := proc(e, h::name, kb::t_kb,$)
      local t, intapps, var, f, e_k, e_args, vs, blo, bhi;
      vs := {op(KB:-kb_to_variables(kb))};
      t := 'applyintegrand'('identical'(h), 'anything');
      intapps := indets(op(1,e), t);
      if intapps = {} then
        return FAIL;
      end if;
      e_k := op(0,e); e_args := op([2..-1],e);
      if Domain:-Has:-Bound(e) and assigned(known_tys[e_k]) then
        var := Domain:-ExtBound[e_k]:-ExtractVar(e_args);
        ASSERT(var::DomBoundVar);
        blo, bhi := Domain:-ExtBound[e_k]:-SplitRange
                    (Domain:-ExtBound[e_k]:-ExtractRange(e_args));
        if ormap(b->op(1,b) in map((q-> (q,-q)), vs) and op(2,b)::SymbolicInfinity
                ,[[blo,bhi],[bhi,blo]]) then
          return FAIL end if;
        if var :: list then var := op(1,var) end if;
        if not depends(intapps, var) then
          f := known_tys[e_k];
        else
          return FAIL;
        end if;
      end if;
      [ op(1,e), f, var, [e_args] ];
    end proc;

    local apply_elim := proc(h::name,kb::t_kb,todo::{list,identical(FAIL)})
      local body, f, var, rrest;
      if todo = FAIL then return FAIL; end if;
      body, f, var, rrest := op(todo);
      banish(body, h, kb, infinity, var,
             proc (kb1,g,$) do_elim_intsum(kb1, f, g, op(rrest)) end proc);
    end proc;

    local check_elim := proc(e, elim,$)
      if has(elim, {MeijerG, undefined, FAIL}) or e = elim or elim :: SymbolicInfinity then
        return FAIL;
      end if;
      return elim;
    end proc;

    local do_elim_intsum := proc(kb, f, ee, v::{name,name=anything})
      local w, e, x, g, t, r;
      w, e := op(Domain:-Extract:-Shape(ee));
      w := Domain:-Shape:-toConstraints(w);
      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;
  end module; # elim
end module; # reduce_Integrals

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;

# Int( .., var=var_ty ) == var &X var_ty
isBound_IntSum := kind -> module()
  option record;
  export MakeKB := (`if`(kind=Sum,KB:-genSummation,KB:-genLebesgue));
  export ExtractVar := (e->op(1,e));
  export ExtractRange := (e->op(2,e));
  export MakeRange := `..`;
  export SplitRange := (e->op(e));
  export Constrain := `if`(kind=Sum,`<=`,`<`);
  export DoMk := ((e,v,t)->kind(e,v=t));
  export Min := `min`; export Max := `max`;
  export VarType := 'name';
  export RangeType := 'range';
  export MapleType := 'And'('specfunc'(kind), 'anyfunc(anything,name=range)');
  export BoundType := `if`(kind=Sum,'integer','real');
  export RecogBound := `if`(kind=Sum,
            (proc(k,b)
               if   k = `<=` then (x->subsop(2=b,x))
               elif k = `>=` then (x->subsop(1=b,x))
               elif k = `<`  then (x->subsop(2=(b-1),x))
               elif k = `>`  then (x->subsop(1=b+1,x))
               end if;
             end proc),
            (proc(k,b)
               if   k in {`<=`,`<`} then (x->subsop(2=b,x))
               elif k in {`>=`,`>`} then (x->subsop(1=b,x))
               end if;
             end proc));
end module;

# Ints( .., var::name, var_ty::range, dims::list(name=range) ) ==
#        [ var   , map(lhs,dims) ] :: list(name)  &X
#        [ var_ty, map(rhs,dims) ] :: list(range)
isBound_IntsSums := kind -> module()
  option record;
  export MakeKB := proc(vars, lo, hi, kb, $)
    local var, dims, ty, rngs, x, kb1;
    var  := op(1, vars);
    rngs := zip(`..`,lo,hi);
    ty   := op(1, rngs);
    dims := subsop(1=NULL,zip(`=`,vars,rngs));
   x, kb1 := genType(var,
                      mk_HArray(`if`(kind=Ints,
                                     HReal(open_bounds(ty)),
                                     HInt(closed_bounds(ty))),
                                dims),kb);
    if nops(dims) > 0 then
      kb1 := assert(size(x)=op([-1,2,2],dims)-op([-1,2,1],dims)+1, kb1);
    end if;
    x, kb1;
  end proc;
  export ExtractVar   := ((v,t,d)->[v,map(lhs,d)[]]);
  export ExtractRange := ((v,t,d)->[t,map(rhs,d)[]]);
  export MakeRange    := ((a,b)->zip(`..`,a,b));
  export SplitRange   := (rs->(map(x->op(1,x),rs), map(x->op(2,x),rs)));
  export Constrain    := ((a,b)->zip(`if`(kind=Ints, `<`, `<=`),a,b)[]);
  export DoMk         := ((e,v,t)->kind( e,op(1,v),op(1,t), subsop(1=NULL,zip(`=`,v,t)) ));
  export Min          := ((a,b)->zip(`min`,a,b));
  export Max          := ((a,b)->zip(`max`,a,b));
  export VarType      := 'And(list(name),satisfies(x->x<>[]))';
  export RangeType    := 'And(list(range),satisfies(x->x<>[]))';
  export MapleType    := 'And'('specfunc'(kind),'anyfunc'('anything', 'name', 'range', 'list(name=range)'));
  export BoundType    := TopProp;
  export RecogBound   := (_->NULL);
end module;

# Step 2 of 3: computer algebra

improve := proc(lo :: LO(name, anything), {_ctx :: t_kb := empty}, opts := [], $)
local r, `&context`;
  userinfo(5, improve, "input: ", print(lo &context _ctx));
  _Env_HakaruSolve := true;
  r:= LO(op(1,lo), reduce(op(2,lo), op(1,lo), _ctx, opts));
  userinfo(5, 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, opts := [], $)
  local e, elim, subintegral, w, ww, x, c, kb1, with_kb1, dom_specw, dom_specb
       , body, dom_spec, ed, mkDom, vars, rr;
  e := ee;

  rr := reduce_Integrals(e, h, kb, opts);
  if rr <> FAIL then return rr end if;
  if e :: 'applyintegrand(anything, anything)' then
    applyop(simplify_assuming, 2, e, kb)
  elif can_reduce_Partition(e) then
    reduce_Partition(e, h, kb, opts, false);
  elif e :: `+` then
    map(reduce, e, h, kb, opts)
  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, opts), 'list', `*`);
    (subintegral, ww) := selectremove(depends, subintegral, h);
    simplify_factor_assuming(`*`(w, op(ww)), kb)
      * reduce_Partition(`*`(op(subintegral)), h, kb, opts, true);
  elif e :: t_case then
    subsop(2=map(proc(b :: Branch(anything, anything))
                   eval(subsop(2='reduce'(op(2,b),x,c,opts),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, opts);
  elif e :: 'toLO:-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, opts)), e)
  else
    simplify_assuming(e, kb)
  end if;
end proc;

# Returns true for expressions for which we could conceivably
# do a Partition simplification.
can_reduce_Partition := proc(e,$)
  if   type(e,Or(Partition,t_pw)) then true
  elif type(e,{indices(Partition:-Simpl:-distrib_op_Partition,nolist)}) then
    nops(select(can_reduce_Partition, convert(e,list)))>1
    # in this case, we hope to apply PProd and then maybe do some cleanup;
    # this is only possible if the expression has at least two sub-Partitions
  else false
  end if;
end proc;

# Same as reduce, but for Partitions; and contains an additional flag which,
# when true, checks `can_reduce_Partition' (when the check is false, there is a
# great chance this function will throw an error!)
reduce_Partition := proc(ee,h::name,kb::t_kb,opts::list,do_check::truefalse, $)
  local e := ee;
  if do_check and not(can_reduce_Partition(e)) then return e end if;

  e := subsindets(e, t_pw, PWToPartition);
  e := Partition:-Simpl(e);

  # This is necessary because subsequent calls to kb_Partition do not work on
  # nested Partitions; but Simpl calls flatten, which should gives us a
  # Partition on the top level.
  if not(e::Partition) then
    error "simplifying %1 should have produced a Partition", ee;
  end if;
  e := kb_Partition(e, kb, simplify_assuming,
                    ((rhs, kb) -> %reduce(rhs, h, kb, opts)));
  e := eval(e, %reduce=reduce);
  # big hammer: simplify knows about bound variables, amongst many
  # other things
  Testzero := x -> evalb(simplify(x) = 0);
  e := Partition:-Simpl(e);
  if ee::t_pw and e :: Partition then
    e := Partition:-PartitionToPW(e);
  end if;
  e;
end proc;

# "Integrals" refers to any types of "integrals" understood by domain (Int,
# Sum currently)
reduce_Integrals := module()
  export ModuleApply;
  local
  # The callbacks passed by reduce_Integrals to Domain:-Reduce
    reduce_Integrals_body, reduce_Integrals_into
  # tries to evaluate a RootOf
  , try_eval_Root
  # tries to evaluate Int/Sum/Ints/Sums
  , elim_intsum;

  reduce_Integrals_body := proc(h,opts,x,kb1) reduce(x,h,kb1,opts) end proc;
  reduce_Integrals_into := proc(h,opts,kind,e,vn,vt,kb,$)
    local rr;
    rr := elim_intsum(Domain:-Apply:-do_mk(args[3..-1]), h, kb,opts);
    rr := subsindets(rr, specfunc(RootOf), x->try_eval_Root(x,a->a));
    return rr;
  end proc;

  ModuleApply := proc(expr, h, kb, opts, $)
    local rr;
    rr := Domain:-Reduce(expr, kb
      ,curry(reduce_Integrals_into,h,opts)
      ,curry(reduce_Integrals_body,h,opts)
      ,(_->:-DOM_FAIL), opts);
    rr := kb_assuming_mb(Partition:-Simpl)(rr, kb, x->x);
    if has(rr, :-DOM_FAIL) then
      return FAIL;
    elif has(rr, FAIL) then
      error "Something strange happened in reduce_Integral(%a, %a, %a, %a)\n%a"
           , expr, kb, kb, opts, rr;
    end if;
    rr;
  end proc;

  try_eval_Root := proc(e0::specfunc(`RootOf`),on_fail := (_->FAIL), $)
    local ix,e := e0;
    try
      if nops(e)=2 or nops(e)=3
      and op(-1,e) :: `=`(identical(index),{specindex(real),nonnegint}) then
        ix := op([2,-1],e);
        if ix :: specindex(real) then ix := op(ix); end if;
        e := op(0,e)(op(1,e));
      else
        ix := NULL;
      end if;
      e := convert(e, 'radical', ix);
      if e :: specfunc(RootOf) then return on_fail(e) end if;
      return e;
    catch: return on_fail(e0); end try;
  end proc;

  # Try to find an eliminate (by evaluation, or simplification) integrals which
  # are free of `applyintegrand`s.
  elim_intsum := module ()
    export ModuleApply := proc(inert0, h :: name, kb :: t_kb, opts, $)
       local ex, e, inert := inert0;
       ex := extract_elim(inert, h, kb);
       e[0] := apply_elim(h, kb, ex);
       e[1] := check_elim(inert, e[0]);
       if e[1] = FAIL then inert
       else
         e[2] := reduce(e[1],h,kb,opts);
         if has(e[2], {csgn}) then
           WARNING("Throwing away an eliminated result result containing csgn (this "
                   "could be a bug!):\n%1\n(while running %2)", e[2], ex);
           inert;
         else e[2] end if;
       end if
    end proc;

    local known_tys := table([Int=int_assuming,Sum=sum_assuming,Ints=ints,Sums=sums]);
    local extract_elim := proc(e, h::name, kb::t_kb,$)
      local t, intapps, var, f, e_k, e_args, vs, blo, bhi;
      vs := {op(KB:-kb_to_variables(kb))};
      t := 'applyintegrand'('identical'(h), 'anything');
      intapps := indets(op(1,e), t);
      if intapps = {} then
        return FAIL;
      end if;
      e_k := op(0,e); e_args := op([2..-1],e);
      if Domain:-Has:-Bound(e) and assigned(known_tys[e_k]) then
        var := Domain:-ExtBound[e_k]:-ExtractVar(e_args);
        ASSERT(var::DomBoundVar);
        blo, bhi := Domain:-ExtBound[e_k]:-SplitRange
                    (Domain:-ExtBound[e_k]:-ExtractRange(e_args));
        if ormap(b->op(1,b) in map((q-> (q,-q)), vs) and op(2,b)::SymbolicInfinity
                ,[[blo,bhi],[bhi,blo]]) then
          return FAIL end if;
        if var :: list then var := op(1,var) end if;
        if not depends(intapps, var) then
          f := known_tys[e_k];
        else
          return FAIL;
        end if;
      end if;
      [ op(1,e), f, var, [e_args] ];
    end proc;

    local apply_elim := proc(h::name,kb::t_kb,todo::{list,identical(FAIL)})
      local body, f, var, rrest;
      if todo = FAIL then return FAIL; end if;
      body, f, var, rrest := op(todo);
      banish(body, h, kb, infinity, var,
             proc (kb1,g,$) do_elim_intsum(kb1, f, g, op(rrest)) end proc);
    end proc;

    local check_elim := proc(e, elim,$)
      if has(elim, {MeijerG, undefined, FAIL}) or e = elim or elim :: SymbolicInfinity then
        return FAIL;
      end if;
      return elim;
    end proc;

    local do_elim_intsum := proc(kb, f, ee, v::{name,name=anything})
      local w, e, x, g, t, r;
      w, e := op(Domain:-Extract:-Shape(ee));
      w := Domain:-Shape:-toConstraints(w);
      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;
  end module; # elim
end module; # reduce_Integrals

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;

# Int( .., var=var_ty ) == var &X var_ty
isBound_IntSum := kind -> module()
  option record;
  export MakeKB := (`if`(kind=Sum,KB:-genSummation,KB:-genLebesgue));
  export ExtractVar := (e->op(1,e));
  export ExtractRange := (e->op(2,e));
  export MakeRange := `..`;
  export SplitRange := (e->op(e));
  export Constrain := `if`(kind=Sum,`<=`,`<`);
  export DoMk := ((e,v,t)->kind(e,v=t));
  export Min := `min`; export Max := `max`;
  export VarType := 'name';
  export RangeType := 'range';
  export MapleType := 'And'('specfunc'(kind), 'anyfunc(anything,name=range)');
  export BoundType := `if`(kind=Sum,'integer','real');
  export RecogBound := `if`(kind=Sum,
            (proc(k,b)
               if   k = `<=` then (x->subsop(2=b,x))
               elif k = `>=` then (x->subsop(1=b,x))
               elif k = `<`  then (x->subsop(2=(b-1),x))
               elif k = `>`  then (x->subsop(1=b+1,x))
               end if;
             end proc),
            (proc(k,b)
               if   k in {`<=`,`<`} then (x->subsop(2=b,x))
               elif k in {`>=`,`>`} then (x->subsop(1=b,x))
               end if;
             end proc));
end module;

# Ints( .., var::name, var_ty::range, dims::list(name=range) ) ==
#        [ var   , map(lhs,dims) ] :: list(name)  &X
#        [ var_ty, map(rhs,dims) ] :: list(range)
isBound_IntsSums := kind -> module()
  option record;
  export MakeKB := proc(vars, lo, hi, kb, $)
    local var, dims, ty, rngs, x, kb1;
    var  := op(1, vars);
    rngs := zip(`..`,lo,hi);
    ty   := op(1, rngs);
    dims := subsop(1=NULL,zip(`=`,vars,rngs));
   x, kb1 := genType(var,
                      mk_HArray(`if`(kind=Ints,
                                     HReal(open_bounds(ty)),
                                     HInt(closed_bounds(ty))),
                                dims),kb);
    if nops(dims) > 0 then
      kb1 := assert(size(x)=op([-1,2,2],dims)-op([-1,2,1],dims)+1, kb1);
    end if;
    x, kb1;
  end proc;
  export ExtractVar   := ((v,t,d)->[v,map(lhs,d)[]]);
  export ExtractRange := ((v,t,d)->[t,map(rhs,d)[]]);
  export MakeRange    := ((a,b)->zip(`..`,a,b));
  export SplitRange   := (rs->(map(x->op(1,x),rs), map(x->op(2,x),rs)));
  export Constrain    := ((a,b)->zip(`if`(kind=Ints, `<`, `<=`),a,b)[]);
  export DoMk         := ((e,v,t)->kind( e,op(1,v),op(1,t), subsop(1=NULL,zip(`=`,v,t)) ));
  export Min          := ((a,b)->zip(`min`,a,b));
  export Max          := ((a,b)->zip(`max`,a,b));
  export VarType      := 'And(list(name),satisfies(x->x<>[]))';
  export RangeType    := 'And(list(range),satisfies(x->x<>[]))';
  export MapleType    := 'And'('specfunc'(kind),'anyfunc'('anything', 'name', 'range', 'list(name=range)'));
  export BoundType    := TopProp;
  export RecogBound   := (_->NULL);
end module;


Add debug printing of dom_spec + kb + LMS(kb) in reduce_IntSum

# 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;

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

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

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

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

    dom_spec := kb_subtract(kb2, kb0);

    if infolevel['procname'] > 3 then
        printf("LMS     : %a\n"
               "kb Big  : %a\n"
               "kb small: %a\n"
               "domain  : %a\n"
         , kb_LMS(kb2), kb2, kb0, dom_spec );
    end if;

    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 return 0 else make := eval; new_rng := op(3,new_rng) end if
    end if;
    e := `*`(e, op(map(proc(a::[identical(assert),anything], $)
                         Indicator(op(2,a))
                       end proc,
                       dom_spec)));
    elim := elim_intsum(make(e, var=new_rng), h, kb0);
    if elim = FAIL then
      e, w := selectremove(depends, list_of_mul(e), var);
      reduce_pw(simplify_factor_assuming(`*`(op(w)), kb0))
        * make(`*`(op(e)), var=new_rng);
    else
      reduce(elim, h, kb0);
    end if
  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;

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

    # if there are domain restrictions, try to apply them
    (dom_spec, e) := get_indicators(ee);
    kb2 := foldr(assert, kb1, op(dom_spec));

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

    dom_spec := kb_subtract(kb2, kb0);
    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 return 0 else make := eval; new_rng := op(3,new_rng) end if
    end if;
    e := `*`(e, op(map(proc(a::[identical(assert),anything], $)
                         Indicator(op(2,a))
                       end proc,
                       dom_spec)));
    elim := elim_intsum(make(e, var=new_rng), h, kb0);
    if elim = FAIL then
      e, w := selectremove(depends, list_of_mul(e), var);
      reduce_pw(simplify_factor_assuming(`*`(op(w)), kb0))
        * make(`*`(op(e)), var=new_rng);
    else
      reduce(elim, h, kb0);
    end if
  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;


Save context for each variable

Save context for each variable

  #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`, htype_to_disint_wrt;
  local
    htypeatom_to_disint_wrt,
    #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,

    TYPES := table(
         [(t_wrt_var_type=
              'satisfies(t-> assigned(Wrt_var_types[op(0,t)]))')
         ,(t_disint_var = '{name, name &M t_wrt_var_type}')
         ,(     #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)')
         ]),

    ModuleLoad::static:= proc($) #Needed to declare types.
      BindingTools:-load_types_from_table(TYPES);
    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,t_kb}:= [] #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, kbs := table(), 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, m_var, m_var_rn, m_ty, m_body, ctx1, x
   ;
    if m :: t_lam then
      m_var, m_ty, m_body := op(m);
      ctx1 := KB:-build_kb(ctx,"disint",KB:-empty);
      m_var_rn, ctx1 := KB:-genType(m_var, m_ty, ctx1);
      return
        applyop( t->[op(t),x->'lam'(m_var_rn, m_ty, x)]
               , 2,`do`(subs(m_var=m_var_rn, m_body)
                       , A, ctx1, _rest));
    end if;

    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 := build_kb(ctx,"disint",KB:-empty);
    for v in ListTools[Reverse](V) do
        kbs[v] := kb;
        var_rn[v], kb := DV[v]:-disintegrator_mktype(kb);
    end do;
    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(unapply('applyop'(di, 2, x, da),x));
      atodo(x->improve(x, _ctx=kb,["no_domain",op(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

    htypeatom_to_disint_wrt := table(
      [ AlmostEveryReal=Lebesgue
      , HReal=Lebesgue
      , HInt=Counting ]);

    htype_to_disint_wrt := proc(t::t_type,inside_wrt::truefalse := false,$)
      if t::'HMeasure(anything)' then
        htype_to_disint_wrt(op(1,t));
      elif t::'HFunction(anything,anything)' then
        htype_to_disint_wrt(op(2,t));
      elif t::specfunc({AlmostEveryReal, HReal, HInt}) then
        gensym(:-`t`) &M htypeatom_to_disint_wrt[op(0,t)](op(eval(KB:-range_of_htype(t), Open=(x->x))));
      elif t::'HData(DatumStruct(identical(pair),[Konst(anything),Konst(anything)]))' then
        if inside_wrt then
          Pair(seq(htypeatom_to_disint_wrt(op([1,2,i,1],t),true),i=[1,2]));
        else
          htype_to_disint_wrt(op([1,2,1,1],t),true);
        end if;
      else
        error "don't know how to disintegrate %1", t;
      end if;
    end proc;

    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`, htype_to_disint_wrt;
  local
    htypeatom_to_disint_wrt,
    #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,

    TYPES := table(
         [(t_wrt_var_type=
              'satisfies(t-> assigned(Wrt_var_types[op(0,t)]))')
         ,(t_disint_var = '{name, name &M t_wrt_var_type}')
         ,(     #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)')
         ]),

    ModuleLoad::static:= proc($) #Needed to declare types.
      BindingTools:-load_types_from_table(TYPES);
    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,t_kb}:= [] #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, m_var, m_var_rn, m_ty, m_body, ctx1, x
   ;
    if m :: t_lam then
      m_var, m_ty, m_body := op(m);
      ctx1 := KB:-build_kb(ctx,"disint",KB:-empty);
      m_var_rn, ctx1 := KB:-genType(m_var, m_ty, ctx1);
      return
        applyop( t->[op(t),x->'lam'(m_var_rn, m_ty, x)]
               , 2,`do`(subs(m_var=m_var_rn, m_body)
                       , A, ctx1, _rest));
    end if;

    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 := build_kb(ctx,"disint",KB:-empty);
    for v in ListTools[Reverse](V) do
        var_rn[v], kb := DV[v]:-disintegrator_mktype(kb);
    end do;
    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(unapply('applyop'(di, 2, x, da),x));
      atodo(x->improve(x, _ctx=kb,["no_domain",op(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

    htypeatom_to_disint_wrt := table(
      [ AlmostEveryReal=Lebesgue
      , HReal=Lebesgue
      , HInt=Counting ]);

    htype_to_disint_wrt := proc(t::t_type,inside_wrt::truefalse := false,$)
      if t::'HMeasure(anything)' then
        htype_to_disint_wrt(op(1,t));
      elif t::'HFunction(anything,anything)' then
        htype_to_disint_wrt(op(2,t));
      elif t::specfunc({AlmostEveryReal, HReal, HInt}) then
        gensym(:-`t`) &M htypeatom_to_disint_wrt[op(0,t)](op(eval(KB:-range_of_htype(t), Open=(x->x))));
      elif t::'HData(DatumStruct(identical(pair),[Konst(anything),Konst(anything)]))' then
        if inside_wrt then
          Pair(seq(htypeatom_to_disint_wrt(op([1,2,i,1],t),true),i=[1,2]));
        else
          htype_to_disint_wrt(op([1,2,1,1],t),true);
        end if;
      else
        error "don't know how to disintegrate %1", t;
      end if;
    end proc;

    ModuleLoad();
  end module; #disint
  ###################### end of Carl's code ######################


An extra assuming is needed to see the simplifications we want. Note that this only affects expressions of the form e^(K*t), where K is a constant and t is a disintegration variable. This same simplification is the one we want in other the call to kb_assuming in disint

  #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;
  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))
         ),
         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))
         ),
         #Ret is aka Dirac.
         Ret= Record(
              cond_constructor= `=`,
              #If it wasn't necessary to clean out the superfluous `Indicator`s,
              #then this disintegrator could simply be `eval`, which would
              #have a great symmetry, the 3 disintegrators being diff, delta,
              #and eval.
              disintegrator= ((e::algebraic, pt::{name=anything})->
                   eval(
                        eval(e, pt),
                        #Remove any Indicator made superfluous by the above eval:
                        Indicator= (r-> `if`(r::`=` and r, 1, 'Indicator'(r)))
                   )
              ),
              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
    ;
         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;
              DV[v]:= Record(
                   'wrt_var_type'= M,
                   'path'= path,
                   'disintegrator_arg'=
                        Wrt_var_types[vK]:-disintegrator_arg_extractor(vM),
                   'disintegrator_mktype'=
                        Wrt_var_types[vK]:-disintegrator_type_extractor(vM)
              );
              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(
    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;
   local
    mc,  #final integral to be passed to improve @ toLO; then result
         #of each disintegration step
    kb, var_rn := table(),
    V, #wrt vars
    v::name #iterator over V
   ;

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

    traverse_var_tree(A); # collect information about A in DV
    userinfo(3, Disint, "DV:", eval(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);

    userinfo(3, Disint, "Disint defn:", eval(mc), kb);
    userinfo(3, Disint, "Disint path:", path);

    mc:= improve(toLO(mc), _ctx= kb);

    userinfo(3, Disint, "Disint improved:", eval(mc));

    #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
         mc:= applyop(
          Wrt_var_types[op(0, DV[v]:-wrt_var_type)]:-disintegrator,
          2, mc, DV[v]:-disintegrator_arg
        );

         # 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.
         mc :=
          kb_assuming_mb( _mc ->
            subsindets( _mc, And(specfunc(`Int`),freeof(op(1, _mc))), x-> simplify( int(op(x)) ) )
                        )(mc, kb, x->x);

         # all of the below achieve the same as the above, but in a different
         # way.
         # mc :=  subs( `int`=`Int`, improve( eval(mc, `Int`=`int`), _ctx=kb ) );
         # mc := subs( `int`=`Int`, improve( eval(mc, `Int`=`int`) , _ctx=kb) );
         # mc := kb_assuming_mb(x-> subs(`int`=`Int`,simplify(eval(x, `Int`=`int`))) )(mc, kb, x->x);

        userinfo(3, Disint, "Disint diff:", eval(mc));
    end do;

    # mc := fromLO(mc, _ctx= kb);
    mc := kb_assuming_mb( _mc -> fromLO(_mc, _ctx= kb)
                        )(mc, kb, _-> fromLO(mc, _ctx= kb) );

    userinfo(3, Disint, "Disint hakaru:", eval(mc));

    mc := subs_disint_data( table([seq(var_rn[v]=v, v=V)]), mc );

    mc

   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;
  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))
         ),
         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))
         ),
         #Ret is aka Dirac.
         Ret= Record(
              cond_constructor= `=`,
              #If it wasn't necessary to clean out the superfluous `Indicator`s,
              #then this disintegrator could simply be `eval`, which would
              #have a great symmetry, the 3 disintegrators being diff, delta,
              #and eval.
              disintegrator= ((e::algebraic, pt::{name=anything})->
                   eval(
                        eval(e, pt),
                        #Remove any Indicator made superfluous by the above eval:
                        Indicator= (r-> `if`(r::`=` and r, 1, 'Indicator'(r)))
                   )
              ),
              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
    ;
         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;
              DV[v]:= Record(
                   'wrt_var_type'= M,
                   'path'= path,
                   'disintegrator_arg'=
                        Wrt_var_types[vK]:-disintegrator_arg_extractor(vM),
                   'disintegrator_mktype'=
                        Wrt_var_types[vK]:-disintegrator_type_extractor(vM)
              );
              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(
    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;
   local
    mc,  #final integral to be passed to improve @ toLO; then result
         #of each disintegration step
    kb, var_rn := table(),
    V, #wrt vars
    v::name #iterator over V
   ;

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

    traverse_var_tree(A); # collect information about A in DV
    userinfo(3, Disint, "DV:", eval(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);

    userinfo(3, Disint, "Disint defn:", eval(mc), kb);
    userinfo(3, Disint, "Disint path:", path);

    mc:= improve(toLO(mc), _ctx= kb);

    userinfo(3, Disint, "Disint improved:", eval(mc));

    #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
         mc:= applyop(
          Wrt_var_types[op(0, DV[v]:-wrt_var_type)]:-disintegrator,
          2, mc, DV[v]:-disintegrator_arg
        );

         # 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.
         mc :=
          kb_assuming_mb( _mc ->
            subsindets( _mc, And(specfunc(`Int`),freeof(op(1, _mc))), x-> simplify( int(op(x)) ) )
                        )(mc, kb, x->x);

         # all of the below achieve the same as the above, but in a different
         # way.
         # mc :=  subs( `int`=`Int`, improve( eval(mc, `Int`=`int`), _ctx=kb ) );
         # mc := subs( `int`=`Int`, improve( eval(mc, `Int`=`int`) , _ctx=kb) );
         # mc := kb_assuming_mb(x-> subs(`int`=`Int`,simplify(eval(x, `Int`=`int`))) )(mc, kb, x->x);

        userinfo(3, Disint, "Disint diff:", eval(mc));
    end do;

    mc := fromLO(mc, _ctx= kb);

    userinfo(3, Disint, "Disint hakaru:", eval(mc));

    mc := subs_disint_data( table([seq(var_rn[v]=v, v=V)]), mc );

    mc

   end proc; #disint:-ModuleApply
   ModuleLoad();
  end module; #disint
  ###################### end of Carl's code ######################