Evaluating a Partition should not solve the pieces (solving is too often too strong)

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

   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
;
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);
       if nops(parts) = 1 and is(op([1,1],parts)) then return op([1,2], parts) end if;
       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,

   Flatten := module()
     export ModuleApply;
     local unpiece, unpart, unpartProd;

     ModuleApply := proc(pr0, { _with := [ 'Partition', unpart ] } )
       local ty, un_ty, pr1, pr2;
       ty, un_ty := op(_with);

       pr1 := subsindets(pr0, ty, un_ty);
       if pr0 <> pr1 then
         ModuleApply(pr1, _with=[ Or('Partiton',`*`), unpartProd ]);
       else
         pr0
       end if;
     end proc;

     # like Piece, but tries to not be a Piece
     unpiece := proc(c, pr, $)
       if pr :: Partition then
         map(q -> applyop(z->bool_And(z,c),1,q), op(1,pr))[]
       else
         Piece(c, pr)
       end if
     end proc;

     unpart := proc(pr, $)
       if pr :: Partition then
         PARTITION(map(q -> unpiece(condOf(q),valOf(q)), op(1,pr)))
       else
         pr
       end if
     end proc:

     unpartProd := proc(pr, $)
       local ps, ws;
       if pr :: `*` then
         ps, ws := selectremove(q->type(q,Partition), [op(pr)]);
         if nops(ps) = 1 then
           Pmap(x->`*`(op(ws),x), unpartProd(op(1,ps)));
         else
           pr;
         end if;
       else
         unpart(pr);
       end if;
     end proc;
   end module,

   # 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 ctx :: 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 postproc_for_solve := proc(ctx, ctxSlv)
                                    ::{identical(false), list({boolean,relation,specfunc(boolean,And),`and`(boolean)})};
               local ctxC := ctxSlv;
               if ctxC = [] then
                   ctxC := [] ;
               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
                       if ctxC :: identical('{}') then
                           ctxC := NULL;
                       else
                           ctxC := remove(is_extra_sol, ctxC);
                           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(PartitionCond);
               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(ctx, specfunc(`exp`)) <> {} then
                       ctxC := [ctx];
                   else
                       ctxC := postproc_for_solve(ctx, [ctxC], _rest);
                   end if;
                   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 := eval(ctxC,`And`=bool_And);
                   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,

   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
;
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);
       if nops(parts) = 1 and is(op([1,1],parts)) then return op([1,2], parts) end if;
       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,

   Flatten := module()
     export ModuleApply;
     local unpiece, unpart, unpartProd;

     ModuleApply := proc(pr0, { _with := [ 'Partition', unpart ] } )
       local ty, un_ty, pr1, pr2;
       ty, un_ty := op(_with);

       pr1 := subsindets(pr0, ty, un_ty);
       if pr0 <> pr1 then
         ModuleApply(pr1, _with=[ Or('Partiton',`*`), unpartProd ]);
       else
         pr0
       end if;
     end proc;

     # like Piece, but tries to not be a Piece
     unpiece := proc(c, pr, $)
       if pr :: Partition then
         map(q -> applyop(z->bool_And(z,c),1,q), op(1,pr))[]
       else
         Piece(c, pr)
       end if
     end proc;

     unpart := proc(pr, $)
       if pr :: Partition then
         PARTITION(map(q -> unpiece(condOf(q),valOf(q)), op(1,pr)))
       else
         pr
       end if
     end proc:

     unpartProd := proc(pr, $)
       local ps, ws;
       if pr :: `*` then
         ps, ws := selectremove(q->type(q,Partition), [op(pr)]);
         if nops(ps) = 1 then
           Pmap(x->`*`(op(ws),x), unpartProd(op(1,ps)));
         else
           pr;
         end if;
       else
         unpart(pr);
       end if;
     end proc;
   end module,

   # 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 ctx :: 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 postproc_for_solve := proc(ctx, ctxSlv)
                                    ::{identical(false), list({boolean,relation,specfunc(boolean,And),`and`(boolean)})};
               local ctxC := ctxSlv;
               if ctxC = [] then
                   ctxC := [] ;
               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
                       if ctxC :: identical('{}') then
                           ctxC := NULL;
                       else
                           ctxC := remove(is_extra_sol, ctxC);
                           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(PartitionCond);
               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(ctx, specfunc(`exp`)) <> {} then
                       ctxC := [ctx];
                   else
                       ctxC := postproc_for_solve(ctx, [ctxC], _rest);
                   end if;
                   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 := eval(ctxC,`And`=bool_And);
                   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:


Warm nested indexings produced by chill

Warm nested indexings produced by chill

# Date: Thu, 24 Mar 2016 18:55:55 -0400
# From: Chung-chieh Shan <ccshan@indiana.edu>
# To: Jacques Carette <carette@mcmaster.ca>
# Subject: Re: partial implementation
#
# Great, let's say a KB means a set of tuples -- in other words, a n-ary
# relation.  (I'm going to treat all variables as parameters for now.)
# So "empty" means the singleton set containing unit, and "gen*" means
# to increment the dimensionality n by 1, such as taking the Cartesian
# product of a relation with an interval.  And "assert" makes a subset.
#
# [...]  let me define subtraction semantically.  Subtraction means
# coming up with a (hopefully compact) sequence of "gen*" and "assert"
# operations that take you from one KB to another.  Of course, for that
# to be possible, the source KB must be a superset of a projection of the
# destination KB.  (Here by projection I mean in the relational database
# sense.)

KB := module ()
  option package;
  local KB, Introduce, Let, Constrain, t_intro, t_lo, t_hi,
        assert_deny, boolean_if, coalesce_bounds, htype_to_property,
        myexpand_product, chilled, chill, warm,
        ModuleLoad, ModuleUnload;
  export empty, genLebesgue, genType, genLet, assert,
         kb_subtract, simplify_assuming, kb_to_assumptions, kb_to_equations,
         kb_piecewise, range_of_HInt;
  global t_kb;
  uses Hakaru;

  t_intro := 'Introduce(name, specfunc({AlmostEveryReal,HReal,HInt}))';
  t_lo    := 'identical(`>`,`>=`)';
  t_hi    := 'identical(`<`,`<=`)';

  empty := KB();

  genLebesgue := proc(xx::name, lo, hi, kb::t_kb)
    # The value of a variable created using genLebesgue is respected only up to
    # negligible changes
    genType(xx, AlmostEveryReal(Bound(`>`,lo), Bound(`<`,hi)), kb, _rest)
  end proc;

  genType := proc(xx::name, tt::t_type, kb::t_kb)
    # A variable created using genType is a parameter, in the sense that its
    # value is completely respected
    local x, t;
    x := `if`(depends([t,kb,_rest], xx), gensym(xx), xx);
    t := evalindets(tt, identical(Bound(`>` , -infinity),
                                  Bound(`>=`, -infinity),
                                  Bound(`<` ,  infinity),
                                  Bound(`<=`,  infinity)), _->NULL);
    x, KB(Introduce(x, t), op(kb));
  end proc;

  genLet := proc(xx::name, e, kb::t_kb)
    # A let-binding, assigning a known value to a new variable
    local x, t;
    x := `if`(depends([e,kb,_rest], xx), gensym(xx), xx);
    x, KB(Let(x, e), op(kb));
  end proc;

  assert := proc(b, kb::t_kb)
    assert_deny(foldl(eval, b, op(kb_to_equations(kb))), true, kb)
  end proc;

  assert_deny := proc(bb, pol::identical(true,false), kb::t_kb)
    # Add `if`(pol,bb,Not(bb)) to kb and return the resulting KB.
    local as, b, log_b, k, x, rel, e, c, kb1, y;
    if bb = pol then
      # Ignore literal true and Not(false).
      kb
    elif bb :: `if`(pol, '{specfunc(anything, And), `and`}',
                         '{specfunc(anything, Or ), `or` }') then
      foldr(((b,kb) -> assert_deny(b, pol, kb)), kb, op(bb))
    elif bb :: '{specfunc(anything, Not), `not`}' then
      foldr(((b,kb) -> assert_deny(b, not pol, kb)), kb, op(bb))
    else
      as := chill(kb_to_assumptions(kb));
      b := simplify(chill(bb)) assuming op(as);
      # Reduce (in)equality between exp(A) and exp(B) to between A and B.
      do
        try log_b := map(ln, b) assuming op(as); catch: break; end try;
        if length(log_b) < length(b)
           and (andmap(is, log_b, real) assuming op(as)) then
          b := log_b;
        else
          break;
        end if;
      end do;
      b := warm(b);
      # Look through kb for the innermost scope where b makes sense.
      k := select((k -> k :: Introduce(name, anything) and depends(b, op(1,k))),
                  kb);
      if nops(k) > 0 then
        x, k := op(op(1,k));
        # Found the innermost scope where b makes sense.
        if b :: And(relation, Or(anyop(identical(x), freeof(x)),
                                 anyop(freeof(x), identical(x)))) then
          # b is a bound on x, so compare it against the current bound on x.
          # First, express `if`(pol,b,Not(b)) as rel(x,e)
          rel := op(0,b);
          if x = lhs(b) then
            e := rhs(b);
          else#x=rhs(b)
            e := lhs(b);
            rel := subs({`<`=`>`, `<=`=`>=`}, rel);
          end if;
          if not pol then
            rel := subs({`<`=`>=`, `<=`=`>`,
                         `>`=`<=`, `>=`=`<`,
                         `=`=`<>`, `<>`=`=`}, rel);
          end if;
          if k :: 'specfunc(AlmostEveryReal)' then
            rel := subs({`<=`=`<`, `>=`=`>`}, rel);
          end if;
          if rel = `=` then
            # To assert that x=e, it's not enough to supersede the Introduce
            # binding for x with a Let binding.
            kb1 := KB(Bound(x,`=`,e), op(kb));
            # We also need to assert that e is in bounds for x.
            for c in t_lo, t_hi do
              c := [op(map2(subsop, 1=NULL,
                       select(type, kb, Bound(identical(x), c, anything)))),
                    op(select(type, k , Bound(              c, anything)) )];
              if nops(c)>0 then
                kb1 := assert_deny(op([1,1],c)(e,op([1,2],c)), true, kb1)
              end if
            end do;
            return kb1
          end if;
          if rel = `<>` then
            # Refine <> to > or < if possible.
            if   is(x<=chill(e)) assuming op(as) then rel := `<`
            elif is(x>=chill(e)) assuming op(as) then rel := `>`
            else return KB(Constrain(x<>e), op(kb)) end if
          end if;
          # Strengthen strict inequality on integer variable.
          if op(0,k) = HInt then
            if rel = `>` then
              rel := `>=`;
              e := warm(floor(chill(e))+1 assuming op(as))
            elif rel = `<` then
              rel := `<=`;
              e := warm(ceil(chill(e))-1 assuming op(as))
            end if
          end if;
          # Look up the current bound on x, if any.
          c := `if`(rel :: t_lo, t_lo, t_hi);
          c := [op(map2(subsop, 1=NULL,
                   select(type, kb, Bound(identical(x), c, anything)))),
                op(select(type, k , Bound(              c, anything)) )];
          # Compare the new bound rel        (x,e          )
          # against the old bound op([1,1],c)(x,op([1,2],c))
          if e = `if`(rel :: t_lo, -infinity, infinity)
            or nops(c)>0 and (is(rel(y,chill(e))) assuming
                                op([1,1],c)(y,chill(op([1,2],c))),
                                y::htype_to_property(k), op(as)) then
            # The old bound renders the new bound superfluous.
            return kb
          elif nops(c)=0 or (is(op([1,1],c)(y,chill(op([1,2],c)))) assuming
                               rel(y,chill(e)),
                               y::htype_to_property(k), op(as)) then
            # The new bound supersedes the old bound.
            return KB(Bound(x,rel,e), op(kb))
          end if
        else
          # Try to make b about x using convert/piecewise.
          try
            c := convert(piecewise(chill(b), true, false), 'piecewise', x)
              assuming op(as);
            if c :: 'specfunc(boolean, piecewise)' and not has(c, 'RootOf') then
              c := foldr_piecewise(boolean_if, false, warm(c));
              if c <> b then return assert_deny(c, pol, kb) end if
            end if
          catch:
          end try;
        end if
      end if;
      # Normalize `=` and `<>` constraints a bit.
      if not pol then
        # Negate b
        if   b :: `=`  then b := `<>`(op(b))
        elif b :: `<>` then b := `=` (op(b))
        elif b :: `<`  then b := `>=`(op(b))
        elif b :: `<=` then b := `>` (op(b))
        else b := Not(b) end if
      end if;
      if b :: 'anything=name' then b := (rhs(b)=lhs(b)) end if;
      # Add constraint to KB.
      `if`((is(chill(b)) assuming op(as)), kb, KB(Constrain(b), op(kb)))
    end if
  end proc:

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

  kb_subtract := proc(kb::t_kb, kb0::t_kb)
    local cut;
    cut := nops(kb) - nops(kb0);
    if cut < 0 or KB(op(cut+1..-1, kb)) <> kb0 then
      error "%1 is not an extension of %2", kb, kb0;
    end if;
    map(proc(k)
      local x, t;
      if k :: 'Introduce(name, anything)' then
        x, t := op(k);
        if t :: 'specfunc(AlmostEveryReal)' then
          t := [op(t), Bound(`>`, -infinity), Bound(`<`, infinity)];
          [genLebesgue, x,
           op([1,2], select(type, t, Bound(identical(`>`), anything))),
           op([1,2], select(type, t, Bound(identical(`<`), anything)))]
        else
          [genType, x, t]
        end if
      elif k :: 'Let(name, anything)' then
        [genLet, op(k)]
      elif k :: 'Bound(name, anything, anything)' then
        [assert, op(2,k)(op(1,k),op(3,k))]
      elif k :: 'Constrain(anything)' then
        [assert, op(1,k)]
      end if
    end proc, [op(coalesce_bounds(KB(op(1..cut, kb))))])
  end proc;

  coalesce_bounds := proc(kb::t_kb)
    local lo, hi, eq, rest, k, x, t, b, s, r;
    for k in select(type, kb, t_intro) do
      x, t := op(k);
      b, t := selectremove(type, t, Bound(t_lo, anything));
      if nops(b) > 0 then lo[x] := op(1,b) end if;
      b, t := selectremove(type, t, Bound(t_hi, anything));
      if nops(b) > 0 then hi[x] := op(1,b) end if;
      rest[x] := [op(t)];
    end do;
    for k in select(type, kb, Bound(name, identical(`=`), anything)) do
      eq[op(1,k)] := op(3,k);
    end do;
    for k in select(type, kb, Bound(name, t_lo, anything)) do
      lo[op(1,k)] := subsop(1=NULL,k);
    end do;
    for k in select(type, kb, Bound(name, t_hi, anything)) do
      hi[op(1,k)] := subsop(1=NULL,k);
    end do;
    map(proc(k)
      if k :: t_intro then
        x := op(1,k);
        if eq[x] = evaln(eq[x]) then
          subsop(2=op([2,0],k)(op(select(type, [lo[x],hi[x]], specfunc(Bound))),
                               op(rest[x])),
                 k);
        else
          Let(x, eq[x]);
        end if
      elif k :: 'Bound(name, anything, anything)'
           and rest[op(1,k)] :: 'list' then
        NULL;
      else
        k;
      end if;
    end proc, kb);
  end proc;

  simplify_assuming := proc(ee, kb::t_kb)
    local e, as;
    e := foldl(eval, ee, op(kb_to_equations(kb)));
    e := evalindets(e, 'specfunc({%product, product})', myexpand_product);
    e := evalindets(e, 'specfunc(sum)', expand);
    e := chill(e);
    as := chill(kb_to_assumptions(kb));
    try
      e := evalindets(e, {logical,
                          specfunc({And,Or,Not}),
                          specop(algebraic,{`<`,`<=`,`=`,`<>`})},
        proc(b)
          try
            if is(b) assuming op(as) then return true
            elif false = coulditbe(b) assuming op(as) then return false
            end if
          catch:
          end try;
          b
        end proc);
      e := simplify(e) assuming op(as);
    catch "when calling '%1'. Received: 'contradictory assumptions'":
      # We seem to be on an unreachable control path
    end try;
    e := warm(e);
    eval(e, exp = expand @ exp);
  end proc;

  myexpand_product := proc(prod)
    local x, p, body, quantifier;
    (body, quantifier) := op(prod);
    x := op(1, quantifier);
    p := proc(e)
      local ee;
      if e :: 'exp(anything)' then
        ee := expand(op(1,e));
        ee := convert(ee, 'list', `+`);
        `*`(op(map(z -> exp(sum(z, quantifier)), ee)));
      elif e :: ('freeof'(x) ^ 'anything') then
        op(1,e) ^ expand(sum(op(2,e), quantifier))
      elif e :: ('anything' ^ 'freeof'(x)) then
        p(op(1,e)) ^ op(2,e)
      else
        product(e, quantifier)
      end if
    end proc;
    `*`(op(map(p, convert(body, list, `*`))));
  end proc;

  kb_to_assumptions := proc(kb)
    map(proc(k)
      local x;
      if k :: t_intro then
        x := op(1,k);
        (x :: htype_to_property(op(2,k))),
        op(map((b -> op(1,b)(x, op(2,b))), op(2,k)))
      elif k :: 'Let(anything, anything)' then
        `=`(op(k))
      elif k :: 'Bound(anything, anything, anything)' then
        op(2,k)(op(1,k), op(3,k))
      elif k :: 'Constrain(anything)' then
        op(1,k)
      else
        NULL # Maple doesn't understand our other types
      end if
    end proc, [op(coalesce_bounds(kb))])
  end proc;

  kb_to_equations := proc(kb)
    map2(subsop, 0=`=`, [op(select(type, kb, 'Let(name, anything)'))])
  end proc;

  htype_to_property := proc(t::t_type)
    if t :: 'specfunc({AlmostEveryReal, HReal})' then real
    elif t :: 'specfunc(HInt)' then integer
    else TopProp end if
  end proc;

  kb_piecewise := proc(e :: specfunc(piecewise), kb :: t_kb, doIf, doThen)
    local kb1, update, n, i;
    kb1 := kb;
    update := proc(c)
      local kb0;
      kb0 := assert(    c , kb1);
      kb1 := assert(Not(c), kb1); # Mutation!
      kb0
    end proc;
    n := nops(e);
    piecewise(seq(`if`(i::even, doThen(op(i,e), update(op(i-1,e))),
                   `if`(i=n,    doThen(op(i,e), kb1),
                                doIf  (op(i,e), kb1))),
                  i=1..n))
  end proc;

  range_of_HInt := proc(t :: And(specfunc(HInt), t_type))
       op(1, [op(map((b -> `if`(op(1,b)=`>`, floor(op(2,b))+1, op(2,b))),
                     select(type, t, Bound(t_lo,anything)))),
              -infinity])
    .. op(1, [op(map((b -> `if`(op(1,b)=`<`, ceil(op(2,b))-1, op(2,b))),
                     select(type, t, Bound(t_hi,anything)))),
              infinity]);
  end proc;

  # Avoid FAILure modes of the assumption system
  chilled := '{size, idx}';
  chill := e -> subsindets(e, specfunc(chilled), c->op(0,c)[op(c)]);
  warm := e -> subsindets(e, specindex(chilled), c->map(warm, op(0,c)(op(c))));

  ModuleLoad := proc()
    Hakaru; # Make sure the KB module is loaded, for the type t_type
    TypeTools[AddType](t_kb,
      'specfunc({
         Introduce(name, t_type),
         Let(name, anything),
         Bound(name, identical(`<`,`<=`,`>`,`>=`,`=`), anything),
         Constrain({`::`, boolean, `in`, specfunc(anything,{Or,Not})})
       }, KB)');
  end proc;

  ModuleUnload := proc()
    TypeTools[RemoveType](t_kb);
  end proc;

  ModuleLoad();
end module; # KB

# Date: Thu, 24 Mar 2016 18:55:55 -0400
# From: Chung-chieh Shan <ccshan@indiana.edu>
# To: Jacques Carette <carette@mcmaster.ca>
# Subject: Re: partial implementation
#
# Great, let's say a KB means a set of tuples -- in other words, a n-ary
# relation.  (I'm going to treat all variables as parameters for now.)
# So "empty" means the singleton set containing unit, and "gen*" means
# to increment the dimensionality n by 1, such as taking the Cartesian
# product of a relation with an interval.  And "assert" makes a subset.
#
# [...]  let me define subtraction semantically.  Subtraction means
# coming up with a (hopefully compact) sequence of "gen*" and "assert"
# operations that take you from one KB to another.  Of course, for that
# to be possible, the source KB must be a superset of a projection of the
# destination KB.  (Here by projection I mean in the relational database
# sense.)

KB := module ()
  option package;
  local KB, Introduce, Let, Constrain, t_intro, t_lo, t_hi,
        assert_deny, boolean_if, coalesce_bounds, htype_to_property,
        myexpand_product, chilled, chill, warm,
        ModuleLoad, ModuleUnload;
  export empty, genLebesgue, genType, genLet, assert,
         kb_subtract, simplify_assuming, kb_to_assumptions, kb_to_equations,
         kb_piecewise, range_of_HInt;
  global t_kb;
  uses Hakaru;

  t_intro := 'Introduce(name, specfunc({AlmostEveryReal,HReal,HInt}))';
  t_lo    := 'identical(`>`,`>=`)';
  t_hi    := 'identical(`<`,`<=`)';

  empty := KB();

  genLebesgue := proc(xx::name, lo, hi, kb::t_kb)
    # The value of a variable created using genLebesgue is respected only up to
    # negligible changes
    genType(xx, AlmostEveryReal(Bound(`>`,lo), Bound(`<`,hi)), kb, _rest)
  end proc;

  genType := proc(xx::name, tt::t_type, kb::t_kb)
    # A variable created using genType is a parameter, in the sense that its
    # value is completely respected
    local x, t;
    x := `if`(depends([t,kb,_rest], xx), gensym(xx), xx);
    t := evalindets(tt, identical(Bound(`>` , -infinity),
                                  Bound(`>=`, -infinity),
                                  Bound(`<` ,  infinity),
                                  Bound(`<=`,  infinity)), _->NULL);
    x, KB(Introduce(x, t), op(kb));
  end proc;

  genLet := proc(xx::name, e, kb::t_kb)
    # A let-binding, assigning a known value to a new variable
    local x, t;
    x := `if`(depends([e,kb,_rest], xx), gensym(xx), xx);
    x, KB(Let(x, e), op(kb));
  end proc;

  assert := proc(b, kb::t_kb)
    assert_deny(foldl(eval, b, op(kb_to_equations(kb))), true, kb)
  end proc;

  assert_deny := proc(bb, pol::identical(true,false), kb::t_kb)
    # Add `if`(pol,bb,Not(bb)) to kb and return the resulting KB.
    local as, b, log_b, k, x, rel, e, c, kb1, y;
    if bb = pol then
      # Ignore literal true and Not(false).
      kb
    elif bb :: `if`(pol, '{specfunc(anything, And), `and`}',
                         '{specfunc(anything, Or ), `or` }') then
      foldr(((b,kb) -> assert_deny(b, pol, kb)), kb, op(bb))
    elif bb :: '{specfunc(anything, Not), `not`}' then
      foldr(((b,kb) -> assert_deny(b, not pol, kb)), kb, op(bb))
    else
      as := chill(kb_to_assumptions(kb));
      b := simplify(chill(bb)) assuming op(as);
      # Reduce (in)equality between exp(A) and exp(B) to between A and B.
      do
        try log_b := map(ln, b) assuming op(as); catch: break; end try;
        if length(log_b) < length(b)
           and (andmap(is, log_b, real) assuming op(as)) then
          b := log_b;
        else
          break;
        end if;
      end do;
      b := warm(b);
      # Look through kb for the innermost scope where b makes sense.
      k := select((k -> k :: Introduce(name, anything) and depends(b, op(1,k))),
                  kb);
      if nops(k) > 0 then
        x, k := op(op(1,k));
        # Found the innermost scope where b makes sense.
        if b :: And(relation, Or(anyop(identical(x), freeof(x)),
                                 anyop(freeof(x), identical(x)))) then
          # b is a bound on x, so compare it against the current bound on x.
          # First, express `if`(pol,b,Not(b)) as rel(x,e)
          rel := op(0,b);
          if x = lhs(b) then
            e := rhs(b);
          else#x=rhs(b)
            e := lhs(b);
            rel := subs({`<`=`>`, `<=`=`>=`}, rel);
          end if;
          if not pol then
            rel := subs({`<`=`>=`, `<=`=`>`,
                         `>`=`<=`, `>=`=`<`,
                         `=`=`<>`, `<>`=`=`}, rel);
          end if;
          if k :: 'specfunc(AlmostEveryReal)' then
            rel := subs({`<=`=`<`, `>=`=`>`}, rel);
          end if;
          if rel = `=` then
            # To assert that x=e, it's not enough to supersede the Introduce
            # binding for x with a Let binding.
            kb1 := KB(Bound(x,`=`,e), op(kb));
            # We also need to assert that e is in bounds for x.
            for c in t_lo, t_hi do
              c := [op(map2(subsop, 1=NULL,
                       select(type, kb, Bound(identical(x), c, anything)))),
                    op(select(type, k , Bound(              c, anything)) )];
              if nops(c)>0 then
                kb1 := assert_deny(op([1,1],c)(e,op([1,2],c)), true, kb1)
              end if
            end do;
            return kb1
          end if;
          if rel = `<>` then
            # Refine <> to > or < if possible.
            if   is(x<=chill(e)) assuming op(as) then rel := `<`
            elif is(x>=chill(e)) assuming op(as) then rel := `>`
            else return KB(Constrain(x<>e), op(kb)) end if
          end if;
          # Strengthen strict inequality on integer variable.
          if op(0,k) = HInt then
            if rel = `>` then
              rel := `>=`;
              e := warm(floor(chill(e))+1 assuming op(as))
            elif rel = `<` then
              rel := `<=`;
              e := warm(ceil(chill(e))-1 assuming op(as))
            end if
          end if;
          # Look up the current bound on x, if any.
          c := `if`(rel :: t_lo, t_lo, t_hi);
          c := [op(map2(subsop, 1=NULL,
                   select(type, kb, Bound(identical(x), c, anything)))),
                op(select(type, k , Bound(              c, anything)) )];
          # Compare the new bound rel        (x,e          )
          # against the old bound op([1,1],c)(x,op([1,2],c))
          if e = `if`(rel :: t_lo, -infinity, infinity)
            or nops(c)>0 and (is(rel(y,chill(e))) assuming
                                op([1,1],c)(y,chill(op([1,2],c))),
                                y::htype_to_property(k), op(as)) then
            # The old bound renders the new bound superfluous.
            return kb
          elif nops(c)=0 or (is(op([1,1],c)(y,chill(op([1,2],c)))) assuming
                               rel(y,chill(e)),
                               y::htype_to_property(k), op(as)) then
            # The new bound supersedes the old bound.
            return KB(Bound(x,rel,e), op(kb))
          end if
        else
          # Try to make b about x using convert/piecewise.
          try
            c := convert(piecewise(chill(b), true, false), 'piecewise', x)
              assuming op(as);
            if c :: 'specfunc(boolean, piecewise)' and not has(c, 'RootOf') then
              c := foldr_piecewise(boolean_if, false, warm(c));
              if c <> b then return assert_deny(c, pol, kb) end if
            end if
          catch:
          end try;
        end if
      end if;
      # Normalize `=` and `<>` constraints a bit.
      if not pol then
        # Negate b
        if   b :: `=`  then b := `<>`(op(b))
        elif b :: `<>` then b := `=` (op(b))
        elif b :: `<`  then b := `>=`(op(b))
        elif b :: `<=` then b := `>` (op(b))
        else b := Not(b) end if
      end if;
      if b :: 'anything=name' then b := (rhs(b)=lhs(b)) end if;
      # Add constraint to KB.
      `if`((is(chill(b)) assuming op(as)), kb, KB(Constrain(b), op(kb)))
    end if
  end proc:

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

  kb_subtract := proc(kb::t_kb, kb0::t_kb)
    local cut;
    cut := nops(kb) - nops(kb0);
    if cut < 0 or KB(op(cut+1..-1, kb)) <> kb0 then
      error "%1 is not an extension of %2", kb, kb0;
    end if;
    map(proc(k)
      local x, t;
      if k :: 'Introduce(name, anything)' then
        x, t := op(k);
        if t :: 'specfunc(AlmostEveryReal)' then
          t := [op(t), Bound(`>`, -infinity), Bound(`<`, infinity)];
          [genLebesgue, x,
           op([1,2], select(type, t, Bound(identical(`>`), anything))),
           op([1,2], select(type, t, Bound(identical(`<`), anything)))]
        else
          [genType, x, t]
        end if
      elif k :: 'Let(name, anything)' then
        [genLet, op(k)]
      elif k :: 'Bound(name, anything, anything)' then
        [assert, op(2,k)(op(1,k),op(3,k))]
      elif k :: 'Constrain(anything)' then
        [assert, op(1,k)]
      end if
    end proc, [op(coalesce_bounds(KB(op(1..cut, kb))))])
  end proc;

  coalesce_bounds := proc(kb::t_kb)
    local lo, hi, eq, rest, k, x, t, b, s, r;
    for k in select(type, kb, t_intro) do
      x, t := op(k);
      b, t := selectremove(type, t, Bound(t_lo, anything));
      if nops(b) > 0 then lo[x] := op(1,b) end if;
      b, t := selectremove(type, t, Bound(t_hi, anything));
      if nops(b) > 0 then hi[x] := op(1,b) end if;
      rest[x] := [op(t)];
    end do;
    for k in select(type, kb, Bound(name, identical(`=`), anything)) do
      eq[op(1,k)] := op(3,k);
    end do;
    for k in select(type, kb, Bound(name, t_lo, anything)) do
      lo[op(1,k)] := subsop(1=NULL,k);
    end do;
    for k in select(type, kb, Bound(name, t_hi, anything)) do
      hi[op(1,k)] := subsop(1=NULL,k);
    end do;
    map(proc(k)
      if k :: t_intro then
        x := op(1,k);
        if eq[x] = evaln(eq[x]) then
          subsop(2=op([2,0],k)(op(select(type, [lo[x],hi[x]], specfunc(Bound))),
                               op(rest[x])),
                 k);
        else
          Let(x, eq[x]);
        end if
      elif k :: 'Bound(name, anything, anything)'
           and rest[op(1,k)] :: 'list' then
        NULL;
      else
        k;
      end if;
    end proc, kb);
  end proc;

  simplify_assuming := proc(ee, kb::t_kb)
    local e, as;
    e := foldl(eval, ee, op(kb_to_equations(kb)));
    e := evalindets(e, 'specfunc({%product, product})', myexpand_product);
    e := evalindets(e, 'specfunc(sum)', expand);
    e := chill(e);
    as := chill(kb_to_assumptions(kb));
    try
      e := evalindets(e, {logical,
                          specfunc({And,Or,Not}),
                          specop(algebraic,{`<`,`<=`,`=`,`<>`})},
        proc(b)
          try
            if is(b) assuming op(as) then return true
            elif false = coulditbe(b) assuming op(as) then return false
            end if
          catch:
          end try;
          b
        end proc);
      e := simplify(e) assuming op(as);
    catch "when calling '%1'. Received: 'contradictory assumptions'":
      # We seem to be on an unreachable control path
    end try;
    e := warm(e);
    eval(e, exp = expand @ exp);
  end proc;

  myexpand_product := proc(prod)
    local x, p, body, quantifier;
    (body, quantifier) := op(prod);
    x := op(1, quantifier);
    p := proc(e)
      local ee;
      if e :: 'exp(anything)' then
        ee := expand(op(1,e));
        ee := convert(ee, 'list', `+`);
        `*`(op(map(z -> exp(sum(z, quantifier)), ee)));
      elif e :: ('freeof'(x) ^ 'anything') then
        op(1,e) ^ expand(sum(op(2,e), quantifier))
      elif e :: ('anything' ^ 'freeof'(x)) then
        p(op(1,e)) ^ op(2,e)
      else
        product(e, quantifier)
      end if
    end proc;
    `*`(op(map(p, convert(body, list, `*`))));
  end proc;

  kb_to_assumptions := proc(kb)
    map(proc(k)
      local x;
      if k :: t_intro then
        x := op(1,k);
        (x :: htype_to_property(op(2,k))),
        op(map((b -> op(1,b)(x, op(2,b))), op(2,k)))
      elif k :: 'Let(anything, anything)' then
        `=`(op(k))
      elif k :: 'Bound(anything, anything, anything)' then
        op(2,k)(op(1,k), op(3,k))
      elif k :: 'Constrain(anything)' then
        op(1,k)
      else
        NULL # Maple doesn't understand our other types
      end if
    end proc, [op(coalesce_bounds(kb))])
  end proc;

  kb_to_equations := proc(kb)
    map2(subsop, 0=`=`, [op(select(type, kb, 'Let(name, anything)'))])
  end proc;

  htype_to_property := proc(t::t_type)
    if t :: 'specfunc({AlmostEveryReal, HReal})' then real
    elif t :: 'specfunc(HInt)' then integer
    else TopProp end if
  end proc;

  kb_piecewise := proc(e :: specfunc(piecewise), kb :: t_kb, doIf, doThen)
    local kb1, update, n, i;
    kb1 := kb;
    update := proc(c)
      local kb0;
      kb0 := assert(    c , kb1);
      kb1 := assert(Not(c), kb1); # Mutation!
      kb0
    end proc;
    n := nops(e);
    piecewise(seq(`if`(i::even, doThen(op(i,e), update(op(i-1,e))),
                   `if`(i=n,    doThen(op(i,e), kb1),
                                doIf  (op(i,e), kb1))),
                  i=1..n))
  end proc;

  range_of_HInt := proc(t :: And(specfunc(HInt), t_type))
       op(1, [op(map((b -> `if`(op(1,b)=`>`, floor(op(2,b))+1, op(2,b))),
                     select(type, t, Bound(t_lo,anything)))),
              -infinity])
    .. op(1, [op(map((b -> `if`(op(1,b)=`<`, ceil(op(2,b))-1, op(2,b))),
                     select(type, t, Bound(t_hi,anything)))),
              infinity]);
  end proc;

  # Avoid FAILure modes of the assumption system
  chilled := '{size, idx}';
  chill := e -> subsindets(e, specfunc(chilled), c->op(0,c)[op(c)]);
  warm := e -> subsindets(e, specindex(chilled), c->op(0,c)(op(c)));

  ModuleLoad := proc()
    Hakaru; # Make sure the KB module is loaded, for the type t_type
    TypeTools[AddType](t_kb,
      'specfunc({
         Introduce(name, t_type),
         Let(name, anything),
         Bound(name, identical(`<`,`<=`,`>`,`>=`,`=`), anything),
         Constrain({`::`, boolean, `in`, specfunc(anything,{Or,Not})})
       }, KB)');
  end proc;

  ModuleUnload := proc()
    TypeTools[RemoveType](t_kb);
  end proc;

  ModuleLoad();
end module; # KB