Set prettyprint=0 only when output is asked to be printed

Mainly for debugging

# This module forms part of NewSLO and is `$include`d there

Commands := [ `Simplify`, `Disintegrate`, `Summarize` ];

RoundTrip := proc(e, t::t_type, {_ret_type := {'print', [ 'convert', 'Partition', 'piecewise'] }
                                ,_gensym_charset := FAIL
                                ,_command := Simplify})
  local result, ret_type, cs, ifc_opts, syms0, command;
  ret_type := _ret_type; command := _command;
  if not(ret_type::set) then ret_type := {ret_type}; end if;
  if command::string then command := convert(command, name); end if;
  if not (command in Commands) then
    error "unrecognized command: %1", command;
  end if;
  if _gensym_charset <> FAIL then
    syms0 := copy(gensym:-SymbolsToGen);
    gensym:-SymbolsToGen := _gensym_charset;
  else
    syms0 := gensym:-SymbolsToGen;
  end if;

  ifc_opts[0] :=
     screenwidth=9999,
     `if`('print' in ret_type, prettyprint=0, NULL),
     warnlevel=0,
     showassumed=0,
     quiet=true;

  ifc_opts[1] := interface(ifc_opts[0]);
  try
    kernelopts(assertlevel=0);
    result := _command(e,t,_rest);
    for cs in select(type, ret_type, [ identical(convert), type, anything ]) do
      result := subsindets(result, op(2,cs), x->convert(x,op(3,cs)));
    end do;
    result := eval(ToInert(result), _Inert_ATTRIBUTE=NULL);
    result := sprintf("%a",result);
    if 'print' in ret_type then printf("%s\n",result); end if;
    if not ('string' in ret_type) then
      result := NULL;
    end if;
  finally
    interface(zip(`=`, map(lhs,[ifc_opts[0]]), [ifc_opts[1]])[]);
    gensym:-SymbolsToGen := syms0;
  end try;
  return result;
end proc;

Summarize := proc(e, _) Summary:-Summarize(e,_rest) end proc;

Simplify := proc(e, t::t_type, {ctx :: list := []})
  local res;
  res := subsindets(SimplifyKB(e, t, build_kb(ctx, "Simplify")),
             And({t_sum, t_product}, anyfunc(anything, anything=range)),
             e -> subsop(0 = `if`(e::t_sum, SumIE, ProductIE),
                         applyop(`+`, [2,2,2], e, 1)));
  Rename(res,_rest);
end proc;

Rename := proc(e, {_do_rename :: truefalse := false})
  local ns;
  if _do_rename then
    ns := [op(bound_names_in(res))];
    subs(zip(`=`,ns,
             [seq(cat(`x`,convert(i,string)),i=1..nops(ns))]),
         e);
  else e
  end if;
end proc;

Disintegrate := proc(e::t_Hakaru,t::t_type, {ctx::list := []})
  local res;
  res := SimplifyKB_((e,t,kb)->disint(e,disint:-htype_to_disint_wrt(t),kb,'do_lam',_rest),
                     e, t, build_kb(ctx,"Disintegrate",KB:-empty));
  Rename(res,_rest);
end proc;

SimplifyKB_ := proc(leaf, e, t::t_type, kb::t_kb, $)
  local patterns, x, kb1, ex;
  if t :: HFunction(anything, anything) then
    patterns := htype_patterns(op(1,t));
    if patterns :: Branches(Branch(PVar(name),anything)) then
      # Eta-expand the function type
      x := `if`(e::lam(name,anything,anything), op(1,e),
                op([1,1,1],patterns));
      x, kb1 := genType(x, op(1,t), kb, e);
      ex := app(e,x);
      lam(x, op(1,t), SimplifyKB_(leaf,ex, op(2,t), kb1))
    else
      # Eta-expand the function type and the sum-of-product argument-type
      x := `if`(e::lam(name,anything,anything), op(1,e), d);
      if depends([e,t,kb], x) then x := gensym(x) end if;
      ex := app(e,x);
      lam(x, op(1,t), 'case'(x,
        map(proc(branch)
            local eSubst, pSubst, p1, binds, y, kb1, i, pSubst1;
              eSubst, pSubst := pattern_match([x,e], x, op(1,branch));
              p1 := subs(pSubst, op(1,branch));
              binds := [pattern_binds(p1)];
              kb1 := kb;
              pSubst1 := table();
              for i from 1 to nops(binds) do
                y, kb1 := genType(op(i,binds), op([2,i],branch), kb1);
                pSubst1[op(i,binds)] := y;
              end do;
              pSubst1 := op(op(pSubst1));
              Branch(subs(pSubst1, p1),
                     SimplifyKB_(leaf,eval(eval(ex,eSubst),pSubst1), op(2,t), kb1))
            end proc,
            patterns)))
    end if
  else
    leaf(e,t,kb)
  end if
end proc;

SimplifyKB := proc(e,t,kb,$)
  local res;
  res[0] := SimplifyKB_(
  proc(e0,t,kb)
    local e := eval_for_Simplify(e0,kb);
    if t :: HMeasure(anything) then
      fromLO(improve(toLO(e), _ctx=kb), _ctx=kb);
    else
      simplify_assuming(e,kb);
    end if;
  end proc, e, t, kb);

  res[1] := eval(res[0]);
  if res[1] <> res[0] then
    KB:-simplify_assuming(res[1], kb);
  else
    res[0]
  end if;
end proc;

eval_for_Simplify_tbl := table(
  [ `Int`=`int`
  # Some parts (which?) of the simplifier still always need `sum` instead of `Sum`
  , `Sum`=[`sum`,Not(anything)]
  , `Product`=`product`
  ]);

eval_for_Simplify := proc(e,kb,$)
  eval_in_ctx(
    proc(x,kb1)
      subsindets(x, {seq(specfunc(q),q=[indices(eval_for_Simplify_tbl, nolist)])},
                 y -> KB:-kb_eval_mb(eval_for_Simplify_tbl[op(0,y)],y,kb1));
    end proc, e, kb);
end proc;

eval_in_ctx_tbl := table(
  [ `PARTITION` = ((e,kb,ev)->KB:-kb_Partition(e,kb,a->a,ev))
  , `piecewise` = ((e,kb,ev)->KB:-kb_piecewise(e,kb,a->a,ev))
  ]);

eval_in_ctx := proc(ev, e, kb, $)
  if assigned(eval_in_ctx_tbl[op(0,e)]) then
    eval_in_ctx_tbl[op(0,e)](e,kb,curry(eval_in_ctx, ev));
  elif has(e, {indices(eval_in_ctx_tbl,nolist)}) then
    ev(map(x->eval_in_ctx(ev,x,kb),e),kb);
  else
    ev(e,kb);
  end if;
end proc;

# Testing

TestSimplify := proc(m, t, n::algebraic:=m, {verify:=simplify})
  local s, r;
  # How to pass keyword argument {ctx::list:=[]} on to Simplify?
  s, r := selectremove(type, [_rest], 'identical(ctx)=anything');
  CodeTools[Test](Simplify(m,t,op(s)), n, measure(verify), op(r))
end proc;

TestHakaru := proc(m, n::{set(algebraic),algebraic}:=m,
                   {simp:=improve, verify:=simplify, ctx::list:=[]})
  local kb := build_kb(ctx, "TestHakaru"), ver := measure(verify);
  ver := `if`(n::set, 'member'(ver), ver);

  CodeTools[Test](fromLO(simp(toLO(m), _ctx=kb), _ctx=kb), n,
    ver, _rest)
end proc;

TestDisint := module()
    export ModuleApply := proc(
      M::{t_Hakaru, list(anything)}, #args to disint, or just 1st arg
      n::set({t_Hakaru, identical(NULL)}), #desired return
      ctx::t_kb_atoms:= [], #context: assumptions, "knowledge"
      TLim::{positive, identical(-1)}:= 80 #timelimit
    )
      local disint_args, disint_var, expected := n;
      if M :: list then
        disint_args := [op(M),ctx];
      else
        disint_var := gensym('t');
        disint_args := [M,disint_var,ctx];
        expected := subs(:-`t`=disint_var,expected);
      end if;
      try
        do_test(disint_args, copy(expected), TLim, _rest);
      catch "time expired":
        error "Time expired while running: disint(%1)", disint_args;
      end try;
    end proc;

    # This is necessary because CodeTools seems to forgot the value
    # of our local variables (but only the `expected result' arg)
    # unless that arg is precisely a formal parameter, and we `copy' the
    # input to this function.
    local do_test := proc(disint_args, expected, tlim)
      timelimit( tlim, CodeTools[Test]
                 ( {disint(op(disint_args))}
                 , expected
                 , '`subset`(measure(simplify))'
                 , _rest));
    end proc;
end module;

TestEfficient := proc(e, t::t_type, t_kb := KB:-empty, {label::string := "Test" })
  local out, result;
  out := SimplifyKB(args[1..3]);

  _Env_TestTools_Try_printf := false;
  result := TestTools[Try](label, Efficient(out),true);
  if result = NULL then
    printf("%s passed.\n", label);
  else
    error sprintf("%s FAILED.\n"
                  "The result of\n\tSimplifyKB(%a,%a,%a)\n\tis not efficient.\n"
                 , label, args[1..3] );
  end if;
end proc;

# Test roughly for "efficient" Hakaru measure terms,
# i.e., those we want simplification to produce.
Efficient := proc(mm, $)
  local m, n;
  m := mm;
  if has(m, 'undefined') then
    return false;
  end if;
  while m :: '{lam(name, anything, anything),
               Context(anything, anything),
               case(anything, Branches(Branch(anything, anything))),
               And(specfunc(piecewise)
                  ,{anyfunc(anything, anything, Msum())
                   ,anyfunc(anything, Msum(), anything)
                   ,anyfunc(anything, anything, anything, Msum())
                   ,anyfunc(anything, Msum(), anything, anything)})}' do
    m := op(`if`(op(0,m)='lam',3,`if`(op(0,m)='case',[2,1,2],2)),m);
  end do;
  if m :: 'Weight(anything, anything)' then m := op(2,m) end if;
  if has(m, '{infinity, Lebesgue, int, Int, Beta, GAMMA}') then
    return false;
  end if;
  for n in `if`(m :: 'specfunc(Msum)', m, [m]) do
    if n :: 'Weight(anything, anything)' then n := op(2,n) end if;
    if has(subsindets(n, 'specfunc(Weight(anything, anything), Msum)',
                      s -> `if`(Testzero(`+`(op(map2(op, 1, s))) - 1),
                                map2(op, 2, s), s)),
           '{Msum, Weight}') then
      return false;
    end if;
  end do;
  return true;
end proc;

Profile := module()
  option package;
  export ModuleApply, GetProf, PPrProf, modules_to_profile, names_to_profile;
  local ModuleLoad, cl, profile_flag_to_ord, name_to_string, take;

  modules_to_profile := proc()
    kernelopts(opaquemodules=false):
    { 'BindingTools', 'Hakaru', 'KB', 'Partition', 'Partition:-Simpl', 'Loop'
    , 'Domain', 'NewSLO', 'Summary'
    , entries(Domain:-Improve:-Simplifiers, nolist)
    };
  end proc();

  cl := proc(f,x,$)
    local rs := f(x) minus x;
    if rs={} then x else cl(f,rs) end if;
  end proc;

  take := proc(xs,n,$)
    op(1,[ListTools[LengthSplit](xs,n)]);
  end proc;

  names_to_profile := proc()
    option remember, system;
    local ns;
    kernelopts(opaquemodules=false):
    ns := cl(curry(map,x->CodeTools:-Profiling:-getMemberFuncs(x,true)), modules_to_profile);
    map(proc(n)
          if n::`module`('ModuleApply') then 'n[ModuleApply]' elif n::procedure then n else NULL end if
        end proc, ns);
  end proc;

  name_to_string := (x->convert(x,'string'));

  profile_flag_to_ord := table(
     ['alpha' = (proc (a, b) lexorder(a[1],b[1]) end proc)
     ,'ralpha' = (proc (a, b) not lexorder(a[1],b[1]) end proc)
     ,'time' = (proc (a, b) evalb(a[4] < b[4]) end proc)
     ,'rtime' = (proc (a, b) evalb(b[4] < a[4]) end proc)
     ,'bytes' = (proc (a, b) evalb(a[6] < b[6]) end proc)
     ,'rbytes' = (proc (a, b) evalb(b[6] < a[6]) end proc)
     ,'load' = (proc (a, b) evalb(a[6]*a[6]*a[4] < b[6]*b[6]*b[4]) end proc)
     ,'rload' = (proc (a, b) evalb(b[6]*b[6]*b[4] < a[6]*a[6]*a[4]) end proc)
     ]);

  GetProf := proc(fns::({list,set})(satisfies(x->member(x,:-profile_profiled)))
                 ,{_flag:='rload'}
                 )
    local i, totaltime, totalbytes, totaldepth, totalcalls, timepc, bytespc, numargs, displist, totaltimepc, totalbytespc
         , ix, get_timepc, get_bytespc, get_nm, nm, flag ;
    global profile_time, profile_bytes, profile_maxdepth, profile_calls, profile_profiled;

    flag := _flag;
    totaltime, totalbytes, totalcalls, totaldepth := 0$4;
    numargs := nops(fns);

    for i to nops(profile_profiled) do
      ix := name_to_string(profile_profiled[i]);
      totaltime := totaltime+profile_time[ix];
      totalbytes := totalbytes+profile_bytes[ix];
      totalcalls := totalcalls+profile_calls[ix];
      totaldepth := totaldepth+profile_maxdepth[ix];
    end do;

    if totaltime = 0 then
      get_timepc := i->0;
      totaltimepc := 0;
    else
      get_timepc := i->100*profile_time[name_to_string(profile_profiled[i])]/totaltime;
      totaltimepc := 100;
    end if;
    for i to nops(profile_profiled) do
      timepc[name_to_string(profile_profiled[i])] := get_timepc(i);
    end do;

    if totalbytes = 0 then
      get_bytespc := i->0;
      totalbytespc := 0;
    else
      get_bytespc := i->100*profile_bytes[name_to_string(profile_profiled[i])]/totalbytes;
      totalbytespc := 100;
    end if;
    for i to nops(profile_profiled) do
      bytespc[name_to_string(profile_profiled[i])] := get_bytespc(i);
    end do;

    displist := [];
    if 0 < numargs then
      get_nm := i->op(i,fns);
    else
      numargs := nops(profile_profiled);
      get_nm := i->profile_profiled[i];
    end if;
    for i to numargs do
      nm := get_nm(i); ix := name_to_string(nm);
      displist := [op(displist),
                   [nm, map(q->q[ix],[profile_maxdepth, profile_calls,
                                      profile_time, timepc, profile_bytes, bytespc])[]  ]];
    end do;

    displist := sort(displist, profile_flag_to_ord[flag]);
    displist, [totaldepth,totalcalls,totaltime,totaltimepc,totalbytes,totalbytespc];
  end proc;

  PPrProf := proc(dat,tot,{_max_name_len:=55,_prof_name:=`function`})
    local i, k, pr_nm;
    k := _max_name_len; pr_nm := _prof_name;

    printf(cat(pr_nm,(" "$k-StringTools[Length](convert(pr_nm,string))),
               `depth    calls     time    time%%     `));
    printf(`    bytes   bytes%%\n`);
    printf(cat("--"$k+1,`\n`));
    for i from 1 to nops(dat) do
      printf(cat(`%-`,convert(k,string),`a%7d%9d%9.3f%9.2f%14d%9.2f\n`),
             op(1..7,dat[i]));
    end do;
    printf(cat("--"$k+1,`\n`));
    printf(cat(`%-`,convert(k,string),`a%7d%9d%9.3f%9.2f%14d%9.2f\n\n`),
           `total:`,op(1..6,tot));
    return NULL
  end proc;

  ModuleApply := proc(f,{_args:=[]})
    local names_prof, res, nppr, rm_ppr, prf, tot, as; as := _args;
    if assigned(_Env_Profile_count_ppr) then
      nppr := _Env_Profile_count_ppr;
    else nppr := 25; end if;
    if assigned(_Env_Profile_remove_ppr) then
      rm_ppr := _Env_Profile_remove_ppr;
    else rm_ppr := (x->andmap(q->op(q,x)<0.001,[3,4,6])); end if;

    unprofile();
    names_prof := names_to_profile();
    profile(op(names_prof));
    if   f::string then res := NULL; read(f);
    else                res := f(op(as)); end if;
    prf, tot := GetProf(names_prof,_rest);
    unprofile();
    prf := remove(rm_ppr, prf);
    PPrProf(take(prf,nppr),tot,_rest);
    res;
  end proc;

  ModuleLoad := proc($)
    unprotect(:-convert);
    :-convert := overload([proc(x::name,_::identical(string),$) option overload(callseq_only); sprintf("%a",x) end proc
                          ,:-convert]);
    protect(:-convert);
    map(unprotect,[modules_to_profile]);
    NULL;
  end proc;
  ModuleLoad();
end module;

# Load a file in concrete Hakaru syntax (using the "momiji" command)
# and return its term (in which Sum and Product are inert) and type.
Concrete := proc(path::string, $)
  local cmd, res, dangerous_chars;
  cmd := FileTools:-AbsolutePath(path,
    (FileTools:-ParentDirectory@@2)(LibraryTools:-FindLibrary(Hakaru)));
  dangerous_chars := [ " ", "'", """", `if`(kernelopts(platform)="windows", [], ["\\"])[] ];
  if ormap((c->StringTools:-Has(cmd,c)), dangerous_chars) then
    error "Dangerous characters in path: %1", cmd;
  end if;
  cmd := cat("momiji ", cmd);
  res := ssystem(cmd);
  if res :: [0, string] then
    parse(cat("use Hakaru in ", op(2,res), " end use"));
  else
    error "ssystem %1: %2", cmd, res;
  end if;
end proc;

# This module forms part of NewSLO and is `$include`d there

Commands := [ `Simplify`, `Disintegrate`, `Summarize` ];

RoundTrip := proc(e, t::t_type, {_ret_type := {'print', [ 'convert', 'Partition', 'piecewise'] }
                                ,_gensym_charset := FAIL
                                ,_command := Simplify})
  local result, ret_type, cs, ifc_opts, syms0, command;
  ret_type := _ret_type; command := _command;
  if not(ret_type::set) then ret_type := {ret_type}; end if;
  if command::string then command := convert(command, name); end if;
  if not (command in Commands) then
    error "unrecognized command: %1", command;
  end if;
  if _gensym_charset <> FAIL then
    syms0 := copy(gensym:-SymbolsToGen);
    gensym:-SymbolsToGen := _gensym_charset;
  else
    syms0 := gensym:-SymbolsToGen;
  end if;

  ifc_opts[0] := screenwidth=9999, prettyprint=0, warnlevel=0,
    showassumed=0,quiet=true;

  ifc_opts[1] := interface(ifc_opts[0]);
  try
    kernelopts(assertlevel=0);
    result := _command(e,t,_rest);
    for cs in select(type, ret_type, [ identical(convert), type, anything ]) do
      result := subsindets(result, op(2,cs), x->convert(x,op(3,cs)));
    end do;
    result := eval(ToInert(result), _Inert_ATTRIBUTE=NULL);
    result := sprintf("%a",result);
    if 'print' in ret_type then printf("%s\n",result); end if;
    if not ('string' in ret_type) then
      result := NULL;
    end if;
  finally
    interface(zip(`=`, map(lhs,[ifc_opts[0]]), [ifc_opts[1]])[]);
    gensym:-SymbolsToGen := syms0;
  end try;
  return result;
end proc;

Summarize := proc(e, _) Summary:-Summarize(e,_rest) end proc;

Simplify := proc(e, t::t_type, {ctx :: list := []})
  local res;
  res := subsindets(SimplifyKB(e, t, build_kb(ctx, "Simplify")),
             And({t_sum, t_product}, anyfunc(anything, anything=range)),
             e -> subsop(0 = `if`(e::t_sum, SumIE, ProductIE),
                         applyop(`+`, [2,2,2], e, 1)));
  Rename(res,_rest);
end proc;

Rename := proc(e, {_do_rename :: truefalse := false})
  local ns;
  if _do_rename then
    ns := [op(bound_names_in(res))];
    subs(zip(`=`,ns,
             [seq(cat(`x`,convert(i,string)),i=1..nops(ns))]),
         e);
  else e
  end if;
end proc;

Disintegrate := proc(e::t_Hakaru,t::t_type, {ctx::list := []})
  local res;
  res := SimplifyKB_((e,t,kb)->disint(e,disint:-htype_to_disint_wrt(t),kb,'do_lam',_rest),
                     e, t, build_kb(ctx,"Disintegrate",KB:-empty));
  Rename(res,_rest);
end proc;

SimplifyKB_ := proc(leaf, e, t::t_type, kb::t_kb, $)
  local patterns, x, kb1, ex;
  if t :: HFunction(anything, anything) then
    patterns := htype_patterns(op(1,t));
    if patterns :: Branches(Branch(PVar(name),anything)) then
      # Eta-expand the function type
      x := `if`(e::lam(name,anything,anything), op(1,e),
                op([1,1,1],patterns));
      x, kb1 := genType(x, op(1,t), kb, e);
      ex := app(e,x);
      lam(x, op(1,t), SimplifyKB_(leaf,ex, op(2,t), kb1))
    else
      # Eta-expand the function type and the sum-of-product argument-type
      x := `if`(e::lam(name,anything,anything), op(1,e), d);
      if depends([e,t,kb], x) then x := gensym(x) end if;
      ex := app(e,x);
      lam(x, op(1,t), 'case'(x,
        map(proc(branch)
            local eSubst, pSubst, p1, binds, y, kb1, i, pSubst1;
              eSubst, pSubst := pattern_match([x,e], x, op(1,branch));
              p1 := subs(pSubst, op(1,branch));
              binds := [pattern_binds(p1)];
              kb1 := kb;
              pSubst1 := table();
              for i from 1 to nops(binds) do
                y, kb1 := genType(op(i,binds), op([2,i],branch), kb1);
                pSubst1[op(i,binds)] := y;
              end do;
              pSubst1 := op(op(pSubst1));
              Branch(subs(pSubst1, p1),
                     SimplifyKB_(leaf,eval(eval(ex,eSubst),pSubst1), op(2,t), kb1))
            end proc,
            patterns)))
    end if
  else
    leaf(e,t,kb)
  end if
end proc;

SimplifyKB := proc(e,t,kb,$)
  local res;
  res[0] := SimplifyKB_(
  proc(e0,t,kb)
    local e := eval_for_Simplify(e0,kb);
    if t :: HMeasure(anything) then
      fromLO(improve(toLO(e), _ctx=kb), _ctx=kb);
    else
      simplify_assuming(e,kb);
    end if;
  end proc, e, t, kb);

  res[1] := eval(res[0]);
  if res[1] <> res[0] then
    KB:-simplify_assuming(res[1], kb);
  else
    res[0]
  end if;
end proc;

eval_for_Simplify_tbl := table(
  [ `Int`=`int`
  # Some parts (which?) of the simplifier still always need `sum` instead of `Sum`
  , `Sum`=[`sum`,Not(anything)]
  , `Product`=`product`
  ]);

eval_for_Simplify := proc(e,kb,$)
  eval_in_ctx(
    proc(x,kb1)
      subsindets(x, {seq(specfunc(q),q=[indices(eval_for_Simplify_tbl, nolist)])},
                 y -> KB:-kb_eval_mb(eval_for_Simplify_tbl[op(0,y)],y,kb1));
    end proc, e, kb);
end proc;

eval_in_ctx_tbl := table(
  [ `PARTITION` = ((e,kb,ev)->KB:-kb_Partition(e,kb,a->a,ev))
  , `piecewise` = ((e,kb,ev)->KB:-kb_piecewise(e,kb,a->a,ev))
  ]);

eval_in_ctx := proc(ev, e, kb, $)
  if assigned(eval_in_ctx_tbl[op(0,e)]) then
    eval_in_ctx_tbl[op(0,e)](e,kb,curry(eval_in_ctx, ev));
  elif has(e, {indices(eval_in_ctx_tbl,nolist)}) then
    ev(map(x->eval_in_ctx(ev,x,kb),e),kb);
  else
    ev(e,kb);
  end if;
end proc;

# Testing

TestSimplify := proc(m, t, n::algebraic:=m, {verify:=simplify})
  local s, r;
  # How to pass keyword argument {ctx::list:=[]} on to Simplify?
  s, r := selectremove(type, [_rest], 'identical(ctx)=anything');
  CodeTools[Test](Simplify(m,t,op(s)), n, measure(verify), op(r))
end proc;

TestHakaru := proc(m, n::{set(algebraic),algebraic}:=m,
                   {simp:=improve, verify:=simplify, ctx::list:=[]})
  local kb := build_kb(ctx, "TestHakaru"), ver := measure(verify);
  ver := `if`(n::set, 'member'(ver), ver);

  CodeTools[Test](fromLO(simp(toLO(m), _ctx=kb), _ctx=kb), n,
    ver, _rest)
end proc;

TestDisint := module()
    export ModuleApply := proc(
      M::{t_Hakaru, list(anything)}, #args to disint, or just 1st arg
      n::set({t_Hakaru, identical(NULL)}), #desired return
      ctx::t_kb_atoms:= [], #context: assumptions, "knowledge"
      TLim::{positive, identical(-1)}:= 80 #timelimit
    )
      local disint_args, disint_var, expected := n;
      if M :: list then
        disint_args := [op(M),ctx];
      else
        disint_var := gensym('t');
        disint_args := [M,disint_var,ctx];
        expected := subs(:-`t`=disint_var,expected);
      end if;
      try
        do_test(disint_args, copy(expected), TLim, _rest);
      catch "time expired":
        error "Time expired while running: disint(%1)", disint_args;
      end try;
    end proc;

    # This is necessary because CodeTools seems to forgot the value
    # of our local variables (but only the `expected result' arg)
    # unless that arg is precisely a formal parameter, and we `copy' the
    # input to this function.
    local do_test := proc(disint_args, expected, tlim)
      timelimit( tlim, CodeTools[Test]
                 ( {disint(op(disint_args))}
                 , expected
                 , '`subset`(measure(simplify))'
                 , _rest));
    end proc;
end module;

TestEfficient := proc(e, t::t_type, t_kb := KB:-empty, {label::string := "Test" })
  local out, result;
  out := SimplifyKB(args[1..3]);

  _Env_TestTools_Try_printf := false;
  result := TestTools[Try](label, Efficient(out),true);
  if result = NULL then
    printf("%s passed.\n", label);
  else
    error sprintf("%s FAILED.\n"
                  "The result of\n\tSimplifyKB(%a,%a,%a)\n\tis not efficient.\n"
                 , label, args[1..3] );
  end if;
end proc;

# Test roughly for "efficient" Hakaru measure terms,
# i.e., those we want simplification to produce.
Efficient := proc(mm, $)
  local m, n;
  m := mm;
  if has(m, 'undefined') then
    return false;
  end if;
  while m :: '{lam(name, anything, anything),
               Context(anything, anything),
               case(anything, Branches(Branch(anything, anything))),
               And(specfunc(piecewise)
                  ,{anyfunc(anything, anything, Msum())
                   ,anyfunc(anything, Msum(), anything)
                   ,anyfunc(anything, anything, anything, Msum())
                   ,anyfunc(anything, Msum(), anything, anything)})}' do
    m := op(`if`(op(0,m)='lam',3,`if`(op(0,m)='case',[2,1,2],2)),m);
  end do;
  if m :: 'Weight(anything, anything)' then m := op(2,m) end if;
  if has(m, '{infinity, Lebesgue, int, Int, Beta, GAMMA}') then
    return false;
  end if;
  for n in `if`(m :: 'specfunc(Msum)', m, [m]) do
    if n :: 'Weight(anything, anything)' then n := op(2,n) end if;
    if has(subsindets(n, 'specfunc(Weight(anything, anything), Msum)',
                      s -> `if`(Testzero(`+`(op(map2(op, 1, s))) - 1),
                                map2(op, 2, s), s)),
           '{Msum, Weight}') then
      return false;
    end if;
  end do;
  return true;
end proc;

Profile := module()
  option package;
  export ModuleApply, GetProf, PPrProf, modules_to_profile, names_to_profile;
  local ModuleLoad, cl, profile_flag_to_ord, name_to_string, take;

  modules_to_profile := proc()
    kernelopts(opaquemodules=false):
    { 'BindingTools', 'Hakaru', 'KB', 'Partition', 'Partition:-Simpl', 'Loop'
    , 'Domain', 'NewSLO', 'Summary'
    , entries(Domain:-Improve:-Simplifiers, nolist)
    };
  end proc();

  cl := proc(f,x,$)
    local rs := f(x) minus x;
    if rs={} then x else cl(f,rs) end if;
  end proc;

  take := proc(xs,n,$)
    op(1,[ListTools[LengthSplit](xs,n)]);
  end proc;

  names_to_profile := proc()
    option remember, system;
    local ns;
    kernelopts(opaquemodules=false):
    ns := cl(curry(map,x->CodeTools:-Profiling:-getMemberFuncs(x,true)), modules_to_profile);
    map(proc(n)
          if n::`module`('ModuleApply') then 'n[ModuleApply]' elif n::procedure then n else NULL end if
        end proc, ns);
  end proc;

  name_to_string := (x->convert(x,'string'));

  profile_flag_to_ord := table(
     ['alpha' = (proc (a, b) lexorder(a[1],b[1]) end proc)
     ,'ralpha' = (proc (a, b) not lexorder(a[1],b[1]) end proc)
     ,'time' = (proc (a, b) evalb(a[4] < b[4]) end proc)
     ,'rtime' = (proc (a, b) evalb(b[4] < a[4]) end proc)
     ,'bytes' = (proc (a, b) evalb(a[6] < b[6]) end proc)
     ,'rbytes' = (proc (a, b) evalb(b[6] < a[6]) end proc)
     ,'load' = (proc (a, b) evalb(a[6]*a[6]*a[4] < b[6]*b[6]*b[4]) end proc)
     ,'rload' = (proc (a, b) evalb(b[6]*b[6]*b[4] < a[6]*a[6]*a[4]) end proc)
     ]);

  GetProf := proc(fns::({list,set})(satisfies(x->member(x,:-profile_profiled)))
                 ,{_flag:='rload'}
                 )
    local i, totaltime, totalbytes, totaldepth, totalcalls, timepc, bytespc, numargs, displist, totaltimepc, totalbytespc
         , ix, get_timepc, get_bytespc, get_nm, nm, flag ;
    global profile_time, profile_bytes, profile_maxdepth, profile_calls, profile_profiled;

    flag := _flag;
    totaltime, totalbytes, totalcalls, totaldepth := 0$4;
    numargs := nops(fns);

    for i to nops(profile_profiled) do
      ix := name_to_string(profile_profiled[i]);
      totaltime := totaltime+profile_time[ix];
      totalbytes := totalbytes+profile_bytes[ix];
      totalcalls := totalcalls+profile_calls[ix];
      totaldepth := totaldepth+profile_maxdepth[ix];
    end do;

    if totaltime = 0 then
      get_timepc := i->0;
      totaltimepc := 0;
    else
      get_timepc := i->100*profile_time[name_to_string(profile_profiled[i])]/totaltime;
      totaltimepc := 100;
    end if;
    for i to nops(profile_profiled) do
      timepc[name_to_string(profile_profiled[i])] := get_timepc(i);
    end do;

    if totalbytes = 0 then
      get_bytespc := i->0;
      totalbytespc := 0;
    else
      get_bytespc := i->100*profile_bytes[name_to_string(profile_profiled[i])]/totalbytes;
      totalbytespc := 100;
    end if;
    for i to nops(profile_profiled) do
      bytespc[name_to_string(profile_profiled[i])] := get_bytespc(i);
    end do;

    displist := [];
    if 0 < numargs then
      get_nm := i->op(i,fns);
    else
      numargs := nops(profile_profiled);
      get_nm := i->profile_profiled[i];
    end if;
    for i to numargs do
      nm := get_nm(i); ix := name_to_string(nm);
      displist := [op(displist),
                   [nm, map(q->q[ix],[profile_maxdepth, profile_calls,
                                      profile_time, timepc, profile_bytes, bytespc])[]  ]];
    end do;

    displist := sort(displist, profile_flag_to_ord[flag]);
    displist, [totaldepth,totalcalls,totaltime,totaltimepc,totalbytes,totalbytespc];
  end proc;

  PPrProf := proc(dat,tot,{_max_name_len:=55,_prof_name:=`function`})
    local i, k, pr_nm;
    k := _max_name_len; pr_nm := _prof_name;

    printf(cat(pr_nm,(" "$k-StringTools[Length](convert(pr_nm,string))),
               `depth    calls     time    time%%     `));
    printf(`    bytes   bytes%%\n`);
    printf(cat("--"$k+1,`\n`));
    for i from 1 to nops(dat) do
      printf(cat(`%-`,convert(k,string),`a%7d%9d%9.3f%9.2f%14d%9.2f\n`),
             op(1..7,dat[i]));
    end do;
    printf(cat("--"$k+1,`\n`));
    printf(cat(`%-`,convert(k,string),`a%7d%9d%9.3f%9.2f%14d%9.2f\n\n`),
           `total:`,op(1..6,tot));
    return NULL
  end proc;

  ModuleApply := proc(f,{_args:=[]})
    local names_prof, res, nppr, rm_ppr, prf, tot, as; as := _args;
    if assigned(_Env_Profile_count_ppr) then
      nppr := _Env_Profile_count_ppr;
    else nppr := 25; end if;
    if assigned(_Env_Profile_remove_ppr) then
      rm_ppr := _Env_Profile_remove_ppr;
    else rm_ppr := (x->andmap(q->op(q,x)<0.001,[3,4,6])); end if;

    unprofile();
    names_prof := names_to_profile();
    profile(op(names_prof));
    if   f::string then res := NULL; read(f);
    else                res := f(op(as)); end if;
    prf, tot := GetProf(names_prof,_rest);
    unprofile();
    prf := remove(rm_ppr, prf);
    PPrProf(take(prf,nppr),tot,_rest);
    res;
  end proc;

  ModuleLoad := proc($)
    unprotect(:-convert);
    :-convert := overload([proc(x::name,_::identical(string),$) option overload(callseq_only); sprintf("%a",x) end proc
                          ,:-convert]);
    protect(:-convert);
    map(unprotect,[modules_to_profile]);
    NULL;
  end proc;
  ModuleLoad();
end module;

# Load a file in concrete Hakaru syntax (using the "momiji" command)
# and return its term (in which Sum and Product are inert) and type.
Concrete := proc(path::string, $)
  local cmd, res, dangerous_chars;
  cmd := FileTools:-AbsolutePath(path,
    (FileTools:-ParentDirectory@@2)(LibraryTools:-FindLibrary(Hakaru)));
  dangerous_chars := [ " ", "'", """", `if`(kernelopts(platform)="windows", [], ["\\"])[] ];
  if ormap((c->StringTools:-Has(cmd,c)), dangerous_chars) then
    error "Dangerous characters in path: %1", cmd;
  end if;
  cmd := cat("momiji ", cmd);
  res := ssystem(cmd);
  if res :: [0, string] then
    parse(cat("use Hakaru in ", op(2,res), " end use"));
  else
    error "ssystem %1: %2", cmd, res;
  end if;
end proc;


Handle Ints/Sums variables

Handle Ints/Sums variables

local constraints_about_vars := module()
    export ModuleApply := proc(vs0 :: DomBound, sh :: DomShape, $)
        local vs := vs0, ctx;
        vs  := {op(Domain:-Bound:-varsOf(vs))};
        ctx := Domain:-Bound:-toConstraints(vs0, 'bound_types');
        subsindets(sh, DomConstrain
                  ,x->do_simpl_constraints(vs, ctx, x));
    end proc;

    local do_simpl_constraints := proc(vars, ctx_vs, x, $)
        local ctx1, ctx, ss, td, rest, d, in_vs;
        ss, ctx := selectremove(q->depends(q,indets(vars,And(name,Not(constant)) )), x);
        in_vs := q-> not(lhs(q) in vars) and not(rhs(q) in vars);
        td, rest := selectremove(type, ss, And(relation,satisfies(in_vs)));
        ctx1 := { op(ctx), op(ctx_vs), op(rest) };
        d := map(x->try_make_about(vars,ctx1,x), td);
        DConstrain(op(d), op(ctx), op(rest));
    end proc;

    local try_make_about := proc(vars, ctx1, q0, $)
        local vars_q, q_s, q := q0;
        vars_q := indets(q, name) intersect vars;
        if nops(vars_q) = 1 then
            vars_q := op(1,vars_q);
            q := KB:-try_improve_exp(q, vars_q, ctx1);
            q_s := solve({q},[vars_q], 'useassumptions'=true) assuming (op(ctx1));
            if q_s::list and nops(q_s)=1 then
                op(op(1,q_s));
            else
                q
            end if;
        else
            q
        end if;
    end proc;
end module;

# Pushes constraints down, or pulls them up, when there are such constraints.
local do_ctx_dir := dir -> proc(vs :: DomBound, sh :: DomShape, $)
    local ctx := `if`(nops(vs)=2,op(2,vs),{});
    ctx := remove(x->x::`::`,ctx);
    if ctx <> {} then
        dir(ctx)(sh);
    else
        sh;
    end if;
end proc;

local push_ctx_down :=
  do_ctx_dir(ctx->sh->subsindets(sh, DomConstrain, x->if nops(x)<>0 then DConstrain(op(x), op(ctx)) else DConstrain() end if));

local pull_ctx_out :=
  do_ctx_dir(ctx->sh->subsindets(sh, DomConstrain
            ,x->remove(c->c in ctx or (is(c) assuming ctx), x)));

local constraints_about_vars := module()
    export ModuleApply := proc(vs0 :: DomBound, sh :: DomShape, $)
        local vs := vs0, ctx;
        vs  := {op(Domain:-Bound:-varsOf(vs))};
        ctx := Domain:-Bound:-toConstraints(vs0, 'bound_types');
        subsindets(sh, DomConstrain
                  ,x->do_simpl_constraints(vs, ctx, x));
    end proc;

    local do_simpl_constraints := proc(vars, ctx_vs, x, $)
        local ctx1, ctx, ss, td, rest, d, in_vs;
        ss, ctx := selectremove(q->depends(q,vars), x);
        in_vs := q-> not(lhs(q) in vars) and not(rhs(q) in vars);
        td, rest := selectremove(type, ss, And(relation,satisfies(in_vs)));
        ctx1 := { op(ctx), op(ctx_vs), op(rest) };
        d := map(x->try_make_about(vars,ctx1,x), td);
        DConstrain(op(d), op(ctx), op(rest));
    end proc;

    local try_make_about := proc(vars, ctx1, q0, $)
        local vars_q, q_s, q := q0;
        vars_q := indets(q, name) intersect vars;
        if nops(vars_q) = 1 then
            vars_q := op(1,vars_q);
            q := KB:-try_improve_exp(q, vars_q, ctx1);
            q_s := solve({q},[vars_q], 'useassumptions'=true) assuming (op(ctx1));
            if q_s::list and nops(q_s)=1 then
                op(op(1,q_s));
            else
                q
            end if;
        else
            q
        end if;
    end proc;
end module;

# Pushes constraints down, or pulls them up, when there are such constraints.
local do_ctx_dir := dir -> proc(vs :: DomBound, sh :: DomShape, $)
    local ctx := `if`(nops(vs)=2,op(2,vs),{});
    ctx := remove(x->x::`::`,ctx);
    if ctx <> {} then
        dir(ctx)(sh);
    else
        sh;
    end if;
end proc;

local push_ctx_down :=
  do_ctx_dir(ctx->sh->subsindets(sh, DomConstrain, x->if nops(x)<>0 then DConstrain(op(x), op(ctx)) else DConstrain() end if));

local pull_ctx_out :=
  do_ctx_dir(ctx->sh->subsindets(sh, DomConstrain
            ,x->remove(c->c in ctx or (is(c) assuming ctx), x)));


Function which computes a suitable default wrt arg given a Hakaru type

  #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(op([1,2,i,1],t),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`;
  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,

    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
   ModuleLoad();
  end module; #disint
  ###################### end of Carl's code ######################


Try to avoid using solve; but sometimes LinearUnivariate won't work (but another solver other than solve should probably be used then too)

local constraints_about_vars := module()
    export ModuleApply := proc(vs0 :: DomBound, sh :: DomShape, $)
        local vs := vs0, ctx;
        vs  := {op(Domain:-Bound:-varsOf(vs))};
        ctx := Domain:-Bound:-toConstraints(vs0, 'bound_types');
        subsindets(sh, DomConstrain
                  ,x->do_simpl_constraints(vs0, vs, ctx, x));
    end proc;

    local do_simpl_constraints := proc(vs0, vars, ctx_vs, x, $)
        local ctx1, ctx, ss, td, rest, d, in_vs;
        ss, ctx := selectremove(q->depends(q,indets(vars,And(name,Not(constant)) )), x);
        in_vs := q-> not(lhs(q) in vars) and not(rhs(q) in vars);
        td, rest := selectremove(type, ss, And(relation,satisfies(in_vs)));
        ctx1 := { op(ctx), op(ctx_vs), op(rest) };
        d := map(x->try_make_about(vs0, vars,ctx1,x), td);
        DConstrain(op(d), op(ctx), op(rest));
    end proc;

    local try_make_about := proc(dbnd, vars, ctx1, q0, $)
        local vars_q, q_s, q := q0;
        vars_q := indets(q, name) intersect vars;
        if nops(vars_q)=0 then return q end if;

        vars_q := op(1,vars_q);
        q := KB:-try_improve_exp(q, vars_q, ctx1);

        try
          q_s := LinearUnivariate(q, vars_q) assuming (op(ctx1));
          if q_s :: set(relation) and nops(q_s)=1 then
            op(1,q_s)
          else
            q
          end if;
        catch "when calling '%2'. Received: 'inequality must be linear in %1'":
          q_s := 'solve({q},[op(vars_q)], 'useassumptions'=true) assuming (op(ctx1))';
          q_s := eval(q_s);
          if q_s::list then
            if nops(q_s)=0 then return q end if;
            q_s := map(s->remove(c->c in ctx1 or `and`(c::relation,lhs(c)::name,lhs(c)=rhs(c)), s), q_s);
            q_s := remove(x->x=[],q_s);
            if nops(q_s)=0 then return q end if;
            op(op(1,q_s)); # pick the first solution arbitrarily!
          else
            q
          end if;
        end try;
    end proc;
end module;

# Pushes constraints down, or pulls them up, when there are such constraints.
local do_ctx_dir := dir -> proc(vs :: DomBound, sh :: DomShape, $)
    local ctx := `if`(nops(vs)=2,op(2,vs),{});
    ctx := remove(x->x::`::`,ctx);
    if ctx <> {} then
        dir(ctx)(sh);
    else
        sh;
    end if;
end proc;

local push_ctx_down :=
  do_ctx_dir(ctx->sh->subsindets(sh, DomConstrain, x->if nops(x)<>0 then DConstrain(op(x), op(ctx)) else DConstrain() end if));

local pull_ctx_out :=
  do_ctx_dir(ctx->sh->subsindets(sh, DomConstrain
            ,x->remove(c->c in ctx or (is(c) assuming ctx), x)));

local constraints_about_vars := module()
    export ModuleApply := proc(vs0 :: DomBound, sh :: DomShape, $)
        local vs := vs0, ctx;
        vs  := {op(Domain:-Bound:-varsOf(vs))};
        ctx := Domain:-Bound:-toConstraints(vs0, 'bound_types');
        subsindets(sh, DomConstrain
                  ,x->do_simpl_constraints(vs0, vs, ctx, x));
    end proc;

    local do_simpl_constraints := proc(vs0, vars, ctx_vs, x, $)
        local ctx1, ctx, ss, td, rest, d, in_vs;
        ss, ctx := selectremove(q->depends(q,indets(vars,And(name,Not(constant)) )), x);
        in_vs := q-> not(lhs(q) in vars) and not(rhs(q) in vars);
        td, rest := selectremove(type, ss, And(relation,satisfies(in_vs)));
        ctx1 := { op(ctx), op(ctx_vs), op(rest) };
        d := map(x->try_make_about(vs0, vars,ctx1,x), td);
        DConstrain(op(d), op(ctx), op(rest));
    end proc;

    local try_make_about := proc(dbnd, vars, ctx1, q0, $)
        local vars_q, q_s, q := q0;
        vars_q := indets(q, name) intersect vars;
        if nops(vars_q)=0 then return q end if;

        q := KB:-try_improve_exp(q, op(1,vars_q), ctx1);
        q_s := 'solve({q},[op(vars_q)], 'useassumptions'=true) assuming (op(ctx1))';
        q_s := eval(q_s);
        if q_s::list then
          if nops(q_s)=0 then return q end if;
          q_s := map(s->remove(c->c in ctx1 or `and`(c::relation,lhs(c)::name,lhs(c)=rhs(c)), s), q_s);
          q_s := remove(x->x=[],q_s);
          if nops(q_s)=0 then return q end if;
          op(op(1,q_s)); # pick the first solution arbitrarily!
        else
          q
        end if;
    end proc;
end module;

# Pushes constraints down, or pulls them up, when there are such constraints.
local do_ctx_dir := dir -> proc(vs :: DomBound, sh :: DomShape, $)
    local ctx := `if`(nops(vs)=2,op(2,vs),{});
    ctx := remove(x->x::`::`,ctx);
    if ctx <> {} then
        dir(ctx)(sh);
    else
        sh;
    end if;
end proc;

local push_ctx_down :=
  do_ctx_dir(ctx->sh->subsindets(sh, DomConstrain, x->if nops(x)<>0 then DConstrain(op(x), op(ctx)) else DConstrain() end if));

local pull_ctx_out :=
  do_ctx_dir(ctx->sh->subsindets(sh, DomConstrain
            ,x->remove(c->c in ctx or (is(c) assuming ctx), x)));


CRLF -> CR

CRLF -> CR

constraints_about_vars := module()
  export SimplName  := "Make constraints abouts vars";
  export SimplOrder := 6;

    export ModuleApply := proc(vs0 :: DomBound, sh :: DomShape, $)
        local vs := vs0, ctx;
        if _Env_HakaruSolve=false then
           return sh end if;
        vs  := {op(Domain:-Bound:-varsOf(vs))};
        ctx := Domain:-Bound:-toConstraints(vs0, 'bound_types');
        subsindets(sh, DomConstrain
                  ,x->do_simpl_constraints(vs0, vs, ctx, x));
    end proc;

    local do_simpl_constraints := proc(vs0, vars, ctx_vs, x, $)
        local ctx1, ctx, ss, td, rest, d, in_vs;
        ss, ctx := selectremove(q->depends(q,indets(vars,And(name,Not(constant)) )), x);
        in_vs := q-> not(lhs(q) in vars) and not(rhs(q) in vars);
        td, rest := selectremove(type, ss, And(relation,satisfies(x->in_vs(x) and has(x,{ln,exp}))));
        ctx1 := { op(ctx), op(ctx_vs), op(rest) };
        d := map(x->try_make_about(vs0, vars,ctx1,x), td);
        DConstrain(op(d), op(ctx), op(rest));
    end proc;

    local try_make_about := proc(dbnd, vars, ctx1, q0, $)
        local vars_q, q_s, q := q0;
        vars_q := indets(q, name) intersect vars;
        if nops(vars_q)=0 then return q end if;

        vars_q := op(1,vars_q);
        q := KB:-try_improve_exp(q, vars_q, ctx1);
        q_s := 'solve({q},[op(vars_q)], 'useassumptions'=true) assuming (op(ctx1))';
        q_s := eval(q_s);
        if q_s::list then
          if nops(q_s)=0 then return q end if;
          q_s := map(s->remove(c->c in ctx1 or `and`(c::relation,lhs(c)::name,lhs(c)=rhs(c)), s), q_s);
          q_s := remove(x->x=[],q_s);
          if nops(q_s)=0 then return q end if;
          userinfo(3, 'constraints_about_vars'
                  ,printf("Found a solution to %a (with solve):\n\t%a\n", q0, op(1,q_s)));
          op(op(1,q_s)); # pick the first solution arbitrarily!
        else
          q
        end if;
    end proc;
end module;

# Pushes constraints down, or pulls them up, when there are such constraints.
local do_ctx_dir := dir -> proc(vs :: DomBound, sh :: DomShape, $)
    local ctx := `if`(nops(vs)=2,op(2,vs),{});
    ctx := remove(x->x::`::`,ctx);
    if ctx <> {} then
        dir(ctx)(sh);
    else
        sh;
    end if;
end proc;

push_ctx_down := module()
  export ModuleApply := do_ctx_dir(ctx->sh->subsindets(sh, DomConstrain, x->if nops(x)<>0 then DConstrain(op(x), op(ctx)) else DConstrain() end if));
  export SimplName  := "Push context down";
  export SimplOrder := 1;
end module;

pull_ctx_out := module()
  export ModuleApply :=
    do_ctx_dir(ctx->sh->subsindets(sh, DomConstrain
              ,x->remove(c->c in ctx or (is(c) assuming op(ctx)), x)));
  export SimplName  := "Pull context out";
  export SimplOrder := 20;
end module;

# Turns constraints(relations) into bounds
classify_DConstrains := module()
  export SimplName  := "Classify constraints";
  export SimplOrder := 8;

  export ModuleApply := proc(dbnds::DomBound,dsh::DomShape,$)
    subsindets(dsh, DomConstrain, x->classify_Rels([op(x)], dbnds));
  end proc;

  # Split relations into those we can incorporate
  # into bounds and others; this process also includes
  # some intermediate computations about the new bound:
  #  [ DInto(var), orig, upd_bound, bound_kind, numVars ]
  #    var         :=   variable to be modified
  #    orig        :=   the original relation
  #    upd_bound   :=   how to modify (a function)
  #    bound_kind  :=   {LO/HI}
  #    numVars     :=   how many variables are mentioned by the bound
  local classify_Rel := proc(r0,dbnd,$)
    local ret, vars, mk_k, bnd_k, i, var_k, q, r := r0;
    ret := [ DConstrain, r0 ];
    vars := {Domain:-Bound:-varsOf(dbnd)[]};
    if r :: {`<=`,`<`} then
      if rhs(r) in vars then
        r := op(0,r)(rhs(r),lhs(r));
        mk_k := flip_rel[op(0,r)]; bnd_k := B_LO;
      elif lhs(r) in vars then
        mk_k := op(0,r);           bnd_k := B_HI;
      else
        return ret;
      end if;

      i := Domain:-Bound:-varIx_mb(dbnd, lhs(r));
      if i >= 0 then
        var_k := op([1,i,3], dbnd);
        q := Domain:-ExtBound[var_k]:-RecogBound(mk_k,rhs(r));
        if q <> NULL then
          ret := [ DInto(lhs(r)), r0, q, bnd_k, countVs(vars minus {lhs(r)},r0) ];
        end if;
      end if;
    end if;
    ret;
  end proc;

  # Classifies a set of relations as potential bounds. The process
  # is as follows:
  #  - Classify each relation individually (see classify_Rel)
  #  - "Categorize" by the classification
  #  - Split relations which will be DConstrains, and those where we found
  #      more than one LO/HI bound or more than 2 bounds total.
  #  - Sort the relations which are to become bounds by the number of variables
  #      mentioned in the bound
  #  - Rebuild the continuations producing each new bound (see make_DInto)
  #  - Rebuild the leftover relations as a DConstrain.
  #  - Squash together ("foldr (.) id fs z") the continuations and leftover relations.
  local classify_Rels := proc(rs0,dbnd,$)
    local cs1, cs2, cs, rs := rs0;
    rs := map(r->classify_Rel(r,dbnd), rs);
    rs := [ListTools[Categorize]( ((a,b) -> op(1,a)=op(1,b) ), rs )];
    cs1, rs := selectremove(x->op([1,1],x)=DConstrain, rs);
    rs, cs2 := selectremove(x->nops(x)=1 or (nops(x)=2 and op([1,4],x)<>op([2,4],x)), rs);
    rs := sort(rs, key=solOrder);
    rs := map(r->make_DInto(r,dbnd),rs);
    cs := DConstrain(map(c->map(q->op(2,q),c)[], [op(cs1),op(cs2)])[]);
    foldr((f,g)->f@g,x->x,op(rs))(cs);
  end proc;

  # Rebuild a classified (by classify_Rel) relation; this
  # takes a list of such classifications, all of whose variable should
  # be identical, and for which the different bound kinds are all distinct.
  # None of this is checked!
  # (since there are 2 bound kinds, this list is at most length 2)
  local make_DInto := proc(r::list([specfunc(DInto),anything,anything,identical(B_LO,B_HI),nonnegint]), dbnd, $)
    local var_nm, var_ty;
    var_nm := op([1,1,1], r);
    var_ty := Domain:-Bound:-get(dbnd, var_nm)[1];
    var_ty := foldr( ((q,x)->op(3,q)(x)), var_ty, op(r) );
    (ctx -> DInto(var_nm, var_ty, ctx))
  end proc;
  local flip_rel := table([`=`=`=`,`<>`=`<>`,`<=`=`>=`,`<`=`>`,`>=`=`<=`,`>`=`<`]);
  local countVs := ((vs,c)-> nops(indets(c, DomBoundVar) intersect {op(vs)} ));
  local solOrder := (x->`+`(map(z->op(5,z),x)[]));
end module;

# todo; this should actually solve for a variable, then substitute
# that variable in. In most cases, it would probably be enough to
# leave that as it is; it would simplify later.
singular_pts := module()
  export SimplName  := "Single_pts";
  export SimplOrder := 14;

  local can_remove := ((x,vs_ty) ->
     nops(x) = 1 and
     op(1,x) :: `=` and
     ormap(s->s(op(1,x))::vs_ty,[lhs,rhs]) and
     not(is(op(1,x))) );

  export ModuleApply := proc(bnds_ :: DomBound, sh_ :: DomShape, $)
    local bnds := bnds_, sh := sh_, vs, todo, sh1, vs_ty;
    vs := applyop(bl -> select(b->op(3,b)=`Int`, bl), 1, bnds);
    vs := Domain:-Bound:-varsOf(vs);
    vs_ty := 'satisfies(x->x in {op(vs)})';
    todo := indets(sh, specfunc(`DConstrain`));
    todo := select(x->can_remove(x,vs_ty), todo);
    subs([seq(t=DSum(),t=todo)], sh);
  end proc;
end module;

constraints_about_vars := module()
  export SimplName  := "Make constraints abouts vars";
  export SimplOrder := 6;

    export ModuleApply := proc(vs0 :: DomBound, sh :: DomShape, $)
        local vs := vs0, ctx;
        if _Env_HakaruSolve=false then
           return sh end if;
        vs  := {op(Domain:-Bound:-varsOf(vs))};
        ctx := Domain:-Bound:-toConstraints(vs0, 'bound_types');
        subsindets(sh, DomConstrain
                  ,x->do_simpl_constraints(vs0, vs, ctx, x));
    end proc;

    local do_simpl_constraints := proc(vs0, vars, ctx_vs, x, $)
        local ctx1, ctx, ss, td, rest, d, in_vs;
        ss, ctx := selectremove(q->depends(q,indets(vars,And(name,Not(constant)) )), x);
        in_vs := q-> not(lhs(q) in vars) and not(rhs(q) in vars);
        td, rest := selectremove(type, ss, And(relation,satisfies(x->in_vs(x) and has(x,{ln,exp}))));
        ctx1 := { op(ctx), op(ctx_vs), op(rest) };
        d := map(x->try_make_about(vs0, vars,ctx1,x), td);
        DConstrain(op(d), op(ctx), op(rest));
    end proc;

    local try_make_about := proc(dbnd, vars, ctx1, q0, $)
        local vars_q, q_s, q := q0;
        vars_q := indets(q, name) intersect vars;
        if nops(vars_q)=0 then return q end if;

        vars_q := op(1,vars_q);
        q := KB:-try_improve_exp(q, vars_q, ctx1);
        q_s := 'solve({q},[op(vars_q)], 'useassumptions'=true) assuming (op(ctx1))';
        q_s := eval(q_s);
        if q_s::list then
          if nops(q_s)=0 then return q end if;
          q_s := map(s->remove(c->c in ctx1 or `and`(c::relation,lhs(c)::name,lhs(c)=rhs(c)), s), q_s);
          q_s := remove(x->x=[],q_s);
          if nops(q_s)=0 then return q end if;
          userinfo(3, 'constraints_about_vars'
                  ,printf("Found a solution to %a (with solve):\n\t%a\n", q0, op(1,q_s)));
          op(op(1,q_s)); # pick the first solution arbitrarily!
        else
          q
        end if;
    end proc;
end module;

# Pushes constraints down, or pulls them up, when there are such constraints.
local do_ctx_dir := dir -> proc(vs :: DomBound, sh :: DomShape, $)
    local ctx := `if`(nops(vs)=2,op(2,vs),{});
    ctx := remove(x->x::`::`,ctx);
    if ctx <> {} then
        dir(ctx)(sh);
    else
        sh;
    end if;
end proc;

push_ctx_down := module()
  export ModuleApply := do_ctx_dir(ctx->sh->subsindets(sh, DomConstrain, x->if nops(x)<>0 then DConstrain(op(x), op(ctx)) else DConstrain() end if));
  export SimplName  := "Push context down";
  export SimplOrder := 1;
end module;

pull_ctx_out := module()
  export ModuleApply :=
    do_ctx_dir(ctx->sh->subsindets(sh, DomConstrain
              ,x->remove(c->c in ctx or (is(c) assuming op(ctx)), x)));
  export SimplName  := "Pull context out";
  export SimplOrder := 20;
end module;

# Turns constraints(relations) into bounds
classify_DConstrains := module()

  export SimplName  := "Classify constraints";
  export SimplOrder := 8;

  export ModuleApply := proc(dbnds::DomBound,dsh::DomShape,$)

    subsindets(dsh, DomConstrain, x->classify_Rels([op(x)], dbnds));

  end proc;

  # Split relations into those we can incorporate
  # into bounds and others; this process also includes
  # some intermediate computations about the new bound:
  #  [ DInto(var), orig, upd_bound, bound_kind, numVars ]
  #    var         :=   variable to be modified
  #    orig        :=   the original relation
  #    upd_bound   :=   how to modify (a function)
  #    bound_kind  :=   {LO/HI}
  #    numVars     :=   how many variables are mentioned by the bound
  local classify_Rel := proc(r0,dbnd,$)

    local ret, vars, mk_k, bnd_k, i, var_k, q, r := r0;
    ret := [ DConstrain, r0 ]
;
    vars := {Domain:-Bound:-varsOf(dbnd)[]};

    if r :: {`<=`,`<`} then

      if rhs(r) in vars then

        r := op(0,r)(rhs(r),lhs(r));

        mk_k := flip_rel[op(0,r)]; bnd_k := B_LO;

      elif lhs(r) in vars then

        mk_k := op(0,r);           bnd_k := B_HI;

      else

        return ret;
      end if;

      i := Domain:-Bound:-varIx_mb(dbnd, lhs(r));

      if i >= 0 then

        var_k := op([1,i,3], dbnd);

        q := Domain:-ExtBound[var_k]:-RecogBound(mk_k,rhs(r));

        if q <> NULL then

          ret := [ DInto(lhs(r)), r0, q, bnd_k, countVs(vars minus {lhs(r)},r0) ];

        end if;

      end if;

    end if;

    ret;
  end proc;

  # Classifies a set of relations as potential bounds. The process
  # is as follows:
  #  - Classify each relation individually (see classify_Rel)
  #  - "Categorize" by the classification
  #  - Split relations which will be DConstrains, and those where we found
  #      more than one LO/HI bound or more than 2 bounds total.
  #  - Sort the relations which are to become bounds by the number of variables
  #      mentioned in the bound
  #  - Rebuild the continuations producing each new bound (see make_DInto)
  #  - Rebuild the leftover relations as a DConstrain.
  #  - Squash together ("foldr (.) id fs z") the continuations and leftover relations.
  local classify_Rels := proc(rs0,dbnd,$)

    local cs1, cs2, cs, rs := rs0;

    rs := map(r->classify_Rel(r,dbnd), rs);

    rs := [ListTools[Categorize]( ((a,b) -> op(1,a)=op(1,b) ), rs )];

    cs1, rs := selectremove(x->op([1,1],x)=DConstrain, rs);

    rs, cs2 := selectremove(x->nops(x)=1 or (nops(x)=2 and op([1,4],x)<>op([2,4],x)), rs);

    rs := sort(rs, key=solOrder);

    rs := map(r->make_DInto(r,dbnd),rs);

    cs := DConstrain(map(c->map(q->op(2,q),c)[], [op(cs1),op(cs2)])[]);
    foldr((f,g)->f@g,x->x,op(rs))(cs);

  end proc;

  # Rebuild a classified (by classify_Rel) relation; this
  # takes a list of such classifications, all of whose variable should
  # be identical, and for which the different bound kinds are all distinct.
  # None of this is checked!
  # (since there are 2 bound kinds, this list is at most length 2)
  local make_DInto := proc(r::list([specfunc(DInto),anything,anything,identical(B_LO,B_HI),nonnegint]), dbnd, $)

    local var_nm, var_ty;
    var_nm := op([1,1,1], r);

    var_ty := Domain:-Bound:-get(dbnd, var_nm)[1];

    var_ty := foldr( ((q,x)->op(3,q)(x)), var_ty, op(r) );

    (ctx -> DInto(var_nm, var_ty, ctx))

  end proc;

  local flip_rel := table([`=`=`=`,`<>`=`<>`,`<=`=`>=`,`<`=`>`,`>=`=`<=`,`>`=`<`]);

  local countVs := ((vs,c)-> nops(indets(c, DomBoundVar) intersect {op(vs)} ));

  local solOrder := (x->`+`(map(z->op(5,z),x)[]));
end module;

# todo; this should actually solve for a variable, then substitute
# that variable in. In most cases, it would probably be enough to
# leave that as it is; it would simplify later.
singular_pts := module()
  export SimplName  := "Single_pts";
  export SimplOrder := 14;

  local can_remove := ((x,vs_ty) ->
     nops(x) = 1 and
     op(1,x) :: `=` and
     ormap(s->s(op(1,x))::vs_ty,[lhs,rhs]) and
     not(is(op(1,x))) );

  export ModuleApply := proc(bnds_ :: DomBound, sh_ :: DomShape, $)
    local bnds := bnds_, sh := sh_, vs, todo, sh1, vs_ty;
    vs := applyop(bl -> select(b->op(3,b)=`Int`, bl), 1, bnds);
    vs := Domain:-Bound:-varsOf(vs);
    vs_ty := 'satisfies(x->x in {op(vs)})';
    todo := indets(sh, specfunc(`DConstrain`));
    todo := select(x->can_remove(x,vs_ty), todo);
    subs([seq(t=DSum(),t=todo)], sh);
  end proc;
end module;


Some comments on banish; Assertion that kb is valid

  banish := proc(g, h :: name, kb :: t_kb, levels :: extended_numeric,
                 x :: name, make, $)
    # banish(g, h, kb, levels, x, make), where the integrand h and the
    # integration variable x take scope over the integral g patently linear
    # in h, should be equivalent to make(kb, g), where the integration operator
    # make binds x in g, except
    #   - integration over x is performed innermost rather than outermost;
    #   - if levels < infinity then levels controls how deeply to banish g;
    #   - make is invoked with the KB in the first argument extended.
    local subintegral, w, y, kb1, lo, hi, m, loops, xx, less;
    if g = 0 then
      0
    elif levels <= 0 then
      make(kb, g)
    elif not depends(g, x) then
      make(kb, 1) * g
    elif g :: `+` then
      map(banish, _passed)
    elif g :: `*` then
      (subintegral, w) := selectremove(depends, g, h);
      if subintegral :: `*` then error "Nonlinear integral %1", g end if;
      banish(subintegral, h, kb, levels, x, banish_weight(make, w));
    elif g :: 'And'('specfunc({Int,int,Sum,sum})',
                    'anyfunc'('anything','name'='range'('freeof'(h)))) then
      lo, hi      := op(op([2,2],g));
      m           := make;
      if depends(lo, x) then
        m  := banish_guard(eval(m), lo<y);
        lo := -infinity;
      end if;
      if depends(hi, x) then
        m  := banish_guard(eval(m), y<hi);
        hi := infinity;
      end if;
      y, kb1 := `if`(op(0,g) in '{Int,int}',
        genLebesgue(op([2,1],g), lo, hi, kb, make),
        genType(op([2,1],g), HInt(closed_bounds(lo..hi)), kb, make));
      subintegral := subs(op([2,1],g)=y, op(1,g));
      op(0,g)(banish(subintegral, h, kb1, levels-1, x, m), y=lo..hi)

    # if `g' is an 'n-' integral or sum of the form
    # {Ints/Sums}(f, nm, x..y, [nm0=x0..y0, .., nmk=xk..yk])
    #   where x..y is free of `h'
    elif g :: 'And'('specfunc({Ints,ints,Sums,sums})',
                    'anyfunc'('anything', 'name', 'range'('freeof'(h)),
                              'list(name=range)')) then
      lo, hi      := op(op(3,g));       # 'primary' (?) integration bounds
      loops       := op(4,g);           # rest of the integration bounds
      xx          := map(lhs, loops);   # [nm0 .. nmk]
      m           := make;
      less        := `if`(op(0,g) in '{Ints,ints}', `<`, `<=`);

      # banish the primary bounds if they depend on the primary integration
      # variable
      if depends(lo, x) then
        m  := banish_guard(m, forall(xx, less(lo, mk_idx(y,loops))));
        lo := -infinity;
      end if;
      if depends(hi, x) then
        m  := banish_guard(m, forall(xx, less(mk_idx(y,loops), hi)));
        hi := infinity;
      end if;

      # augment the KB with a new binding (y) corresponding to the primary
      # variable of integration.
      y, kb1 := genType(op(2,g),
                        mk_HArray(`if`(op(0,g) in '{Ints,ints}',
                                       HReal(open_bounds(lo..hi)),
                                       HInt(closed_bounds(lo..hi))),
                                  op(4,g)),
                        kb);

      # if there are any more integration bounds, then add the information
      # about the last (?) integration bound to the KB.
      if nops(op(4,g)) > 0 then
        kb1 := assert(size(y)=op([4,-1,2,2],g)-op([4,-1,2,1],g)+1, kb1);
          ASSERT(type(kb1,t_kb), "banish/{Ints,Sums}: invalid integration bounds found "
                 "in input.");
      end if;

      subintegral := subs(op(2,g)=y, op(1,g));
      op(0,g)(banish(subintegral, h, kb1, levels-1, x, m), y, lo..hi, op(4,g));
    elif g :: t_pw then
      foldr_piecewise(
        proc(cond, th, el, $) proc(make, kb, $)
          if depends(cond, x) then
            banish(th, h, kb, levels-1, x, banish_guard(make, cond))
              + el(banish_guard(make, Not(cond)), kb)
          else
            piecewise_if(cond,
              banish(th, h, assert(cond, kb), levels-1, x, make),
              el(make, assert(Not(cond), kb)))
          end if
        end proc end proc,
        proc(make, kb, $) 0 end proc,
        g)(make, kb)
    elif g :: t_case then
      map_piecewiselike(banish, _passed)
    elif g :: 'integrate(freeof(x), Integrand(name, anything), list)' then
      y           := gensym(op([2,1],g));
      subintegral := subs(op([2,1],g)=y, op([2,2],g));
      subsop(2=Integrand(y, banish(subintegral, h, kb, levels-1, x, make)), g)
    else
      make(kb, g)
    end if
  end proc;

  banish_guard := proc(make, cond, $)
    if cond :: 'And(specfunc(Not), anyfunc(anything))' then
      # Work around simplify/piecewise bug:
      #   > simplify(piecewise(Not(i=0), 1, 0))
      #   a
      # (due to PiecewiseTools:-ImportImplementation:-UseSolve calling
      # solve(Not(i=0), {i}, 'AllSolutions', 'SolveOverReals'))
      proc(kb,g,$) make(kb, piecewise(op(1,cond),0,g)) end proc
    else
      proc(kb,g,$) make(kb, piecewise(cond,g,0)) end proc
    end if
  end proc;

  banish_weight := proc(make, w, $)
    proc(kb,g,$) make(kb, w*g) end proc
  end proc;

  banish := proc(g, h :: name, kb :: t_kb, levels :: extended_numeric,
                 x :: name, make, $)
    # banish(g, h, kb, levels, x, make), where the integrand h and the
    # integration variable x take scope over the integral g patently linear
    # in h, should be equivalent to make(kb, g), where the integration operator
    # make binds x in g, except
    #   - integration over x is performed innermost rather than outermost;
    #   - if levels < infinity then levels controls how deeply to banish g;
    #   - make is invoked with the KB in the first argument extended.
    local subintegral, w, y, kb1, lo, hi, m, loops, xx, less;
    if g = 0 then
      0
    elif levels <= 0 then
      make(kb, g)
    elif not depends(g, x) then
      make(kb, 1) * g
    elif g :: `+` then
      map(banish, _passed)
    elif g :: `*` then
      (subintegral, w) := selectremove(depends, g, h);
      if subintegral :: `*` then error "Nonlinear integral %1", g end if;
      banish(subintegral, h, kb, levels, x, banish_weight(make, w));
    elif g :: 'And'('specfunc({Int,int,Sum,sum})',
                    'anyfunc'('anything','name'='range'('freeof'(h)))) then
      lo, hi      := op(op([2,2],g));
      m           := make;
      if depends(lo, x) then
        m  := banish_guard(eval(m), lo<y);
        lo := -infinity;
      end if;
      if depends(hi, x) then
        m  := banish_guard(eval(m), y<hi);
        hi := infinity;
      end if;
      y, kb1 := `if`(op(0,g) in '{Int,int}',
        genLebesgue(op([2,1],g), lo, hi, kb, make),
        genType(op([2,1],g), HInt(closed_bounds(lo..hi)), kb, make));
      subintegral := subs(op([2,1],g)=y, op(1,g));
      op(0,g)(banish(subintegral, h, kb1, levels-1, x, m), y=lo..hi)
    elif g :: 'And'('specfunc({Ints,ints,Sums,sums})',
                    'anyfunc'('anything', 'name', 'range'('freeof'(h)),
                              'list(name=range)')) then
      lo, hi      := op(op(3,g));
      loops       := op(4,g);
      xx          := map(lhs, loops);
      m           := make;
      less        := `if`(op(0,g) in '{Ints,ints}', `<`, `<=`);
      if depends(lo, x) then
        m  := banish_guard(m, forall(xx, less(lo, mk_idx(y,loops))));
        lo := -infinity;
      end if;
      if depends(hi, x) then
        m  := banish_guard(m, forall(xx, less(mk_idx(y,loops), hi)));
        hi := infinity;
      end if;
      y, kb1 := genType(op(2,g),
                        mk_HArray(`if`(op(0,g) in '{Ints,ints}',
                                       HReal(open_bounds(lo..hi)),
                                       HInt(closed_bounds(lo..hi))),
                                  op(4,g)),
                        kb);
      if nops(op(4,g)) > 0 then
        kb1 := assert(size(y)=op([4,-1,2,2],g)-op([4,-1,2,1],g)+1, kb1);
      end if;
      subintegral := subs(op(2,g)=y, op(1,g));
      op(0,g)(banish(subintegral, h, kb1, levels-1, x, m), y, lo..hi, op(4,g));
    elif g :: t_pw then
      foldr_piecewise(
        proc(cond, th, el, $) proc(make, kb, $)
          if depends(cond, x) then
            banish(th, h, kb, levels-1, x, banish_guard(make, cond))
              + el(banish_guard(make, Not(cond)), kb)
          else
            piecewise_if(cond,
              banish(th, h, assert(cond, kb), levels-1, x, make),
              el(make, assert(Not(cond), kb)))
          end if
        end proc end proc,
        proc(make, kb, $) 0 end proc,
        g)(make, kb)
    elif g :: t_case then
      map_piecewiselike(banish, _passed)
    elif g :: 'integrate(freeof(x), Integrand(name, anything), list)' then
      y           := gensym(op([2,1],g));
      subintegral := subs(op([2,1],g)=y, op([2,2],g));
      subsop(2=Integrand(y, banish(subintegral, h, kb, levels-1, x, make)), g)
    else
      make(kb, g)
    end if
  end proc;

  banish_guard := proc(make, cond, $)
    if cond :: 'And(specfunc(Not), anyfunc(anything))' then
      # Work around simplify/piecewise bug:
      #   > simplify(piecewise(Not(i=0), 1, 0))
      #   a
      # (due to PiecewiseTools:-ImportImplementation:-UseSolve calling
      # solve(Not(i=0), {i}, 'AllSolutions', 'SolveOverReals'))
      proc(kb,g,$) make(kb, piecewise(op(1,cond),0,g)) end proc
    else
      proc(kb,g,$) make(kb, piecewise(cond,g,0)) end proc
    end if
  end proc;

  banish_weight := proc(make, w, $)
    proc(kb,g,$) make(kb, w*g) end proc
  end proc;