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

  # Constructor for Partition pieces
  global Piece;

local
  Umap := proc(f,x,$)
    f(op(0,x))( map( p -> Piece(f(condOf(p)),f(valOf(p))), piecesOf(x) )
              , `if`(nops(x)>1,map(f,[op(2..-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)))' ) or
    type(e, 'PARTITION(list(PartitionPiece(Or(elem_t,PieceRef))),list(elem_t))' );
  end proc,

  TYPES := table(
    [(PieceRef = 'And(specfunc(nonnegint,PieceRef),satisfies(x->nops(x)>0))')
    ,(PartitionCond = '{relation, boolean, `::`, specfunc({`And`,`Or`,`Not`}), `and`, `or`, `not`}')
    ,(PartitionPiece = 'isPartitionPieceOf')
    ,(Partition = 'isPartitionOf')
    ]),

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

    BindingTools:-load_types_from_table(TYPES);

    # global extensions to maple functionality
    :-`eval/PARTITION` :=
    proc(p, eqs, $)
      Umap(x->eval(x,eqs), p);
    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) ), dp(x,);
    # end proc;

    :-`diff/PARTITION` := proc()
      local pw, wrt, dpw, r, r0, r1;
      wrt := args[-1];
      pw := PARTITION(args[1..-2]);
      pw  := PartitionToPW(pw);
      dpw := diff(pw, wrt);
      r   := thismodule:-PWToPartition(dpw, 'do_solve');
      r   := Pmap(simplify, r);
    end proc;

    :-`simplify/PARTITION` := Simpl;

    :-`convert/piecewise` := overload(
      [proc(p::Partition)
         option overload(callseq_only);
         PartitionToPW(Simpl:-stable_order(p));
       end proc, :-`convert/piecewise`]);

    VerifyTools[AddVerification](same_partition = proc(a,b,$) evalb(a=b) or SamePartition((x,y)->evalb(x=y),(x,y)->evalb(x=y),a,b) end proc);

    NULL
  end proc,

  ModuleUnload::static:= proc()
    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;
export
  piecesOf := proc(x, $)
    local ps, rs;
    ps := op(1,x);
    if nops(x)=2 then
      rs := op(2,x);
      ps := map(mapPiece(proc(c0,v0)
                  local c,c1,v,s; c,v := c0,v0; s := (x->x);
                  if v::PieceRef then
                    c1 := is_lhs((s,_)->type(s,name),c);
                    if c1<>FAIL then s := x->subs(c1,x) end if;
                    c, s(op(op(1,v),rs))
                  else
                    c, v
                  end if; end proc), ps );
    elif has(x,PieceRef) then
      error "found piece references (%1) but no table of pieces: %2", indets(x,PieceRef), x
    end if;
    ps;
  end proc,

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

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

  mapPiece := proc(f,$) proc(x::PartitionPiece,$) Piece(f(condOf(x), valOf(x))) end proc; end proc,
  ident := proc() args end proc,
  unPiece := mapPiece(ident),

  # This is an alternate (to PARTITION) constructor for partition, which has the
  # same call convention as piecewise, except there are no implicit cases. if
  # there is an otherwise case, its condition is the conjunction of negations of
  # the other conditions.
  ModuleApply := proc()::Partition;
    local ps, as, ops_r, i;
    if nargs=0 then
      error "empty partition";
    end if;
    ps := [args]; ops_r := iquo(nops(ps),2);
    if nops(ps)::odd then
      ps := [op(1..-2,ps), Not(bool_Or(seq(op(2*i-1,ps),i=1..ops_r))), op(-1,ps)];
      ops_r := ops_r+1;
    end if;
    ps := [seq(Piece(op(2*i-1,ps),op(2*i,ps)),i=1..ops_r)];
    PARTITION(ps);
  end proc,

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

  #This is just `map` for Partitions.
  #Allow additional args, just like `map`
  Pmap::static:= proc(f)::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= piecesOf(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,piecesOf(part)));
  end proc,

  Foldr := proc( cons, nil, prt :: Partition, $ )
    foldr(proc(p, x) cons(condOf(p), valOf(p), x); end proc,nil,op(piecesOf(prt)));
  end proc,
  Foldr_mb := proc(cons,nil,prt)
    Case(Partition, x->Foldr(cons,nil,x), x->cons(true,x,nil))
  end proc,

  PartitionToPW := module()
    export ModuleApply; local pw_cond_ctx;
    ModuleApply := proc(x::Partition, $)
      option remember,system;
      local p, parts := piecesOf(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;

    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
                    , 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;
  end module,
  PartitionToPW_mb := Case(Partition, PartitionToPW, x->x),

  isShape := kind ->
  module()
    option record;

    export MakeCtx := proc(p0,_rec,kb)
      local p := p0, pw, p1, wps, ws, vs, cs, w, ps;
      if kind='piecewise' then
        p := Partition:-PWToPartition(p);
      end if;
      p1 := Partition:-Simpl:-remove_false_pieces(p,kb);
      w, p1 := Partition:-Simpl:-single_nonzero_piece(p1);
      if not w :: identical(true) or p1 <> p then
        [ w, p1 ]
      else
        ps := piecesOf(p);
        wps := map((x->_rec(valOf(x),kb)), ps);
        ws, vs, cs := map2(op, 1, wps), map2(op, 2, wps), map(condOf, ps);
        if nops(vs) > 0 and
          andmap(v->op(1,vs)=v, vs) and
          ormap(a->a<>{}, ws)
        then
          [ `bool_Or`( op( zip(`bool_And`, ws, cs) ) ) , op(1,vs) ];
        else
          [ true, p0 ];
        end if;
      end if;
    end proc;
    export MapleType := `if`(kind=`PARTITION`,'Partition','specfunc(piecewise)');
  end module,

  # Checks if the given Partition is semantically valid, i.e. the conditions are
  # all disjoint. This exploits the property that if each adjacent pair of
  # conditions is pairwise disjoint, then they are all disjoint
  # (i.e. disjointness is transitive).
  IsValid := proc(p::Partition,$)
    option remember, system;
    local i, cs; cs := map(condOf, piecesOf(p));
    for i from 2 to nops(cs) do
      if rel_coulditbe(op(i  ,cs), op(i-1,cs)) or
         rel_coulditbe(op(i-1,cs), op(i  ,cs)) then
        return false; end if;
    end do;
    return true;
  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 := module()
    export ModuleApply := proc(x::specfunc(piecewise),{_kb::t_kb:=KB:-empty})
      option remember, system;
      local p;
      p := semantically_Partition(x);
      if p=FAIL then general(x,_kb,_rest);
      else           p
      end if;
    end proc;

    # A special case in which the piecewise is of the form
    # piecewise(A {<=,<} C_0, V_0, ..,
    #           A {<=,<,=} C_i, V_i, ..,
    #           A {<=,<} C_n, V_n, V_{n+1})
    # Such a piecewise is semantically a Partition, but not syntactically so.
    # Returns FAIL if the piecewise is not of this form
    local semantically_Partition := proc(x::specfunc(piecewise), $)
                                 ::{Partition,identical(FAIL)};
      local ns, cs, i, vs;
      ns := nops(x);
      if ns <= 3 then return FAIL; end if;
      cs[0] := [seq(op(2*i-1, x),i=1..iquo(ns,2))];
      if ormap(c->not(c::relation), cs[0]) then return FAIL; end if;
      if ns::odd then
        # Assuming it is semantically a Partition, construct the otherwise case
        cs[0] := [ cs[0][], negate_rel(cs[0][-1]) ];
      end if;
      # Check if the conditions are of the desired form...
      cs[1] := map(c->classify_relation(c,x->type(x,realcons)),
                   cs[0]);
      if has(cs[1], FAIL)
         # Relations must be in {<,<=,=}
      or ormap(c->not(op(1,c) in { B_LO, B_HI, B_EQ }), cs[1])
         # First and last conditions may not be equalities
      or (op([1,1],c)=B_EQ or op([-1,1],c)=B_EQ)
         # Value branched on must be identical in each condition
      or not(the(map2(op,4,cs[1])))
         # Must be ordered accordingly
      or (cs[1] <> sort(cs[1],key=bnd_key))
      then return FAIL end if;
      # ...they are; build the resulting conditions
      cs[2] := map(negate_rel, cs[0]);
      cs[3] := [ true  , op(1..-2, cs[2]) ];
      cs[4] := [ true$2, op(1..-3, cs[2]) ];
      cs[3] := zip_k(
        proc(x,y,z)
          # No need to take the previous negated condition; it's implied by the
          # equality
          if    x::`=`   then  x
          # Skip over the previous negated condition if it's an inequality; take
          # the one before that instead (and strenghten it, since this condition
          # also includes the negation of the equality)
          elif  y::`<>`  then  bool_And(x, table([`<=`=`<`, `<`=`<`])[op(0,z)](op(z)))
          # General case
          else                 bool_And(x,y)
          end if;
        end proc, cs[0], cs[3], cs[4] );
      # Finally build the Partition
      vs    := [seq(op(2*i, x),i=1..iquo(ns,2)), `if`(ns::odd,op(-1,x),NULL)];
      PARTITION(zip(Piece, cs[3], vs));
    end proc;
    local bnd_key := (x->[op(3,x), table([B_LO, B_EQ, B_HI] =~ [0,1,2])[op(1,x)]]);

    local general := proc(x, kb::t_kb)::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, p;

      # Checks if the piecewise is valid when translated literally to a Partition
      # if so, that Partition can be returned directly. This is not done by
      # default because the check calls `coulditbe' many times which is
      # potentially much more expensive than just building the Partition from
      # scratch. This should only be used when the piecewise comes from a solver
      # which may or may not already return a 'partition', and when it does return
      # a 'partition', the set of conditions is typically so complicated that
      # rebuilding it produces an unwieldy monster (e.g. SemiAlgebraic in the case
      # of e.g. RoundTrip/t62).
      if 'check_valid' in {_rest} then
        p := Partition(op(x));
        if IsValid(p) then return p end if;
      end if;

      # handles all but the `otherwise` case if there is such a case
      for i in seq(q, q = 1 .. iquo(n, 2)) do
        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 := bool_And(cnd, ctx);              # the condition, along with the context (which is implicit in pw)
          ctxC := Simpl:-condition(ctxC, kb, _rest);

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

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

          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, kb, _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
        WARNING("PWToPartition: the piecewise %1 produced an empty partition", x);
        return 0;
      end if;
      PARTITION( cls );
    end proc;
  end module,
  PWToPartition_mb := Case(specfunc(piecewise), PWToPartition, x->x),

  # 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,x::Or(Partition,specfunc(piecewise)),
                      to_opts:=[], from_opts:=[])
    if x::Partition then f(x);
    else
      thismodule:-PartitionToPW(f(PWToPartition(x,op(to_opts))),op(from_opts))
    end if;
  end proc,

  #Check whether the conditions of a Partition satisfy a type (or a proc return
  #truefalse)
  ConditionsSatisfy := proc(P::Partition, test, $)
    local p, ty; ty := `if`(test::type,test,satisfies(test));
    for p in piecesOf(P) do if condOf(p)::ty then return true end if end do;
    false
  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)}, $)
    ConditionsSatisfy(P, x->depends(x,V));
  end proc,

  # The cartesian product of two Partitions
  PProd := proc(p0::Partition,p1::Partition,{_add := `+`})::Partition;
  local ps0, ps1, cs, cs0, rs, rs0, rs1, condOrder;
    # This first part is a special case to handle the subsets of Partitions
    # whose conditions are the same - we can add those directly.
    ps0 := piecesOf(p0); cs0 := map(condOf, ps0);
    condOrder := proc(c)
      # This relies on the fact that integers (numeric types in general) are
      # 'less than' everything else. This sorts the 2nd partition with pieces in
      # common with the 1st coming before other pieces (in the order they appear
      # in the first).
      local i := ListTools:-Search(c, cs0);
      `if`(i=0, c, i);
    end proc;
    ps1 := sort(piecesOf(p1), key=condOrder@condOf);
    # Add those pieces with identical conditions directly; return the rest as a
    # pair of pieces.
    cs := zip(proc(p0,p1)
                if condOf(p0)=condOf(p1) then
                  Piece(condOf(p0),_add(valOf(p0),valOf(p1))) ;
                else [p0,p1];
                end if;
              end proc, ps0,ps1);
    # Extract the pieces already processed above; those not processed are lists
    rs, cs := selectremove(c->type(c,list),cs);
    # Unzip the list of remaining pieces
    rs0, rs1 := map(k->map(r->op(k,r),rs),[1,2])[];
    # The actual cartesian product (of whats left)
    rs := map(r0->map(r1-> Piece( bool_And(condOf(r0),condOf(r1)), _add(valOf(r0),valOf(r1)) )
                      ,rs1)[],rs0);
    PARTITION([op(cs),op(rs)]);
  end proc,

  Simpl := module()
    export ModuleApply := proc()
      local p;
      p := do_Simpl_fin("outer",args);
      p := subsindets[flat](p,Partition,Factor);
    end proc;

    local do_Simpl_fin := proc(io::identical("inner","outer"))
      local k, r; k, r := do_Simpl(_rest)[];
      if io="inner" and r::Partition then
        Pmap(k, r)
      else
        k(r)
      end if;
    end proc;
    local do_Simpl := proc(p)
      option remember, system;
      local ps, qs, qs1, mk, as; as := _rest;
      if p :: Partition then
        [ (x->x),
        foldr((f,x)->f(x,as), p,
              reduce_branches,
              coalesce_equalities,
              remove_false_pieces,
              flatten,
              singular_pts) ];
      elif not hastype(p, Partition) then
        [ (x->x), p ]
      elif assigned(distrib_op_Partition[op(0,p)]) then
        ps := simpl_op_Partition[op(0,p)](p);
        if op(0,p)=op(0,ps) then
          mk := distrib_op_Partition[op(0,ps)];
          ps := [op(ps)];
          ps := map(x->do_Simpl_fin("inner",x,as), ps);
          ps, qs := selectremove_outerPartitions(ps);
          if nops(ps)=0 then
            return [(x->x), mk(op(qs))]
          end if;
          ps := foldr(((a,b)->
                       remove_false_pieces(Partition:-PProd(a,b,_add=mk))),
                      op(ps));
          [ x->mk(op(qs),x), ps ];
        else
          do_Simpl(ps,as);
        end if;
      else
        [ (x->x),
          subsindets(p,{Partition,indices(distrib_op_Partition,nolist)},
                     x->do_Simpl_fin("outer",x,as)) ];
      end if;
    end proc;
    local  simpl_op_Partition := table([`+`=factor,`*`=(x->x)]);
    export distrib_op_Partition := table([`+`=`+`,`*`=`*`]);

    # Selects those list elements which are Partitions, and those which are
    # `applyintegrand' with a Partition argument. In the latter case, the
    # `applyintegrand' is pushed down over the pieces.
    local selectremove_outerPartitions :=
    proc(ps0::list,$)::list(Partition),list;
      local ps, rs;
      ps[1], rs[1] := selectremove(type, ps0, Partition);
      ps[2], rs[2] := selectremove(type, rs[1],
                                   'NewSLO:-applyintegrand'
                                     (anything, Partition));
      ps[2] := map(p->Pmap(x->NewSLO:-applyintegrand(op(1,p),x),op(2,p)),
                   ps[2]);

      map(op, [ps[1],ps[2]]),
      [op(rs[2])] ;
    end proc;

    local Factor := proc(p::Partition)
      local ps, qs, zs, tycands, v, p1;
      ps := piecesOf(p);
      qs, zs := selectremove(x->valOf(x)<>0,ps);
      # Deal with only the simple case of one non-zero piece
      if not (nops(qs)=1 and nops(zs)=1) then return p end if;
      ps := valOf(op(1,ps));
      if not(ps :: factor_op_Partition) then return p end if;
      # Deal only with simple weights
      tycands := [ specfunc(NewSLO:-applyintegrand) ];
      tycands := select(`<>`,map(t -> indets[flat](ps, t), tycands), {});
      # Expect to find exactly one 'atom' type
      if nops(tycands)<>1 then return p end if;
      tycands := op([1,1,0],tycands);

      if ps::`+` then
        v[0] := ps;
        if has(ps, exp) then
          v[0] := convert(v[0], exp);
          v[0], v[1] := selectremove(type, convert(v[0], list, `*`), `+`);
          v[0], v[1] := map(`*`@op, [v[0], v[1]])[];
          v[0] := collect(v[0], tycands);

          v[2] := convert(v[0], exp);
        else
          v[0] := factor(v[0]);
          v[0], v[1] := selectremove(type, convert(v[0], list, `*`), `+`);
          v[0], v[1] := map(`*`@op, [v[0], v[1]])[];
        end if;
      elif ps::`*` then
        v[0] := [op(ps)];
        v[0], v[1] := selectremove(has, v[0], tycands);
        v[0], v[1] := map(`*`@op, [v[0],v[1]])[];
      else error "impossible"; end if;

      p1 := v[1]*subs(ps=v[0], p);
    end proc;
    # TODO: factor for `*` is completely untested
    local factor_op_Partition := {`+`};

    export flatten := module()
      export ModuleApply;
      local unpiece, unpart, flatten_with;

      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',`*`), unpart ]);
        else
          pr0
        end if;
      end proc;

      # like Piece, but tries to not be a Piece
      unpiece := proc(c, pr, $)
        flatten_with(proc(mk_q, ps)
                       map(q -> Piece(bool_And(condOf(q),c),mk_q(valOf(q))), ps)[]
                     end proc,
                     x->Piece(c,x),
                     pr);
      end proc;

      unpart := curry(
        flatten_with,proc(mk_q, ps)
                       PARTITION(map(q -> unpiece(condOf(q),valOf(q)), ps))
                     end proc, x->x);

      flatten_with := proc(rec, fail, pr, $)
      local ps, ws;
        if pr :: Partition then
          ps := piecesOf(pr); ws := [];
        elif pr :: `*` then
          ps, ws := selectremove(q->type(q,Partition), [op(pr)]);
          if nops(ps) = 1 then
            ps := piecesOf(op(1,ps));
          else return fail(pr) end if;
        else
          return fail(pr);
        end if;
        rec(x->`*`(op(ws),x), ps);
      end proc;
    end module;

    # Technically a no-op since Partitions have set semantics, but provides a
    # stable (hopefully) order of pieces, which will matter once the Partition
    # is returned to Haskell; the final condition will be erased (replaced by an
    # 'otherwise') and we would like 1) for that to always be the same one (in
    # case changes to Partition simplification order the pieces slightly
    # differently) and 2) for that to be the most 'complex' one.
    export stable_order := proc(e::Partition)
      # hopefully `sort' is actually a stable sort...
      PARTITION( sort(piecesOf(e),key=condition_complexity@condOf) );
    end proc;

    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)), piecesOf(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, kb := KB:-empty)
      PARTITION(remove(p -> type(KB:-assert(condOf(p), kb), t_not_a_kb), piecesOf(e)));
    end proc;

    local `&on` := proc(f,k,$) proc(a,b,$) f(k(a),k(b)) end proc end proc;
    local condition_complexity := proc(x)
      nops(indets(x,PartitionCond)) + nops(indets(x,specfunc({exp, ln})))
    end proc;

    local try_eval := proc(x,s,$)
      try eval(x,s)
      catch "numeric exception: division by zero": FAIL; end try;
    end proc;

    # Combines pieces whose conditions are of the form `x=A' and (`x<A' or
    # `A<x') and whose values are equal under the evaluation `x=A'
    export coalesce_equalities :=
    proc(e::Partition,{ _testequal := ((a,b) -> Testzero(a-b)) })
      local ps, eqs, rest, p, pcond, pval, pbnds, cand, cands, sb;
      ps := piecesOf(e);
      eqs, rest[0] := selectremove(x->condOf(x)::`=`, ps);
      for p in eqs do
        pcond := condOf(p); pval := valOf(p);
        pbnds := {`<`(op(pcond)), `>`(op(pcond))};
        cands, rest[1] := selectremove(x-> has(condOf(x),pbnds), rest[0]);
        cands, rest[2] := selectremove((x->try_eval(x,pcond)=pval)@valOf, cands);
        if nops(cands) = 0 then
          rest[0] := [ p, op(rest[0]) ];
        elif nops(cands) <= 2 then
          cand := op(1,cands);
          sb := select(b->has(condOf(cand),b), pbnds);
          ASSERT(nops(sb)=1); # assumes that both `x<A' and `x>A' won't appear
                              # in a single condition
          sb := op(1,sb);
          rest[0] :=
          [ applyop(x->subs(sb=`<=`(op(sb)),x), 1, cand),
            `if`(nops(cands)=2, op(2,cands), NULL),
            op(rest[2]), op(rest[1]) ];
        else
          error "should be impossible (invalid Partition?): %1", cands;
        end if;
      end do;
      PARTITION(rest[0]);
    end proc;

    export reduce_branches := proc(e::Partition, kb := KB:-empty, { _testequal := ((a,b) -> Testzero(a-b)) })
      local k, ks, i, ps1, ps; ps := piecesOf(e);
      userinfo(3, :-reduce_branches, printf("Input: %a\n", ps));

      if nops(ps)=1 then return op([1,2],ps); end if;

      # Categorize(group) by equality of piece values
      ps1 := [ListTools:-Categorize(_testequal &on valOf, ps)];
      # unless there are fewer groups than original pieces ...

      ks  := map(nops, ps1); # number of pieces per group

      # build the result
      ps1 := zip((p,k)->
                 Piece(bool_Or(condition(bool_Or(map(condOf,p)[]), kb,
                         `if`(k<>1,
                              ['do_solve', 'do_kb', 'do_check'],
                              ['reduce_conjs', 'do_kb']
                             )[])[]),
                       valOf(op(1,p)))
                 ,ps1, ks);
      userinfo(3, :-reduce_branches, printf("condition: %a\n", ps1));

      # replace the condition of each piece built from many others
      if nops(ps1) < nops(ps) and nops(ps1)>1 then
        for i in select(x->op(1,x)>1,sort(zip(`[]`,ks,[seq(1..nops(ks))]), key=(x->-op(1,x)))) do
          ps1 := piecesOf( replace_piece_cond(PARTITION(ps1), op(2,i)) );
        end do;
      end if;

      return PARTITION(ps1);
    end proc;

    # Replaces a piece (at given index) condition with the logically equivalent
    # one formed from the other pieces.
    export replace_piece_cond := proc(e::Partition, n::integer := -1, failure:=(x->x), cmp_score := [ (x->x), (x->x+1) ], $)
      local p_n, p_n1,ps,cmp; ps := piecesOf(e);
      if abs(n)>nops(ps) then
        error "index out of bound: %1", n;
      elif nops(ps)=1 then
        error "cannot replace in single piece Partition: %1", e
      end if;
      p_n := condOf(op(n, ps));                              # old condition
      p_n1 := Not(bool_Or(map(condOf,subsop(n=NULL,ps))[])); # new condition
      cmp := map(condition_complexity, [p_n1, p_n]);

      # a cheap metric for determining if the new condition is an improvement
      if `<=`(zip(apply, cmp_score, cmp)[]) then
        ps := subsop([n,1]=p_n1, ps);
        PARTITION(ps);
      else
        failure(PARTITION(ps));
      end if;
    end proc;

    # Removal of singular points from partitions
    # works with other things too!
    export singular_pts := module()
      local t_constant := (ns->x->(indets(x,And(name,Not(constant))) minus ns)={});
      local can_remove := proc(ns)
        local t1, t2;
        t1 := satisfies(t_constant(ns));
        t2 := satisfies(n->n in ns);
        'Or'(`=`(t2,{t1,t2}),`=`(t1,t2));
      end proc;

      local weakening := {`<=`=`<`, `>=`=`>`};
      local can_replace := proc(ns)
        local t := satisfies(n->n in ns);
        'And'('specfunc'(map(lhs,weakening)),
              {'anyfunc'('anything',t),'anyfunc'(t,'anything')});
      end proc;
      local do_replace := proc(c)
        table([op(weakening)])[op(0,c)](op(c));
      end proc;

      export ModuleApply := proc(sh, kb::t_kb:=KB:-empty,{_name_cands::list := [] })
        local ns, sh1; sh1 := sh;
        # todo: work with array types as well?
        ns := select(type, [op(kb)], And(KB:-t_kb_Introduce,anyfunc(anything,specfunc(`AlmostEveryReal`))));
        ns := map(curry(op,1), ns);
        ns := { op(ns), op(_name_cands) };
        if ns={} then return sh end if;

        sh1 := subsindets(sh1, can_remove(ns), _->false);
        sh1 := eval(eval(sh1, [`And`=bool_And,`Or`=bool_Or]));
        sh1 := subsindets(sh1, 'specfunc'('specfunc'(map(op,weakening)),Not), bool_Not@op);
        sh1 := subsindets(sh1, can_replace(ns), do_replace);
        subsindets[flat](sh1, Partition, pr->remove_false_pieces(pr,kb));
      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 c, 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);
               # if all the solutions are 'extra', the solution is actually just
               # garbage. Maple can't really tell and doesn't just return the
               # empty set (no solutions) for these cases.
              if ctxC = {} then
                ctxC := ctx;
              else
                ctxC := bool_And(op(ctxC));
              end if;
            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=piecesOf(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;

      # Removes each conjunct if it is true under the assumption of the others
      local do_reduce_conj := proc(x::specfunc(And), $)
        local i;
        if has(x, {idx,size}) then return x end if;

        bool_And(seq(
          `if`((is(op(i,x)) assuming
                op(subsop(i=NULL,[op(x)]))),
               NULL, op(i,x)),
          i=1..nops(x)));
      end proc;

      # For some reason, solve just disregards these sorts of conditions
      # altogether, but not when they appear on their own! e.g.
      #  solve( {a<>b} )       = {a=a,a<>b}
      #  solve( {Not(a<>b)} )  = {a=a,b=b}  -- but should be {..,a=b}
      #  solve( {a=0,b<>1} )   = {a=0,b=b}
      local can_solve := proc(c,$)
        evalb(not hastype(c, '`<>`({name,constant},{name,constant})')
          and not has(c, '{idx, PARTITION, Branch}'));
      end proc;

      export do_condition := proc(ctx, kb::t_kb := KB:-empty)::list(PartitionCond);
        option remember, system;
        local ctxC, ctxC1, ctxC_c, ctxC1_c, t;
        ctxC := ctx;
        if ctx :: identical(true) then
          error "Simpl:-condition: don't know what to do with %1", ctxC;
        end if;
        if 'do_kb' in {_rest} then
          ctxC1 := KB:-kb_subtract( KB:-assert( ctxC, kb ), kb );
          if nops(ctxC1)=1 and op([1,1], ctxC1)=KB:-assert then
            ctxC1 := op([1,2], ctxC1);
            ctxC1_c, ctxC_c := map(condition_complexity, [ctxC1,ctxC])[];
            if ctxC1_c < ctxC_c then
              ctxC := ctxC1;
            end if;
          end if;
        end if;
        if condition_complexity(ctxC)=1 then
          return [ctxC];
        end if;

        ctxC := KB:-chill(ctxC);
        if 'reduce_conjs' in {_rest} then
          ctxC := subsindets(ctxC,specfunc(And),do_reduce_conj)
        elif 'do_solve' in {_rest} and _Env_HakaruSolve<>false and can_solve(ctxC) then
          ctxC1 := solve({ctxC}, 'useassumptions'=true);
          if ctxC1 = ctxC then
            # sometimes solve returns unevaluated which confuses postproc because
            # it expects the typical output of solve
            ctxC := [ctxC];
          elif ctxC1 = NULL and indets(ctx, specfunc(`exp`)) <> {} then
            ctxC := [ctxC];
          else
            ctxC1 := postproc_for_solve(ctxC, [ctxC1], _rest);
            if 'do_check' in {_rest} and condition_complexity(ctxC)>condition_complexity(ctxC1) then
              ctxC := ctxC1;
            end if;
          end if;
          if indets(ctxC, specfunc({`Or`, `or`})) <> {} then
            userinfo(10, 'Simpl:-condition',
                     printf("output: \n"
                            "  %a\n\n"
                            , ctxC ));
          end if;
        else
          ctxC1 := ctxC;
          ctxC := [seq(simpl_relation(ctxC1, norty=t), t=['DNF','CNF'])];
          ctxC := eval(ctxC,`And`=bool_And);
          ctxC := op(1, sort(ctxC, key=condition_complexity));
          if ctxC :: specfunc(`Or`) then
            ctxC := [op(ctxC)]
          else
            ctxC := [ctxC];
          end if;
        end if;
        if 'no_split_disj' in {_rest} then
          ctxC := [ bool_Or(op(ctxC)) ];
        end if;
        ctxC := KB:-warm(ctxC);
        `if`(ctxC::list, ctxC, [ctxC]);
      end proc;

      export ModuleApply := ProfileFn(do_condition, 1);

    end module; #Simpl:-condition
  end module, #Simpl

  SamePartition := proc(eqCond, eqPart, p0 :: Partition, p1 :: Partition, $)
    local ps0, ps1, pc0, the;
    ps0, ps1 := map(piecesOf,[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
;
  uses Hakaru, Utilities;
  ModuleLoad();
end module:


with(DocumentTools):
with(StringTools):

SetProperty("Meter_sian", value, 100):
SetProperty("LogAreaSIAN", value, ""):
SetProperty("LogAreaSE", value, ""):
SetProperty("LogAreaME", value, ""):
SetProperty("GlobalParams1", expression, NULL):
SetProperty("LocalParams1", expression, NULL):
SetProperty("NoIDParams1", expression, NULL):
SetProperty("Bound", expression, NULL):
SetProperty("MultiFunctions", expression, NULL):
SetProperty("SingleFunctions", expression, NULL):
SetProperty("being_refined", caption, ""):

SetProperty("RunningTimeSIAN", value, ""):
SetProperty("RunningTimeMulti", value, ""):
SetProperty("RunningTimeSingle", value, ""):

LogParameters := proc(s, target)
	local logsofar;
	logsofar := DocumentTools:-GetProperty(target, value);
	if logsofar <> "" then
		logsofar := logsofar, "\n";
	end if;
	DocumentTools:-SetProperty(target, value, cat(logsofar,s), 'refresh');
end proc:

ClearLog := proc(target)

		DocumentTools:-SetProperty(target, value, "");

end proc:
ClearLog("Parameters"):

skip_single:= parse(GetProperty("SkipSingle", value)):
computeId:= parse(GetProperty("ComputeId", value)):

simplified_generators := parse(GetProperty("SimplifiedGen", value)):
simplify_bound := parse(GetProperty("Refine", value)):
no_bound:= parse(GetProperty("NoBound", value)):
use_char := parse(GetProperty("use_char", value)):
err := 0:
#try:
	sigma:="":
	sigma:=GetProperty("sigma", value):
	if SearchText("diff", sigma)>0 then
		LogText(sprintf("%q\n", "Using Maple input format"), "LogAreaSIAN"):
		sigma := map(x->parse(x), Split(sigma, ";")):
	else
		LogText(sprintf("Using text-based input format"), "LogAreaSIAN"):
		sigma := Split(sigma, ";"):
		states := map(x->Trim(RegSubs("d([a-zA-Z0-9]+)/dt(.*)" = "\\1", x)), select(x->Search("/dt", x)>0, sigma)):
		state_eqs := select(x->Search("/dt", x)>0, sigma):

		outputs :=  map(x->Trim(Split(x, "=")[1]), select(x-> not Search("/dt", x)>0, sigma)):
		output_eqs := select(x->not Search("/dt", x)>0, sigma):

		state_eqs := map(x->convert(subs({seq(parse(states[i])=parse(cat(states[i],"(t)")), i=1..nops(states))}, parse(x)), string),  state_eqs):
		state_eqs := map(x->parse(RegSubs("d([a-zA-Z0-9]+)/dt(.*)" = "diff(\\1(t), t)\\2", x)), state_eqs):

		output_eqs := map(x->parse(Subs({seq(outputs[i]=cat(outputs[i],"(t)"), i=1..nops(outputs))}, x)), output_eqs):
		output_eqs := map(x->subs({seq(parse(states[i])=parse(cat(states[i],"(t)")), i=1..nops(states))}, x),  output_eqs):

		sigma := [op(state_eqs), op(output_eqs)]:
	end if:
	LogExpression(sprintf("%q \n", sigma), "LogAreaSIAN"):
(*catch:
	SetProperty("LogAreaSIAN", value, "Error parsing system: check syntax"): # LogText(
	err:=1:
	SetProperty("GlobalParams1", expression, SystemParseError("see Logs")):
	SetProperty("LocalParams1", expression,  SystemParseError("see Logs")):
	SetProperty("NoIDParams1", expression, SystemParseError("see Logs")):
	SetProperty("Bound", expression,  SystemParseError("see Logs")):
	SetProperty("MultiFunctions", expression,  SystemParseError("see Logs")):
	SetProperty("SingleFunctions", expression,  SystemParseError("see Logs")):
	SetProperty("Meter_sian", value, 0):
	error "Error parsing system: check syntax":
end try:*)

#try:
	params_to_assess := [seq(parse(expr), expr in StringTools[Split](GetProperty("params", value), ";"))]:
	LogExpression(sprintf("%q \n", params_to_assess), "LogAreaSIAN"):
(*catch:
	SetProperty("LogAreaSIAN", value, "Error Parsing Parameters"): # LogText(
	err:=1:
	SetProperty("GlobalParams1", expression, ParameterParseError("see Logs")):
	SetProperty("LocalParams1", expression,  ParameterParseError("see Logs")):
	SetProperty("NoIDParams1", expression, ParameterParseError("see Logs")):
	SetProperty("Bound", expression,  ParameterParseError("see Logs")):
	SetProperty("MultiFunctions", expression,  ParameterParseError("see Logs")):
	SetProperty("SingleFunctions", expression,  ParameterParseError("see Logs")):
	SetProperty("Meter_sian", value, 0):
	error "Error parsing parameters: check syntax":
end try:*)

#try:
	replicas := parse(GetProperty("replicas", value)):
	if replicas <=1 then
		initial_conditions:= true:
	else
		sigma := GenerateReplica(sigma, replicas):
		initial_conditions:=false:
	end if:

	if nops(params_to_assess)=0 then
		LogText(sprintf("%q\n", "Checking all parameters"), "LogAreaSIAN"):
		params_to_assess := GetParameters(sigma, initial_conditions):
	end if:
	p:=parse(GetProperty("p", value)):

(*catch:
	SetProperty("LogAreaSIAN", value, "SYNTAX ERROR PLEASE CHECK INPUTS"): # LogText(
	err:=1:
	SetProperty("GlobalParams1", expression, Error("see Logs")):
	SetProperty("LocalParams1", expression, Error("see Logs")):
	SetProperty("NoIDParams1", expression, Error("see Logs")):
	SetProperty("Bound", expression, Error("see Logs")):
	SetProperty("MultiFunctions", expression, Error("see Logs")):
	SetProperty("SingleFunctions", expression, Error("see Logs")):
	SetProperty("Meter_sian", value, 0):
end try:*)

if err=0 then
	run_sian := parse(GetProperty("RunSIAN", value)):
	if run_sian then
		SetProperty("GlobalParams1", expression, Running):
		SetProperty("LocalParams1", expression, Running):
		SetProperty("NoIDParams1", expression, Running):
	fi:
	if computeId then
		if not no_bound then
			SetProperty("Bound", expression, Running):
		fi:
		if not skip_single then
			SetProperty("SingleFunctions", expression, Running):
		fi:
		SetProperty("MultiFunctions", expression, Running):
	end if:

	output_targets_multi:=table([log="LogAreaME", multi="MultiFunctions", bound_="Bound", runningtime="RunningTimeMulti", single="SingleFunctions",
					  	    run_single_=run_single, runningtimesingle="RunningTimeSingle"]):
	output_targets_single:=table([log="LogAreaSE", single="SingleFunctions", runningtime="RunningTimeSingle"]):
	output_targets_sian:=table([globalparams="GlobalParams1", localparams= "LocalParams1", noidparams="NoIDParams1",
						   runningtime="RunningTimeSIAN", log="LogAreaSIAN", parameters="Parameters"]):
	bypass_ := parse(GetProperty("bypass", value)):

	count_solutions := parse(GetProperty("printSolutions", value)):

	if run_sian then
		if use_char then
			char := 2^29 -3:
		else
			char := 0:
		end if:
		out_sian := timed_SIAN(sigma,  params_to_assess, 0.99, output_targets_sian, count_solutions, char):
		basis_sian:=out_sian[basis]:
		ordering_sian:=out_sian[varordering]:
		all_other:=out_sian[allvars]:
		identified_params:=select(x->evalb(x in out_sian[parameters]), out_sian[globally]):
		max_perms:= parse(GetProperty("MaxPermutations", value)):
		if bypass_ then
			if nops(identified_params)=nops(out_sian[parameters]) then
				if computeId then
					LogText(sprintf("Bypassing Multi-Experiment check via SIAN"), "LogAreaME"):
				end if:
				computeId:=false;
				se_me_bypass_time := time():
				SetProperty("Bound", value, 1):
				SetProperty("MultiFunctions", value, convert(out_sian[parameters], list)):
				SetProperty("RunningTimeMulti", value, convert(time() - se_me_bypass_time, string), 'refresh'): # time

				if not skip_single then
					LogText(sprintf("Bypassing Single-Experiment check via SIAN"), "LogAreaSE"):
				end if:
				skip_single:=true:
				se_me_bypass_time := time():
				SetProperty("SingleFunctions", value, convert(out_sian[parameters], list)):
				SetProperty("RunningTimeSingle", value, convert(time() - se_me_bypass_time, string), 'refresh'): # time
			fi:
		end if:
	fi:
	if computeId then
		out_multi := timed_Multi(sigma, simplified_generators, no_bound, simplify_bound, max_perms, output_targets_multi):
		generators := convert(out_multi[3],list):
		finish_bypass_multi:=out_multi[2]:
		bound := out_multi[1]: # bound value
		if bound=1  then
			if not skip_single then
				LogText(sprintf("Deterministically bypassing Single-Experiment via Multi-Experiment check, bound from Multi-Experiment = 1"), "LogAreaSE"):
			end if:
			skip_single:=true:
			SetProperty("RunningTimeSingle", value, finish_bypass_multi, 'refresh'): # time
		fi:
		if not skip_single then
			out_single := timed_Single(sigma, output_targets_single):
			if out_single = generators and bound>1 then
				LogText(sprintf("Deterministically overriding Multi-Experiment via Single-Experiment check,\n bound from Multi-Experiment > 1, single- and multi-experiment generators are the same"), "LogAreaSE"):
				SetProperty("MultiFunctions", value, convert(out_single, list)):
				SetProperty("Bound", value, 1):
			fi:
			LogExpression(sprintf("%q %q\n",out_single, generators), "LogAreaSE");
		fi:
	fi:
	SetProperty("Meter_sian", value, 0):
end if:


(*
    所有文件的变量和函数声明
*)

$ifndef _HEADERS_
$define _HEADERS_

# Basic.mpl
export
        d,                              # 导出微分算子，用于生成输入表达式
        setSymbols,                     # 设置输入表达式所含变量
        getSymbols;                     # 获取输入表达式所含变量
local
        SymsHolder,                     # 保留符号信息
        getTransMatAndPDE,              # 获取伴随变换矩阵和偏微分方程
        getInvariants,                  # 根据偏微分方程获取不变量

        `&c`,                           # 交换子运算符
        getKd,                          # 将表达式分解为非线性项并提取系数
        getPmVec,                       # 获取表达式关于给定非线性项集的系数向量
        ans2v,                          # 求解表达式关于基的线性表出

        getPDE;                         # 获取生成不变量的偏微分方程
uses    Pa=`\x26\x50\x61\x72\x74\x69\x61\x6C\x44\x3B`;

# Classifyer.mpl
local
        ClassifyHolder,             # 状态保存器
        getCname,                   # 获取不变量方程中常数项c[k]的名字
        getIeqCode,                 # 获取不变量方程的编号
        getUsolsKey,                # 获取全零方程在usols中的key
        getNewSols,                 # 获取新解
        addSol,                     # 新增解
        reset,                      # 状态重置

        buildInvEqs,                # 构造不变量方程
        genInvariants,              # 产生新的不变量
        subsOeq,                    # 产生新的偏微分方程
        solveInvEqs,                # 求解不变量方程
        solveAllZero,               # 求解全零不变量方程
        fetchRep,                   # 取特解定代表元
        solveTransEq,               # 求解伴随变换方程
        solveRestAllZeroIeqs,       # 求解剩余全零不变量方程
        solveTeq,                   # 指定求解伴随变换方程

        clearConditions,            # 删去与a无关的约束
        eqOfEpsilon,                # 检查是否和epsilon有关
        printDeltas,                # 输出Delta

        ieqsolve,                   # 自定义求解不变量方程
        teqsolve,                   # 自定义求解变换方程

        resolve,                    # 重新分类
        classify;                   # 自动分类
export
        getSols;                    # 获取所有解

# Combine.mpl
export
        rmRep,                      # 删除代表元
        updateRep,                  # 修改代表元
        getReps;                    # 获取排序后的代表元
local
        RepsHolder,                 # 保存reps
        buildReps,                  # 重新计算代表元
        addReps,                    # 新增代表元
        formReps;                   # 建立代表元

# Condition.mpl
local
        findSolutionDomain,         # 求解解的定义域
        classifySolve,              # 分类求解约束
        findDomain,                 # 求解表达式定义域
        findDomainCondtions;        # 求解表达式约束条件

# Fetch.mpl
export  fetchSolRep;                # 取特解
local
        fetchSpecSol,               # 根据方程和约束取特解
        rebuildAndFetch,            # 转化关于c的不等式约束之后，再对约束进行分类
        fetchByCons,                # 求解关于a的约束之后，转化为单边约束，再逐解取特解
        fetchBySingleCons,          # 对于和a有关的约束，采用逐步替换的方法取特解
        isSingleCon,                # 是否是单变量约束
        filtCon,                    # 筛选：自由变量，确定性约束，和c无关的不等式约束，和c有关的不等式约束
        transIeq,                   # 将不等式约束转化为等式约束
        fetchIeq;                   # 最邻近整数方法取特解

# InvSimplify.mpl
local
        simplifyInvariants,             # 化简不变量
        simplifyInvs,                   # 单次化简
        simpleSimplify,                 # 消除不变量的倍数
        myAlgsubs,                      # 解决algsubs对分式进行替换的问题
        dealsubs,                       # 预处理替换表达式
        rmOrd,                          # 简化不变量次数
        getOrd,                         # 获取连乘项的各项幂次
        setOrd,                         # 设置连乘项的各项幂次
        isInv,                          # 检查是否为不变量
        rmK,                            # 删除多项式的倍数
        myGcd,                          # 多个数的gcd
        spAdd,                          # 简化不变量之和
        spMul,                          # 简化不变量之积
        invOrd;                         # 化简分数次数的不变量

# InvOrder.mpl
local   findInvariantsOrder,        # 计算不变量阶数
        findOrder,                  # 计算表达式阶数（不含分母）
        findItemOrder;              # 计算某一项的阶数

# Utils.mpl
local
        sortByComplexity,           # 表达式按照复杂度进行排序
        tappend,                    # 按照集合拓展table键值
        tpop,                       # 提取并删除值
        collectObj,                 # 对象按键值分类
        uniqueObj;                  # 对象按键值唯一化

# Interaction.mpl
export

        canTransform,               # 检查两个代表元之间能否相互转化
        resolveRep,                 # 添加新的RepSol进行求解
        resolveSol,                 # 添加新的InvSol进行求解
        fetchNewRep,                # 获取新的代表元

        summaryReps,                # 简要输出代表元及其成立条件以及不变量方程和变换方程的解
        printRepCon,                # 简要输出代表元及其成立条件
        printSols,                  # 输出所有InvSol
        printReps;                  # 输出所有RepSol
local
        testTransform;              # 检查两个解之间能否相互转化

# Logout.mpl
(*
    输出级别：
        1   输出所有过程
        2   输出关键结果
        3   不输出
*)
export  setLogLevel;                # 设置输出级别
local
        LogLevelHolder,             # 保留logLevel状态
        flog,                       # 对应 print
        flogf;                      # 对应 printf

$endif


# Teach Maple (through depends and eval) about our new binding forms.
# Integrand and LO bind from 1st arg to 2nd arg.

`depends/Integrand` := proc(v, e, x) depends(e, x minus {v}) end proc:
`depends/LO`        := proc(v, e, x) depends(e, x minus {v}) end proc:

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

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

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

NewSLO := module ()
  option package;
  local
        t_sum, t_product,
        mysolve, Shiftop, Diffop, Recognized,
        bind, weight,
        reduce_IntsSums, reduce_Integrals,
        elim_intsum, int_assuming, sum_assuming,
        banish, isBound_IntsSums, isBound_IntSum,
        mk_sym, mk_ary, mk_idx, innermostIntSum, ChangeVarInt, SimplifyKB_,
        ModuleLoad;
  export
     # These first few are smart constructors (for themselves):
         integrate, applyintegrand,
     # while these are "proper functions"
         RoundTrip, Simplify, SimplifyKB,  apply_LO,
         TestSimplify, TestHakaru, TestDisint, Efficient, TestEfficient,
         Concrete,
         toLO, fromLO, improve, reduce,
         density, bounds, unweight,

     # Like simplify_assuming, but also applies `hack_Beta` and `eval_factor`
     # which helps some things simplify.
         simplify_factor_assuming,

         ReparamDetermined, determined, reparam, disint ;
  # these names are not assigned (and should not be).  But they are
  # used as global names, so document that here.
  global LO, Integrand, SumIE, ProductIE;
  uses Hakaru, KB, Loop, Partition, Domain, disint;

  t_sum     := 'specfunc({sum    ,Sum    })';
  t_product := 'specfunc({product,Product})';

$include "NewSLO/Interface.mpl"
$include "NewSLO/To.mpl"
$include "NewSLO/From.mpl"
$include "NewSLO/Banish.mpl"
$include "NewSLO/Improve.mpl"
$include "NewSLO/Disint.mpl"
$include "NewSLO/Reparam.mpl"
$include "NewSLO/Factor.mpl"

  # This is for backwards compatibility; do not use them directly,
  # instead use the symbols exported from inner modules of NewSLO
  `integrate` := toLO:-integrate;
  `unweight`  := fromLO:-unweight;

  apply_LO := proc(e::specfunc(LO),f,$) unapply(op(2,e),op(1,e))(f) end proc;

# An integrand h is either an Integrand (our own binding construct for a
# measurable function to be integrated) or something that can be applied
# (probably proc, which should be applied immediately, or a generated symbol).
  applyintegrand := proc(h, x, $)
    local var, body, dummy;
    if h :: 'Integrand(name, anything)' then
      var, body := op(h);
      if x :: {boolean, specfunc({And,Or,Not})} then
        body := eval(body, var=dummy);
        var  := dummy;
        body := subs((var=true)=var, body);
      end if;
      eval(body, var=x)
    elif h :: appliable then
      h(x)
    else
      'procname(_passed)'
    end if
  end proc;

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

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

  ###
  # smart constructors for our language

  bind := proc(m, x, n, $)
    if n = 'Ret'(x) then
      m # monad law: right identity
    elif m :: 'Ret(anything)' then
      eval(n, x = op(1,m)) # monad law: left identity
    else
      'Bind(_passed)'
    end if;
  end proc;

  weight := proc(p, m, $)
    #Trying to make the below into an ASSERT statement results in a kernel
    #crash, even though the condition is caught, the message printed, and
    #the error generated.
    if kernelopts(assertlevel) > 0 then
         if not p::
              (complexcons &implies ((numeric &implies {0,1}) &under csgn))
         then
              userinfo(
                   1, SLO,
                   proc()
                   uses LL= ListTools:-LengthSplit;
                   local
                        S:= Matrix([LL(debugopts(callstack)[2..], 3)]),
                        rts:= interface(rtablesize= infinity)
                   ;
                        print(S);
                        interface(rtablesize= rts);
                        NULL
                   end proc()
              );
              error "Negative weight %1 not allowed", p
         end if
    end if;
    if p = 1 then
      m
    elif p = 0 then
      Msum()
    elif m :: 'Weight(anything, anything)' then
      weight(p * op(1,m), op(2,m))
    else
      'Weight(_passed)'
    end if;
  end proc;

  density[Lebesgue] := proc(lo,hi,$) proc(x,$) 1 end proc end proc;
  density[Uniform] := proc(a,b,$) proc(x,$)
    1/(b-a)
  end proc end proc;
  density[Gaussian] := proc(mu, sigma, $) proc(x,$)
    1/sigma/sqrt(2)/sqrt(Pi)*exp(-(x-mu)^2/2/sigma^2)
  end proc end proc;
  density[Cauchy] := proc(loc, scale, $) proc(x,$)
    1/Pi/scale/(1+((x-loc)/scale)^2)
  end proc end proc;
  density[StudentT] := proc(nu, loc, scale, $) proc(x,$)
    GAMMA((nu+1)/2) / GAMMA(nu/2) / sqrt(Pi*nu) / scale
    * (1 + ((x-loc)/scale)^2/nu)^(-(nu+1)/2)
  end proc end proc;
  density[BetaD] := proc(a, b, $) proc(x,$)
    x^(a-1)*(1-x)^(b-1)/Beta(a,b)
  end proc end proc;
  # Hakaru uses the alternate definition of gamma, so the args are backwards
  density[GammaD] := proc(shape, scale, $) proc(x,$)
    x^(shape-1)/scale^shape*exp(-x/scale)/GAMMA(shape);
  end proc end proc;
  density[InverseGammaD]:= proc(shape, scale, $)
       proc(x,$) scale^shape/GAMMA(shape)/x^(shape+1)/exp(scale/x) end proc
  end proc;
  density[Counting] := proc(lo, hi, $) proc(k,$)
    1
  end proc end proc;
  density[Categorical] := proc(a, $) proc(k,$)
    idx(a,k)
  end proc end proc;
  density[Binomial]:= proc(n,p,$)
       proc(k,$) p^k*(1-p)^(n-k)*GAMMA(n+1)/GAMMA(k+1)/GAMMA(n-k+1) end proc
  end proc;
  density[NegativeBinomial] := proc(r, p, $) proc(k,$)
    p^k * (1-p)^r * GAMMA(r+k) / GAMMA(k+1) / GAMMA(r)
  end proc end proc;
  density[PoissonD] := proc(lambda, $) proc(k,$)
    lambda^k/exp(lambda)/k!
  end proc end proc;
  density[ChiSquared] := proc(k, $) proc(x,$)
    x^((1/2)*k-1)*exp(-(1/2)*x)/(2^((1/2)*k)*GAMMA((1/2)*k))
  end proc end proc:

  bounds[Lebesgue] := `..`;
  bounds[Uniform] := proc(a, b, $) a .. b end proc;
  bounds[Gaussian] := proc(mu, sigma, $) -infinity .. infinity end proc;
  bounds[Cauchy] := proc(loc, scale, $) -infinity .. infinity end proc;
  bounds[StudentT] := proc(nu, loc, scale, $) -infinity .. infinity end proc;
  bounds[BetaD] := proc(a, b, $) 0 .. 1 end proc;
  bounds[GammaD] := proc(shape, scale, $) 0 .. infinity end proc;
  bounds[InverseGammaD]:= proc(shape, scale, $) 0..infinity end proc;
  bounds[Counting] := proc(lo, hi, $) lo..hi-1 end proc;
  bounds[Categorical] := proc(a, $) 0 .. size(a)-1 end proc;
  bounds[Binomial]:= proc(n,p,$) 0..n end proc;
  bounds[NegativeBinomial] := proc(r, p, $) 0 .. infinity end proc;
  bounds[PoissonD] := proc(lambda, $) 0 .. infinity end proc;
  bounds[ChiSquared] := proc(k, $) 0 .. infinity end proc;

  mk_sym := proc(var :: name, h, $)
    local x;
    x := var;
    if h :: 'Integrand(name, anything)' then
      x := op(1,h);
    elif h :: 'procedure' then
      x := op(1, [op(1,h), x]);
    end if;
    gensym(x)
  end proc;

  mk_ary := proc(e, loops :: list(name = range), $)
    foldl((res, i) -> ary(op([2,2],i) - op([2,1],i) + 1,
                          op(1,i),
                          eval(res, op(1,i) = op(1,i) + op([2,1],i))),
          e, op(loops));
  end proc;

  mk_idx := proc(e, loops :: list(name = range), $)
    foldr((i, res) -> idx(res, op(1,i) - op([2,1],i)),
          e, op(loops));
  end proc;

  ModuleLoad := proc($)
    local prev, ex;
    ModuleUnload();
    Hakaru; # Make sure the Hakaru module is loaded for the types t_type and t_Hakaru.
    KB;     # Make sure the KB module is loaded, for the type t_kb
    prev := kernelopts(opaquemodules=false);
    try
      PiecewiseTools:-InertFunctions := PiecewiseTools:-InertFunctions
        union '{# Do not lift piecewise over a binder
                Integrand,LO,lam,Branch,Bind,ary,Plate,
                forall,Ints,Sums,ints,sums,`..`}';
    catch:
         userinfo(
              1, NewSLO,
              "Redefinition of PiecewiseTools:-InertFunctions failed.",
              StringTools:-FormatMessage(lastexception[2..-1])
         )
    finally
      kernelopts(opaquemodules=prev);
    end try;

    for ex in [ [`Int`,isBound_IntSum], [`Sum`,isBound_IntSum]
              , [`Ints`,isBound_IntsSums], [`Sums`,isBound_IntsSums] ] do
      Domain:-Set_ExtBound(op(1,ex), op(2,ex)(op(1,ex)));
    end do;

    for ex in [ [`PARTITION`, Partition:-isShape] , [ 'piecewise', Partition:-isShape] ] do
      Domain:-Set_ExtShape(op(1,ex), op(2,ex)(op(1,ex)));
    end do;

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


# Domain types which are registered/unregistered with TypeTools.
# Note that the types have to be quoted (additionally to the quote one would
# normally place on certain types) to work properly
local DomBoundVar_type := proc(nm)
    local ixs := [indices(Domain:-ExtBound, nolist)], vs;
    ormap(i->type(nm,Domain:-ExtBound[i]:-VarType), ixs);
end proc;

local DomBoundRange_type := proc(nm)
    local ixs := [indices(Domain:-ExtBound, nolist)], vs;
    ormap(i->type(nm,Domain:-ExtBound[i]:-RangeType), ixs);
end proc;

local DomainTypes := table(
       # Domain bounds
       [(DomBoundVar = 'thismodule:-DomBoundVar_type')
       ,(DomBoundRange = 'thismodule:-DomBoundRange_type')
       ,(DomBoundBinder = ''DInto(DomBoundVar, DomBoundRange, DomBoundKind)'' )
       ,(DomBoundKind   = 'And(name, satisfies(nm->assigned(Domain:-ExtBound[nm])))' )
       ,(DomBound       = ''And(specfunc(DBound)
                               ,{anyfunc(list(DomBoundBinder))
                                ,anyfunc(list(DomBoundBinder),DomCtx)
                                ,anyfunc(list(DomBoundBinder),DomCtx,table) })'' )
       # Domain shape
       ,(DomConstrain = 'specfunc(relation, `DConstrain`)' )
       ,(DomSum       = 'specfunc(DomShape, `DSum`)' )
       ,(DomSplit     = ''DSplit(Partition(DomShape))'' )
       ,(DomInto      = ''Or(DInto(DomBoundVar, DomBoundRange, DomShape)
                            ,DInto(DomBoundVar, DomShape) )'' )
       ,(DomShape     = 'Or( DomConstrain, DomSum, DomSplit, DomInto )' )
       # Domain
       ,(DomCtx = ''t_kb'')
       ,(HDomain = ''DOMAIN(DomBound, DomShape)'' )
       # Maybe domain
       ,(DomNoSol  = ''Not(freeof(`DNoSol`))'' )
       ,(HDomain_mb = ''Or(HDomain, DOMAIN(DomBound, DomNoSol))'' )
       ] );


srclang 3
type $SS <struct {@f1 i32, @f2 i8, @f3 <[] u16>}>
func $foo ( var %x <*<$SS>>, var %y <*<$SS>>) void {
  var %i i32
  var %j i32
  iassign <* u16> ( array 1 ptr <*[]u16> (
                iaddrof ptr <* <$SS>> 3 (dread ptr %x), dread i32 %i),
                iread u16 <* u16> ( array 1 ptr <*[]u16> (
                    iaddrof ptr <* <$SS>> 3 (dread ptr %y), dread i32 %j)))
  return()  }
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


# This is from the original version of Gemma Halliwell's thesis.
# It is probably not useful.

`is_element/marked_digraphs` := (V::set) -> (m,n::nonnegint) -> proc(EIO)
 local E,VI,VO,NI,NO,v;

 if not (type(EIO,list) and nops(EIO) = 3) then
  return false;
 fi;

 E,VI,VO := op(EIO);

 if not `is_element/digraphs`(V)(E) then
  return false;
 fi;

 if not(type(VI,set) and nops(VI) = m and VI minus V = {}) then
  return false;
 fi;

 if not(type(VO,set) and nops(VO) = n and VO minus V = {}) then
  return false;
 fi;

 if VI intersect VO <> {} then return false; fi;

 NI := `in_neighbour_table/digraphs`(V)(E);
 NO := `out_neighbour_table/digraphs`(V)(E);

 for v in VI do
  if nops(NI[v]) <> 0 then return false; fi;
 od:

 for v in VO do
  if nops(NO[v]) <> 0 then return false; fi;
  if nops(NI[v]) <> 1 then return false; fi;
 od:

 return true;
end:

`internal_vertices/marked_digraphs` := (V) -> (m,n) -> proc(EIO)
 local E,VI,VO;
 E,VI,VO := op(EIO);
 return V minus (VI union VO);
end:


# Class: Event
#
# Description:
#  Implementation of events -- a real algebraic number and list of associated quadrics.
#
# Author:
#  Kacper Pluta - kacper.pluta@esiee.fr
#  Laboratoire d'Informatique Gaspard-Monge - LIGM, A3SI, France
#
# Date:
#  29/12/2016
#
# License:
#  Simplified BSD License
#
# Copyright (c) 2016, Kacper Pluta
# All rights reserved.

# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are met:
#   * Redistributions of source code must retain the above copyright
#     notice, this list of conditions and the following disclaimer.
#   * Redistributions in binary form must reproduce the above copyright
#     notice, this list of conditions and the following disclaimer in the
#     documentation and/or other materials provided with the distribution.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
# DISCLAIMED. IN NO EVENT SHALL Kacper Pluta BE LIABLE FOR ANY
# DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
# LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
# ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#
EventType := module()
  option object;

  (*Real Algebraic Number*)
  local ranum::RealAlgebraicNumber;

  (*List of indices of associeted quadrics*)
  local quadrics::list;

# Method: ModuleCopy
#   Standard constructor / copy constructor
#
# Parameters:
#   self::EventType                   - a new object to be constructed
#   proto::EventType                  - a prototype object from which self is derived
#   ranum::RealAlgebraicNumber    - a real algebraic number
#   quadrics::rational            - a list of indices which corresponds to associated quadrics
#
# Output:
#   An object of type RealAlgebraicNumber.
#
# Exceptions:
#  "Invalid range. A range is valid when: a <= b."
#  "Degree of %1 is invalid."
#
  export ModuleCopy::static := proc( self::EventType,
                                     proto::EventType,
                                     ranum::RealAlgebraicNumber,
                                     quadrics::list, $ )
    if _passed = 2 then
      self:-ranum := proto:-ranum;
      self:-quadrics := proto:-quadrics;
    else
      self:-ranum := ranum;
      self:-quadrics := quadrics;
    fi;
  end proc;

# Method: ModulePrint
#   Standard printout of an object of type EventType.
#
# Parameters:
#   self::EventType                  - an event
#
  export ModulePrint::static := proc( self::EventType )
   nprintf("(%a, %a)", self:-ranum, self:-quadrics);
  end proc;

# Method: ModuleApply
#   Define standard constructor.
#
  export ModuleApply::static := proc()
   Object(EventType, args)
  end proc;

# Method: ModuleDeconstruct
#   Provides information how to recreate an object after being serialized.
#
# Parameters:
#   self::EventType                  - an event
#
  export ModuleDeconstruct::static := proc( self::EventType )
    ('EventType')(('RealAlgebraicNumber')(GetPolynomial(self:-ranum), GetInterval(self:-ranum)[1],
    GetInterval(self:-ranum)[2]), self:-quadrics)
  end proc;

# Method: GetRealAlgebraicNumber
#   Getter of the real algebraic number.
#
# Parameters:
#   self::EventType                  - an event
# Output:
#   Associated real algebraic number.
  export GetRealAlgebraicNumber::static := proc(self::EventType)
    return self:-ranum;
  end proc;

# Method: GetQuadrics
#   Getter of the list of indices.
#
# Parameters:
#   self::EventType                  - an event
# Output:
#   Associated quadrics' indices.
  export GetQuadrics::static := proc(self::EventType)
    return self:-quadrics;
  end proc;

# Method: Compare
#   A method used to compare two events.
#
# Parameters:
#   l::EventType      - an event
#   r::EventType      - an event
#
# Output:
#   -1 when l is smaller than r, 0 when they are equal and 1 when l is bigger than r.
#
  export Compare::static := proc( l::EventType, r::EventType, $ )
    return RealAlgebraicNumber:-Compare(l:-ranum, r:-ranum);
  end proc;

end module;


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

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

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

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

  ifc_opts[1] := interface(ifc_opts[0]);
  try
    if not(_debug) then kernelopts(assertlevel=0); end if;
    result := _command(e,t,_rest);
    for pp in _postproc do
      if assigned(RoundTrip_postproc[op(1,pp)]) then
        result := RoundTrip_postproc[op(1,pp)](result, op(2..-1,pp))
      else
        error "invalid postproc option: %1", pp;
      end if;
    end do;
    if not ('expr' in ret_type) then
      result := eval(ToInert(result), _Inert_ATTRIBUTE=NULL);
      if ({'print','string'} intersect ret_type) <> {} then
        result := sprintf("%a",result);
      end if;
      if 'print' in ret_type then
        printf("%s\n",result);
        result := NULL;
      end if;
    end if;
  finally
    interface(zip(`=`, map(lhs,[ifc_opts[0]]), [ifc_opts[1]])[]);
    gensym:-SymbolsToGen := syms0;
  end try;
  return result;
end proc;

RoundTrip_postproc[convert] := proc(r, f::type, t, $)
  subsindets(r, f, x->convert(x,t));
end proc;
RoundTrip_postproc[stable_Partition_order] := proc(r, $)
  subsindets(r, Partition, Simpl:-stable_order)
end proc;

Reparam := proc(e, t::t_type, {ctx :: list := []})
  SimplifyKB_(
    ((e1,_,kb1)->
     fromLO(ReparamDetermined(toLO(e1),kb1),_ctx=kb1)),
    e,t,build_kb(ctx,"Reparam",KB:-empty))
end proc;

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

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

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

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

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

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

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

eval_for_Simplify_tbl := table(
  [ `Int`=`int`
  # Some parts (which?) of the simplifier still always need `sum` instead of `Sum`
  , `Sum`=[`sum`,Not(anything)]
  # Some parts (e.g. gmm_gibbs, see #103) of the simplifier still need `product`
  , `Product`=[`product`,Not(satisfies(x->has(x,{Hakaru:-idx,Hakaru:-size})))]
  ]);

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

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

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

PrintVersion := proc($)
  local i,v,s;
  s := max(op(map(length@lhs,Hakaru:-Version)));
  for i in map(lhs,Hakaru:-Version) do
    v := table(Hakaru:-Version)[i];
    printf(cat("%-",s,"s : %s\n"), i, `if`(v::string,v,""));
  end do;
end proc;

# Testing

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

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

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

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

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

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

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

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

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


# This is from the original version of Gemma Halliwell's thesis.
# It is probably not useful.

`build/standard_levelled_planar_tree` := proc(n::posint,num_levels::posint,u::list(posint))
 local u1,V,E,i,i1,h;

 if nops(u) <> n-1 then
  error "u should have length n-1";
 fi;

 if not(max(op(u)) < num_levels) then
  error "entries in u should be < num_levels";
 fi;

 u1 := [op(u),num_levels];
 V := {seq(seq([i,j],j=0..u1[i]-1),i=1..n)};
 E := {seq(seq([[i,j+1],[i,j]],j=0..u1[i]-2),i=1..n)};
 for i from 1 to n-1 do
  h := u1[i];
  i1 := i+1;
  while i1 < n and u1[i1] <= h do i1 := i1 + 1; od;
  E := {op(E),[[i1,h],[i,h-1]]};
 od;
 return [V,E];
end: