#!/bin/bash maple
# Use `maple -q expand6.mpl -D n=100` to run

e := a0 + a1:
f := 0:

for i from 2 to (n - 1)
do
    f := f + cat(a, convert(i, string)):
    e := e + cat(a, convert(i, string)):
end do:

f := -f:
e := e ^ 2:

st := time[real]():
e := expand(e):
e := subs(a0 = f, e):
e := expand(e):
1000*(time[real]()-st);

print(e);

done


with(Groebner):

################ proc PolylistToNormal
# input:
# Polylist: a nonempty list of nonzero polynomials which are different from each other (list)
# VarList: a list of variables which appear in Polylist (list)
# output: If Polylist has finite solutions, then the output is a strong triangular decomposition (STD) of Polylist.
#         (a row vector of some row vectors)
#         Else FAIL.
PolylistToNormal := proc(PolyList, VarList)
local i, k, ans, TriList, j;
for i from 1 to nops(PolyList) do
    if type(PolyList[i], constant)=true then
       return Vector[row]();
    end if;
end do;
TriList := IsTri(PolyList, VarList);
if TriList[1]=true then
    if IniConstant(PolyList, TriList[2])=0 then
        if nops(PolyList)=nops(VarList) then
            ans := Vector[row](nops(VarList));
            for i from 1 to nops(TriList[3]) do
                k := TriList[3][i];
                ans[-i] := PolyList[k];
            end do;
            for i from 2 to nops(VarList) do
                ans[i] := NormalForm(ans[i], [seq(ans[j], j=1..i-1)], plex(op(VarList)));
            end do;
            return Vector[row](1, fill = ans);
        else
            error "FAIL1: This is not a zero-dimensional system.";
        end if;
    else
        return SubPolylistToNormal(PolyList, VarList, 1, 1);
    end if;
else
    return SubPolylistToNormal(PolyList, VarList, 2, 1);
end if;
end proc:

################ proc SubPolylistToNormal
# GBmethod: 0: fgb+convert
#           1: buchberger
#           2: the first time 0, else 1 (def)
# SATGBmethod: 0: fgb+convert
#              1: buchberger
SubPolylistToNormal := proc(PolyList, VarList, GBmethod := 2, SATGBmethod := 1)
local ComputedSet, GBmethod1, SplitSet, P, GB_Grad, GB_Lex, wCharList, AbnormalNum, IniNum, GB, AddF, i, GB_mainvar, lindex, lnum;
ComputedSet := Vector[row]();   # ComputedSet is a row vector of some row vectors
SplitSet := Vector[row]();      # SplitSet is a row vector of some lists
SplitSet(1) := PolyList;
GBmethod1 := GBmethod;
lindex := 1;
lnum := 1;
while lindex<=lnum do
    P := SplitSet[lindex];
    lindex := lindex+1;
    if GBmethod1=1 then
        GB_Lex := Basis(P, plex(op(VarList)), method = Buchberger);
    else
        GB_Grad := Basis(P, tdeg(op(VarList)), method = fgb);
        GB_Lex  := Basis(GB_Grad, plex(op(VarList)), method = convert);
        if GBmethod1=2 then
            GBmethod1 := 1;
        end if;
    end if;
    if GB_Lex <> [1] then
       GB_mainvar := [seq(MainVar(GB_Lex[i], VarList), i=1..nops(GB_Lex))];
       if lindex=2 then
           if not(IsZeroDim(GB_Lex, VarList)) then
              error "FAIL2: This is not a zero-dimensional system.";
           end if;
       end if;
       wCharList := wChar(GB_Lex, VarList, GB_mainvar); # wCharList is a row vector
       AbnormalNum := IsNormal(wCharList, VarList);
       if AbnormalNum = 0 then
            ComputedSet(numelems(ComputedSet)+1) := wCharList;
       else
            IniNum := SquareFree(primpart(lcoeff(wCharList[AbnormalNum], VarList[-AbnormalNum])));
            GB := SaturIdeal(IniNum, [seq(wCharList[i], i=1..AbnormalNum-1)], VarList, SATGBmethod); # GB is a row vector
            AddF := Vector[row]();
            for i from 1 to numelems(GB) do
                if NormalForm(GB[i], [seq(wCharList[i], i=1..AbnormalNum-1)], plex(op(VarList)))<>0 then
                    AddF(numelems(AddF)+1) := GB[i];
                end if;
            end do;
            SplitSet(++lnum):= [op(GB_Lex), seq(AddF[i], i=1..numelems(AddF))];
            SplitSet(++lnum):= [op(GB_Lex), IniNum];
       end if;
    end if;
end do;
return ComputedSet;
end proc:

################ proc NormalToSquarefree
# input:
# NormalChain: a strong chain (a row vector)
# VarList: a list of variables which appear in Polylist (list)
# output:
# ans: a strong square-free triangular decomposition (SSFTD) of NormalChain
#         (a row vector of some row vectors)
NormalToSquarefree := proc(NormalChain, VarList, SATGBmethod:=1)
local NormalSet, ans, P, AbNum, temp, tempSet, f, GB, AddF, i, r1, r2, lindex, lnum;
NormalSet := Vector[row]();   # NormalSet is a vector of some row vectors
NormalSet(1) := NormalChain;
ans := Vector[row]();         # ans is a vector of some row vectors
lindex := 1;
lnum := 1;
while lindex<=lnum do
   P := NormalSet[lindex];           # P is a row vector
   lindex := lindex+1;
   AbNum := IsSquareFree(P, VarList);
   if AbNum=0 then
        ans(numelems(ans)+1) := P;
   elif AbNum=1 then
        temp := factors(P[1]);
        tempSet := [seq(temp[2][i][1], i = 1 .. nops(temp[2]))];
        for i from 1 to nops(tempSet) do
            P(1) := tempSet[i];
            NormalSet(++lnum) := Vector[row](P);
        end do;
    else
        f := SquareFree(diff(P[AbNum], VarList[-AbNum]));
        GB := SaturIdeal(f, [seq(P[i], i=1..AbNum)], VarList, SATGBmethod); # GB is a row vector
        AddF := Vector[row]();
        for i from 1 to numelems(GB) do
            if NormalForm(GB[i], [seq(P[i], i=1..AbNum)], plex(op(VarList)))<>0 then
                AddF(numelems(AddF)+1) := GB[i];
            end if;
        end do;
        r1 := SubPolylistToNormal([seq(P[i], i=1..numelems(P)), f], VarList); # r1 is a row vector of some row vectors
        r2 := SubPolylistToNormal([seq(P[i], i=1..numelems(P)), seq(AddF[i], i=1..numelems(AddF))], VarList);
        # r2 is a row vector of some row vectors
        for i from 1 to numelems(r1) do
            NormalSet(++lnum) := r1[i];
        end do;
        for i from 1 to numelems(r2) do
            NormalSet(++lnum) := r2[i];
        end do;
    end if;
end do;
return ans;
end proc:

################ proc PolysetToSfNormal
# input:
# Polylist: a nonempty list of nonzero polynomials which are different from each other (list)
# VarList: a nonempty list of variables
# output:
# output: If Polylist has finite solutions, then the output is a strong square-free triangular decomposition (SSFTD) of Polylist.
#         (a row vector of some row vectors)
#         Else FAIL.
PolylistToSfNormal := proc(PolySet, VarList, SATGBmethod:=1)
local NormalDec, ans, i, r, j;
NormalDec := PolylistToNormal(PolySet, VarList);   # NormalDec is a row vector of some row vectors
if NormalDec=FAIL then
   return FAIL;
else
   ans := Vector[row]();     # ans is a row vector of some row vectors
   for i from 1 to numelems(NormalDec) do
       r := NormalToSquarefree(NormalDec[i], VarList, SATGBmethod);    # r is a row vector of some row vectors
       for j from 1 to numelems(r) do
           ans(numelems(ans)+1) := r[j];
       end do;
   end do;
   return ans;
end if;
end proc:

################ proc IsTri
IsTri := proc(PolyList, VarList)
local JudgeList, i, k, mainvarList;
JudgeList := [seq(-1, i=1..nops(VarList))];
mainvarList := [seq(MainVar(PolyList[i], VarList), i=1..nops(PolyList))];
for i from 1 to nops(PolyList) do
    member(mainvarList[i], VarList, 'k');
    if JudgeList[k]=-1 then
        JudgeList[k] := i;
    else
        return [false];
    end if;
end do;
return [true, mainvarList, JudgeList];
end proc:

################ proc wChar
# input:
# GroeBasis: the reduced lex Groebner basis w.r.t. VarList[1]>...>VarList[n]
# VarList: the variable list of GroeBasis
# mainvar: the main variable list of GroeBasis such that the main variable of GroeBasis[i] is mainvar[i]
# output:
# wCharList: the W-characteristic list of GroeBasis (row vector)
wChar := proc(GroeBasis, VarList, mainvar)
local k, i, PolySet, wCharList, wCharPrep, j;
PolySet := Vector[row](nops(VarList));
for k from 1 to nops(VarList) do
    PolySet[k] := Vector[row]();
end do;
for i from 1 to nops(GroeBasis) do
    member(mainvar[i], VarList, 'k');
    PolySet[k](numelems(PolySet[k])+1) := GroeBasis[i];
end do;
wCharList := Vector[row](nops(VarList));
for i from 1 to nops(VarList) do
    wCharPrep := PolySet[i][1];
    for j from 2 to numelems(PolySet[i]) do
        if TestOrder(LeadingMonomial(PolySet[i][j], plex(op(VarList))), LeadingMonomial(wCharPrep, plex(op(VarList))), plex(op(VarList))) then
           wCharPrep := PolySet[i][j];
        end if;
    end do;
    wCharList[-i] := wCharPrep;
end do;
return wCharList;
end proc:

################ proc IsNormal
# input:
# TriSet: a zero-dim triangle set T=[T1,...,Tn] such that 0<lv(T1)<...<lv(Tn) (row vector)
# VarList: the list of main variables of TriSet such that the main variable of TriSet[i] is VarList[-i] (list)
# output:
# NormNum: if Triset is normal, then return 0
# else return the smallest integer (>1) such that [T1,...,Tk] is abnormal
IsNormal := proc(TriSet, VarList)
local NormNum, i;
NormNum := 0;
for i from 1 to numelems(TriSet) do    # Note that Triset[1] is a univariate polynomial.
    if type(lcoeff(TriSet[i], VarList[-i]), constant)=false then
       NormNum := i;
       break;
    end if;
end do;
return NormNum;
end proc:

################ proc IsNormalSpe
# input:
# PolyList: a polynomial list which is a out-of-order triangle set (a list)
# mainvarList: lv(PolyList[i]) = mainvarList[i]
# output:
# NormNum: if all initials of PolyList are constants, then return 0; else return 1
IniConstant := proc(PolyList, mainvarList)
local i;
for i from 1 to nops(PolyList) do    # Note that Triset[1] is a univariate polynomial.
    if type(lcoeff(PolyList[i], mainvarList[i]), constant)=false then
       return 1;
    end if;
end do;
return 0;
end proc:

################ proc IsSquareFree
# input:
# TriSet: a triangle set T=[T1,...,Tn] such that 0<lv(T1)<...<lv(Tn) (a row vector)
# (a list)
# VarList: the list of main variables of TriSet such that the main variable of TriSet[i] is VarList[-i]
# output:
# NormNum: if Triset is square-free, then return 0
# else return the smallest integer such that [T1,...,Tk] is not squarefree
IsSquareFree := proc(TriSet, VarList)
local NormNum, j, i, dis, Tri;
NormNum := 0;
if primpart(discrim(TriSet[1], VarList[-1]))=0 then
   return 1;
else
   for i from 2 to numelems(TriSet) do
        dis[i] := primpart(discrim(TriSet[i], VarList[-i]));
        Tri := [seq(TriSet[j], j=1..i-1)];
        if ResTri(dis[i], Tri, VarList)=0 then
           NormNum := i; break;
        end if;
        if NormNum <> 0 then break; end if;
    end do;
    return NormNum;
end if;
end proc:

################ proc ResTri
# input:
# P : a polynomial
# TriSet: a triangle set T=[T1,...,Tn] such that 0<lv(T1)<...<lv(Tn)   (a list)
# VarList: the list of main variables of TriSet such that the main variable of TriSet[i] is VarList[-i]
# output:
# F: Res(P, TriSet)
ResTri := proc(P, TriSet, VarList)
local F, n,i,j,temp,tempSet1,tempSet2;
F := P;
for n from nops(TriSet) by -1 to 1 do
    F := primpart(resultant(F, TriSet[n], VarList[-n]));
end do;
return F;
end proc:

################ proc SaturIdeal
# input:
# Poly : a polynomial
# PolyList: a list of polynomials (a list)
# SATGBmthod: 0: fgb+convert; 1: buchberger
# output:
# ans: the lex reduced Groebner basis of <op(PolyList)>:Poly^{infinity} (a vector)
SaturIdeal := proc(Poly, PolyList, VarList, SATGBmethod:=0)
local Z, GB_Grad, GB_Lex, i, ans;
ans := Vector[row]();
if SATGBmethod=0 then
    GB_Grad := Basis([op(PolyList), 1-Poly*Z], tdeg(Z, op(VarList)), method = fgb);
    GB_Lex  := Basis(GB_Grad, plex(Z, op(VarList)), method = convert);
else
    GB_Lex  := Basis([op(PolyList), 1-Poly*Z], plex(Z, op(VarList)), method = buchberger);
end if;
for i from 1 to nops(GB_Lex) do
    if has(GB_Lex[i], Z)=false then
       ans(numelems(ans)+1) := GB_Lex[i];
    end if;
end do;
return ans;
end proc:

########## proc Class, proc MainVar, proc WuInitial
# input:
# f: a polynomial
# ord: a list of variables of f such that ord[1]>ord[2]>...
########## proc Class
Class := proc(f::polynom, ord::list)
local i;
option cache;
for i from 1 to nops(ord) do
	if has(f,ord[i]) then
		return i;
	end if;
end do;
return 0;
end proc:

########## proc MainVar
MainVar := proc(f::polynom, ord::list)
local i;
option cache;
for i from 1 to nops(ord) do
	if has(f, ord[i]) then
		return ord[i];
	end if;
end do;
return 0;
end proc:

########## proc WuInitial
WuInitial := proc(f::polynom, ord::list)
option cache;
if Class(f, ord)=0 then
	return 1;
else
	return primpart(lcoeff(f, MainVar(f,ord)));
end if;
end proc:

########## proc SquareFree
SquareFree := proc(poly)
option cache;
local FactorList,i;
FactorList := sqrfree(poly);
return mul(FactorList[2][i][1], i = 1 .. nops(FactorList[2]));
end proc:

########## proc IsZeroDim
IsZeroDim := proc(GBlex, VarList)
local JudgeList,i,IndSet,j;
JudgeList := [seq(0, i=1..nops(VarList))];
for i from 1 to nops(GBlex) do
   IndSet := indets(LeadingMonomial(GBlex[i], plex(op(VarList))));
   if nops(IndSet)=1 then
       for j from 1 to nops(VarList) do
           if IndSet={VarList[j]} then
               JudgeList[j] := 1;
               break;
           end if;
       end do;
   end if;
end do;
for i from 1 to nops(JudgeList) do
   if JudgeList[i]=0 then
       return false;
   end if;
end do;
return true;
end proc:


# Note this is valid only because this file is technically a top-level file,
# i.e. it isn't included anywhere with `$include'
with(Domain_Type):

local Simplify_DConstrain := (can_simp, do_simp) -> module()
    uses Domain;

    export ModuleApply := proc(vs0 :: DomBound, sh :: DomShape, $)
        local vs := vs0, ctx;
        if _Env_HakaruSolve=false then
           return sh end if;
        vs  := Domain:-Bound:-varsOf(vs,"set");
        ctx := Domain:-Bound:-toConstraints(vs0, 'bound_types');
        subsindets(sh, DomConstrain
                  ,x->do_simpl_constraints(vs0, vs, ctx, x));
    end proc;

    local do_simpl_constraints := proc(vs0, vars, ctx_vs, x, $)
        local ctx1, ctx, ss, td, rest, d, in_vs;
        ss, ctx := selectremove(q->depends(q,indets(vars,Name)), x);
        td, rest := selectremove(can_simp(vs0), ss);
        ctx1 := { op(ctx), op(ctx_vs), op(rest) };
        d := map(x->do_simp(vs0,ctx1,x), td);
        DConstrain(op(d), op(ctx), op(rest));
    end proc;
end module;

Domain_try_improve_exp := module()
  uses Utilities;

  export SimplName  := "Try improve exp";
  export SimplOrder := 6 - 2/10;

  local can := proc(vs)
    c -> c::relation and (not(lhs(c) :: Name) and not(rhs(c) :: Name) and has(c,{ln,exp}));
  end proc;

  local `try` := proc(dbnd, ctx1, q0, $)
    local vars, vars_q, q := q0;
    vars := Domain:-Bound:-varsOf(dbnd,"set");
    vars_q := indets(q, name) intersect vars;
    if nops(vars_q)=0 then return q end if;

    vars_q := op(1,vars_q);
    try_improve_exp(q, vars_q, ctx1);
  end proc;

  export ModuleApply := Simplify_DConstrain(can, `try`);
end module;

constraints_about_vars := module()
  uses Utilities;
  export SimplName  := "Make constraints abouts vars";
  export SimplOrder := 6;

  local can_make_about := proc(vs)
    local vars := Domain:-Bound:-varsOf(vs,"set");
    c -> c::relation and (not(lhs(c) in vars) and not(rhs(c) in vars));
  end proc;
  local try_make_about := proc(dbnd, ctx1_, q0, $)
      local vars_q, vars, q_s, q_r
          , q := q0
          , ctx1 := ctx1_ ;
      vars := Domain:-Bound:-varsOf(dbnd,"set");
      vars_q := indets(q, name) intersect vars;
      if nops(vars_q)=0 then return q end if;

      vars_q := op(1,vars_q);
      q := try_improve_exp(q, vars_q, ctx1);
      q_r := `if`(has(q,{ln,exp}),q0,q);

      q, ctx1 := map(KB:-chill, [q,ctx1])[];
      # Unevaluated for debugging
      q_s := 'solve({q},[op(vars_q)], 'useassumptions'=true) assuming (op(ctx1))';
      q_s := eval(q_s);
      q, ctx1 := map(KB:-warm, [q,ctx1])[];
      if q_s::list and not has(q_s, signum) then
        if nops(q_s)=0 then return q_r end if;
        q_s := map(s->remove(c->c in ctx1 or `and`(c::relation,lhs(c)::name,lhs(c)=rhs(c)), s), q_s);
        q_s := remove(x->x=[],q_s);
        if nops(q_s)=0 then return q_r end if;
        userinfo(3, 'constraints_about_vars'
                ,printf("Found a solution to %a (with solve):\n\t%a\n", q0, op(1,q_s)));
        op(op(1,q_s)); # pick the first solution arbitrarily!
      else
        q_r
      end if;
  end proc;

  export ModuleApply := Simplify_DConstrain(can_make_about, try_make_about);
end module;

clamp_extraneous_constraints := module()
  uses Utilities;
  export SimplName  := "clamp_extraneous_constraints";
  export SimplOrder := 6 - 1/10;

  local can := proc(vs)
    local vars := Domain:-Bound:-varsOf(vs,"set");
    c-> c::relation and
        (ormap(s->s(c)::Name and not(c in vars),[lhs,rhs]) and has(c, vars));
  end proc;

  local `try` := proc(dbnd, ctx1, q0, $)
    local bnd, b_ty, b_rel, b_var, b_bnd, b_bnd_vs, vars, extremum, q := q0;
    if has(q, {ln,exp}) then
      vars := Domain:-Bound:-varsOf(dbnd, "set");
      bnd := classify_relation(q0, x -> type(x, Name) and not (x in vars));
      if bnd=FAIL then return q0 end if;
      b_ty, b_rel, b_var, b_bnd := op(bnd):
      b_bnd_vs := indets(b_bnd, satisfies(x -> x in vars));
      if b_bnd_vs <> {} then
        b_ty := `if`(b_ty=B_LO, 'minimize', 'maximize');
        extremum := b_ty(b_bnd, op(b_bnd_vs)) assuming(op(ctx1));
        if not (ext :: SymbolicInfinity or has(extremum, {maximize,minimize})) then
          q := q, b_rel(b_var,extremum);
        end if;
      end if;
    end if;
    q
  end proc;
  export ModuleApply := Simplify_DConstrain(can, `try`);
end module;

# Pushes constraints down, or pulls them up, when there are such constraints.
local do_ctx_dir := dir -> proc(vs :: DomBound, sh :: DomShape, $)
    local ctx := Domain:-Bound:-toConstraints(vs, 'no_infinity');
    ctx := remove(x->x::`::`,ctx);
    if ctx <> {} then
        dir(ctx)(sh);
    else
        sh;
    end if;
end proc;

push_ctx_down := module()
  uses Domain;
  export ModuleApply := do_ctx_dir(ctx->sh->subsindets(sh, DomConstrain, x->if nops(x)<>0 then DConstrain(op(x), op(ctx)) else DConstrain() end if));
  export SimplName  := "Push context down";
  export SimplOrder := 1;
end module;

pull_ctx_out := module()
  export ModuleApply :=
    do_ctx_dir(ctx->sh->subsindets(sh, DomConstrain
              ,x->remove(c->c in ctx or (is(c) assuming op(ctx)), x)));
  export SimplName  := "Pull context out";
  export SimplOrder := 20;
end module;

# Turns constraints(relations) into bounds
classify_DConstrains := module()
  uses Domain, Utilities;

  export SimplName  := "Classify constraints";
  export SimplOrder := 8;

  export ModuleApply := proc(dbnds::DomBound,dsh::DomShape,$)
    subsindets(dsh, DomConstrain, x->classify_Rels([op(x)], dbnds));
  end proc;

  # Split relations into those we can incorporate
  # into bounds and others; this process also includes
  # some intermediate computations about the new bound:
  #  [ DInto(var), orig, upd_bound, bound_kind, numVars ]
  #    var         :=   variable to be modified
  #    orig        :=   the original relation
  #    upd_bound   :=   how to modify (a function)
  #    bound_kind  :=   {LO/HI}
  #    numVars     :=   how many variables are mentioned by the bound
  local classify_Rel := proc(r0,dbnd,$)
    local ret, vars, mk_k, bnd_k, i, var_k, q, cl, lhs_r, rhs_r, r := r0;
    ret := [ DConstrain, r0 ];
    vars := Domain:-Bound:-varsOf(dbnd,"set");

    # extract a representation of the relation, and check that it is a bound
    cl := classify_relation(r, vars);
    if cl=FAIL or not (op(1,cl) in {B_LO,B_HI}) then return ret; end if;
    bnd_k,mk_k,lhs_r,rhs_r := op(cl);

    i := Domain:-Bound:-varIx_mb(dbnd, lhs_r);
    if i >= 0 then
      var_k := op([1,i,3], dbnd);
      q := Domain:-ExtBound[var_k]:-RecogBound(mk_k,rhs_r);
      if q <> NULL then
        ret := [ DInto(lhs_r), r0, q, bnd_k, countVs(vars minus {lhs_r},r0) ];
      end if;
    end if;
    ret;
  end proc;

  # Classifies a set of relations as potential bounds. The process
  # is as follows:
  #  - Classify each relation individually (see classify_Rel)
  #  - "Categorize" by the classification
  #  - Split relations which will be DConstrains, and those where we found
  #      more than one LO/HI bound or more than 2 bounds total.
  #  - Sort the relations which are to become bounds by the number of variables
  #      mentioned in the bound
  #  - Rebuild the continuations producing each new bound (see make_DInto)
  #  - Rebuild the leftover relations as a DConstrain.
  #  - Squash together ("foldr (.) id fs z") the continuations and leftover relations.
  local classify_Rels := proc(rs0,dbnd,$)
    local cs1, cs2, cs, rs := rs0;
    rs := map(r->classify_Rel(r,dbnd), rs);
    rs := [ListTools[Categorize]( ((a,b) -> op(1,a)=op(1,b) ), rs )];
    cs1, rs := selectremove(x->op([1,1],x)=DConstrain, rs);
    rs, cs2 := selectremove(x->nops(x)=1 or (nops(x)=2 and op([1,4],x)<>op([2,4],x)), rs);
    rs := sort(rs, key=solOrder);
    rs := map(r->make_DInto(r,dbnd),rs);
    cs := DConstrain(map(c->map(q->op(2,q),c)[], [op(cs1),op(cs2)])[]);
    foldr((f,g)->f@g,x->x,op(rs))(cs);
  end proc;

  # Rebuild a classified (by classify_Rel) relation; this
  # takes a list of such classifications, all of whose variable should
  # be identical, and for which the different bound kinds are all distinct.
  # None of this is checked!
  # (since there are 2 bound kinds, this list is at most length 2)
  local make_DInto := proc(r::list([specfunc(DInto),anything,anything,identical(B_LO,B_HI),nonnegint]), dbnd, $)
    local var_nm, var_ty;
    var_nm := op([1,1,1], r);
    var_ty := Domain:-Bound:-get(dbnd, var_nm)[1];
    var_ty := foldr( ((q,x)->op(3,q)(x)), var_ty, op(r) );
    (ctx -> DInto(var_nm, var_ty, ctx))
  end proc;
  local flip_rel := table([`=`=`=`,`<>`=`<>`,`<=`=`>=`,`<`=`>`,`>=`=`<=`,`>`=`<`]);
  local countVs := ((vs,c)-> nops(indets(c, DomBoundVar) intersect {op(vs)} ));
  local solOrder := (x->`+`(map(z->op(5,z),x)[]));
end module;

# todo; this should actually solve for a variable, then substitute
# that variable in. In most cases, it would probably be enough to
# leave that as it is; it would simplify later.
singular_pts := module()
  uses Domain, Domain_Type, Hakaru;

  export SimplName  := "Single_pts";
  export SimplOrder := 7;

  export ModuleApply := proc(bnds :: DomBound, sh :: DomShape, $)
    local kb, kb_rn, ns, sh1; sh1 := sh;
    kb, kb_rn := Domain:-Bound:-toKB(bnds)[];
    sh1 := subs(kb_rn, sh1);
    ns := op(1,bnds);
    ns := select(b->op(3,b) in {`Int`,`Ints`}, ns);
    ns := map(curry(op,1), ns);

    sh1 := Partition:-Simpl:-singular_pts(sh1, kb, _name_cands=ns);
    eval(sh1, [DSum=DSum,DConstrain=DConstrain]);
  end proc;
end module;


(*
    Test file for highlight
*)
`&+`:=proc(x::set,y::set)
    return x union y;
end proc:               # keywords
$include "utils.mpl"    # preprocessor
solve(x^2+x-1);         # maple functions
print(`&+`);            # quoted name
print("123");           # string
print('x+y');           # unvaluated expression
type(x,uneval);         # type name
fun:=proc(x::uneval)    # parameter modifier
    option inline;      # proc and module options
    print(procname);    # language variable
    return true;        # language constants
end proc:


# MG10HL von Kawasaki
# Voraussetzung:
# fourbarpris muss mit der Toolbox berechnet worden sein (Arbeitsblatt "fourbarprisTE_kinematic_constraints.mw")
# fourbar1 muss mit der Toolbox berechnet worden sein (Arbeitsblatt "fourbar1TE_kinematic_constraints.mw")
#
# Offene Punkte / TODO:
# In [Bejaoui2018_S749] wurden die Systeme fourbar1 und fourbarpris etwas anders definiert. Die Änderung wurde hier noch nicht angepasst. Daher funktioniert das Modell aktuell nicht. Die kinematischen Ketten werden nicht geschlossen.
# Autor
# Abderahman Bejaoui
# Studienarbeit bei: Moritz Schappler, moritz.schappler@imes.uni-hannover.de, 2018-09
# (C) Institut fuer mechatronische Systeme, Leibniz Universitaet Hannover
# Quellen
# [Bejaoui2018_S749]
#
# Initialisierung
# Import
interface(warnlevel=0): # Unterdrücke die folgende Warnung.
restart: # Gibt eine Warnung, wenn über Terminal-Maple mit read gestartet wird.
interface(warnlevel=3):
kin_constraints_exist := true: # Für Speicherung
;
with(StringTools): # Für Zeitausgabe
with(LinearAlgebra):
with(codegen):
with(CodeGeneration):
#with(ListTools):
codegen_act := true:
codegen_opt := 1: # Geringerer Optimierungsgrad. Sonst zu lange.
codegen_debug := 0: # Zur Code-Generierung auch für Nicht-Inert-Ausdrücke
;
read "../helper/proc_MatlabExport":
read "../transformation/proc_rotx":
read "../transformation/proc_roty":
read "../transformation/proc_rotz":
read "../helper/proc_convert_s_t":
read "../helper/proc_convert_t_s":
read "../robot_codegen_constraints/proc_subs_kintmp_exp":
with(RealDomain): # Schränkt alle Funktionen auf den reellen Bereich ein. Muss nach Definition von MatlabExport kommen. Sonst geht dieses nicht.
;
read "../robot_codegen_definitions/robot_env":
read sprintf("../codeexport/%s/tmp/tree_floatb_definitions",robot_name):
# Variable mit Winkeln der Nebenstruktur nur in Abhängigkeit der verallgemeinerten Koordinaten
kintmp_qs := Matrix(RowDimension(kintmp_s),1):
# Konstante Winkel bereits hineinschreiben
for i from 1 to RowDimension(kintmp_s) do
  if diff(kintmp_s(i,1), t) = 0 then
    kintmp_qs(i,1) := kintmp_s(i,1):
  end if:
end do:
# Variablen definieren für die Hilfswinkel
#
# Ersetzungsausdrücke definieren.
# Speichere Sinus und Cosinus der Winkel direkt ab, da diese in den Rotationsmatrizen direkt auftreten.
# Spalte 1: Zu suchender Ausdruck (sin oder cos eines Winkels)
# Spalte 2: Einzusetzender Ausdruck.
# Dadurch werden arctan-Ausdrücke in der direkten Kinematik reduziert.
# Ähnliches Vorgehen wie in [1].
kintmp_subsexp := Matrix(2*RowDimension(kintmp_s),2):
for i from 1 to RowDimension(kintmp_s) do
  kintmp_subsexp(2*i-1, 1) := sin(kintmp_s(i,1)):
  kintmp_subsexp(2*i,   1) := cos(kintmp_s(i,1)):
  # Initialisierung der rechten Spalte mit gleichen Werten. Später nur Ersetzung, wenn Vorteilhaft.
  kintmp_subsexp(2*i-1, 2) := kintmp_subsexp(2*i-1, 1):
  kintmp_subsexp(2*i,   2) := kintmp_subsexp(2*i,   1):
end do:
# Einlesen der Ergebnisse der allgemeinen Viergelenkkette. TODO: Nehme die Ausgabe von
# fourbar1TE/tmp/kinematic_constraints_maple_inert.m und nutze kintmp_subsexp direkt von dort.
read sprintf("../codeexport/fourbar1TE/tmp/fourbar1TE_angles_trig_elim"):
# Liest Variable: "winkel"
;
read sprintf("../codeexport/fourbarprisTE/tmp/fourbarprisTE_angles_trig_elim"):
# Liest Variable: "winkel_fourbarpris"
;

# Viergelenkkette A-C-D-E
winkel1:=<<sin_rho910|sin(rho910_s)>;<cos_rho910|cos(rho910_s)>;<sin_rho19|sin(rho19_s)>;<cos_rho19|cos(rho19_s)>;<sin_rho3|sin(rho3_s)>;<cos_rho3|cos(rho3_s)>>:
for i from 1 to 6 do
  winkel1(i,2):=winkel(i,2):
  cos_phi_s := sin(qJ2s)*cos(phi23)+cos(qJ2s)*sin(phi23):
  sin_phi_s := cos(qJ2s)*cos(phi23)-sin(qJ2s)*sin(phi23):
  winkel1(i,2):=subs({sin(qJ1s)=sin_phi_s},winkel1(i,2)): # qJ1s in fourbar1TE ist der aktive Winkel
  winkel1(i,2):=subs({cos(qJ1s)=cos_phi_s},winkel1(i,2)):
  winkel1(i,2) := subs({l1=AC}, winkel1(i,2)):
  winkel1(i,2) := subs({l2=AE}, winkel1(i,2)):
  winkel1(i,2) := subs({l3=ED}, winkel1(i,2)):
  winkel1(i,2) := subs({l4=DC}, winkel1(i,2)):
end do:
winkel1(1..6,1):
sin_rho910_s:=winkel1(1,2): # für kintmp_subsexp
;
cos_rho910_s:=winkel1(2,2): # für kintmp_subsexp
;
sin_rho19_s:=winkel1(3,2): # für kintmp_subsexp
;
cos_rho19_s:=winkel1(4,2):  # für kintmp_subsexp
;
sin_rho3_s:=winkel1(5,2):
cos_rho3_s:=winkel1(6,2):
cos_rho23_s:=-cos_rho3_s: # für kintmp_subsexp
;
sin_rho23_s:=sin_rho3_s:  # für kintmp_subsexp
;
# Schubkurbel G-P-K
winkel2:=<<sin_eta1112|sin(eta1112_s)>;<cos_eta1112|cos(eta1112_s)>;<sin_eta3|sin(eta3_s)>;<cos_eta3|cos(eta3_s)>;<sin_eta45|sin(eta45_s)>;<cos_eta45|cos(eta45_s)>>:
for i from 1 to 6 do
	winkel2(i,2):=winkel_fourbarpris(i,2):
	winkel2(i,2):=subs({qJ1s=qJ6s},winkel2(i,2)):
	winkel2(i,2) := subs({GK=GK}, winkel2(i,2)):
     winkel2(i,2) := subs({GP=GP}, winkel2(i,2)):
     winkel2(i,2) := subs({HP=HP}, winkel2(i,2)):
end do:
winkel2
;
sin_eta1112_s:=winkel2(1,2): # für kintmp_subsexp
;
cos_eta1112_s:=winkel2(2,2): # für kintmp_subsexp
;
sin_eta3_s:=winkel2(3,2):
cos_eta3_s:=winkel2(4,2):
sin_eta45_s:=winkel2(5,2): # für kintmp_subsexp
;
cos_eta45_s:=winkel2(6,2): # für kintmp_subsexp
;
sin_eta411_s:=sin_eta3_s: # für kintmp_subsexp
;
cos_eta411_s:=-cos_eta3_s: # für kintmp_subsexp
;
cos_eta34_s:=-(cos_eta411_s*cos(phi3)-sin_eta411_s*sin(phi3)):  # für kintmp_subsexp
;
sin_eta34_s:=sin_eta411_s*cos(phi3)+cos_eta411_s*sin(phi3):  # für kintmp_subsexp
;
# Kintmp_subsexp
kintmp_subsexp(1,2):=sin_rho23_s:
kintmp_subsexp(2,2):=cos_rho23_s:
kintmp_subsexp(3,2):=sin_eta34_s:
kintmp_subsexp(4,2):=cos_eta34_s:
kintmp_subsexp(5,2):=sin_eta45_s:
kintmp_subsexp(6,2):=cos_eta45_s:
kintmp_subsexp(7,2):=sin_rho19_s:
kintmp_subsexp(8,2):=cos_rho19_s:
kintmp_subsexp(9,2):=sin_rho910_s:
kintmp_subsexp(10,2):=cos_rho910_s:
kintmp_subsexp(11,2):=sin_eta411_s:
kintmp_subsexp(12,2):=cos_eta411_s:
kintmp_subsexp(13,2):=sin_eta1112_s:
kintmp_subsexp(14,2):=cos_eta1112_s:
kintmp_subsexp(11..14,1);

# Kintmp_qs
kintmp_qs(1,1):=arctan(sin_rho23_s,cos_rho23_s):
kintmp_qs(2,1):=arctan(sin_eta34_s,cos_eta34_s):
kintmp_qs(3,1):=arctan(sin_eta45_s,cos_eta45_s):
kintmp_qs(4,1):=arctan(sin_rho19_s,cos_rho19_s):
kintmp_qs(5,1):=arctan(sin_rho910_s,cos_rho910_s):
kintmp_qs(6,1):=arctan(sin_eta411_s,cos_eta411_s):
kintmp_qs(7,1):=arctan(sin_eta1112_s,cos_eta1112_s):
# Export
kintmp_qt := convert_s_t(kintmp_qs):
save kintmp_subsexp, sprintf("../codeexport/%s/tmp/kinematic_constraints_kintmp_subsexp_maple", robot_name):
save kintmp_subsexp, sprintf("../codeexport/%s/tmp/kinematic_constraints_kintmp_subsexp_maple.m", robot_name):
#printf("Ausdrücke für kintmp_subsexp gespeichert (Maple). %s. CPU-Zeit bis hier: %1.2fs.\n", FormatTime("%Y-%m-%d %H:%M:%S"), time()-st):
for i from 1 to RowDimension(kintmp_s) do
  tmp := kintmp_qs(i):
  save tmp, sprintf("../codeexport/%s/tmp/kinematic_constraints_maple_inert_kintmpq_%d",robot_name, i):
  save tmp, sprintf("../codeexport/%s/tmp/kinematic_constraints_maple_inert_kintmpq_%d.m", robot_name, i):
end do:
save kin_constraints_exist, kintmp_qs, kintmp_qt,kintmp_subsexp, sprintf("../codeexport/%s/tmp/kinematic_constraints_maple_inert" ,robot_name):
save kin_constraints_exist, kintmp_qs, kintmp_qt, kintmp_subsexp, sprintf("../codeexport/%s/tmp/kinematic_constraints_maple_inert.m", robot_name):
save kintmp_qs, sprintf("../codeexport/%s/tmp/kinematic_constraints_kintmp_qs_maple_inert", robot_name):
#printf("Ausdrücke mit Inert-Arctan exportiert (Matlab). %s. CPU-Zeit bis hier: %1.2fs.\n", FormatTime("%Y-%m-%d %H:%M:%S"), time()-st):
# Liste mit abhängigen konstanten Kinematikparametern erstellen (wichtig für Matlab-Funktionsgenerierung)
read "../helper/proc_list_constant_expressions";
kc_symbols := Matrix(list_constant_expressions( kintmp_subsexp ));
#kc_symbols :=Transpose(kc_symbols);
save kc_symbols, sprintf("../codeexport/%s/tmp/kinematic_constraints_symbols_list_maple", robot_name):
MatlabExport(kc_symbols, sprintf("../codeexport/%s/tmp/kinematic_constraints_symbols_list_matlab.m",robot_name),2);
#printf("Fertig. %s. CPU-Zeit bis hier: %1.2fs.\n", FormatTime("%Y-%m-%d %H:%M:%S"), time()-st):
kc_symbols
;


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

`eta/simplex_interior` :=
 (A::set) -> `if`(nops(A)=1,table({op(A)=1}),FAIL);

`gamma/simplex_interior` := (A::set,B::set) -> (p) -> proc(y,x)
 local a;
 return table({seq(a = x[p[a]][a] * y[p[a]],a in A)});
end:


print "Give a number: ";
var n : int;
read n;
var v : int := 2;
var i : int;
for i in 1..n do
v := v * i;
end for;
print "The result is: ";
print v;
print "\n";


# Definitions for Parallel Robot Dynamics Code Generation
# Einleitung
# Erstelle Definitionen für die Maple-Skripte zur Berechnung von Kinematik und Dynamik des parallelen Roboters
#
# Dateiname:
# robot -> Berechnung für allgemeinen Roboter
# para -> Berechnung für eine parallelen Roboter
# definitions -> Definitionen
# Autor
# Tim Job (Studienarbeit bei Moritz Schappler), 2018-12
# Moritz Schappler, moritz.schappler@imes.uni-hannover.de
# (C) Institut für Mechatronische Systeme, Universität Hannover
# Init
interface(warnlevel=0): # Unterdrücke die folgende Warnung.
restart: # Gibt eine Warnung, wenn über Terminal-Maple mit read gestartet wird.
interface(warnlevel=3):
with(LinearAlgebra):
read "../helper/proc_MatlabExport":
read "../helper/proc_convert_t_s":
# Lese Umgebungsvariable für Codegenerierung.
read "../robot_codegen_definitions/robot_env_par":
printf("Generiere Parameter für %s\n",robot_name):
read sprintf("../codeexport/%s/tmp/tree_floatb_definitions", leg_name):
# Link-Index, für den die Jacobi-Matrix aufgestellt wird. Hier wird angenommen, dass der Endeffektor das letzte Segment (=Link) ist. Die Jacobi-Matrix kann hier aber für beliebige Segmente aufgestellt werden. (0=Basis)
LIJAC:=NL-1:
# Ergebnisse der analytischen Jacobi-Matrix (Translatorisch)
px, py, pz := 0, 0, 0:
alphaxs_base, betays_base, gammazs_base := 0, 0, 0:
read sprintf("../codeexport/%s/tmp/jacobia_transl_%d_maple.m", leg_name, LIJAC):
b_transl := b_transl:
# Lese Umgebungsvariable für Codegenerierung.
read "../robot_codegen_definitions/robot_env_par":
# Additional Definitions
# Parameter definieren, wenn nicht vorher schon geschehen
if not assigned(J_SP) then
   J_SP := Matrix(3,3,[XX,XY,XZ,XY,YY,YZ,XZ,YZ,ZZ]):
end if:
if not assigned(J_P_P) then
   J_P_P := Matrix(3,3,[XXFP,XYFP,XZFP,XYFP,YYFP,YZFP,XZFP,YZFP,ZZFP]):
end if:
if not assigned(xE_s) then
   xE_s:=<x_all[1];x_all[2];x_all[3];x_all[4];x_all[5];x_all[6]>:
end if:

# Gravity vector in world frame
if not assigned(g_world) then
  g_world := Matrix(3, 1):
  g_world(1 .. 3, 1) := <g1, g2, g3>:
end if:

# Parallel Robotics Definitions
# Erstelle für Gelenkkoordinaten, -geschwindigkeiten und -beschleunigungen für jedes Bein
J := simplify(b_transl):
vars := indets(J):
counter := 0:
thetaList := convert(vars,list):
dList := convert(d,list):
for i to NQJ do
  var := parse(sprintf("qJ%ds", i)):
  if has(thetaList, var) then
    counter := counter + 1:
  end if:
  if has(dList, var) then
    counter := counter + 1:
  end if:
end do:
NQJ_parallel := counter:
counter := 0:
for i to ColumnDimension(J) do
  if not(Equal(J(..,i),Vector(3,[0,0,0]))) then
    counter := counter + 1:
  end if:
end do:
NQJ_parallel := counter:

qJ_i_s := Matrix(NQJ_parallel,N_LEGS):
qJD_i_s := Matrix(NQJ_parallel,N_LEGS):
qJDD_i_s := Matrix(NQJ_parallel,N_LEGS):
for i from 1 to NQJ_parallel do
  for j from 1 to N_LEGS do
     k := j-1:
     qJ_i_s(i,j):=parse(sprintf("qJ%ds", i+k*NQJ_parallel)):
     qJD_i_s(i,j):=parse(sprintf("qJD%ds", i+k*NQJ_parallel)):
     qJDD_i_s(i,j):=parse(sprintf("qJDD%ds", i+k*NQJ_parallel)):
  end do:
end do:
# Erstelle Vektor der Basisdrehungen jedes Beines
frame_A_i := Matrix(3,N_LEGS):
for i to N_LEGS do
   for j to 3 do
      if has(indets(leg_frame(4..6)),leg_frame(j+3)) then
         frame_A_i(j,i) := leg_frame(j+3)[i]:
      else
         frame_A_i(j,i) := leg_frame(j+3):
      end if:
   end do:
end do:
# Plattformschwerpunkt
r_P_sP := Vector(3,symbol=r_sP):
s_P_sP := Vector(3,symbol=s_sP):
angleConvLeg := leg_frame(7):
angleConv := xE_s(7):
# Erstelle EE-Koordinaten: xE_t, xED_t, xEDD_t -> Variablen mit Zeitabhängigkeit
#                                          xE_s, xED_s, xEDD_s -> Variablen ohne Zeitabhängigkeit
xE_t:=<xE(t);yE(t);zE(t);PsiE(t);ThetaE(t);PhiE(t)>:
xED_t:=diff~(xE_t,t):
xEDD_t:=diff~(xED_t,t):
# Zähle Freiheitsgrade des Roboters und setze nicht benötigte zu null.
xE_s := Matrix(xE_s(1..6,1)):
xED_s := copy(xE_s):
xEDD_s := copy(xE_s):
FHG_trans := 0:FHG_rot := 0:
counter := 6:
for i to 6 do
   if not(xE_s(i) = 0) then
   	 Tmp := xE_s(i):
      xED_s(i) := D||Tmp:
      xEDD_s(i) := DD||Tmp:
   else
   	 counter := counter - 1:
      xED_s(i) := 0:
      xEDD_s(i) := 0:
      xE_t(i) := 0:
      xED_t(i) := 0:
      xEDD_t(i) := 0:
   end if:
end do:
NX := counter:
counter := 0:
for i from 4 to 6 do
	if not(leg_frame(i) = 0) then
		counter := counter + 1:
	end if:
end do:
legAngles := counter:
# Export
# Maple-Export
save g_world, J_P_P, s_P_sP, NX, NQJ_parallel, angleConvLeg, angleConv, r_P_sP, frame_A_i, qJ_i_s, qJD_i_s, qJDD_i_s, xE_t, xED_t, xEDD_t, xE_s, xED_s, xEDD_s, J_SP, sprintf("../codeexport/%s/tmp/para_definitions", robot_name):
varScript := <NX;NQJ_parallel;legAngles>:
MatlabExport(varScript, sprintf("../codeexport/%s/tmp/var_parallel.m", robot_name), 1);


func $foo ( var %i i32 ) i32
func $fact ( var %n i32) i32
func $fact ( var %n i32) i32
func $foo ( var %i i32 ) i32

func $fact (
 var %n i32) i32 {
 if (ne i32 i32 (dread i32 %n, constval i32 1)) {
    call &foo(
      sub i32 (dread i32 %n, constval i32 1))
    return (regread i32 %%retval)}
   else {
     return (constval i32 1) } }

func $foo ( var %i i32 ) i32 {
  return (dread i32 %i) }
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


type $atyp <[10] f32>
type $aaaa <f32>
var $fff <$atyp>
func $foo ( var %i i32 )i32

func $fact (
 var %n i32, var %m f32) i32 {
 regassign i32 %987 (constval i32 '0')
 if (ne i32 i32 (regread i32 %987, constval i32 10)) {
    eval (regread i32 %987)
    call &foo(
      sub i32 (regread i32 %1, constval i32 1))
    return (regread i32 %%retval)}
   else {
     regassign i32 %987 (constval i32 111)
     return (constval i32 '1') }
 }
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


#!/bin/bash maple
# Use `maple -q expand2.mpl -D n=15` to run

e := (x + y + z + w) ^ n:
f := e * (e + w):

st := time[real]():
f := expand(f):
1000*(time[real]() - st);

done


# The full Eilenberg-Zilber operad EZ has EZ(A) equal to the set of
# natural maps N_*(X) \to N_*(X)^{\otimes A} for simplicial sets X.
# By consideration of universal examples, we see that any such map
# sends N_{\leq n}(X) into (N_{\leq n}(X))^{\otimes A} for all n.
# Thus, if we define EZ_{\leq n}(A) to be the set of natural maps
# N_{\leq n}(X) \to (N_{\leq n}(X))^{\otimes A}, we get a quotient
# operad of EZ.  The group EZ(A) is an infinite product of copies of
# the integers and so is not computationally tractable.  We
# therefore work with EZ_{\leq n} instead.

`is_element/eilenberg_zilber` := (n :: nonnegint) -> (A::set) -> proc(x)
 local y,z,i;

 if x = 0 then return true; fi;

 if type(x,`+`) then
  return `and`(op(map(`is_element/eilenberg_zilber`(n)(A),[op(x)])));
 fi;

 if type(x,`*`) then
  y,z := selectremove(type,[op(x)],integer);
  return (nops(z) = 1 and `is_element/eilenberg_zilber`(n)(A)(z[1]));
 fi;

 if not type(x,specfunc(Z)) then return false; fi;

 if nops(x) = 0 or nops(x) > n+1 then return false; fi;

 for i from 1 to nops(x) do
  if not(`is_element/subsets`(A)(op(i,x))) then
   return false;
  fi;
 od;

 if map(op,{op(x)}) <> A then
  return false;
 fi;

 for i from 1 to nops(x) - 1 do
  if op(i,x) intersect op(i+1,x) = {} then return false; fi;
 od;

 return true;
end:

`is_equal/eilenberg_zilber` := (n::nonnegint) -> (A::set) -> (x,y) -> evalb(x = y):

`random_basis_element/eilenberg_zilber` := (n::nonnegint) -> (A) -> proc(m_)
 local m,t,M,a,i;

 if A = {} then
  if nargs = 0 or m_ = 0 then
   return Z({});
  else
   error("A is empty");
  fi;
 fi;

 m := `if`(nargs > 0,min(n,m_),rand(0..n)());

 t := table():
 M := {seq(i,i=0..m)};

 for a in A do t[a] := random_nonempty_subset_of(M); od;

 for i from 0 to m-1 do
  a := random_element_of(A);
  t[a] := t[a] union {i,i+1};
 od:

 return Z(seq(select(a->member(i,t[a]),A),i=0..m));
end:

`random_element/eilenberg_zilber` := (n::nonnegint) -> (A) -> proc(coeff_range_,num_terms_)
 local coeff_range,num_terms;

 coeff_range := -3..3;
 num_terms := 5;
 if nargs > 0 then coeff_range := args[1]; fi;
 if nargs > 1 then num_terms := args[2]; fi;

 add(rand(coeff_range)() * `random_basis_element/eilenberg_zilber`(n)(A)(),i=1..num_terms);
end:

`transpose0/eilenberg_zilber` := (A::set) -> proc(x)
 local m,M,t,a;

 m := nops(x) - 1;
 M := [seq(i,i=0..m)];
 t := table():
 for a in A do
  t[a] := select(i -> member(a,op(i+1,x)),M);
 od;

 return Zt(eval(t));
end;

`transpose/eilenberg_zilber` := (A::set) ->
 apply_linear(`transpose0/eilenberg_zilber`(A));

`detranspose0/eilenberg_zilber` := (A::set) -> proc(x)
 local t,m;

 t := op(1,x);
 m := max(op(map(op,{{0},seq(t[a],a in A)})));
 return Z(seq(select(a -> member(i,t[a]),A),i=0..m));
end:

`detranspose/eilenberg_zilber` := (A::set) ->
 apply_linear(`detranspose0/eilenberg_zilber`(A));

`eta/eilenberg_zilber` := (n::nonnegint) -> (A::set) ->
 `if`(nops(A)=1,add(Z(A $ k),k=1..(n+1)),FAIL);

`source_degree/eilenberg_zilber` := (A::set) -> proc(x)
 return nops(x) - 1;
end:

`target_degrees/eilenberg_zilber` := (A::set) -> proc(x)
 local xt,d,a;

 xt := op(1,`transpose/eilenberg_zilber`(A)(x));
 d := table();
 for a in A do
  d[a] := nops(xt[a]) - 1;
 od:

 return eval(d);
end:

`gamma0/eilenberg_zilber` := (A::set,B::set) -> (p) -> proc(y,x)
 local F,s,d,t,u,a,b;

 F := fibres(A,B)(p);
 s := op(1,`transpose/eilenberg_zilber`(B)(y));
 d := `target_degrees/eilenberg_zilber`(B)(y);

 t := table():
 for b in B do
  if `source_degree/eilenberg_zilber`(F[b])(x[b]) <> d[b] then
   return 0;
  fi;

  t[b] := op(1,`transpose/eilenberg_zilber`(F[b])(x[b]));
 od;

 u := table();
 for a in A do
  b := p[a];
  u[a] := [seq(s[b][j+1], j in t[b][a])];
 od;

 return `detranspose/eilenberg_zilber`(A)(Zt(u));
end:

`gamma/eilenberg_zilber` := (n::nonnegint) -> (A::set,B::set) -> (p) -> proc(y,x)
 local c,y1,F,d0,BL,M,t,z,b,m,mt;

 if y = 0 then
  return 0;
 elif type(y,`+`) then
  return map(t -> `gamma/eilenberg_zilber`(n)(A,B)(p)(t,x),y);
 fi;

 if type(y,`*`) then
  c,y1 := selectremove(type,y,integer);
 else
  c := 1;
  y1 := y;
 fi;

 if not(type(y1,specfunc(Z))) then
  return FAIL;
 fi;

 F := fibres(A,B)(p);

 d0 := `target_degrees/eilenberg_zilber`(B)(y1);

 BL := sort([op(B)]);
 M := [[1]];
 for b in BL do
  t := map(coeff_split,sum_terms(x[b]));
  t := select(u -> `source_degree/eilenberg_zilber`(F[b])(u[2]) = d0[b],t);
  M := [seq(seq([m[1] * u[1],seq(m[i],i=2..nops(m)),u[2]],u in t),m in M)];
 od:

 z := 0;

 for m in M do
  mt := table([seq(BL[i]=m[i+1],i=1..nops(BL))]);
  z := z + c * m[1] * `gamma0/eilenberg_zilber`(A,B)(p)(y1,mt);
 od;

 return z;
end:


#@ Not autoload

# This was originally written for Mathematica, and needs more
# translation.

#**************************************************************
# the rest of this does not appear in Deligne's formulaire.

# The cubical structure

#h[{{x0_,y0_,z0_},
#   {x1_,y1_,z1_},
#   {x2_,y2_,z2_}}] :=
#     Det[{{x0,y0,z0},{x1,y1,z1},{x2,y2,z2}}] z0 z1 z2 /
#     ( Det[{{x0,z0},{x1,z1}}] *
#       Det[{{x1,z1},{x2,z2}}] *
#       Det[{{x2,z2},{x0,z0}}] )

# z in terms of x where y = 1, valid mod x^10

#zx =
#  x^3 - a1 x^4 + a1^2 x^5 + a2 x^5 - a1^3 x^6 - 2 a1 a2 x^6 - a3 x^6 +
#   a1^4 x^7 + 3 a1^2 a2 x^7 + a2^2 x^7 + 3 a1 a3 x^7 + a4 x^7 - a1^5 x^8 -
#   4 a1^3 a2 x^8 - 3 a1 a2^2 x^8 - 6 a1^2 a3 x^8 - 3 a2 a3 x^8 -
#   3 a1 a4 x^8 + a1^6 x^9 + 5 a1^4 a2 x^9 + 6 a1^2 a2^2 x^9 + a2^3 x^9 +
#   10 a1^3 a3 x^9 + 12 a1 a2 a3 x^9 + 2 a3^2 x^9 + 6 a1^2 a4 x^9 +
#   3 a2 a4 x^9 + a6 x^9

# Invariant differential mod x^10, where y = 1

#omx =
#  dx (-1 + a1 x - a1^2 x^2 - a2 x^2 + a1^3 x^3 + 2 a1 a2 x^3 + 2 a3 x^3 -
#     a1^4 x^4 - 3 a1^2 a2 x^4 - a2^2 x^4 - 6 a1 a3 x^4 - 2 a4 x^4 +
#     a1^5 x^5 + 4 a1^3 a2 x^5 + 3 a1 a2^2 x^5 + 12 a1^2 a3 x^5 +
#     6 a2 a3 x^5 + 6 a1 a4 x^5 - a1^6 x^6 - 5 a1^4 a2 x^6 - 6 a1^2 a2^2 x^6 -
#     a2^3 x^6 - 20 a1^3 a3 x^6 - 24 a1 a2 a3 x^6 - 6 a3^2 x^6 -
#     12 a1^2 a4 x^6 - 6 a2 a4 x^6 - 3 a6 x^6)

# The following functions are invertible near [0:1:0], and
# they satisfy uu ww = vv^3.  Note that vv depends only on y
# and z.  Moreover, {uu != 0} \cap {x = 0} = {0} as schemes.

#uu = y^2 + a1 x y - a2 x^2 + a3 y z - a4 x z - a6 z^2
#vv = y^2 + a3 y z - a6 z^2
#ww = a1^2 x^2 y^2 + a2 x^2 y^2 - a1 x y^3 + y^4 + a2 a3 x^2 y z -
#   2 a1 a4 x^2 y z + a1^2 a2 x y^2 z + a2^2 x y^2 z - a1 a3 x y^2 z +
#   a4 x y^2 z - a1^3 y^3 z - 2 a1 a2 y^3 z + 2 a3 y^3 z + a4^2 x^2 z^2 -
#   a2 a6 x^2 z^2 + a2^2 a3 x y z^2 - 2 a1 a2 a4 x y z^2 + a3 a4 x y z^2 +
#   a1 a6 x y z^2 - 2 a1 a2 a3 y^2 z^2 + a3^2 y^2 z^2 + 3 a1^2 a4 y^2 z^2 +
#   2 a2 a4 y^2 z^2 - 2 a6 y^2 z^2 + a2 a4^2 x z^3 - a2^2 a6 x z^3 -
#   a4 a6 x z^3 + 2 a2 a3 a4 y z^3 - 3 a1 a4^2 y z^3 + 2 a1 a2 a6 y z^3 -
#   2 a3 a6 y z^3 + a4^3 z^4 - 2 a2 a4 a6 z^4 + a6^2 z^4

# We now give some formulae that identify the singular locus.

#Frule = {F  -> HomogeneousCubic,
#         Fx -> D[HomogeneousCubic,x],
#         Fy -> D[HomogeneousCubic,y],
#         Fz -> D[HomogeneousCubic,z]}

#A0 = 4 F - 2 x Fx - (2 y + a3 z) Fy
#A1 = - 2 Fx + a1 Fy
#A2 = 4 a2 z F +
#     - ((a1 a3 + a4) z^2 + (a1^2 + 2 a2) x z + 3 x^2 + a1 y z) Fx +
#     - (a2 a3 z^2 + (a1 a2 + 2 a3) x z + 2 a1 x^2 + (2 a2 z + 4 x) y) Fy
#
#AA0 = 2 x^3 - B4 x z^2 - B6 z^3
#AA1 = 6 x^2 + B2 x z + B4 z^2
#AA2 = x^4 - B4 x^2 z^2 - 2 B6 x z^3 - B8 z^4

#Dl = (-7 B2 B4 z^2 + 27 B6 z^2 - 36 B4 x z + 3 B2 x^2) AA0 +
#     (-8 B4^2 z^3 + 2 B2 B6 z^3 + B2 B4 x z^2 - 9 B6 x z^2 +
#      12 B4 x^2 z - B2 x^3) AA1 +
#      B2^2 z AA2

# The singular point, where Delta = 0 and c4 is invertible.

#xs = 18 b6 - b2 b4

#ys = (a1 a4 - 2 a2 a3) b2 + 12 a3 b4 - 9 a1 b6

#zs = c4

# This evaluates to {0,0,0,0}, showing that [xs:ys:zs] is
# indeed a singular point.

CheckSingular0 =
({F,Fx,Fy,Fz} /. Frule /. {x->xs,y->ys,z->zs}) -
 {-c6,36,0,3 b2} Delta

# The following evaluates to {0,0}.  Because points with z=0
# are smooth and zs = c4 is assumed invertible, we conclude
# that every singular point is projectively equivalent to
# [xs:ys:zs].

CheckSingular1 =
({-2 b2 z Fx -
 (6 a1 x + 12 y - a1 b2 z + 18 a3 z) Fy +
 24 z Fz,
 a1 b2 z Fx +
 (3 a1^2 x + 6 a1 y + (2 a2 b2 - 3 a1 a3 - 24 a4)z ) Fy -
 12 a1 z Fz} /. Frule) -
{ (zs x - xs z) z^2 ,
  (zs y - ys z) z^2}

# Grobner basis for the singular points over the locus where
# c4 = Delta = 2 = 0 (with y > x > a3 > a1 > a6 > a4 > a2)

AdditiveLocusMod2 = {
 y^2 + x^3 + a2 x^2 + a4 x + a6,
 x^2 y + a4 y + a3 x^2 + a2 a3 x + a1 a6 + a3 a4,
 a3 y + x^3 + a4 x,
 a1 y + x^2 + a4,
 x^4 + a3^2 x + a1^2 a6 + a4^2 + a1 a3 a4 + a2 a3^2,
 a3 x^3 + a1^3 a6 + a1 a4^2 + a1^3 a2 a4,
 a1^2 a4^2 + a3^2 x^2,
 a3 + a1 x,
 a3^3 + a1^2 a3 a4,
 a1 a3^2 + a1^3 a4,
 a1^3 a3,
 a1^4}

ReducedAdditiveLocusMod2 = {y^2 + a2 a4 + a6, x^2 + a4, a1, a3}

AdditiveLocusMod3 = {
 y - a1 x - a3,
 a1^4 - a1^2 a2 + a2^2,
 -a3^2 - a6 - a1 a3 x + a4 x - x^3,
 a1 a3 - a4 + a1^2 x + a2 x,
 a1^3 a3 + a1 a2 a3 - a1^2 a4 - a2 a4,
 -(a1^2 a3^2) - a1 a3 a4 - a4^2,
 a1^2 a3^2 + a2 a3^2 + a1^2 a6 + a2 a6 - a1 a3 x^2 + a4 x^2}

ReducedAdditiveLocusMod3 = {
 y - a1 x - a3,
 x^3 + a6 + a3^2,
 a4 - a1 a3,
 a2 + a1^2}

ReducedAdditiveLocusRational = {
 y + a1 x/2 + a3/2,
 x^2 - b2 x/6 - b4/6,
 a6 + a3^2/4 - a2^3/27 - a1^2 a2^2/36 - a1^4 a2/144 - a1^6/1728,
 a4 + a1 a3/2 - a2^2/3 - a1^2 a2/6 - a1^4/48}

#**************************************************************
# Various quotients of localisations of Z[a1,..,a6] that give
# etale maps to the elliptic moduli stack (I think)

# etale1 covers D(6 c6)

etale1 = {a1 -> 0, a2 -> 0, a3 -> 0, a6 -> 1}

# etale2 covers D(6 c4)

etale2 = {a1 -> 0, a3 -> 0, a2 -> 0, a4 -> 1}

# etale3 covers a neighbourhood of V(2) D(c4)

etale3 = {a1 -> 1, a3 -> 0, a2 -> 0, a4 -> 0}

# etale4 covers a neighbourhood of V(3) D(c4)

etale4 = {a1 -> 0, a3 -> 0, a2 -> 1, a4 -> 0}

# etale5 covers a neighbourhood of V(2,a1) ; etale over D(3)

etale5 = {a3 -> 1, a2 -> 0, a4 -> 0, a6 -> 0}

# etale6 covers a neighbourhood of V(3,a2) ; etale over D(2)

etale6 = {a1 -> 0, a3 -> 0, a4 -> 1, a6 -> 0}

# Det[Jac[etale6,a2]] (for example) is the Jacobian
# determinant for the map
#
#  Z[a1,a2,a3,a4,a6] -> Z[v,r,s,t,a2]
#
# (where v = 1/u) given by alpha.  This must be invertible for
# the map to be etale.

Jac[er_,aa_] :=
 Outer[D,
  FixedPoint[Expand[# /. er /. u -> 1/v]&, alpha /@ {a1,a3,a2,a4,a6}],
  {v,r,s,t,aa}
 ]

#**************************************************************
# Singular fibres

# The curve y^2 z + x y z = x^3 is a nodal cubic, with
# multiplicative formal group.

multcurve = {a1->1, a3->0, a2->0, a4->0, a6->0}

# There is a birational map f from P^1 to the curve, with
# inverse g.	This sends both 0 and infinity to the singular
# point [0:0:1], and the restriction to G_m is a homomorphism.
# The discriminant is zero and the j invariant is infinite.

fm[s_,t_] := {s t (s - t), t^2 s, (s - t)^3}

gm[x_,y_,z_] := {y + x, y}

# The curve y^2 = x^3 is a cuspidal cubic, with additive
# formal group.

addcurve = {a1->0, a3->0, a2->0, a4->0, a6->0}

# There is a birational map f from P^1 to the curve, with
# inverse g.	This sends infinity to the singular point
# [0:0:1] with multiplicity two, and the restriction to G_a is
# a homomorphism the discriminant is zero and the j invariant
# is undefined.

fa[s_,t_] := {t^2 s, t^3, s^3}

ga[x_,y_,z_] := {x, y}

#**************************************************************
# Curves with prescribed j invariant

# This curve is defined if jj - 1728 is invertible, and is
# nonsingular if jj is also invertible.  It has
# c4 = - c6 = jj/(jj - 1728) and Delta = jj^2 / (jj - 1728)^3
# and j = jj (unless jj = 0, in which case j is undefined).

# jcurve[0] corresponds to the curve (y + x/2)^2 =(x + 1/12)^3

jcurve[jj_] :=
 {a1 -> 1, a2 -> 0, a3 -> 0,
  a4 -> 36/(1728 - jj), a6 -> 1/(1728 - jj)}

#**************************************************************
# Legendre curve.  This is defined where 2 is invertible and
# lm != 0 or 1.  The points of order two are
# P = [0:0:1] and Q = [1:0:1] and P+Q = [lm:0:1].  An invariant
# differential is given by om = -dx/y.  This is the universal
# example of a curve with an invariant differential and a
# level two structure such that x(P) = 0 and x(Q) = 1, where
# x is the unique choice adapted to om with a1 = a3 = 0.

# c4    = 16(1 - lm + lm^2)
# c6    = 32(lm - 2)(lm + 1)(2 lm - 1)
# Delta = 16 lm^2 (lm - 1)^2
# j     = 256 (1 - lm + lm^2)^3 / ((lm - 1)^2 lm^2)

legendre = {a1 -> 0, a3 -> 0, a2 -> -(lm + 1), a4 -> lm, a6 -> 0}

#**************************************************************
# Jacobi quartic.

# c4    = 2^6 3^4 (dl^2 + 3 ep)
# c6    = 2^9 3^6 (dl^3 - 9 dl ep)
# Delta = 2^12 3^12 ep (ep - dl^2)^2
# j     = 64 (dl^2 + 3 ep)^3 / (ep (ep - dl^2)^2)

jacobi_rule :=
 {a1 = 0, a3 = 0, a2 = 0, a4 = -108 dl^2 - 324 ep, a6 = 3888 dl ep - 432 dl^3}

xXY := (6*(-2*dl - dl^2*X^2 + 3*ep*X^2 + 2*dl*Y))/(-1 + dl*X^2 + Y);
yXY := (108*(dl^2 - ep)*X)/(-1 + dl*X^2 + Y);

Xxy = (6*(12*dl - x))/y
Yxy = (2592*dl^3 - 7776*dl*ep + 216*dl^2*x + 648*ep*x -
       36*dl*x^2 + y^2)/y^2

# In quartic form, the zero element is (0,1).

jacobiquartic = Y^2 - (1 - 2 dl X^2 + ep X^4)

# invariant differential

omegaXY = -dX/(6 Y)

# This can also be written as \sum_n P_n(dl,ep) X^(2n) dX
# where P_n(dl,ep)=P_n(dl/Sqrt[ep]) ep^(n/2) and P_n(t) is the
# Legendre polynomial.  These are defined by
# (1 -2xt +t^2)^(-1/2) = \sum_n P_n(x) t^n

# There is a canonical point P of order 2: (x,y)=(12 dl,0).
# Apparently this is the universal example of a curve with an
# invariant differential and a point of exact order 2 (where
# 2 is invertible).  Apparently also
# div(X) = [2]^{-1}[0] - [2]^{-1}[P]

# It seems that if six is invertible and we have a given point
# P of order 2, we can put the curve in the form
# y^2 = x^3 + a4 x + a6 and then P = (12 dl,0) say and we can
# define ep = -(4 a4 + 432 dl^2)/1296 to put the curve in
# Jacobi form.  I'm not sure this is right, though.

#**************************************************************

# Formal group formulae, valid up to terms of weight 7.

F = x0 + x1 + a1*x0*x1 - a2*x0^2*x1 + 2*a3*x0^3*x1 - 2*a1*a3*x0^4*x1 -
 2*a4*x0^4*x1 + 2*a1^2*a3*x0^5*x1 + 2*a2*a3*x0^5*x1 + 2*a1*a4*x0^5*x1 -
 2*a1^3*a3*x0^6*x1 - 4*a1*a2*a3*x0^6*x1 - 2*a3^2*x0^6*x1 -
 2*a1^2*a4*x0^6*x1 - 2*a2*a4*x0^6*x1 - 3*a6*x0^6*x1 - a2*x0*x1^2 -
 a1*a2*x0^2*x1^2 + 3*a3*x0^2*x1^2 + a2^2*x0^3*x1^2 - a1*a3*x0^3*x1^2 -
 4*a4*x0^3*x1^2 + a1^2*a3*x0^4*x1^2 + a1*a4*x0^4*x1^2 - a1^3*a3*x0^5*x1^2 -
 a1*a2*a3*x0^5*x1^2 - a1^2*a4*x0^5*x1^2 - 9*a6*x0^5*x1^2 + 2*a3*x0*x1^3 +
 a2^2*x0^2*x1^3 - a1*a3*x0^2*x1^3 - 4*a4*x0^2*x1^3 + a1*a2^2*x0^3*x1^3 +
 a1^2*a3*x0^3*x1^3 - 2*a2*a3*x0^3*x1^3 - a2^3*x0^4*x1^3 - a1^3*a3*x0^4*x1^3 -
 2*a1*a2*a3*x0^4*x1^3 + 4*a3^2*x0^4*x1^3 - a1^2*a4*x0^4*x1^3 +
 4*a2*a4*x0^4*x1^3 - 15*a6*x0^4*x1^3 - 2*a1*a3*x0*x1^4 - 2*a4*x0*x1^4 +
 a1^2*a3*x0^2*x1^4 + a1*a4*x0^2*x1^4 - a2^3*x0^3*x1^4 - a1^3*a3*x0^3*x1^4 -
 2*a1*a2*a3*x0^3*x1^4 + 4*a3^2*x0^3*x1^4 - a1^2*a4*x0^3*x1^4 +
 4*a2*a4*x0^3*x1^4 - 15*a6*x0^3*x1^4 + 2*a1^2*a3*x0*x1^5 + 2*a2*a3*x0*x1^5 +
 2*a1*a4*x0*x1^5 - a1^3*a3*x0^2*x1^5 - a1*a2*a3*x0^2*x1^5 -
 a1^2*a4*x0^2*x1^5 - 9*a6*x0^2*x1^5 - 2*a1^3*a3*x0*x1^6 -
 4*a1*a2*a3*x0*x1^6 - 2*a3^2*x0*x1^6 - 2*a1^2*a4*x0*x1^6 - 2*a2*a4*x0*x1^6 -
 3*a6*x0*x1^6

logF =
 x - (a1*x^2)/2 + (a1^2*x^3)/3 + (a2*x^3)/3 - (a1^3*x^4)/4 - (a1*a2*x^4)/2 -
 (a3*x^4)/2 + (a1^4*x^5)/5 + (3*a1^2*a2*x^5)/5 + (a2^2*x^5)/5 +
 (6*a1*a3*x^5)/5 + (2*a4*x^5)/5 - (a1^5*x^6)/6 - (2*a1^3*a2*x^6)/3 -
 (a1*a2^2*x^6)/2 - 2*a1^2*a3*x^6 - a2*a3*x^6 - a1*a4*x^6 + (a1^6*x^7)/7 +
 (5*a1^4*a2*x^7)/7 + (6*a1^2*a2^2*x^7)/7 + (a2^3*x^7)/7 +
 (20*a1^3*a3*x^7)/7 + (24*a1*a2*a3*x^7)/7 + (6*a3^2*x^7)/7 +
 (12*a1^2*a4*x^7)/7 + (6*a2*a4*x^7)/7 + (3*a6*x^7)/7

# ms[k] is the [k] series.

ms[-1] =
 -x + a1*x^2 - a1^2*x^3 + a1^3*x^4 + a3*x^4 - a1^4*x^5 - 3*a1*a3*x^5 +
 a1^5*x^6 + 6*a1^2*a3*x^6 + a2*a3*x^6 - a1^6*x^7 - 10*a1^3*a3*x^7 -
 4*a1*a2*a3*x^7 - 2*a3^2*x^7 + a1^7*x^8 + 15*a1^4*a3*x^8 +
 10*a1^2*a2*a3*x^8 + a2^2*a3*x^8 + 10*a1*a3^2*x^8 + a3*a4*x^8 - a1^8*x^9 -
 21*a1^5*a3*x^9 - 20*a1^3*a2*a3*x^9 - 5*a1*a2^2*a3*x^9 - 30*a1^2*a3^2*x^9 -
 5*a2*a3^2*x^9 - 5*a1*a3*a4*x^9

ms[2] =
 2*x + a1*x^2 - 2*a2*x^3 - a1*a2*x^4 + 7*a3*x^4 + 2*a2^2*x^5 - 6*a1*a3*x^5 -
 12*a4*x^5 + a1*a2^2*x^6 + 7*a1^2*a3*x^6 + 2*a2*a3*x^6 + 6*a1*a4*x^6 -
 2*a2^3*x^7 - 8*a1^3*a3*x^7 - 14*a1*a2*a3*x^7 + 4*a3^2*x^7 - 8*a1^2*a4*x^7 +
 4*a2*a4*x^7 - 54*a6*x^7

ms[3] =
 3*x + 3*a1*x^2 + a1^2*x^3 - 8*a2*x^3 - 12*a1*a2*x^4 + 39*a3*x^4 -
 6*a1^2*a2*x^5 + 24*a2^2*x^5 - 9*a1*a3*x^5 - 96*a4*x^5 - a1^3*a2*x^6 +
 44*a1*a2^2*x^6 + 30*a1^2*a3*x^6 - 57*a2*a3*x^6 - 48*a1*a4*x^6 +
 30*a1^2*a2^2*x^7 - 72*a2^3*x^7 - 36*a1^3*a3*x^7 - 168*a1*a2*a3*x^7 +
 234*a3^2*x^7 - 72*a1^2*a4*x^7 + 288*a2*a4*x^7 - 936*a6*x^7

ms[5] =
 5*x + 10*a1*x^2 + 10*a1^2*x^3 - 40*a2*x^3 + 5*a1^3*x^4 - 140*a1*a2*x^4 +
 310*a3*x^4 + a1^4*x^5 - 222*a1^2*a2*x^5 + 376*a2^2*x^5 + 306*a1*a3*x^5 -
 1248*a4*x^5 - 205*a1^3*a2*x^6 + 1740*a1*a2^2*x^6 + 620*a1^2*a3*x^6 -
 2130*a2*a3*x^6 - 3120*a1*a4*x^6 - 120*a1^4*a2*x^7 + 3750*a1^2*a2^2*x^7 -
 3560*a2^3*x^7 - 90*a1^3*a3*x^7 - 9540*a1*a2*a3*x^7 + 10540*a3^2*x^7 -
 5800*a1^2*a4*x^7 + 14240*a2*a4*x^7 - 33480*a6*x^7

Null[];


program change;
var n, count : integer;
begin
    writeln('please input change');
    readln(n);
    count := 0;
    while n > 0 do begin
        while n >= 10 do begin
            while n >= 100 do begin
                while n >= 1000 do begin
                    while n >= 10000 do begin
                        count := count + 1;
                        n := n - 10000;
                    end;
                    if count > 0 then
                        writeln('10000 yen : ', count);
                    count := 0;
                    if n < 1000 then
                        break;
                    count := count + 1;
                    n := n - 1000;
                end;
                if count > 0 then
                    writeln(' 1000 yen : ', count);
                count := 0;
                if n < 100 then
                    break;
                count := count + 1;
                n := n - 100;
            end;
            if count > 0 then
                writeln('  100 yen : ', count);
            count := 0;
            if n < 10 then
                break;
            count := count + 1;
            n := n - 10;
        end;
        if count > 0 then
            writeln('   10 yen : ', count);
        count := 0;
        if n < 1 then
            break;
        count := count + 1;
        n := n - 1;
    end;
    if count > 0 then
        writeln('    1 yen : ', count);
end.


# Kinematik-Berechnung 3. Arm KAS5
# Beschreibung
#
# Modell ohne Zwangsbedingungen. Diese Definitionsdatei erzeugt Dummy-Variablen, damit die Code-Generierung funktioniert.
#
# Die Gelenkvariablen der Schnittgelenke sollen nicht berechnet werden und sind als konstante Ausdrücke in kintmp_s vorgegeben und werden später mit Null ersetzt.
#

# Autor
# Moritz Schappler, schappler@imes.uni-hannover.de, 2018-02
# Institut fuer mechatronische Systeme, Leibniz Universitaet Hannover
# Initialisierung
interface(warnlevel=0): # Unterdrücke die folgende Warnung.
restart: # Gibt eine Warnung, wenn über Terminal-Maple mit read gestartet wird.
interface(warnlevel=3):
kin_constraints_exist := true: # Für Speicherung
;
with(LinearAlgebra):
with(StringTools): # Für Zeitausgabe
;
read "../helper/proc_convert_s_t":
read "../helper/proc_convert_t_s":
read "../helper/proc_MatlabExport":
codegen_act := true:
read "../robot_codegen_constraints/proc_subs_kintmp_exp":
read "../robot_codegen_definitions/robot_env":
read sprintf("../codeexport/%s/tmp/tree_floatb_definitions", robot_name):
kin_constraints_exist := true:
# Zwangsbedingungen auslesen und Nachverarbeiten
# Lese Ergebnisse der Kinematik von KAS5m7 aus.
# Entferne dort die Ersetzungsausdrücke
read  sprintf("../codeexport/KAS5m7TE/tmp/kinematic_constraints_maple_inert.m", robot_name):
kintmp_qs := kintmp_qs:
kintmp_qt := kintmp_qt:
kintmp_subsexp := kintmp_subsexp:
# Ausdrücke entfernen
kintmp_subsexp := kintmp_subsexp*0:
#
# Speichern der Ergebnisse
save kin_constraints_exist, kintmp_qs, kintmp_qt, kintmp_subsexp, sprintf("../codeexport/%s/tmp/kinematic_constraints_maple_inert", robot_name):
save kin_constraints_exist, kintmp_qs, kintmp_qt, kintmp_subsexp, sprintf("../codeexport/%s/tmp/kinematic_constraints_maple_inert.m", robot_name):
# Liste der Parameter speichern
# Liste mit abhängigen konstanten Kinematikparametern erstellen (wichtig für Matlab-Funktionsgenerierung)
read "../helper/proc_list_constant_expressions";
kc_symbols := Matrix(list_constant_expressions( kintmp_qs )):
save kc_symbols, sprintf("../codeexport/%s/tmp/kinematic_constraints_symbols_list_maple", robot_name):
kintmp_s:


# 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.)
# TODO: decide if this should be kept

# KB, short for knowledge base, is an 'abstract' representation
# of constraints on bound variables. Abstractly, it is a (boolean) conjunction
# of clauses, each of which is of one of the following forms:
#  - Introduce(n::Name,t::HakaruType)
#      introduces a new variable "n : t" which scopes over
#      the 'rest' of the KB (to the right (?))
#  - Let(n::Name,e::Hakaru)
#      introduces a new variable "n" which scopes over the rest
#      of the KB whose value is precisely "e"
#  - Constrain(c::Constraint) where
#      where Constraint is essentially a boolean-valued expression
#      on Hakaru terms, containing equalities, inequalities,
#      and boolean algebra on such
KB := module ()
  option package;
  local
     # The 'constructors' of a KB, which should not be used externally to the module
     KB, Introduce, Let, Constrain,

     # Experimental KB which allows one 'level' of a KB to be a partition along
     # a particular dimension/variable.  Under that split, what is below are other
     # layers of SplitKB.  A KB is a degenerate case of a KB with no split.
     SplitKB,

     # Some sort of hideous hack to get built-in maple
     # functions (assuming,eval,is...) to work with
     # Hakaru types
     chilled,

     ModuleLoad, ModuleUnload,

     # Various utilities
     t_intro, t_lo, t_hi, log_metric,
     boolean_if, coalesce_bounds, htype_to_property, bad_assumption, bad_assumption_pw

     ;
  export
     # Functions which build up KBs from KBs and other pieces
     #  typically ensuring that internal invariants are upheld
     # (i.e. 'smart' constructors)
      empty, genLebesgue, genType, genSummation, genIntVar, genLet,
      assert, assert_deny, assert_mb, assert_deny_mb, build_kb,

     # for debugging
     build_unsafely,

     chill, warm,

     # Negation of 'Constrain' atoms, that is, equality and
     # inequality constraints
     negated_relation, negate_rel, negate_rels,

     # "kb0 - kb1" - that is, kb0 without the knowledge of kb1
     kb_subtract,

     # kb_entails(kb,cond) = "kb => cond"
     kb_entails,

     # Simplify a Hakaru term assuming the knowledge of the kb
     # variants do different things in case of simplification error
     # (which should really only occur when the KB contains a contradicition)
     kb_assuming_mb, simplify_assuming, simplify_assuming_mb, simplify_assuming_f,

     # Gets the most refined (see refine_given) type of a given name under the
     # assumptions of the KB; & convert such a type to a range.
     getType,

     # Various 'views' of the KB, in that they take a KB and produce something
     # which is somehow 'representative' of the KB
     kb_to_variables, kb_to_assumptions, kb_to_constraints, kb_to_equations, kb_piecewise, kb_Partition,

     kb_atom_to_assumptions,

     # Various utilities ...
     list_of_mul, for_poly, range_of_HInt, eval_kb, kb_is_false, try_improve_exp,

     # Types corresponding to the constructor forms of the 'atoms' of KBs
     t_kb_Introduce, t_kb_Let, t_kb_Bound, t_kb_Constrain;
  global
     # The type of KBs. It is 'assumed' that things 'with this type'
     # are actually KBs in the proper form
     t_kb, t_kb_atom, t_kb_atoms,

     # Things which should produce a KB, but sometimes don't return this
     # expression
     NotAKB,

     # kb_LMS produces NoSol when it doesn't find a solution.
     NoSol,

     # Some silly things that KB must do to appease
     # Maple when using Maple functions to work with
     # Hakaru 'terms'.
     `expand/product`, `simplify/int/simplify`,
     `product/indef/indef`, `convert/Beta`;
  uses Hakaru, SolveTools:-Inequality ;

  # The type of introductions about which we want to pass some useful
  # information to Maple.
  t_intro := 'Introduce(name, And(t_type, Not(specfunc({HMeasure,HFunction}))))';

  # Low and high bounds (?)
  t_lo    := 'identical(`>`,`>=`)';
  t_hi    := 'identical(`<`,`<=`)';

  # The 'constructor' forms of KB
  t_kb_Introduce := 'Introduce(name, anything)';
  t_kb_Let       := 'Let(name, anything)';
  t_kb_Bound     := 'Bound(name, anything, anything)';
  t_kb_Constrain := 'Constrain(anything)';

  # The empty KB means "true".
  empty := KB();

  # The false KB
  NotAKB := proc($)
      'procname'()
  end proc;

  # Check if a kb which might be NotAKB is indeed NotAKB
  kb_is_false := proc(mbkb :: t_kb_mb, $) evalb(mbkb :: t_not_a_kb) end proc;

  # A smart constructor for introducing Lebesgue integration variables (?)
  #   genLebesgue(var,lo,hi,kb) =
  #     "KB(Introduce(x::AlmostEveryReal(x>lo,x<hi))
  #        ,kb)"
  genLebesgue := genIntVar(proc(lo,hi,$) `AlmostEveryReal`(Bound(`>`,lo), Bound(`<`, hi)) end proc);

  # Another type of integration variable
  genSummation := genIntVar(proc(lo,hi,$) `HInt`(Bound(`>=`,lo), Bound(`<=`, hi)) end proc);

  # A smart constructor for 'integration' (of which summation is a variety)
  # variables.
  genIntVar := proc (kind,$) proc(xx::name, lo, hi, kb::t_kb)
      genType(xx, kind(lo,hi), kb, _rest);
  end proc; end proc;

  # A smart constructor for type introductions. ensures name binding
  # is done correctly.
  #   genType(var,type,kb) =
  #     "KB(Introduce(x::type),kb)"
  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([tt,kb,_rest], xx), gensym(xx), xx);
    t := subsindets(tt, identical(Bound(`>` , -infinity),
                                  Bound(`>=`, -infinity),
                                  Bound(`<` ,  infinity),
                                  Bound(`<=`,  infinity)), _->NULL);
    x, KB(Introduce(x, t), op(kb));
  end proc;

  # A smart constructor for 'let' introductions. ensures name binding
  # is done correctly.
  #   genLet(var,expr,kb) =
  #     "KB(Let(var=expr),kb)"
  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;

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

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

  negate_rels := proc(e, $)
      subsindets(e, { specfunc(relation, `Not`), `not`(relation) }, negate_rel@op );
  end proc;

  # Builds a kb from a list of atoms - simply foldr(assert,empty,as) except
  # and extra check is (optionally) done for the resulting KB to be valid.
  build_kb := proc(as::t_kb_atoms, shouldBeValid::{identical(false),string} := false, initKb::t_kb := empty, $)
      local
      kb := initKb;

      kb := foldr(assert,kb, op(as));
      if shouldBeValid :: string then
          ASSERT(type(kb,t_kb), sprintf("%s (in build_kb): KB contains a contradiction.", shouldBeValid));
      end if;
      kb
  end proc;

  assert_mb := proc(b::t_kb_atom, mkb::t_kb_mb, $)
      if mkb :: t_kb then
          assert(b,mkb);
      else
          NotAKB();
      end if;
  end proc;

  assert_deny_mb := proc(bb0::t_kb_atom, pol::identical(true,false), kb::t_kb_mb, $)
      if kb :: t_kb then
          assert_deny(bb0,pol,kb);
      else
          NotAKB();
      end if;
  end proc;

  # Like assert_deny, except does not accept a boolean
  # parameter to indicate negation, and evaluates
  # (using Maple's eval, anything can happen!) the
  # new conjunct under the derived knowledge of the KB
  assert := proc(b::t_kb_atom, kb::t_kb, $)
    assert_deny(foldl(eval, b, op(kb_to_equations(kb))), true, kb)
  end proc;

  # Implements the assert_deny function, which inserts either
  # a constraint or its negation into a KB, essentially, a
  # 'smart constructor'.
  # Also implements a second way to call it, 'part', which will
  # return a SplitKB instead.
  assert_deny := module ()
   export ModuleApply;
   local t_if_and_or_of, t_not, t_constraint_flipped, bound_simp, not_bound_simp, postproc_for_solve,
         refine_given, t_bound_on, simplify_in_context, expr_indp_errMsg, rel_coulditbe;

   # Either And or Or type, chosen by boolean pol
   t_if_and_or_of := proc(pol,$)
       `if`(pol, '{specfunc(anything, And), `and`}', '{specfunc(anything, Or ), `or` }')
   end proc;

   # The 'type' of `not(..)` statements
   t_not := '{specfunc(anything, Not), `not`}';

   # The type representing equalities
   # between something which is neither a name nor 'size' applied to a name
   # and another thing which is a name which is neither constant nor undefined
   t_constraint_flipped := 'Not({name, size(name)}) = Name';

   # The 'type' representing bounds on `x', where `x' is a name
   t_bound_on := proc(x,$) And(relation, Or(anyop(identical(x), freeof(x)), anyop(freeof(x), identical(x)))) end proc;

   # Given (TODO: add these types to the function(?))
   #   k  :: HakaruType
   #   kb :: t_kb
   #   x  :: name
   #   c  :: type
   # a bound name "x" of type "k", produces a 'refinement' of the
   # type "k", which is a type more specific than "k" at which
   # the name "x" is well-typed given the knowledge in the KB,
   # i.e. the conjunction of "x :: $result" with "kb" gives
   # "x :: k" inside the KB
   #
   # Note that if the list is non-empty, the refined knowledge
   #   is given by the first element of the list, and if it
   #   is empty, no refinement is possible.
   #
   # Original enlightenment:
   #   hakaru-dev/hakaru/commit/02b9335669e00921a57c3d2a65a1f5f9f6162aa4
   refine_given := proc(k,kb,x,c,$)
       [ op(map2(subsop
                , 1=NULL
                , select(type, kb, Bound(identical(x), c, anything))
                )
           )
       , op(select(type, k , Bound(              c, anything)) )
       ]
   end proc;

   # Performs simplification(?) in case something of the form `t_bound_on` is
   # found
   # This function signals it has failed to find a result with `FAIL`
   bound_simp := proc(b,x,k,kb,pol,as,$)
      local e, rel, c, kb1,ch;
      # 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);

      # Account for the symmetric cases of `x' being on the left or right
      # hand side; the predicate is modified(?) in case of a 'flip'
      if x = lhs(b) then
        e := rhs(b);
      else #x=rhs(b)
        e   := lhs(b);
        rel := subs({`<`=`>`, `<=`=`>=`}, rel);
      end if;

      # Change relations to their negations if `pol = false'
      if not pol then
        # A 'table' giving the negations of relations
        rel := subs({`<`=`>=`, `<=`=`>`, `>`=`<=`, `>=`=`<`, `=`=`<>`, `<>`=`=`}, rel);
      end if;

      # Make inequalities loose over Real
      # Warning: other code relies on this!!!
      if k :: 'specfunc(AlmostEveryReal)' then
        # A 'table' giving the relaxation of strict relations
        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 := refine_given(k,kb,x,c);
          if nops(c)>0 then
            kb1 := assert_deny_mb(op([1,1],c)(e,op([1,2],c)), true, kb1)
          end if
        end do;
        return kb1
      end if;

      ch := chill(e);
      if rel = `<>` then
        # Refine <> to > or < if possible.
        if   is(x<=ch) assuming op(as) then rel := `<`
        elif is(x>=ch) 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 := `>=`;
          ch  := floor(ch)+1 assuming op(as);
          e   := warm(ch)
        elif rel = `<` then
          rel := `<=`;
          ch  := ceil(ch)-1 assuming op(as);
          e   := warm(ch)
        end if
      end if;

      # Look up the current bound on x, if any.
      c := `if`(rel :: t_lo, t_lo, t_hi);
      c := refine_given(k,kb,x,c);

      # chill but also unwraps `c' (?)
      if nops(c) > 0 then c := chill(op(1,c)) end if;

      # 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,ch)) assuming
                              (op(1,c)(y,op(2,c)),
                               y::htype_to_property(k), op(as)) ) then
          # The old bound renders the new bound superfluous.
          return kb

      # "assuming" used to be in a try which would
      # cause the return to never be reached if it threw, but now it
      # produces FAIL instead - and `_x or FAIL = FAIL'
      elif nops(c)=0 or (is(op(1,c)(y,op(2,c))) assuming
                             (rel(y,ch),
                              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;

      FAIL; # No simplification could be done
   end proc;

   # Simplification when the `:: t_bound_on' predicate is false
   # note: k is ignored, but this makes the API the same as
   # bound_simp
   not_bound_simp := proc(b,x,k,kb,pol,as,$)
     local c, bad;
     if _Env_HakaruSolve=false then return FAIL; end if;
     if x::relation then
       userinfo(6, 'KB', printf("Chose not to solve %a\n",x));
       return FAIL;
     end if;

     # don't even try to solve bad cases, we might get a RootOf !
     bad := select(depends, indets(b, specfunc(chilled)),x);
     if not (bad = {}) then return FAIL; end if;

     # otherwise go ahead
     try
       c := solve({chill(b)},[x], 'useassumptions'=true) assuming op(as);
       postproc_for_solve((x,kb)->assert_deny_mb(x,pol,kb), warm(c), kb, as);
     catch "when calling '%1'. Received: 'side relations must be polynomials in (name or function) variables'":
       WARNING( sprintf( "siderels bug:\n\t'%s'\nwhen calling solve(%%1, %%2) assuming (%%3)"
                         , StringTools[FormatMessage](lastexception[2..-1])), b, x, as );
       return FAIL;
     end try;
   end proc;

   postproc_for_solve := proc(reduce_op, c, kb, as, $)
     local p, c0, c1;
     if c :: list and nops(c) = 0 then # false
       return FAIL;

     elif c :: list({relation, specfunc(`And`), `and`}) then # conjunction
       c0 := map(c -> if c::{specfunc(`And`),`and`} then op(c) else c end if,c);
       return foldr(((z,kb)->postproc_for_solve(reduce_op, z, kb, as)), kb, op(c0));

     elif c :: list then # disjunction
       if nops(c)=1 then
         return postproc_for_solve(reduce_op, op(1,c), kb, as);
       else
         return FAIL;
       end if;

     elif c :: {relation,specfunc(`Not`)} then # atom
       return reduce_op(c, kb);

     elif c :: specfunc(`piecewise`) then # try to make it into a conjunction
       p := Partition:-PWToPartition(c);
       p := apply(Partition:-Simpl:-remove_false_pieces,p) assuming op(as);
       c0, c1 := Partition:-Simpl:-single_nonzero_piece(p, _testzero=(x->x=[]));
       if not c0 :: identical(true) then
         if c1 :: relation then
         elif c1 :: list and nops(c1) = 1 then
             c1 := op(1,c1);
             if c1 :: list then c1 := op(c1) end if;
         else
             return FAIL;
         end if;
         try return postproc_for_solve(reduce_op, [ c0, c1 ], kb, as);
         catch "when calling '%1'. Received: 'cannot assume on a constant object'": NULL; end try;
       end if;
       return FAIL;
     end if;

     error "don't know what to do with %1 (in ctx %2, %3)", c, as, kb;
   end proc;

   # Simplify `bb' in context `as'
   simplify_in_context := proc(bb, as, $)
     local b;
     b := chill(bb);
     b := simplify(b) assuming op(as);
     warm(b);
   end proc;

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

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

   # Given a constraint "bb" on a KB "kb", this
   #   inserts either "bb" (if "pol" is true) or "Not bb" (otherwise)
   #   or, KB(Constrain(`if`(pol,bb,Not(bb))), kb)
   # Great deal of magic happens behind the scenes
   ModuleApply := proc(bb0::t_kb_atom, pol::identical(true,false), kb::t_kb)
    # Add `if`(pol,bb,Not(bb)) to kb and return the resulting KB.
    local as, bb, bbv, b, k, x, log_b, todo, kb0, ch;
    bb := bb0;

    if bb = pol then
      # Ignore literal true and Not(false).
      kb

    elif bb :: t_if_and_or_of(pol) then
      foldr(((b,kb) -> assert_deny_mb(b, pol, kb)), kb, op(bb))

    elif bb :: t_not then
      foldr(((b,kb) -> assert_deny_mb(b, not pol, kb)), kb, op(bb))

    else
      as := chill(kb_to_assumptions(kb, bb));
      bb := chill(bb);

      # try to evaluate under the assumptions, but some assumptions break
      # with eval, so remove any of those we tried to chill to prevent them breaking
      bb := subsindets(bb, relation, x->map(eval,x) assuming(op(as)));

      # Check that the new clause would not cause a contradictory
      # KB. If it does, then produce NotAKB.
      if not bad_assumption(bb) and not rel_coulditbe(`if`(pol,bb,not(bb)), as) then
          return NotAKB();
      end if;

      b := simplify_in_context(bb, as);

      # 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 that scope is not precisely the trivial KB, then ..
      if nops(k) > 0 then
        x, k := op(op(1,k));
        # Found the innermost scope where b makes sense.
        # Reduce (in)equality between exp(A) and exp(B) to between A and B.
        b := try_improve_exp(b, x, as);

        # syntactic adjustment
        # If `b' is of a particular form (a bound on `x'), simplification
        # is in order
        if not b::`::` then
          todo := `if`(b :: t_bound_on(`x`), bound_simp, not_bound_simp);
          kb0 := todo(b,x,k,kb,pol,as);

          # If it succeeds, return that result
          if not kb0 :: identical(FAIL) then return kb0 end if;
        end if;
      end if;

      # Normalize `=` and `<>` constraints a bit.
      if not pol then
        b := negate_rel(b);
      end if;

      # If the name in the simple equality (if it is such) is not
      # on the lhs, then flip the equality
      if b :: t_constraint_flipped then b := (rhs(b)=lhs(b)) end if;

      # If `b' reduces to `true' in the KB environment then there is no need to
      # add it
      ch := chill(b);
      try
        if is(ch) assuming op(as) then return kb end if;
      catch "when calling '%1'. Received: 'side relations must be polynomials in (name or function) variables'":
        WARNING( sprintf( "siderels bug:\n\t'%s'\nwhen calling is(%%1) assuming (%%2)"
                        , StringTools[FormatMessage](lastexception[2..-1])), b, as );
      end try;

      # Add constraint to KB.
      KB(Constrain(b), op(kb))
    end if;
   end proc: # ModuleApply
  end module; # assert_deny

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

  # This should be local to KB (or even to assert_deny) but it is used
  # by Domain.
  try_improve_exp := proc(b0, x, ctx, $)
        local b := b0, log_b;
        do
          try log_b := map(simplify@ln, b) assuming op(ctx); catch: break; end try;

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

  # 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"
  boolean_if := proc(cond, th, el, $)
    use
      a = ((x,y)-> `if`(x=true,y, `if`(x=false,x,
                   `if`(y=true,x, `if`(y=false,y, And(x,y)))))),
      o = ((x,y)-> `if`(x=false,y, `if`(x=true,x,
                   `if`(y=false,x, `if`(y=true,y, Or (x,y)))))),
      n = (x    -> `if`(x=false,true,
                   `if`(x=true,false,             Not(x))))
    in
      o(a(cond,th), a(n(cond),el))
    end use
  end proc;

  # Given that kb is an extension of kb0
  # (in that all the knowledge in kb0 is contained in kb)
  # then produces kb 'without' kb0.
  # Essentially this just applies coalesce_bounds
  # and then folds over the kb, at each step producing
  # a 'valid' KB by applying the smart constructor
  # (?) What is the role of of coalesce_bounds? why is it necessary?
  kb_subtract := proc(kb::t_kb, kb0::t_kb, $)
    local cut;
    cut := nops(kb) - nops(kb0);
    if cut < 0 or [op(cut+1..-1, kb)] <> [op(kb0)] then
      error "%1 is not an extension of %2", kb, kb0;
    end if;
    map(proc(k, $)
      local x, t;
      if k :: t_kb_Introduce 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 :: t_kb_Let then
        [genLet, op(k)]
      elif k :: t_kb_Bound then
        [assert, op(2,k)(op(1,k),op(3,k))]
      elif k :: t_kb_Constrain then
        [assert, op(1,k)]
      end if
    end proc, [op(coalesce_bounds(KB(op(1..cut, kb))))])
  end proc;

  # checks that the given condition is fully contained in the given KB,
  # or that `kb => cond'
  kb_entails := proc(kb::t_kb, cond,$)
      local kb0;
      # nothing implies false (other than false, but kb is not false)
      if cond :: t_not_a_kb then
          false
      # if the condition is a kb, subtract from it directly
      elif cond :: t_kb then
          nops(kb_subtract(cond, kb)) = 0
      else # if the condition is an atom, check that asserting it has
           # no effect on the KB
          kb0 := assert(cond,kb);
          if kb0 :: t_kb then
              nops(kb_subtract(kb0,kb)) = 0
          else
              false
          end if;
      end if;
  end proc;

  # This essentially extracts all of the `Bound`s from a
  # KB and then re-inserts them 'directly' by applying their
  # knowledge to the rest of the KB. This may (?) produce
  # an invalid KB
  coalesce_bounds := proc(kb::t_kb, $)
    local lo, hi, eq, rest, k, x, t, b, s, r;

    # For every introduction in kb, remove bounds from
    # the introduction and store them seperately
    #  rest   maps variables to the stripped type
    #  lo,hi  map variables to low,high bounds
    for k in select(type, kb, t_intro) do
      x, t := op(k); # "x = t" is the intro

      # t := minus the lower,upper bounds in t
      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;

    # Extract equality bounds, stored in eq (again a map from names)
    for k in select(type, kb, Bound(name, identical(`=`), anything)) do
      eq[op(1,k)] := op(3,k);
    end do;

    # Select `Bound`s in `Constrain`s, i.e. bounds on bound variables
    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;

    # 'coalesce' the bounds back into each clause of the KB
    map(proc(k, $)
      # when the clause is an introduction
      #  and there are equations on "x" which all evaluate to "a = a"
      #  remove that introduction and substitute
      #  bounds information about "x" back into things about "x"
      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
      #  otherwise, just replace the intro with a Let
          Let(x, eq[x]);
        end if

      # When the clause is a bound, erase it
      elif k :: t_kb_Bound
           and rest[op(1,k)] :: 'list' then
        NULL;

      # otherwise, do nothing
      else
        k;
      end if;
    end proc, kb);
  end proc;

  # The constraints do not include type assumptions
  kb_to_constraints := proc(kb::t_kb, $)::list(t_kb_atom);
    remove(type, kb_to_assumptions(kb), `::`);
  end proc;

  eval_kb := proc(e,kb::t_kb, $)
    foldl(eval, e, op(kb_to_equations(kb)));
  end proc;

  kb_assuming_mb := simpl -> proc(ee, kb::t_kb, failure, $)
    local e, as, e0;                                                         # for debugging

    e := eval_kb(ee,kb);                                                  `eval`;
    as := kb_to_assumptions(kb, e);
    e := chill(e);                                                        `chill`;
    as := chill(as);

    # The assumptions may be contradictory - I'm not sure why the right thing to
    # do is to return the original expression. Assuming false one can derive
    # anything - hence exception - so who calls this function under which
    # contexts that they expect `false` to mean something other than `false`?
    e0 := e;
    try e := simpl(e) assuming op(as); catch: e := failure(e0); end try;

    e := warm(e);                                            `warm (then expand@exp)`;
    eval(e, exp = expand @ exp);
  end proc;

  # Simplfies a given Hakaru term under knowledge of the
  # given KB. Does some magic to appease the Maple simplifier.
  # simplification might fail, in which case `failure(e)` where `e`
  # is the un-simplified (and chilled) expression is taken to be the result of
  # simplification. 'mb' for 'maybe'
  simplify_assuming_mb := kb_assuming_mb(simplify);

  simplify_assuming := proc(ee, kb::t_kb, $)
    simplify_assuming_mb(ee,kb,e->e);
  end proc;

  # like simplify_assuming but propgates the failure (as FAIL) instead of
  # silently consuming it and returning the unsimplified expression.  'f' for
  # 'failure'
  simplify_assuming_f := proc(ee, kb::t_kb, $)
    simplify_assuming_mb(ee,kb,e->FAIL);
  end proc;

  getType := proc(kb :: t_kb, x :: name, $)
    local res, over, bound;
    res := op([1,2], select(type, kb, 'Introduce(identical(x), anything)'));
    over := table([`<`=identical(`<`,`<=`), `<=`=identical(`<`,`<=`),
                   `>`=identical(`>`,`>=`), `>=`=identical(`>`,`>=`)]);
    for bound in select(type, kb, 'Bound(identical(x),
                                         identical(`<`,`<=`,`>`,`>=`),
                                         anything)') do
      res := remove(type, res, 'Bound'(over[op(2,bound)], 'anything'));
      res := op(0,res)(subsop(1=NULL,bound), op(res));
    end do;
    res
  end proc;

  # extract all introduced variables from a KB
  kb_to_variables := proc(kb :: t_kb, $)
    [op(map2(op, 1, select(type, kb, t_intro)))];
  end proc;

  bad_assumption_pw := (x->x::`=` and has(x,piecewise));
  # Returns true if the assumption is bad, false otherwise
  bad_assumption := proc(a, $)
    bad_assumption_pw(a) or
    # The case above is because the following takes forever:
    # simplify(piecewise(_a = docUpdate, aaa, bbb)) assuming i = piecewise(_a_
    # = docUpdate, zNew, idx[z, _a]), _a::integer, 0 <= _a, _a <= size[t]-1,
    # i::integer, 0 <= i, i <= size[as]-2, size[xs] = size[as]-1, size[z] =
    # size[t], docUpdate::integer, 0 <= docUpdate, docUpdate <= size[z]-1
    ( a :: `=` and
      ormap(f->f(a)::name,[lhs,rhs]) and
      indets(a,'{specindex,specfunc}'(chilled))<>{} )
    # These are dealt with otherwise and aren't understood by Maple
  end proc;

  # Note that this returns potentially any number of operands.
  kb_atom_to_assumptions := proc(k, $)
    local x, x_ty, x_typ;
    if k :: t_intro then
      x, x_ty := op(k);
      x_typ := htype_to_property(x_ty);
      (x :: x_typ),
       op(`if`(x_typ<>TopProp, map((b -> `if`(nops(b)>=2,[op(1,b)(x, op(2,b))],[])[]), x_ty),[]))
    elif k :: t_kb_Let then
      `=`(op(k))
    elif k :: t_kb_Bound then
      op(2,k)(op(1,k), op(3,k))
    elif k :: t_kb_Constrain then
      op(1,k)
    else
      NULL # Maple doesn't understand our other types
    end if
  end proc;

  kb_to_assumptions := proc(kb, e:={}, to_remove := bad_assumption_pw, $)
    local n, as;
    as := remove(to_remove,
          map( kb_atom_to_assumptions ,
             [op(coalesce_bounds(kb))
             ,seq(Constrain(n::nonnegint), n in indets(e, 'specfunc(size)'))]));
  end proc;

  # extract Lets and equality constraints (only!) from a KB
  kb_to_equations := proc(kb, $)
    local lets, constraints;

    lets := map2(subsop, 0=`=`, [op(select(type, kb, t_kb_Let))]);
    constraints := map(op, select(type, kb, 'Constrain(anything = anything)'));
    [op(lets), op(constraints)]
  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;

  # See kb_Partition
  kb_piecewise := proc(e :: specfunc(piecewise), kb :: t_kb, doIf, doThen)
    Partition:-PartitionToPW(
        kb_Partition(Partition:-PWToPartition(e, _rest), kb, doIf, doThen)
        ) ;
  end proc;

  # A sort of map over a Partition with the given KB as a context, such that:
  #    kb_Partition( PARTITION ( Piece( c_i , v_i ), .. )  , kb, doIf, doThen )
  #    =
  #    PARTITION ( Piece( doIf(c_i, kb), doThen(v_i, assert(c_i, kb)) ) )
  # Semantics originally given here:
  #  https://github.com/hakaru-dev/hakaru/commit/6f1c1ea2d039a91c157462f09f15760c98884303
  kb_Partition:= proc(e::Partition, kb::t_kb, doIf, doThen,$)::Partition;
  local br;
    #Unlike `piecewise`, the conditions in a Partition are necessarily
    #disjoint, so the `update` used in kb_piecewise isn't needed. We may
    #simply `assert` the condition (i.e., roll it into the kb) without
    #needing to `assert` the negation of all previous conditions.

    Partition:-Amap([(x,_) -> doIf(x, kb), (x,c) -> doThen(x, assert(c,kb)), z -> z], e);
  end proc;

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

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

  # Computes the range of (possible values of) a Hakaru Int,
  # given a Hakaru type for that Int
  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
  # This transforms {size,idx}(a,b,..x) to {size,id}[a,b,..x] (that is, a
  # subscript operator, which doesn't evaluate) and back. Some functions
  # evaluating causes simplification to fail because information is lost
  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))));

  # The KB constructors are local, but sometimes for debugging purposes one
  # would like to construct the KB directly. This converts the global names
  # Introduce,Constrain,Let, and Bound to KB:-<..> and replaces the 0-th operand
  # with KB:-KB.
  build_unsafely := proc(kb,$)
    KB(op(subs([ :-Introduce=Introduce, :-Let=Let, :-Bound=Bound, :-Constrain=Constrain ], kb)));
  end proc;

  ModuleLoad := proc($)
    ModuleUnload();
    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)');

    # KB 'atoms' , i.e. single pieces of knowledge, in "maple form".
    # Note that boolean already includes `Bound`s in the form `x R y`
    TypeTools[AddType](t_kb_atom,
      '{`::`, boolean, `in`, specfunc(anything,{Or,Not,And})}');
    TypeTools[AddType](t_kb_atoms,list(t_kb_atom));

    # The 'false' KB, produced when a contradiction arises in a KB
    TypeTools[AddType](t_not_a_kb, 'specfunc(NotAKB)');

    # Something that might be a KB, or is the false KB
    TypeTools[AddType](t_kb_mb, '{t_kb, t_not_a_kb}');

    # Prevent expand(product(f(i),i=0..n-1))
    # from producing (product(f(i),i=0..n))/f(n)
    `expand/product` := overload([
      proc(ff, rr::name=And(`+`,Not(`+`(Not(integer))))..anything)
        option overload(callseq_only);
        thaw(`expand/product`(ff, applyop(freeze, [2,1], rr)))
      end proc,
      proc(ff, rr::name=anything..And(`+`,Not(`+`(Not(integer)))))
        option overload(callseq_only);
        thaw(`expand/product`(ff, applyop(freeze, [2,2], rr)))
      end proc,
      `expand/product`]);

    # Prevent simplify(product(1-x[i],i=0..n-1))
    # from producing (-1)^n*product(-1+x[i],i=0..n-1)
    `simplify/int/simplify` := overload([
      proc (f::identical(product), a::`+`, r::{name,name=anything}, $)
        option overload(callseq_only);
        return 'f'(a,r);
      end proc,
      `simplify/int/simplify`]);

    # Prevent product(1/(n-i),i=0..n-1) and product(1/(i-n),n=0..i-1)
    # from evaluating to 0 (?!)
    # by preventing `product/indef/indef`(n-i,i)
    # from evaluating to (-1)^i * GAMMA(i-n)
    `product/indef/indef` := overload([
      proc(expr, i, $)
        option overload;
        local a, b;
        if expr :: `*` then
          `*`(op(map(`product/indef/indef`, list_of_mul(expr), i)))
        elif expr :: 'anything^freeof(i)' then
          `product/indef/indef`(op(1,expr),i)^op(2,expr)
        elif has(expr,i) and sign(expr,i) :: negative then
          if ispoly(expr, linear, i, 'b', 'a') then
            (-a)^i / GAMMA(1-i-b/a)
          else
            error FAIL
          end if
        else
          error "invalid input: cannot product/indef/indef(%1, %2)", expr, i
        end if
      end proc,
      `product/indef/indef`]);

    # Convert GAMMA(x)*GAMMA(y)/GAMMA(x+y) to Beta(x,y)
    `convert/Beta` := proc(e, $)
      subsindets(e, 'And(`*`, Not(`*`(Not(specfunc(GAMMA)))),
                              Not(`*`(Not(1/specfunc(GAMMA)))))',
        proc(p, $)
          local s, t, r, i, j, x, y;
          s, r := selectremove(type, convert(p,'list',`*`), 'specfunc(GAMMA)');
          t := map2(op, [1,1], select(type, {op(r)}, '1/specfunc(GAMMA)'));
          for i from nops(s) to 2 by -1 do
            x := op([i,1],s);
            for j from i-1 to 1 by -1 do
              y := op([j,1],s);
              if x + y in t then
                s := subsop(j=GAMMA(x+y), i=Beta(x,y), s);
                break;
              end if;
            end do;
          end do;
          `*`(op(s), op(r));
        end proc);
    end proc;
  end proc;

  ModuleUnload := proc($)
    map(proc(x::uneval) try eval(x) catch: NULL; end try end proc,
         ['TypeTools[RemoveType](t_kb)']);
  end proc;
  ModuleLoad();
end module; # KB


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

`eta/one_cubes_prime` := (A::set) -> `eta/cubes`(1)(A);

`gamma/one_cubes_prime` :=
 (A::set,B::set) -> (p) -> (U,V) -> `gamma/cubes`(1)(A,B)(p)(U,V);