program change;  /* sample2a.mpl */ { compute change program. What is change? }
             { no 5, 50, 500, & 5000 yen used }
  var n, count : integer;
begin
  writeln('please input change');  readln(n);    count := 0;
while n>0 do begin
    while n>=10 do begin
        while n>=  100 do begin
           while n>=1000 do begin
             while n  >=10000 do begin
               count := count +1; n := n-10000;
             end;
             if count >0 then writeln('10000 yen : ',  count);
             count := 0;
             if n < 1000 then break;
             count := count +1; n := n-1000;
           end;
             if count >0 then writeln(' 1000 yen : ',  count);
             count := 0;
             if n < 100 then break;
              count := count +1; n := n-100;
         end;
         if count >0 then     writeln('  100 yen : ',  count);
             count := 0;
             if n < 10 then break;
              count := count +1; n := n-10;
      end;
         if count >0 then     writeln('   10 yen : ',  count);
             count := 0;
             if n < 1 then break;
              count := count +1; n := n-1;
 end;
 if count >            0 then writeln('    1 yen : ',  count);
/*  if n !=0 then break;  */
end.


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

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

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

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

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

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

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

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

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

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

  Print := proc(kind::identical(Ints,Sums,ints,sums),e,v::name,r0::range,rs::list(name=range),$)
    local k;
    k := StringTools[Capitalize](StringTools[Chop](convert(kind,string)));
    k := parse(cat("`print/",eval(k),"`"));
    eval(k)(e,v[op(rs)]=r0);
  end proc;

  intssums := proc(makes::name, make::name,
                   e::anything, x::name, rr::range, ll::list(name=range),
                   kb::t_kb:=empty, $)
    local t, r, l, kb2, w0, pp, i;
    t := `if`(make=int, HReal(open_bounds(rr)), HInt(closed_bounds(rr)));
    r, l, kb2 := genLoop(rr, ll, kb, 'Integrand'(x,e));
    w0, pp := unproducts(e, x, l, kb2);
    if depends(w0, x) then
      'makes(e, x, rr, ll)'
    else
      pp := 'make'(pp, x=r);
      for i in l do pp := 'product'(pp, i) end do;
      NewSLO:-simplify_factor_assuming(w0 * pp, kb);
    end if
  end proc;

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

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

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

  # Find [w1,pp] so that
  #   wrap(heap,w,mode,kb1,kb0)
  #   = w1*product(eval(pp,var=idx(var,lhs(loop))),loop)
  # making w1 depend on var as little as possible.
  # The flag "mode" should be `+` if "heap" contains an entry of the form
  # t_exp, or `*` otherwise.
  unproduct := proc(w, var::name, loop::(name=range),
                    heap::list, mode::identical(`*`,`+`),
                    kb1::t_kb, kb0::t_kb, $)
    local ind, res, dummy, kb, kbThen, i, w1, pp, s, r, x;
    if not depends(w, var) then
      return [wrap(heap, w, mode, kb1, kb0), 1]
    end if;
    # The `..' (indices) of all occurences of `idx(var,..)'
    ind := map2(op, 2, indets(w, idx(identical(var), anything)));
    if nops(ind) = 1 then
      ind := op(ind);
      # Make sure ind contains no bound variables before lifting it!
      # So, check that "extract using indets" and "rename using eval" commute.
      s := indets(ind, 'name');
      s := map(proc(x,$) local y; `if`(depends(ind,x), x=y, NULL) end proc, s);
      if indets(eval(w, s), idx(identical(var), anything))
                = {idx(var, eval(ind, s))} then
        # use kb as a local context, and 'solve' for the innermost bound var
        #   used in ind.
        kb  := assert(lhs(loop)=ind, kb1); # BUG! bijectivity assumed!
        # if the assertion makes the KB false, it isn't needed(?)
        ASSERT(type(kb, t_kb),
          sprintf("assert(%a,%a) produced a false KB!\n", lhs(loop)=ind,kb1)):
        res := subs(idx(var,ind) = idx(var,lhs(loop)), w);
        res := wrap(heap, res, mode, kb, kb0);
        res := subs(idx(var,lhs(loop))=dummy, res);
        if not depends(res, var) then
          return [1, subs(dummy=var, res)]
        end if
      end if
    end if;
    # distribute the unproduct over each part
    if w :: mode then
      res := map(unproduct, `if`(mode=`*`, list_of_mul(w), [op(w)]),
                 var, loop, heap, mode, kb1, kb0);
      return [`*`(op(map2(op,1,res))), `*`(op(map2(op,2,res)))]
    end if;
    # for piecewise, just map right in (using KB for context tracking)
    if w :: 'specfunc(piecewise)' then
      kb := kb1;
      for i from 1 to nops(w) do
        if i :: even then
          kbThen := assert(    op(i-1,w) , kb);
          # accumulate the rest, regardless
          kb     := assert(Not(op(i-1,w)), kb);

          # if kbThen is invalid, deal appropriately
          if not type(kbThen,t_kb) then next end if;

          w1[i], pp[i] := op(unproduct(op(i,w),var,loop,heap,mode,kbThen,kb0));
          # if kb is inconsistent, we're done
          if not type(kb,t_kb) then break end if;
        elif i = nops(w) then
          if not type(kb,t_kb) then next end if;
          w1[i], pp[i] := op(unproduct(op(i,w),var,loop,heap,mode,kb    ,kb0))
        end if
      end do;
      return [`*`(entries(w1,'nolist')), `*`(entries(pp,'nolist'))]
    end if;
    if mode = `*` then
      if w :: (anything^freeof(var)) then
        return unproduct(op(1,w), var, loop,
                         [op(heap), Stmt(`^`, [], [op(2,w)])], `*`, kb1, kb0)
      elif w :: exp(anything) then
        return unproduct(op(1,w), var, loop,
                         [op(heap), Stmt(exp, [], [])], `+`, kb1, kb0)
      elif w :: (freeof(var)^anything) then
        return unproduct(op(2,w), var, loop,
                         [op(heap), Stmt(`^`, [op(1,w)], [])], `+`, kb1, kb0)
      end if
    end if;
    if mode = `+` and w :: `*` then
      s, r := selectremove(depends, w, var);
      if s :: `*` then
        # Nonlinear %1 (time to reread kiselyov-lifted?)
      else
        return unproduct(s, var, loop,
                         [op(heap), Stmt(`*`, [], [r])], `+`, kb1, kb0)
      end if
    end if;
    if w :: And(specfunc(`if`(mode = `*`, {product, Product}, {sum, Sum})),
                anyfunc(anything, name=range(freeof(var)))) then
      x, kb := genType(op([2,1],w), HInt(closed_bounds(op([2,2],w))), kb1,
                       w, var, loop, heap);
      return unproduct(eval(op(1,w), op([2,1],w)=x), var, loop,
                       [op(heap), Binder(op(0,w), kb1)], mode, kb, kb0)
    end if;
    if mode = `*` and w :: '{`+`, specfunc({sum, Sum})}' then
      # Maybe this w is one of those big sums involving products that are
      # always equal to 1, left behind by the density of Categorical
      w1 := graft(split(peel(w)));
      w1 := combine(rebase_upper(w1));
      w1 := combine(rebase_lower(w1));
      return [wrap(heap, w1, mode, kb1, kb0), 1]
    end if;
    return [wrap(heap, w, mode, kb1, kb0), 1]
  end proc;

  enter_piecewise := proc(ee, kb0::t_kb, mode::identical(`*`,`+`), $)
    local e, kb, mo;
    e  := ee;
    kb := kb0;
    mo := mode();
    while e :: 'specfunc(piecewise)' and nops(e) = 3 do
      if op(3,e) = mo then
        kb := assert(op(1,e), kb);
        e := op(2,e);
      elif op(2,e) = mo then
        kb := assert(Not(op(1,e)), kb);
        e := op(3,e);
      else
        break;
      end if;
    end do;
    ASSERT(type(kb,t_kb), "enter_piecewise: KB of piecewise conditions is not valid, so the input piecewise must not be valid.");
    e, kb
  end proc;

  # heap is a list of t_binder and t_stmt
  # one invariant to maintain:
  #  wrap(heap, mode(a,b)) = wrap(heap,a) * wrap(heap,b)

  # Also, a t_binder is a Product/product/Sum/sum.
  # And, a t_stmt is a 1-hole context of a (multiplicative) AST,
  #   used for [a ^ hole, hole ^ b, exp(hole), c * hole].

  wrap := proc(heap::list, e1, mode1::identical(`*`,`+`),
               kb1::t_kb, kb0::t_kb, $)
    local e, kb, mode, i, entry, rest, var, new_rng, make, logmake,
       dom_spec, w, wPow, wExp, arrrgs;
    e    := e1;
    kb   := kb1;
    mode := mode1;
    for i from nops(heap) to 1 by -1 do
      entry := op(i,heap);
      if entry :: t_binder then
        if not (op(1,entry) in `if`(mode=`+`, {sum,Sum},
                                              {product,Product})) then
          print("Warning: heap mode inconsistency", heap, mode1)
        end if;
        e, kb := enter_piecewise(e, kb, mode);
        rest := kb_subtract(kb, op(2,entry));
        new_rng, rest := selectremove(type, rest,
          {[identical(genType), name, specfunc(HInt)],
           [identical(genLet), name, anything]});
        if not (new_rng :: [list]) then
          error "kb_subtract should return exactly one gen*"
        end if;
        new_rng := op(new_rng);
        var     := op(2,new_rng);
        if op(1,new_rng) = genType then
          make    := op(1,entry);
          new_rng := range_of_HInt(op(3,new_rng));
        else # op(1,new_rng) = genLet
          make    := eval;
          new_rng := op(3,new_rng);
        end if;
        dom_spec, rest := selectremove(depends,
          map(proc(a::[identical(assert),anything],$) op(2,a) end proc, rest),
          var);

        # Like e := make(piecewise(And(op(dom_spec)), e, mode()), var=new_rng);
        # but try to simplify by pushing the make and the piecewise into e
        (e, w) := selectremove(depends, convert(e, 'list', `*`), var);
        w := `*`(op(w));
        if mode = `*` then
          (wPow, e) := selectremove(type, e, '`^`'('freeof'(var), 'anything'));
          (wExp, e) := selectremove(type, e, 'exp(anything)');
          wExp := `+`(op(map2(op, 1, wExp)));
          logmake := t -> `if`(make=eval,eval,Sum)
                              (piecewise_And(dom_spec,t,0), var=new_rng);
          w := `*`( `if`(w = 1, 1, w ^ logmake(1))
                  , op(map((f -> op(1,f) ^ logmake(op(2,f))), wPow))
                  , `if`(wExp = 0, 1, exp(logmake(wExp))) );
        end if;
        e := w * make(piecewise_And(dom_spec, `*`(op(e)), mode()), var=new_rng);

        # `rest' originally comes from `entry', and this reinserts it after some
        # processing. The original KB was valid, so this one should also be valid.
        kb := foldr(assert, op(2,entry), op(rest));
        ASSERT(type(kb,t_kb), "Loop/wrap{t_binder}: rebuilding kb produced contradiction");

      elif entry :: t_stmt then
        # We evaluate arrrgs first, in case op(1,stmt) is an operation (such as
        # piecewise) that looks ahead at how many arguments it is passed before
        # they are evaluated.
        arrrgs := op(op(2,entry)), e, op(op(3,entry));
        e      := op(1,entry)(arrrgs);
        if entry :: t_exp then
          if mode <> `+` then
            print("Warning: heap mode inconsistency?", heap, mode1)
          end if;
          mode := `*`;
        end if
      else error "Malformed heap entry %1", entry end if
    end do;
    if mode <> `*` then
      print("Warning: heap mode inconsistency??", heap, mode1)
    end if;
    e, kb := enter_piecewise(e, kb, mode);
    rest := kb_subtract(kb, kb0);
    rest := map(proc(a::[identical(assert),anything],$) op(2,a) end proc, rest);
    piecewise_And(rest,e,mode())
  end proc;

  # Rewrite product(...piecewise(i+42=lo+42,th,el)...,i=lo..hi)
  # to eval(...th...,i=lo)*product(...el...,i=lo+1..hi)
  t_peel := 'And(specfunc({sum,Sum,product,Product}),
                 anyfunc(anything, name=range))';
  peel := proc(e, $)
    subsindets(e, t_peel, do_peel);
  end proc;
  do_peel := proc(e, $)
    local make, body, x, r, cond, line, test, x0, r0, cond0, here, rest;
    if not (e :: t_peel) then return e end if;
    if   op(0,e) in '{sum    ,Sum    }' then make := `+`;
    elif op(0,e) in '{product,Product}' then make := `*`; end if;
    body, r := op(e);
    x, r    := op(r);
    for cond in indets(body, '{`=`(algebraic),`<`,`<=`}') do
      line := `-`(op(cond));
      if 1 <> degree(line, x) then next end if;
      if cond :: `=` then
        cond0 := true;
        if Testzero(eval(line, x=lhs(r))) then
          x0 := lhs(r); r0 := applyop(`+`, 1, r, 1);
        elif Testzero(eval(line, x=rhs(r))) then
          x0 := rhs(r); r0 := applyop(`-`, 2, r, 1);
        else next end if;
      else
        test := proc(x0, x1, $)
          local res;
          res := evalb(not op(0,cond)(eval(line, x=x1), 0));
          `if`(res in '{true,false}'
                 and evalb(op(0,cond)(eval(line, x=x0), 0)) = res,
               res,
               FAIL)
        end proc;
        cond0 := test(lhs(r), lhs(r)+1);
        if cond0 <> FAIL then
          x0 := lhs(r); r0 := applyop(`+`, 1, r, 1);
        else
          cond0 := test(rhs(r), rhs(r)-1);
          if cond0 <> FAIL then
            x0 := rhs(r); r0 := applyop(`-`, 2, r, 1);
          else next end if;
        end if;
      end if;
      here := subs(cond =           cond0 , body);
      rest := subs(cond = evalb(not cond0), body);
      return make(eval(here, x=x0), do_peel(eval(subsop(1=rest, [2,2]=r0, e))));
    end do;
    return e;
  end proc;

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

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

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

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

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

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

    :-`print/Ints` := curry(thismodule:-Print,Ints);
    :-`print/Sums` := curry(thismodule:-Print,Sums);
    :-`print/ints` := curry(thismodule:-Print,ints);
    :-`print/sums` := curry(thismodule:-Print,sums);

  end proc;
  ModuleLoad():
end module; # Loop


# Teach Maple (through depends and eval) about our new binding forms.
# lam binds from 1st arg to 3rd arg.
# Branch binds from 1st arg (a pattern) to 2nd arg.
# Bind and ary bind from 2nd arg to 3rd arg.

# note that v _can_ in principle occur in t.
`depends/lam` := proc(v::name, t, e, x, $)
  depends(t, x) or depends(e, x minus {v})
end proc:

`depends/Branch` := proc(p, e, x, $)
  depends(e, x minus {Hakaru:-pattern_binds(p)})
end proc:

# note that v _can_ occur in m1.
`depends/Bind` := proc(m1, v::name, m2, x, $)
  depends(m1, x) or depends(m2, x minus {v})
end proc:

# note that i _can_ occur in n.
`depends/ary` := proc(n, i::name, e, x, $)
  depends(n, x) or depends(e, x minus {i})
end proc:
`depends/Plate` := eval(`depends/ary`):

`eval/lam` := proc(e, eqs, $)
  local v, t, ee;
  v, t, ee := op(e);
  v, ee := BindingTools:-generic_evalat(v, ee, eqs);
  t := eval(t, eqs);
  eval(op(0,e), eqs)(v, t, ee)
end proc:

`eval/Branch` := proc(e, eqs, $)
  local p, ee, vBefore, vAfter;
  p, ee := op(e);
  vBefore := [Hakaru:-pattern_binds(p)];
  vAfter, ee := BindingTools:-generic_evalat(vBefore, ee, eqs);
  eval(op(0,e), eqs)(subs(op(zip(`=`, vBefore, vAfter)), p), ee)
end proc:

`eval/Bind` := proc(e, eqs, $)
  local m1, v, m2;
  m1, v, m2 := op(e);
  eval(op(0,e), eqs)(eval(m1, eqs), BindingTools:-generic_evalat(v, m2, eqs))
end proc:

`eval/ary` := proc(e, eqs, $)
  local n, i, ee;
  n, i, ee := op(e);
  eval(op(0,e), eqs)(eval(n, eqs), BindingTools:-generic_evalat(i, ee, eqs))
end proc:
`eval/Plate` := eval(`eval/ary`):

#############################################################################
Hakaru := module ()
  option package;
  local p_true, p_false, make_piece, Mk_Plus, lift1_piecewise,
        ModuleLoad, ModuleUnload;
  export
     # These first few are smart constructors (for themselves):
         case, app, ary, idx, fst, snd, size, Datum,
     # while these are "proper functions"
         verify_measure, verify_hboolean, pattern_equiv,
         piecewise_And, map_piecewiselike, lift_piecewise, foldr_piecewise,
         flatten_piecewise,
         pattern_match, pattern_binds,
         closed_bounds, open_bounds,
         htype_patterns,
         bool_And, bool_Or, bool_Not,
         UpdateArchive;
  # These names are not assigned (and should not be).  But they are
  # used as global names, so document that here.
  global
     # Basic syntax for composing measures
         Bind, Weight, Ret, Msum, Plate, Context, Pair, _Unit, PARTITION,
     # Primitive (known) measures
         Lebesgue, Uniform, Gaussian, Cauchy, StudentT, BetaD,
         GammaD, ChiSquared,
         Counting, Categorical, NegativeBinomial, PoissonD,
     # Functions, annotated with argument type, applied using "app"
         lam,
     # Term constructors for Datum (algebraic data type)
         Inr, Inl, Et, Done, Konst, Ident,
     # The parts of "case" besides the scrutinee
         Branches, Branch,
     # Pattern constructors
         PWild, PVar, PDatum, PInr, PInl, PEt, PDone, PKonst, PIdent,
     # Verification of alpha-equivalence among measures
         measure,
     # Punctuation for matching free variables with measures for disintegration
         `&M`,
     # Structure types for Hakaru types and Hakaru "case" expressions
         known_continuous, known_discrete, t_Hakaru, t_type, t_case,
     # Structure types for piecewise-like expressions:
     # piecewise, case, and idx into literal array
         t_pw, t_piecewiselike,
     #other types
         `&implies`,
     # Type constructors for Hakaru
         AlmostEveryReal, HReal, HInt, HData, HMeasure, HArray, HFunction,
         Bound, DatumStruct;
  p_true  := 'PDatum(true,PInl(PDone))';
  p_false := 'PDatum(false,PInr(PInl(PDone)))';

  case := proc(e, bs :: specfunc(Branch(anything, anything), Branches), $)
    local ret, b, substs, eSubst, pSubst, p, binds, uncertain;
    if e :: 't_piecewiselike' then
      map_piecewiselike(procname, _passed)
    else
      ret := Branches();
      for b in bs do
        substs := pattern_match(e, e, op(1,b));
        if substs <> NULL then
          eSubst, pSubst := substs;
          p := subs(pSubst, op(1,b));
          binds := {pattern_binds(p)};
          uncertain := remove((eq -> lhs(eq) in binds), eSubst);
          if nops(uncertain) = 0 then p := PWild end if;
          ret := Branches(op(ret),
                          Branch(p, eval(eval(op(2,b), pSubst), eSubst)));
          if nops(uncertain) = 0 then break end if;
        end if
      end do;
      if ret :: Branches(Branch(identical(PWild), anything)) then
        op([1,2], ret)
      elif ret :: Branches(Branch(identical(p_true), anything),
                           Branch({identical(p_false),
                                   identical(PWild),
                                   PVar(anything)}, anything)) then
        piecewise(make_piece(e), op([1,2], ret), op([2,2], ret))
      elif ret :: Branches(Branch(identical(p_false), anything),
                           Branch({identical(p_true),
                                   identical(PWild),
                                   PVar(anything)}, anything)) then
        piecewise(make_piece(e), op([2,2], ret), op([1,2], ret))
      else
        'case'(e, ret)
      end if
    end if
  end proc;

  pattern_match := proc(e0, e, p, $)
    local x, substs, eSubst, pSubst;
    if p = PWild then return {}, {}
    elif p :: PVar(anything) then
      x := op(1,p);
      pSubst := {`if`(depends(e0,x), x=gensym(x), NULL)};
      return {subs(pSubst,x)=e}, pSubst;
    elif p = p_true then
      if e = true then return {}, {}
      elif e = false then return NULL
      end if
    elif p = p_false then
      if e = false then return {}, {}
      elif e = true then return NULL
      end if
    elif p :: PDatum(anything, anything) then
      if e :: Datum(anything, anything) then
        if op(1,e) = op(1,p) then return pattern_match(e0, op(2,e), op(2,p))
        else return NULL
        end if
      end if
    elif p :: PInl(anything) then
      if e :: Inl(anything) then return pattern_match(e0, op(1,e), op(1,p))
      elif e :: Inr(anything) then return NULL
      end if
    elif p :: PInr(anything) then
      if e :: Inr(anything) then return pattern_match(e0, op(1,e), op(1,p))
      elif e :: Inl(anything) then return NULL
      end if
    elif p :: PEt(anything, anything) then
      if e :: Et(anything, anything) then
        substs := pattern_match(e0, op(1,e), op(1,p));
        if substs = NULL then return NULL end if;
        eSubst, pSubst := substs;
        substs := pattern_match(e0, eval(op(2,e),eSubst), op(2,p));
        if substs = NULL then return NULL end if;
        return eSubst union substs[1], pSubst union substs[2];
      elif e = Done then return NULL
      end if
    elif p = PDone then
      if e = Done then return {}, {}
      elif e :: Et(anything, anything) then return NULL
      end if
    elif p :: PKonst(anything) then
      if e :: Konst(anything) then return pattern_match(e0, op(1,e), op(1,p))
      end if
    elif p :: PIdent(anything) then
      if e :: Ident(anything) then return pattern_match(e0, op(1,e), op(1,p))
      end if
    else
      error "pattern_match: %1 is not a pattern", p
    end if;
    pSubst := map((x -> `if`(depends(e0,x), x=gensym(x), NULL)),
                  {pattern_binds(p)});
    eSubst := {e=subsindets(
                   subsindets[nocache](
                     subs(pSubst,
                          p_true=true,
                          p_false=false,
                          PDatum=Datum, PInr=Inr, PInl=Inl, PEt=Et, PDone=Done,
                          PKonst=Konst, PIdent=Ident,
                          p),
                     identical(PWild),
                     p -> gensym(_)),
                   PVar(anything),
                   p -> op(1,p))};
    eSubst, pSubst
  end proc;

  make_piece := proc(rel, $)
    # Try to prevent PiecewiseTools:-Is from complaining
    # "Wrong kind of parameters in piecewise"
    if rel :: {specfunc(anything, {And,Or,Not}), `and`, `or`, `not`} then
      map(make_piece, rel)
    elif rel :: {'`::`', 'boolean', '`in`'} then
      rel
    else
      rel = true
    end if
  end proc;

  pattern_binds := proc(p, $)
    if p = PWild or p = PDone then
      NULL
    elif p :: PVar(anything) then
      op(1,p)
    elif p :: PDatum(anything, anything) then
      pattern_binds(op(2,p))
    elif p :: {PInl(anything), PInr(anything),
               PKonst(anything), PIdent(anything)} then
      pattern_binds(op(1,p))
    elif p :: PEt(anything, anything) then
      pattern_binds(op(1,p)), pattern_binds(op(2,p))
    else
      error "pattern_binds: %1 is not a pattern", p
    end if
  end proc:

  verify_hboolean := proc(a, b, $)
    local x,y,conv_tbl,and_fn,or_fn,not_fn;
    and_fn := ((x->AND({op(x)}))@`bool_And`);
    or_fn  := ((x->OR({op(x)}))@`bool_Or`);
    not_fn := bool_Not;
    conv_tbl := table([`and`=and_fn,`And`=and_fn,`Or`=or_fn,`or`=or_fn,`Not`=not_fn,`not`=not_fn]);
    x,y := subsindets([a,b], Or(`and`,`or`,`not`, specfunc({`And`,`Or`,`Not`})), x->conv_tbl[op(0,x)](op(x)))[];
    evalb(x=y);
  end proc;

  verify_measure := proc(m, n, v:='hboolean', $)
    local mv, x, i, j, k;
    mv := measure(v);
    if m :: specfunc({Bind, Plate}) and n :: specfunc({Bind, Plate}) and
       (verify(m, n, 'Bind'(mv, true, true))
      or verify(m, n, 'Plate'(v, true, true))) then
      x := gensym(cat(op(2,m), "_", op(2,n), "_"));
      thisproc(subs(op(2,m)=x, op(3,m)),
               subs(op(2,n)=x, op(3,n)), v)
    elif m :: 'specfunc(Msum)' and n :: 'specfunc(Msum)'
         and nops(m) = nops(n) then
      k := nops(m);
      verify(k, GraphTheory[BipartiteMatching](GraphTheory[Graph]({
                seq(seq(`if`(thisproc(op(i,m), op(j,n), v), {i,-j}, NULL),
                        j=1..k), i=1..k)}))[1]);
    elif andmap(type, [m,n], 'specfunc(piecewise)') and nops(m) = nops(n) then
      k := nops(m);
      verify(m, n, 'piecewise'(seq(`if`(i::even or i=k, mv, hboolean), i=1..k)));

    elif andmap(type, [m,n], 'specfunc(PARTITION)') then
      Partition:-SamePartition(verify_hboolean, verify_measure, m, n);

    elif m :: specfunc('case') and
        verify(m, n, 'case'(v, specfunc(Branch(true, true), Branches))) then
      # This code unfortunately only handles alpha-equivalence for 'case' along
      # the control path -- not if 'case' occurs in the argument to 'Ret', say.
      k := nops(op(2,m));
      for i from 1 to k do
        j := pattern_equiv(op([2,i,1],m), op([2,i,1],n));
        if j = false then return j end if;
        j := map(proc(eq, $)
                   local x;
                   x := gensym(cat(lhs(eq), "_", rhs(eq), "_"));
                   [lhs(eq)=x, rhs(eq)=x]
                 end proc, j);
        j := thisproc(subs(map2(op,1,j), op([2,i,2],m)),
                      subs(map2(op,2,j), op([2,i,2],n)), v);
        if j = false then return j end if;
      end do;
      true
    elif m :: 'LO(name, anything)' and n :: 'LO(name, anything)' then
      x := gensym(cat(op(1,m), "_", op(1,n), "_"));
      verify(subs(op(1,m)=x, op(2,m)),
             subs(op(1,n)=x, op(2,n)), v)
    elif m :: specfunc('lam') and n :: specfunc('lam') and
        verify(m, n, 'lam'(true, v, true)) then
      # m and n are not even measures, but we verify them anyway...
      x := gensym(cat(op(1,m), "_", op(1,n), "_"));
      thisproc(subs(op(1,m)=x, op(2,m)),
               subs(op(1,n)=x, op(2,n)), v)
    else
      verify(m, n, {v, Ret(v), Weight(v, mv), Context(v, mv)})
    end if
  end proc;

  pattern_equiv := proc(p, q, $) :: {identical(false),set(`=`)};
    local r, s;
    if ormap((t->andmap(`=`, [p,q], t)), [PWild, PDone]) then
      {}
    elif andmap(type, [p,q], PVar(anything)) then
      {op(1,p)=op(1,q)}
    elif andmap(type, [p,q], PDatum(anything,anything)) and op(1,p)=op(1,q) then
      pattern_equiv(op(2,p),op(2,q))
    elif ormap((t->andmap(type, [p,q], t(anything))),
               [PInl, PInr, PKonst, PIdent]) then
      pattern_equiv(op(1,p),op(1,q))
    elif andmap(type, [p,q], PEt(anything, anything)) then
      r := pattern_equiv(op(1,p),op(1,q));
      s := pattern_equiv(op(2,p),op(2,q));
      if map(lhs,r) intersect map(lhs,s) = {} and
         map(rhs,r) intersect map(rhs,s) = {} then
        r union s
      else
        false
      end if
    else
      false
    end if
  end proc;

  piecewise_And := proc(cond::{list,set,specfunc(`And`),`and`}, th, el, $)
    if nops(cond) = 0 or th = el then
      th
    else
      piecewise(And(op(cond)), th, el)
    end if
  end proc;

  map_piecewiselike := proc(f, p::t_piecewiselike)
    local i, g, h;
    if p :: 'specfunc(piecewise)' then
      piecewise(seq(`if`(i::even or i=nops(p), f(op(i,p),_rest), op(i,p)),
                    i=1..nops(p)))
    elif p :: 't_case' then
      # Mind the hygiene
      subsindets(eval(subsop(2 = map[3](applyop, g, 2, op(2,p)), p),
                      g=h(f,_rest)),
                 'typefunc(specfunc(h))',
                 (e -> op([0,1],e)(op(1,e), op(2..-1,op(0,e)))))
    elif p :: 'idx(list, anything)' then
      idx(map(f,op(1,p),_rest), op(2,p))
    else
      error "map_piecewiselike: %1 is not t_piecewiselike", p
    end if
  end proc;

  lift_piecewise := proc(e, extra:={}, $)
    local e1, e2;
    e2 := e;
    while e1 <> e2 do
      e1 := e2;
      e2 := subsindets(e1,
              '{extra,
                And(`+`, Not(specop(Not(specfunc(piecewise)), `+`))),
                And(`*`, Not(specop(Not(specfunc(piecewise)), `*`))),
                And(`^`, Not(specop(Not(specfunc(piecewise)), `^`))),
                exp(specfunc(piecewise))}',
              lift1_piecewise)
    end do
  end proc;

  lift1_piecewise := proc(e, $)
    local i, p;
    if membertype(t_piecewiselike, [op(e)], i) then
      p := op(i,e);
      if nops(p) :: even and not (e :: `*`) and op(-1,p) <> 0 then
        p := piecewise(op(p), 0);
      end if;
      map_piecewiselike((arm->lift1_piecewise(subsop(i=arm,e))), p)
    else
      e
    end if
  end proc;

  foldr_piecewise := proc(cons, nil, pw, $) # pw may or may not be piecewise
    # View pw as a piecewise and foldr over its arms
    if pw :: 'specfunc(piecewise)' then
      foldr(proc(i,x) cons(op(i,pw), op(i+1,pw), x) end proc,
            `if`(nops(pw)::odd, cons(true, op(-1,pw), nil), nil),
            seq(1..nops(pw)-1, 2))
    else
      cons(true, pw, nil)
    end if
  end proc;

  #Take a piecewise: If some of the branches also contain piecewises, attempt
  #to re-express the whole as a single piecewise. In short: fewer piecewises, more
  #branches, more complex conditions.--Carl 2016Sep09
  flatten_piecewise:= proc(PW::specfunc(piecewise), $)::specfunc(piecewise);
  local
     pwL:= [op(PW)],
     nP:= nops(pwL),
     conds:= pwL[[seq(1..nP-1, 2)]],
     branches:= pwL[[seq(2..nP-1, 2), nP]],
     innerPW:= indets(branches, specfunc(piecewise)),
     outerPW, C_O, C_I, B_I, r
  ;
     if indets(conds, specfunc(piecewise)) <> {} then
          userinfo(2, procname, "Case of inner pw in a condition not yet handled.");
          return PW
     end if;
     if innerPW = {} then
          userinfo(3, procname, "No inner pw.");
          return PW
     end if;
     if nops~(innerPW) <> {3} then
          userinfo(2, procname, "Case of inner pw of other than 3 ops not yet handled.");
          return PW
     end if;
     if nops(PW) <> 3 then
          userinfo(2, procname, "Case of outer pw of other than 3 ops not yet handled.");
          return PW
     end if;
     outerPW:= applyop(lift_piecewise, {2,3}, PW);
     if membertype(
          And(
               satisfies(e-> indets(e, specfunc(piecewise)) <> {}),
               Not(specfunc(piecewise))
          ),
          {op(2..3, outerPW)}
     )
     then
          userinfo(1, procname, "Unliftable pw.");
          return PW
     end if;
     C_O:= op(1,outerPW);
     C_I:= map(e-> `if`(e::specfunc(piecewise), op(1,e), true), [op(2..3, outerPW)]);
     B_I:= map(e-> `if`(e::specfunc(piecewise), [op(2..3, e)], [e$2])[], [op(2..3, outerPW)]);
     #For debugging purposes, I want to show the proposed output before it's passed to
     #piecewise.
     r:= [
          And(C_O, C_I[1]), B_I[1],
          And(C_O, KB:-negate_rel(C_I[1])), B_I[2],
          And(KB:-negate_rel(C_O), C_I[2]), B_I[3],
          And(KB:-negate_rel(C_O), KB:-negate_rel(C_I[2])), B_I[4]
     ];
     userinfo(3, procname, "Proposed ouput: ", print(%piecewise(r[])));
     piecewise(r[])
  end proc;

  app := proc (func, argu, $)
    if func :: 'lam(name, anything, anything)' then
      eval(op(3,func), op(1,func)=argu)
    elif func :: 't_piecewiselike' then
      map_piecewiselike(procname, _passed)
    else
      'procname(_passed)'
    end if
  end proc;

  ary := proc (n, i, e, $)
    local j;
    if e :: 'idx'('freeof'(i), 'identical'(i)) then
      # Array eta-reduction. Assume the size matches.  (We should keep array
      # size information in the KB and use it here, but we don't currently.)
      op(1,e)
    elif n :: nonnegint then
      [seq(eval(e,i=j), j=0..n-1)] # Unroll array with literal size
    else
      'procname(_passed)'
    end if
  end proc;

  idx := proc (a, i, $)
    if a :: 'ary(anything, name, anything)' then
      eval(op(3,a), op(2,a)=i)
    elif a :: 'list' and i::nonnegint then
      a[i+1]
    elif a :: 'list' and nops(convert(a,'set')) = 1 then
      a[1] # Indexing into a literal array whose elements are all the same
    elif a :: 't_piecewiselike' then
      map_piecewiselike(procname, _passed)
    else
      'procname(_passed)'
    end if
  end proc;

  #Extract the first member of a Pair.
  fst:= proc(p, $)
    if p :: 'Pair'('anything'$2) then
      op(1,p)
    elif p :: t_piecewiselike then
      map_piecewiselike(fst, p)
    else
      'procname'(p)
    end if;
  end proc;

  #Extract the second member of a Pair.
  snd:= proc(p, $)
    if p :: 'Pair'('anything'$2) then
      op(2,p)
    elif p :: t_piecewiselike then
      map_piecewiselike(snd, p)
    else
      'procname'(p)
    end if;
  end proc;

  size := proc(a, $)
    local res;
    if a :: 'ary(anything, name, anything)' then
      op(1,a)
    elif a :: 'list' then
      nops(a)
    elif a :: 't_piecewiselike' then
      map_piecewiselike(procname, _passed)
    else
      'procname(_passed)'
    end if
  end proc;

  Datum := proc(hint, payload, $)
    # Further cheating to equate Maple booleans and Hakaru booleans
    if hint = true and payload = Inl(Done) or
       hint = false and payload = Inr(Inl(Done)) then
      hint
    else
      'procname(_passed)'
    end if
  end proc;

  closed_bounds := proc(r::range, $)
    Bound(`>=`, lhs(r)), Bound(`<=`, rhs(r))
  end proc;

  open_bounds := proc(r::range, $)
    Bound(`>`, lhs(r)), Bound(`<`, rhs(r))
  end proc;

  # Creates an N-ary operator `Plus` such:
  #  Plus(Plus(a,b),c)=Plus(a,Plus(a,b))
  #  Plus(a,Zero)=a
  #  Plus(a)=a
  #  Plus(x,x)=x
  Mk_Plus := proc(plus,zero,$) proc()
    local as := {args};
    as := map(a->if op(0,a)=plus then op(a) else a end if, as);
    if nops(as)=0 then zero
    elif nops(as)=1 then op(1,as)
    else plus(op(as))
    end if;
  end proc; end proc;

  # Replacements for `and` and `or` which do not
  # evaluate "x = y" to "false" when "x,y" are unbound vars.
  bool_And := Mk_Plus('And','true' );
  bool_Or  := Mk_Plus('Or' ,'false');

  bool_Not := proc(a,$)
    if a :: t_kb_atom then
      subsindets(KB:-negate_rel(a), `not`, Not@op);
    else
      Not(a)
    end if;
  end proc;

  # Enumerate patterns for a given Hakaru type
  htype_patterns := proc(t::t_type, $)
    :: specfunc(Branch(anything, list(t_type)), Branches);
    local struct;
    uses StringTools;
    if t :: specfunc(DatumStruct(anything, list(Konst(anything))), HData) then
      foldr(proc(struct,ps,$) Branches(
              op(map((p -> Branch(PDatum(op(1,struct), PInl(op(1,p))),
                                  op(2,p))),
                     foldr(proc(kt,qs,$)
                             local p, q;
                             Branches(seq(seq(Branch(PEt(PKonst(op(1,p)),
                                                         op(1,q)),
                                                     [op(op(2,p)),op(op(2,q))]),
                                              q in qs),
                                          p in htype_patterns(op(1,kt))))
                           end proc,
                           Branches(Branch(PDone, [])), op(op(2,struct))))),
              op(map[3](applyop, PInr, [1,2], ps)))
            end proc,
            Branches(), op(t))
    else
      Branches(Branch(PVar(gensym(convert(LowerCase(op(-1, ["x", op(
                                            `if`(t::function,
                                              select(IsUpper, Explode(op(0,t))),
                                              []))])),
                                          name))),
                      [t]))
    end if
  end proc;

  ModuleLoad := proc($)
    local g; #Iterator over thismodule's globals
    ModuleUnload();
    VerifyTools[AddVerification](measure = eval(verify_measure));
    VerifyTools[AddVerification](hboolean = eval(verify_hboolean));

    TypeTools:-AddType(
         `&implies`,
         proc(e, t1, t2, $) type(e, Or(Not(t1), t2)) end proc
    );
    TypeTools:-AddType(Name, And(name, Not({constant,undefined})));
    TypeTools:-AddType(known_continuous,
         '{
              Lebesgue(anything, anything), Uniform(anything, anything),
              Gaussian(anything, anything), Cauchy(anything, anything),
              StudentT(anything, anything, anything), ChiSquared(anything),
              BetaD(anything, anything), GammaD(anything, anything),
              InverseGammaD(anything, anything)
         }'
    );
    TypeTools:-AddType(known_discrete,
         '{
              Counting(anything, anything),
              Categorical(anything),
              Binomial(anything,anything),
              NegativeBinomial(anything,anything),
              PoissonD(anything)
          }'
    );
    #This type t_Hakaru is the basic syntax checker for that part of the
    #Maple/Hakaru language accessible by the external user.--Carl 2016Sep20
    TypeTools:-AddType(t_Hakaru,
         #Alternation/conjunction of types via {} or And follows the McCarthy
         #short-cut rule: Proceeding left to right, once satisfaction of the type
         #can be determined, the remaining elements aren't evaluated. Therefore,
         #recursive types are possible by placing the base cases at the beginning.
         #But use Or instead of {} because you can't control the order of
         #expressions with {}.
         Or(
           'known_continuous', 'known_discrete',
           t_pw, #Needs to be more specific!
           t_partition,
           t_case,
          'Ret(anything)',
          'Bind(t_Hakaru, name, t_Hakaru)',
          'specfunc(t_Hakaru, Msum)',
          'Weight(algebraic, t_Hakaru)',
          'Plate(algebraic, name, t_Hakaru)',
          t_lam
         )
    );
    TypeTools:-AddType(t_type,
      '{specfunc(Bound(identical(`<`,`<=`,`>`,`>=`), anything),
                 {AlmostEveryReal, HReal, HInt}),
        specfunc(DatumStruct(anything, list({Konst(t_type), Ident(t_type)})),
                 HData),
        HMeasure(t_type),
        HArray(t_type),
        HFunction(t_type, t_type)}');
    TypeTools:-AddType(t_case,
      'case(anything, specfunc(Branch(anything, anything), Branches))');
    TypeTools:-AddType(t_pw, 'specfunc(piecewise)');
    TypeTools:-AddType(t_partition, 'specfunc(PARTITION)'); #Appropriate to put this here?
    TypeTools:-AddType(t_piecewiselike,
      '{specfunc(piecewise), t_case, idx(list, anything)}');
    TypeTools:-AddType(t_lam, 'lam(name, t_type, t_Hakaru)');

    # A temporary type which should be removed when piecewise is gone
    TypeTools:-AddType(t_pw_or_part, Or(t_pw,t_partition));

    #Protect the keywords of the Hakaru language.
    #op([2,6], ...) of a module is its globals.
    for g in op([2,6], thismodule) do
         if g <> eval(g) then
           unassign(g);
           WARNING("Previous value of Hakaru keyword '%1' erased.", g);
         end if;
         protect(g)
    end do
  end proc;

  ModuleUnload := proc($)
    map(proc(x::uneval) try eval(x) catch: NULL; end try end proc,
        ['TypeTools:-RemoveType(`&implies`)'
        ,'TypeTools:-RemoveType(Name)'
        ,'TypeTools:-RemoveType(known_continuous)'
        ,'TypeTools:-RemoveType(known_discrete)'
        ,'TypeTools:-RemoveType(t_Hakaru)'
        ,'TypeTools:-RemoveType(t_pw)'
        ,'TypeTools:-RemoveType(t_partition)'
        ,'TypeTools:-RemoveType(t_pw_or_part)'
        ,'TypeTools:-RemoveType(t_piecewiselike)'
        ,'TypeTools:-RemoveType(t_case)'
        ,'TypeTools:-RemoveType(t_type)'
        ,'TypeTools:-RemoveType(t_lam)'
        ,'VerifyTools[RemoveVerification](measure)'
        ]);
    unprotect(op([2,6], thismodule)); #See comment in ModuleLoad.
    #Skip restoring the globals to any prior value they had.
  end proc;
  ModuleLoad();
end module; # Hakaru


# Various utilities used by Hakaru which don't fit logically elsewhere
Utilities := module ()
  option package;

  # Returns true for a sequence for which all the elements are equal up to the
  # specified equality, or false otherwise. A 0-length sequence produces an
  # error.
  export the := proc(as, eq:=`=`, $)
    if nops(as)=0 then error "sequence %1 must have at least one operand", as; end if;
    andmap(x -> eq(x,op(1,as)), [op(2..-1,as)]);
  end proc;

  # zip together an arbitrary number of lists;
  # - if any lists are shorter, the function recieves all available arguments
  #    e.g. zip_k(F, [a,b], [c]) -> [F(a, c), F(b)]
  # - if any lists contain subslists, those are also zipped together, so
  #   zip_k(F, as) and zip_k(F, [as]) are equivalent. To avoid this, use a 0-th
  #   operand other than `[]`.
  #    e.g. zip_k(F, [a,b], [ [c,d], [e,f] ]) -> [F(a, c, d), F(b, e, f)]
  export zip_k := proc(f)
    map(f@op@ListTools[Flatten], foldl((a,b)->zip(`[]`,a,b,[]), _rest));
  end proc;

  # Merges two records, `rspec' and `rdef'. If `rspec' contains any fields of
  # `rdef', the fields of `rspec' are taken.
  export merge_record_default := proc(rdef::record, rspec::record, $)
    local s;
    s   := {exports(rdef)} intersect {exports(rspec)};
    Record[ Record[rdef](op(map(`-`,s))) , rspec ]();
  end proc;

  # Creates a new record with `field' updated to the given function applied to
  # `field' of the given record.
  export upd_field := proc(r::record, field::name, k, $)
    Record[r](-field,field=k(r[field]))
  end proc;

  # Simplistic negation of relations. Used by Hakaru:-flatten_piecewise, KB, and
  # Domain.
  export negated_relation:= table([`<`, `<=`, `=`, `<>`] =~ [`>=`, `>`, `<>`, `=`]);

  # Takes the bool type (true/false) to mean universal and empty relations
  # respectively.  i.e. negate R, where R is an 'atomic' relation of a KB.
  # This is used by KB and Partition
  export negate_rel:= proc(R::Relation, $)::Relation;
    if R :: truefalse then
      not R
    elif R :: relation then
      negated_relation[op(0,R)](op(R));
    else
      # This is to appease 'piecewise', which won't be happy with Not
      # However, KB doesn't really care - it's already expecting {Not,not}
      # 'Technically' this is a KB 'constructor'!
      not(R);
    end if;
  end proc;

  # Differs from negate_rel in that
  #  [ negate_rel (x) ] = "Not x"  but
  #  [ negate_rels(x) ] = "x"
  export negate_rels := proc(e, $)
    subsindets(e, { specfunc(relation, `Not`), `not`(relation) }, negate_rel@op );
  end proc;

  # Creates an N-ary operator `Plus` such:
  #  Plus(Plus(a,b),c)=Plus(a,Plus(a,b))
  #  Plus(a,Iden)=a
  #  Plus(a,Zero)=Zero
  #  Plus(a)=a
  #  Plus(x,x)=x
  export Mk_Plus := proc(plus,iden,zero,$) proc()
    local as := {args};
    as := map(a->if op(0,a)=plus then op(a) else a end if, as);
    if zero in as then return zero end if;
    as := remove(`=`,as,iden);
    if nops(as)=0 then iden
    elif nops(as)=1 then op(1,as)
    else plus(op(as))
    end if;
  end proc; end proc;

  # Replacements for `and`, `or`, `not` which do not
  # evaluate "x = y" to "false" when "x,y" are unbound vars.
  export bool_And := Mk_Plus(And,true ,false);
  export bool_Or  := Mk_Plus(Or ,false,true);
  export bool_Not := proc(a,$)
    if a :: Relation and not (a :: `::`) then
      subsindets(negate_rel(a), `not`, Not@op);
    else
      Not(a)
    end if;
  end proc;

  # boolean_if should be equivalent to `if`, but it assumes
  # all its arguments are boolean conditions, so it basically
  # simplifies "cond and th or not cond and el"
  export boolean_if := proc(cond, th, el, $)
    use
      a = ((x,y)-> `if`(x=true,y, `if`(x=false,x,
                   `if`(y=true,x, `if`(y=false,y, And(x,y)))))),
      o = ((x,y)-> `if`(x=false,y, `if`(x=true,x,
                   `if`(y=false,x, `if`(y=true,y, Or (x,y)))))),
      n = (x    -> `if`(x=false,true,
                   `if`(x=true,false,             Not(x))))
    in
      o(a(cond,th), a(n(cond),el))
    end use
  end proc;

  # In order to hopefully produce a simplification,
  #   assert_deny will on some occasions repeatedly apply
  #   `simplify@ln` in the hopes of producing an 'improved'
  #   constraint. This metric gives the stopping condition
  # - when the simplification ceases to improve the constraint
  # - which is when the metric is made no less by the `simplify@ln`.
  # Since this is a `length`, this is strictly decreasing,
  #  so such a loop will 'provably' always terminate
  export log_metric := proc(e, x, $)
    local m, L;
    m := select(depends, indets(e, 'exp(anything)'), indets(x,name));
    length(subsindets(map2(op, 1, m), name, _->L));
  end proc;

  # Used by both KB and Domain
  export try_improve_exp := proc(b0, x, ctx, $)
    local b := b0, log_b;
    do
      try log_b := map(simplify@ln, b) assuming op(ctx); catch: break; end try;

      if log_metric(log_b, x) < log_metric(b, x)
         and (andmap(e->is(e,real)=true, log_b) assuming op(ctx)) then
        b := log_b;
      else
        break;
      end if;
    end do;
    b;
  end proc;

  # Given an expression containing products and sums, i.e. polynomials
  # and a function , applies this expression to each factor and summand
  export for_poly := proc(e, f, $)
    if e :: '{`+`,`*`}' then map(for_poly, e, f)
    elif e :: 'specfunc({product,Product,sum,Sum})' then
      applyop(for_poly, 1, e, f)
    else f(e)
    end if
  end proc;

  # Apply a function to each summand at the top level of the expression
  export distrib_over_sum := proc(f,e,$) `+`(op(map(f,convert(e, 'list',`+`)))) end proc;

  # Like convert(e, 'list', `*`) but tries to keep the elements positive
  export list_of_mul := proc(e, $)
    local rest, should_negate, can_negate, fsn;
    rest := convert(e, 'list', `*`);
    rest := map((f -> [f, signum(f),
                       `if`(f::'{specfunc({Sum,sum}),anything^odd}',
                            applyop(`-`,1,f),
                       `if`(f::'specfunc(ln)',
                            applyop(`/`,1,f),
                            -f))]),
                rest);
    should_negate, rest := selectremove(type, rest,
      '[anything, -1, Not(`*`)]');
    if nops(should_negate) :: even then
      [seq(op(3,fsn), fsn=should_negate),
       seq(op(1,fsn), fsn=rest)]
    else
      can_negate, rest := selectremove(type, rest,
        '[{`+`, specfunc({Sum,sum,ln}), `^`}, Not(1), Not(`*`)]');
      if nops(can_negate) > 0 then
        [seq(op(3,fsn), fsn=should_negate),
         op([1,3], can_negate),
         seq(op(1,fsn), fsn=subsop(1=NULL, can_negate)),
         seq(op(1,fsn), fsn=rest)]
      else
        [seq(op(3,fsn), fsn=subsop(-1=NULL, should_negate)),
         op([-1,1], should_negate),
         seq(op(1,fsn), fsn=rest)]
      end if
    end if
  end proc;

  export mysolve := proc(constraints)
    # This wrapper around "solve" works around the problem that Maple sometimes
    # thinks there is no solution to a set of constraints because it doesn't
    # recognize the solution to each constraint is the same.  For example--
    # This fails     : solve({c*2^(-1/2-alpha) = sqrt(2)/2, c*4^(-alpha) = 2^(-alpha)}, {c}) assuming alpha>0;
    # This also fails: solve(simplify({c*2^(-1/2-alpha) = sqrt(2)/2, c*4^(-alpha) = 2^(-alpha)}), {c}) assuming alpha>0;
    # But this works : map(solve, {c*2^(-1/2-alpha) = sqrt(2)/2, c*4^(-alpha) = 2^(-alpha)}, {c}) assuming alpha>0;
    # And the difference of the two solutions returned simplifies to zero.

    local result;
    if nops(constraints) = 0 then return NULL end if;
    result := solve(constraints, _rest);
    if result <> NULL or not (constraints :: {set,list}) then
      return result
    end if;
    result := mysolve(subsop(1=NULL,constraints), _rest);
    if result <> NULL
       and op(1,constraints) :: 'anything=anything'
       and simplify(eval(op([1,1],constraints) - op([1,2],constraints),
                         result)) <> 0 then
      return NULL
    end if;
    result
  end proc;

  # A debugging utility that's like `and` except it calls `userinfo` if there is
  # disagreement
  export and_info := proc(e :: {list,set})
    local s, r;
    s, r := selectremove(evalb, e);
    if nops(r) = 0 then return true end if;
    if nops(s) > 0 then userinfo(op([_rest, s, r])) end if;
    return false;
  end proc;

  # Simplifies relations using `Logic:-Normalize' and places the result in a
  # canonical form. The input can be {and,not,or} but the output is always
  # {And,Or,Not}.
  #  - false, true are expressed as And and Or
  #  - When `norty' is DNF/CNF then the outer constructor is always Or/And
  #
  # TODO:
  # A better interface for `simpl_relation` - something that allows it to treat
  #   arbitrary constructor forms as And, Or, Not. Typically, we do a `subs` right
  #   before the call to `simpl_relation` to put things in the right form, then
  #   another `subs` immediately inside `simpl_relation` to turn `And,Or` into `&and,&or`.
  export simpl_relation :=
  proc( expr_ :: {relation, boolean, specfunc({`And`,`Not`,`Or`}), `and`, `not`, `or`}
      , { norty := 'DNF' }
      , $) :: { specfunc(specfunc({Relation, specfunc(relation, Not)}, `Or`), `And`)
              , specfunc(specfunc({Relation, specfunc(relation, Not)}, `And`), `Or`)
              };
      local expr := expr_, outty, outmk, inty, inmk, ty_ord ;

      # Necessary because we convert `And' (etc.) to `Logic:-&and' (etc.), and
      # e.g. `Logic:-&and(a<b,c<d)' is not a valid piecewise condition.
      expr := chillFns('piecewise', expr);

      expr := foldr( proc(v,e) subsindets(e, op(v)) end proc
                   , expr
                   , [ { specfunc(relation, `Not`), `not`(relation) }
                     , x-> negate_rel(op(1,x)) ]
                   , [ { specfunc(`Not`), `not` }
                     , x->Logic:-`&not`(op(1,x)) ]
                   , [ { specfunc(`Or`), `or` }
                     , x->Logic:-`&or`(op(x)) ]
                   , [ { specfunc(`And`), `and` }
                     , x->Logic:-`&and`(op(x)) ] );
      expr := Logic:-Normalize(expr, form=norty);
      expr := foldr( proc(v,e) subsindets(e, op(v)) end proc
                   , expr
                   , [ specfunc(Logic:-`&and`), x->`And`(op(x)) ]
                   , [ specfunc(Logic:-`&or`) , x->`Or`(op(x)) ]
                   , [ specfunc(Logic:-`&not`), x->negate_rel(op(1,x))  ] );

      if expr :: identical(false) then
        return `if`(norty='DNF', `Or`(), `And`(`Or`()));
      elif expr :: identical(true) then
        return `if`(norty='DNF', `Or`(`And`()), `And`());
      end if;

      ty_ord := `if`(norty='DNF', [1,2], [2,1]);
      outty, inty := [ 'specfunc(Or)', 'specfunc(And)' ][ty_ord][];
      outmk, inmk := [ `Or`, `And` ][ty_ord][];

      if not expr :: outty then expr := outmk(expr) end if;
      expr := map(x -> if not x :: inty then inmk(x) else x end if, expr);
      expr := warmFns('piecewise', expr);
  end proc;

  # Classify a relation by matching either the LHS or RHS against
  # a given predicate, and placing the relation in a canonical form
  # where the LHS (3rd component of the result) is the side matching
  # the predicate, or FAIL of neither side matches.
  export classify_relation := proc(r0::relation, vars0, $)
    ::{identical(FAIL), [identical(B_LO,B_HI,B_EQ,B_NEQ),
                         satisfies(q->q in {indices(flip_relation,nolist)}),
                         anything, anything]};
    local r_k, r_s, in_vars, vars := vars0, r := r0;
    if vars :: ({set,list})({name,list(name)}) then
      vars := map(x->`if`(x::list,op(1,x),x),vars);
      vars := {op(vars)}; in_vars := x->x in vars;
    elif vars :: procedure then
      in_vars := vars;
    elif vars :: type then
      in_vars := x->type(x,vars);
    else error "unknown argument: %1 "
               "(expecting variables, variable membership check)"
               , vars;
    end if;
    if r :: {`<=`,`<`, `=`, `<>`} then
      if in_vars(rhs(r)) then
        r_k := flip_relation[op(0,r)]; r_s := rhs(r), lhs(r);
      elif in_vars(lhs(r)) then
        r_k := op(0,r); r_s := op(r);
      else return FAIL end if;
      [ classify_relop[r_k], r_k, r_s ];
    else FAIL
    end if;
  end proc;
  local flip_relation := table([`=`=`=`,`<>`=`<>`,`<=`=`>=`,
                                `<`=`>`,`>=`=`<=`,`>`=`<`]);
  local classify_relop := table([`=`=B_EQ,`<>`=B_NEQ,`<=`=B_HI,
                                 `<`=B_HI,`>=`=B_LO,`>`=B_LO]);

  # Functionalized, curried `if' statement
  export Case :=
  proc(ty,f,g)
    proc(x)
      if x::ty then f(x) else g(x) end if
    end proc
  end proc;

  # A replacement for `coulditbe .. assuming ..' which uses `is' internally
  # (since `is' is actually stronger than `coulditbe'); tries to handle `Or`s
  # correctly (which don't do well with `assuming'); and catches some exceptions
  # which we are reasonably sure have a valid interpretation.
  local do_rel_coulditbe := proc(a,as_::{set,list,Relation},$)
    option remember, system;
    local os, rs, as := as_;
    if as::{set,list} then
      as := And(op(as));
    end if;
    as := simpl_relation(as,norty='DNF');

    if nops(as)=1 then
      try
        not(is(bool_Not(a)) assuming op(1,as));
      catch "when calling '%1'. Received: 'contradictory assumptions'" :
        # technically this means the KB was already contradictory, we
        # just didn't know?
        return false;
      catch "when calling '%1'. Received: "
            "'side relations must be polynomials in"
            " (name or function) variables'":
        # This is seemingly a Maple bug - the condition could still be, but we
        # don't know, so conservatively return true.
        WARNING( sprintf( "siderels bug:\n\t'%s'\n"
                          "when calling coulditbe(%%1) assuming (%%2)"
                          , StringTools[FormatMessage](lastexception[2..-1])),
                 a, as_ );
        return true;
      catch "when calling '%3'. Received: "
            "'when calling '%2'. Received: "
            "'expression independent of, %0''":
        error expr_indp_errMsg(), a, as_;
      catch "when calling '%2'. Received: 'expression independent of, %0'":
        error expr_indp_errMsg(), a, as_;
      end try;
    else
      ormap(o1->rel_coulditbe(a,o1)=true, as);
    end if;
  end proc;

  local expr_indp_errMsg := proc($)
    sprintf("Something strange happened(%s)\n"
            "\tin coulditbe(%%1) assuming %%2"
            ,StringTools[FormatMessage](lastexception[2..-1]))
  end proc;

  # Given a symmetric relation `x0', applies `test' the operands of the relation
  # in a symmetric manner. If it succeeds, returns `x0' with the side satisifying
  # `test' on the left-hand. If neither side satisfies `test', returns FAIL.
  #  e.g.:
  #   is_lhs(x=3, (a,_)->type(a,integer))  =  3=x
  #   is_lhs(x=3, (a,_)->type(a,name))     =  x=3
  #   is_lhs(x=3, (a,_)->type(a,complex))  =  FAIL
  export is_lhs := proc(test,x)
    if test(lhs(x), rhs(x),_rest) then return x end if;
    if test(rhs(x), lhs(x),_rest) then return op(0,x)(rhs(x),lhs(x)) end if;
    FAIL;
  end proc;

  # `curry(chillFns,foo)' is the function which converts all occurences of
  # `foo(as)' to `f[as]' in the given expression. `warmFns' is the inverse.
  #
  # For some reason making these curried also requires `KB:-chill' and
  # `KB:-warm' to be eta-expanded (i.e. `chill := x->chillFns(chilled)(x)')
  export chillFns := (fns, e) -> subsindets(e, 'specfunc'(fns), c->op(0,c)[op(c)]);
  export warmFns  := (fns, e) -> subsindets(e, 'specindex'(fns), c->map(curry(warmFns,fns), op(0,c)(op(c))));

  # Print profiling information for a function when `infolevel' for that
  # function is set to at least 3, and assertlevel>0; e.g.
  #  > do_func := proc() .. func .. end: func := ProfileFn(do_func):
  #  > infolevel[func] := 3:
  #  > kernelopts(assertlevel) := 1:
  #  > func(a,b,c);
  #
  #  - profiling information is only printed for runs of the function
  #    which use a minimum amount of time, bytesalloc, or bytesused
  #  - setting infolevel >= 5 prints profiling information for all runs of the
  #    function.
  #  - less than a minimum amount of a resource consumed omits the actual usage
  #    with both infolevel >= 3 < 5 and infolevel >= 5 (just "less than <min>"
  #    is printed instead)
  #  - profiling information is not printed for recursives calls of a function
  #    (in other words, if a recursive function is profiled, only non-recursive
  #     instances will have profiling attached)
  export ProfileFn := module()
    local get_prof := proc()
      [ time[real](), kernelopts(bytesalloc)/2^20, kernelopts(bytesused)/2^20 ];
    end proc;
    local ppr_prof1 := proc(m,a,nm,fmt0,$)
      local v,p,fmt;
      v,p,fmt := `if`(a>=m, ["",a,fmt0], ["less than ",m,"%a"])[];
      cat(v,sprintf(fmt,p)," ",nm);
    end proc;
    local ppr_prof := proc(min_t, t, nms, $)
      local prefix, prefixl, strs;
      prefix := "took "; prefixl := length(prefix);
      strs :=
      zip_k(ppr_prof1, min_t, t, nms);
      cat(op(
        ListTools:-Interleave(
          ["\n\t"$nops(strs)],
          [prefix,cat(" "$prefixl)$(nops(strs)-1)],
          strs)));
    end proc;
    export ModuleApply :=
    proc(fn,min_t:=0.1,min_ba:=100,min_bu:=100)
      proc()
        local t, min_prof, profs, res, ctx, fncall;
        if kernelopts(assertlevel) > 0 and
           not (assigned(_Env_ProfileFn_inside[fn])) and
           assigned(infolevel['procname']) and
           infolevel['procname'] >= 3
        then
          _Env_ProfileFn_inside[fn] := true;
          t[0] := get_prof();
          res  := fn(args);
          t[1] := get_prof();
          t[2] := zip(`-`,t[1],t[0]);
          ctx  := map(op@getassumptions,indets([fn,args],Name));
          fncall := sprintf("%a(%q)",'procname',args);
          ctx    := sprintf("assuming (%q)", op(ctx));
          min_prof := [min_t,min_ba,min_bu];
          profs  := ppr_prof(min_prof, t[2],
                             [["seconds","%.3f"],
                              ["MiB alloc", "%.3f"],
                              ["MiB total used", "%.3f"]]);
          userinfo(`if`(`or`(zip(`>`,t[2], min_prof)[]),3,5),
                   'procname',
                   printf("Evaluating\n\t%s\n\t%s%s\n",fncall,ctx,profs));
          res;
        else
          fn(args)
        end if;
      end proc;
    end proc;
  end module;

  export rel_coulditbe := ProfileFn(do_rel_coulditbe, 1);

  # The closure of `f:set->set' with respect to `x:set'. That is, all values
  # which are outputs of `f' applied to `x' or an output of `f'.
  export cl := proc(f,x,$)
    local rs := f(x) minus x;
    if rs={} then x else cl(f,rs) union x end if;
  end proc;

  # The first `n' elements of a list, or the entire list if it has fewer than
  # `n' elements.
  export take := proc(xs,n,$)
    op(1,[ListTools[LengthSplit](xs,n)]);
  end proc;

  # A copy of `:-profile' with
  #  - better pretty printing of the result
  #  - bug fix for the fact that multiple names of sub-modules with the same
  #    'root' name cannot be profiled (e.g. M1:-x and M2:-x, commonly an issue
  #    with ModuleApply)
  #  - automatic collection of the names present in the Hakaru library
  # To profile `f(as)', call `Profile(f,_args=[as])'. Profiling information
  #  if printed to stdout
  # Extra arguments to `Profile' are passed to `GetProf' and `PPrProf', which
  #  determine which stats to profile and how to pretty print profiling
  #  information.
  # Environment variables affecting this function:
  #  _Env_Profile_count_ppr  = number of profiled names to print
  #  _Env_Profile_remove_ppr = selector function (: name->bool) to omit
  #    certain names from the profiling output
  export Profile := module()
    option package;
    export ModuleApply, GetProf, PPrProf, modules_to_profile, names_to_profile;
    local ModuleLoad, profile_flag_to_ord, name_to_string;

    modules_to_profile := proc()
      kernelopts(opaquemodules=false):
      { 'BindingTools'
      # , 'Hakaru'
      , 'KB'
      , 'Partition'
      , 'Partition:-Simpl'
      , 'Loop'
      , 'Domain'
      # , 'NewSLO'
      , 'NewSLO:-fromLO'
      , 'NewSLO:-toLO'
      , 'NewSLO:-reduce'
      , 'NewSLO:-reduce_Integrals'
      , 'NewSLO:-reduce_Partition'
      , 'NewSLO:-simplify_factor_assuming'
      , 'Summary'
      , entries(Domain:-Improve:-Simplifiers, nolist)
      };
    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);
      NULL;
    end proc;
    ModuleLoad();
  end module;

  local ModuleLoad := proc($)
    BindingTools:-load_types_from_table(
      table(
        [(Relation=
          ''{`::`, boolean, `in`, specfunc(anything,{Or,Not,And})}'')
        ,(Name = 'And(name, Not({constant,undefined}))')
        ]));
  end proc;
  ModuleLoad();
end module;