change one sum to a Sum

change one sum to a Sum

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  ModuleLoad();

end module; # Loop

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  ModuleLoad();

end module; # Loop


Cheat a bit and skip checking new bounds are valid if it might return unevaluated

# Convert Domain to a KB. Very partial, mainly for backwards compatibility
# for parts of the code which still work with KB.
export Bound := module ()
    export toKB := proc(dom :: DomBound, kb0 :: t_kb, $)::[t_kb_mb, list(name=name)];
        local kb := kb0, vs := op(1, dom), rn := []
            , vn, vt, make, lo, hi, vn_rn, rn_t, v ;
        for v in vs do
            vn, vt, make := op(v);
            lo, hi := ExtBound[make]:-SplitRange(vt);
            vn_rn, kb := ExtBound[make]:-MakeKB( vn, lo, hi, kb );
            rn := [ vn=vn_rn, op(rn) ];
        end do;
        [ kb, rn ]
    end proc;

    export varsOf := proc(dom :: DomBound, $)::list(DomBoundVar);
        map(x->op(1,x), op(1, dom));
    end proc;

    export withVarsIxs := proc(dom :: DomBound, $) :: DomBound;
        DBound( op(1..2,dom), table([ seq(op([1,i,1],dom)=i,i=1..nops(op(1,dom))) ]) );
    end proc;

    export varIx := proc(dom0::DomBound, v::DomBoundVar, $)::nonnegint;
        local dom := `if`(nops(dom0)>=3, (_->_), withVarsIxs)(dom0);
        if assigned(op(3,dom)[v]) then
            op(3,dom)[v]
        else
            error "cannot find var %1 in %2", v, dom0;
        end if;
    end proc;

    export isEmpty := proc(dom :: DomBound, $)::truefalse;
        evalb(nops(op(1,dom))=0);
    end proc;

    export get := proc(dom :: DomBound, var :: DomBoundVar, $)
        local th;
        th := select(x->op(1,x)=var, op(1,dom));
        if nops(th) = 1 then
            op([1,2], th), op([1,3], th)
        elif nops(th) = 0 then
            error "cannot find var %1 in %2", var, dom;
        else
            error "multiple references in %1", dom;
        end if;
    end proc;

    export upd := proc(dom0 :: DomBound, vr :: DomBoundVar, ty :: DomBoundRange, $)
        local dom := `if`(nops(dom0)>=3, (_->_), withVarsIxs)(dom0), i
            , old_lo,old_hi, lo,hi, old_ty, new_ty, _, vr_k;
        i := varIx(dom, vr);

        _, old_ty, vr_k := op(op([1,i], dom));
        old_lo,old_hi := Domain:-ExtBound[vr_k]:-SplitRange(old_ty);
        lo, hi        := Domain:-ExtBound[vr_k]:-SplitRange(ty);

        if lo :: realcons then
          lo := Domain:-ExtBound[vr_k]:-Max(old_lo, lo);
        end if;
        if hi :: realcons then
          hi := Domain:-ExtBound[vr_k]:-Min(old_hi, hi);
        end if;

        new_ty := Domain:-ExtBound[vr_k]:-MakeRange(lo,hi);

        subsop([1,i,2]=new_ty, dom);
    end proc;

    local constrain := proc( opts, vn::DomBoundVar, ty::DomBoundRange, mk :: DomBoundKind, $ )
                    :: set({relation, `::`});
        local lo, hi, noi, bt
            , noinf := evalb('no_infinity' in opts)
            , btys  := evalb('bound_types' in opts);
        lo,hi := Domain:-ExtBound[mk]:-SplitRange(ty);
        noi := `if`(noinf,mk->b->if b in {infinity,-infinity} then {} else {mk(b)} end if
                         ,mk->b->{mk(b)} );
        bt  := `if`(btys, { vn :: Domain:-ExtBound[mk]:-BoundType }, {});
        { noi(x->Domain:-ExtBound[mk]:-Constrain( x, vn ))(lo)[]
        , noi(x->Domain:-ExtBound[mk]:-Constrain( vn, x ))(hi)[]
        , bt[]}
    end proc;

    local toConstraints_opts := { 'no_infinity', 'bound_types' };
    export toConstraints := proc( bnd :: DomBound )
        local cs, opts, bad_opts, noinf;
        opts := { args[2..-1] } ;
        bad_opts := opts minus toConstraints_opts;
        if bad_opts <> {} then
            error "invalid arguments: %1", bad_opts;
        end if;
        {op(map(b->constrain(opts, op(b))[], op(1,bnd)))
        ,op( `if`(nops(bnd)>1,op(2,bnd),{}) ) };
    end proc;
end module;#Bound

# Convert Domain to a KB. Very partial, mainly for backwards compatibility
# for parts of the code which still work with KB.
export Bound := module ()
    export toKB := proc(dom :: DomBound, kb0 :: t_kb, $)::[t_kb_mb, list(name=name)];
        local kb := kb0, vs := op(1, dom), rn := []
            , vn, vt, make, lo, hi, vn_rn, rn_t, v ;
        for v in vs do
            vn, vt, make := op(v);
            lo, hi := ExtBound[make]:-SplitRange(vt);
            vn_rn, kb := ExtBound[make]:-MakeKB( vn, lo, hi, kb );
            rn := [ vn=vn_rn, op(rn) ];
        end do;
        [ kb, rn ]
    end proc;

    export varsOf := proc(dom :: DomBound, $)::list(DomBoundVar);
        map(x->op(1,x), op(1, dom));
    end proc;

    export withVarsIxs := proc(dom :: DomBound, $) :: DomBound;
        DBound( op(1..2,dom), table([ seq(op([1,i,1],dom)=i,i=1..nops(op(1,dom))) ]) );
    end proc;

    export varIx := proc(dom0::DomBound, v::DomBoundVar, $)::nonnegint;
        local dom := `if`(nops(dom0)>=3, (_->_), withVarsIxs)(dom0);
        if assigned(op(3,dom)[v]) then
            op(3,dom)[v]
        else
            error "cannot find var %1 in %2", v, dom0;
        end if;
    end proc;

    export isEmpty := proc(dom :: DomBound, $)::truefalse;
        evalb(nops(op(1,dom))=0);
    end proc;

    export get := proc(dom :: DomBound, var :: DomBoundVar, $)
        local th;
        th := select(x->op(1,x)=var, op(1,dom));
        if nops(th) = 1 then
            op([1,2], th), op([1,3], th)
        elif nops(th) = 0 then
            error "cannot find var %1 in %2", var, dom;
        else
            error "multiple references in %1", dom;
        end if;
    end proc;

    export upd := proc(dom0 :: DomBound, vr :: DomBoundVar, ty :: DomBoundRange, $)
        local dom := `if`(nops(dom0)>=3, (_->_), withVarsIxs)(dom0), i
            , old_lo,old_hi, lo,hi, old_ty, new_ty, _, vr_k;
        i := varIx(dom, vr);

        _, old_ty, vr_k := op(op([1,i], dom));
        old_lo,old_hi := Domain:-ExtBound[vr_k]:-SplitRange(old_ty);
        lo, hi        := Domain:-ExtBound[vr_k]:-SplitRange(ty);

        lo := Domain:-ExtBound[vr_k]:-Max(old_lo, lo);
        hi := Domain:-ExtBound[vr_k]:-Min(old_hi, hi);

        new_ty := Domain:-ExtBound[vr_k]:-MakeRange(lo,hi);

        subsop([1,i,2]=new_ty, dom);
    end proc;

    local constrain := proc( opts, vn::DomBoundVar, ty::DomBoundRange, mk :: DomBoundKind, $ )
                    :: set({relation, `::`});
        local lo, hi, noi, bt
            , noinf := evalb('no_infinity' in opts)
            , btys  := evalb('bound_types' in opts);
        lo,hi := Domain:-ExtBound[mk]:-SplitRange(ty);
        noi := `if`(noinf,mk->b->if b in {infinity,-infinity} then {} else {mk(b)} end if
                         ,mk->b->{mk(b)} );
        bt  := `if`(btys, { vn :: Domain:-ExtBound[mk]:-BoundType }, {});
        { noi(x->Domain:-ExtBound[mk]:-Constrain( x, vn ))(lo)[]
        , noi(x->Domain:-ExtBound[mk]:-Constrain( vn, x ))(hi)[]
        , bt[]}
    end proc;

    local toConstraints_opts := { 'no_infinity', 'bound_types' };
    export toConstraints := proc( bnd :: DomBound )
        local cs, opts, bad_opts, noinf;
        opts := { args[2..-1] } ;
        bad_opts := opts minus toConstraints_opts;
        if bad_opts <> {} then
            error "invalid arguments: %1", bad_opts;
        end if;
        {op(map(b->constrain(opts, op(b))[], op(1,bnd)))
        ,op( `if`(nops(bnd)>1,op(2,bnd),{}) ) };
    end proc;
end module;#Bound


More bug fixing

More bug fixing

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

#The outer data structure for a Partition is a function, PARTITION(...), (just like it
#is for piecewise.

Partition:= module()

option package;

#This module is essentially an object, but we decided, for now at least, to not
#use Maple's "option object".

global Piece;

local
   Umap := proc(f,x,$)
       f(op(0,x))( map( p -> Piece(f(condOf(p)),f(valOf(p)))
                      , op(1,x)
                      )
                 )
   end proc,

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

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

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

      TypeTools:-AddType(PartitionCond, {relation, boolean, `::`, specfunc({`And`,`Or`,`Not`}), `and`, `or`, `not`});
      TypeTools:-AddType(PartitionPiece, isPartitionPieceOf);
      TypeTools:-AddType(Partition, isPartitionOf);

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

          r := eval( PartitionToPW(q), eqs );
          if r :: specfunc('piecewise') then
              q := PWToPartition( r , 'do_solve' );
          else
              q := r;
          end if;

          q;

      end proc;

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

      :-`diff/PARTITION` :=
      proc(parts, wrt, $)
          local pw  := PartitionToPW(PARTITION(parts))
              , dpw := diff(pw, wrt)
              , r   := PWToPartition(dpw, 'do_solve' )
              , r0, r1;
            ;
          r0 := Simpl:-singular_pts(r);

          # probably a better way to do this; we really only want to simplify
          # sums and products of integrals and summations
          r1 := subsindets(r0, algebraic, `simplify`);

          userinfo(10, 'disint_trace',
                   printf("  input        : \n\t%a\n\n"
                          "  diff         : \n\t%a\n\n"
                          "  singular pts : \n\t%a\n\n"
                          "  simplified   : \n\t%a\n\n\n"
                          , parts, r, r0, r1 ));

          r1;
      end proc;

      :-`simplify/PARTITION` := Simpl;

      NULL
   end proc,

   ModuleUnload::static:= proc()
      TypeTools:-RemoveType(Partition);
      TypeTools:-RemoveType(PartitionPiece);
      NULL
   end proc,

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

   flatten := proc(ty, x, $)
       if x :: ty then
           { map(a->flatten(ty,a)[],[op(x)])[] };
       else
           {x};
       end if;
   end proc,

   pw_cond_ctx := proc(ctx_, p, $)
       local ps, ctx, ctxN, cond; ps, ctx := op(ctx_); cond := condOf(p);
       cond := flatten({specfunc(`And`), `and`}, cond);
       ctxN := map(KB:-negate_rel,ctx);            # "this context"
       cond := cond minus ctxN;                    # "this cond" minus "context"
       ctx := ctxN union map(KB:-negate_rel,cond); # context and not "this cond"
       cond := `and`(op(cond));
       [ [ op(ps), Piece(cond, valOf(p)) ], ctx ]
   end proc
;
export

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

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

   #This is the exported lazy-syntax constructor. The syntax is like piecewise except
   #that there can be no 'otherwise'.
   ModuleApply::static:= proc(Terms::seq(anything))::Partition;
   local pair, s, Pairs, k;
      if nargs::odd then
         error "Expected an even number of arguments"
      end if;
      s:= [ seq(Piece( Terms[k], Terms[k+1]), k= 1..nargs-1, 2) ] ;
      userinfo(3, PARTITION, s);
      PARTITION(s)
   end proc,

   #Deconstructor that returns just the conditions as a set
   Conditions::static:= proc(P::Partition)::set;
   local p;
      {seq(condOf(p), p= op(1,P))}
   end proc,

   #Deconstructor that returns a set of [cond, val] pairs
   Pairs:= proc(P::Partition)::set([anything, anything]);
   local p;
      {seq([condOf(p), valOf(p)], p= op(1,P)) }
   end proc,

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

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

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

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

   Foldr_mb := proc( cons, nil, prt, $ )
       if prt :: Partition then
           Foldr(_passed);
       else
           cons( true, prt, nil )
       end if;
   end proc,

   PartitionToPW := proc(x::Partition)#::specfunc(piecewise);
       local parts := op(1,x);
       parts := foldl(pw_cond_ctx, [ [], {} ], op(parts) );
       piecewise( op( ListTools[Flatten]( [ seq([condOf(p), valOf(p)], p=op(1,parts)) ] ) ) );
   end proc,

   # convert a piecewise to a partition, which is straightforward except:
   # - if any of the branches are unreachable, they are removed
   # - if the last clause is (implicitly) `otherwise`, that clause is filled in
   #     appropriately

   # note that if the piecewise does not cover the entire domain,
   #   then this Partition will be 'invalid' (in the sense that it also
   #   will not cover the entire domain) - the 'correct' thing to do would
   #   probably be to add a new clause whose value is 'undefined'

   # the logic of this function is already essentially implemented, by KB
   # in fact, kb_piecewise does something extremely similar to this
   PWToPartition := proc(x::specfunc(piecewise))::Partition;

       # each clause evaluated under the context so far,
       # which is the conjunction of the negations of all clauses
       # so far
       local ctx := true, n := nops(x), cls := [], cnd, ncnd, i, q
           , ctxC, cl;
       userinfo(5, PWToPartition
               , printf("PWToPartition: found %d ops in %a \n ", n, x) );
       # handles all but the `otherwise` case if there is such a case
       for i in seq(q, q = 1 .. iquo(n, 2)) do
           userinfo(3, PWToPartition
                    , printf("PWToPartition: looking at clause %d (op %d) \n ", i, 2*i-1));

           cnd := op(2*i-1,x); # the clause as given

           # if this clause is unreachable, then every subsequent clause will be as well
           if ctx :: identical(false) then
               return PARTITION( cls );
           else
               ctxC := `And`(cnd, ctx);              # the condition, along with the context (which is implicit in pw)
               ctxC := Simpl:-condition(ctxC, _rest);

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

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

               userinfo(3, PWToPartition, printf("PWToPartition: ctx after %d clauses "
                                                 "is %a\n", i, ctx));

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

       end do;

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

       if nops(cls) = 0 then
           error "PWToPartition: the piecewise  %1  produced an empty partition\n", x;
       end if;

       PARTITION( cls );
   end proc,

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

   #Check whether the conditions of a Partition depend on any of a set of names.
   ConditionsDepend:= proc(P::Partition, V::{name, list(name), set(name)}, $)
   local p;
      for p in op(1,P) do if depends(condOf(p), V) then return true end if end do;
      false
   end proc,

   Simpl := module()
       export ModuleApply := (single_branch@remove_false_pieces);

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

       export remove_false_pieces := proc(e::Partition, $)
           PARTITION(remove(p -> not(coulditbe(condOf(p))), op(1, e)));
       end proc;

       export single_branch := proc(e::Partition, $)
           if nops(op(1,e)) = 1 then
               op([1,1,2], e)
           else
               e
           end if;
       end proc;

       # Removal of singular points from partitions
       export singular_pts := module()
           # we can simplify the pieces which are equalities and whose LHS or RHS is
           # a name.
           local canSimp := c -> #valOf(c) :: identical('undefined') and
                                 condOf(c) :: `=` and (lhs(condOf(c)) :: name or rhs(condOf(c)) :: name);

           # determines if a given variable `t' has the given upper/lower `bnd'.
           local mentions_t_hi :=
                    t -> bnd -> cl -> has(cl, t<bnd) or has(cl, bnd>t);

           local mentions_t_lo :=
                    t -> bnd -> cl -> has(cl, bnd<t) or has(cl, t>bnd);

           # replace bounds with what we would get if the equality can be
           # integrated into other pieces
           local replace_with := t -> bnd -> x ->
                    if mentions_t_hi(t)(bnd)(x) then
                        t <= bnd
                    elif mentions_t_lo(t)(bnd)(x) then
                        t >= bnd
                    else
                        x
                    end if;

           local set_xor := proc(a,b,$) (a union b) intersect (a minus b) end proc;

           # this loops over the pieces to replace, keeping a state consisting of
           # the "rest" of the pieces
           local tryReplacePieces :=
                   proc(replPieces, otherPieces,cmp,$)
                     local rpp := replPieces, otp := otherPieces, nm, val, rp, rpv;

                     for rp in rpp do
                         rp, rpv := op(rp);

                         nm   := `if`(lhs(rp)::name, lhs(rp), rhs(rp));
                         val  := `if`(lhs(rp)::name, rhs(rp), lhs(rp));

                         otp := tryReplacePiece( nm, val, rpv, otp, cmp )
                     end do;

                     otp;

                   end proc;

           local do_eval_for_cmp := proc(ev, x, $)
              try
                  return ev(x);
              catch "numeric exception: division by zero":
                  # a cheap and dirty way of discovering we have
                  # an expression which is singular at the point
              end try;
              x
           end proc;

           local tryReplacePiece :=
               proc(vrNm, vrVal, pc0val, pcs, eval_cmp,$)
                 local pcs0 := pcs, pcs1, qs0, qs1, qs2, vrEq := vrNm=vrVal, vs2, ret;
                 ret := [ Piece(vrEq, pc0val), op(pcs0) ] ;

                 # speculatively replace the conditions
                 pcs1 := subsindets(pcs0, relation, replace_with(vrNm)(vrVal));

                 # convert to sets and take the "set xor", which will contain
                 # only those elements which are not common to both sets.
                 qs0, qs1 := seq({op(qs)},qs=(pcs0,pcs1));
                 qs2 := set_xor(qs1, qs0);

                 # if we have updated precisely two pieces (an upper and lower bound)
                 if nops(qs2) = 2 then

                     # get the values of those pieces, and the value of the
                     # piece to be replaced, if that isn't undefined
                     vs2 := map(valOf, qs2);
                     if not pc0val :: identical('undefined') then
                         vs2 := { pc0val, op(vs2) };
                     end if;

                     # substitute the equality over the piece values
                     vs2 := map(q -> do_eval_for_cmp(r -> eval_cmp(subs(vrEq, r)), q), vs2);

                     # if they are identically equal, return the original
                     # "guess"
                     if nops(vs2) = 1 then ret := pcs1; end if;
                 end if;

                 ret;

               end proc;

           export ModuleApply := proc(p_,{eval_cmp:='value'},$)

              local p := p_, r := p, uc, oc;

              # if the partition contains case of the form `x = t', where `t' is a
              # constant (or term??) and `x' is a variable, and the value of that
              # case is `undefined', then we may be able to eliminate it (if another
              # case includes that point)
              r := op(1,r);
              uc, oc := selectremove(canSimp, r);

              PARTITION(tryReplacePieces(uc, oc, eval_cmp));

           end proc;

       end module; # singular_pts

       export condition := module()
           local is_extra_sol := x -> (x :: `=` and rhs(x)=lhs(x) and lhs(x) :: name);
           local eval_ctrs := ctx -> eval(ctx, [`And`=`and`, `Not`=`not`]);

           local postproc_for_solve := proc(ctx, ctxSlv)::{identical(false), list({boolean,relation})};
                     local ctxC := ctxSlv;

                     if ctxC = [] then
                         ctxC := false ;

                     elif nops(ctxC)> 1 then
                         ctxC := map(x -> postproc_for_solve(ctx, [x], _rest)[], ctxC);

                     elif nops(ctxC) = 1 then
                         ctxC := op(1,ctxC);

                         if ctxC :: set then
                             ctxC := remove(is_extra_sol, ctxC);

                             if ctxC :: identical('{}') then
                                 ctxC := eval_ctrs(ctx);
                             else
                                 ctxC := `and`(op(ctxC));
                             end if ;

                             ctxC := [ctxC];

                         elif ctxC :: specfunc('piecewise') then
                             ctxC := PWToPartition(ctxC, _rest);

                             ctxC := [ seq( map( o -> condOf(c) and o
                                               , postproc_for_solve(ctx, valOf(c), _rest))[]
                                          , c=op(1, ctxC)
                                          )
                                     ] ;
                         else
                             error "Simpl:-condition: don't know what to do with %1", ctxC;
                         end if;
                     else
                         error "Simpl:-condition: don't know what to do with %1", ctxC;

                     end if;

                     ctxC;

                 end proc;

           export ModuleApply := proc(ctx)::list;
               local ctxC := ctx;

               if ctx :: identical(true) then
                   error "Simpl:-condition: don't know what to do with %1", ctxC;
               end if;

               if 'do_solve' in {_rest} then
                   ctxC := solve({ctxC}, 'useassumptions'=true);
                   if ctxC = NULL and indets(ctxC, specfunc(`exp`)) <> {} then
                       return [ctx];
                   end if;
                   ctxC := postproc_for_solve(ctx, [ctxC], _rest);
                   if indets(ctxC, specfunc({`Or`, `or`})) <> {} then
                       userinfo(10, 'Simpl:-condition',
                           printf("output: \n"
                                  "  %a\n\n"
                                  , ctxC )
                          );
                   end if;
               else
                   ctxC := Domain:-simpl_relation(ctxC, norty='DNF');
                   ctxC := subsindets(ctxC, list, `and`@op);
                   if ctxC :: set then
                       ctxC := [op(ctxC)]
                   else
                       ctxC := [ctxC];
                   end if;
               end if;
               ctxC;
           end proc;
       end module; #Simpl:-condition
   end module, #Simpl

   SamePartition := proc(eqCond, eqPart, $) proc(p0 :: Partition, p1 :: Partition, $)
     local ps0, ps1, pc0, the;
     ps0, ps1 := seq(op(1,p),p=(p0,p1));

     if nops(ps0) <> nops(ps1) then
         return false;
     end if;

     for pc0 in ps0 do
         the, ps1 :=
           selectremove(pc1 -> eqCond( condOf(pc1), condOf(pc0) ) and
                               eqPart( valOf(pc1) , valOf(pc0)  )
                       ,ps1);
         if nops(the) <> 1 then
             return false;
         end if;
     end do;

     true;
   end proc; end proc

;

uses Hakaru;

   ModuleLoad()
end module:

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

#The outer data structure for a Partition is a function, PARTITION(...), (just like it
#is for piecewise.

Partition:= module()

option package;

#This module is essentially an object, but we decided, for now at least, to not
#use Maple's "option object".

global Piece;

local
   Umap := proc(f,x,$)
       f(op(0,x))( map( p -> Piece(f(condOf(p)),f(valOf(p)))
                      , op(1,x)
                      )
                 )
   end proc,

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

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

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

      TypeTools:-AddType(PartitionCond, {relation, boolean, `::`, specfunc({`And`,`Or`,`Not`}), `and`, `or`, `not`});
      TypeTools:-AddType(PartitionPiece, isPartitionPieceOf);
      TypeTools:-AddType(Partition, isPartitionOf);

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

          r := eval( PartitionToPW(q), eqs );
          if r :: specfunc('piecewise') then
              q := PWToPartition( r , 'do_solve' );
          else
              q := r;
          end if;

          q;

      end proc;

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

      :-`diff/PARTITION` :=
      proc(parts, wrt, $)
          local pw  := PartitionToPW(PARTITION(parts))
              , dpw := diff(pw, wrt)
              , r   := PWToPartition(dpw, 'do_solve' )
              , r0, r1;
            ;
          r0 := Simpl:-singular_pts(r);

          # probably a better way to do this; we really only want to simplify
          # sums and products of integrals and summations
          r1 := subsindets(r0, algebraic, `simplify`);

          userinfo(10, 'disint_trace',
                   printf("  input        : \n\t%a\n\n"
                          "  diff         : \n\t%a\n\n"
                          "  singular pts : \n\t%a\n\n"
                          "  simplified   : \n\t%a\n\n\n"
                          , parts, r, r0, r1 ));

          r1;
      end proc;

      :-`simplify/PARTITION` := Simpl;

      NULL
   end proc,

   ModuleUnload::static:= proc()
      TypeTools:-RemoveType(Partition);
      TypeTools:-RemoveType(PartitionPiece);
      NULL
   end proc,

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

   pw_cond_ctx := proc(ctx_, p, $)
       local ps, ctx, ctxN, cond; ps, ctx := op(ctx_); cond := condOf(p);
       if cond :: {specfunc(`And`), `and`} then
           cond := { op(cond) };
       else
           cond := { cond };
       end if;
       ctxN := map(KB:-negate_rel,ctx);
       try cond := remove(x->not(coulditbe(x)), cond) assuming (op(ctxN));
         catch: NULL; end try;
       ctx := ctxN union cond;
       cond := `and`(op(cond));
       [ [ op(ps), Piece(cond, valOf(p)) ], ctx ]
   end proc
;
export

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

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

   #This is the exported lazy-syntax constructor. The syntax is like piecewise except
   #that there can be no 'otherwise'.
   ModuleApply::static:= proc(Terms::seq(anything))::Partition;
   local pair, s, Pairs, k;
      if nargs::odd then
         error "Expected an even number of arguments"
      end if;
      s:= [ seq(Piece( Terms[k], Terms[k+1]), k= 1..nargs-1, 2) ] ;
      userinfo(3, PARTITION, s);
      PARTITION(s)
   end proc,

   #Deconstructor that returns just the conditions as a set
   Conditions::static:= proc(P::Partition)::set;
   local p;
      {seq(condOf(p), p= op(1,P))}
   end proc,

   #Deconstructor that returns a set of [cond, val] pairs
   Pairs:= proc(P::Partition)::set([anything, anything]);
   local p;
      {seq([condOf(p), valOf(p)], p= op(1,P)) }
   end proc,

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

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

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

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

   Foldr_mb := proc( cons, nil, prt, $ )
       if prt :: Partition then
           Foldr(_passed);
       else
           cons( true, prt, nil )
       end if;
   end proc,

   PartitionToPW := proc(x::Partition)#::specfunc(piecewise);
       local parts := op(1,x);
       parts := foldl(pw_cond_ctx, [ [], {} ], op(parts) );
       piecewise( op( ListTools[Flatten]( [ seq([condOf(p), valOf(p)], p=op(1,parts)) ] ) ) );
   end proc,

   # convert a piecewise to a partition, which is straightforward except:
   # - if any of the branches are unreachable, they are removed
   # - if the last clause is (implicitly) `otherwise`, that clause is filled in
   #     appropriately

   # note that if the piecewise does not cover the entire domain,
   #   then this Partition will be 'invalid' (in the sense that it also
   #   will not cover the entire domain) - the 'correct' thing to do would
   #   probably be to add a new clause whose value is 'undefined'

   # the logic of this function is already essentially implemented, by KB
   # in fact, kb_piecewise does something extremely similar to this
   PWToPartition := proc(x::specfunc(piecewise))::Partition;

       # each clause evaluated under the context so far,
       # which is the conjunction of the negations of all clauses
       # so far
       local ctx := true, n := nops(x), cls := [], cnd, ncnd, i, q
           , ctxC, cl;
       userinfo(5, PWToPartition
               , printf("PWToPartition: found %d ops in %a \n ", n, x) );
       # handles all but the `otherwise` case if there is such a case
       for i in seq(q, q = 1 .. iquo(n, 2)) do
           userinfo(3, PWToPartition
                    , printf("PWToPartition: looking at clause %d (op %d) \n ", i, 2*i-1));

           cnd := op(2*i-1,x); # the clause as given

           # if this clause is unreachable, then every subsequent clause will be as well
           if ctx :: identical(false) then
               return PARTITION( cls );
           else
               ctxC := `And`(cnd, ctx);              # the condition, along with the context (which is implicit in pw)
               ctxC := Simpl:-condition(ctxC, _rest);

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

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

               userinfo(3, PWToPartition, printf("PWToPartition: ctx after %d clauses "
                                                 "is %a\n", i, ctx));

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

       end do;

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

       if nops(cls) = 0 then
           error "PWToPartition: the piecewise  %1  produced an empty partition\n", x;
       end if;

       PARTITION( cls );
   end proc,

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

   #Check whether the conditions of a Partition depend on any of a set of names.
   ConditionsDepend:= proc(P::Partition, V::{name, list(name), set(name)}, $)
   local p;
      for p in op(1,P) do if depends(condOf(p), V) then return true end if end do;
      false
   end proc,

   Simpl := module()
       export ModuleApply := (single_branch@remove_false_pieces);

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

       export remove_false_pieces := proc(e::Partition, $)
           PARTITION(remove(p -> not(coulditbe(condOf(p))), op(1, e)));
       end proc;

       export single_branch := proc(e::Partition, $)
           if nops(op(1,e)) = 1 then
               op([1,1,2], e)
           else
               e
           end if;
       end proc;

       # Removal of singular points from partitions
       export singular_pts := module()
           # we can simplify the pieces which are equalities and whose LHS or RHS is
           # a name.
           local canSimp := c -> #valOf(c) :: identical('undefined') and
                                 condOf(c) :: `=` and (lhs(condOf(c)) :: name or rhs(condOf(c)) :: name);

           # determines if a given variable `t' has the given upper/lower `bnd'.
           local mentions_t_hi :=
                    t -> bnd -> cl -> has(cl, t<bnd) or has(cl, bnd>t);

           local mentions_t_lo :=
                    t -> bnd -> cl -> has(cl, bnd<t) or has(cl, t>bnd);

           # replace bounds with what we would get if the equality can be
           # integrated into other pieces
           local replace_with := t -> bnd -> x ->
                    if mentions_t_hi(t)(bnd)(x) then
                        t <= bnd
                    elif mentions_t_lo(t)(bnd)(x) then
                        t >= bnd
                    else
                        x
                    end if;

           local set_xor := proc(a,b,$) (a union b) intersect (a minus b) end proc;

           # this loops over the pieces to replace, keeping a state consisting of
           # the "rest" of the pieces
           local tryReplacePieces :=
                   proc(replPieces, otherPieces,cmp,$)
                     local rpp := replPieces, otp := otherPieces, nm, val, rp, rpv;

                     for rp in rpp do
                         rp, rpv := op(rp);

                         nm   := `if`(lhs(rp)::name, lhs(rp), rhs(rp));
                         val  := `if`(lhs(rp)::name, rhs(rp), lhs(rp));

                         otp := tryReplacePiece( nm, val, rpv, otp, cmp )
                     end do;

                     otp;

                   end proc;

           local do_eval_for_cmp := proc(ev, x, $)
              try
                  return ev(x);
              catch "numeric exception: division by zero":
                  # a cheap and dirty way of discovering we have
                  # an expression which is singular at the point
              end try;
              x
           end proc;

           local tryReplacePiece :=
               proc(vrNm, vrVal, pc0val, pcs, eval_cmp,$)
                 local pcs0 := pcs, pcs1, qs0, qs1, qs2, vrEq := vrNm=vrVal, vs2, ret;
                 ret := [ Piece(vrEq, pc0val), op(pcs0) ] ;

                 # speculatively replace the conditions
                 pcs1 := subsindets(pcs0, relation, replace_with(vrNm)(vrVal));

                 # convert to sets and take the "set xor", which will contain
                 # only those elements which are not common to both sets.
                 qs0, qs1 := seq({op(qs)},qs=(pcs0,pcs1));
                 qs2 := set_xor(qs1, qs0);

                 # if we have updated precisely two pieces (an upper and lower bound)
                 if nops(qs2) = 2 then

                     # get the values of those pieces, and the value of the
                     # piece to be replaced, if that isn't undefined
                     vs2 := map(valOf, qs2);
                     if not pc0val :: identical('undefined') then
                         vs2 := { pc0val, op(vs2) };
                     end if;

                     # substitute the equality over the piece values
                     vs2 := map(q -> do_eval_for_cmp(r -> eval_cmp(subs(vrEq, r)), q), vs2);

                     # if they are identically equal, return the original
                     # "guess"
                     if nops(vs2) = 1 then ret := pcs1; end if;
                 end if;

                 ret;

               end proc;

           export ModuleApply := proc(p_,{eval_cmp:='value'},$)

              local p := p_, r := p, uc, oc;

              # if the partition contains case of the form `x = t', where `t' is a
              # constant (or term??) and `x' is a variable, and the value of that
              # case is `undefined', then we may be able to eliminate it (if another
              # case includes that point)
              r := op(1,r);
              uc, oc := selectremove(canSimp, r);

              PARTITION(tryReplacePieces(uc, oc, eval_cmp));

           end proc;

       end module; # singular_pts

       export condition := module()
           local is_extra_sol := x -> (x :: `=` and rhs(x)=lhs(x) and lhs(x) :: name);
           local eval_ctrs := ctx -> eval(ctx, [`And`=`and`, `Not`=`not`]);

           local postproc_for_solve := proc(ctx, ctxSlv)::{identical(false), list({boolean,relation})};
                     local ctxC := ctxSlv;

                     if ctxC = [] then
                         ctxC := false ;

                     elif nops(ctxC)> 1 then
                         ctxC := map(x -> postproc_for_solve(ctx, [x], _rest)[], ctxC);

                     elif nops(ctxC) = 1 then
                         ctxC := op(1,ctxC);

                         if ctxC :: set then
                             ctxC := remove(is_extra_sol, ctxC);

                             if ctxC :: identical('{}') then
                                 ctxC := eval_ctrs(ctx);
                             else
                                 ctxC := `and`(op(ctxC));
                             end if ;

                             ctxC := [ctxC];

                         elif ctxC :: specfunc('piecewise') then
                             ctxC := PWToPartition(ctxC, _rest);

                             ctxC := [ seq( map( o -> condOf(c) and o
                                               , postproc_for_solve(ctx, valOf(c), _rest))[]
                                          , c=op(1, ctxC)
                                          )
                                     ] ;
                         else
                             error "Simpl:-condition: don't know what to do with %1", ctxC;
                         end if;
                     else
                         error "Simpl:-condition: don't know what to do with %1", ctxC;

                     end if;

                     ctxC;

                 end proc;

           export ModuleApply := proc(ctx)::list;
               local ctxC := ctx;

               if ctx :: identical(true) then
                   error "Simpl:-condition: don't know what to do with %1", ctxC;
               end if;

               if 'do_solve' in {_rest} then
                   ctxC := solve({ctxC}, 'useassumptions'=true);
                   if ctxC = NULL and indets(ctxC, specfunc(`exp`)) <> {} then
                       return [ctx];
                   end if;
                   ctxC := postproc_for_solve(ctx, [ctxC], _rest);
                   if indets(ctxC, specfunc({`Or`, `or`})) <> {} then
                       userinfo(10, 'Simpl:-condition',
                           printf("output: \n"
                                  "  %a\n\n"
                                  , ctxC )
                          );
                   end if;
               else
                   ctxC := Domain:-simpl_relation(ctxC, norty='DNF');
                   ctxC := subsindets(ctxC, list, `and`@op);
                   if ctxC :: set then
                       ctxC := [op(ctxC)]
                   else
                       ctxC := [ctxC];
                   end if;
               end if;
               ctxC;
           end proc;
       end module; #Simpl:-condition
   end module, #Simpl

   SamePartition := proc(eqCond, eqPart, $) proc(p0 :: Partition, p1 :: Partition, $)
     local ps0, ps1, pc0, the;
     ps0, ps1 := seq(op(1,p),p=(p0,p1));

     if nops(ps0) <> nops(ps1) then
         return false;
     end if;

     for pc0 in ps0 do
         the, ps1 :=
           selectremove(pc1 -> eqCond( condOf(pc1), condOf(pc0) ) and
                               eqPart( valOf(pc1) , valOf(pc0)  )
                       ,ps1);
         if nops(the) <> 1 then
             return false;
         end if;
     end do;

     true;
   end proc; end proc

;

uses Hakaru;

   ModuleLoad()
end module: