`eta/BW` := eval(`eta/prime_simplex`);
`gamma/BW` := eval(`gamma/prime_simplex`);
`gamma_min/BW` := eval(`gamma_min/prime_simplex`);


# The block below either calculates or reads from file the alternative
# Boys immersion, calibrated to have special behaviour at the points
# [+/- 1, +/- 1, +/- 1]/sqrt(3).

if false then
 make_boys_embedding_alt():
 save(boys_M0,boys_M1,boys_a1,boys_embedding_alt,cat(data_dir,"/boys_embedding_alt.m")):
else
 read(cat(data_dir,"/boys_embedding_alt.m")):
fi:

bef := (x) -> evalf(boys_embedding_alt(x)):

check_bef := proc()
 _ASSERT(
  max(evalf([
  dd(bef(u[0]),u[0]),
  dd(bef(u[1]),u[6]),
  dd(bef(u[2]),u[5]),
  dd(bef(u[3]),u[4]),
  dd(bef(u[4]),u[4]),
  dd(bef(u[5]),u[5]),
  dd(bef(u[6]),u[6]),
  dd(bef(u[7]),u[0])
  ])) < 10^(-6),
  "bef(u[i])=u[j] for expected pairs (i,j)"
 );
end:

# Miscellaneous functions
dp := `dot/R`(3):
dd := `d_2/R`(3):
`mmu/H` := apply_assoc(`mu/H`,[0,0,0,1]):
rot := (x) -> [x[2],x[3],x[1]]:

# Unit quaternions.
ii[1] := [1,0,0,0]:
ii[2] := [0,1,0,0]:
ii[3] := [0,0,1,0]:
ii[4] := [0,0,0,1]:

# Misccellaneous quaternions
zt[1] := [1,1+sqrt(3),1-sqrt(3),0] /~ 3:
zt[2] := [1-sqrt(3),1,1+sqrt(3),0] /~ 3:
zt[3] := [1+sqrt(3),1-sqrt(3),1,0] /~ 3:
al := [ 1, 1, 1, 0] /~ sqrt(3):
om := [ 1, 1, 1, 1] /~ 2:
ob := [-1,-1,-1, 1] /~ 2:

# Various unit vectors in R3.  For each i, the vectors u[i], v[i] and w[i]
# form an orthonormal frame.  z[i] is in the plane spanned by u[0] and u[i]
# and is orthogonal to u[0].

u := table(): v := table(): w := table(): z := table():
u[ 0] := [ 1, 1, 1] /~ sqrt(3): v[ 0] := [ 2,-1,-1] /~ sqrt(6): w[ 0] := [ 0, 1,-1] /~ sqrt(2):
u[ 1] := [ 1, 1,-1] /~ sqrt(3): v[ 1] := [ 2,-1, 1] /~ sqrt(6): w[ 1] := [ 0,-1,-1] /~ sqrt(2): z[ 1] := [ 1, 1,-2] /~ sqrt(6):
u[ 2] := [ 1,-1, 1] /~ sqrt(3): v[ 2] := [-1, 1, 2] /~ sqrt(6): w[ 2] := [-1,-1, 0] /~ sqrt(2): z[ 2] := [ 1,-2, 1] /~ sqrt(6):
u[ 3] := [-1, 1, 1] /~ sqrt(3): v[ 3] := [ 1, 2,-1] /~ sqrt(6): w[ 3] := [-1, 0,-1] /~ sqrt(2): z[ 3] := [-2, 1, 1] /~ sqrt(6):
u[ 4] := [ 1,-1,-1] /~ sqrt(3): v[ 4] := [-1,-2, 1] /~ sqrt(6): w[ 4] := [-1, 0,-1] /~ sqrt(2): z[ 4] := [ 2,-1,-1] /~ sqrt(6):
u[ 5] := [-1, 1,-1] /~ sqrt(3): v[ 5] := [ 1,-1,-2] /~ sqrt(6): w[ 5] := [-1,-1, 0] /~ sqrt(2): z[ 5] := [-1, 2,-1] /~ sqrt(6):
u[ 6] := [-1,-1, 1] /~ sqrt(3): v[ 6] := [-2, 1,-1] /~ sqrt(6): w[ 6] := [ 0,-1,-1] /~ sqrt(2): z[ 6] := [-1,-1, 2] /~ sqrt(6):
u[ 7] := [-1,-1,-1] /~ sqrt(3): v[ 7] := [-2, 1, 1] /~ sqrt(6): w[ 7] := [ 0, 1,-1] /~ sqrt(2):

pol  := unapply(expand(cos(s) *~ u[0] +~ sin(s) *~ (cos(t) *~ v[0] +~ sin(t) *~ w[0])),s,t):
pol0 := (s,t) -> [cos(s),sin(s)*cos(t),sin(s)*sin(t)]:

# The function wave(t) has trigonometric polynomial entries and lies on
# the unit sphere, passing through all the points u[1],...,u[6].
wave := unapply(
(sin(3*t)/3) *~ u[0] +~
((sqrt(2)/3-1/2) * sin(5*t)) *~ v[0] +~
((sqrt(2)/3-1/2) * cos(5*t) * (-1)) *~ w[0] +~
((sqrt(2)/3+1/2) * sin(t)) *~ v[0] +~
((sqrt(2)/3+1/2) * cos(t)) *~ w[0],
t):

# wband(t,s) parametrises a band with wave(t) = wband(t,0) at the centre
wave_normal := unapply(combine(expand(simplify(expand(cross_product(wave(t),map(diff,wave(t),t)))))),t):
wband := unapply(sin(s) *~ wave_normal(t) +~ cos(s) *~ wave(t),t,s):

check_wband := proc()
 _ASSERT(
  simplify(expand(dp(wave(t),wave(t)) - 1)) = 0,
  "wave(t) is a unit vector"
 );

 _ASSERT(
  simplify(expand(wave(t - Pi/3) +~ rot(wave(t)))) = [0$3],
  "wave(t) is Z/3-equivariant"
 );

 _ASSERT(
  {seq(simplify(wave((2 * i - 1) * Pi/6) -~ u[[1,4,2,6,3,5][i]]),i=1..6)} = {[0$3]},
  "wave(t) passes through u[1],...,u[6]"
 );
end:

# A band in S2 with central circle perpendicular to u[0]
hband := (t,s) ->
 sin(s) *~ u[0] +~ cos(s) *~ (cos(t) *~ v[0] +~ sin(t) *~ w[0]):

# A family of bands in S2 whose central circles are lines of longitude
# (with u[0] as the North pole).

vband := (p) -> unapply(combine(
                 cos(s) *~ ( cos(t) *~ (cos(p) *~ v[0] +~ sin(p) *~ w[0]) +~ sin(t) *~ u[0]) +~
                 sin(s) *~ ( -sin(p) *~ v[0] +~ cos(p) *~ w[0] )),
                t,s):

check_bands := proc()
 _ASSERT(simplify(hband(0,0) -~ vband(0)(0,0)) = [0$3],
  "Intersection of hband and vband(0)");

 _ASSERT(simplify(hband(Pi/6,0) -~ vband(Pi/6)(0,0)) = [0$3],
  "Intersection of hband and vband(Pi/6)");

 _ASSERT(vband(0)(Pi/2,0) -~ u[0] = [0$3],"u[0] on vband(0)");

 _ASSERT(simplify(vband(0)(Pi-arctan(sqrt(2)/4),0) -~ u[3]) = [0$3],"u[3] on vband(0)");

 _ASSERT(simplify(vband(0)(-arctan(sqrt(2)/4),0) -~ u[4]) = [0$3],"u[4] on vband(0)");

 _ASSERT(vband(Pi/6)(Pi/2,0) -~ u[0] = [0$3],"u[0] on vband(Pi/6)");

 _ASSERT({
  simplify(wband(    Pi/6,0) -~ u[1]),
  simplify(wband(3 * Pi/6,0) -~ u[4]),
  simplify(wband(5 * Pi/6,0) -~ u[2]),
  simplify(wband(7 * Pi/6,0) -~ u[6]),
  simplify(wband(9 * Pi/6,0) -~ u[3]),
  simplify(wband(11* Pi/6,0) -~ u[5])} = {[0$3]},
  "u[1],...,u[6] on wband");

 _ASSERT({
  simplify(wband(        0,0) -~ hband(15*Pi/6,0)),
  simplify(wband(     Pi/3,0) -~ hband(13*Pi/6,0)),
  simplify(wband( 2 * Pi/3,0) -~ hband(11*Pi/6,0)),
  simplify(wband( 3 * Pi/3,0) -~ hband( 9*Pi/6,0)),
  simplify(wband( 4 * Pi/3,0) -~ hband( 7*Pi/6,0)),
  simplify(wband( 5 * Pi/3,0) -~ hband( 5*Pi/6,0))} = {[0$3]},
  "Intersections of wband with hband");

 _ASSERT(
  simplify(expand(hband(t-2*Pi/3,s) -~ rot(hband(t,s)))) = [0$3],
  "hband is Z/3-equivariant");

 _ASSERT(
  simplify(expand(hband(t+Pi/3,-s) +~ rot(hband(t,s)))) = [0$3],
  "hband is Z/6-equivariant");

 _ASSERT(vband(0)(t+Pi,-s) +~ vband(0)(t,s) = [0$3],
  "vband(0) is Z/2-equivariant");

 _ASSERT(vband(Pi/6)(t+Pi,-s) +~ vband(Pi/6)(t,s) = [0$3],
  "vband(Pi/6) is Z/2-equivariant");

 _ASSERT(simplify(expand(wband(t-Pi/3,0) +~ rot(wband(t,0)))) = [0$3],
  "wband is Z/6-equivariant");

 _ASSERT(wband(t+Pi,0) +~ wband(t,0) = [0$3],
  "wband is Z/2-equivariant");

end:

# An embedding of the Mobius band in R^3 whose centra curve is
# a circle of radius sqrt(8/9) on S2 passing through u[1],u[2] and u[3],
# and perpendicular to u[0].

triple_mobius := unapply(
(1 + s * cos(3*t)) *~ ((1/3) *~ u[0] +~ sqrt(8/9) *~ (cos(2*t) *~ v[0] +~ sin(2*t) *~ w[0])) +~
 (s * sin(3*t) * sqrt(2/27)) *~ [cos(2*t)-2,cos(2*t-2*Pi/3)-2,cos(2*t+2*Pi/3)-2],
t,s):

check_triple_mobius := proc()
 _ASSERT(
  simplify(expand(dp(triple_mobius(t,0),triple_mobius(t,0)) - 1)) = 0,
  "triple_mobius(t,0) is a unit vector");

 _ASSERT(
  expand(dp(triple_mobius(t,0),u[0]) - 1/3) = 0,
  "triple_mobius(t,0) lies in a plane perpendicular to u[0]");

 _ASSERT(
  simplify(expand(dp(map(coeff,expand(triple_mobius(t,s)),s),map(diff,triple_mobius(t,0),t)))) = 0,
  "The triple_mobius() offset vector is perpendicular to the line of the central circle"
 );

 _ASSERT({
  simplify(triple_mobius(  Pi/6,0) -~ u[1]),
  simplify(triple_mobius(5*Pi/6,0) -~ u[2]),
  simplify(triple_mobius(3*Pi/6,0) -~ u[3])} = {[0$3]},
  "u[1],u[2],u[3] on triple_mobius()");

 _ASSERT(
  abs(twist_number(triple_mobius) - 3) < 10^(-6),
  "triple_mobius() twist number is 3"
 );
end:

# This is a smooth map R -> R^3 whose image is close to an equilateral
# triangle
smooth_triangle := unapply([
 3 * cos(2*t-  Pi/3) + cos(4*t-5*Pi/3),
 3 * cos(2*t-5*Pi/3) + cos(4*t-  Pi/3),
 3 * cos(2*t-3*Pi/3) + cos(4*t-3*Pi/3)
] /~ (sqrt(27)) +~ u[0]/~3,t):

smooth_triangle_p := Pi/4:

smooth_triangle_offset :=
 unapply(( sin(3*(t-Pi/4))*sqrt(2/3)) *~ [cos(2*t-  Pi/3),cos(2*t-5*Pi/3),cos(2*t-3*Pi/3)] +~
         (-cos(3*(t-Pi/4))) *~ u[0],t):

triangle_mobius := unapply(
 smooth_triangle(t) +~ s *~ smooth_triangle_offset(t),
 t,s
):

check_smooth_triangle := proc()
 local t;

 _ASSERT(
  simplify(expand(smooth_triangle(t-2*Pi/3) -~ rot(smooth_triangle(t)))) = [0$3],
  "smooth_triangle is Z/3-equivariant"
 );

 _ASSERT({
  simplify(expand(smooth_triangle(     0) -~ u[1])),
  simplify(expand(smooth_triangle(  Pi/3) -~ u[2])),
  simplify(expand(smooth_triangle(2*Pi/3) -~ u[3]))} = {[0$3]},
  "u[1],u[2],u[3] on smooth_triangle"
 );

 _ASSERT(
  abs(twist_number(triangle_mobius) - 3) < 10^(-6),
  "triangle_mobius() twist number is 3"
 );
end:

make_band_plots := proc()
 global hband_plot,vband_plot,wband_plot,triangle_mobius_plot,usphere_plot,frame_plot;
 local s,t,opts;

 opts := t=0..2*Pi,s=-0.2..0.2,style=patchnogrid,scaling=constrained,axes=none;

 vband_plot := table():

 hband_plot       :=  plot3d(hband(t,s),opts);
 vband_plot[0]    :=  plot3d(vband(0)(t,s),opts);
 vband_plot[Pi/6] :=  plot3d(vband(Pi/6)(t,s),opts);
 wband_plot       :=  plot3d(wband(t,s),opts);

 triangle_mobius_plot :=  plot3d(triangle_mobius(t,s),opts);

 usphere_plot := plot3d(
  cos(s) *~ u[0] +~ sin(s) *~ (cos(t) *~ v[0] +~ sin(t) *~ w[0]),
  s=0..Pi,t=0..2*Pi,colour=grey,style=wireframe,
  scaling=constrained,axes=none
 ):

 frame_plot := display(
  usphere_plot,
  point(u[0],colour=red,symbolsize=20),
  seq(point(u[i],colour=blue,symbolsize=20),i=1..3),
  seq(point(u[i],colour=cyan,symbolsize=20),i=4..6),
  point(u[7],colour=magenta,symbolsize=20),
  seq(spacecurve(cos(t) *~ u[0] +~ sin(t) *~ z[i],t=0..arccos(1/3),colour=orange),i=1..3),
  seq(spacecurve(cos(t) *~ u[0] +~ sin(t) *~ z[i],t=arccos(1/3)..Pi,colour=green),i=1..3),
  seq(spacecurve(cos(t) *~ u[7] +~ sin(t) *~ z[i],t=0..arccos(1/3),colour=orange),i=4..6),
  seq(spacecurve(cos(t) *~ u[7] +~ sin(t) *~ z[i],t=arccos(1/3)..Pi,colour=green),i=4..6),
  spacecurve(cos(t) *~ v[0] +~ sin(t) *~ w[0],t=0..2*Pi,colour=cyan),
  seq(point(cos(k*Pi/6) *~ v[0] +~ sin(k*Pi/6) *~ w[0],colour=black,symbolsize=20),k=0..11),
  spacecurve(wave(t),t=0..2*Pi,colour=black),
  scaling=constrained,axes=none
 ):

 save(hband_plot,vband_plot,wband_plot,triangle_mobius_plot,frame_plot,usphere_plot,
      cat(data_dir,"/boys_band_plots.m"));
end:

load_band_plots := proc()
 read(cat(data_dir,"/boys_band_plots.m"));
end:

make_band_be_plots := proc()
 global hband_be_plot,vband_be_plot,wband_be_plot;
 local s,t,opts;

 opts := t=0..Pi,s=-0.2..0.2,numpoints=10000,style=patchnogrid,scaling=constrained,axes=none;

 vband_be_plot := table():

 hband_be_plot       :=  plot3d(bef(hband(t,s)),opts);
 vband_be_plot[0]    :=  plot3d(bef(vband(0)(t,s)),opts);
 vband_be_plot[Pi/6] :=  plot3d(bef(vband(Pi/6)(t,s)),opts);
 wband_be_plot       :=  plot3d(bef(wband(t,s)),opts);

 save(hband_be_plot,vband_be_plot,wband_be_plot,
      cat(data_dir,"/boys_band_be_plots.m"));
end:

load_band_be_plots := proc()
 read(cat(data_dir,"/boys_band_be_plots.m"));
end:

# If f : R2 -> R3 with f(t+2*Pi=f(t) this measures the amount of twisting,
# so a standard Mobius band gives 1 and the maps triple_mobius and
# triangle_mobius give 3.

twist_number := proc(f)
 local N,e,a,b,c,z,i;
 N := 24;
 e := 0.001;
 a := table():
 b := table():
 c := table():
 z := table():
 for i from 0 to 2*N-1 do
  a[i] := evalf(f(i*Pi/N,0));
  b[i] := evalf((f(i*Pi/N,e) -~ f(i*Pi/N,-e))/~e);
  b[i] := b[i] /~ sqrt(dp(b[i],b[i]));
 od:
 a[2*N] := a[0]; a[2*N+1] := a[1];
 b[2*N] := b[0]; b[2*N+1] := b[1];

 for i from 0 to 2*N do
  c[i] := cross_product(u[0],a[i+1] -~ a[i]);
  c[i] := c[i] /~ sqrt(dp(c[i],c[i]));
  z[i] := dp(b[i],c[i]) + I * dp(b[i],u[0]);
 od:

 return evalf(add(argument(z[i+1]/z[i]),i=0..2*N-1) / (2*Pi));
end:

# For a homogeneous quadratic map q : R4 -> R, return the matrix M
# such that q(x) = x^T M x.

quadratic_coeffs := proc(u)
 local M,i,j,c;

 M := Matrix(4,4,shape=symmetric):
 for i from 1 to 4 do M[i,i] := coeff(u,x[i],2); od:

 for i from 1 to 3 do
  for j from i+1 to 4 do
   c := coeff(coeff(u,x[i],1),x[j],1)/2;
   M[i,j] := c;
   M[j,i] := c;
  od:
 od:

 return M;
end:

# Construct a matrix of coefficients for a discrete Fourier transform.
# This will use 2*N sample points and return a trigonometric polynomial
# of degree d.

set_fourier_matrix := proc(N,d)
 global fourier_N,fourier_d,fourier_matrix;
 local Pi0,T,i,j,k;

 Pi0 := evalf(Pi);
 T := Matrix(2*d+1,2*N):
 for i from 1 to 2*N do
  T[1,i] := 1/(2*N);
  for k from 1 to d do
   T[2*k  ,i] := sin(i*k*Pi0/N)/N;
   T[2*k+1,i] := cos(i*k*Pi0/N)/N;
  od:
 od:

 fourier_N := N;
 fourier_d := d;
 fourier_matrix := T;
 return T;
end:

set_fourier_matrix(480,12):

# Calculate an approximate Fourier series for bef o b, for a function
# b : R2 -> S2 with b(t + 2*Pi,s) = b(t,s).  The result is returned as
# a table with many different entries.

fourier_approx := proc(b)
 local t,c,Pi0,d,N,U,F,m,k,e,cxyz,cuvw;

 c := table():
 Pi0 := evalf(Pi);
 d := fourier_d;
 N := fourier_N;
 U := map(evalf,Transpose(Matrix([u[0],v[0],w[0]])));
 e := 10.^(-3);

 c["vals"]    := [seq(evalf(b(i*Pi0/N, 0)),i=1..2*N)];
 c["offset0"] := [seq(evalf(b(i*Pi0/N, e)),i=1..2*N)];
 c["offset1"] := [seq(evalf(b(i*Pi0/N,-e)),i=1..2*N)];

 c["vals_be"]    := map(bef,c["vals"]);
 c["offset0_be"] := map(bef,c["offset0"]);
 c["offset1_be"] := map(bef,c["offset1"]);
 c["vals_dbe"]   :=
  [seq((c["offset0_be"][i] -~ c["offset1_be"][i]) /~ (2*e),i=1..2*N)];

 c["coeffs_be"]      := fourier_matrix . Matrix(c["vals_be"]);
 c["uvw_coeffs_be"]  := c["coeffs_be"] . U;
 c["coeffs_dbe"]     := fourier_matrix . Matrix(c["vals_dbe"]);
 c["uvw_coeffs_dbe"] := c["coeffs_dbe"] . U;

 for k in ["coeffs_be","uvw_coeffs_be","coeffs_dbe","uvw_coeffs_dbe"] do
  c[k] := trim(c[k],10.^(-6));
 od:

 F := [1,seq(op([sin(k*t),cos(k*t)]),k=1..d)];
 c["approx_be"]  := unapply(convert(Transpose(Vector(F)) . c["coeffs_be" ],list),t);
 c["approx_dbe"] := unapply(convert(Transpose(Vector(F)) . c["coeffs_dbe"],list),t);
 c["approx"] := unapply(c["approx_be"](t) +~ c["approx_dbe"](t) *~ s,t,s);

 for k in ["coeffs_be","uvw_coeffs_be","coeffs_dbe","uvw_coeffs_dbe"] do
  c[k] := convert(c[k],listlist);
 od:

 return eval(c):
end:

if false then
 vband_approx := table():
 printf("hband\n");
 hband_approx := fourier_approx(hband):
 printf("vband 0\n");
 vband_approx[0] := fourier_approx(vband(0)):
 printf("vband 1\n");
 vband_approx[Pi/6] := fourier_approx(vband(Pi/6)):
 printf("wband\n");
 wband_approx := fourier_approx(wband):
 save(hband_approx,vband_approx,wband_approx,
      cat(data_dir,"/boys_approx.m")):
else
 read(cat(data_dir,"/boys_approx.m")):
fi:

make_approx_plot := proc(a)
 a["plot"] :=
  plot3d(a["approx"](t,s),t=0..2*Pi,s=-0.1..0.1,
         style=patchnogrid,scaling=constrained,axes=none,args[2..-1]):
 return a["plot"];
end:

make_approx_plots := proc()
 global ribbon_plot;
 local opts;

 make_approx_plot(hband_approx,numpoints=5000):
 make_approx_plot(vband_approx[0],numpoints=8000):
 make_approx_plot(vband_approx[Pi/6],numpoints=5000):
 make_approx_plot(wband_approx,numpoints=5000):

 opts := t=0..2*Pi,s=-0.02..0.02,numpoints=6000,style=patchnogrid:

 ribbon_plot :=
  display(
   plot3d(vband_approx[0]["approx"](t,s),             opts,colour=red),
   plot3d(rot(vband_approx[0]["approx"](t,s)),        opts,colour=red),
   plot3d(rot(rot(vband_approx[0]["approx"](t,s))),   opts,colour=red),
   plot3d(vband_approx[Pi/6]["approx"](t,s),          opts,colour=blue),
   plot3d(rot(vband_approx[Pi/6]["approx"](t,s)),     opts,colour=blue),
   plot3d(rot(rot(vband_approx[Pi/6]["approx"](t,s))),opts,colour=blue),
   plot3d(hband_approx["approx"](t,s),                opts,colour=green),
   plot3d(wband_approx["approx"](t,s),                opts,colour=magenta),
   scaling=constrained,axes=none
  );

end:

# Given asome approximate Fourier transforms, try to work out the general
# form.  For coefficients of small absolute value, we assume that they
# are really supposed to be zero.  For coefficients that are sufficiently
# cloe, we assume that they should actually be the same.  Signs are
# inserted to ensure that the values of all parameters should be positive.

reset_outline := proc()
 global outline_k,outline_a;
 outline_k := 0;
 outline_a := table():
end:

reset_outline():

make_outline := proc(b)
 global outline_k,outline_a;
 local p,q,i,j,k,m,vp,d,x,F,found;

 p := [op(map(op,b["uvw_coeffs_be"])),
       op(map(op,b["uvw_coeffs_dbe"]))];

 q := NULL:

 for i from 1 to nops(p) do
  vp := p[i];
  if abs(vp) < 0.05 then
   q := q,0;
  else
   found := false;
   for j from 1 to outline_k do
    if abs(vp - outline_a[j]) < 0.001 then
     q := q,a[j];
     found := true;
     break;
    fi;
    if abs(vp + outline_a[j]) < 0.001 then
     q := q,-a[j];
     found := true;
     break;
    fi;
   od:
   if not(found) then
    outline_k := outline_k + 1;
    outline_a[outline_k] := abs(vp);
    q := q,signum(vp) * a[outline_k];
   fi;
  fi;
 od:

 q := [q];

 m := nops(q)/6;
 d := (m-1)/2;
 q := [[seq([q[3*i-2],q[3*i-1],q[3*i]],i=1..m)],
       [seq([q[3*i-2],q[3*i-1],q[3*i]],i=m+1..2*m)]];

 b["uvw_coeffs_be_outline"]  := q[1];
 b["uvw_coeffs_dbe_outline"] := q[2];

 x := [0,0,0];
 F := [1,seq(op([sin(k*t),cos(k*t)]),k=1..d)];

 b["outline_be"] := unapply(
 add(F[i] * q[1][i][1],i=1..m) *~ u[0] +~
 add(F[i] * q[1][i][2],i=1..m) *~ v[0] +~
 add(F[i] * q[1][i][3],i=1..m) *~ w[0],t);

 b["outline_dbe"] := unapply(
 add(F[i] * q[2][i][1],i=1..m) *~ u[0] +~
 add(F[i] * q[2][i][2],i=1..m) *~ v[0] +~
 add(F[i] * q[2][i][3],i=1..m) *~ w[0],t);
end:

# Here we find the general form of the Fourier coefficients for bef o f
# with f in {hband, vband(0), vband(Pi/6), wband}.  Then we construct a list
# of relations that must be imposed to ensure that the approximations fit
# together correctly and have the expected behaviour at the points u[i].

find_approx_form := proc()
 global approx_form_rels,approx_form_sols;
 local t;

 reset_outline():
 make_outline(hband_approx):
 make_outline(vband_approx[0]):
 make_outline(vband_approx[Pi/6]):
 make_outline(wband_approx):

 approx_form_rels := expand(simplify(map(op,expand([
 hband_approx["outline_be"](0) -~ vband_approx[0]["outline_be"](0),
 hband_approx["outline_be"](Pi/6) -~ vband_approx[Pi/6]["outline_be"](0),
 vband_approx[0]["outline_be"](Pi/2) -~ u[0],
 vband_approx[Pi/6]["outline_be"](Pi/2) -~ u[0],
 vband_approx[0]["outline_be"](Pi - arctan(sqrt(2)/4)) -~ u[4],
 vband_approx[0]["outline_be"](   - arctan(sqrt(2)/4)) -~ u[4],
 wband_approx["outline_be"](     Pi/6,0) -~ u[6],
 wband_approx["outline_be"]( 3 * Pi/6,0) -~ u[4],
 wband_approx["outline_be"]( 5 * Pi/6,0) -~ u[5],
 wband_approx["outline_be"]( 7 * Pi/6,0) -~ u[6],
 wband_approx["outline_be"]( 9 * Pi/6,0) -~ u[4],
 wband_approx["outline_be"](11 * Pi/6,0) -~ u[5],
 wband_approx["outline_be"](        0,0) -~ hband_approx["outline_be"](15*Pi/6,0),
 wband_approx["outline_be"](     Pi/3,0) -~ hband_approx["outline_be"](13*Pi/6,0),
 wband_approx["outline_be"]( 2 * Pi/3,0) -~ hband_approx["outline_be"](11*Pi/6,0),
 wband_approx["outline_be"]( 3 * Pi/3,0) -~ hband_approx["outline_be"]( 9*Pi/6,0),
 wband_approx["outline_be"]( 4 * Pi/3,0) -~ hband_approx["outline_be"]( 7*Pi/6,0),
 wband_approx["outline_be"]( 5 * Pi/3,0) -~ hband_approx["outline_be"]( 5*Pi/6,0),
 map(coeffs,expand(hband_approx["outline_be"](t-2/3*Pi)   -~   rot(hband_approx["outline_be" ](t))),{sin(t),cos(t)}),
 map(coeffs,expand(hband_approx["outline_dbe"](t-2/3*Pi)  -~   rot(hband_approx["outline_dbe"](t))),{sin(t),cos(t)}),
 map(coeffs,expand(hband_approx["outline_be"](t+Pi/3)     -~   rot(hband_approx["outline_be" ](t))),{sin(t),cos(t)}),
 map(coeffs,expand(hband_approx["outline_dbe"](t+Pi/3)    +~   rot(hband_approx["outline_dbe"](t))),{sin(t),cos(t)}),
 map(coeffs,expand(vband_approx[0]["outline_be"](t+Pi)    -~ vband_approx[   0]["outline_be" ](t)) ,{sin(t),cos(t)}),
 map(coeffs,expand(vband_approx[0]["outline_dbe"](t+Pi)   +~ vband_approx[   0]["outline_dbe"](t)) ,{sin(t),cos(t)}),
 map(coeffs,expand(vband_approx[Pi/6]["outline_be"](t+Pi) -~ vband_approx[Pi/6]["outline_be" ](t)) ,{sin(t),cos(t)}),
 map(coeffs,expand(vband_approx[Pi/6]["outline_dbe"](t+Pi)-~ vband_approx[Pi/6]["outline_dbe"](t)) ,{sin(t),cos(t)}),
 map(coeffs,expand(wband_approx["outline_be"](t-Pi/3)     -~  rot(wband_approx["outline_be"  ](t))),{sin(t),cos(t)}),
 simplify(expand(dp(hband_approx["outline_dbe"](Pi/12),u[0]))),
 #simplify(expand(dp(wband_approx["outline_dbe"](Pi/12),u[0]))),
 simplify(expand(dp(vband_approx[0]["outline_dbe"](Pi/6),u[0]))),
 simplify(expand(dp(vband_approx[Pi/6]["outline_dbe"](Pi/2),u[0]))),
 NULL])))):

 approx_form_sols := solve(approx_form_rels);
end:

make_boys_cube_complex := proc()
 global boys_cube_complex;
 local N,T,V,P,E,F,C,i,j,k,e,a;

 T := table():
 N := 50;

 V := [seq(i,i=0..N-1)];
 T["vertices"] := V;

 P := table():

 P[ 0] := [ 2, 2, 2]; P[ 1] := [ 2, 2,-2]; P[ 2] := [ 2,-2, 2]; P[ 3] := [-2, 2, 2];
 P[ 4] := [ 2,-2,-2]; P[ 5] := [-2, 2,-2]; P[ 6] := [-2,-2, 2]; P[ 7] := [-2,-2,-2];
 P[ 8] := [ 2, 2, 0]; P[ 9] := [ 2, 0, 2]; P[10] := [ 0, 2, 2]; P[11] := [ 0,-2,-2];
 P[12] := [-2, 0,-2]; P[13] := [-2,-2, 0]; P[14] := [ 2, 0,-2]; P[15] := [ 2,-2, 0];
 P[16] := [ 0,-2, 2]; P[17] := [-2, 0, 2]; P[18] := [-2, 2, 0]; P[19] := [ 0, 2,-2];
 P[20] := [ 2, 0, 0]; P[21] := [ 0, 0, 2]; P[22] := [ 0, 2, 0];
 P[23] := [-2, 0, 0]; P[24] := [ 0, 0,-2]; P[25] := [ 0,-2, 0];
 P[26] := [ 2, 1, 1]; P[27] := [ 2,-1, 1]; P[28] := [ 2,-1,-1]; P[29] := [ 2, 1,-1];
 P[30] := [ 1, 1, 2]; P[31] := [-1, 1, 2]; P[32] := [-1,-1, 2]; P[33] := [ 1,-1, 2];
 P[34] := [ 1, 2, 1]; P[35] := [ 1, 2,-1]; P[36] := [-1, 2,-1]; P[37] := [-1, 2, 1];
 P[38] := [-2,-1,-1]; P[39] := [-2, 1,-1]; P[40] := [-2, 1, 1]; P[41] := [-2,-1, 1];
 P[42] := [-1,-1,-2]; P[43] := [ 1,-1,-2]; P[44] := [ 1, 1,-2]; P[45] := [-1, 1,-2];
 P[46] := [-1,-2,-1]; P[47] := [-1,-2, 1]; P[48] := [ 1,-2, 1]; P[49] := [ 1,-2,-1];

 T["embedding_dim"] := 3;
 T["embedding"] := eval(P);
 T["cube_embedding"] := eval(P);

 T["sphere_embedding"] := table():
 for i in V do
  a := P[i];
  a := a /~ sqrt(add(a[i]^2,i=1..3));
  T["sphere_embedding"][i] := a;
 od:

 E := NULL:
 for i from 0 to N-1 do
  for j from i + 1 to N-1 do
   a := sort(map(abs,P[j] -~ P[i]));
   if modp(P[i],2) *~ modp(P[j],2) = [0,0,0] and
      (a = [0,1,1] or a = [0,0,2]) then
    E := E,[i,j];
   fi;
  od:
 od:

 E := [E];
 T["edges"] := E;

 F := NULL;
 for e in E do
  for k from e[2] + 1 to N-1 do
   if member([e[1],k],E) and member([e[2],k],E) then
    F := F,[op(e),k];
   fi;
  od:
 od:

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

 T["vertex_index"] := table():

 for i in V do
  T["vertex_index"][T["cube_embedding"][i]] := i;
  T["vertex_index"][T["sphere_embedding"][i]] := i;
 od:

 T["hedges"] := [14,28,15,48,16,32,17,40,18,36,19,44,14]:
 T["hedges"] := map(sort,[seq([T["hedges"][i],T["hedges"][i+1]],i=1..nops(T["hedges"])-1)]):

 T["wedges"] := [1,14,4,15,2,16,6,17,3,18,5,19,1]:
 T["wedges"] := map(sort,[seq([T["wedges"][i],T["wedges"][i+1]],i=1..nops(T["wedges"])-1)]):

 C := table():

 for e in T[ "edges"] do C[e] := grey;  od:
 for e in T["hedges"] do C[e] := cyan;  od:
 for e in T["wedges"] do C[e] := black; od:

 C[[ 0, 8]] := orange: C[[ 0, 9]] := orange: C[[ 0,10]] := orange: C[[ 1, 8]] := orange:
 C[[ 2, 9]] := orange: C[[ 3,10]] := orange: C[[ 7,11]] := orange: C[[ 7,12]] := orange:
 C[[ 7,13]] := orange: C[[ 4,11]] := orange: C[[ 5,12]] := orange: C[[ 6,13]] := orange:
 C[[ 0,26]] := green:  C[[ 0,34]] := green:  C[[ 0,20]] := green:  C[[20,26]] := green:
 C[[22,34]] := green:  C[[21,30]] := green:  C[[20,28]] := green:  C[[22,36]] := green:
 C[[21,32]] := green:  C[[ 4,28]] := green:  C[[ 5,36]] := green:  C[[ 6,32]] := green:
 C[[ 1,44]] := green:  C[[ 2,48]] := green:  C[[ 3,40]] := green:  C[[24,44]] := green:
 C[[25,48]] := green:  C[[23,40]] := green:  C[[24,42]] := green:  C[[25,46]] := green:
 C[[23,38]] := green:  C[[ 7,42]] := green:  C[[ 7,46]] := green:  C[[ 7,38]] := green:

 T["edge_colour"] := eval(C):

 T["cube_plot"] :=
 display(
  plot3d([ s, t,-1] *~ 1.99,s=-1..1,t=-1..1,style=patchnogrid,colour=grey),
  plot3d([ s, t, 1] *~ 1.99,s=-1..1,t=-1..1,style=patchnogrid,colour=grey),
  plot3d([ s,-1, t] *~ 1.99,s=-1..1,t=-1..1,style=patchnogrid,colour=grey),
  plot3d([ s, 1, t] *~ 1.99,s=-1..1,t=-1..1,style=patchnogrid,colour=grey),
  plot3d([-1, s, t] *~ 1.99,s=-1..1,t=-1..1,style=patchnogrid,colour=grey),
  plot3d([ 1, s, t] *~ 1.99,s=-1..1,t=-1..1,style=patchnogrid,colour=grey),
  seq(line(P[e[1]],P[e[2]],colour=T["edge_colour"][e]),e in T["edges"]),
  axes=none
 );

 boys_cube_complex := eval(T):
 return eval(T);
end:

refine_boys_cube_complex := proc()
 global refined_boys_cube_complex;
 local T0,TT,S,P,p;
 T0 := `condense/simplicial_complex`(make_boys_cube_complex()):
  `set_edges/simplicial_complex`(T0):
  `set_faces/simplicial_complex`(T0):
  `normalise_embedding/simplicial_complex`(T0):
 T0["boys_embedding"] := map(bef,eval(T0["embedding"])):
 TT := [eval(T0)]:

# P := [0.8,0.6,0.4,0.3]:
 P := [0.8]:

 for p in P do
  S := select(e -> boys_edge_length(T0)(e) > p,T0["edges"]):
  T0 := `partial_triangular_subdivision/simplicial_complex`(T0,S):
  `normalise_embedding/simplicial_complex`(T0):
  T0["sphere_embedding"] := eval(T0["embedding"]):
  T0["boys_embedding"] := map(evalf,map(bef,T0["embedding"])):
  TT := [op(TT),eval(T0)]:
 od:

 refined_boys_cube_complex := eval(T0):

# save(refined_boys_cube_complex,cat(data_dir,"/refined_boys_cube_complex.m")):

 return eval(T0):
end:

edge_length      := (T) -> e -> `d_2/R`(3)(T["embedding"][e[1]],T["embedding"][e[2]]):
boys_edge_length := (T) -> e -> `d_2/R`(3)(T["boys_embedding"][e[1]],T["boys_embedding"][e[2]]):

edge_length_plot      := (T) ->
 listplot(sort(map(edge_length(T),[op(T["edges"])]))):
boys_edge_length_plot := (T) ->
 listplot(sort(map(boys_edge_length(T),[op(T["edges"])]))):

homogeneous_basis := proc(d,x)
 return [seq(seq(x[1]^i*x[2]^j*x[3]^(d-i-j),j=0..d-i),i=0..d)];
end:

extend_cyclic := proc(p)
 local x;

 return unapply([p([x[1],x[2],x[3]]),
                 p([x[2],x[3],x[1]]),
                 p([x[3],x[1],x[2]])],x)
end:

maybe_extend_cyclic := proc(p)
 if type(p(x),list) then
  return eval(p);
 else
  return extend_cyclic(p);
 fi;
end:

make_quadric := proc()
 global general_quadric0,general_quadric,quadric_point_rels,quadric_point_sol,
  special_quadric0,special_quadric,hband_quadric,vband_quadric;
 local B,x,rels,sol;

 B := homogeneous_basis(4,x);
 general_quadric0 := unapply(add(a[i] * B[i],i=1..nops(B)),x):
 general_quadric := extend_cyclic(eval(general_quadric0));

 quadric_point_rels := [
  op(general_quadric(u[0]) -~ u[0]),
  op(general_quadric(u[1]) +~ u[1])
 ]:

 hband_quadric :=
  map(collect,combine(simplify(expand(general_quadric(hband(t,0))))),{seq(cos(k*t),k=1..10),seq(sin(k*t),k=1..10)}):

 vband_quadric[0] :=
  map(collect,combine(simplify(expand(general_quadric(vband(0)(t,0))))),{seq(cos(k*t),k=1..10),seq(sin(k*t),k=1..10)}):

 vband_quadric[Pi/6] :=
  map(collect,combine(simplify(expand(general_quadric(vband(Pi/6)(t,0))))),{seq(cos(k*t),k=1..10),seq(sin(k*t),k=1..10)}):

 quadric_point_sol := solve(quadric_point_rels);

 # We now construct a 6-parameter family of quadrics such that
 # - u[0] maps to u[0], with specified behaviour on the tangent space
 # - u[4] maps to u[4] (which forces u[5] and u[6] to also be fixed, by equivariance)
 # - pol(Pi/3,Pi/6) maps to zero.
 special_quadric := eval(general_quadric):
 rels := simplify(expand({
  op(special_quadric(u[0]) -~ u[0] /~ sqrt(2)),
  op(map(coeffs,simplify(map(rem,expand(
     special_quadric(u[0] +~ t *~ v[0]) -~ special_quadric(u[0]) -~ t *~ ([-1,2,-1]/~sqrt(2))),t^2,t)),t)),
  op(map(coeffs,simplify(map(rem,expand(
     special_quadric(u[0] +~ t *~ w[0]) -~ special_quadric(u[0]) -~ t *~ ([-1,0,1]*~sqrt(3/2))),t^2,t)),t)),
  op(special_quadric(u[4]) -~ u[4] /~ sqrt(2)),
  op(special_quadric(pol(Pi/3,Pi/6)))
 })):
 sol := solve(rels,{seq(a[i],i=7..15)}):
 special_quadric := unapply(expand(subs(sol,special_quadric(x))),x):
 special_quadric0 := unapply(special_quadric(x)[1],x);
end:

make_sextic := proc()
 global general_sextic0,general_sextic,sextic_point_rels,sextic_point_sol,
  hband_sextic,vband_sextic;
 local B,x;

 B := homogeneous_basis(6,x);
 general_sextic0 := unapply(add(a[i] * B[i],i=1..nops(B)),x):
 general_sextic := extend_cyclic(general_sextic0);

 sextic_point_rels := [
  op(general_sextic(u[0]) -~ u[0]),
  op(general_sextic(u[1]) +~ u[1])
 ]:

 hband_sextic :=
  map(collect,combine(simplify(expand(general_sextic(hband(t,0))))),{seq(cos(k*t),k=1..10),seq(sin(k*t),k=1..10)}):

 vband_sextic[0] :=
  map(collect,combine(simplify(expand(general_sextic(vband(0)(t,0))))),{seq(cos(k*t),k=1..10),seq(sin(k*t),k=1..10)}):

 vband_sextic[Pi/6] :=
  map(collect,combine(simplify(expand(general_sextic(vband(Pi/6)(t,0))))),{seq(cos(k*t),k=1..10),seq(sin(k*t),k=1..10)}):

 sextic_point_sol := solve(sextic_point_rels);
end:

check_sextic := proc()
 local x,xx;
 xx := [x[1],x[2],x[3]];

 _ASSERT(
  general_sextic(-~xx) -~ general_sextic(xx) = [0$3],
  "general_sextic is Z/2-equivariant"
 );

 _ASSERT(
  general_sextic(rot(xx)) -~ rot(general_sextic(xx)) = [0$3],
  "general_sextic is Z/3-equivariant"
 );
end:

make_quadric():
make_sextic():

refine_sextic_a := proc()
 global sextic_a0,sextic_a;
 local sextic_rels,sextic_sol;

 sextic_rels := [op(sextic_point_rels),
   seq(coeff(combine(expand(dp(u[0],hband_sextic))),f,1), f in [cos(2*t),sin(4*t),cos(4*t),sin(6*t),cos(6*t)]),
   seq(coeff(combine(expand(dp(v[0],hband_sextic))),f,1), f in [cos(4*t),sin(6*t),cos(6*t)]),
   seq(coeff(combine(expand(dp(w[0],hband_sextic))),f,1), f in [sin(4*t),sin(6*t),cos(6*t)]),
   seq(coeff(combine(expand(dp(u[0],vband_sextic[0]))),f,1), f in [sin(4*t),sin(6*t),cos(6*t)]),
   seq(coeff(combine(expand(dp(v[0],vband_sextic[0]))),f,1), f in [sin(4*t),sin(6*t),cos(6*t)]),
   seq(coeff(combine(expand(dp(w[0],vband_sextic[0]))),f,1), f in [cos(2*t),sin(4*t),cos(4*t),sin(6*t),cos(6*t)]),
   seq(coeff(combine(expand(dp(u[0],vband_sextic[Pi/6]))),f,1), f in [sin(4*t),sin(6*t),cos(6*t)]),
   seq(coeff(combine(expand(dp(v[0],vband_sextic[Pi/6]))),f,1), f in [sin(4*t),sin(6*t),cos(6*t)]),
   seq(coeff(combine(expand(dp(w[0],vband_sextic[Pi/6]))),f,1), f in [cos(2*t),sin(4*t),cos(4*t),sin(6*t),cos(6*t)])
 ]:

 sextic_sol := solve(sextic_rels);
 sextic_a0 := unapply(simplify(expand(subs(sextic_sol,general_sextic0(x)))),x);
 sextic_a  := unapply(simplify(expand(subs(sextic_sol,general_sextic(x)))) ,x);
end:

refine_sextic_b := proc()
 global sextic_b0,sextic_b;
 local sextic_rels,sextic_sol;

 sextic_rels := [op(sextic_point_rels),
  op(map(coeffs,expand(simplify(expand(map(convert,map(series,expand(general_sextic(hband(t,s)) -~ triangle_mobius(t,s)),s=0,2),polynom,s)))),{sin(t),cos(t),s}))
 ]:

 sextic_sol := solve(sextic_rels);
 sextic_b0 := unapply(simplify(expand(subs(sextic_sol,general_sextic0(x)))),x);
 sextic_b  := unapply(simplify(expand(subs(sextic_sol,general_sextic(x)))) ,x);
end:

compare_terms := (u,v) ->
 abs(subs({x[1]=1,x[2]=1,x[3]=1},u)) < abs(subs({x[1]=1,x[2]=1,x[3]=1},v));

sort_terms := proc(p)
 local T;
 T := `if`(type(p,`+`),[op(p)],[p]);
 return sort(T,compare_terms);
end:

# Precompute coefficients for approximate integration over S2 using the
# triangulation T.
int_setup := proc(T)
 local a,b,c,d,f;
 T["face_area"] := table():
 T["face_centre"] := table():
 T["face_centre_be"] := table():
 for f in T["faces"] do
  a,b,c := op(map(i -> T["embedding"][i],f));
  d := a +~ b +~ c;
  d := d /~ `norm_2/R`(3)(d);
  T["face_centre"][f] := d;
  T["face_centre_be"][f] := bef(d);
  T["face_area"][f] := spherical_triangle_area(a,b,c);
 od:
end:

# Integration over S2, normalised to have total area 1.
sphere_int := proc(g,T)
 local u,f;
 u := 0;
 for f in T["faces"] do
  u := u + (g(T["face_centre"][f]) * T["face_area"][f]);
 od:
 u := evalf(u / (4*Pi));
 return u;
end:

sphere_int_be := proc(g,T)
 local u,f;
 u := [0,0,0];
 for f in T["faces"] do
  u := u +~ (g(T["face_centre"][f]) * T["face_area"][f]) *~ T["face_centre_be"][f];
 od:
 u := evalf(u / (4*Pi));
 return u;
end:

# Symbolic integration over the sphere, again normalised to have area 1
sint0 := proc(u)
 option remember;
 local v;
 v := subs({x[1]=sin(s)*cos(t),x[2]=sin(s)*sin(t),x[3]=cos(s)},u) * sin(s)/(4*Pi);
 v := expand(convert(v,exp));
 v := int(v,t=0..2*Pi);
 v := int(v,s=0..Pi);
 return v;
end:

sint := apply_linear(sint0,realcons):

ips := (u,v) -> evalf(sint(expand(u*v))):

# Faster symbolic integration for polynomials
sintp0 := proc(u)
 local c,d,i;
 c := 1;
 for i from 1 to 3 do
  d[i] := degree(u,x[i]);
 od:
 if u <> x[1]^d[1] * x[2]^d[2] * x[3]^d[3] then
  error("Argument is not monomial");
 fi:
 if modp(d[1],2) = 1 or modp(d[2],2) = 1 or modp(d[3],2) = 1 then
  return 0;
 fi;

 return doublefactorial(d[1]-1) *
        doublefactorial(d[2]-1) *
        doublefactorial(d[3]-1) /
        doublefactorial(d[1]+d[2]+d[3]+1);
end:

sintp := apply_linear(sintp0,realcons):

ipsp := (u,v) -> evalf(sintp(expand(u*v))):

make_orthonormal := proc(B,T)
 local Y,i,j;

 Y := table():
 for i from 1 to nops(B) do
  Y[i] := B[i]:
  for j from 1 to i-1 do
   Y[i] := expand(Y[i] - sphere_int(unapply(Y[i]*Y[j],x),T) * Y[j]);
  od:
  Y[i] := expand(Y[i] / sqrt(sphere_int(unapply(Y[i]^2,x),T0))):
 od:

 return eval(Y):
end:

make_immersion := proc(p,T_)
 local pp,T,s,t;

 pp := p;
 if not(type(pp,function)) then pp := unapply(pp,x); fi;
 if not(type(pp(x),list)) then
  pp := unapply([pp([x[1],x[2],x[3]]),
                 pp([x[2],x[3],x[1]]),
                 pp([x[3],x[1],x[2]])],x);
 fi;

 if nargs > 1 then T := eval(T_) else T := table(): fi;
 T["map"] := eval(pp);
 T["map0"] := unapply(pp(x)[1],x);

 pp := T["map0"](pol(s,t));
 pp := combine(expand(simplify(evalf(expand(pp)))));
 T["pol_map0"] := unapply(pp,s,t);
 T["pol_map"] :=
  unapply(evalf([pp(s,t),pp(s+2*Pi/3,t),pp(s,t-2*Pi/3)]),s,t);

 return eval(T);
end:

make_plots := proc(T)
 local opts,p;
 opts := style=patchnogrid,scaling=constrained,axes=none;
 T["plot"] := plot3d(T["pol_map"](s,t),t=0..2*Pi,s=0..Pi,opts,numpoints=8000);
 T["hband_plot"] := plot3d(T["map"](hband(t,s)),t=0..2*Pi,s=-0.2..0.2,opts,numpoints=8000);
 T["vband_plot"] := table():
 for p in [0,Pi/6] do
  T["vband_plot"][p] := plot3d(T["map"](vband(p)(t,s)),t=0..2*Pi,s=-0.2..0.2,opts,numpoints=8000);
 od:

 return T["plot"];
end:

orth_proj := (x) -> <
 <x[2]^2+x[3]^2|-x[1]*x[2]|-x[1]*x[3]>,
 <-x[1]*x[2]|x[1]^2+x[3]^2|-x[2]*x[3]>,
 <-x[1]*x[3]|-x[2]*x[3]|x[1]^2+x[2]^2>
>;

segment_max := proc(f)
 local T,N,s_step,t_step,m0,s0,t0,i,j,sol;
 T := f(pol(s,t));
 N := 6;
 s_step := evalf(Pi/(2*N)):
 t_step := evalf(2*Pi/(3*N)):
 m0 := 0;
 s0 := 0;
 t0 := 0;
 for i from 0 to N-1 do
  for j from 0 to N-1 do
   try
    sol :=
     NLPSolve(T,[],s=i*s_step..(i+1)*s_step,t=j*t_step..(j+1)*t_step,
              maximize=true,method=sqp);
    if sol[1] > m0 then
     m0 := sol[1];
     s0 := subs(sol[2],s);
     t0 := subs(sol[2],t);
    fi;
   catch:
   end try:
  od:
 od:

 return [m0,s0,t0]
end:

# If p : R^3 -> R^3 then jac(p)(x) is a 3x3 positive semidefinite
# matrix with 0 as one eigenvalue.  The map p is immersive at a
# point x in S2 iff the other two eigenvalues of jac(p)(x) are
# strictly positive.  If p(x) is a homogeneous polynomial of degree
# d in the variables x[i], then jac(p)(x) is homogeneous of degree
# 2 in the coefficients of p, and homogeneous of degree 2d in the
# variables x[i].

jac := proc(p)
 local J0,P,J,x;
 J0 := Matrix([seq([seq(diff(p(x)[i],x[j]),j=1..3)],i=1..3)]):
 P := orth_proj(x);
 J := map(expand,P . Transpose(J0) . J0 . P);
 return unapply(J,x);
end:

jac_det := proc(p)
 local J,f,t,x;
 J := jac(p)(x);
 f := Determinant(t * IdentityMatrix(3) - J);
 return unapply(coeff(f,t,1),x);
end:

jac_det_min := proc(p)
 local f,m0,s0,t0;
 f := unapply(-jac_det(p)(x),x);
 m0,s0,t0 := op(segment_max(f));
 return [-m0,s0,t0];
end:

jac_det_plot := proc(T)
 local p;
 p := T["map"];

 T["jac_det_plot"] :=
  display(
   plot3d(0,s=0..Pi/2,t=0..2*Pi/3,colour=grey,style=patchnogrid),
   plot3d(jac_det(p)(pol(s,t)),s=0..Pi/2,t=0..2*Pi/3)
  );
 return T["jac_det_plot"];
end:

# This returns a function of x measuring the failure of p to be
# locally isometric at x.  It is easy to evaluate and integrate,
# but does not strongly penalise points where the Jacobian becomes
# singular.  If p is homogeneous quadric, then jac_dev_a(p)
jac_dev_a := proc(p)
 local J,P,E;
 J := jac(p)(x);
 P := orth_proj(x);
 E := add(add((J[i,j] - P[i,j])^2,j=1..3),i=1..3);
 return unapply(E,x);
end:

# This is a different measure of the failure of p to be a local
# isometry.  It is less easy to compute but strongly penalises
# points where the Jacobian becomes singular.
jac_dev_b := proc(p)
 local J,f,c1,c2,x;
 J := jac(p)(x);
 f := Determinant(t * IdentityMatrix(3) - J);
 c1 := - coeff(f,t,2);
 c2 := coeff(f,t,1);
 return unapply(c1*(1+1/c2),x);
end:

jac_dev_a_max := (p) -> segment_max(jac_dev_a(p));

jac_dev_b_max := (p) -> segment_max(jac_dev_b(p));

# This takes a polynomial map p : R3 -> R3 (which may depend linearly
# on some parameters) and another polynomial map p_start : R3 -> R3
# (with no parameters).  It specialises the parameters in p to make it
# as close as possible (as measured by coefficients) to p_start.
# Starting from there, it adjusts the parameters to minimize the
# value of jac_dev_b_max.
optimise_immersion := proc(p,p_start)
 global F,F_n,F_vars,F_best,F_vals;
 local pp,pp_start,p0,err,sol,aa0;

 pp := maybe_extend_cyclic(p);
 pp_start := maybe_extend_cyclic(p_start);

 F_vars := indets(pp(x)) minus {x[1],x[2],x[3]};
 F_n := nops(F_vars);
 p0 := unapply(subs({seq(F_vars[i] = a[i],i=1..F_n)},pp(x)),x);
 F_vals := table():
 F_best := NULL:

 err := evalf(expand(p0(x)[1] - pp_start(x)[1]));
 err := [coeffs(err,{x[1],x[2],x[3]})];
 err := expand(add(t^2,t in err));
 sol := solve({seq(diff(err,a[i]),i=1..F_n)}):
 aa0 := subs(sol,[seq(a[i],i=1..F_n)]);

 F := proc(aa)
  local p1,m;
  global F_vals,F_best;
  p1 := unapply(evalf(subs({seq(a[i]=aa[i],i=1..F_n)},p0(x))),x);
  m := jac_dev_b_max(p1);
  F_vals := [op(F_vals),[convert(aa,list),m]];
  if F_best = NULL or m[1] < F_best[2][1] then
   F_best := [convert(aa,list),m];
  fi;
  print(m[1]);
  return m[1];
 end:

 NLPSolve(F_n,F,initialpoint=Vector(aa0),method=nonlinearsimplex);
 return unapply(evalf(subs({seq(a[i] = F_best[1][i],i=1..F_n)},p0(x))),x);
end:

sextics := table():

sextics[1] := make_immersion(
 0.264790817514485*x[2]*x[3]^5 +
 0.310873678789934*x[2]^5*x[3] +
 0.314356886190530*x[1]^6 +
(-0.367461017219878)*x[1]^3*x[2]^3 +
 0.520593122199589*x[1]^3*x[3]^3 +
 0.576919957376212*x[3]^6 +
 0.916070813636660*x[1]^4*x[2]*x[3] +
 1.08011357291557*x[1]*x[2]^4*x[3] +
(-1.29574375446066)*x[1]^2*x[2]^4 +
(-1.50136425744714)*x[2]^4*x[3]^2 +
 1.75322964015665*x[2]^3*x[3]^3 +
 1.83297848992403*x[1]^4*x[3]^2 +
 1.97193642230680*x[1]^3*x[2]^2*x[3] +
 3.00614990897844*x[1]^2*x[2]*x[3]^3 +
 3.14671754019206*x[2]^2*x[3]^4 +
(-3.31538823843401)*x[1]^3*x[2]*x[3]^2 +
 3.47953011385635*x[1]*x[2]^3*x[3]^2 +
(-3.48258924201893)*x[1]^2*x[2]^2*x[3]^2 +
 3.68883801947675*x[1]^2*x[3]^4 +
(-3.70117135607353)*x[1]*x[2]^2*x[3]^3 +
 5.13825301199981*x[1]^2*x[2]^3*x[3]):

quadrics := table():

# This map is nice and simple and is equivariant for the full symmetry
# group of the tetrahedron.  There are double points on the intersections
# of the coordinate planes with S2, and the points +/- e[i] are all
# sent to the origin.  The map is not an immersion because the Jacobian
# is zero at [+/-1,+/-1,0]/sqrt(2) and permutations of that.
quadrics[0] := make_immersion(
 sqrt(2)*x[2]*x[3]*(-2*x[1]^2+x[2]^2+x[3]^2)+(3*sqrt(3))*x[1]^2*x[2]*x[3]
);

quadrics["singular"] := eval(quadrics[0]);

# This is fitted to the original Boys embedding.  The pictures are nice but
# the minimal Jacobian determinant is very small.
quadrics[1] := make_immersion(
 2.22504534947546*x[1]^2*x[2]*x[3]+
 0.458129331010717*x[2]*x[3]^3+
 0.189460510525367*x[1]*x[2]*x[3]^2+
 0.707682203241314*x[2]^3*x[3]+
 0.188439848721650*x[1]*x[2]^2*x[3]+
 0.259985777619243*x[1]^3*x[3]+
 (-0.287042815821211)*x[1]*x[3]^3+
 1.76981740175627*x[1]^2*x[3]^2+
 0.118256474175355*x[2]^2*x[3]^2+
 (-0.478109121568119)*x[1]^3*x[2]+
 0.279208660926366*x[1]*x[2]^3+
 (-1.02732331413132)*x[1]^2*x[2]^2+
 (-0.127292231262611)*x[2]^4+
 0.812016127928750*x[3]^4+
 0.348555338251230*x[1]^4):

quadrics["boys"] := eval(quadrics[1]);

# This is chosen for simplicity.  The pictures are again nice and the minimal
# Jacobian determinant is a bit bigger than for quadric1, but still small.
quadrics[2]  := make_immersion(
 x[1]^2*x[3]*(x[2]+x[3])+(1/2)*(-1+3*sqrt(3))*x[2]*x[3]*(x[2]^2+x[3]^2)+
 sqrt(3)*x[3]^4-(1+sqrt(3))*x[1]^2*x[2]^2):

quadrics["simple"] := eval(quadrics[2]);

# The map quadric3 is a special case of special_quadric0 with
# max(jac_dev_b) minimized.

quadrics_a[3] :=
 [0.439109301326211, 1.00088884489061, 0.276971768183746,
  0.804297719366554, -0.228929556357166, -0.0920206086999537]:

quadrics[3] := make_immersion(
 evalf(sqrt(2) * subs({seq(a[i] = quadrics_a[3][i],i=1..6)},special_quadric0(x))));

quadrics[3]["a"] := quadrics_a[3];

quadrics["best"] := eval(quadrics[3]);

# This is Apery's quadric, up to linear changes of variables in the
# domain and codomain.  It sends u[0] to itself, and u[1] to u[6]
# to the origin.
quadrics[4] := make_immersion((
 (2 + 20*sqrt(2)) * x[1]^4 +
 (2 - 10*sqrt(2)) * (x[2]^4 + x[3]^4) +
 (10*sqrt(2) + 13) * x[1]^2 * (x[2]^2 + x[3]^2) +
 27 * x[1] * x[2] * x[3] * (x[1]+x[2]+x[3]) +
 (13 - 20*sqrt(2)) * x[2]^2 * x[3]^2 +
 9 * x[1]^3 * (x[2] + x[3]) +
 9 * x[2] * x[3] * (x[2]^2 + x[3]^2) +
 9 * x[1] * (x[2]^3 + x[3]^3) +
 (9 + 20*sqrt(2)) * x[2] * x[3] * (x[2]^2 - x[3]^2) +
 (10 * sqrt(2) - 9) * x[1] * (x[2]^3-x[3]^3) +
 (10 * sqrt(2) - 9) * (-x[1]^3) * (x[2] - x[3])) / (20 * sqrt(3)));

quadrics["apery"] := eval(quadrics[4]);

# This is optimised in a similar way to quadric3 but with slightly
# different constraints
quadrics[5] := make_immersion(
 3.25245542513966246*x[1]^2*x[2]*x[3]+
 0.567045610094270236*x[1]^2*x[3]^2+
 0.506746342124321902*x[2]^3*x[3]+
 1.43695065673601552*x[2]*x[3]^3+
 0.506586664999783221*x[3]^4+
 (-1.07154585120271717)*x[1]^2*x[2]^2+
 (-0.137651281752026899)*x[2]^2*x[3]^2+
 (-0.0475300936088673548)*x[2]^4+
 (-0.0729799939799069125)*x[1]*x[3]^3+
 (0.600907939705055405)*x[1]*x[2]*x[3]^2+
 (-0.121589626981102178)*x[1]*x[2]^2*x[3]+
 (0.0173511518008154855)*x[1]*x[2]^3+
 0.194569620961009104*x[1]^3*x[3]+
 (-0.618259091505870884)*x[1]^3*x[2]+
 0.183094951469558120*x[1]^4);

find_double_direction := proc(T,x0,x1)
 local v0,v1,w0,w1,pv0,pv1,pw0,pw1,n0,n1,nn;
 v0 := evalf(u[0] -~ dp(u[0],x0) *~ x0);
 v0 := v0 /~ sqrt(dp(v0,v0));
 w0 := evalf(cross_product(x0,v0));
 v1 := evalf(u[0] -~ dp(u[0],x1) *~ x1);
 v1 := v1 /~ sqrt(dp(v1,v1));
 w1 := evalf(cross_product(x1,v1));
 pv0 := evalf(subs(t = 0,map(diff,T["map"](x0 +~ t *~ v0),t)));
 pw0 := evalf(subs(t = 0,map(diff,T["map"](x0 +~ t *~ w0),t)));
 pv1 := evalf(subs(t = 0,map(diff,T["map"](x1 +~ t *~ v1),t)));
 pw1 := evalf(subs(t = 0,map(diff,T["map"](x1 +~ t *~ w1),t)));
 n0 := cross_product(pv0,pw0);
 n1 := cross_product(pv1,pw1);
 nn := cross_product(n0,n1);
 nn := nn /~ sqrt(dp(nn,nn));
 return nn;
end:

find_double_point := proc(T,x0,y0,u0,d0)
 local pp,eqs,start,sol,xyz;

 pp := T["map"];
 eqs := {
  x[1]^2 + x[2]^2 + x[3]^2 - 1,
  y[1]^2 + y[2]^2 + y[3]^2 - 1,
  op(pp(x) -~ pp(y)),
  dp(pp(x),u0) - d0
 };
 start := {
  seq(x[i] = x0[i],i=1..3),
  seq(y[i] = y0[i],i=1..3)};
 sol := fsolve(eqs,start);
 xyz := evalf(subs(sol,
   [[x[1],x[2],x[3]],[y[1],y[2],y[3]],pp(x)]));
 if not(type(T["double_points"],list)) then
  T["double_points"] := []:
 fi:
 T["double_points"] := [op(T["double_points"]),xyz];
 return xyz;
end:

double_point_step := proc(T,e)
 local p,q,x0,y0,u0,d0;
 p := T["double_points"][-2];
 q := T["double_points"][-1];
 x0 := 2 *~ q[1] -~ p[1];
 y0 := 2 *~ q[2] -~ p[2];
 u0 := q[3] -~ p[3];
 u0 := evalf(u0 /~ sqrt(dp(u0,u0)));
 d0 := dp(q[3],u0) + e;
 return find_double_point(T,x0,y0,u0,d0);
end:

find_seam := proc(T,xyz0,u0,e_min,e_max)
 local pp,z0,z01,z02,r0,r1,c0,c1,dc0,dc1,N,M,F,i,aa,bb,a,b;

 pp := T["map"];

 N := 240:
 F := proc(e)
  local i;
  T["double_points"] := evalf([xyz0]):
  find_double_point(T,xyz0[1],xyz0[2],u0,e):
  for i from 1 to N do double_point_step(T,e); od:
  return table(["err" = dp(T["double_points"][N+1][3],u0)]);
 end:

 T["double_point_step_length"] :=
  brent_fsolve(F,e_min,e_max,false,false,10^(-7),10^(-7))[1];

 aa := T["double_points"][1];
 bb := T["double_points"][240];

 if evalf(`d_2/R`(3)(bb[1],aa[2])) < evalf(`d_2/R`(3)(bb[1],-~aa[2])) then
  T["double_points_alt"] := [
   seq(T["double_points"][i][1],i=1..240),
   seq(T["double_points"][i][2],i=1..240),
   seq(-~ T["double_points"][i][1],i=1..240),
   seq(-~ T["double_points"][i][2],i=1..240),
   T["double_points"][1][1]]:
 else
  T["double_points_alt"] := [
   seq(T["double_points"][i][1],i=1..240),
   seq(-~ T["double_points"][i][2],i=1..240),
   seq(-~ T["double_points"][i][1],i=1..240),
   seq(T["double_points"][i][2],i=1..240),
   T["double_points"][1][1]]:
 fi;

 M := 20:
 for i from 0 to M do
  a[i] := add(T["double_points_alt"][j+1][1] * evalf(cos(Pi * (2 * i + 1) * j/480)),j=0..959)/480;
  b[i] := add(T["double_points_alt"][j+1][1] * evalf(sin(Pi * (2 * i + 1) * j/480)),j=0..959)/480;
 od:

 T["seam0"] := unapply(
   add(a[i] * cos((2 * i + 1) * t) + b[i] * sin((2 * i + 1) * t),i=0..M),t):

 T["seam"] := unapply([T["seam0"](t),T["seam0"](t+2*Pi/3),T["seam0"](t-2*Pi/3)],t):

 return NULL:
end:

double_points_plot := proc(T)
 local L;
 L := T["double_points"];
 display(
  usphere_plot,
  seq(point(x[1],colour=red),x in L),
  seq(point(x[2],colour=blue),x in L),
  seq(point(-~ x[1],colour=magenta),x in L),
  seq(point(-~ x[2],colour=cyan),x in L),
  axes=none,scaling=constrained
 );
end:

seam_plot := proc(T)
 spacecurve(T["seam"](t),t=0..2*Pi,colour=red,scaling=constrained,axes=none)
end:


# Konvertierung Vektor zu symmetrischer Matrix
# Einleitung
# Generiere die Umwandlung von Vektor mit oberem rechten Teil einer Symmetrischen Matrix zur Matrix selbst für die Dimensionen des Roboters.
# Diese Umwandlung verursacht weniger Rechenoperationen als die Verwendung der numerischen Funktion vec2symmat in Matlab, da dort jedes Mal die Indizes beim Zusammenbauen der Matrix getestet werden müssen.
# Autor
# Tim Job (Studienarbeit bei Moritz Schappler), 2019-4
# Moritz Schappler, moritz.schappler@imes.uni-hannover.de
# (C) Institut für Mechatronische Systeme, Universität Hannover
# 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.
read "../helper/proc_MatlabExport":
read "../helper/proc_vector2mat":
read "../robot_codegen_definitions/robot_env_par":
read sprintf("../codeexport/%s/tmp/para_definitions", robot_name):
printf("Generiere Symmat2Vector-Funktionen für %s\n", robot_name):
codegen_opt := 0: # Soll nicht von Einstellung in robot_env überschrieben werden.
;
# Funktion symmat2vector für den Roboter definieren
# Erstelle eine Dummy-Variable (mv), die als temporäre Variable in Matlab dient (zum Zusammensetzen der Matrix).
clear('mv'):
M_NX:= vec2mat(mv, NX):
# Warnungen bei Code-Generierung unterdrücken. Die Meldung das der Ausdruck mv() in Matlab nicht bekannt ist, spielt keine Rolle, da diese Variable nach dem Einsetzen des Codes vorher definiert sein wird.
interface(warnlevel=0):
MatlabExport(M_NX, sprintf("../codeexport/%s/tmp/vec2mat_%d_matlab.m", robot_name, NX), codegen_opt):


p := 5;

# b(i) is the image in H_{2i}(QS^0) of the standard generator of H_{2i}(BC_p)
# This is zero unless i is divisible by p-1.  An expression like b(8,4,6)
# represents the circle product of b(8), b(4) and b(6).

b := proc()
 if map(mods,{0,args},p-1) <> {0} or min(0,args) < 0 then
  return(0);
 fi;
 'b'(op(sort([args])));
end:

# Signature of permutations of {1,...,n}, represented as lists of values.
# Sends non-permutations to zero.
signature := proc(s)
 local i,j,x;
 x := 1;
 for i from 1 to nops(s)-1 do
  for j from i+1 to nops(s) do
   if op(i,s) > op(j,s) then
    x := -x;
   elif op(i,s) = op(j,s) then
    return(0);
   fi;
  od;
 od;
 x;
end:

# a(i) is the image in H_{2i+1}(QS^0) of the standard generator of H_{2i+1}(BC_p)
# This is zero unless i+1 is divisible by p-1.  An expression like a(11,3,7)
# represents the circle product of a(11), a(3) and a(7).
a := proc()
 if map(modp,{-1,args},p-1) <> {p-2} or min(0,args) < 0 then
  return(0);
 fi;
 signature([args]) * 'a'(op(sort([args])));
end:

# The elements b(i) satisfy \sum b(i,j) s^i t^j=\sum b(i,j) s^i (s+t)^j.
# By expanding this out we see that b_rel(i,j) = 0 for all i and j,
# where b_rel(i, j) is as defined below.

b_rel := proc(i,j)
 add(mods(binomial(i+j-u,j),p) * b(u,i+j-u),u=0..i-1);
end:

b_rels := proc(d) [seq(b_rel(i,d-i),i=0..d)]; end:

# The elements a(i) satisfy \sum a(i,j) s^i t^j=\sum a(i,j) s^i (s+t)^j.
# By expanding this out we see that a_rel(i,j) = 0 for all i and j,
# where a_rel(i, j) is as defined below.

a_rel := proc(i,j)
 add(mods(binomial(i+j-u,j),p) * a(u,i+j-u),u=0..i-1);
end:

a_rels := proc(d) [seq(a_rel(i,d-i),i=0..d)]; end:

# Degree function for expressions in a's, b's, P's and Q's.
# Should be refactored to use apply_deg
# Not sure what the P's and Q's are
deg := proc(x)
 local d,n;
 if type(x,`+`) then
  d := map(deg,{op(x)});
  if nops(d) = 1 then
   return(op(1,d));
  else
   error("inhomogeneous sum");
  fi;
 elif type(x,`*`) then
  return(`+`(op(map(deg,[op(x)]))));
 elif type(x,function) and op(0,x) = o then
  return(`+`(op(map(deg,[op(x)]))));
 elif type(x,integer) then
  return(0);
 elif type(x,function) and op(0,x) = a then
  return(`+`(op(map(i->2*i+1,[op(x)]))));
 elif type(x,function) and op(0,x) = b then
  return(`+`(op(map(i->2*i,[op(x)]))));
 elif type(x,function) and op(0,x) = P then
  n := nops(x)/2;
  return( -2*(p-1)*add(op(2*i,x),i=1..n) - add(op(2*i-1,x),i=1..n));
 elif type(x,function) and op(0,x) = Q then
  n := nops(x)/2;
  return( 2*(p-1)*add(op(2*i,x),i=1..n) - add(op(2*i-1,x),i=1..n));
 fi;
end:

# Circle product.  Shoud be refactored to use apply_*
o := proc()
 local xx;
 xx := map(mods,[args],p);
 if member(0,xx) then
  return(0);
 else
  return('o'(op(xx)));
 fi;
end:

# Bockstein operation.  Recognises star and circle products, a's, b's and Q's
beta := proc(x)
 local xx,n,s,y,i,j;
 if type(x,`+`) then
  return(map(beta,x));
 elif type(x,`*`) then
  xx := [op(x)];
  n := nops(xx);
  s := 1;
  y := 0;
  for i from 1 to n do
   y := y + s * mul(xx[j],j=1..(i-1)) * beta(xx[i]) * mul(xx[j],j=i+1..n);
   s := s * (-1)^deg(xx[i]);
  od;
  return(mods(expand(y),p));
 elif type(x,function) and op(0,x) = o then
  xx := [op(x)];
  n := nops(xx);
  s := 1;
  y := 0;
  for i from 1 to n do
   y := y + s * o(seq(xx[j],j=1..(i-1)),beta(xx[i]),seq(xx[j],j=i+1..n));
   s := s * (-1)^deg(xx[i]);
  od;
  return(mods(expand(y),p));
 elif type(x,integer) then
  return(0);
 elif type(x,function) and op(0,x) = a then
  return(0);
 elif type(x,function) and op(0,x) = b then
  xx := [op(x)];
  n := nops(xx);
  y := 0;
  for i from 1 to n do
   if xx[i] > 0 then
    y := y + o(a(xx[i]-1),b(seq(xx[j],j=1..i-1),seq(xx[j],j=i+1..n)));
   fi;
  od;
  return(mods(expand(y),p));
 elif type(x,function) and op(0,x) = Q then
  if nops(x) = 0 or op(1,x) = 1 then return(0); fi;
  return(Q(1,op(2..-1,x)));
 else
  return('beta'(x));
 fi;
end:

# Dyer-Lashof operation.  Only knows linearity and the Cartan rule
QQ := proc(i,x)
 local y,z;
 if type(x,`+`) then
  return(map2(QQ,i,x));
 elif type(x,`*`) then
  y := op(1,x);
  z := `*`(op(2..-1,x));
  if type(y,integer) then
   return(mods(expand(y*QQ(i,z)),p));
  else
   return(mods(expand(add(QQ(j,y)*QQ(i-j,z),j=0..i)),p));
  fi;
 elif type(x,integer) then
  if i = 0 then
   return(x);
  else
   return(0);
  fi;
 else
  return('QQ'(i,x));
 fi;
end:

# Steenrod operation.  Knows the Cartan rule for star and circle products,
# and behaviour on a's, b's and Q's.
PP := proc(i,x)
 local y,z,j,s;
 if i<0 then
  return(0);
 elif i=0 then
  return(x);
 elif type(x,`+`) then
  return(map2(PP,i,x));
 elif type(x,`*`) then
  y := op(1,x);
  z := `*`(op(2..-1,x));
  if type(y,integer) then
   return(mods(expand(y*PP(i,z)),p));
  else
   return(mods(expand(add(PP(j,y)*PP(i-j,z),j=0..i)),p));
  fi;
 elif type(x,function) and op(0,x) = o then
  y := op(1,x);
  z := o(op(2..-1,x));
  if type(y,integer) then
   return(mods(expand(y * PP(i,z)),p));
  else
   return(mods(expand(add(o(PP(j,y),PP(i-j,z)),j=0..i)),p));
  fi;
 elif type(x,integer) then
  if i = 0 then
   return(x);
  else
   return(0);
  fi;
 elif type(x,function) and op(0,x) = b then
  j := op(1,x);
  if nops(x) = 1 then
   return(mods(binomial(j-(p-1)*i,i),p)*b(j-(p-1)*i));
  else
   z := b(op(2..-1,x));
   return(mods(expand(add(binomial(j-(p-1)*k,k)*o(b(j-(p-1)*k),PP(i-k,z)),k=0..j/(p-1))),p));
  fi;
 elif type(x,function) and op(0,x) = a then
  j := op(1,x);
  if nops(x) = 1 then
   return(mods(binomial(j-(p-1)*i,i),p)*a(j-(p-1)*i));
  else
   z := a(op(2..-1,x));
   return(mods(expand(add(binomial(j-(p-1)*k,k)*o(a(j-(p-1)*k),PP(i-k,z)),k=0..j/(p-1))),p));
  fi;
 elif type(x,function) and op(0,x) = Q then
  if nops(x) = 0 then
   if i=0 then return(x) else return(0); fi;
  fi;
  s := op(2,x);
  y := Q(op(3..-1,x));
  if op(1,x) = 0 then
   return(add((-1)^(i+k)*binomial((s-i)*(p-1),i-p*k)*oQ(Q(0,s-i+k),PP(k,y)),k=0..i/p));
  else
   return(zap(
    add((-1)^(i+k)*binomial((s-i)*(p-1)-1,i-p*k)*oQ(Q(1,s-i+k),PP(k,y)),k=0..i/p) +
    add((-1)^(i+k)*binomial((s-i)*(p-1)-1,i-p*k-1)*oQ(Q(0,s-i+k),PP(k,beta(y))),k=0..i/p)
   ));
  fi;
 else
  return('PP'(i,x));
 fi;
end:

# Length function for Steenrod or Dyer-Lashof words.
len := proc(x)
 if type(x,function) and (op(0,x) = P or op(0,x) = Q) then
  return(nops(x)/2);
 else
  return('len'(x));
 fi;
end:

# Excess for Dyer-Lashof words
excess := proc(x)
 local n;
 if type(x,function) and op(0,x) = Q then
  n := nops(x)/2;
  if n = 0 then return(0); fi;
  return(2*op(2,x) - op(1,x) - add(2*(p-1)*op(2*i,x)-op(2*i-1,x),i=2..n));
 else
  return('excess'(x));
 fi;
end:

# Admissibility criterion for Dyer-Lashof words
is_admissible := proc(x)
 local i,n;
 if type(x,function) and op(0,x) = Q then
  n := nops(x)/2;
  if n = 0 then
   return(true);
  fi;
  if op(2,x) < op(1,x) then
   return(false);
  fi;
  for i from 2 to n do
   if p*op(2*i,x) - op(2*i-1,x) < op(2*i-2,x) then
    return(false);
   fi;
  od;
  return(true);
 else
  return('is_admissible'(x));
 fi;
end:

Q_adem := proc()
 local i,j,u,ep,r,dl,s,v;
 if nargs = 0 then
  return(Q());
 fi;
 if args[2] < args[1] then
  # (we must have args[1] = 1, args[2] = 0)
  if nargs = 2 then
#   error("naked beta");
   return(Q(1,0));
  fi;
  if args[3] = 1 then
   return(0);
  else
   return(Q(1,args[4..-1]));
  fi;
 fi;
 for i from 2 to nargs/2 do
  u  := args[1..2*i-4];
  ep := args[2*i-3];
  r  := args[2*i-2];
  dl := args[2*i-1];
  s  := args[2*i  ];
  v  := args[2*i+1..-1];
  if r > p*s-dl then
   if dl = 0 then
    return(
     mods(add(
      (-1)^(r+j)*binomial((p-1)*(j-s)-1,p*j-r)*
       Q(u,ep,r+s-j,0,j,v),
      j=ceil(r/p)..(r-(p-1)*s-1)
     ),p)
    );
   else
    if ep = 0 then
     return(mods(add(
      (-1)^(r+j)*binomial((p-1)*(j-s),p*j-r)*
       Q(u,1,r+s-j,0,j,v),
      j=ceil(r/p)..(r-(p-1)*s)
     ),p) -
     mods(add(
      (-1)^(r+j)*binomial((p-1)*(j-s)-1,p*j-r-1)*
       Q(u,0,r+s-j,1,j,v),
       j = ceil((r+1)/p)..(r-(p-1)*s)
     ),p));
    else
     return(mods(add(
      (-1)^(r+j+1)*binomial((p-1)*(j-s)-1,p*j-r-1)*
       Q(u,1,r+s-j,1,j,v),
       j = ceil((r+1)/p)..(r-(p-1)*s)
     ),p));
    fi;
   fi;
  fi;
 od;
 return(Q(args));
end:

Q_exc0 := proc()
 if excess(Q(args)) < 0 then
  return(0);
 else
  return(Q(args));
 fi;
end:

Q_comp := proc(a,b)
 local aa,bb,n,m,i,d;
 aa := a;
 bb := b;
 if type(aa,`*`) then
  aa := select(type,a,specfunc(integer,Q));
 fi;
 if type(bb,`*`) then
  bb := select(type,b,specfunc(integer,Q));
 fi;
 if not(type([aa,bb],[specfunc(integer,Q)$2])) then
  error("invalid arguments");
 fi;
 n := nops(aa)/2;
 m := nops(bb)/2;
 for i from 1 to min(n,m) do
  d := 2*op(2*i,aa) - op(2*i-1,aa) - 2*op(2*i,bb) + op(2*i-1,bb);
  if d < 0 then
   return(true);
  elif d > 0 then
   return(false);
  fi;
 od;
 if n<m then return(true); fi;
 return(false);
end:

Q_terms := proc(x)
 if type(x,specfunc(integer,Q)) then
  return([x]);
 elif type(x,`*`) then
  return(select(type,[op(x)],specfunc(integer,Q)));
 elif type(x,`+`) then
  return(map(op,map(Q_terms,[op(x)])));
 else
  return([]);
 fi;
end:

Q_bot := proc(x)
 local t;
 t := sort(Q_terms(x),Q_comp);
 if t = [] then
  return(0);
 else
  return(t[1]);
 fi;
end:

Q_top := proc(x)
 local t;
 t := sort(Q_terms(x),Q_comp);
 if t = [] then
  return(0);
 else
  return(t[nops(t)]);
 fi;
end:

oQ := proc(a,b)
 local n,aa,bb;
 if type(a,`+`) then
  return(map(oQ,a,b));
 elif type(b,`+`) then
  return(map2(oQ,a,b));
 fi;
 if type(a,`*`) then
  n,aa := selectremove(type,a,integer);
  if n<>1 then
   return(expand(n*oQ(aa,b)));
  fi;
 fi;
 if type(b,`*`) then
  n,bb := selectremove(type,b,integer);
  if n<> 1 then
   return(expand(n*oQ(a,bb)));
  fi;
 fi;
 if type(a,integer) or type(b,integer) then
  return(expand(a*b));
 fi;
 if type(a,specfunc(integer,Q)) and type(b,specfunc(integer,Q)) then
  return(Q(op(a),op(b)));
 fi;
end:

zap := proc(x) mods(eval(subs(Q=Q_exc0,eval(subs(Q = Q_adem,x)))),p); end:


program typeconv;
 var i : integer; b : boolean; c : char;
begin
  i := integer(false);
  while i <= integer(true) do begin
    writeln( boolean(i), ' : ', i);
    i := i + 1;
  end;
  writeln;
  i := integer(' ');
  while i < 127 do begin
    if i div 16 * 16 = i then writeln;
    write(char(i), ' ');
    i := i + 1;
  end;
  writeln
end.


read "print_comp.mpl":
all_var_set:=[
   [DPH,0,dn] , [dg,2,dn] ,
         [met,2,dn], [invmet,2,up], [DDL,2,dn],
   [DTK,0,dn],
         [RR,2,dn], [U,2,dn] , [P,2,dn],
   [DAA,2,dn],
   [DLAM,1,up],
   [C1,0,dn],
   [C5,0,dn],
   [HS,0,dn]
             ];
s:="";
for i from 1 to nops(all_var_set) do
  s:=cat(s,print_comp(all_var_set[i][1],[x,theta,phi],all_var_set[i][2],diag=true,tp=all_var_set[i][3])):
end do:
FP:=fopen("allequations.mpl",WRITE);
writeline(FP,s);
fclose(FP);


var $g_i8_u <i8>
var $g_i8 <i8> = 8
var $g_u8_u <u8>
var $g_u8 <u8> = 8

var $g_i16_u <i16>
var $g_i16 <i16> = 16
var $g_u16_u <u16>
var $g_u16 <u16> = 16

var $g_i32_u <i32>
var $g_i32 <i32> = 32
var $g_u32_u <u32>
var $g_u32 <u32> = 32

var $g_i64_u <i64>
var $g_i64 <i64> = 0x123456789a
var $g_u64_u <u64>
var $g_u64 <u64> = 0x123456789a

var $g_f32_u <f32>
var $g_f32 <f32> = 1.2f

var $g_f64_u <f64>
var $g_f64 <f64> = 2.4

# i8/u8
func $add_i8_u () i8 {
   return (
     add i32(dread i32 $g_i8_u, constval i32 0))}

func $add_i8 () i8 {
   return (
     add i32(dread i32 $g_i8, constval i32 0))}

func $add_u8_u () u8 {
   return (
     add u32(dread u32 $g_u8_u, constval u32 0))}

func $add_u8 () u8 {
   return (
     add u32(dread u32 $g_u8, constval u32 0))}

# i16/u16
func $add_i16_u () i16 {
   return (
     add i32(dread i32 $g_i16_u, constval i32 0))}

func $add_i16 () i16 {
   return (
     add i32(dread i32 $g_i16, constval i32 0))}

func $add_u16_u () u16 {
   return (
     add u32(dread u32 $g_u16_u, constval u32 0))}

func $add_u16 () u16 {
   return (
     add u32(dread u32 $g_u16, constval u32 0))}

# i32/u32
func $add_i32_u () i32 {
   return (
     add i32(dread i32 $g_i32_u, constval i32 0))}

func $add_i32 () i32 {
   return (
     add i32(dread i32 $g_i32, constval i32 0))}

func $add_u32_u () u32 {
   return (
     add u32(dread u32 $g_u32_u, constval u32 0))}

func $add_u32 () u32 {
   return (
     add u32(dread u32 $g_u32, constval u32 0))}

# i64/u64
func $add_i64_u () i64 {
   return (
     add i64(dread i64 $g_i64_u, constval i64 0))}

func $add_i64 () i64 {
   return (
     add i64(dread i64 $g_i64, constval i64 0))}

func $add_u64_u () u64 {
   return (
     add u64(dread u64 $g_u64_u, constval u64 0))}

func $add_u64 () u64 {
   return (
     add u64(dread u64 $g_u64, constval u64 0))}

# # f32
# func $add_f32_u () f32 {
   # return (
     # add f32(dread f32 $g_f32_u, constval f32 0.0f))}

# func $add_f32 () f32 {
   # return (
     # add f32(dread f32 $g_f32, constval f32 0.0f))}

# # f64
# func $add_f64_u () f64 {
   # return (
     # add f64(dread f64 $g_f64_u, constval f64 0))}

# func $add_f64 () f64 {
   # return (
     # add f64(dread f64 $g_f64, constval f64 0))}
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


# Base Parameter Regressor for Robot based on MDH frames
# Einleitung
# Erstellung einer parameterlinearen Regressorform in Newton Euler Bewegungsgleichung
#
# Dateiname:
# robot -> Berechnung für allgemeinen Roboter
# chain -> Berechnung für eine serielle Struktur (nicht: Baumstruktur)
# fixb -> fixed base. Kein Floating base Modell. Dort ist diese Form der Minimalparameterform nicht möglich.
# rotmat -> Kinematik wird mit Rotationsmatrizen berechnet
# NewtonEuler -> Berechnung der Newton Euler Bewegungsgleichung
# regressor -> Regressorform (parameterlinear)
#
# Initialisierung
interface(warnlevel=0): # Unterdrücke die folgende Warnung.
restart: # Gibt eine Warnung, wenn über Terminal-Maple mit read gestartet wird.
interface(warnlevel=3):
interface(rtablesize=100): # Zur Anzeige von größeren Vektoren
;
with(LinearAlgebra):
with(ArrayTools):
with(codegen):
with(CodeGeneration):
with(StringTools):
codegen_act := true:
codegen_opt := 2:
codeexport_grav := true:
codeexport_corvec := true:
codeexport_cormat := true:
codeexport_inertia := true:
codeexport_inertiaD := true:
codeexport_invdyn := true:
codeexport_act:= true:
codegen_dynpar := 2:
read "../helper/proc_convert_s_t":
read "../helper/proc_convert_t_s":
read "../helper/proc_MatlabExport":
read "../helper/proc_simplify2":
read "../robot_codegen_definitions/robot_env":
printf("Generiere Regressorform für %s\n", robot_name, codegen_dynpar):
read sprintf("../codeexport/%s/tmp/tree_floatb_definitions", robot_name, base_method_name):
read sprintf("../codeexport/%s/tmp/kinematic_constraints_maple_inert.m", robot_name):
kin_constraints_exist := kin_constraints_exist: # nur zum Abschätzen der Komplexität
;
# Term-Vereinfachungen einstellen
if not assigned(simplify_options) or simplify_options(10)=-1 then # Standard-Einstellungen:
  if not kin_constraints_exist then # normale serielle Ketten und Baumstrukturen
    use_simplify := 0: # Standardmäßig aus
  else # mit kinematischen Zwangsbedingungen
    use_simplify := 1: # standardmäßig simplify-Befehle anwenden
  end if:
else # Benutzer-Einstellungen:
  use_simplify := simplify_options(10): # zehnter Eintrag ist für Dynamik-Regressor

end if:
# Ergebnisse der Newton Euler- Bewegungsgleichung laden
read sprintf("../codeexport/%s/tmp/invdyn_%s_NewtonEuler_linkframe_par%d_maple.m", robot_name, base_method_name, codegen_dynpar):
f_i_i := f_i_i:
m_i_i := m_i_i:
tau_B := tau_B:
tau_J := tau_J:
# Mit diesem Arbeitsblatt werden die Vorwärtsrekursive für Fixed-Base Modelle generiert. Erkenne welche Basis-Modellierung aktiv ist
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):
end if:
# Die kinetischen und potentiellen Energien aus (2) und (3) stehen ab hier durch T_fixb und U_fixb zur Verfügung.
# Der Parametervektor 'PV2_vec' aus (13) wurde in 'robot_tree_floatb_twist_definitions.mw' aufgestellt.

# Parameterlinearisierung
# Parameterlinearisierung auf Basis von [HRL_IDR] (14) und (15)
# Linearisierung_Gelenkmomente
tauJ_regressor := Matrix(NQJ, 10*(NL-1)):

for i from 1 to NQJ do
  for j from 1 to 10*(NL-1) do
    tauJ_regressor[i,j] :=  diff(tau_J(i,1),PV2_vec[10+j,1]):
  end do:
end do:
# Terme vereinfachen
if use_simplify>=1 then
  tmp_t1:=time():
  tmp_l1 := length(tauJ_regressor):
  tauJ_regressor := simplify2(tauJ_regressor):
  tmp_t2:=time():
  tmp_l2 := length(tauJ_regressor):
  printf("%s: Gelenkmoment-Regressor vereinfacht. Länge: %d->%d. Rechenzeit %1.1fs.\n", \
    FormatTime("%Y-%m-%d %H:%M:%S"), tmp_l1, tmp_l2, tmp_t2-tmp_t1):
end if:

# Linearisierung_Gelenkmomente(base)
#
tauB_regressor := Matrix(6,10*NL):
for i from 1 to 6 do
  for j from 1 to 10*NL do
    tauB_regressor[i,j] := diff(tau_B(i,1),PV2_vec[j,1]):
  end do:
end do:
# Terme vereinfachen
if use_simplify>=1 then
  tmp_t1:=time():
  tmp_l1 := length(tauB_regressor):
  tauB_regressor := simplify2(tauB_regressor):
  tmp_t2:=time():
  tmp_l2 := length(tauB_regressor):
  printf("%s: Basis-Kraft/Moment-Regressor vereinfacht. Länge: %d->%d. Rechenzeit %1.1fs.\n", \
    FormatTime("%Y-%m-%d %H:%M:%S"), tmp_l1, tmp_l2, tmp_t2-tmp_t1):
end if:

# Linearisierung_Schnittmomente
m_regressor := Matrix(3*NL,10*NL):

m_i_i_vec := Matrix(3*(NL),1):
for i from 1 to NL do
  for j from 1 to 3 do
    m_i_i_vec[3*(i-1)+j] := m_i_i[j,i]:
  end do:
end do:

for i from 1 to 3*NL do
  for j from 1 to 10*NL do
    m_regressor[i,j] := diff~(m_i_i_vec(i,1),PV2_vec[j,1]):
  end do:
end do:

# Terme vereinfachen
if use_simplify>=1 then
  tmp_t1:=time():
  tmp_l1 := length(m_regressor):
  m_regressor := simplify2(m_regressor):
  tmp_t2:=time():
  tmp_l2 := length(m_regressor):
  printf("%s: Schnittmoment-Regressor vereinfacht. Länge: %d->%d. Rechenzeit %1.1fs.\n", \
    FormatTime("%Y-%m-%d %H:%M:%S"), tmp_l1, tmp_l2, tmp_t2-tmp_t1):
end if:

# Linearisierung_Schnittkräfte
f_regressor := Matrix(3*NL,10*NL):
f_i_i_vec := Matrix(3*(NL),1):
for i from 1 to NL do
  for j from 1 to 3 do
    f_i_i_vec[3*(i-1)+j] := f_i_i[j,i]:
  end do:
end do:

for i from 1 to 3*NL do
  for j from 1 to 10*NL do
    f_regressor[i,j] := diff~(f_i_i_vec(i,1),PV2_vec[j,1]):
  end do:
end do:
# Terme vereinfachen
if use_simplify>=1 then
  tmp_t1:=time():
  tmp_l1 := length(f_regressor):
  f_regressor := simplify2(f_regressor):
  tmp_t2:=time():
  tmp_l2 := length(f_regressor):
  printf("%s: Schnittkraft-Regressor vereinfacht. Länge: %d->%d. Rechenzeit %1.1fs.\n", \
    FormatTime("%Y-%m-%d %H:%M:%S"), tmp_l1, tmp_l2, tmp_t2-tmp_t1):
end if:

# Export
# Maple Export
save tauJ_regressor, sprintf("../codeexport/%s/tmp/fixb_NewtonEuler_tauJ_regressor_maple.m", robot_name):
save tauB_regressor, sprintf("../codeexport/%s/tmp/fixb_NewtonEuler_tauB_regressor_maple.m", robot_name):
save m_regressor, sprintf("../codeexport/%s/tmp/fixb_NewtonEuler_m_regressor_maple.m", robot_name):
save f_regressor, sprintf("../codeexport/%s/tmp/fixb_NewtonEuler_f_regressor_maple.m", robot_name):
printf("Maple-Ausdrücke exportiert. %s\n", FormatTime("%Y-%m-%d %H:%M:%S")):
# Matlab Export
if codegen_act then
  MatlabExport(convert_t_s(tauJ_regressor), sprintf("../codeexport/%s/tmp/invdyn_%s_NewtonEuler_tauJ_regressor_matlab.m", robot_name, expstring), codegen_opt):
  MatlabExport(convert_t_s(tauB_regressor), sprintf("../codeexport/%s/tmp/invdyn_%s_NewtonEuler_tauB_regressor_matlab.m", robot_name, expstring), codegen_opt):
  MatlabExport(convert_t_s(m_regressor), sprintf("../codeexport/%s/tmp/invdyn_%s_NewtonEuler_m_regressor_matlab.m", robot_name, expstring), codegen_opt):
  MatlabExport(convert_t_s(f_regressor), sprintf("../codeexport/%s/tmp/invdyn_%s_NewtonEuler_f_regressor_matlab.m", robot_name, expstring), codegen_opt):
end if
;


 func $foo (
  var %i i32
#var %i1 i32, var %j1 i32, var %k1 i32
  ) i32 {
   return (
     neg i32(dread i32 %i))}

 func $foo1 (
  var %i i32, var %j i32, var %k i32,
  var %i1 i32, var %j1 i32, var %k1 i32
  ) i32 {
   return (
     neg i32(dread i32 %i))}

 func $foo2 (
  var %i i32, var %j i32, var %k i32
  ) i32 {
   return (
     neg i32(constval i32 0x111111111))}

 func $foo3 (
  var %i i64, var %j i64, var %k i32
  ) i64 {
   return (
     neg i64(dread i64 %i))}

 func $foo5 (
  var %i i64, var %j i64, var %k i32
  ) i64 {
   return (
     neg i64(constval i64 0x11111))}

 func $foo6 (
  var %i f64
  ) f64 {
   return (
     neg f64(dread f64 %i))}

 func $foo7 (
  var %i f32
  ) f32 {
   return (
     neg f32(dread f32 %i))}

 func $foo8 (
  var %i f64
  ) f64 {
   return (
     neg f64(constval f64 -1.24))}

 func $foo9 (
  var %i f32
  ) f32 {
   return (
     neg f32(constval f32 -1.24f))}
# todo float neg
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


LogText:= proc(text, target)
	# must pass text as sprintf(text)!!!
	UpdateLog(text, target);
end proc:

LogExpression:= proc(text, target)
	# must pass text as sprintf("%q\n", text)!!!
	UpdateLog(text, target);
end proc:

#LogTextSIAN := ()->UpdateLog(sprintf(_passed), "LogAreaSIAN");
#LogExpressionSIAN := ()->UpdateLog(sprintf("%q\n", _passed), "SIAN");

#LogTextME := ()->UpdateLog(sprintf(_passed), "LogAreaME");
#LogExpressionME := ()->UpdateLog(sprintf("%q\n", _passed), "LogAreaME");

#LogTextSE := ()->UpdateLog(sprintf(_passed), "LogAreaSE");
#LogExpressionSE := ()->UpdateLog(sprintf("%q\n", _passed), "LogAreaSE");

UpdateLog := proc(s, target)
local logsofar;

	logsofar := DocumentTools:-GetProperty(target, value);
	if logsofar <> "" then
		logsofar := logsofar, "\n";
	end if;

	DocumentTools:-SetProperty(target, value, cat(logsofar,s), 'refresh');

end proc:

examples := table([
  	"Biohydrogenation" = [ "Taken from R. Munoz-Tamayo, L. Puillet, J.B. Daniel, D. Sauvant, O. Martin, M. Taghipoor, P. Blavy\n Review: To be or not to be an identifiable model. Is this a relevant question in animal science modelling?\ndoi.org/10.1017/S1751731117002774\nSystem (3) in Supplementary Material 2, initial conditions are assumed to be unknown",
  	[
  "dx4/dt = - k5 * x4 / (k6 + x4);\n",
  "dx5/dt = k5 * x4 / (k6 + x4) - k7 * x5/(k8 + x5 + x6);\n",
  "dx6/dt = k7 * x5 / (k8 + x5 + x6) - k9 * x6 * (k10 - x6) / k10;\n",
  "dx7/dt = k9 * x6 * (k10 - x6) / k10;\n",
  "y1 = x4;\n",
  "y2 = x5"]],

  	"Chemical Reaction Network" = ["Taken from  Conradi, C., Shiu, A., Dynamics of post-translational modification systems: recent progress and future directions Eq. 3.4",
	[
  "dx1/dt = -k1 * x1 * x2 + k2 * x4 + k4 * x6;\n",
  "dx2/dt = k1 * x1 * x2 + k2 * x4 + k3 * x4;\n",
  "dx3/dt = k3 * x4 + k5 * x6 - k6 * x3 * x5;\n",
  "dx4/dt = k1 * x1 * x2 - k2 * x4 - k3 * x4;\n",
  "dx5/dt = k4 * x6 + k5 * x6 - k6 * x3 * x5;\n",
  "dx6/dt = -k4 * x6 - k5 * x6 + k6 * x3 * x5;\n",
  "y1 = x3;\n"
  "y2 = x2;\n" ]],

	"DAISY Ex. 3" = ["DAISY Example 3", [
  "dx1/dt = -1 * p1 * x1 + p2 * x2 + u(t);\n",
  "dx2/dt = p3 * x1 - p4 * x2 + p5 * x3;\n",
  "dx3/dt = p6 * x1 - p7 * x3;\n",
  "y1 = x1;\n"]],

	"DAISY_mamil3" = ["DAISY mamil 3",
	[
  "dx1/dt = -(a21 + a31 + a01) * x1 + a12 * x2 + a13 * x3 + u(t);\n",
  "dx2/dt = a21 * x1 - a12 * x2;\n",
  "dx3/dt = a31 * x1 - a13 * x3;\n",
  "y = x1"]],

	"DAISY_mamil4" = ["DAISY mamil 4", [
  "dx1/dt = -k01 * x1 + k12 * x2 + k13 * x3 + k14 * x4 - k21 * x1 - k31 * x1 - k41 * x1 + u(t);\n",
  "dx2/dt = -k12 * x2 + k21 * x1;\n",
  "dx3/dt = -k13 * x3 + k31 * x1;\n",
  "dx4/dt = -k14 * x4 + k41 * x1;\n",
  "y = x1"]],

	"HIV" = ["Example (with initial conditions assumed being unknown) from Section IV of 'DAISY: an Efficient Tool to Test Global Identifiability. Some Case Studies' by G. Bellu, M.P. Saccomani",
	[
  "dx1/dt = -b * x1 * x4 - d * x1 + s;\n",
  "dx2/dt = b * q1 * x1 * x4 - k1 * x2 - mu1 * x2;\n",
  "dx3/dt = b * q2 * x1 * x4 + k1 * x2 - mu2 * x3;\n",
  "dx4/dt = -c * x4 + k2 * x3;\n",
  "y1 = x1;\n",
  "y2 = x4"]],

	"HIV2" = ["The system is taken from Wodarz, D., Nowak, M.\nSpecific therapy regimes could lead to long-term immunological control of HIV\nhttps://doi.org/10.1073/pnas.96.25.14464\nPage 1",
	[
  "dx/dt = lm - d * x - beta * x * v;\n",
  "dy/dt = beta * x * v - a * y;\n",
  "dv/dt = k * y - u * v;\n",
  "dw/dt = c * x * y * w - c * q * y * w - b * w;\n",
  "dz/dt = c * q * y * w - h * z;\n",
  "y1 = w;\n",
  "y2 = z"]],

	"Lipolysis" = ["Taken from R. Munoz-Tamayo, L. Puillet, J.B. Daniel, D. Sauvant, O. Martin, M. Taghipoor, P. Blavy\nReview: To be or not to be an identifiable model. Is this a relevant question in animal science modelling?\ndoi.org/10.1017/S1751731117002774\nSystem (1) in Supplementary Material 2, initial conditions are assumed to be unknown\nbrought to the rational function form by introducing new state variable x5 = k1 e^(-k3 t)",
	[
  "dx1/dt = -x1 * x5 / (k2 + x1);\n",
  "dx2/dt = 2 * x1 * x5 / ((k2 + x1) * 3) - k4 * x2;\n",
  "dx3/dt = k4*(x2)/2 - k4*x3;\n",
  "dx4/dt = x1 * x5 / (3 * (k2 + x1)) + k4 * (x2)/2 + k4 * x3;\n",
  "dx5/dt = -k3 * x5;\n",
  "y1 = x1;\n",
  "y2 = x2 + x3;\n",
  "y3 = x4"]],

  	"LV" = ["Lotka-Volterra System",[
  	"dx1/dt = a*x1 - b*x1*x2;\n",
  	"dx2/dt = -c*x2 + d*x1*x2;\n",
  	"y = x1;\n"]],
	"OralGlucose" = ["Example (with initial conditions assumed being unknown) from Section III of 'DAISY: an Efficient Tool to Test Global Identifiability. Some Case Studies'\nby G. Bellu, M.P. Saccomani",
	[
  "dG/dt = -(p1 + X) * G + p1 * Gb + v * R;\n",
  "dX/dt = -p2 * X + p3 * (u(t) - Ib);\n",
  "dR/dt = k;\n",
  "dIb/dt = 0;\n",
  "dGb/dt = 0;\n",
  "y1 = G;\n",
  "y2 = Ib;\n",
  "y3 = Gb;\n"]],

	"SEIR" = ["Taken from N. Tuncer, T. Le\n'Structural and practical identifiability analysis of outbreak models'\nhttps://doi.org/10.1016/j.mbs.2018.02.004\nEquation (2.2) with prevalence observations",
[
  "dS/dt = -b * S * In / N;\n",
  "dE/dt = b * S * In / N - nu * E;\n",
  "dIn/dt = nu * E - a * In;\n",
  "dN/dt = 0;\n",
  "y1 = In;\n",
  "y2 = N;\n"]],

	"SEIR2" = ["Taken from N. Tuncer, T. Le\n'Structural and practical identifiability analysis of outbreak models'\nhttps://doi.org/10.1016/j.mbs.2018.02.004\nEquation (2.2) with cumulative incidence observations",
	[
  "dS/dt = -b * S * In / N;\n",
  "dE/dt = b * S * In / N - nu * E;\n",
  "dIn/dt = nu * E - a * In;\n",
  "dN/dt = 0;\n",
  "dCu/dt = nu * E;\n",
  "y1 = Cu;\n",
  "y2 = N"]],

	"SIR_R0" = ["SIR R0",[
  "dS/dt = -b * In * S;\n",
  "dIn/dt = b * In * S - g * In;\n",
  "dR/dt = g * In;\n",
  "daux/dt = 0;\n",
  "y1 = In;\n",
  "y2 = b / g + aux;"]],

	"SIRSForced" = ["Taken from Capistran M., Moreles M., Lara B.\n'Parameter Estimation of Some Epidemic Models.\n The Case of Recurrent Epidemics Caused by Respiratory Syncytial Virus'\ndoi.org/10.1007/s11538-009-9429-3\nEquations (7)-(11)",
[
  "ds/dt = mu - mu * s - b0 * (1 + b1 * x1) * i * s + g * r;\n",
  "di/dt = b0 * (1 + b1 * x1) * i * s - (nu + mu) * i;\n",
  "dr/dt = nu * i - (mu + g) * r;\n",
  "dx1/dt = -M * x2;\n",
  "dx2/dt = M * x1;\n",
  "y1 = i;\n",
  "y2 = r;\n"]],

	"SlowFast" = ["Taken from Vajda S., Rabitz H.\n'Identifiability and Distinguishability of First-Order Reaction Systems', p. 701\nWe added an extra output x_C",
	[
  "dxA/dt = -k1 * xA;\n",
  "dxB/dt = k1 * xA - k2 * xB;\n",
  "dxC/dt = k2 * xB;\n",
  "deA/dt = 0;\n",
  "deC/dt = 0;\n",
  "y1 = eA * xA + eB * xB + eC * xC;\n",
  "y2 = xC;\n",
  "y3 = eA;\n",
  "y4 = eC"]],

	"Treatment" = ["Taken from N. Tuncer, T. Le\nStructural and practical identifiability analysis of outbreak models'\nhttps://doi.org/10.1016/j.mbs.2018.02.004\nEquation (2.3) with observed treatment",
	[
  "dS/dt = -b * S * In / N - d * b * S * Tr / N;\n",
  "dIn/dt = b * S * In / N + d * b * S * Tr / N - (a + g) * In;\n",
  "dTr/dt = g * In - nu * Tr;\n",
  "dN/dt = 0;\n",
  "y1 = Tr;\n",
  "y2 = N"]],

	"Tumor" = ["Example (with initial conditions assumed being unknown) from Section 3 of\n'Examples of testing global identifiability of biological and biomedical models with the DAISY software'\nby M.P. Saccomani, S. Audoly, G. Bellu, L. D'Angio",
[ "dx1/dt = -(k3 + k7) * x1 + k4 * x2;\n",
  "dx2/dt = k3 * x1 - (k4 + a * k5 + b * d1 * k5) * x2 + k6 * x3 + k6 * x4 + k5 * x2 * x3 + k5 * x2 * x4;\n",
  "dx3/dt = a * k5 * x2 - k6 * x3 - k5 * x2 * x3;\n",
  "dx4/dt = b * d1 * k5 * x2 - k6 * x4 - k5 * x2 * x4;\n",
  "dx5/dt = k7 * x1;\n",
  "da/dt = 0;\n",
  "db/dt = 0;\n",
  "dd1/dt = 0;\n",
  "y1 = x5;\n",
  "y2 = a;\n",
  "y3 = b;\n",
  "y4 = d1;\n"]]
]):

# Setup

timed_SIAN:=proc(sigma, params_to_assess, p, output_targets_sian, count_solutions, char)
	local output, data, start, finish:
	start:= time():
	output := IdentifiabilityODE(sigma, params_to_assess, p, output_targets_sian, count_solutions, char):
	finish:= time():
	DocumentTools:-SetProperty(output_targets_sian[runningtime], value, convert(finish-start, string), 'refresh'): # time
	return  output:
end proc:

timed_Multi:=proc(model, simplified_generators, no_bound, simplify_bound, max_perms, output_targets_multi)
	local start, output, finish, data, bound, generators:
	start:=time():
	bound, generators := op(MultiExperimentIdentifiableFunctions(model, simplified_generators, no_bound, simplify_bound, max_perms, output_targets_multi)):
	finish:=time():
	DocumentTools:-SetProperty(output_targets_multi[runningtime], value, convert(finish-start, string), 'refresh'):
	return [bound, finish-start, generators]: #table([output=bound, runtime=finish-start]):
end proc:

timed_Single:=proc(model, output_targets_single)
	local start, output, finish, data:
	start:=time():
	output := SingleExperimentIdentifiableFunctions(model, output_targets_single):
	finish:=time():
	DocumentTools:-SetProperty(output_targets_single[runningtime], value, convert(finish-start, string), 'refresh'):
	return output:
end proc:

with(StringTools):

sigmaParser := proc(sigma)
	local states, state_eqs, outputs, output_eqs;
	if SearchText("diff", sigma)>0 then
		sigma := [map(x->parse(x), Split(sigma, ";"))]:
	else
		LogExpression(sprintf("%q \n", Split(sigma, ";")), "LogAreaSIAN"):
		sigma := Split(sigma, ";"):

		states := map(x->Trim(RegSubs("d([a-zA-Z0-9]+)/dt(.*)" = "\\1", x)), select(x->SearchText(x, "/dt")>0, sigma)):
		state_eqs := select(x->Has(x, "/dt"), sigma):

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

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

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

		sigma := [op(state_eqs), op(output_eqs)]:
	end if:
	return sigma;
end proc:

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

DocumentTools:-SetProperty("run_system", enabled, true):
DocumentTools:-SetProperty("Meter_sian", visible, true):
DocumentTools:-SetProperty("Meter_sian", value, 0):
DocumentTools:-SetProperty("sigma", enabled, true):
DocumentTools:-SetProperty("p", value, "0.99"):
DocumentTools:-SetProperty("params", value, ""):
DocumentTools:-SetProperty("replicas", value, "1"):

DocumentTools:-SetProperty("p", enabled, true):
DocumentTools:-SetProperty("params", enabled, true):
DocumentTools:-SetProperty("replicas", enabled, true):
DocumentTools:-SetProperty("LogAreaSE", value, ""):
DocumentTools:-SetProperty("LogAreaSIAN", value, ""):
DocumentTools:-SetProperty("LogAreaME", value, ""):

DocumentTools:-SetProperty("printSolutions", enabled, true):
DocumentTools:-SetProperty("printSolutions", value, true):

DocumentTools:-SetProperty("GlobalParams1", expression, NULL):
DocumentTools:-SetProperty("LocalParams1", expression, NULL):
DocumentTools:-SetProperty("NoIDParams1", expression, NULL):

DocumentTools:-SetProperty("Parameters", value, ""):

DocumentTools:-SetProperty("Bound", expression, NULL):
DocumentTools:-SetProperty("MultiFunctions", expression, NULL):
DocumentTools:-SetProperty("SingleFunctions", expression, NULL):

DocumentTools:-SetProperty("use_char", enabled, true):
DocumentTools:-SetProperty("use_char", value, false):
DocumentTools:-SetProperty("p_label", enabled, true):

DocumentTools:-SetProperty("ComputeId", enabled, true):
DocumentTools:-SetProperty("ComputeId", value, false):
DocumentTools:-SetProperty("bypass", enabled, false):

DocumentTools:-SetProperty("bypass", value, true):
DocumentTools:-SetProperty("SimplifiedGen", enabled, false):
DocumentTools:-SetProperty("SimplifiedGen", value, true):
DocumentTools:-SetProperty("SkipSingle", enabled, false):
DocumentTools:-SetProperty("SkipSingle", value, false):
DocumentTools:-SetProperty("Refine", enabled, false):
DocumentTools:-SetProperty("NoBound", enabled, false):
DocumentTools:-SetProperty("NoBound", value, false):
DocumentTools:-SetProperty("UsingUpTo", enabled, false):
DocumentTools:-SetProperty("MaxPermutations", enabled, false):
DocumentTools:-SetProperty("Permutations", enabled, false):
DocumentTools:-SetProperty("RunSIAN", enabled, true):
DocumentTools:-SetProperty("RunSIAN", value, true):
DocumentTools:-SetProperty("being_refined", caption, "");
DocumentTools:-SetProperty("sigma", value, "dx1/dt = a*x1 + x2*b + u(t);\ndx2/dt = x2*c + x1;\ny=x2"):
DocumentTools:-SetProperty("example_box", value, "Custom"):
DocumentTools:-SetProperty(reference, value, ""):
DocumentTools:-SetProperty("LocalLabel" , caption, "Locally Identifiable Paramters");
DocumentTools:-SetProperty(TxtOutput, visible, false);
DocumentTools:-SetProperty(TxtOutput, value, "");
DocumentTools:-SetProperty(SaveOutputLabel, visible, false);

readyToSave:=false:
counter:=0:
exname:="Custom":


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

`is_element/ICP` := (N::posint) -> (A::set) -> proc(Q)
 local i,U,V;

 global reason;

 if not `is_element/ACP`(N)(A)(Q) then
  reason := [convert(procname,string),"Q in ACP(N)(A)",reason];
  return false;
 fi;

 if not `is_separated/preord`(A)(Q[N]) then
  reason := [convert(procname,string),"Q[N] is not separated",Q[N]];
  return false;
 fi;

 return true;
end:

`is_equal/ICP` := (N::posint) -> (A::set) -> proc(Q1,Q2)
 global reason;

 if Q1 <> Q2 then
  reason := [convert(procname,string),"Q1 <> Q2",Q1,Q2];
  return false;
 fi;

 return true;
end:

`is_leq/ICP` := (N::posint) -> (A::set) -> proc(Q1,Q2)
 local i;

 for i from 1 to N do
  if Q2[i] minus Q1[i] <> {} then
   return false;
  fi;
 od;

 return true;
end:

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

`random_element/ICP` := (N::posint) -> (A::set) -> proc()
 local i,j,n,pi,Q,R,S,B,C;

 if nops(A) = 0 then
  return FAIL;
 fi;

 R := `random_element/total_preord`(A)();
 Q := [R];
 for i from 2 to N do
  pi := `block_partition/preord`(A)(R);
  R := {};
  for B in pi do
   if i < N then
    S := `random_element/total_preord`(B)();
   else
    C := `random_element/ord`(B)();
    n := nops(C);
    S := {seq(seq([C[i],C[j]],j=i..n),i=1..n)};
   fi;

   R := R union S;
  od;
  Q := [op(Q),R];
 od;

 return Q;
end:

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

`build/ICP` := (N::posint) -> (A::set) -> proc(Ru)
 local R,u,n,i,j,p,a,b,aa,bb,Q;
 R,u := op(Ru);
 n := nops(A);
 aa := table():
 bb := table():
 for i from 1 to n do
  for p from 1 to N do
   a := i;
   while a > 1 and u[a-1] > p do a := a - 1; od;
   aa[i,p] := a;
   b := i;
   while b < n and u[b] >= p do b := b + 1; od;
   bb[i,p] := b;
  od:
 od:
 Q := [seq(
  {seq(seq([R[i],R[j]],j=aa[i,p]..bb[i,p]),i=1..n)}
 ,p=1..N)];

 return Q;
end:

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

`list_elements/ICP` := (N::posint) -> proc(A::set)
 local U,u,n,i,j,RR,R;

 U := [[]];
 n := nops(A);
 for i from 1 to n-1 do
  U := [seq(seq([op(u),j],j=1..N),u in U)];
 od:

 RR := `list_elements/ord`(A);

 [seq(seq(`build/ICP`(N)(A)([R,u]),u in U),R in RR)];
end:

`count_elements/ICP` := (N::posint) -> (A::set) ->
 nops(A)! * N^(nops(A) - 1);

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

`list_ordered_elements/ICP` := (N::posint) -> proc(A::{set,list})
 local U,u,n,i,j,R,A0;

 U := [[]];
 n := nops(A);
 for i from 1 to n-1 do
  U := [seq(seq([op(u),j],j=1..N),u in U)];
 od:

 R := [op(A)];
 A0 := {op(A)};

 [seq(`build/ICP`(N)(A0)([R,u]),u in U)];
end:

`count_ordered_elements/ICP` := (N::posint) -> (A::set) ->
 N^(nops(A) - 1);

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

# Note that we omit the rank of Q[N], because it is always equal to N here.

`rank_vector/ICP` := (N) -> (A) -> proc(Q)
 local i;
 return [seq(`rank/preord`(A)(Q[i])-1,i=1..N-1)];
end;

`rank/ICP` := (N) -> (A) -> proc(Q)
 return `+`(op(`rank_vector/ICP`(N)(A)(Q)));
end;

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

`phi/SEM/ICP` := (N::posint) -> (A::set) -> proc(eta)
 local A2,a,b,i;

 A2 := {seq(seq([a,b],b in A),a in A)};

 return [seq(select(ab -> `is_preceq/E`(N)(eta[op(ab)],epsilon^i),A2),i=0..N-1)];
end;

`psi/ICP/SEM` := (N::posint) -> (A::set) -> proc(Q)
 local eta,a,b,i;

 eta := table();
 for a in A do
  for b in A do
   if a = b then
    eta[a,b] := 0;
   else
    i := 1;
    while (i < N and member([a,b],Q[i]) and member([b,a],Q[i])) do
     i := i+1;
    od;
    if member([a,b],Q[i]) then
     eta[a,b] :=  epsilon^(i-1);
    else
     eta[a,b] := -epsilon^(i-1);
    fi;
   fi;
  od;
 od;

 return eval(eta);
end:

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

`totalise/ICP/ord` := (N::posint) -> (A::set) -> proc(Q)
 local R,T,r,i,a;

 R := `id/autorel`(A);
 for i from 1 to N do
  R := R union (Q[i] minus `op/autorel`(A)(Q[i]));
 od:

 T := table():
 for a in A do
  r := nops(select(x -> member([x,a],R),A));
  T[r] := a;
 od:

 return [seq(T[i],i=1..nops(A))];
end:

`res/ICP` := (N::posint) -> (A::set,B::set) -> proc(Q)
 local BB;

 BB := `top/autorel`(B);

 return(map(`intersect`,Q,BB));
end;

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

`is_fibre_sphere/ICP` := (N::posint) -> (A::set) -> (a,b,Q) -> proc(P)
 local B,i,U,V,L;

 if not(member(a,A)) then error("a not in A"); fi;
 B := A minus {a};

 if not(`is_equal/ICP`(N)(B)(`res/ICP`(N)(A,B)(P),Q)) then
  return false;
 fi;

 i := 1;
 while i < N and member([a,b],P[i]) and member([b,a],P[i]) do
  i := i+1;
 od;

 U := select(x -> member([x,a],P[i]),B);
 V := select(x -> member([a,x],P[i]),B);

 if U intersect V <> {} then return false; fi;
 if member(b,U) then
  L := select(x -> not(member([x,b],P[i])),U);
  if L <> {} then return false; fi;
 fi;
 if member(b,V) then
  L := select(x -> not(member([b,x],P[i])),V);
  if L <> {} then return false; fi;
 fi;

 return true;
end;

######################################################################
# Each of the subsets S_b(Q) is isomorphic to ICP_N({a,b})

`f/fibre_sphere/ICP` := (N::posint) -> (A::set) -> (a,b,Q) -> proc(R)
 local i,e;

 i := 1;
 while member([a,b],R[i]) and member([b,a],R[i]) do
  i := i+1;
 od;
 if member([a,b],R[i]) then
  e := -1;
 else
  e := +1;
 fi;

 return `f_alt/fibre_sphere/ICP`(N)(A)(a,b,Q)([i,e]);
end:

`f_alt/fibre_sphere/ICP` := (N::posint) -> (A::set) -> (a,b,Q) -> proc(ie)
 local i,e,PT,j,x,L,U;

 i,e := op(ie);

 PT := table();
 for j from 1 to i-1 do
  PT[j] := {[a,a]} union Q[j];
  for x in Q[j] do
   if x[1] = b then PT[j] := {op(PT[j]),[a,x[2]]}; fi;
   if x[2] = b then PT[j] := {op(PT[j]),[x[1],a]}; fi;
  od;
 od;
 PT[i] := Q[i] union {[a,a]};
 L := select(x -> member([x,b],Q[i]),A);
 U := select(x -> member([b,x],Q[i]),A);
 if e = -1 then
  L := L minus U;
 else
  U := U minus L;
 fi;
 PT[i] := PT[i] union {seq([x,a],x in L)}
                union {seq([a,x],x in U)};
 for j from i+1 to N do
  PT[j] := Q[j] union {[a,a]};
 od;

 return [seq(PT[j],j=1..N)];
end:

`g/fibre_sphere/ICP` := (N::posint) -> (A::set) -> (a,b,Q) -> proc(P)
 if not(`is_fibre_sphere/ICP`(N)(A)(a,b,Q)(P)) then
  return FAIL;
 fi;
 return `res/ICP`(N)(A,{a,b})(P);
end:

`g_alt/fibre_sphere/ICP` := (N::posint) -> (A::set) -> (a,b,Q) -> proc(P)
 local R,i,e;

 R := `g/fibre_sphere/ICP`(N)(A)(a,b,Q)(P);
 if R = FAIL then return FAIL; fi;
 i := 1;
 while member([a,b],R[i]) and member([b,a],R[i]) do
  i := i+1;
 od;
 if member([a,b],R[i]) then
  e := -1;
 else
  e := +1;
 fi;
 return [i,e];
end:

######################################################################
# This function provides a point of intesection between
# S_b(Q) and S_b1(Q), where b1 is the successor of b in the total
# order induced by Q.

`m/fibre_sphere/ICP` := (N::posint) -> (A::set) -> proc(a,b,Q)
 local B,L,n,r,b1,i,R;

 B := A minus {a};
 L := `totalise/ICP/ord`(N)(B)(Q);
 n := nops(B);
 r := table();
 for i from 1 to n do
  r[L[i]] := i;
 od;
 if not(r[b] < n) then
  return FAIL;
 fi;
 b1 := L[r[b]+1];
 i := 0;
 while i < N and member([b1,b],Q[i+1]) do
  i := i+1;
 od;
 R := [{[a,a],[a,b],[b,a],[b,b]}$i,
       {[a,a],[b,a],[b,b]},
       {[a,a],[b,b]}$(N-i-1)];
 return `f/fibre_sphere/ICP`(N)(A)(a,b,Q)(R);
end:

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

`bump/ICP` := (N::posint) -> (A::set) -> proc(Q)
 local r,n,i,j,R,E,Q1;

 r := `rank_vector/ICP`(N)(A)(Q);
 n := nops(A);
 i := N-1;
 while i > 0 and r[i] = n-1 do
  i := i - 1;
 od;
 if i = 0 then
  return FAIL;
 fi;
 R := `bump/striped_preord`(A)(Q[i]);
 E := R intersect `op/autorel`(A)(R);
 Q1 := [seq(Q[j],j=1..i-1),
        R,
        seq(Q[j] intersect E,j=i+1..N)];
 return Q1;
end:

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

`describe/ICP` := eval(`describe/ACP`):


Foo:=module()
    export fun1,fun2;
    `fun1`:=proc()
        fun11:=proc()

        end proc:
        return fun11;
    end proc:
    fun2:=proc()
        return module()
        end module:
    end proc:
end module:

A[B]:=proc()

end proc:

A[1]:=proc()

end proc:

A["fadfa"]:=proc()

end proc:

:-C[D]:=proc()

end proc:

:-U['V']:=proc()

end proc:

A:-B:-C:=proc()

end proc:

U[V][W]:=proc()
    fadfa:=proc()

    end proc:

end proc:

jkladfjakdflkja:=proc()

end proc:

(*
    OptMethods.mpl
*)

# Maple 符号线性规划
Opt[SLP]:=proc(A,b)
    uses LinearAlgebra;
    local E,x,FF,AA,BB,m,n;
    n:=RowDimension(A);
    m:=ColumnDimension(A);
    E:=IdentityMatrix(n);
    FF:=Vector([[0$m][],[1$n][]]);
    AA:=<<A|-E>,<-A|-E>>;
    BB:=convert(<b,-b>,Vector);
    x:=Opt[Simplex](FF,AA,BB);
    x:=x[1..m];
    return x;
end proc:

# Maple 单纯形法矩阵接口
# min f*x
# A*x<=b
Opt[Simplex]:=proc(f,A,b)
    uses LinearAlgebra;
    local m,n,v,V,x,AA,CC;
    m:=RowDimension(A);
    n:=ColumnDimension(A);
    V:=Vector([seq(v[k],k=1..n)]);
    AA:=A.V;
    CC:=map(k->(AA[k]<=b[k]),{seq(1..m)});
    x:=simplex[minimize](f^%T.V,CC,UNRESTRICTED);
    x:=map(k->rhs(k),[x[]]);
    return Vector(x);
end proc:

# Maple 进行整数线性规划
Opt[NILP]:=proc(A,b)
    uses LinearAlgebra,Optimization;
    local E,x,FF,AA,BB,m,n;
    n:=RowDimension(A);
    m:=ColumnDimension(A);
    E:=IdentityMatrix(n);
    FF:=Vector([[0$m][],[1$n][]]);
    AA:=<<A|-E>,<-A|-E>>;
    # 根据帮助文档的说法，sparse 矩阵更快
    # 实际上并不是 -_-||
    # AA:=Matrix(AA,storage=sparse);
    BB:=convert(<b,-b>,Vector);
    x:=LPSolve(FF,[AA,BB],integervariables=[seq(1..m)]);
    x:=map(round,x[2][1..m]);
    return x;
end proc:

# Matlab 整数线性规划
# 调用代价约为 0.02 秒
Opt[MatlabILP]:=proc(A,b)
    uses Matlab;
    local x;
    setvar("A",A);
    setvar("b",b);
    # 直接运行具体代码，避免产生路径问题
    evalM("[n,m]=size(A);E=eye(n);AA=[A,-E;-A,-E];BB=[b;-b];f=[zeros(m,1);ones(n,1)];x=intlinprog(f,1:m,AA,BB,[],[],[],[],optimoptions('intlinprog','Display','off'));x=x(1:m);");
    x:=getvar("x");
    if type(x,float) then
        x:=Vector([round(x)]);
    else
        x:=map(round,x);
    end if;
    return x;
end proc:

# Mathematica 符号线性规划
# 调用代价约为 0.7 秒
Opt[mmaSLP]:=proc(A,b)
    uses LinearAlgebra;
    local E,x,FF,AA,BB,m,n;
    n:=RowDimension(A);
    m:=ColumnDimension(A);
    E:=IdentityMatrix(n);
    FF:=Vector([[0$m][],[1$n][]]);
    AA:=<<A|-E>,<-A|-E>>;
    BB:=convert(<b,-b>,Vector);
    x:=Opt[mmaLP](FF,-AA,-BB);
    x:=x[1..m];
    return x;
end proc:

Opt[mmaLP]:=proc(f,A,b)
    uses FileTools;
    local cmd,fd,r;
    cmd:=sprintf("Print[LinearProgramming[%s,%s,%s,-Infinity,Method->\"Simplex\"]];",
        mmaVec(f),mmaMat(A),mmaVec(b));
    fd:=Text[Open]("LP.wl",create,overwrite);
    Text[WriteString](fd,cmd);
    Text[Close](fd);
    r:=ssystem("wolframscript -file LP.wl")[2];
    try
        r:=parse(cat("[",r[2..-2],"]"));
    catch :
        error r;
    finally
        Remove("LP.wl");
    end try;
    return Vector(r);# end proc
end proc:# proc

(*
mmaVec:=proc(x)
    uses StringTools;
    local k,n,buffer,fmt;
    n:=numelems(x);
    buffer:=StringBuffer();
    buffer:-clear();
    buffer:-append("{");
    for k from 1 to n do
        buffer:-append(sprintf("%d",x[k]));
        if k<n then
            buffer:-append(",");
        end if;
    end do;
    buffer:-append("}");
    return buffer:-value('clear');
end proc:
*)

# mmaMat:=proc(A)
#     uses LinearAlgebra,StringTools;
#     local k,m,buffer;
#     m:=RowDimension(A);
#     buffer:=StringBuffer();
#     buffer:-clear();
#     buffer:-append("{");
#     for k from 1 to m do
#         buffer:-append(mmaVec(A[k]));
#         if k<m then
#             buffer:-append(",");
#         end if;
#     end do;
#     buffer:-append("}");
#     return buffer:-value('clear');
# end proc:

printf("\d \d \" fadfa hahah:=proc()end proc \" \"\"\n");
printf("hahah:=proc()end proc\n");

fadsfasdf:=proc()
    return proc()

    end proc
end proc:

fadf:=proc()
    fadsfafadfasd:=module()
    end:
end:

gjhdg:=module()

end: