# The goal here is to set up a simplicial complex K and an embedding of
# |K| in R^3 such that the image is a version of the standard "pair of
# pants space", or in other words a sphere with three discs removed.
# More specifically, we start with the unit sphere in R^3, and remove
# three discs of radius 1/2 centred at points equally spaced around
# the plane perpendicular to [1,1,1].  This has an evident linear action
# of the group G = S_3 x C_2, and everything will be equivariant with
# respect to this.  There is a fundamental domain for the action on S^2
# that is a spherical triangle with one vertex at [1,1,1]/sqrt(3) and
# the other two vertices separated by Pi/3 on the equator perpendicular
# to [1,1,1].  One boundary circle meets this domain in a quarter
# circle, and the other boundary circles do not intersect it at all.
# We start by setting up a triangulation of the fundamental domain
# such that this quarter circle is essentially a subcomplex.  We
# can then propagate this equivariantly and remove the boundary
# discs to obtain a triangulated surface of the required homeomorphism
# type.  We can glue a standard horizontal cylinder to each boundary
# circle to connect to other pieces and so construct various surfaces.
# However, this is ugly because the tangent spaces do not line up
# along the glued circles.  To fix this, we construct a map
# f : S^2 -> R^3 with the property the f is the identity on our
# boundary circles but acts near those circles in such a way as to
# line up the tangent spaces with a horizontal cylinder.

lib_read("brent.mpl"):

make_pants_complex := proc(verbose := false)
 local plot_opts,dp,G,T,U,V,xx,i,j,k,lm,m,v,g,gi,gx,E,R,f2,sphere_retract,
  xa,xb,xc,ua,rb,rels,F,a,n,s,t,u;
 global pants_group,pants_sphere_sector_complex,pants_sphere_complex,
  pants_complex,condensed_pants_complex;

 plot_opts := scaling=constrained, axes=none:
 dp := `dot/R`(3);

 if verbose then printf("Making group\n"); fi;

 # This is the group S_3 x C_2, which will act isometrically on everything.
 G := table():
 pants_group := eval(G);
 G["elements"] := [seq(seq([op(u),s],u in combinat[permute](3)),s in [1,-1])]:
 G["id"] := [1,2,3,1]:
 G["o"] := (u,v) -> [u[v[1]],u[v[2]],u[v[3]],u[4] * v[4]]:
 G["inv"] := proc(u)
  local ui,i;
  ui := table():
  for i from 1 to 3 do ui[u[i]] := i; od:
  return [ui[1],ui[2],ui[3],u[4]];
 end:

 if verbose then printf("Making skeleton\n"); fi;
 T := table():
 pants_sphere_sector_complex := eval(T):

 T["u"] := table([
   1 = [ 2,-1,-1] /~ sqrt(6),
   2 = [ 1, 1,-2] /~ sqrt(6),
   3 = [-1, 2,-1] /~ sqrt(6),
   4 = [-2, 1, 1] /~ sqrt(6),
   5 = [-1,-1, 2] /~ sqrt(6),
   6 = [ 1,-2, 1] /~ sqrt(6),
 ##
   7 = [ 1, 1, 1] /~ sqrt(3),
   8 = [-1,-1,-1] /~ sqrt(3),
 ##
   9 = [ 0, 1,-1] /~ sqrt(2),
  10 = [-1, 1, 0] /~ sqrt(2),
  11 = [-1, 0, 1] /~ sqrt(2),
  12 = [ 0,-1, 1] /~ sqrt(2),
  13 = [ 1,-1, 0] /~ sqrt(2),
  14 = [ 1, 0,-1] /~ sqrt(2)
 ]):

 T["u_index"] := table():
 for i from 0 to 13 do
  T["u_index"][T["u"][i]] := i;
  T["u_index"][simplify(T["u"][i])] := i;
 od:

 xx := [x[1],x[2],x[3]];

 T["act_R3"] := table():
 for g in G["elements"] do
  gi := G["inv"](g);
  gx := [x[gi[1]],x[gi[2]],x[gi[3]]];
  if g[4] = -1 then
   gx := expand(gx -~ (2/3 * dp([1,1,1],gx)) *~ [1,1,1]);
  fi;
  T["act_R3"][g] := unapply(gx,x);
 od:

 T["act_u_table"] := table():
 T["act_u"] := table():
 for g in G["elements"] do
  T["act_u_table"][g] :=
   table([seq(i = T["u_index"][simplify(T["act_R3"][g](T["u"][i]))],i=0..13)]);
  T["act_u"][g] := (i) -> T["act_u_table"][g][i];
 od:

 T["equator"] := unapply(cos(t) *~ T["u"][1] +~ sin(t) *~ T["u"][9],t):
 T["equator_plot"] :=
  spacecurve(T["equator"](t),t=0..2*Pi,colour=green,plot_opts):
 T["equator_sector_plot"] :=
  spacecurve(T["equator"](t),t=0..Pi/3,colour=green,plot_opts):

 T["longitude"] := table():
 T["longitude_plot"] := table():
 for i from 1 to 6 do
  T["longitude"][i] :=
   unapply(expand(sin(t) *~ T["u"][7] +~ cos(t) *~ T["u"][i]),t);
  T["longitude_plot"][i] :=
   spacecurve(T["longitude"][i](t),t=-Pi/2..Pi/2,colour=blue,plot_opts):
 od:
 T["longitude_sector_plot"] :=
  display(
   spacecurve(T["longitude"][1](t),t=0..Pi/2,colour=blue,plot_opts),
   spacecurve(T["longitude"][2](t),t=0..Pi/2,colour=blue,plot_opts),
   plot_opts
  ):

 T["boundary_circle"] := table():
 T["boundary_circle_plot"] := table():
 for i from 1 to 3 do
  T["boundary_circle"][i] :=
   unapply(expand((sqrt(3)/2) *~ T["u"][2*i-1] +~ (cos(t)/2) *~ T["u"][2*i+7] +~ (sin(t)/2) *~ T["u"][7]),t);
  T["boundary_circle_plot"][i] :=
   spacecurve(T["boundary_circle"][i](t),t=0..2*Pi,colour=red,plot_opts)
 od:
 T["boundary_circle_sector_plot"] :=
   spacecurve(T["boundary_circle"][1](t),t=0..Pi/2,colour=red,plot_opts):

 T["wire_sphere_plot"]  := sphere(colour=grey,style=wireframe):
 T["solid_sphere_plot"] := sphere(colour=grey,style=patchnogrid):
 T["wire_sector_plot"]  :=
  plot3d(cos(t) *~ T["u"][7] +~ sin(t) *~ (cos(u) *~ T["u"][1] +~ sin(u) *~ T["u"][9]),
	 t = 0 .. Pi/2,u = 0 .. Pi/3,
	 colour=grey,style=wireframe,scaling=constrained, axes=none):
 T["solid_sector_plot"]  :=
  plot3d(cos(t) *~ T["u"][7] +~ sin(t) *~ (cos(u) *~ T["u"][1] +~ sin(u) *~ T["u"][9]),
	 t = 0 .. Pi/2,u = 0 .. Pi/3,
	 colour=grey,style=patchnogrid,scaling=constrained, axes=none):

 T["line_plot"] := display(
  T["equator_plot"],
  seq(T["longitude_plot"][i],i=1..6),
  seq(T["boundary_circle_plot"][i],i=1..3)
 ):

 T["sphere_plot"] := display(
  T["solid_sphere_plot"],T["line_plot"],
  plot_opts
 ):

 T["line_sector_plot"] := display(
  T["equator_sector_plot"],
  T["longitude_sector_plot"],
  T["boundary_circle_sector_plot"],
  plot_opts
 ):

 T["sector_plot"] := display(
  T["solid_sector_plot"],T["line_sector_plot"],
  plot_opts
 ):

 lm := 4:
 m := 2 ^ lm:
 T["m"] := m:

 if verbose then printf("Making simplices\n"); fi;

 v := (i,j) -> [i/m,j/m,(m-i-j)/m]:

 T["vertices"] := [seq(seq(v(i,j),j=0..m - i),i=0..m)]:

 T["edges"] := [
  seq(seq([v(i,j),v(i+1,j)],j=0..m-1-i),i=0..m-1),
  seq(seq([v(i,j),v(i,j+1)],j=0..m-1-i),i=0..m-1),
  seq(seq([v(i+1,j),v(i,j+1)],j=0..m-1-i),i=0..m-1),
 NULL
 ]:

 T["faces"] := [
  seq(seq([v(i,j),v(i+1,j),v(i,j+1)],j=0..m-1-i),i=0..m-1),
  seq(seq([v(i,j+1),v(i+1,j),v(i+1,j+1)],j=0..m-2-i),i=0..m-2)
 ]:

 T["max_simplices"] := T["faces"]:

 if verbose then printf("Making explicit embedding\n"); fi;

 unassign('i');
 T["f0"] := unapply(i[1] *~ T["u"][1] +~ i[2] *~ T["u"][2] +~ i[3] *~ T["u"][7],i):
 T["f1"] := proc(i) local x; x := T["f0"](i); return x /~ sqrt(add(x[j]^2,j=1..3)); end:
 T["embedding0"] := table():
 T["embedding1"] := table():
 for i in T["vertices"] do
  T["embedding0"][i] := T["f0"](i);
  T["embedding1"][i] := T["f1"](i);
 od:

 E := table():
 for i in T["vertices"] do E[i] := NULL; od:

 for i from 0 to m do
   E[[m-i,i,0] /~ m] := T["equator"](i/m * Pi/3);
   E[[0,m-i,i] /~ m] := T["longitude"][2](i/m * Pi/2);
 od:
 for i from 0 to m/2 do
   E[[m-i,0,i]       /~ m] := T["longitude"][1]((2*i/m) * Pi/6);
   E[[m/2-i,0,m/2+i] /~ m] := T["longitude"][1]((1+4*i/m) * Pi/6);
   E[[m/2,m/2-i,i]   /~ m] := T["boundary_circle"][1]((2*i/m) * Pi/2);
 od:

 sphere_retract := (u) -> evalf(u /~ sqrt(add(u[i]^2,i=1..3))):

 `midpoint_extend/simplicial_complex`(E,4,sphere_retract):
 T["embedding2"] := eval(E):
 T["embedding"] := eval(E):
 `plot/simplicial_complex`(T):
 `surface_plot/simplicial_complex`(T):

 T["proj"] := table():
 for k from 1 to 3 do
  T["proj"][k] := unapply(expand(xx - dp(x,T["u"][2*k-1]) *~ T["u"][2*k-1]),x);
 od:

 T["proj_a"] := unapply([dp(xx,T["u"][ 1]),dp(xx,T["u"][12])],x):
 T["proj_b"] := unapply([dp(xx,T["u"][ 5]),dp(xx,T["u"][ 7])],x):
 T["proj_c"] := unapply([dp(xx,T["u"][ 1]),dp(xx,T["u"][ 7])],x):
 T["proj_d"] := unapply([dp(xx,T["u"][12]),dp(xx,T["u"][ 7])],x):

 unassign('s');

 T["unproj_a"] := unapply(s[1] *~ T["u"][ 1] +~ s[2] *~ T["u"][12], s);
 T["unproj_b"] := unapply(s[1] *~ T["u"][ 5] +~ s[2] *~ T["u"][ 7], s);
 T["unproj_c"] := unapply(s[1] *~ T["u"][ 1] +~ s[2] *~ T["u"][ 7], s);
 T["unproj_d"] := unapply(s[1] *~ T["u"][12] +~ s[2] *~ T["u"][ 7] +~ (sqrt(3)/2) *~ T["u"][1], s);

 T["g"] := unapply(expand(mul(dp(x,T["u"][2*j-1]) - sqrt(3)/2,j=1..3)),x):
 T["h"] := unapply(expand((2 + dp(x,T["u"][7]) ^ 2)*sqrt(3)/4),x):

 # Here we define a particular polynomial function k(x), and then we
 # define f(x) in terms of k(x).  Most of the desired properties hold
 # independently of the choice of k(x).  Our particular choice is
 # designed to straighten out the tangent spaces on the boundary
 # circles and ensure that the width of he surface in the centre
 # is the same as the width of the circles.
 T["k"] := (x) -> (20 + 5 * sqrt(2) * x[1] - 15 * x[1]^2 + 5 * sqrt(2) * x[1]^3 +
		   (4 * x[1] - 3 * sqrt(2)) * (x[2] + x[3]) +
		   (8 * sqrt(2) * x[1] - 26) * x[2] * x[3] +
		   (-5) * sqrt(2) * (x[2] + x[3]) * x[2] * x[3])/27:
 T["f2"] := unapply(simplify(
   xx +~
    (T["g"](x)/T["h"](x)) *~ (
      T["k"]([x[1],x[2],x[3]]) *~ T["proj"][1](x) +~
      T["k"]([x[2],x[3],x[1]]) *~ T["proj"][2](x) +~
      T["k"]([x[3],x[1],x[2]]) *~ T["proj"][3](x))),
   x):

 for i in T["vertices"] do
  T["embedding3"][i] := evalf(T["f2"](T["embedding2"][i]));
 od:
 T["embedding"] := eval(T["embedding4"]);

 if verbose then printf("Making implicit embedding\n"); fi;

 # We now start to define an alternative embedding, using the surface
 # where the following function is zero.
 T["l"] := unapply(
  12*sqrt(3)*T["g"](xx) + (1-dp(xx,xx))*(27+6*(x[1]*x[2]+x[2]*x[3]+x[3]*x[1])+
  8*sqrt(3)*T["g"](xx)-6*dp(xx,xx)),x):
 T["l_min_root"] := fsolve(expand(T["l"]((-t) *~ T["u"][1])),t=0.68..0.70);
 T["l_max_root"] := fsolve(expand(T["l"](t *~ T["u"][1])),t=1.42..1.43);
 xa := (r * cos(t)) *~ T["u"][1] +~ (r * sin(t)) *~ T["u"][9] +~ u *~ T["u"][7]:
 ua := solve(simplify(expand(T["l"](xa))),u)[1]:
 ua := sqrt(factor(ua^2)):
 xa := subs(u = ua,xa):
 T["chart_a"] := unapply(xa,r,t):
 xb := (r * cos(t)) *~ T["u"][9] +~ (r * sin(t)) *~ T["u"][7] +~ u *~ T["u"][1]:
 rb := solve(simplify(expand(T["l"](xb))),r)[3]:
 rb := 1/sqrt(factor(expand(rationalize(1/rb^2)))):
 xb := subs(r = rb,xb):
 T["chart_b"] := unapply(xb,u,t):
 xc := (a[0] - a[1] * r^2 - a[2] * r^4) *~ T["u"][1] +~ r *~ (cos(t) *~ T["u"][9] +~ sin(t) *~ T["u"][7]):
 rels := expand([coeffs(collect(simplify(expand(convert(series(T["l"](xc),r=0,5),polynom,r))),r),r)]):
 xc := expand(evalf(subs(a[0] = T["l_max_root"],subs(solve([rels[2],rels[3]],{a[1],a[2]}),xc)))):
 T["chart_c"] := unapply(xc,r,t):

 T["dl"] := unapply([seq(diff(T["l"](xx),x[i]),i=1..3)],x);

 T["retract"] := proc(x)
  local g,y,sols;
  g := evalf(T["dl"](x));
  g := g /~ sqrt(add(g[i]^2,i=1..3));
  y := x +~ t *~ g;
  sols := [fsolve(evalf(expand(T["l"](y))),t)];
  sols := select(t -> abs(t) = min(map(abs,sols)),sols);
  if sols = [] then error("No solutions"); fi;
  return(evalf(subs(t = sols[1],y)));
 end:

 T["step"] := proc(q,d0,proj,unproj)
  local xx,st0,mx,dx,g,h,sol;
  xx  := eval(unproj([s,t]));
  st0 := eval(proj(q));
  mx := evalf(T["l"](xx));
  dx := (s - st0[1])^2 + (t - st0[2])^2 - d0^2;
  g := evalf(subs({s = st0[1],t = st0[2]},[-diff(mx,t),diff(mx,s)]));
  g := (d0 / sqrt(g[1]^2+g[2]^2)) *~ g;
  h := st0 +~ g;
  sol := fsolve({mx,dx},{s = h[1], t = h[2]});
  return evalf(subs(sol,xx));
 end:

 F[0] := (E) -> proc(d0)
  local i;
  E[[1,0,0]] := evalf(T["l_max_root"] *~ T["u"][1]);
  for i from 1 to 8 do
   E[[16-i,i,0] /~ 16] := T["step"](E[[17-i,i-1,0]/~16],d0,T["proj_a"],T["unproj_a"]):
  od:
  return table(["err" = evalf(sqrt(3)/2 - dp(T["u"][1],E[[1/2,1/2,0]]))]);
 end:

 F[1] := (E) -> proc(d0)
  global p; local i;
  E[[1/2,1/2,0]] := T["u"][14];
  for i from 1 to 8 do
   E[[8-i,8+i,0]/~16] := T["step"](E[[9-i,7+i,0]/~16],d0,T["proj_a"],T["unproj_a"]):
  od:
  return table(["err" = evalf(dp(T["u"][10],E[[0,1,0]]))]);
 end:

 F[2] := (E) -> proc(d0)
  global p; local i;
  E[[0,1,0]] := evalf(T["l_min_root"] *~ T["u"][2]):
  for i from 1 to 16 do
   E[[0,16-i,i]/~16] := T["step"](E[[0,17-i,i-1]/~16],d0,T["proj_b"],T["unproj_b"]):
  od:
  return table(["err" = evalf(-dp(T["u"][9],E[[0,0,1]]))]);
 end:

 F[3] := (E) -> proc(d0)
  global p; local i;
  E[[0,0,1]] := T["u"][7] /~ 2:
  for i from 1 to 8 do
   E[[i,0,16-i]/~16] := T["step"](E[[i-1,0,17-i]/~16],d0,T["proj_c"],T["unproj_c"]):
  od:
  return table(["err" = evalf(dp(E[[1/2,0,1/2]],T["u"][1]) - sqrt(3)/2)]);
 end:

 F[4] := (E) -> proc(d0)
  global p; local i,e;
  E[[1/2,0,1/2]] := (sqrt(3)/2) *~ T["u"][1] +~ (1/2) *~ T["u"][7];
  for i from 1 to 8 do
   E[[8+i,0,8-i]/~16] := T["step"](E[[7+i,0,9-i]/~16],d0,T["proj_c"],T["unproj_c"]):
  od:
  e := - evalf(dp(E[[1,0,0]],T["u"][7]));
  E[[1,0,0]] := evalf(T["l_max_root"] *~ T["u"][1]);
  return table(["err" = e]);
 end:

 F[5] := (E) -> proc(d0)
  global p; local i,e;
  for i from 1 to 8 do
   E[[8,8-i,i]/~16] := T["step"](E[[8,9-i,i-1]/~16],d0,T["proj_d"],T["unproj_d"]):
  od:
  e := - evalf(dp(E[[1/2,0,1/2]],T["u"][9]));
  E[[1/2,0,1/2]] := (sqrt(3)/2) *~ T["u"][1] +~ (1/2) *~ T["u"][7];
  return table(["err" = e]);
 end:

 E := table():
 for i in T["vertices"] do E[i] := NULL; od:
 T["F_step"] := table([0 = 0.10, 1 = 0.06, 2 = 0.05, 3 = 0.10, 4 = 0.10, 5 = 0.09]):
 T["F_error"] := table():
 for i from 0 to 5 do
  T["F_step"][i] :=
   brent_fsolve(F[i](E),T["F_step"][i],T["F_step"][i] + 0.01,false,false,10.^(-10))[1];
  T["F_error"][i] := F[i](E)(T["F_step"][i]);
 od:

 `midpoint_extend/simplicial_complex`(E,4,T["retract"]):

 T["embedding4"] := eval(E);

 if verbose then printf("Extending equivariantly\n"); fi;

 U := table():
 pants_sphere_complex := eval(U);
 U["act_i"] := table():
 U["act_i"][[1,2,3, 1]] := (j) -> [ j[1], j[2], j[3], j[4]]:
 U["act_i"][[2,3,1, 1]] := (j) -> [-j[2],-j[3], j[1], j[4]]:
 U["act_i"][[3,1,2, 1]] := (j) -> [ j[3],-j[1],-j[2], j[4]]:
 U["act_i"][[2,1,3, 1]] := (j) -> [ j[3], j[2], j[1], j[4]]:
 U["act_i"][[3,2,1, 1]] := (j) -> [-j[2],-j[1], j[3], j[4]]:
 U["act_i"][[1,3,2, 1]] := (j) -> [ j[1],-j[3],-j[2], j[4]]:
 U["act_i"][[1,2,3,-1]] := (j) -> [ j[1], j[2], j[3],-j[4]]:
 U["act_i"][[2,3,1,-1]] := (j) -> [-j[2],-j[3], j[1],-j[4]]:
 U["act_i"][[3,1,2,-1]] := (j) -> [ j[3],-j[1],-j[2],-j[4]]:
 U["act_i"][[2,1,3,-1]] := (j) -> [ j[3], j[2], j[1],-j[4]]:
 U["act_i"][[3,2,1,-1]] := (j) -> [-j[2],-j[1], j[3],-j[4]]:
 U["act_i"][[1,3,2,-1]] := (j) -> [ j[1],-j[3],-j[2],-j[4]]:

 U["vertex_convert"] := (i) -> [i[1],i[2],0,i[3]]:
 U["edge_convert"]   := (e) -> sort(map(U["vertex_convert"],e)):
 U["face_convert"]   := (f) -> sort(map(U["vertex_convert"],f)):

 U["embedding0"] := table():
 U["embedding1"] := table():
 U["embedding2"] := table():
 U["embedding3"] := table():
 U["embedding4"] := table():
 U["vertices"] := map(U["vertex_convert"],T["vertices"]):
 for i in T["vertices"] do
  U["embedding0"][U["vertex_convert"](i)] := evalf(T["embedding0"][i]);
  U["embedding1"][U["vertex_convert"](i)] := evalf(T["embedding1"][i]);
  U["embedding2"][U["vertex_convert"](i)] := evalf(T["embedding2"][i]);
  U["embedding3"][U["vertex_convert"](i)] := evalf(T["embedding3"][i]);
  U["embedding4"][U["vertex_convert"](i)] := evalf(T["embedding4"][i]);
 od:

 for i in U["vertices"] do
  for g in G["elements"] do
   U["embedding0"][U["act_i"][g](i)] := evalf(T["act_R3"][g](U["embedding0"][i]));
   U["embedding1"][U["act_i"][g](i)] := evalf(T["act_R3"][g](U["embedding1"][i]));
   U["embedding2"][U["act_i"][g](i)] := evalf(T["act_R3"][g](U["embedding2"][i]));
   U["embedding3"][U["act_i"][g](i)] := evalf(T["act_R3"][g](U["embedding3"][i]));
   U["embedding4"][U["act_i"][g](i)] := evalf(T["act_R3"][g](U["embedding4"][i]));
  od:
 od:
 U["embedding"] := eval(U["embedding4"]);

 U["vertices"] := sort(map(op,[indices(U["embedding0"])])):
 U["edges"] :=
  {seq(seq(sort(map(U["act_i"][g],U["edge_convert"](e))),
    e in T["edges"]),g in G["elements"])}:
 U["edges"] := sort([op(U["edges"])]):
 U["faces"] :=
  {seq(seq(sort(map(U["act_i"][g],U["face_convert"](f))),
    f in T["faces"]),g in G["elements"])}:
 U["faces"] := sort([op(U["faces"])]):

 R := T["act_R3"][[1,2,3,-1]];
 f2 := T["f2"];

 U["smooth_plot"] :=
  display(
   plot3d(  f2(sqrt(1-r^2) *~ T["u"][7] +~ (r * cos(t)) *~ T["u"][1] +~ (r * sin(t)) *~ T["u"][9]),
          r=0..0.6,t=0..2*Pi,style=patchnogrid),
   plot3d(R(f2(sqrt(1-r^2) *~ T["u"][7] +~ (r * cos(t)) *~ T["u"][1] +~ (r * sin(t)) *~ T["u"][9])),
          r=0..0.6,t=0..2*Pi,style=patchnogrid),
   plot3d(  f2(cos(s) *~ T["u"][7] +~ (sin(s) * cos(t)) *~ T["u"][1] +~ (sin(s) * sin(t)) *~ T["u"][9]),
          s=0.2*Pi..0.8*Pi,t=0..2*Pi,style=patchnogrid,numpoints=4000),
   plot_opts
  );

 U["chart_plot"] := display(
  plot3d(xa,r=0..0.5,t=0..2*Pi,style=patchnogrid),
  plot3d(T["act_R3"][[1,2,3,-1]](xa),r=0..0.5,t=0..2*Pi,style=patchnogrid),
  plot3d(xb,u=0..1.4,t=0..2*Pi,style=patchnogrid),
  plot3d(T["act_R3"][[2,3,1,1]](xb),u=0..1.4,t=0..2*Pi,style=patchnogrid),
  plot3d(T["act_R3"][[3,1,2,1]](xb),u=0..1.4,t=0..2*Pi,style=patchnogrid),
  plot3d(xc,r=0..0.3,t=0..2*Pi,style=patchnogrid),
  plot3d(T["act_R3"][[2,3,1,1]](xc),r=0..0.3,t=0..2*Pi,style=patchnogrid),
  plot3d(T["act_R3"][[3,1,2,1]](xc),r=0..0.3,t=0..2*Pi,style=patchnogrid),
  scaling=constrained,axes=none):

 if verbose then printf("Trimming\n"); fi;

 V := table():
 pants_complex := eval(V);
 V["vertices"] := select(i -> max(i[1],-i[2],i[3]) <= 1/2,U["vertices"]):
 V["edges"] := select(e -> {op(e)} minus {op(V["vertices"])} = {}, U["edges"]):
 V["faces"] := select(f -> {op(f)} minus {op(V["vertices"])} = {}, U["faces"]):
 V["max_simplices"] := V["faces"]:
 V["embedding0"] := table():
 V["embedding1"] := table():
 V["embedding2"] := table():
 V["embedding3"] := table():
 V["embedding4"] := table():
 for i in V["vertices"] do
  V["embedding0"][i] := U["embedding0"][i];
  V["embedding1"][i] := U["embedding1"][i];
  V["embedding2"][i] := U["embedding2"][i];
  V["embedding3"][i] := U["embedding3"][i];
  V["embedding4"][i] := U["embedding4"][i];
 od:
 V["embedding"] := V["embedding4"]:

 V["normal"] := table():
 for i in V["vertices"] do
  n := evalf(T["dl"](V["embedding"][i]));
  n := n /~ dp(n,n);
  V["normal"][i] := n;
 od:

 V["chart_plot"] :=
  display(
   plot3d(xa,r=0..0.5,t=0..2*Pi,style=patchnogrid),
   plot3d(T["act_R3"][[1,2,3,-1]](xa),r=0..0.5,t=0..2*Pi,style=patchnogrid),
   plot3d(xb,u=0..sqrt(3.)/2,t=0..2*Pi,style=patchnogrid),
   plot3d(T["act_R3"][[2,3,1,1]](xb),u=0..sqrt(3.)/2,t=0..2*Pi,style=patchnogrid),
   plot3d(T["act_R3"][[3,1,2,1]](xb),u=0..sqrt(3.)/2,t=0..2*Pi,style=patchnogrid),
  scaling=constrained,axes=none):

 condensed_pants_complex :=
  `condense/simplicial_complex`(pants_complex);

 if verbose then printf("Generating javascript\n"); fi;
 `set_javascript/simplicial_complex`(condensed_pants_complex);
end:

`base/pants` := table([
 "centre" = [0,0,0],
 "circle_centres" = [[sqrt(3)/2,0,0],[-sqrt(3)/4,3/4,0],[-sqrt(3)/4,-3/4,0]],
 "top" = [0,0,1/2]
]):

`outline/pants` := proc(P)
 local c,z,t;
 c := P["centre"];
 z := 2 *~ (P["top"] -~ P["centre"]);
 display(
  seq(line(P["centre"],u,colour=green),u in P["circle_centres"]),
  seq(spacecurve(u +~ (cos(t)/sqrt(3)) *~ cross_product(u -~ c,z) +~ (sin(t)/2) *~ z,t=0..2*Pi,colour=red),
       u in P["circle_centres"]),
  scaling=constrained,axes=none
 );
end:

`rough_plot/pants` := proc(P)
 local c,z,t,u,v,w,X;
 c := P["centre"];
 z := 2 *~ (P["top"] -~ P["centre"]);
 X := NULL;
 for u in P["circle_centres"] do
  v := evalf((u -~ c) *~ (2/sqrt(3)));
  w := cross_product(v,z);
  X := X,plot3d(c +~ (s * abs(cos(t))/4 + (1-s) * sqrt(3)/2) *~ v
                +~ (cos(t)/2) *~ w +~ (sin(t)/2) *~ z,
                s=0..1,t=0..2*Pi,style=patchnogrid,scaling=constrained,axes=none);
 od:
 return(display(X));
end:

`plot/pants` := proc(P)
 local dp,h,c,b,u,v,w,p,f,X;

 dp := (u,v) -> add(u[i] * v[i],i=1..3);
 h := (x) -> evalf(x /~ sqrt(dp(x,x)));
 c := evalf(P["centre"]);
 b := map(x -> x -~ c,P["circle_centres"]);
 u := h(b[1]);
 v := h(b[2] -~ b[3]);
 w := h(P["top"] -~ c);
 p := pants_sphere_sector_complex["u"];
 f := unapply(c +~ dp(x,p[1]) *~ u +~ dp(x,p[9]) *~ v +~ dp(x,p[7]) *~ w,x);
 X := `map/simplicial_complex`(f,condensed_pants_complex);
 return `surface_plot/simplicial_complex`(X);
end:

`map/pants` := proc(f,P)
 return table([
  "centre" = f(P["centre"]),
  "circle_centres" = map(f,P["circle_centres"]),
  "top" = f(P["top"])
 ]);
end:

`sprout/pants` := proc(P,i)
 local Q,u,c;
 c := P["centre"];
 u := P["circle_centres"][i] -~ c;
 Q := table():
 Q["centre"] := c +~ 2 *~ u;
 Q["circle_centres"] := map(v -> 2 *~ c + 2 *~ u -~ v,P["circle_centres"]);
 Q["top"] := P["top"] -~ P["centre"] +~ Q["centre"];
 return eval(Q);
end:

`pants_tube/base` := table([
  "centre"    = [0,0,0],
  "direction" = [1,0,0],  # unit vector
  "bend"      = [0,1,0],  # unit vector
  "length"    = 1,
  "curvature" = 0
]):

`outline/pants_tube` := proc(T)
 local c,d,b,l,k,w,x,y,z,s,t0,t;
 c := T["centre"];
 d := T["direction"];
 b := T["bend"];
 l := T["length"];
 k := T["curvature"];
 w := cross_product(d,b);
 x := c -~ (`C/pants_tube`(t*l*k/2)*t^2*l^2*k/8) *~ b +~ (`S/pants_tube`(t*l*k/2)*t*l/2) *~ d;
 y := cos(t*l*k/2) *~ b +~ sin(t*l*k/2) *~ d;
 z := x +~ (cos(s)/2) *~ y +~ (sin(s)/2) *~ w;
 return display(
  spacecurve(x,t = -1..1,colour=cyan),
  spacecurve(subs(t=-1,z),s=0..2*Pi,colour=orange),
  spacecurve(subs(t= 1,z),s=0..2*Pi,colour=orange),
  scaling=constrained,axes=none
 );
end:

`S/pants_tube` := unapply(convert(series(sin(x)/x,x=0,11),polynom,x),x);
`C/pants_tube` := unapply(convert(series(2*(1-cos(x))/x^2,x=0,11),polynom,x),x);
`A/pants_tube` := unapply(convert(series(arcsin(x)/x,x=0,11),polynom,x),x);

`plot/pants_tube` := proc(T)
 local c,d,b,l,k,w,x,y,z,s,t;
 c := T["centre"];
 d := T["direction"];
 b := T["bend"];
 l := T["length"];
 k := T["curvature"];
 w := cross_product(d,b);
 x := c -~ (`C/pants_tube`(t*l*k/2)*t^2*l^2*k/8) *~ b +~ (`S/pants_tube`(t*l*k/2)*t*l/2) *~ d;
 y := cos(t*l*k/2) *~ b +~ sin(t*l*k/2) *~ d;
 z := x +~ (cos(s)/2) *~ y +~ (sin(s)/2) *~ w;
 return display(
  plot3d(z,t=-1..1,s=0..2*Pi,style=patchnogrid),
  scaling=constrained,axes=none
 );
end:

`map/pants_tube` := proc(f,T)
 local U;
 U := table():
 U["centre"] := f(T["centre"]);
 U["direction"] := f(T["centre"] +~ T["direction"]) -~ U["centre"];
 U["bend"]      := f(T["centre"] +~ T["bend"]     ) -~ U["centre"];
 U["length"]    := T["length"];
 U["curvature"] := T["curvature"];
 return eval(U);
end:

`joiner/pants_tube` := proc(c1,n1,c2,n2_)
 local dp,d,s,c0,ca,sa,n2,err,p,q,k,l,b,c,T,alpha,m,pic;
 dp := `dot/R`(3);

 d := evalf(c2 -~ c1);
 s := sqrt(dp(d,d));           # straight line length
 d := d /~ s;                  # unit vector c1 -> c2
 c0 := evalf((c1 +~ c2) /~ 2); # straight line midpoint

 ca := -evalf(dp(n1,d));       # cos(alpha/2)
 sa := sqrt(1 - ca * ca);      # sin(alpha/2)

 if nargs >= 4 then
  n2 := n2_;
 else
  n2 := n1 +~ (2 * p) *~ d;
 fi;

 k := 2 * sa/s;       # curvature
 q := s/2 * sqrt((1-ca)/(1+ca));

 err := evalf(cross_product(d,n2 -~ n1));
 err := sqrt(dp(err,err));
 if err > 10.^(-6) then
  error("Non-matching circles");
 fi;

 b := -~ evalf(n1 +~ n2);

 if sqrt(dp(b,b)) < 10.^(-4) then
  # Tube will be straight.  Set b to be an arbitrary vector
  # orthogonal to d.

  b := [1,0,0]; p := abs(d[1]);
  if abs(d[2]) < p then b := [0,1,0]; p := abs(d[2]); fi;
  if abs(d[3]) < p then b := [0,0,1]; p := abs(d[3]); fi;
  b := b -~ dp(d,b) *~ d;
  b := b /~ sqrt(dp(b,b));
  k := 0;
  c := c0;
  l := s;
 else
  b := b /~ sqrt(dp(b,b));
  c := evalf(c0 +~ q *~ b);
#  l := s * `A/pants_tube`(s * k / 2);
  alpha := 2 * arccos(ca);
  l := alpha / k;
  m := c -~ b /~ k;
  pic := display(
   point(c1,colour=black),
   line(c1,c2,colour=black),
   arrow(c1,0.3*~n1,cross_product(b,d),0.05,0.1,0.025,colour=magenta),
   arrow(c2,0.3*~n2,cross_product(b,d),0.05,0.1,0.025,colour=magenta),
   line(c0,c,colour=orange),
   line(m,c1,colour=purple),
   line(m,c2,colour=purple),
   spacecurve(m +~ (cos(t)/k) *~ b +~ (sin(t)/k) *~ d,t=-alpha/2..alpha/2,colour=cyan),
   scaling=constrained,axes=none
  );
 fi;

 T := table([
  "c1" = evalf(c1), "c2" = evalf(c2), "n1" = evalf(n1), "n2" = evalf(n2), "d" = d, "s" = s, "c0" = c0, "ca" = ca, "sa" = sa, "q" = q, "alpha" = alpha,
  "centre" = c,
  "direction" = d,
  "bend" = b,
  "length" = l,
  "curvature" = k,
  "pic" = pic
 ]);

 return eval(T);
end:

`pants_joiner/pants_tube` := proc(P1,i1,P2,i2)
 local dp,a1,a2,c1,c2,n1,n2;
 dp := `dot/R`(3);
 a1 := P1["centre"];
 a2 := P2["centre"];
 c1 := P1["circle_centres"][modp(i1-1,3)+1];
 c2 := P2["circle_centres"][modp(i2-1,3)+1];
 n1 := a1 -~ c1;
 n2 := a2 -~ c2;
 n1 := n1 /~ sqrt(dp(n1,n1));
 n2 := n2 /~ sqrt(dp(n2,n2));
 return `joiner/pants_tube`(c1,n1,c2,n2);
end:


var $arr1 <[10] i32>
var $arr2 <[10] i32>
var $arr3 <[10] i32>

func $ArrayAdd () void {
 var %i i32
 doloop %i (
  constval i32 0,
  lt i32 i32 (dread i32 %i, constval i32 10),
  add i32(dread i32 %i, constval i32 1)){
   iassign <* [10] i32>(
    array 1 a32 <* [10] i32>(addrof a32 $arr1, dread i32 %i),
    add i32(
     iread i32 <* [10] i32>(
      array 1 a32 <* [10] i32>(addrof a32 $arr2, dread i32 %i)),
     iread i32 <* [10] i32>(
      array 1 a32 <* [10] i32>(addrof a32 $arr3, dread i32 %i))
     ))
  }
  return()
}
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


# Inverse Dynamics for Robot with IC
# Einleitung
# Berechnung der inversen Dynamik für Roboter mit impliziten Zwangsbedingungen
#
# Dateiname:
# robot -> Berechnung für allgemeinen Roboter
# implicit_constraints -> Berechnung für Roboter mit impliziten Zwangsbedingungen
# rotmat -> Kinematik wird mit Rotationsmatrizen berechnet
# dynamics -> Berechnung der Dynamik
# worldframe -> Berechnung basierend auf Energien aus Welt-KS (KS W)
# par1 -> Parametersatz 1 (Schwerpunkt als Parameter: SX,SY,SZ)
# reg2 -> Regressorform
# Autor
# Tim Job (HiWi-Job bei Moritz Schappler), 2019-05
# Moritz Schappler, moritz.schappler@imes.uni-hannover.de
# (C) Institut für Mechatronische Systeme, Universität Hannover
# Sources
# [ParkChoPlo1999] Park, FC and Choi, Jihyeon and Ploen, SR: Symbolic formulation of closed chain dynamics in independent coordinates
# [Docquier2013] Docquier, Nicolas and Poncelet, Antoine and Fisette, Paul: ROBOTRAN: a powerful symbolic gnerator of multibody models (2013)
# [DoThanhKotHeiOrt2009b] Do Thanh et al.: On the inverse dynamics problem of general parallel robots (2009)
# Initialization
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):
with(ArrayTools):
with(codegen):
with(CodeGeneration):
with(StringTools):
# Einstellungen für Code-Export: Optimierungsgrad (2=höchster) und Aktivierung jedes Terms.
#codegen_act := true: # noch nicht implementiert
codegen_debug := false:
codegen_opt := 2:
read "../helper/proc_MatlabExport":
read "../robot_codegen_definitions/robot_env_IC":
read sprintf("../codeexport/%s/tmp/tree_floatb_definitions", robot_name_OL):
read "../robot_codegen_definitions/robot_env_IC":
if base_method_name="twist" then # Basis-Methode "twist" wird (hier) nur für fixed Base benutzt
  expstring:="fixb":
elif base_method_name="eulxyz" then
  expstring:="floatb_eulxyz":
else
  printf("Nicht behandelte Basis-Methode: %s\n", base_method_name):
fi:
# Kennung des Parametersatzes, für den die Dynamikfunktionen erstellt werden sollen. Muss im Repo und in der mpl-Datei auf 1 gelassen werden, da die folgende Zeile mit einem Skript verarbeitet wird.
codegen_dynpar := 1:
regressor_modus := "regressor":
herleitungsverfahren := "lagrange":
codeexport_invdyn := false:
codeexport_grav_inertia := false:
codeexport_coriolisvec := false:
codeexport_regressor := false:
if herleitungsverfahren = "lagrange" then #Dynamik aus Lagrange
# Ergebnisse der inversen Dynamik für par1/2 laden
  if codeexport_invdyn then
    read sprintf("../codeexport/%s/tmp/invdyn_fixb_par%d_maple.m", robot_name_OL, codegen_dynpar):
    tau := Matrix(taus_fixb(7..NQ,1)):
    printf("%s. Generiere inverse Dynamik (%s) für %s basierend auf IC-Jacobi und OL-Dynamik mit Parametersatz %d  und %s\n", \
      FormatTime("%Y-%m-%d %H:%M:%S"), herleitungsverfahren, robot_name, codegen_dynpar, base_method_name):
  fi:
# Ergebnisse der inversen Dynamik in Regressorform laden
  if codeexport_regressor then
    read sprintf("../codeexport/%s/tmp/invdyn_%s_%s_maple.m", robot_name_OL, expstring, regressor_modus):
    tau_regressor_s := tau_regressor_s(7..NQ,..):
    printf("%s. Generiere Dynamik in Regressorform (%s) für %s basierend auf IC-Jacobi und OL-Dynamik\n", \
      FormatTime("%Y-%m-%d %H:%M:%S"), herleitungsverfahren, robot_name):
  fi:
# Ergebnisse der Massenmatrix und des Gravitationsvektors laden
  if codeexport_grav_inertia then
    read sprintf("../codeexport/%s/tmp/gravload_par%d_maple.m", robot_name_OL, codegen_dynpar):
    taug := Matrix(taug_s(7..NQ,..)):
    read sprintf("../codeexport/%s/tmp/inertia_par%d_maple.m", robot_name_OL, codegen_dynpar):
    MM := Matrix(MM_s(7..NQ,7..NQ)):
    read sprintf("../codeexport/%s/tmp/coriolisvec_par%d_maple.m", robot_name_OL, codegen_dynpar):
    tauCC := Matrix(tauCC_s(7..NQ,..)):
    printf("%s. Generiere Gravitationsvektor und Massenmatrix (%s) für %s basierend auf IC-Jacobi und OL-Dynamik mit Parametersatz %d und %s\n",\
      FormatTime("%Y-%m-%d %H:%M:%S"), herleitungsverfahren, robot_name, codegen_dynpar, base_method_name):
  fi:

# Ergebnisse des Coriolisvektors laden. Noch nicht implementiert.
  if codeexport_coriolisvec then
    read sprintf("../codeexport/%s/tmp/coriolisvec_par%d_maple.m", robot_name_OL, codegen_dynpar):
    tauCC := Matrix(tauCC_s(7..NQ,..)):
    read sprintf("../codeexport/%s/tmp/inertia_par%d_maple.m", robot_name_OL, codegen_dynpar):
    MM := Matrix(MM_s(7..NQ,7..NQ)):
    printf("%s. Generiere Coriolisvektor (%s) für %s basierend auf IC-Jacobi und OL-Dynamik mit Parametersatz %d und %s\n", \
      FormatTime("%Y-%m-%d %H:%M:%S"), herleitungsverfahren, robot_name, codegen_dynpar, base_method_name):
  fi:
else #Dynamik aus Newton-Euler
# Ergebnisse der inversen Dynamik für par1/2 laden
  invdynfile:=sprintf("../codeexport/%s/tmp/invdyn_twist_NewtonEuler_linkframe_par%d_maple.m", robot_name_OL, codegen_dynpar):
  if FileTools[Exists](invdynfile) then
    read invdynfile:
  else
    printf("%s. Inversdynamik der offenen Kette wurde nicht berechnet. Abbruch der Newton-Euler-Berechnung (Regressorform).\n", \
      FormatTime("%Y-%m-%d %H:%M:%S")):
    quit: # Funktioniert in GUI nicht richtig...
    robot_name := "": # ...Daher auch Löschung des Roboternamens.
  end if:
  tau := Matrix(tau_J(1..NQJ,..)):
  taug := copy(tau):
  for i from 1 to NQ do
    taug := subs({qD_s[i,1]=0},taug):
    taug := subs({qDD_s[i,1]=0},taug):
  end do:
  printf("%s. Generiere Gravitationsvektor und gesamte inverse Dynamik (%s) für %s basierend auf IC-Jacobi und OL-Dynamik mit Parametersatz %d\n", \
    FormatTime("%Y-%m-%d %H:%M:%S"), herleitungsverfahren, robot_name, codegen_dynpar):
fi:
# Ergebnisse der impliziten Zwangsbedingungen laden
read sprintf("../codeexport/%s/tmp/kinconstr_impl_projection_jacobian_maple", robot_name):
B21 := B21:
read sprintf("../codeexport/%s/tmp/kinconstr_impl_projection_jacobian_derivative_maple", robot_name):
B21D := B21D:
# Ergebnisse des Positionsvektors und der aktiven und passiven Gelenke laden
read sprintf("../codeexport/%s/tmp/positionVector_NQJ_maple.m", robot_name):
posNQJ := posNQJ:
# Pertubationsmatrizen berechnen
# Entferne aktive/passive Koordinaten zur Umrechnung
# Berechne die Anzahl aller aktiven und passiven Gelenke (inkl virtueller Schnittgelenke)
NAJ := add(mu(k), k=1..NJ):
NPJ := NJ-NAJ:
# Bestimme Indizes der aktiven und passiven Gelenke
# Entspricht Partitionierung der Gelenkwinkel in q1 und q2 in [Docquier2013]. Hier kann die Reihenfolge von aktiven und passiven Winkeln auch durchmischt sein.
IndAct := Matrix(NAJ, 1):
IndPass:= Matrix(NPJ, 1):
ka := 1: kp := 1:
for i from 1 to NJ do
  if mu(i) = 1 then
    IndAct(ka) := i:
    ka := ka + 1:
  else
    IndPass(kp) := i:
    kp := kp + 1:
  end if:
end do:
# Entfernt die Einträge aus IndPass/IndAct, die virtuelle Schnittglenke sind
for i from 1 to NJ do
  if posNQJ(i) = 0 then
    posAct := ListTools[Search](i, convert(IndAct, list)):
    if posAct <> 0 then
      IndAct := DeleteRow(IndAct,posAct):
    end if:
    #posPass := ListTools[Search](i, convert(IndPass, list)):
    #if posPass <> 0 then
    #  IndPass := DeleteRow(IndPass,posPass):
    #end if:
  end if:
end do:
NQJA := RowDimension(IndAct):
NQJP := NQJ-NQJA: #RowDimension(IndPass):
IndPass:= Matrix(NQJP, 1):
kp := 1: ka := 1:
for i from 1 to NQJ do
  if ListTools[Search](i, convert(IndAct, list)) = 0 then
    IndPass(kp) := i:
    kp := kp + 1:
  end if:
end do:
# Permutationsmatrizen berechnen zur Umrechnung von aufgeteilten Koordinaten
# (aktiv/passiv nacheinander) in Koordinaten der Baumstruktur (aktiv/passiv gemischt)
P1 := Matrix(NQJA,NQJ):
P2 := Matrix(NQJP,NQJ):
for i from 1 to NQJA do
  P1(i,IndAct(i)) := 1:
end do:
for i from 1 to NQJP do
  P2(i,IndPass(i)) := 1:
end do:
# Inverse Dynamik
# explizit [Docquier2013], Gl. 12
W := Transpose(P1 + Transpose(B21).P2):
WD := Transpose(Transpose(B21D).P2):
#q1D_s := Transpose(W).qJD_s:
tauIC := Transpose(W).tau:
taugIC := Transpose(W).taug:
# [DoThanhKotHeiOrt2009b], Gl. (23); [ParkChoPlo1999] Gl. (56)
#tauCCIC := Transpose(W).tauCC + Transpose(W).MM.WD.q1D_s: # noch nicht implementiert
;
tauIC_regressor := P1.tau_regressor_s + Transpose(B21).P2.tau_regressor_s:
if herleitungsverfahren = "newton" then
  tau_MM := copy(tau):
  for i to NQ do
    tau_MM := subs(qD_s[i, 1] = 0,tau_MM);
  end do:

  MM := Matrix(NQJ, NQJ):
  for i to NQJ do
    for j to NQJ do
      MM[i, j] := diff(tau_MM[i, 1], qDD_s[6+j, 1]):
    end do:
  end do:
end if:
# [ParkChoPlo1999], Gl. 55; [DoThanhKotHeiOrt2009b], Gl. (23)
MMIC := Transpose(W).MM.W:
# Export
# Export der Belastung der Gelenke
# Floating Base
if codeexport_invdyn and not(base_method_name="twist") then
  MatlabExport(tauIC, sprintf("../codeexport/%s/tmp/invdyn_floatb_%s_par%d_ic_matlab.m", robot_name, base_method_name, codegen_dynpar), codegen_opt):
end if:
if codeexport_regressor and not(base_method_name="twist") then
  MatlabExport(tauIC_regressor, sprintf("../codeexport/%s/tmp/invdyn_floatb_%s_%s_ic_matlab.m", robot_name, base_method_name, regressor_modus), codegen_opt):
end if:
# Fixed Base
if codeexport_invdyn then
  tauIC_fixb:=tauIC:
  for i from 1 to NQB do
    tauIC_fixb := subs({X_base_s[i,1]=0},tauIC_fixb):
  end do:
  for i from 1 to 6 do
    tauIC_fixb := subs({V_base_s[i,1]=0},tauIC_fixb):
    tauIC_fixb := subs({VD_base_s[i,1]=0},tauIC_fixb):
  end do:
  MatlabExport(tauIC_fixb, sprintf("../codeexport/%s/tmp/invdyn_fixb_par%d_ic_matlab.m", robot_name, codegen_dynpar), codegen_opt):
end if:
if codeexport_grav_inertia then
  taugIC_fixb:=taugIC:
  MMIC_fixb:=MMIC:
  for i from 1 to NQB do
    MMIC_fixb := subs({X_base_s[i,1]=0},MMIC_fixb):
  end do:
  for i from 1 to 6 do
    MMIC_fixb := subs({V_base_s[i,1]=0},MMIC_fixb):
    MMIC_fixb := subs({VD_base_s[i,1]=0},MMIC_fixb):
  end do:
  MatlabExport(taugIC_fixb, sprintf("../codeexport/%s/tmp/gravload_joint_floatb_twist_par%d_ic_matlab.m", robot_name, codegen_dynpar), codegen_opt):
  MatlabExport(MMIC_fixb, sprintf("../codeexport/%s/tmp/inertia_joint_joint_floatb_%s_par%d_ic_matlab.m", robot_name, base_method_name, codegen_dynpar), codegen_opt):
end if:
# Noch nicht implementiert
if codeexport_coriolisvec then
  tauCCIC_fixb:=tauCCIC:
  for i from 1 to NQB do
    tauCCIC_fixb := subs({X_base_s[i,1]=0},tauCCIC_fixb):
  end do:
  for i from 1 to 6 do
    tauCCIC_fixb := subs({V_base_s[i,1]=0},tauCCIC_fixb):
    tauCCIC_fixb := subs({VD_base_s[i,1]=0},tauCCIC_fixb):
  end do:
  MatlabExport(tauCCIC_fixb, sprintf("../codeexport/%s/tmp/coriolisvec_joint_fixb_twist_par%d_ic_matlab.m", robot_name, codegen_dynpar), codegen_opt):
end if:
if codeexport_regressor then
  tauIC_regressor_fixb:=tauIC_regressor:
  for i from 1 to NQB do
    tauIC_regressor_fixb := subs({X_base_s[i,1]=0},tauIC_regressor_fixb):
  end do:
  for i from 1 to 6 do
    tauIC_regressor_fixb := subs({V_base_s[i,1]=0},tauIC_regressor_fixb):
    tauIC_regressor_fixb := subs({VD_base_s[i,1]=0},tauIC_regressor_fixb):
  end do:
  MatlabExport(tauIC_regressor_fixb, sprintf("../codeexport/%s/tmp/invdyn_fixb_%s_ic_matlab.m", robot_name, regressor_modus), codegen_opt):
end if:
if herleitungsverfahren = "newton" then
  tauIC_fixb:=tauIC:
  taugIC_fixb:=taugIC:
  MMIC_fixb:=MMIC:
  for i from 1 to NQB do
    tauIC_fixb := subs({X_base_s[i,1]=0},tauIC_fixb):
    MMIC_fixb := subs({X_base_s[i,1]=0},MMIC_fixb):
  end do:
  for i from 1 to 6 do
    tauIC_fixb := subs({V_base_s[i,1]=0},tauIC_fixb):
    tauIC_fixb := subs({VD_base_s[i,1]=0},tauIC_fixb):
    MMIC_fixb := subs({V_base_s[i,1]=0},MMIC_fixb):
    MMIC_fixb := subs({VD_base_s[i,1]=0},MMIC_fixb):
  end do:
  MatlabExport(tauIC_fixb, sprintf("../codeexport/%s/tmp/invdyn_fixb_snew_par%d_ic_matlab.m", robot_name, codegen_dynpar), codegen_opt):
  MatlabExport(taugIC_fixb, sprintf("../codeexport/%s/tmp/gravload_joint_floatb_twist_snew_par%d_ic_matlab.m", robot_name, codegen_dynpar), codegen_opt):
  MatlabExport(MMIC_fixb, sprintf("../codeexport/%s/tmp/inertia_joint_joint_floatb_%s_snew_par%d_ic_matlab.m", robot_name, base_method_name, codegen_dynpar), codegen_opt):
end if:
# Export Anzahl der aktiven Koordinaten NAJ
MatlabExport(NAJ, sprintf("../codeexport/%s/tmp/NAJ_ic_matlab.m", robot_name), codegen_opt):


# This file sets up the theory of the simplicial category, with simplicial
# maps encoded as lists of values.  This is an alternative to simplicial.mpl,
# where simplicial maps are encoded as tables.  This version is more efficient,
# but suffers from the fact that Maple uses 1-based indexing, so we need a
# lot of extra +1's.

`is_element/simplicial_maps_alt` := (n::nonnegint,m::nonnegint) -> proc(f)
 evalb(type(f,list(nonnegint)) and nops(f) = n+1 and max(op(f)) <= m)
end:

`is_leq/simplicial_maps_alt` := (n::nonnegint,m::nonnegint) -> proc(f,g)
 evalb( min(op(g -~ f)) >= 0 );
end:

# This assumes that
# *  p is a subset of {1,...,n} of size k
# *  q is a subset of {0,...,m} of size k+1
# It returns the nondecreasing map f : {0,...,n} -> {0,...,m} such that
# *  The image of f is q
# * { i > 0 : f(i) > f(i-1) } = p.

`build/simplicial_maps_alt` :=  (n::nonnegint,m::nonnegint) -> proc(k,p,q)
 local pp,i,j,f;
 pp := [0,op(p),n+1];
 f := NULL;
 i := 0;
 for i from 0 to k do
  for j from pp[i+1] to pp[i+2]-1 do
   f := f,q[i+1];
  od;
 od;

 return [f];
end:

`random_element/simplicial_maps_alt` := (n::nonnegint,m::nonnegint) -> proc()
 local p,q,i,j,k,l,f;

 k := rand(0..min(n,m))();
 p := combinat[randcomb](n,k);
 q := combinat[randcomb](m+1,k+1) -~ 1;
 return `build/simplicial_maps_alt`(n,m)(k,p,q);
end:

`list_elements/simplicial_maps_alt` := proc(n::nonnegint,m::nonnegint)
 option remember;
 local i;

 if n = 0 then
  return [seq(`C/simplicial_maps_alt`(0,i),i=0..m)];
 else
  if m = 0 then
   return [`C/simplicial_maps_alt`(n,0)];
  else
   return [op(map(`I/simplicial_maps_alt`(n,m-1),
                   `list_elements/simplicial_maps_alt`(n,m-1))),
           op(map(`T/simplicial_maps_alt`(n-1,m),
	           `list_elements/simplicial_maps_alt`(n-1,m)))];
  fi;
 fi;
end:

`count_elements/simplicial_maps_alt` := (n::nonnegint,m::nonnegint) -> binomial(n+m+1,m);

# Constant maps
`C/simplicial_maps_alt` := proc(n::nonnegint,k::nonnegint)
 [k$(n+1)]
end:

# Inclusion Delta(n,m) -> Delta(n,m+1)
`I/simplicial_maps_alt` := (n::nonnegint,m::nonnegint) -> proc(f)
 f;
end:

# Map Delta(n,m) -> Delta(n+1,m): extend by sending n+1 to m
`T/simplicial_maps_alt` := (n::nonnegint,m::nonnegint) -> proc(f)
 [op(f),m];
end:

# `delta/simplicial_maps_alt`(n)(i) : [n] >-> [n+1]; image omits i
`delta/simplicial_maps_alt` := proc(n::nonnegint,i::nonnegint)
 local j;
 if i > n+1 then return FAIL; fi;
 return [seq(j,j=0..i-1),seq(j+1,j=i..n)];
end:

# `sigma/simplicial_maps_alt`(n)(i) : [n] ->> [n-1]; takes the value i twice
`sigma/simplicial_maps_alt` := proc(n::nonnegint,i::nonnegint)
 local j;
 if i > n-1 then return FAIL; fi;
 return [seq(j,j=0..i),seq(j-1,j=i+1..n)];
end:

`id/simplicial_maps_alt` := proc(n::nonnegint)
 local i;
 return [seq(i=i,i=0..n)];
end:

`eval/simplicial_maps_alt` := (n::nonnegint,m::nonnegint) -> (f) -> (i) -> f[i+1];

# `compose/simplicial_maps`(n,m,p)(f,g) assumes that f:[n] -> [m] and g:[m] -> [p],
# and it returns the composite g o f : [n] -> [p].

`compose/simplicial_maps_alt` := (n::nonnegint,m::nonnegint,p::nonnegint) -> proc(f,g)
 local i;
 [seq(g[f[i+1]+1],i=0..n)];
end:

`is_wide/simplicial_maps_alt` := (n::nonnegint,m::nonnegint) -> proc(f)
 return evalb(f[1] = 0 and f[n+1] = m);
end:

`is_mono/simplicial_maps_alt` := (n::nonnegint,m::nonnegint) -> proc(f)
 evalb(nops({op(f)}) = n+1);
end:

`is_epi/simplicial_maps_alt` := (n::nonnegint,m::nonnegint) -> proc(f)
 local j;
 evalb({op(f)} = {seq(j,j=0..m)});
end:

# This assumes that f : [n] -> [m], and it returns [k,g,h] such that
# g : [n] ->> [k] and h : [k] >-> [m] and f = h o g

`factor/simplicial_maps_alt` := (n::nonnegint,m::nonnegint) -> proc(f)
 local K,k,g,h,hi,i;

 h := sort([op({op(f)})]);
 k := nops(h) - 1;
 hi := table();
 for i from 0 to k do hi[h[i+1]] := i; od;
 g := [seq(hi[f[i+1]],i=0..n)];
 return [k,g,h];
end:

`describe/simplicial_maps_alt` := (n::nonnegint) -> proc(f)
 local i;
 cat(seq(nat_code[f[i]],i=1..n+1));
end:

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

`is_element/simplicial_epi_alt` := (n::nonnegint,m::nonnegint) -> proc(f)
 global reason;

 if not(`is_element/simplicial_maps_alt`(n,m)(f)) then
  reason := [convert(procname,string),"not a simplicial map from [n] to [m]",reason];
  return false;
 fi;

 return `is_epi/simplicial_maps_alt`(n,m)(f);
end:

`is_leq/simplicial_epi_alt` :=  (n::nonnegint,m::nonnegint) -> proc(f,g)
 `is_leq/simplicial_maps_alt`(n,m)(f,g);
end:

`random_element/simplicial_epi_alt` := (n::nonnegint,m::nonnegint) -> proc()
 local p,q,k,f,i;

 if n < m then return FAIL; fi;

 k := m;
 p := combinat[randcomb](n,k);
 q := [seq(i,i=0..m)];
 return `build/simplicial_maps_alt`(n,m)(k,p,q);
end:

`list_elements/simplicial_epi_alt` := proc(n::nonnegint,m::nonnegint)
 local P,L,S,i,j;

 P := combinat[choose]([seq(i,i=1..n)],m);
 L := map(S -> [0$S[1],seq(j$(S[j+1]-S[j]),j=1..m-1),m$(n+1-S[m])],P);

 return L;
end:

`count_elements/simplicial_epi_alt` := (n::nonnegint,m::nonnegint) -> binomial(n,m);

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

`is_element/simplicial_mono_alt` := (n::nonnegint,m::nonnegint) -> proc(f)
 global reason;

 if not(`is_element/simplicial_maps_alt`(n,m)(f)) then
  reason := [convert(procname,string),"not a simplicial map from [n] to [m]",reason];
  return false;
 fi;

 return `is_mono/simplicial_maps_alt`(n,m)(f);
end:

`is_leq/simplicial_mono_alt` :=  (n::nonnegint,m::nonnegint) -> proc(f,g)
 `is_leq/simplicial_maps_alt`(n,m)(f,g);
end:

`random_element/simplicial_mono_alt` := (n::nonnegint,m::nonnegint) -> proc()
 local p,q,i,j,k,l,f;

 if n > m then return FAIL; fi;

 q := combinat[randcomb](m+1,n+1) -~ 1;
 q := sort([op(q)]);
 return q;
end:

`list_elements/simplicial_mono_alt` := proc(n::nonnegint,m::nonnegint)
 map(q -> q -~ 1,combinat[choose](m+1,n+1));
end:

`count_elements/simplicial_mono_alt` := (n::nonnegint,m::nonnegint) -> binomial(m+1,n+1);


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

# General framework for operads freely generated by a strongly
# reduced Sigma-module.

`is_element/Phi/generic` := (gen_name,el_test) -> (A::set) ->
proc(TTm)
 local pn,TT,m,TT1,C,T;
 global reason;

 pn := cat("is_element/Phi/",gen_name);

 if not(type(TTm,list) and nops(TTm) = 2) then
  reason := [pn,"TTm is not a list of length two"];
  return false;
 fi;

 TT,m := op(TTm);

 if not(`is_element/full_trees`(A)(TT)) then
  reason := [pn,"TT is not a full tree on A",TT,A];
  return false;
 fi;

 if not type(m,table) then
  reason := [pn,"m is not a table"];
  return false;
 fi;

 if map(nops,{indices(m)}) <> {1} then
  reason := [pn,"m is not a unidimensional table"];
  return false;
 fi;

 TT1 := map(op,[indices(m)]);

 if {op(TT1)} <> select(T -> nops(T) > 1,TT) then
  reason := [pn,"m is not indexed by the big sets in TT",TT1,TT];
  return false;
 fi;

 C := children_map(A)(TT);

 for T in TT1 do
  if not(el_test(C[T])(m[T])) then
   reason := [pn,"m[T] is not in M(C[T])",m[T],T,C[T]];
   return false;
  fi;
 od;

 return true;
end;

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

`is_equal/Phi/generic` :=  (gen_name,eq_test) -> (A::set) ->
proc(TTm,UUn)
 local pn,TT,m,UU,n,C,TT1,T;
 global reason;

 pn := cat("is_element/realisation/",poset_name);

 TT,m := op(TTm);
 UU,n := op(UUn);

 if not(`is_equal/full_trees`(A)(TT,UU)) then
  reason := [pn,"TT <> UU",TT,UU];
  return false;
 fi;

 C := children_map(A)(TT);
 TT1 := select(T -> nops(T) > 1,TT);

 for T in TT1 do
  if not(eq_test(C[T])(m[T],n[T])) then
   reason := [pn,"m[T] <> n[T]",T,C[T],m[T],n[T]];
   return false;
  fi;
 od;

 return true;
end;

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

`eta/Phi/generic` := (gen_name) -> (A::set) -> `if`(nops(A) = 1,[{A},table()],FAIL);

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

`gamma/Phi/generic` := (gen_name,action) -> (A::set,B::set) -> (p) -> proc(UUn,TTm)
 local F,FF,UU,UU1,CU,CV,CT,U,U0,Ui,CU0,CU1,TT,T,VV,f,b,m,n,o;

 F := fibres(A,B)(p);
 UU,n := op(UUn);
 CU := children_map(B)(UU);
 FF := table();
 for U in UU do
  FF[U] := `union`(seq(F[b],b in U));
 od;

 TT := table();
 CT := table();
 m := table();

 for b in B do
  TT[b],m[b] := op(TTm[b]);
  CT[b] := children_map(F[b])(TT[b]);
 od;

 VV := `gamma/trees`(A,B)(p)(UU,TT);
 CV := children_map(A)(VV);

 o := table();
 UU1 := select(U -> nops(U) > 1,UU);
 for U in UU do
  Ui := FF[U];
  CU0 := CU[U];
  CU1 := CV[Ui];
  f := table();
  for U0 in CU0 do f[U0] := FF[U0]; od;
  o[Ui] := action(CU0,CU1)(f)(n[U]);
 od;

 for b in B do
  for T in TT[b] do
   if nops(T) > 1 then
    o[T] := m[b](T);
   fi;
  od;
 od;

 return(eval([VV,o]));
end:

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

`zeta/Phi/generic` := (gen_name,action) -> (A::set) -> proc(m)
 local TT,n,f,A1,a;

 if nops(A) = 1 then return(`eta/Phi/generic`(gen_name)(A)); fi;

 TT := corolla(A);
 n := table();
 f := table();
 A1 := {seq({a},a in A)};
 for a in A do f[a] := {a}; od;
 n[A] := action(A,A1)(f)(m);
 return eval([TT,n]);
end:

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

`epsilon/Phi/generic` := (gen_name,eta,gamma) -> (A::set) -> proc(TTm)
 local TT,m;

 TT,m := op(TTm);
 return `theta/Xi/generic`(gen_name,eta,gamma)(A)(TT,corolla(A))(m);
end;


 func $fooi64 (
  var %i i64, var %j i64
  ) i64 {
   return (
     add i64(dread i64 %i, dread i64 %j))}

 func $addi64I (
  var %i i64
  ) i64 {
   return (
#add i64(dread i64 %i, constval i64 0x123456789))}
     add i64(dread i64 %i, constval i64 0x800000115))}
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


cdir := "/home/scott/Documents/research/software/hqca/hqca/maple/test_cases/":
with(LinearAlgebra): with(ArrayTools): with(QuantumChemistry):
loaddata := readdata(cat(cdir,"tmp7bh4a4ao.rdm"), 8):
Flatten := proc(x) local n, a, i, j, k, l; `local`(a, n, i, j, k, l); `description`("convert chemists to numpy and flatten an array to form a matrix"); n := Size(x); a := Matrix(1 .. n[1]*n[2], 1 .. n[3]*n[4], datatype = float[8]); for i to round(n[1]) do for j to round(n[2]) do for k to round(n[3]) do for l to round(n[4]) do a[(i - 1)*n[1] + j, (k - 1)*n[3] + l] := x[i, j, k, l]; end do; end do; end do; end do; return a; end proc:
New := Array(1 .. 4, 1 .. 4, 1 .. 4, 1 .. 4, datatype = float[8]):
for i in loaddata[3 .. ()] do
    New[round(i[1]), round(i[2]), round(i[3]), round(i[4])] := i[5]:
end do:
Transpose(Re(Eigenvalues(Flatten(New))));
pure := Purify2RDM(New, spin_free = false, electron_number=4, conv_tol = 0.00000000001):
ExportMatrix(cat(cdir, "_temp_purified.csv"), Flatten(pure[rdm2])):


(*
 Copyright (C) 2017 M.A.L. Marques

 This Source Code Form is subject to the terms of the Mozilla Public
 License, v. 2.0. If a copy of the MPL was not distributed with this
 file, You can obtain one at http://mozilla.org/MPL/2.0/.
*)

(* type: mgga_exc *)
(* prefix:
  mgga_c_revtpss_params *params;

  assert(p->params != NULL);
  params = (mgga_c_revtpss_params * )(p->params);
*)

$include "gga_c_regtpss.mpl"
$include "tpss_c.mpl"

f := (rs, z, xt, xs0, xs1, us0, us1, ts0, ts1) ->
  + tpss_f(f_pbe, rs, z, xt, xs0, xs1, ts0, ts1):


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

`is_element/stasheff_star` := (A::set) -> proc(Rt)
 local R,t,n,JJ,TT,J,u,i,j,k;
 global reason;

 if not(type(Rt,list) and nops(Rt) = 2) then
  reason := [convert(procname,string),"Rt cannot be split as [R,t]",Rt];
  return false;
 fi;

 R,t := op(Rt);

 if not(`is_element/ord`(A)(R)) then
  reason := [convert(procname,string),"R is not an order on A",R,A,reason];
  return false;
 fi;

 n := nops(A);
 JJ := {seq(seq({seq(R[k],k=i..j)},j=i..n),i=1..n)};

 if not(type(t,table)) then
  reason := [convert(procname,string),"t is not a table",t];
  return false;
 fi;

 if map(op,{indices(t)}) <> JJ then
  reason := [convert(procname,string),"t is not indexed by the set of R-intervals",t,R,JJ];
  return false;
 fi;

 TT := NULL;

 for J in JJ do
  u := t[J];

  if not (`is_element/RR`(u) and u >= 0 and u <= 1) then
   reason := [convert(procname,string),"t[J] is not in the unit interval",J,t[J]];
   return false;
  fi;

  if (nops(J) = 1 and u <> 1) then
   reason := [convert(procname,string),"t[{a}] <> 1",op(J),t[J]];
   return false;
  fi;

  if (nops(J) = 1 or nops(J) = n) and u <> 1 then
   reason := [convert(procname,string),"t[A] <> 1",A,t[J]];
   return false;
  fi;

  if u > 0 then TT := TT,J; fi;
 od;

 TT := {TT};

 if not(`is_element/trees`(A)(TT)) then
  reason := [convert(procname,string),"TT is not a tree",TT,reason];
  return false;
 fi;

 return true;
end;

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

`is_equal/stasheff_star` := (A::set) -> proc(Rt1,Rt2)
 local R1,R2,t1,t2,n,JJ,J,i,j,k;

 R1,t1 := op(Rt1);
 R2,t2 := op(Rt2);

 if not(`is_equal/ord`(A)(R1,R2)) then
  return false;
 fi;

 n := nops(A);
 JJ := {seq(seq({seq(R1[k],k=i..j)},j=i..n),i=1..n)};

 for J in JJ do
  if t1[J] <> t2[J] then return false; fi;
 od;

 return true;
end:

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

`is_leq/stasheff_star` := NULL;

######################################################################
# Covariant functoriality for bijections p : A -> B.

`act/stasheff_star` := (A::set,B::set) -> (p) -> proc(Rt)
 local R,t,S,u,JJ,J,J1;

 R,t := op(Rt);
 S := map(a -> p[a],R);
 u := table();
 JJ := map(op,[indices(t)]);
 for J in JJ do
  J1 := map(a -> p[a],J);
  u[J1] := t[J];
 od:
 return [S,eval(u)];
end:

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

`random_element/stasheff_star` := (A::set) -> proc()
 local R,t0,JJ0,J0,t,J;

 R := `random_element/ord`(A)();
 t0 := `random_element/standard_stasheff_star`(nops(A))();

 JJ0 := map(op,[indices(t0)]);
 t := table();
 for J0 in JJ0 do
  J := map(i -> R[i],J0);
  t[J] := t0[J0];
 od:

 return [R,eval(t)];
end:

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

`list_elements/stasheff_star` := NULL;
`count_elements/stasheff_star` := NULL;

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

`phi/stasheff_trees/stasheff_star` := (A::set) -> proc(RTT)
 local R,TT,n,JJ,J,t,i,j,k;

 R,TT := op(RTT);

 n := nops(R);
 JJ := {seq(seq({seq(R[k],k=i..j)},j=i..n),i=1..n)};
 t := table();

 for J in JJ do t[J] := 0; od;
 for J in TT do t[J] := 1; od;

 return [R,eval(t)];
end;

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

`phi/realisation/stasheff_trees/stasheff_star` := (A::set) -> proc(x)
 local y,C,R,n,JJ,J,RTT,t,TT,z,i,j,k;

 y := table();
 C := map(op,[indices(x)]);
 R := C[1][1];
 n := nops(A);
 JJ := {seq(seq({seq(R[k],k=i..j)},j=i..n),i=1..n)};

 for J in JJ do y[J] := 0; od;

 for RTT in C do
  t := x[RTT];
  TT := RTT[2];
  z := `phi/stasheff_trees/stasheff_star`(A)(TT);
  for J in JJ do y[J] := y[J] + t * z[J]; od;
 od;

 return eval(y);
end:

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

`phi/stasheff_star/ord_simplex_interior` := (A::set) -> proc(Rt)
 local R,t,JJ,JS,Ja,J,K,lambda,mu,a,children;

 R,t := op(Rt);
 JJ := select(J -> t[J] > 0, map(op,{indices(t)}));
 children := `children_map`(A)(JJ);
 JS := sort([op(JJ),(U,V) -> nops(U) < nops(V)]);

 lambda := table();
 for J in JS do
  if nops(J) = 1 then
   lambda[J] := 1;
  else
   lambda[J] := add(lambda[K]^(1-t[K]),K in children[J]);
  fi;
 od;

 mu := table();
 for a in A do
  Ja := select(J -> member(a,J),JJ);
  mu[a] := mul(lambda[J]^(-t[J]),J in Ja);
 od;

 return [R,eval(mu)];
end;

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

`phi/stasheff_star/one_cubes_prime` := (A::set) -> proc(Rt)
 `phi/ord_simplex_interior/one_cubes_prime`(A)(
  `phi/stasheff_star/ord_simplex_interior`(A)(Rt));
end;

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

`proj/stasheff_star/ord` := (A::set) -> (Rt) -> Rt[1];

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

`describe/stasheff_star` := (A::set) -> proc(Rt)
 local R,t,n,r,i,TT;
 R,t := op(Rt);
 n := nops(A);
 r := table();
 for i from 1 to n do r[R[i]] := i; od:

 TT := map(op,[indices(t)]);
 TT := select(J -> (t[J] > 0 and nops(J) > 1),TT);
 TT := map(J -> [op(J)],TT);
 TT := map(sort,TT,(a,b) -> (r[a] < r[b]));
 TT := sort(TT,(J0,J1) -> (
        (nops(J0) < nops(J1)) or
        ((nops(J0) = nops(J1)) and (r[J0[1]] < r[J1[1]]))));
 return sprintf("%A",map(J -> (J=t[{op(J)}]),TT));
end;


 func $foo (
  var %i i32
#var %i1 i32, var %j1 i32, var %k1 i32
  ) i32 {
   return (
     depositbits i32 1 23(
       constval i32 0xfff, constval i32 0x11))}
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


da2 :=
[
    [#(1) filter9 ((1)-(34) are from http://homepages.math.uic.edu/~jan/demo.html)
        [m2*m4*m6 - 1/100,
 a*m4*b - 7/500,
 a**2 + m1**2 - 2/25,
 b**2 + m7**2 - 37/50,
 m3**2 + m5**2 + m4**2 + m2**2 + m6**2 - 9401/10000,
 m4**2*m6**2 + m2**2*m4**2 + m3**2*m6**2 + m2**2*m5**2
 + m3**2*m5**2 + m2**2*m6**2 - 38589/1000000,
 m1*m3*m5*m7 - m6*m1*m3*b + m2*m6*a*b - m2*a*m5*m7 + 81/10000,
 -m1*m2*m3*m4*b - a*m4*m5*m6*m7 + a*m4*b*m6**2 + a*m2**2*m4*b + 39/25000,
 -m4**2*m7**2 - m3**2*m7**2 + 2*m5*m6*b*m7 - m2**2*m7**2 - m5**2*m7**2
- m3**2*b**2 - b**2*m6**2 - m2**2*b**2 + 27173/40000
        ],
        [m1,m2,m3,m4,m5,m6,m7,a,b]
    ],
    [#(2) katsura6
        [ 1*x1+2*x2+2*x3+2*x4+2*x5+2*x6+2*x7-1,
 2*x4*x3+2*x5*x2+2*x6*x1+2*x7*x2-1*x6,
 1*x3^2+2*x4*x2+2*x5*x1+2*x6*x2+2*x7*x3-1*x5,
 2*x3*x2+2*x4*x1+2*x5*x2+2*x6*x3+2*x7*x4-1*x4,
 1*x2^2+2*x3*x1+2*x4*x2+2*x5*x3+2*x6*x4+2*x7*x5-1*x3,
 2*x2*x1+2*x3*x2+2*x4*x3+2*x5*x4+2*x6*x5+2*x7*x6-1*x2,
 1*x1^2+2*x2^2+2*x3^2+2*x4^2+2*x5^2+2*x6^2+2*x7^2-1*x1
        ],
        [x1,x2,x3,x4,x5,x6,x7]
    ],
    [#(3) katsura7
        [-x1+2*x8^2+2*x7^2+2*x6^2+2*x5^2+2*x4^2+2*x3^2+2*x2^2+x1^2,
 -x2+2*x8*x7+2*x7*x6+2*x6*x5+2*x5*x4+2*x4*x3+2*x3*x2+2*x2*x1,
 -x3+2*x8*x6+2*x7*x5+2*x6*x4+2*x5*x3+2*x4*x2+2*x3*x1+x2^2,
 -x4+2*x8*x5+2*x7*x4+2*x6*x3+2*x5*x2+2*x4*x1+2*x3*x2,
 -x5+2*x8*x4+2*x7*x3+2*x6*x2+2*x5*x1+2*x4*x2+x3^2,
 -x6+2*x8*x3+2*x7*x2+2*x6*x1+2*x5*x2+2*x4*x3,
 -x7+2*x8*x2+2*x7*x1+2*x6*x2+2*x5*x3+x4^2,
 -1+2*x8+2*x7+2*x6+2*x5+2*x4+2*x3+2*x2+x1
        ],
        [x1,x2,x3,x4,x5,x6,x7,x8]
    ],
    [#(4) katsura8
        [ -x1+2*x9^2+2*x8^2+2*x7^2+2*x6^2+2*x5^2+2*x4^2+2*x3^2+2*x2^2+x1^2,
 -x2+2*x9*x8+2*x8*x7+2*x7*x6+2*x6*x5+2*x5*x4+2*x4*x3+2*x3*x2+2*x2*x1,
 -x3+2*x9*x7+2*x8*x6+2*x7*x5+2*x6*x4+2*x5*x3+2*x4*x2+2*x3*x1+x2^2,
 -x4+2*x9*x6+2*x8*x5+2*x7*x4+2*x6*x3+2*x5*x2+2*x4*x1+2*x3*x2,
 -x5+2*x9*x5+2*x8*x4+2*x7*x3+2*x6*x2+2*x5*x1+2*x4*x2+x3^2,
 -x6+2*x9*x4+2*x8*x3+2*x7*x2+2*x6*x1+2*x5*x2+2*x4*x3,
 -x7+2*x9*x3+2*x8*x2+2*x7*x1+2*x6*x2+2*x5*x3+x4^2,
 -x8+2*x9*x2+2*x8*x1+2*x7*x2+2*x6*x3+2*x5*x4,
 -1+2*x9+2*x8+2*x7+2*x6+2*x5+2*x4+2*x3+2*x2+x1
        ],
        [x1,x2,x3,x4,x5,x6,x7,x8,x9]
    ],
    [#(5) katsura9
        [ -x1+2*x10^2+2*x9^2+2*x8^2+2*x7^2+2*x6^2+2*x5^2+2*x4^2+2*x3^2+2*x2^2+x1^2,
 -x2+2*x10*x9+2*x9*x8+2*x8*x7+2*x7*x6+2*x6*x5+2*x5*x4+2*x4*x3+2*x3*x2+2*x2*x1,
 -x3+2*x10*x8+2*x9*x7+2*x8*x6+2*x7*x5+2*x6*x4+2*x5*x3+2*x4*x2+2*x3*x1+x2^2,
 -x4+2*x10*x7+2*x9*x6+2*x8*x5+2*x7*x4+2*x6*x3+2*x5*x2+2*x4*x1+2*x3*x2,
 -x5+2*x10*x6+2*x9*x5+2*x8*x4+2*x7*x3+2*x6*x2+2*x5*x1+2*x4*x2+x3^2,
 -x6+2*x10*x5+2*x9*x4+2*x8*x3+2*x7*x2+2*x6*x1+2*x5*x2+2*x4*x3,
 -x7+2*x10*x4+2*x9*x3+2*x8*x2+2*x7*x1+2*x6*x2+2*x5*x3+x4^2,
 -x8+2*x10*x3+2*x9*x2+2*x8*x1+2*x7*x2+2*x6*x3+2*x5*x4,
 -x9+2*x10*x2+2*x9*x1+2*x8*x2+2*x7*x3+2*x6*x4+x5^2,
 -1+2*x10+2*x9+2*x8+2*x7+2*x6+2*x5+2*x4+2*x3+2*x2+x1
        ],
        [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10]
    ],
    [#(6) katsura10
        [ -x1+2*x11^2+2*x10^2+2*x9^2+2*x8^2+2*x7^2+2*x6^2+2*x5^2+2*x4^2+2*x3^2+2*x2^2+x1^2,
 -x2+2*x11*x10+2*x10*x9+2*x9*x8+2*x8*x7+2*x7*x6+2*x6*x5+2*x5*x4+2*x4*x3+2*x3*x2+2*x2*x1,
 -x3+2*x11*x9+2*x10*x8+2*x9*x7+2*x8*x6+2*x7*x5+2*x6*x4+2*x5*x3+2*x4*x2+2*x3*x1+x2^2,
 -x4+2*x11*x8+2*x10*x7+2*x9*x6+2*x8*x5+2*x7*x4+2*x6*x3+2*x5*x2+2*x4*x1+2*x3*x2,
 -x5+2*x11*x7+2*x10*x6+2*x9*x5+2*x8*x4+2*x7*x3+2*x6*x2+2*x5*x1+2*x4*x2+x3^2,
 -x6+2*x11*x6+2*x10*x5+2*x9*x4+2*x8*x3+2*x7*x2+2*x6*x1+2*x5*x2+2*x4*x3,
 -x7+2*x11*x5+2*x10*x4+2*x9*x3+2*x8*x2+2*x7*x1+2*x6*x2+2*x5*x3+x4^2,
 -x8+2*x11*x4+2*x10*x3+2*x9*x2+2*x8*x1+2*x7*x2+2*x6*x3+2*x5*x4,
 -x9+2*x11*x3+2*x10*x2+2*x9*x1+2*x8*x2+2*x7*x3+2*x6*x4+x5^2,
 -x10+2*x11*x2+2*x10*x1+2*x9*x2+2*x8*x3+2*x7*x4+2*x6*x5,
 -1+2*x11+2*x10+2*x9+2*x8+2*x7+2*x6+2*x5+2*x4+2*x3+2*x2+x1
        ],
        [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11]
    ],
    [#(7) utbikker
        [ x^2+x*y+y^2-2*x*z-4*y*z+3*z^2-3*x*t+2*y*t+t^2-3*x-2*y+3*z-2*t-2,
 2*x^2-x*y+y^2-x*z-y*z-6*z^2-x*t+y*t-5*z*t-3*t^2-5*x+y+5*z+2*t+5,
 -3-3*x*y+2*x*z+x*t^2-5*x*z^2-5*z^2*t-3*x*t-2*z*t+x*y*z+x*y*t-x^2*z+x^2
 -y^2+2*z^2+11*z-2*t-x+y+x^3+y^3-3*z^3+2*t^3-3*t^2-5*y^2*z+7*y*z^2,
 -15+2*x*y+11*x*t^2+5*x*z^2-z*t-4*x*y*z+6*x*y*t-x^2*z+3*x^2+2*y^2-z^2+4*z
 -10*t-35*x-14*y-x^3+6*y^3+15*z^3+4*t^3+5*t^2+6*y^2*z+4*y*z^2-x*z*t+6*x^2*y
 -12*x*y^2-7*y^2*t+2*y*t
        ],
        [x,y,z,t]
    ],
    [#(8) kotsireas
        [ (b-d1)*(a-c) - 2*f + 2,
 (b-d1)*(a+c-2*f) + 2*(a-c),
 (b-d1)*(b-d1) - 2*(b+d1) + t + 1,
 a**2*b**3 - 1,
 c**2*d1**3 - 1,
 f**2*t**3 - 1
        ],
        [a,b,c,d1,f,t]
    ],
    [#(9) chandra4
        [ 8*H1 - 051234/100000*H1*(1+(1/2)*H1+(1/3)*H2+(1/4)*H3) - 8,
 8*H2 - 051234/100000*H2*(1+(2/3)*H1+(2/4)*H2+(2/5)*H3) - 8,
 8*H3 - 051234/100000*H3*(1+(3/4)*H1+(3/5)*H2+(3/6)*H3) - 8,
 8*H4 - 051234/100000*H4*(1+(4/5)*H1+(4/6)*H2+(4/7)*H3) - 8
        ],
        [H1,H2,H3,H4]
    ],
    [#(10) chandra5
        [ 10*H1 - 051234/100000*H1*(1+(1/2)*H1+(1/3)*H2+(1/4)*H3+(1/5)*H4) - 10,
 10*H2 - 051234/100000*H2*(1+(2/3)*H1+(2/4)*H2+(2/5)*H3+(2/6)*H4) - 10,
 10*H3 - 051234/100000*H3*(1+(3/4)*H1+(3/5)*H2+(3/6)*H3+(3/7)*H4) - 10,
 10*H4 - 051234/100000*H4*(1+(4/5)*H1+(4/6)*H2+(4/7)*H3+(4/8)*H4) - 10,
 10*H5 - 051234/100000*H5*(1+(5/6)*H1+(5/7)*H2+(5/8)*H3+(5/9)*H4) - 10
        ],
        [H1,H2,H3,H4,H5]
    ],
    [#(11) chandra6
        [ 12*H1 - 051234/100000*H1*(1+(1/2)*H1+(1/3)*H2+(1/4)*H3+(1/5)*H4+(1/6)*H5) - 12,
 12*H2 - 051234/100000*H2*(1+(2/3)*H1+(2/4)*H2+(2/5)*H3+(2/6)*H4+(2/7)*H5) - 12,
 12*H3 - 051234/100000*H3*(1+(3/4)*H1+(3/5)*H2+(3/6)*H3+(3/7)*H4+(3/8)*H5) - 12,
 12*H4 - 051234/100000*H4*(1+(4/5)*H1+(4/6)*H2+(4/7)*H3+(4/8)*H4+(4/9)*H5) - 12,
 12*H5 - 051234/100000*H5*(1+(5/6)*H1+(5/7)*H2+(5/8)*H3+(5/9)*H4+(5/10)*H5) - 12,
 12*H6 - 051234/100000*H6*(1+(6/7)*H1+(6/8)*H2+(6/9)*H3+(6/10)*H4+(6/11)*H5) - 12
        ],
        [H1,H2,H3,H4,H5,H6]
    ],
    [#(12) tangents0
        [x0**2+x1**2+x2**2-1,
x0*x3+x1*x4+x2*x5,
 50*x0**2-2*x0*x4+ 14*x0*x5+x1**2-14*x1*x2+ 2*x1*x3+ 49*x2**2-14*x2*x3+x3**2
+x4**2+x5**2-1,
 29*x0**2-10*x0*x1-4*x0*x2-4*x0*x4+ 10*x0*x5+ 5*x1**2-20*x1*x2+ 4*x1*x3-2*x1
*x5+ 26*x2**2-10*x2*x3+ 2*x2*x4+x3**2+x4**2+x5**2-1,
 9*x0**2-6*x0*x5+ 9*x2**2+ 6*x2*x3+x3**2+x4**2+x5**2-1,
 9*x0**2+ 6*x0*x5+ 9*x2**2-6*x2*x3+x3**2+x4**2+x5**2-1
        ],
        [x0,x1,x2,x3,x4,x5]
    ],
    [#(13) assur44
        [ ca^2+sa^2-1,
 cb^2+sb^2-1,
 cc^2+sc^2-1,
 cd^2+sd^2-1,
 8*cc*cb*ca+8*cc*cb*sa-8*cc*sb*ca+8*cc*sb*sa-8*sc*cb*ca+8*sc*cb*sa-8*sc*
 sb*ca-8*sc*sb*sa+24*cc*cb-24*cc*sb-24*sc*cb-24*sc*sb-16*cb*ca+12*cb*sa-12*sb*ca
-16*sb*sa-4*cc+28*sc-48*cb-36*sb+24*ca+48,
 -8*cd*cb*ca+16*cd*cb*sa-16*cd*sb*ca-8*cd*sb*sa+16*sd*cb*ca+8*sd*cb*sa-8*
sd*sb*ca+16*sd*sb*sa-32*cd*cb+86*cd*sb-86*sd*cb-32*sd*sb+8*cb*ca+12*cb*sa-12*sb
*ca+8*sb*sa+16*cd+28*sd-73*cb+12*sb-28*ca-30*sa+112,
 -980*cd*cb*ca-1960*cd*cb*sa+1960*cd*sb*ca-980*cd*sb*sa-1960*sd*cb*ca+980
*sd*cb*sa-980*sd*sb*ca-1960*sd*sb*sa+280*cc*cb*ca-1400*cc*cb*sa+1400*cc*sb*ca+
280*cc*sb*sa+1400*sc*cb*ca+280*sc*cb*sa-280*sc*sb*ca+1400*sc*sb*sa+6300*cd*cc-
4900*cd*sc+6860*cd*cb+8330*cd*sb-4900*sd*cc-6300*sd*sc-8330*sd*cb+6860*sd*sb+
6860*cc*cb+1540*cc*sb+1540*sc*cb-6860*sc*sb+56*cb*ca+2268*cb*sa-2268*sb*ca+56*
sb*sa-11480*cd+5390*sd-8060*cc+1820*sc-10094*cb-4788*sb+784*ca-1764*sa+19798,
 280*cd*cc-280*sd*sc-336*cd-240*cc+391
        ],
        [ca,cb,cc,cd,sa,sb,sc,sd]
    ],
    [#(14) cyclic9
        [ z0 + z1 + z2 + z3 + z4 + z5 + z6 + z7 + z8,
  z0*z1 + z1*z2 + z2*z3 + z3*z4 + z4*z5 + z5*z6 + z6*z7 + z7*z8 + z8*z0,
  z0*z1*z2 + z1*z2*z3 + z2*z3*z4 + z3*z4*z5 + z4*z5*z6 + z5*z6*z7
+ z6*z7*z8 + z7*z8*z0 + z8*z0*z1,
  z0*z1*z2*z3 + z1*z2*z3*z4 + z2*z3*z4*z5 + z3*z4*z5*z6 + z4*z5*z6*z7
+ z5*z6*z7*z8 + z6*z7*z8*z0 + z7*z8*z0*z1 + z8*z0*z1*z2,
  z0*z1*z2*z3*z4 + z1*z2*z3*z4*z5 + z2*z3*z4*z5*z6 + z3*z4*z5*z6*z7
+ z4*z5*z6*z7*z8 + z5*z6*z7*z8*z0 + z6*z7*z8*z0*z1 + z7*z8*z0*z1*z2
+ z8*z0*z1*z2*z3,
  z0*z1*z2*z3*z4*z5 + z1*z2*z3*z4*z5*z6 + z2*z3*z4*z5*z6*z7 + z3*z4*z5*z6*z7*z8
+ z4*z5*z6*z7*z8*z0 + z5*z6*z7*z8*z0*z1 + z6*z7*z8*z0*z1*z2 + z7*z8*z0*z1*z2*z3
+ z8*z0*z1*z2*z3*z4,
  z0*z1*z2*z3*z4*z5*z6 + z1*z2*z3*z4*z5*z6*z7 + z2*z3*z4*z5*z6*z7*z8
+ z3*z4*z5*z6*z7*z8*z0 + z4*z5*z6*z7*z8*z0*z1 + z5*z6*z7*z8*z0*z1*z2
+ z6*z7*z8*z0*z1*z2*z3 + z7*z8*z0*z1*z2*z3*z4 + z8*z0*z1*z2*z3*z4*z5,
  z0*z1*z2*z3*z4*z5*z6*z7 + z1*z2*z3*z4*z5*z6*z7*z8 + z2*z3*z4*z5*z6*z7*z8*z0
+ z3*z4*z5*z6*z7*z8*z0*z1 + z4*z5*z6*z7*z8*z0*z1*z2 + z5*z6*z7*z8*z0*z1*z2*z3
+ z6*z7*z8*z0*z1*z2*z3*z4 + z7*z8*z0*z1*z2*z3*z4*z5 + z8*z0*z1*z2*z3*z4*z5*z6,
  z0*z1*z2*z3*z4*z5*z6*z7*z8 - 1
        ],
        [z0,z1,z2,z3,z4,z5,z6,z7,z8]
    ],
    [#(15) cyclic10
        [  z0 + z1 + z2 + z3 + z4 + z5 + z6 + z7 + z8 + z9,
  z0*z1 + z1*z2 + z2*z3 + z3*z4 + z4*z5 + z5*z6 + z6*z7 + z7*z8 + z8*z9 + z9*z0,
  z0*z1*z2 + z1*z2*z3 + z2*z3*z4 + z3*z4*z5 + z4*z5*z6 + z5*z6*z7
+ z6*z7*z8 + z7*z8*z9 + z8*z9*z0 + z9*z0*z1,
  z0*z1*z2*z3 + z1*z2*z3*z4 + z2*z3*z4*z5 + z3*z4*z5*z6 + z4*z5*z6*z7
+ z5*z6*z7*z8 + z6*z7*z8*z9 + z7*z8*z9*z0 + z8*z9*z0*z1 + z9*z0*z1*z2,
  z0*z1*z2*z3*z4 + z1*z2*z3*z4*z5 + z2*z3*z4*z5*z6 + z3*z4*z5*z6*z7
+ z4*z5*z6*z7*z8 + z5*z6*z7*z8*z9 + z6*z7*z8*z9*z0 + z7*z8*z9*z0*z1
+ z8*z9*z0*z1*z2 + z9*z0*z1*z2*z3,
  z0*z1*z2*z3*z4*z5 + z1*z2*z3*z4*z5*z6 + z2*z3*z4*z5*z6*z7 + z3*z4*z5*z6*z7*z8
+ z4*z5*z6*z7*z8*z9 + z5*z6*z7*z8*z9*z0 + z6*z7*z8*z9*z0*z1 + z7*z8*z9*z0*z1*z2
+ z8*z9*z0*z1*z2*z3 + z9*z0*z1*z2*z3*z4,
  z0*z1*z2*z3*z4*z5*z6 + z1*z2*z3*z4*z5*z6*z7 + z2*z3*z4*z5*z6*z7*z8
+ z3*z4*z5*z6*z7*z8*z9 + z4*z5*z6*z7*z8*z9*z0 + z5*z6*z7*z8*z9*z0*z1
+ z6*z7*z8*z9*z0*z1*z2 + z7*z8*z9*z0*z1*z2*z3 + z8*z9*z0*z1*z2*z3*z4
+ z9*z0*z1*z2*z3*z4*z5,
  z0*z1*z2*z3*z4*z5*z6*z7 + z1*z2*z3*z4*z5*z6*z7*z8 + z2*z3*z4*z5*z6*z7*z8*z9
+ z3*z4*z5*z6*z7*z8*z9*z0 + z4*z5*z6*z7*z8*z9*z0*z1 + z5*z6*z7*z8*z9*z0*z1*z2
+ z6*z7*z8*z9*z0*z1*z2*z3 + z7*z8*z9*z0*z1*z2*z3*z4 + z8*z9*z0*z1*z2*z3*z4*z5
+ z9*z0*z1*z2*z3*z4*z5*z6,
  z0*z1*z2*z3*z4*z5*z6*z7*z8 + z1*z2*z3*z4*z5*z6*z7*z8*z9
+ z2*z3*z4*z5*z6*z7*z8*z9*z0 + z3*z4*z5*z6*z7*z8*z9*z0*z1
+ z4*z5*z6*z7*z8*z9*z0*z1*z2 + z5*z6*z7*z8*z9*z0*z1*z2*z3
+ z6*z7*z8*z9*z0*z1*z2*z3*z4 + z7*z8*z9*z0*z1*z2*z3*z4*z5
+ z8*z9*z0*z1*z2*z3*z4*z5*z6 + z9*z0*z1*z2*z3*z4*z5*z6*z7,
  z0*z1*z2*z3*z4*z5*z6*z7*z8*z9 - 1
        ],
        [z0,z1,z2,z3,z4,z5,z6,z7,z8,z9]
    ],
    [#(16) cyclic11
        [z0*z1*z2*z3*z4*z5*z6*z7*z8*z9*z10 - 1,
z0 + z1 + z2 + z3 + z4 + z5 + z6 + z7 + z8 + z9 + z10,
z0*z1 + z1*z2 + z2*z3 + z3*z4 + z4*z5 + z5*z6 + z6*z7
+ z7*z8 + z8*z9 + z9*z10 + z10*z0,
z0*z1*z2 + z1*z2*z3 + z2*z3*z4 + z3*z4*z5 + z4*z5*z6 + z5*z6*z7
 + z6*z7*z8 + z7*z8*z9 + z8*z9*z10 + z9*z10*z0 + z10*z0*z1,
z0*z1*z2*z3 + z1*z2*z3*z4 + z2*z3*z4*z5 + z3*z4*z5*z6 + z4*z5*z6*z7
 + z5*z6*z7*z8 + z6*z7*z8*z9 + z7*z8*z9*z10 + z8*z9*z10*z0 + z9*z10*z0*z1
 + z10*z0*z1*z2,
z0*z1*z2*z3*z4 + z1*z2*z3*z4*z5 + z2*z3*z4*z5*z6 + z3*z4*z5*z6*z7
 + z4*z5*z6*z7*z8 + z5*z6*z7*z8*z9 + z6*z7*z8*z9*z10 + z7*z8*z9*z10*z0
 + z8*z9*z10*z0*z1 + z9*z10*z0*z1*z2 + z10*z0*z1*z2*z3,
z0*z1*z2*z3*z4*z5 + z1*z2*z3*z4*z5*z6 + z2*z3*z4*z5*z6*z7
 + z3*z4*z5*z6*z7*z8 + z4*z5*z6*z7*z8*z9 + z5*z6*z7*z8*z9*z10
 + z6*z7*z8*z9*z10*z0 + z7*z8*z9*z10*z0*z1 + z8*z9*z10*z0*z1*z2
 + z9*z10*z0*z1*z2*z3 + z10*z0*z1*z2*z3*z4,
z0*z1*z2*z3*z4*z5*z6 + z1*z2*z3*z4*z5*z6*z7 + z2*z3*z4*z5*z6*z7*z8
 + z3*z4*z5*z6*z7*z8*z9 + z4*z5*z6*z7*z8*z9*z10 + z5*z6*z7*z8*z9*z10*z0
 + z6*z7*z8*z9*z10*z0*z1 + z7*z8*z9*z10*z0*z1*z2 + z8*z9*z10*z0*z1*z2*z3
 + z9*z10*z0*z1*z2*z3*z4 + z10*z0*z1*z2*z3*z4*z5,
z0*z1*z2*z3*z4*z5*z6*z7 + z1*z2*z3*z4*z5*z6*z7*z8 + z2*z3*z4*z5*z6*z7*z8*z9
 + z3*z4*z5*z6*z7*z8*z9*z10 + z4*z5*z6*z7*z8*z9*z10*z0
 + z5*z6*z7*z8*z9*z10*z0*z1 + z6*z7*z8*z9*z10*z0*z1*z2
 + z7*z8*z9*z10*z0*z1*z2*z3 + z8*z9*z10*z0*z1*z2*z3*z4
 + z9*z10*z0*z1*z2*z3*z4*z5 + z10*z0*z1*z2*z3*z4*z5*z6,
z0*z1*z2*z3*z4*z5*z6*z7*z8 + z1*z2*z3*z4*z5*z6*z7*z8*z9
 + z2*z3*z4*z5*z6*z7*z8*z9*z10 + z3*z4*z5*z6*z7*z8*z9*z10*z0
 + z4*z5*z6*z7*z8*z9*z10*z0*z1 + z5*z6*z7*z8*z9*z10*z0*z1*z2
 + z6*z7*z8*z9*z10*z0*z1*z2*z3 + z7*z8*z9*z10*z0*z1*z2*z3*z4
 + z8*z9*z10*z0*z1*z2*z3*z4*z5 + z9*z10*z0*z1*z2*z3*z4*z5*z6
 + z10*z0*z1*z2*z3*z4*z5*z6*z7,
z0*z1*z2*z3*z4*z5*z6*z7*z8*z9 + z1*z2*z3*z4*z5*z6*z7*z8*z9*z10
 + z2*z3*z4*z5*z6*z7*z8*z9*z10*z0 + z3*z4*z5*z6*z7*z8*z9*z10*z0*z1
 + z4*z5*z6*z7*z8*z9*z10*z0*z1*z2 + z5*z6*z7*z8*z9*z10*z0*z1*z2*z3
 + z6*z7*z8*z9*z10*z0*z1*z2*z3*z4 + z7*z8*z9*z10*z0*z1*z2*z3*z4*z5
 + z8*z9*z10*z0*z1*z2*z3*z4*z5*z6 + z9*z10*z0*z1*z2*z3*z4*z5*z6*z7
 + z10*z0*z1*z2*z3*z4*z5*z6*z7*z8
        ],
        [z0,z1,z2,z3,z4,z5,z6,z7,z8,z9,z10]
    ],
    [#(17) simple
        [ x^2,
 x*y,
 y^2
        ],
        [x,y]
    ],
    [#(18) eg1
        [ x**2,
 y**2
        ],
        [x,y]
    ],
    [#(19) eg2
        [ x**2+y**2,
 x-y
        ],
        [x,y]
    ],
    [#(20) eg3
        [ x**2,
 x-y
        ],
        [x,y]
    ],
    [#(21) eg4
        [ x**3,
 x-y
        ],
        [x,y]
    ],
    [#(22) eg5
        [ x**4,
 x-y
        ],
        [x,y]
    ],
    [#(23) baker1
        [ x1**2-x2,
 x1**2+x2
        ],
        [x1,x2]
    ],
    [#(24) cbms1
        [x1**3-x2*x3,
x2**3-x1*x3,
x3**3-x1*x2
        ],
        [x1,x2,x3]
    ],
    [#(25) cbms2
        [ x1**3  - 3*x1**2*x2 + 3*x1*x2**2  - x2**3  - x3**2,
 x3**3  - 3*x3**2*x1 + 3*x3*x1**2  - x1**3  - x2**2,
 x2**3  - 3*x2**2*x3 + 3*x2*x3**2  - x3**3  - x1**2
        ],
        [x1,x2,x3]
    ],
    [#(26) mth191
        [ x^3+y^2+z^2-1,
 x^2+y^3+z^2-1,
 x^2+y^2+z^3-1
        ],
        [x,y,z]
    ],
    [#(27) decker1
        [ x1**3+x1*x2,
 x2**2+x2
        ],
        [x1,x2]
    ],
    [#(28) decker2
        [ x1+x2**3,
 x1**2*x2-x2**4
        ],
        [x1,x2]
    ],
    [#(29) decker3
        [ x1+x2**2,
 15/10*x1*x2+x2**2+x2**3
        ],
        [x1,x2]
    ],
    [#(30) kss3
        [ x1^2 + x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 - 2*x1 - 9,
 x2^2 + x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 - 2*x2 - 9,
 x3^2 + x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 - 2*x3 - 9,
 x4^2 + x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 - 2*x4 - 9,
 x5^2 + x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 - 2*x5 - 9,
 x6^2 + x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 - 2*x6 - 9,
 x7^2 + x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 - 2*x7 - 9,
 x8^2 + x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 - 2*x8 - 9,
 x9^2 + x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 - 2*x9 - 9,
 x10^2 + x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 - 2*x10 - 9
        ],
        [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10]
    ],
    [#(31) ojika1
        [ x**2+y-3,
 x+0125/1000*y**2-15/10
        ],
        [x,y]
    ],
    [#(32) ojika2
        [ x1**2+x2+x3-1,
 x1+x2**2+x3-1,
 x1+x2+x3**2-1
        ],
        [x1,x2,x3]
    ],
    [#(33) ojika3
        [ x1+x2+x3-1,
 02/10*x1**3+05/10*x2**2-x3+05/10*x3**2+05/10,
 x1+x2+05/10*x3**2-05/10
        ],
        [x1,x2,x3]
    ],
    [#(34) ojika4
        [ x1+x3*x1**3+x1*x3*x2**2-x1*x3,
 10*x2-2*x2*x3*x1**2-x3*x2**3-x2*x3,
 -6*x3**2*x1**4-3*x1**2*x2**2*x3**2-x3**2*x1**2+28*x3*x1**2
 -3*x3**2*x2**4+2*x3**2*x2**2+7*x3*x2**2+x3**2-11*x3+10
        ],
        [x1,x2,x3]
    ]
]:


(*
 Copyright (C) 2017 M.A.L. Marques

 This Source Code Form is subject to the terms of the Mozilla Public
 License, v. 2.0. If a copy of the MPL was not distributed with this
 file, You can obtain one at http://mozilla.org/MPL/2.0/.
*)

op_a1 := 1.5214:
op_a2 := 0.5764:
op_b1 := 1.1284:
op_b2 := 0.3183:

(* This wrapper is to avoid overflows in the OP functionals. The
   energy is not affected, since the value is only changed for
   densities that are screened away.  *)
op_b88_zab := (f_x, rs, z, xs0, xs1) ->
  my_piecewise3(
    b88_zab(1, op_enhancement, rs, z, xs0, xs1) = 0,
    DBL_EPSILON,
    b88_zab(1, op_enhancement, rs, z, xs0, xs1)
  ):

op_beta := (rs, z, xs0, xs1) ->
  op_qab/op_b88_zab(op_enhancement, rs, z, xs0, xs1):

op_f_s := (rs, z, xt, xs0, xs1) ->
  - (1 - z^2)*n_total(rs)/4.0
  * (op_a1*op_beta(rs, z, xs0, xs1) + op_a2)
  / (op_beta(rs, z, xs0, xs1)^4 + op_b1*op_beta(rs, z, xs0, xs1)^3 + op_b2*op_beta(rs, z, xs0, xs1)^2)
:

op_f := (rs, z, xt, xs0, xs1) ->
   my_piecewise3(1 - abs(z) <= p_a_zeta_threshold or (screen_dens(rs,z) and screen_dens(rs,-z)), 0,
                 op_f_s(rs, z_thr(z), xt, xs0, xs1)):

f := (rs, z, xt, xs0, xs1) ->
  op_f(rs, z, xt, xs0, xs1):


check_set_generic("RR");
check_set_generic("CC");
check_set_generic("RZ");
check_set_generic("R",[[5]]);
check_set_generic("C",[[5]]);
check_set_generic("CP",[[5]]);
check_set_generic("sphere",[[5]]);
check_set_generic("RZ_set");
check_set_generic("RP_points");
check_set_generic("RP_lines");
check_set_generic("RP_conics");
check_set_generic("RP_arcs");
check_set_generic("simplices",[[5], [3]]);
check_set_generic("real_functions",[[{10, 20, 30, 40, 50}]]);
check_set_generic("vector_functions",[[4], [{10, 20, 30, 40, 50}]]);
check_set_generic("maps",[[{10, 20, 30, 40, 50}, {1, 2, 3}]]);
check_set_generic("binops",[[{0, 1}, {1, 2, 3}, {1, 2, 3}]]);
check_set_generic("epi",[[{10, 20, 30, 40, 50}, {1, 2, 3}]]);
check_set_generic("subsets",[[{10, 20, 30, 40, 50}]]);
check_set_generic("nonempty_subsets",[[{10, 20, 30, 40, 50}]]);
check_set_generic("proper_nonempty_subsets",[[{10, 20, 30, 40, 50}]]);
check_set_generic("big_subsets",[[{10, 20, 30, 40, 50}]]);
check_set_generic("pairs",[[{10, 20, 30, 40, 50}]]);
check_set_generic("pair_subsets",[[{10, 20, 30, 40, 50}]]);
check_set_generic("triples",[[{10, 20, 30, 40, 50}]]);
check_set_generic("partitions",[[{10, 20, 30, 40, 50}]]);
check_set_generic("permutations",[[5]]);
check_set_generic("shuffles",[[3, 4]]);
check_set_generic("nat_partitions",[[8, 3]]);
check_set_generic("pos_partitions",[[8, 3]]);
check_set_generic("rel",[[{11, 22, 33, 44}, {1, 2, 3}]]);
check_set_generic("autorel",[[{1, 2, 3}]]);
check_set_generic("equiv",[[{10, 20, 30, 40, 50}]]);
check_set_generic("preord",[[{10, 20, 30, 40, 50}]]);
check_set_generic("partord",[[{10, 20, 30, 40, 50}]]);
check_set_generic("total_preord",[[{10, 20, 30, 40, 50}]]);
check_set_generic("ord",[[{10, 20, 30, 40, 50}]]);
check_set_generic("cycord",[[{10, 20, 30, 40, 50}]]);
check_set_generic("linord",[[{10, 20, 30, 40, 50}]]);
check_set_generic("posint_intervals");
check_set_generic("interval_partitions",[[5]]);
check_set_generic("graphs",[[{10, 20, 30, 40, 50}]]);
check_set_generic("paths",[[{11, 12, 13, 14, 15, 16, 17, 18, 19, 20}], [{[11, 15], [11, 17], [11, 18], [11, 19], [11, 20], [12, 13], [12, 16], [12, 19], [12, 20], [13, 12], [13, 15], [13, 16], [13, 19], [13, 20], [14, 15], [14, 18], [14, 20], [15, 11], [15, 13], [15, 14], [15, 16], [15, 18], [15, 20], [16, 12], [16, 13], [16, 15], [16, 19], [17, 11], [17, 19], [17, 20], [18, 11], [18, 14], [18, 15], [18, 19], [19, 11], [19, 12], [19, 13], [19, 16], [19, 17], [19, 18], [20, 11], [20, 12], [20, 13], [20, 14], [20, 15], [20, 17]}], [4]]);
check_set_generic("trails",[[{11, 12, 13, 14, 15, 16, 17, 18, 19, 20}], [{[11, 15], [11, 17], [11, 18], [11, 19], [11, 20], [12, 13], [12, 16], [12, 19], [12, 20], [13, 12], [13, 15], [13, 16], [13, 19], [13, 20], [14, 15], [14, 18], [14, 20], [15, 11], [15, 13], [15, 14], [15, 16], [15, 18], [15, 20], [16, 12], [16, 13], [16, 15], [16, 19], [17, 11], [17, 19], [17, 20], [18, 11], [18, 14], [18, 15], [18, 19], [19, 11], [19, 12], [19, 13], [19, 16], [19, 17], [19, 18], [20, 11], [20, 12], [20, 13], [20, 14], [20, 15], [20, 17]}], [4]]);
check_set_generic("digraphs",[[{11, 22, 33, 44}]]);
check_set_generic("dipaths",[[{11, 12, 13, 14, 15, 16, 17, 18, 19, 20}], [{[11, 12], [11, 13], [11, 15], [11, 19], [12, 14], [12, 15], [12, 16], [12, 19], [13, 16], [13, 17], [13, 19], [14, 15], [14, 19], [15, 13], [15, 17], [15, 19], [16, 11], [16, 15], [16, 18], [16, 19], [17, 11], [17, 12], [17, 14], [17, 19], [18, 12], [19, 18], [19, 20], [20, 13], [20, 15], [20, 18]}], [4]]);
check_set_generic("ditrails",[[{11, 12, 13, 14, 15, 16, 17, 18, 19, 20}], [{[11, 12], [11, 13], [11, 15], [11, 19], [12, 14], [12, 15], [12, 16], [12, 19], [13, 16], [13, 17], [13, 19], [14, 15], [14, 19], [15, 13], [15, 17], [15, 19], [16, 11], [16, 15], [16, 18], [16, 19], [17, 11], [17, 12], [17, 14], [17, 19], [18, 12], [19, 18], [19, 20], [20, 13], [20, 15], [20, 18]}], [4]]);
check_set_generic("trees",[[{10, 20, 30, 40, 50}]]);
check_set_generic("full_trees",[[{10, 20, 30, 40, 50}]]);
check_set_generic("binary_trees",[[{10, 20, 30, 40, 50}]]);
check_set_generic("standard_stasheff_trees",[[6]]);
check_set_generic("binary_standard_stasheff_trees",[[6]]);
check_set_generic("stasheff_trees",[[{11, 22, 33, 44}]]);
check_set_generic("standard_stasheff_star",[[5]]);
check_set_generic("stasheff_star",[[{11, 22, 33, 44}]]);
check_set_generic("W",[[4], [{11, 22, 33, 44}]]);
check_set_generic("prime_W",[[4], [{11, 22, 33, 44}]]);
check_set_generic("SW",[[4], [{11, 22, 33, 44}]]);
check_set_generic("W1",[[{11, 22, 33, 44}]]);
check_set_generic("BW1",[[{11, 22, 33, 44}]]);
check_set_generic("SWW",[[3], [{10, 20, 30, 40, 50}, {10, 30, 50}]]);
check_set_generic("single_cubes",[[3]]);
check_set_generic("cubes",[[3], [{10, 20, 30, 40, 50}]]);
check_set_generic("one_cubes_prime",[[{10, 20, 30, 40, 50}]]);
check_set_generic("simplicial_interval",[[6]]);
check_set_generic("simplicial_maps",[[6, 5]]);
check_set_generic("simplicial_epi",[[5, 3]]);
check_set_generic("simplicial_mono",[[3, 5]]);
check_set_generic("simplex",[[{10, 20, 30, 40, 50}]]);
check_set_generic("simplex_interior",[[{10, 20, 30, 40, 50}]]);
check_set_generic("ord_simplex_interior",[[{10, 20, 30, 40, 50}]]);
check_set_generic("prime_simplex",[[{10, 20, 30, 40, 50}]]);
check_set_generic("prime_simplex_boundary",[[{10, 20, 30, 40, 50}]]);
check_set_generic("height_functions",[[{11, 12, 13, 14, 15, 16, 17, 18, 19, 20}]]);
check_set_generic("tree_height_functions",[[{11, 12, 13, 14, 15, 16, 17, 18, 19, 20}], [{{11}, {12}, {13}, {14}, {15}, {16}, {17}, {18}, {19}, {20}, {11, 13, 14}, {16, 17, 18, 19, 20}, {11, 12, 13, 14, 15, 16, 17, 18, 19, 20}}]]);
check_set_generic("F",[[3], [{10, 20, 30, 40, 50}]]);
check_set_generic("Fbar",[[3], [{10, 20, 30, 40, 50}]]);
check_set_generic("E",[[6]]);
check_set_generic("P",[[6]]);
check_set_generic("SEM",[[3], [{10, 11, 12, 13, 14, 15, 16}]]);
check_set_generic("ACP",[[3], [{10, 11, 12, 13, 14, 15, 16}]]);
check_set_generic("SCP",[[3], [{10, 11, 12, 13, 14, 15, 16}]]);
check_set_generic("ICP",[[3], [A]]);
check_set_generic("SCP2",[[3], [{10, 11, 12, 13, 14, 15, 16}], [B6]]);
check_set_generic("FFbar",[[3], [{10, 20, 30, 40, 50}]]);
check_set_generic("X/F3",[[4]]);
check_set_generic("Y/F3",[[4]]);
check_set_generic("D_plus/F3",[[4]]);
check_set_generic("D_minus/F3",[[4]]);
check_set_generic("D_zero/F3",[[4]]);
check_set_generic("comm",[[{10, 20, 30, 40, 50}]]);
check_set_generic("itloc",[[{1, 2, 3}], [3]]);
check_set_generic("Phi0/itloc",[[{10, 20, 30, 40, 50}]]);
check_set_generic("M11/itloc",[[{10, 20, 30, 40, 50}], [{10, 30, 50}]]);
check_set_generic("M1/itloc",[[{1, 2, 3, 4, 5}], [[{4}, {3, 4}, {1, 3}, {3, 4}]]]);


`gamma/permutations` := (J) -> proc(s,t)
 local k,i,m,tt;
 k := nops(J);
 i := `+`(op(J));
 tt := [];
 m := 0;
 for i from 1 to k do
  tt := [op(tt),t[i] +~ m];
  m := m + J[i];
 od:
 return [seq(op(tt[s[i]]),i=1..k)];
end:

`eta/permutations` := [1];

`circ/permutations` := (i,m,n) -> proc(s,t)
 local u,p;
 u := NULL;
 for p from 1 to m do
  if s[p] < i then
   u := u,s[p]
  elif s[p] = i then
   u := u , op(t +~ (i - 1));
  else
   u := u,s[p]+n-1;
  fi;
 od;
 return [u];
end: