Don't generate lowercase `and`

Don't generate lowercase `and`

(Cherry-picking 4fe2b02a59005456cafc2aa657b620bfff29ba39 from pw_simp branch)

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

   bool_And := proc()
       if nargs=0 then true
       elif nargs=1 then args[1]
       else `And`(args)
       end if;
   end proc,

   bool_Or := proc()
       if nargs=0 then false
       elif nargs=1 then args[1]
       else `Or`(args)
       end if;
   end proc,

   extr_conjs := proc(x,$)
       if x::{specfunc(`And`), `and`} then
           map(extr_conjs, [op(x)])[];
       else
           x
       end if
   end proc,

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

   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 ;

        expr := foldr( proc(v,e) subsindets(e, op(v)) end proc
                     , expr
                     , [ { specfunc(relation, `Not`), `not`(relation) }
                       , x-> KB:-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->KB:-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;
        map(x -> if not x :: inty then inmk(x) else x end if, expr);
    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_mb := proc(x, $)
       if x :: Partition then PartitionToPW(x) else x end if;
   end proc,

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

   # 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_cps := proc(k)
           local r,p; r, p := single_nonzero_piece(_rest);
           if r :: identical(true) then
               args[2]
           else
               k(r, p);
           end if;
       end proc;

       export single_nonzero_piece := proc(e, { _testzero := Testzero })
           local zs, nzs;
           if e :: Partition then
               zs, nzs := selectremove(p -> _testzero(valOf(p)), 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`=bool_And, `Not`=KB:-negate_rel]);

           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 := bool_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
                       ctxC := FAIL;
                   end if;
               else
                   ctxC := FAIL;
               end if;
               if ctxC = FAIL then
                   error "don't know what to do with %1", ctxSlv;
               else
                   ctxC;
               end if;
           end proc;

           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 := simpl_relation(ctxC, norty='DNF');
                   ctxC := subs(`And`=bool_And, ctxC);
                   if ctxC :: specfunc(`Or`) 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,

   bool_And := proc()
       if nargs=0 then true
       elif nargs=1 then args[1]
       else `And`(args)
       end if;
   end proc,

   bool_Or := proc()
       if nargs=0 then false
       elif nargs=1 then args[1]
       else `Or`(args)
       end if;
   end proc,

   extr_conjs := proc(x,$)
       if x::{specfunc(`And`), `and`} then
           map(extr_conjs, [op(x)])[];
       else
           x
       end if
   end proc,

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

   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 ;

        expr := foldr( proc(v,e) subsindets(e, op(v)) end proc
                     , expr
                     , [ { specfunc(relation, `Not`), `not`(relation) }
                       , x-> KB:-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->KB:-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;
        map(x -> if not x :: inty then inmk(x) else x end if, expr);
    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_mb := proc(x, $)
       if x :: Partition then PartitionToPW(x) else x end if;
   end proc,

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

   # 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_cps := proc(k)
           local r,p; r, p := single_nonzero_piece(_rest);
           if r :: identical(true) then
               args[2]
           else
               k(r, p);
           end if;
       end proc;

       export single_nonzero_piece := proc(e, { _testzero := Testzero })
           local zs, nzs;
           if e :: Partition then
               zs, nzs := selectremove(p -> _testzero(valOf(p)), 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
                       ctxC := FAIL;
                   end if;
               else
                   ctxC := FAIL;
               end if;
               if ctxC = FAIL then
                   error "don't know what to do with %1", ctxSlv;
               else
                   ctxC;
               end if;
           end proc;

           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 := simpl_relation(ctxC, norty='DNF');
                   ctxC := subs(`And`=`and`, ctxC);
                   if ctxC :: specfunc(`Or`) 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:


easy-easy-HMM

easy-easy-HMM

kernelopts(assertlevel=2): # be strict on all assertions while testing
kernelopts(opaquemodules=false): # allow testing of internal routines
read "NewSLO.mpl":

with(NewSLO):

# covers primitive constructs
model1 :=
  Bind(Gaussian(0,1), x,
  Bind(Msum(Ret(0),Weight(1,Lebesgue())), y,
  Ret(1/exp(x^2+y^2)))):

# simplifies to
model1s :=
  Bind(Gaussian(0,1), x,
  Msum(Ret(1/exp(x^2)),
       Bind(Lebesgue(), y,
       Ret(1/exp(x^2+y^2))))):

CodeTools[Test](value(integrate(model1,z->z)), (sqrt(Pi)+1)/sqrt(3), equal,
  label="primitive constructs + integrate + value");

TestHakaru(model1, model1s, label = "primitive constructs simplification");

# Unknown measures -- no changes
u1 := Bind(m, x, Ret(x^2)):
u2 := Bind(Gaussian(0,1), x, m(x)):

TestHakaru(u1, u1, label = "binding unknown m");
TestHakaru(u2, u2, label = "sending to unknown m");

# example with an elaborate simplifier to do reordering of
# integration, which in turn integrates out a variable
model3 := Bind(Gaussian(0,1),x,Gaussian(x,1)):

TestHakaru(model3, Gaussian(0,sqrt(2)),
 simp = (lo -> evalindets(lo, 'specfunc(Int)',
  i -> evalindets(IntegrationTools[CollapseNested](
                  IntegrationTools[Combine](i)), 'Int(anything,list)',
  i -> subsop(0=int, applyop(ListTools[Reverse], 2, i))))),
  label = "use simplifier to integrate out variable");

# Kalman filter; note the parameter + assumption
kalman :=
  Bind(Gaussian(0,1),x,Weight(NewSLO:-density[Gaussian](x,1)(y),Ret(x))):

TestHakaru( kalman,
  Weight(exp(-y^2/4)/2/sqrt(Pi),Gaussian(y/2,1/sqrt(2))),
  label = "Kalman filter") assuming y::real;

# piecewise
model4 :=
  Bind(Gaussian(0,1),x,
  Bind(piecewise(x<0,Ret(0),x>4,Ret(4),Ret(x)),y,
  Ret(y^2))):
model4s := Bind(Gaussian(0,1),x,piecewise(x<0,Ret(0),4<x,Ret(16),Ret(x^2))):

TestHakaru(model4, model4s, label = "piecewise test");

# test with uniform.  No change without simplifier, eliminates it with
# call to value.
introLO :=
  Bind(Uniform(0,1),x,
  Bind(Uniform(0,1),y,
  piecewise(x<y,Ret(true),x>=y,Ret(false)))):
introLOs := Msum(Weight(1/2, Ret(false)), Weight(1/2, Ret(true))):

TestHakaru(introLO, introLO, label = "2 uniform - no change");
TestHakaru(introLO, introLOs, simp = value, label = "2 uniform + value = elimination");

# a variety of other tests
TestHakaru(LO(h,(x*applyintegrand(h,5)+applyintegrand(h,3))/x), Weight(1/x, Msum(Weight(x, Ret(5)), Ret(3))));
TestHakaru(Bind(Gaussian(0,1),x,Weight(x,Msum())), Msum());
TestHakaru(Bind(Uniform(0,1),x,Weight(x^alpha,Ret(x))), Weight(1/(1+alpha),BetaD(1+alpha,1)));
TestHakaru(Bind(Uniform(0,1),x,Weight(x^alpha*(1-x)^beta,Ret(x))), Weight(Beta(1+alpha,1+beta),BetaD(1+alpha,1+beta)));
TestHakaru(Bind(Uniform(0,1),x,Weight((1-x)^beta,Ret(x))), Weight(1/(1+beta),BetaD(1,1+beta)));

# tests that basic densities are properly recognized
TestHakaru(Bind(Uniform(0,1),x,Weight(x*2,Ret(x))), BetaD(2,1));
TestHakaru(BetaD(alpha,beta));
TestHakaru(GammaD(a,b));
TestHakaru(LO(h, int(exp(-x/2)*applyintegrand(h,x),x=0..infinity)), Weight(2,GammaD(1,2)));
TestHakaru(LO(h, int(x*exp(-x/2)*applyintegrand(h,x),x=0..infinity)), Weight(4,GammaD(2,2)));
TestHakaru(Bind(Lebesgue(), x, Weight(1/x^2, Ret(x))));
TestHakaru(Cauchy(loc,scale)) assuming scale>0;

# how far does myint get us?
TestHakaru(
  Bind(Uniform(0,1),x,Weight(x,Ret(Unit))),
  Weight(1/2,Ret(Unit)),
  label = "eliminate Uniform");

# just the front-end is already enough to get this
TestHakaru(
  Bind(Weight(1/2,Ret(Unit)),x,Ret(Unit)),
  Weight(1/2, Ret(Unit)),
  label = "integrate at work");

# and more various
TestHakaru(Bind(Uniform(-1,1),x,Ret(exp(x))));
TestHakaru(IntegrationTools[Expand](LO(h, Int((1+y)*applyintegrand(h,y),y=0..1))), Msum(Uniform(0,1), Weight(1/2,BetaD(2,1))));
TestHakaru(Bind(Uniform(0,1),x,Bind(IntegrationTools[Expand](LO(h, Int((1+y)*applyintegrand(h,y),y=0..1))),y,Ret([x,y]))), Weight(3/2,Bind(Uniform(0,1),x,Msum(Weight(2/3,Bind(Uniform(0,1),y,Ret([x,y]))),Weight(1/3,Bind(BetaD(2,1),y,Ret([x,y])))))));

# easy-easy-HMM
eeHMM := Bind(GammaD(1,1),t,
                 Weight(NewSLO:-density[Gaussian](0,1/sqrt(t))(a),
                 Ret(t))):
ees := Weight(1/(a^2+2)^(3/2), GammaD(3/2, 1/((1/2)*a^2+1))):

TestHakaru(eeHMM, ees, label = "easy-easy-HMM") assuming a :: real;

# and now models (then tests) taken from Tests.RoundTrip
t1 := Bind(Uniform(0, 1), a0, Msum(Weight(a0, Ret(Unit)))):
t2 := BetaD(1,1):
t2s := Bind(Uniform(0, 1), a0, Ret(a0)):
t3 := Gaussian(0,10):
t4 := Bind(BetaD(1, 1), a0,
      Bind(Msum(Weight(a0, Ret(true)),
                Weight((1-a0), Ret(false))), a1,
      Ret(Pair(a0, a1)))):
t4s := Bind(Uniform(0, 1), a0,
       Msum(Weight(a0, Ret(Pair(a0, true))),
            Weight((1+(a0*(-1))), Ret(Pair(a0, false))))):
t5 := Bind(Msum(Weight((1/2), Ret(Unit))), a0, Ret(Unit)):
t5s := Weight((1/2), Ret(Unit)):

t80 := Bind(GammaD(1, 1), a0, Gaussian(0, a0)):

TestHakaru(t1, t5s, label = "t1");
TestHakaru(t2, t2s, label = "t2");
TestHakaru(t3, t3, label = "t3");
TestHakaru(t4, t4s, label = "t4");
TestHakaru(t5, t5s, label = "t5");
TestHakaru(t80, t80, label = "t80");

kernelopts(assertlevel=2): # be strict on all assertions while testing
kernelopts(opaquemodules=false): # allow testing of internal routines
read "NewSLO.mpl":

with(NewSLO):

# covers primitive constructs
model1 :=
  Bind(Gaussian(0,1), x,
  Bind(Msum(Ret(0),Weight(1,Lebesgue())), y,
  Ret(1/exp(x^2+y^2)))):

# simplifies to
model1s :=
  Bind(Gaussian(0,1), x,
  Msum(Ret(1/exp(x^2)),
       Bind(Lebesgue(), y,
       Ret(1/exp(x^2+y^2))))):

CodeTools[Test](value(integrate(model1,z->z)), (sqrt(Pi)+1)/sqrt(3), equal,
  label="primitive constructs + integrate + value");

TestHakaru(model1, model1s, label = "primitive constructs simplification");

# Unknown measures -- no changes
u1 := Bind(m, x, Ret(x^2)):
u2 := Bind(Gaussian(0,1), x, m(x)):

TestHakaru(u1, u1, label = "binding unknown m");
TestHakaru(u2, u2, label = "sending to unknown m");

# example with an elaborate simplifier to do reordering of
# integration, which in turn integrates out a variable
model3 := Bind(Gaussian(0,1),x,Gaussian(x,1)):

TestHakaru(model3, Gaussian(0,sqrt(2)),
 simp = (lo -> evalindets(lo, 'specfunc(Int)',
  i -> evalindets(IntegrationTools[CollapseNested](
                  IntegrationTools[Combine](i)), 'Int(anything,list)',
  i -> subsop(0=int, applyop(ListTools[Reverse], 2, i))))),
  label = "use simplifier to integrate out variable");

# Kalman filter; note the parameter + assumption
kalman :=
  Bind(Gaussian(0,1),x,Weight(NewSLO:-density[Gaussian](x,1)(y),Ret(x))):

TestHakaru( kalman,
  Weight(exp(-y^2/4)/2/sqrt(Pi),Gaussian(y/2,1/sqrt(2))),
  label = "Kalman filter") assuming y::real;

# piecewise
model4 :=
  Bind(Gaussian(0,1),x,
  Bind(piecewise(x<0,Ret(0),x>4,Ret(4),Ret(x)),y,
  Ret(y^2))):
model4s := Bind(Gaussian(0,1),x,piecewise(x<0,Ret(0),4<x,Ret(16),Ret(x^2))):

TestHakaru(model4, model4s, label = "piecewise test");

# test with uniform.  No change without simplifier, eliminates it with
# call to value.
introLO :=
  Bind(Uniform(0,1),x,
  Bind(Uniform(0,1),y,
  piecewise(x<y,Ret(true),x>=y,Ret(false)))):
introLOs := Msum(Weight(1/2, Ret(false)), Weight(1/2, Ret(true))):

TestHakaru(introLO, introLO, label = "2 uniform - no change");
TestHakaru(introLO, introLOs, simp = value, label = "2 uniform + value = elimination");

# a variety of other tests
TestHakaru(LO(h,(x*applyintegrand(h,5)+applyintegrand(h,3))/x), Weight(1/x, Msum(Weight(x, Ret(5)), Ret(3))));
TestHakaru(Bind(Gaussian(0,1),x,Weight(x,Msum())), Msum());
TestHakaru(Bind(Uniform(0,1),x,Weight(x^alpha,Ret(x))), Weight(1/(1+alpha),BetaD(1+alpha,1)));
TestHakaru(Bind(Uniform(0,1),x,Weight(x^alpha*(1-x)^beta,Ret(x))), Weight(Beta(1+alpha,1+beta),BetaD(1+alpha,1+beta)));
TestHakaru(Bind(Uniform(0,1),x,Weight((1-x)^beta,Ret(x))), Weight(1/(1+beta),BetaD(1,1+beta)));

# tests that basic densities are properly recognized
TestHakaru(Bind(Uniform(0,1),x,Weight(x*2,Ret(x))), BetaD(2,1));
TestHakaru(BetaD(alpha,beta));
TestHakaru(GammaD(a,b));
TestHakaru(LO(h, int(exp(-x/2)*applyintegrand(h,x),x=0..infinity)), Weight(2,GammaD(1,2)));
TestHakaru(LO(h, int(x*exp(-x/2)*applyintegrand(h,x),x=0..infinity)), Weight(4,GammaD(2,2)));
TestHakaru(Bind(Lebesgue(), x, Weight(1/x^2, Ret(x))));
TestHakaru(Cauchy(loc,scale)) assuming scale>0;

# how far does myint get us?
TestHakaru(
  Bind(Uniform(0,1),x,Weight(x,Ret(Unit))),
  Weight(1/2,Ret(Unit)),
  label = "eliminate Uniform");

# just the front-end is already enough to get this
TestHakaru(
  Bind(Weight(1/2,Ret(Unit)),x,Ret(Unit)),
  Weight(1/2, Ret(Unit)),
  label = "integrate at work");

# and more various
TestHakaru(Bind(Uniform(-1,1),x,Ret(exp(x))));
TestHakaru(IntegrationTools[Expand](LO(h, Int((1+y)*applyintegrand(h,y),y=0..1))), Msum(Uniform(0,1), Weight(1/2,BetaD(2,1))));
TestHakaru(Bind(Uniform(0,1),x,Bind(IntegrationTools[Expand](LO(h, Int((1+y)*applyintegrand(h,y),y=0..1))),y,Ret([x,y]))), Weight(3/2,Bind(Uniform(0,1),x,Msum(Weight(2/3,Bind(Uniform(0,1),y,Ret([x,y]))),Weight(1/3,Bind(BetaD(2,1),y,Ret([x,y])))))));

# and now models (then tests) taken from Tests.RoundTrip
t1 := Bind(Uniform(0, 1), a0, Msum(Weight(a0, Ret(Unit)))):
t2 := BetaD(1,1):
t2s := Bind(Uniform(0, 1), a0, Ret(a0)):
t3 := Gaussian(0,10):
t4 := Bind(BetaD(1, 1), a0,
      Bind(Msum(Weight(a0, Ret(true)),
                Weight((1-a0), Ret(false))), a1,
      Ret(Pair(a0, a1)))):
t4s := Bind(Uniform(0, 1), a0,
       Msum(Weight(a0, Ret(Pair(a0, true))),
            Weight((1+(a0*(-1))), Ret(Pair(a0, false))))):
t5 := Bind(Msum(Weight((1/2), Ret(Unit))), a0, Ret(Unit)):
t5s := Weight((1/2), Ret(Unit)):

t80 := Bind(GammaD(1, 1), a0, Gaussian(0, a0)):

TestHakaru(t1, t5s, label = "t1");
TestHakaru(t2, t2s, label = "t2");
TestHakaru(t3, t3, label = "t3");
TestHakaru(t4, t4s, label = "t4");
TestHakaru(t5, t5s, label = "t5");
TestHakaru(t80, t80, label = "t80");


Understanding maple syntax...

Understanding maple syntax...

# Wrapper for existing Hakaru test functions,
# to make the output a bit nicer and to (potentially?)
# only collect information about tests without running them
# This is hard because some tests throw Maple errors...
TestWrapper := module ()
  option package;
  export ModuleApply, RunTest, PrintTest, MakeTest
       , RunOpts, args_to_table;
  local TestGroups, ModuleLoad;

  # Only works if numArgs is less than 4...
  PrintTest :=
    proc (testGroup :: string)
    local numArgs;
    numArgs := TestGroups[testGroup]["numArgs"];

    proc (a0::uneval,a1::uneval,a2::uneval,a3::uneval)
      [op(1..numArgs,[_passed])];
    end proc;
  end proc;

  # Runs a test in a group..
  RunTest := proc
    ( testGroup :: string, lbl :: string
    )
    proc ()
      local testixl, res, testProc;
      if RunOpts["DoRun"] then
        testProc := TestGroups[testGroup]["runTest"];
        testixl := nops([indices(TestGroups[testGroup]["tests"])]);

        printf("===BEGIN(%s:%d) %s===\n", testGroup, testixl, lbl);
        res := "SUCCESS";

        try testProc(_passed)
        catch:
          printf("%s\n",
              StringTools:-FormatMessage(lastexception[2 .. -1])
              );
          res := "ERROR";
        finally
          printf("===END(%s:%d) %s ===\n\n", testGroup, testixl, res);
        end try ;

      else
        # lprintf("Printing... %s %s \n", testGroup, lbl);

        # TestGroups[testGroup]["tests"][lbl]();

      end if;
    end proc;
  end proc;

  MakeTest := proc
   ( testProc
   , {testGroup :: string := "(Maple)"}
   , {testArgs :: Or(identical(0),posint) := 2}
   , $
   )
     # Create the test group if needed
     if not assigned(TestGroups[testGroup]) then
        TestGroups[testGroup]["tests"];
        TestGroups[testGroup]["numArgs"] := testArgs;
        TestGroups[testGroup]["runTest"] := testProc;
     end if;

     proc()
        local lbl;

        # Find the test label
        lbl :=
          op([1,2],select(type, [_passed], `=`(identical('label'),'anything')));

        # Print the test and store it
        TestGroups[testGroup]["tests"][lbl] :=
           PrintTest(testGroup)(_passed);

        # Run the test
        RunTest(testGroup,lbl)(_passed);

     end proc;
  end proc;

  ModuleLoad := proc($)
     RunOpts["DoRun"] := true;
  end proc;

  # converts args (as an list of s-expr) to a table, ignoring things not of the form
  #   name = anything
  args_to_table := proc(as)
      local t;
      t :=
        map(q -> subsop(1=sprintf(op(1,q)),q),
          select(type,as, `=`({name, string},anything))
           );
      t := convert(t,table);
      return t;
  end proc;

  # Loads the given module with the given options
  ModuleApply := proc(fn:: string, runOpts:=[]
    )
     # Setup options
     if not is(runOpts,[]) then
         unprotect(`RunOpts`);
         TestWrapper:-RunOpts := args_to_table(runOpts);
         protect(`RunOpts`);
     end if;

     # Read a file containing some tests
     read(fn);

  end proc;

  ModuleLoad();
end module;

# Wrapper for existing Hakaru test functions,
# to make the output a bit nicer and to (potentially?)
# only collect information about tests without running them
# This is hard because some tests throw Maple errors...
TestWrapper := module ()
  option package;
  export ModuleApply, RunTest, PrintTest, MakeTest
       , RunOpts;
  local TestGroups, ModuleLoad;

  # Only works if numArgs is less than 4...
  PrintTest :=
    proc (testGroup :: string)
    local numArgs;
    numArgs := TestGroups[testGroup]['numArgs'];

    proc (a0::uneval,a1::uneval,a2::uneval,a3::uneval)
      op(0..numArgs+1,[_passed]);
    end proc;
  end proc;

  # Runs a test in a group..
  RunTest := proc
    ( testGroup :: string, lbl :: string
    )
    proc ()
      local testixl, res, testProc;
      if RunOpts['DoRun'] then
        testProc := TestGroups[testGroup]['runTest'];
        testixl := nops([indices(TestGroups[testGroup]['tests'])]);

        printf("===BEGIN(%s:%d) %s===\n", testGroup, testixl, lbl);
        res := "SUCCESS";

        try testProc(_passed)
        catch:
          printf("%s\n",
              StringTools:-FormatMessage(lastexception[2 .. -1])
              );
          res := "ERROR";
        finally
          printf("===END(%s:%d) %s ===\n\n", testGroup, testixl, res);
        end try ;

      end if;
    end proc;
  end proc;

  MakeTest := proc
   ( testProc
   , {testGroup :: string := "(Maple)"}
   , {testArgs :: Or('0',posint) := 2}
   , $
   )
     # Create the test group if needed
     if not assigned(TestGroups[testGroup]) then
        TestGroups[testGroup]['tests'];
        TestGroups[testGroup]['numArgs'] := testArgs;
        TestGroups[testGroup]['runTest'] := testProc;
     end if;

     proc()
        local lbl;

        # Find the test label
        lbl :=
          op([1,2],select(type, [_passed], `=`(identical('label'),'anything')));

        # Print the test and store it
        TestGroups[testGroup]['tests'][lbl] :=
           PrintTest(testGroup)(_passed);

        # Run the test
        RunTest(testGroup,lbl)(_passed);

     end proc;
  end proc;

  ModuleLoad := proc($)
     RunOpts['DoRun'] := true;
  end proc;

  # Loads the given module with the given options
  ModuleApply := proc(fn::'string', {runOpts:=[]}
    )
     # Setup options
     if not is(runOpts,[]) then RunOpts := runOpts; end if;

     # Read a file containing some tests
     read(fn);

  end proc;

  ModuleLoad();
end module;


Move elim_intsum

Move elim_intsum

# Step 2 of 3: computer algebra

  improve := proc(lo :: LO(name, anything), {_ctx :: t_kb := empty}, opts := [], $)
  local r, `&context`;
       userinfo(5, improve, "input: ", print(lo &context _ctx));
       r:= LO(op(1,lo), reduce(op(2,lo), op(1,lo), _ctx, opts));
       userinfo(5, improve, "output: ", print(r));
       r
  end proc;

  # Walk through integrals and simplify, recursing through grammar
  # h - name of the linear operator above us
  # kb - domain information
  reduce := proc(ee, h :: name, kb :: t_kb, opts := [], $)
    local e, elim, subintegral, w, ww, x, c, kb1, with_kb1, dom_specw, dom_specb
         , body, dom_spec, ed, mkDom, vars, rr
         , do_domain := evalb( not ( "no_domain" in {op(opts)} ) ) ;
    e := ee;

    if do_domain then
      rr := reduce_Integrals(e, h, kb, opts);
      if rr <> FAIL then return rr end if;
    end if;
    if e :: 'applyintegrand(anything, anything)' then
      map(simplify_assuming, e, kb)
    elif e :: `+` then
      map(reduce, e, h, kb, opts)
    elif e :: `*` then
      (subintegral, w) := selectremove(depends, e, h);
      if subintegral :: `*` then error "Nonlinear integral %1", e end if;
      subintegral := convert(reduce(subintegral, h, kb, opts), 'list', `*`);
      (subintegral, ww) := selectremove(depends, subintegral, h);
      nub_piecewise(simplify_factor_assuming(`*`(w, op(ww)), kb))
        * `*`(op(subintegral));
    elif e :: Or(Partition,t_pw) then
      if e :: t_pw then e := PWToPartition(e); end if;
      e := Partition:-Simpl(e);
      e := kb_Partition(e, kb, simplify_assuming,
                        ((rhs, kb) -> %reduce(rhs, h, kb, opts)));
      e := eval(e, %reduce=reduce);
      # big hammer: simplify knows about bound variables, amongst many
      # other things
      Testzero := x -> evalb(simplify(x) = 0);
      e := PartitionToPW(e);
      e := nub_piecewise(e);
      if ee::Partition and e :: t_pw then
        e := Partition:-PWToPartition(e,'do_solve');
      end if;
      e;
    elif e :: t_case then
      subsop(2=map(proc(b :: Branch(anything, anything))
                     eval(subsop(2='reduce'(op(2,b),x,c,opts),b),
                          {x=h, c=kb})
                   end proc,
                   op(2,e)),
             e);
    elif e :: 'Context(anything, anything)' then
      kb1 := assert(op(1,e), kb);
      # A contradictory `Context' implies anything, so produce 'anything'
      # In particular, 42 :: t_Hakaru = false, so a term under a false
      # assumption should never be inspected in any way.
      if kb1 :: t_not_a_kb then
          return 42
      end if;
      applyop(reduce, 2, e, h, kb1, opts);
    elif e :: 'toLO:-integrate(anything, Integrand(name, anything), list)' then
      x := gensym(op([2,1],e));
      # If we had HType information for op(1,e),
      # then we could use it to tell kb about x.
      subsop(2=Integrand(x, reduce(subs(op([2,1],e)=x, op([2,2],e)), h, kb, opts)), e)
    else
      simplify_assuming(e, kb)
    end if;
  end proc;

  # "Integrals" refers to any types of "integrals" understood by domain (Int,
  # Sum currently)
  reduce_Integrals := module()
    export ModuleApply;

    local
    # The callbacks passed by reduce_Integrals to Domain:-Reduce
      reduce_Integrals_body, reduce_Integrals_into

    # tries to evaluate a RootOf
    , try_eval_Root;

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

    ModuleApply := proc(expr, h, kb, opts, $)
      local rr, elim;
      rr := Domain:-Reduce(expr, kb
        ,curry(reduce_Integrals_into,h)
        ,curry(reduce_Integrals_body,h,opts)
        ,(_->:-DOM_FAIL));

      elim := subsindets(rr, specfunc(ELIMED), x->op(1,x));
      if elim <> rr then rr := reduce(elim,h,kb,opts) end if;
      rr := kb_assuming_mb(Partition:-Simpl)(rr, kb, x->x);

      if has(rr, :-DOM_FAIL) then
        return FAIL;
      elif has(rr, FAIL) then
        error "Something strange happened in reduce_Integral(%a, %a, %a, %a)\n%a"
            , expr, kb, kb, opts, rr;
      end if;
      rr;
    end proc;

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

    # Try to find an eliminate (by evaluation, or simplification) integrals which
    # are free of `applyintegrand`s.
    elim_intsum := module ()
      export ModuleApply := proc(inert0, h :: name, kb :: t_kb, $)
         local ex, un_elim, e1, inert := inert0, done_e := false;
         un_elim := subsindets(inert, specfunc('ELIMED'), x->op(1,x));
         if un_elim <> inert then
           inert := un_elim; done_e := true;
         end if;
         ex := extract_elim(inert, h);
         e1 := apply_elim(h, kb, ex);
         e1 := check_elim(inert, e1);
         if e1 = FAIL then
           `if`(done_e,ELIMED,_->_)(inert)
         else
           ELIMED(e1)
         end if
      end proc;

      local extract_elim := proc(e, h::name, $)
        local t, intapps, var, f, e_k, e_args;
        t := 'applyintegrand'('identical'(h), 'anything');
        intapps := indets(op(1,e), t);
        if intapps = {} then
          return FAIL;
        end if;
        e_k := op(0,e); e_args := op([2..-1],e);
        if Domain:-Has:-Bound(e) then
          var := Domain:-ExtBound[e_k]:-ExtractVar(e_args);
          ASSERT(var::DomBoundVar);
          if var :: list then var := op(1,var) end if;
          if not depends(intapps, var) then
            f := Domain:-ExtBound[e_k]:-EvalInCtx;
          else
            return FAIL;
          end if;
        end if;
        [ op(1,e), f, var, [e_args] ];
      end proc;

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

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

      local do_elim_intsum := proc(kb, f, ee, v::{name,name=anything})
        local w, e, x, g, t, r;
        w, e := op(Domain:-Extract:-Shape(ee));
        w := Domain:-Shape:-toConstraints(w);
        e := piecewise_And(w, e, 0);
        e := f(e,v,_rest,kb);
        x := `if`(v::name, v, lhs(v));
        g := '{sum, sum_assuming, sums}';
        if f in g then
          t := {'identical'(x),
                'identical'(x) = 'Not(range(Not({SymbolicInfinity, undefined})))'};
        else
          g := '{int, int_assuming, ints}';
          t := {'identical'(x),
                'identical'(x) = 'anything'};
          if not f in g then g := {f} end if;
        end if;
        for r in indets(e, 'specfunc'(g)) do
          if 1<nops(r) and op(2,r)::t then return FAIL end if
        end do;
        e
      end proc;
    end module; # elim
  end module; # reduce_Integrals

  int_assuming := proc(e, v::name=anything, kb::t_kb, $)
    simplify_factor_assuming('int'(e, v), kb);
  end proc;

  sum_assuming := proc(e, v::name=anything, kb::t_kb)
    simplify_factor_assuming('sum'(e, v), kb);
  end proc;

  nub_piecewise := proc(pw, $) # pw may or may not be piecewise
    foldr_piecewise(piecewise_if, 0, pw)
  end proc;

  piecewise_if := proc(cond, th, el, $)
    # piecewise_if should be equivalent to `if`, but it produces
    # 'piecewise' and optimizes for when the 3rd argument is 'piecewise'
    if cond = true then
      th
    elif cond = false or Testzero(th - el) then
      el
    elif el :: t_pw then
      if nops(el) >= 2 and Testzero(th - op(2,el)) then
        applyop(Or, 1, el, cond)
      elif nops(el) = 2 then
        piecewise(cond, th, op(el), 0)
      else
        piecewise(cond, th, op(el))
      end if
    elif Testzero(el) then
      piecewise(cond, th)
    else
      piecewise(cond, th, el)
    end if
  end proc;

  # Int( .., var=var_ty ) == var &X var_ty
  isBound_IntSum := kind -> module()
    option record;

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

  # Ints( .., var::name, var_ty::range, dims::list(name=range) ) ==
  #        [ var   , map(lhs,dims) ] :: list(name)  &X
  #        [ var_ty, map(rhs,dims) ] :: list(range)
  isBound_IntsSums := kind -> module()
    option record;

    export MakeKB := proc(vars, lo, hi, kb, $)
      local var, dims, ty, rngs, x, kb1;
      var  := op(1, vars);
      rngs := zip(`..`,lo,hi);
      ty   := op(1, rngs);
      dims := subsop(1=NULL,zip(`=`,vars,rngs));

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

# Step 2 of 3: computer algebra

  improve := proc(lo :: LO(name, anything), {_ctx :: t_kb := empty}, opts := [], $)
  local r, `&context`;
       userinfo(5, improve, "input: ", print(lo &context _ctx));
       r:= LO(op(1,lo), reduce(op(2,lo), op(1,lo), _ctx, opts));
       userinfo(5, improve, "output: ", print(r));
       r
  end proc;

  # Walk through integrals and simplify, recursing through grammar
  # h - name of the linear operator above us
  # kb - domain information
  reduce := proc(ee, h :: name, kb :: t_kb, opts := [], $)
    local e, elim, subintegral, w, ww, x, c, kb1, with_kb1, dom_specw, dom_specb
         , body, dom_spec, ed, mkDom, vars, rr
         , do_domain := evalb( not ( "no_domain" in {op(opts)} ) ) ;
    e := ee;

    if do_domain then
      rr := reduce_Integrals(e, h, kb, opts);
      if rr <> FAIL then return rr end if;
    end if;
    if e :: 'applyintegrand(anything, anything)' then
      map(simplify_assuming, e, kb)
    elif e :: `+` then
      map(reduce, e, h, kb, opts)
    elif e :: `*` then
      (subintegral, w) := selectremove(depends, e, h);
      if subintegral :: `*` then error "Nonlinear integral %1", e end if;
      subintegral := convert(reduce(subintegral, h, kb, opts), 'list', `*`);
      (subintegral, ww) := selectremove(depends, subintegral, h);
      nub_piecewise(simplify_factor_assuming(`*`(w, op(ww)), kb))
        * `*`(op(subintegral));
    elif e :: Or(Partition,t_pw) then
      if e :: t_pw then e := PWToPartition(e); end if;
      e := Partition:-Simpl(e);
      e := kb_Partition(e, kb, simplify_assuming,
                        ((rhs, kb) -> %reduce(rhs, h, kb, opts)));
      e := eval(e, %reduce=reduce);
      # big hammer: simplify knows about bound variables, amongst many
      # other things
      Testzero := x -> evalb(simplify(x) = 0);
      e := PartitionToPW(e);
      e := nub_piecewise(e);
      if ee::Partition and e :: t_pw then
        e := Partition:-PWToPartition(e,'do_solve');
      end if;
      e;
    elif e :: t_case then
      subsop(2=map(proc(b :: Branch(anything, anything))
                     eval(subsop(2='reduce'(op(2,b),x,c,opts),b),
                          {x=h, c=kb})
                   end proc,
                   op(2,e)),
             e);
    elif e :: 'Context(anything, anything)' then
      kb1 := assert(op(1,e), kb);
      # A contradictory `Context' implies anything, so produce 'anything'
      # In particular, 42 :: t_Hakaru = false, so a term under a false
      # assumption should never be inspected in any way.
      if kb1 :: t_not_a_kb then
          return 42
      end if;
      applyop(reduce, 2, e, h, kb1, opts);
    elif e :: 'toLO:-integrate(anything, Integrand(name, anything), list)' then
      x := gensym(op([2,1],e));
      # If we had HType information for op(1,e),
      # then we could use it to tell kb about x.
      subsop(2=Integrand(x, reduce(subs(op([2,1],e)=x, op([2,2],e)), h, kb, opts)), e)
    else
      simplify_assuming(e, kb)
    end if;
  end proc;

  # "Integrals" refers to any types of "integrals" understood by domain (Int,
  # Sum currently)
  reduce_Integrals := module()
    export ModuleApply;

    local
    # The callbacks passed by reduce_Integrals to Domain:-Reduce
      reduce_Integrals_body, reduce_Integrals_into

    # tries to evaluate a RootOf
    , try_eval_Root;

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

    ModuleApply := proc(expr, h, kb, opts, $)
      local rr, elim;
      rr := Domain:-Reduce(expr, kb
        ,curry(reduce_Integrals_into,h)
        ,curry(reduce_Integrals_body,h,opts)
        ,(_->:-DOM_FAIL));

      elim := subsindets(rr, specfunc(ELIMED), x->op(1,x));
      if elim <> rr then rr := reduce(elim,h,kb,opts) end if;
      rr := kb_assuming_mb(Partition:-Simpl)(rr, kb, x->x);

      if has(rr, :-DOM_FAIL) then
        return FAIL;
      elif has(rr, FAIL) then
        error "Something strange happened in reduce_Integral(%a, %a, %a, %a)\n%a"
            , expr, kb, kb, opts, rr;
      end if;
      rr;
    end proc;

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

  int_assuming := proc(e, v::name=anything, kb::t_kb, $)
    simplify_factor_assuming('int'(e, v), kb);
  end proc;

  sum_assuming := proc(e, v::name=anything, kb::t_kb)
    simplify_factor_assuming('sum'(e, v), kb);
  end proc;

  nub_piecewise := proc(pw, $) # pw may or may not be piecewise
    foldr_piecewise(piecewise_if, 0, pw)
  end proc;

  piecewise_if := proc(cond, th, el, $)
    # piecewise_if should be equivalent to `if`, but it produces
    # 'piecewise' and optimizes for when the 3rd argument is 'piecewise'
    if cond = true then
      th
    elif cond = false or Testzero(th - el) then
      el
    elif el :: t_pw then
      if nops(el) >= 2 and Testzero(th - op(2,el)) then
        applyop(Or, 1, el, cond)
      elif nops(el) = 2 then
        piecewise(cond, th, op(el), 0)
      else
        piecewise(cond, th, op(el))
      end if
    elif Testzero(el) then
      piecewise(cond, th)
    else
      piecewise(cond, th, el)
    end if
  end proc;

  # Int( .., var=var_ty ) == var &X var_ty
  isBound_IntSum := kind -> module()
    option record;

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

  # Ints( .., var::name, var_ty::range, dims::list(name=range) ) ==
  #        [ var   , map(lhs,dims) ] :: list(name)  &X
  #        [ var_ty, map(rhs,dims) ] :: list(range)
  isBound_IntsSums := kind -> module()
    option record;

    export MakeKB := proc(vars, lo, hi, kb, $)
      local var, dims, ty, rngs, x, kb1;
      var  := op(1, vars);
      rngs := zip(`..`,lo,hi);
      ty   := op(1, rngs);
      dims := subsop(1=NULL,zip(`=`,vars,rngs));

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

  # Try to find an eliminate (by evaluation, or simplification) integrals which
  # are free of `applyintegrand`s.
  elim_intsum := module ()
    export ModuleApply := proc(inert0, h :: name, kb :: t_kb, $)
       local ex, un_elim, e1, inert := inert0, done_e := false;

       un_elim := subsindets(inert, specfunc('ELIMED'), x->op(1,x));
       if un_elim <> inert then
         inert := un_elim; done_e := true;
       end if;

       ex := extract_elim(inert, h);
       e1 := apply_elim(h, kb, ex);
       e1 := check_elim(inert, e1);
       if e1 = FAIL then
         `if`(done_e,ELIMED,_->_)(inert)
       else
         ELIMED(e1)
       end if
    end proc;

    local extract_elim := proc(e, h::name, $)
      local t, intapps, var, f, e_k, e_args;
      t := 'applyintegrand'('identical'(h), 'anything');
      intapps := indets(op(1,e), t);
      if intapps = {} then
        return FAIL;
      end if;
      e_k := op(0,e); e_args := op([2..-1],e);

      if Domain:-Has:-Bound(e) then
        var := Domain:-ExtBound[e_k]:-ExtractVar(e_args);
        ASSERT(var::DomBoundVar);
        if var :: list then var := op(1,var) end if;

        if not depends(intapps, var) then
          f := Domain:-ExtBound[e_k]:-EvalInCtx;
        else
          return FAIL;
        end if;
      end if;

      [ op(1,e), f, var, [e_args] ];
    end proc;

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

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

    local do_elim_intsum := proc(kb, f, ee, v::{name,name=anything})
      local w, e, x, g, t, r;
      w, e := op(Domain:-Extract:-Shape(ee));
      w := Domain:-Shape:-toConstraints(w);
      e := piecewise_And(w, e, 0);
      e := f(e,v,_rest,kb);
      x := `if`(v::name, v, lhs(v));
      g := '{sum, sum_assuming, sums}';
      if f in g then
        t := {'identical'(x),
              'identical'(x) = 'Not(range(Not({SymbolicInfinity, undefined})))'};
      else
        g := '{int, int_assuming, ints}';
        t := {'identical'(x),
              'identical'(x) = 'anything'};
        if not f in g then g := {f} end if;
      end if;
      for r in indets(e, 'specfunc'(g)) do
        if 1<nops(r) and op(2,r)::t then return FAIL end if
      end do;
      e
    end proc;

  end module;