# Number of subspaces of dimension d in F^n, if |F|=q

grassmann_count := (q::posint) -> proc(n,d)
 local i;
 return mul(q^(n-i)-1,i=0..d-1)/mul(q^(d-i)-1,i=0..d-1);
end:

# Number of splittings of F^(n+m) as a sum of subspaces of
# dimensions n and m, if |F| = q.

splitting_count := (q::posint) -> (n,m) ->
 grassman_count(q)(n+m,n) * q^(n*m);

# tanabe_N(p,n,r)(k) is the number of irreducible F-linear representations
# of Z_p^n that have dimension p^k over F.

tanabe_N := (p,n,r) -> (k) -> `if`(k = 0,p^(n*r),(p^n-1) * p^((n-1)*k + n*(r-1)));

# The socle of K^0(BGL_{p^k}(F)) is generated by
# euler(V)^{N-1}, where N = tanabe_N_bar(n,v,k)

tanabe_N_bar := (p,n,r) -> proc(k)
 local j;
 p^(n*r) + (p^n-1)*p^(n*(r-1))*sum(p^((n-1)*j),j=1..k);
end:

tanabe_N_star := (p,n,r) -> proc(k)
 local j;
 p^(n*r-1) * (p-1) * sum(p^((n-1)*j),j=0..k-1);
end:

tanabe_N_lim := (p,n,r) -> (k) -> p^(n*r+n*k-k) * (1-p^(-n))/(1-p^(1-n));

# The natural numbers can be partitioned as the disjoint union of
# the sets tanabe_NN(p,n,r)(k), of size tanabe_N(p,n,r)(k).

tanabe_NN := (p,n,r) -> proc(k::nonnegint)
 local i;
 if k = 0 then
  return [seq(i,i=0..tanabe_N_bar(p,n,r)(0)-1)];
 else
  return [seq(i,i=tanabe_N_bar(p,n,r)(k-1)..tanabe_N_bar(p,n,r)(k)-1)];
 fi;
end:

# tanabe_s(p,n,r)(m) is the unique k such that m lies in tanabe_NN(p,n,r)(k).
tanabe_s := (p,n,r) -> proc(m)
 local k;
 k := 0;
 while m >= tanabe_N_bar(p,n,r)(k) do
  k := k+1;
 od;
 return k;
end:

# tanabe_X(p,n,r)(k) is the set of generators for E^0(BGL_*(F)) in
# degree p^k.

tanabe_X := (p,n,r) -> proc(k)
 local j;
 return [seq(c[p^k] ^ j, j = 0..tanabe_N(p,n,r)(k)-1)];
end:

# tanabe_prim_gen(p,n,r)(k) is a generator for the primitives
# in K^0(BGL_*(F)) in degree p^k
tanabe_prim_gen := (p,n,r) -> (k) -> c[p^k] ^ tanabe_N_bar(p,n,r)(k-1);

# tanabe_soc_gen(p,n,r)(k) is a generator for the socle of
# K^0(BGL_{p^k}(F))
tanabe_soc_gen  := (p,n,r) -> (k) -> c[p^k] ^ (tanabe_N_bar(p,n,r)(k) - 1);

# tanabe_m(p)(k) has p-adic valuation k and divides
# tanabe_m(p)(k+1).  Moreover, any positive integer n divides
# tanabe_m(p)(k) when k is sufficiently large.

tanabe_m := (p) -> proc(k)
  local m,i;
  m := 1;
  i := 1;
  while ithprime(i) <= p + k do
    m := m * ithprime(i) ^ k;
    i := i + 1;
  od:
  return m;
end:

check_tanabe_m := proc(p,k)
  _ASSERT(padic_val(tanabe_m(p)(k),p) = k,
          "v_p(m[k])");

  _ASSERT(type(tanabe_m(p)(k+1)/tanabe_m(p)(k),posint),
          "m[k] divides m[k+1]");
end:

# Given a polynomial f over the integers and a prime q, return
# the first irreducible factor of f mod q, in the standard
# Maple order.

first_factor := proc(f,q)
 local F;
 F := :-Factor(f) mod q;
 if type(F,`*`) then F := [op(F)] else F := [F]; fi:
 F := sort(map(g -> `if`(type(g,`^`),op(1,g),g),F));
 return F[1];
end:

# Return an irreducible polynomial f[k](x) of degree v0 * p^k over
# Z/q0.  This gives a field F(k) of degree p^k over F = F(0),
# where F(0) has order q = q0 ^ v0.  The polynomials are arranged
# so that the canonical primitive element x[k] in F(k) generates
# the group of units, and there is an inclusion F(k) -> F(k+1)
# sending x[k] to x[k+1] ^ m, where m = |F(k+1)^x|/|F(k)^x|.
tanabe_FF_poly := (q0,v0,p) -> proc(k::nonnegint)
 option remember;
 local q,m,f;

 q := q0 ^ v0;
 if k = 0 then
  f := NumberTheory[CyclotomicPolynomial](q0 ^ v0 - 1,x);
 else
  m := (q ^ (p ^ k) - 1)/(q ^ (p ^ (k - 1)) - 1);
  f := subs(x = x ^ m, tanabe_FF_poly(q0,v0,p)(k - 1));
 end:

 return first_factor(f,q0);
end:

# tanabe_F(q0,v0)(m) is the field denoted by F[m] in the paper,
# where q = q0 ^ v0 with q0 prime and v0 > 0.
# tanabe_FF(q0,v0)(p,k) is F(k) = F[p^k].

tanabe_F := (q0,v0) -> (m) -> GF(q0,v0 * m);
tanabe_FF := (q0,v0) -> (p,k) -> GF(q0,v0 * p ^ k,tanabe_FF_poly);

# Orders of various groups: G is the general linear group,
# N is the subgroup of monomial matrices, H is the block
# diagonal subgroup of p' index as in prop-non-p-power.

tanabe_G_order := (q) -> proc(d)
 local k;
 return mul(q ^ d - q ^ k,k = 0..d-1);
end:

tanabe_N_order := (q) -> (d) -> d! * (q - 1)^d;

tanabe_H_order := (q,p) -> proc(d)
 local dd,m,i;
 dd := digit_list(d,p);
 m := nops(dd);
 mul(tanabe_G_order(q)(p ^ i) ^ dd[i+1], i = 0..m-1);
end:

# The E^2 page of the AHSS converging to K_*(BV) has a trigrading
# with E^2_{ijk} = H_i(BV_k;K_j).  It has even generators
# b[i] and u, and odd generators e[i] with
#   |b[i]| = tanabe_b_trideg(p,n,r)(i) = [2i,0,1]
#   |e[i]| = tanabe_e_trideg(p,n,r)(i) = [2i+1,0,1]
#   |u|    = tanabe_u_trideg(p,n,r)    = [0,2,0].

tanabe_b_trideg  := (p,n,r) -> (i) -> [2*i,0,1];
tanabe_e_trideg  := (p,n,r) -> (i) -> [2*i+1,0,1];
tanabe_u_trideg  := (p,n,r) -> [0,2,0];

# The only nontrivial differentials have the form d_r, where
# r = tanabe_AHSS_page(p,n,r)(k) for some k >= 0
# [From now on we refer to this as the k'th differential,
#  and the page on which it occurs as the k'th page.]

tanabe_AHSS_page := (p,n,r) -> (k) -> 2*p^(n*(r+k)) - 1;

# Tridegree of the k'th differential
tanabe_AHSS_d_trideg := (p,n,r) -> (k) ->
 [1-2*p^(n*(r+k)),2*p^(n*(r+k))-2,0];

# The k'th page can be described in terms of generators
# bb[m,i] and ee[m,i]

tanabe_bb_defined := (p,n,r) -> (k) -> (m,i) ->
  m >= min(k,tanabe_s(p,n,r)(i));

tanabe_bb_indec := (p,n,r) -> (k) -> (m,i) ->
  m = min(k,tanabe_s(p,n,r)(i));

tanabe_ee_defined := (p,n,r) -> (k) -> (m,i) ->
  m = k and i >= tanabe_N_star(p,n,r)(k);

tanabe_bb_trideg := (p,n,r) -> (m,i) -> [2*p^m*i,0,p^m];
tanabe_ee_trideg := (p,n,r) -> (m,i) -> [2*p^m*i + 1,0,p^m];

tanabe_dbb0 := (p,n,r) -> (k) -> (m,i) ->
  ee[k,i - tanabe_N_bar(p,n,r)(k) + tanabe_N_star(p,n,r)(k)] *
    u ^ (p^(n * (k + r)) - 1);

tanabe_dbb := (p,n,r) -> (k) -> (m,i) ->
  `if`(m < k, 0, `if`(i < tanabe_N_bar(p,n,r)(k), 0, tanabe_dbb0(p,n,r)(k)(m,i)));

# This is the part of the inverse Poincare series contributed by
# irreducible representations of dimension at most p^k.

tanabe_inverse_poincare_series := (p,n,r) -> proc(k)
 local j;
 (1-t)^(p^(n*r)) * mul((1 - t^(p^j))^(p^(n*(r+j))*(1-1/p^n)),j=1..k);
end:

tanabe_poincare_series := (p,n,r) -> (k) ->
 convert(series(1/tanabe_inverse_poincare_series(p,n,r)(k),t=0,p^k+1),
         polynom,t);

tanabe_trideg := (p,n,r) -> proc(x)
 local d,d0,y;

 if type(x,indexed) then
  if op(0,x) = b then
   return tanabe_b_trideg(p,n,r)(op(x));
  elif op(0,x) = e then
   return tanabe_e_trideg(p,n,r)(op(x));
  elif op(0,x) = bb then
   return tanabe_bb_trideg(p,n,r)(op(x));
  elif op(0,x) = ee then
   return tanabe_ee_trideg(p,n,r)(op(x));
  else
   return [0,0,0];
  fi;
 elif x = u then
  return tanabe_u_trideg(p,n,r);
 elif type(x,`+`) then
  d := map(tanabe_trideg(p,n,r),{op(x)});
  if nops(d) = 1 then
   return op(d);
  else
   return FAIL;
  fi;
 elif type(x,`*`) then
  d := [0,0,0];
  for y in [op(x)] do
   d0 := tanabe_trideg(p,n,r)(y);
   if d0 = FAIL then return FAIL; fi;
   d := d +~ d0;
  od;
  return d;
 elif type(x,`^`) then
  return tanabe_trideg(p,n,r)(op(1,x)) *~ op(2,x);
 else
  return [0,0,0];
 fi;
end:

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

# Check v_p(q ^ j - 1) = r + v_p(j)
check_lem_vp := (p) -> proc(q::posint,j::posint)
 local r;
 r := padic_val(q - 1,p);
 _ASSERT(r > 0, "r > 0");

 _ASSERT(padic_val(q ^ j - 1,p) = r + padic_val(j,p),
         sprintf("v_{%d}(%d ^ %d - 1)",p,q,j));
end;

check_tanabe_numbers := proc()
 local n,r,k,p,L,N,N_bar,N_star,N_lim,P,err;

 assume(n::posint);
 assume(r::posint);
 assume(k::posint);
 assume(p::posint);

 N      := tanabe_N(p,n,r);
 N_bar  := tanabe_N_bar(p,n,r);
 N_star := tanabe_N_star(p,n,r);
 N_lim  := tanabe_N_lim(p,n,r);

 _ASSERT(
  simplify(N_bar(k) - N_bar(k-1) - N(k)) = 0,
  "N_bar(k) - N_bar(k-1) = N(k)"
 );

 _ASSERT(
  simplify(N_star(k) - (N_bar(k) - p^(n*k + n*r - k))) = 0,
  "N_star(k) = N_bar(k) - p^(n*k + n*r - k)"
 );

 _ASSERT(
  simplify(p^k * (N_bar(k) - N_star(k)) - p^(n * (k + r))) = 0,
  "p^k * (N_bar(k) - N_star(k)) = p^(n * (k + r))"
 );

 _ASSERT(
  simplify(p^(k + 1) * (N_bar(k) - N_star(k + 1)) - p^(n * (k + r))) = 0,
  "p^(k + 1) * (N_bar(k) - N_star(k + 1)) = p^(n * (k + r))"
 );

 _ASSERT(
  simplify(N(0) + sum(p^j * N(j),j=1..k) - p^(n*(r+k))) = 0,
  "sum(p^j * N(j),j=0..k) = p^(n*(r+k))"
 );

 _ASSERT(
  simplify((1 - p^(-k)) * N(0) +
           sum(expand((1 - p^(j - k)) * N(j)),j=1..k) - N_star(k)) = 0,
  "sum((1 - p^(j-k)) * N(j),j=0..k) = N_star(k)"
 );

 _ASSERT(
  simplify(p^(k + 1) * N_star(k + 1) - p^k * N_star(k) - (p - 1) * p^k * N_bar(k)) = 0,
  "p^(k + 1) * N_star(k + 1) = p^k * N_star(k) + (p - 1) * p^k * N_bar(k)"
 );

 _ASSERT(
  simplify(factor(N_bar(k) - (N_star(k)*(p^n-1)/(p-1) + p^(n*r)))) = 0,
  "N_bar(k) = N_star(k)*(p^n-1)/(p-1) + p^(n*r)"
 );

 _ASSERT(
  simplify(sum(p^j*(p-1)*N_bar(j),j=0..k-1) - p^k*N_bar(k) + p^(n*(r+k))) = 0,
  "sum(p^j*(p-1)*N_bar(j),j=0..k-1)"
 );

 _ASSERT(
  limit(simplify(N_bar(k)/N_lim(k)-1),k=infinity) = 0,
  "N_bar(k) is asymptotic to N_lim(k)"
 );
end:

check_factorial_congruences := proc()
 local p,i;
 p := ithprime(20);

 _ASSERT(
  {seq(modp((-1)^i * (i - 1)! * (p - i)!,p),i=1..p-1)} = {1},
  "(-1)^i * (i - 1)! * (p - i)! = 1 mod p"
 );

 _ASSERT(
  {seq(mods((-1)^i * binomial(p-1,i-1),p),i=1..p-1)} = {-1},
  "(-1)^i * binomial(p-1,i-1) = -1 mod p"
 );
end:

check_valuations := proc()
 local q0,v0,q,p,r,d,m;
 q0 := 19;
 v0 := 1;
 q  := q0 ^ v0;
 p  := 3;
 r  := padic_val(q - 1, p);
 d  := 20;

 _ASSERT(
  padic_val(tanabe_G_order(q)(d),p) - (d * r + (d - digit_sum(d,p))/(p - 1)) = 0,
  "valuation of |G(d)|"
 );

 m := tanabe_G_order(q)(d) / tanabe_N_order(q)(d):
 _ASSERT(type(m,posint) and padic_val(m,p) = 0,
  "N(d) has p' index in G(d)"
 );

 m := tanabe_G_order(q)(d) / tanabe_H_order(q,p)(d):
 _ASSERT(type(m,posint) and padic_val(m,p) = 0,
  "H(d) has p' index in G(d)"
 );

end:

check_diff_trideg := proc()
 local p,n,r,k,m,i,err,d0,d1,d2;

 d0 := tanabe_bb_trideg(p,n,r)(k,i);
 d1 := tanabe_AHSS_d_trideg(p,n,r)(k);
 d2 := tanabe_trideg(p,n,r)(tanabe_dbb0(p,n,r)(k)(m,i));

 err := simplify(d0 + d1 - d2, symbolic);

 _ASSERT(err = [0,0,0], "differential respects tridegrees");
end:


with(Groebner):
with(PolynomialIdeals):

J := PolynomialIdeal({2*f1*f2*f3*f4*f5 - 9823275,
5*f1*f2*f3*f4 + 24/5*f1*f2*f3*f5 + 21/5*f1*f2*f4*f5 + 16/5*f1*f3*f4*f5 + 9/5*f2*f3*f4*f5 - 4465125,
4*f1*f2*f3 + 6*f1*f2*f4 + 18/5*f1*f2*f5 + 6*f1*f3*f4 + 24/5*f1*f3*f5 + 14/5*f1*f4*f5 + 4*f2*f3*f4 + 18/5*f2*f3*f5 + 14/5*f2*f4*f5 + 8/5*f3*f4*f5 - 441486,
3*f1*f2 + 4*f1*f3 + 4*f1*f4 + 12/5*f1*f5 + 3*f2*f3 + 4*f2*f4 + 12/5*f2*f5 + 3*f3*f4 + 12/5*f3*f5 + 7/5*f4*f5 - 15498,
2*f1 + 2*f2 + 2*f3 + 2*f4 + 6/5*f5 - 215,
f1 + 2*f2 + 3*f3 + 4*f4 + 5*f5 + 6*t}):
st := time[real]():
Basis(J, tdeg(f1,f2,f3,f4,f5,t), characteristic=2^31-1):
time[real]() - st;

J := PolynomialIdeal({2*f1*f2*f3*f4*f5*f6 - 1404728325,
6*f1*f2*f3*f4*f5 + 35/6*f1*f2*f3*f4*f6 + 16/3*f1*f2*f3*f5*f6 + 9/2*f1*f2*f4*f5*f6 + 10/3*f1*f3*f4*f5*f6 + 11/6*f2*f3*f4*f5*f6 - 648336150,
5*f1*f2*f3*f4 + 8*f1*f2*f3*f5 + 14/3*f1*f2*f3*f6 + 9*f1*f2*f4*f5 + 7*f1*f2*f4*f6 + 4*f1*f2*f5*f6 + 8*f1*f3*f4*f5 + 7*f1*f3*f4*f6 + 16/3*f1*f3*f5*f6 + 3*f1*f4*f5*f6 + 5*f2*f3*f4*f5 + 14/3*f2*f3*f4*f6 + 4*f2*f3*f5*f6 + 3*f2*f4*f5*f6 +
5/3*f3*f4*f5*f6 - 67597623,
4*f1*f2*f3 + 6*f1*f2*f4 + 6*f1*f2*f5 + 7/2*f1*f2*f6 + 6*f1*f3*f4 + 8*f1*f3*f5 + 14/3*f1*f3*f6 + 6*f1*f4*f5 + 14/3*f1*f4*f6 + 8/3*f1*f5*f6 + 4*f2*f3*f4 + 6*f2*f3*f5 + 7/2*f2*f3*f6 + 6*f2*f4*f5 + 14/3*f2*f4*f6 + 8/3*f2*f5*f6 + 4*f3*f4*f5 + 7/2*f3*f4*f6 + 8/3*f3*f5*f6 +
3/2*f4*f5*f6 - 2657700,
3*f1*f2 + 4*f1*f3 + 4*f1*f4 + 4*f1*f5 + 7/3*f1*f6 + 3*f2*f3 + 4*f2*f4 + 4*f2*f5 + 7/3*f2*f6 + 3*f3*f4 + 4*f3*f5 + 7/3*f3*f6 + 3*f4*f5 + 7/3*f4*f6 + 4/3*f5*f6 - 46243,
2*f1 + 2*f2 + 2*f3 + 2*f4 + 2*f5 + 7/6*f6 - 358}):
st := time[real]():
Basis(J, tdeg(f1,f2,f3,f4,f5,f6), characteristic=2^31-1):
time[real]() - st;

J := PolynomialIdeal({2*f1*f2*f3*f4*f5*f6*f7 - 273922023375, 7*f1*f2*f3*f4*f5*f6 + 48/7*f1*f2*f3*f4*f5*f7 + 45/7*f1*f2*f3*f4*f6*f7 + 40/7*f1*f2*f3*f5*f6*f7 + 33/7*f1*f2*f4*f5*f6*f7 + 24/7*f1*f3*f4*f5*f6*f7 + 13/7*f2*f3*f4*f5*f6*f7 - 127830277575,
6*f1*f2*f3*f4*f5 + 10*f1*f2*f3*f4*f6 + 40/7*f1*f2*f3*f4*f7 + 12*f1*f2*f3*f5*f6 + 64/7*f1*f2*f3*f5*f7 + 36/7*f1*f2*f3*f6*f7 + 12*f1*f2*f4*f5*f6 + 72/7*f1*f2*f4*f5*f7 + 54/7*f1*f2*f4*f6*f7 + 30/7*f1*f2*f5*f6*f7 + 10*f1*f3*f4*f5*f6 + 64/7*f1*f3*f4*f5*f7 + 54/7*f1*f3*f4*f6*f7 + 40/7*f1*f3*f5*f6*f7 + 22/7f1*f4*f5*f6*f7 + 6*f2*f3*f4*f5*f6 + 40/7*f2*f3*f4*f5*f7 + 36/7*f2*f3*f4*f6*f7 + 30/7*f2*f3*f5*f6*f7 + 22/7*f2*f4*f5*f6*f7 + 12/7*f3*f4*f5*f6*f7 - 13829872635,
5*f1*f2*f3*f4 + 8*f1*f2*f3*f5 + 8*f1*f2*f3*f6 + 32/7*f1*f2*f3*f7 + 9*f1*f2*f4*f5 + 12*f1*f2*f4*f6 + 48/7*f1*f2*f4*f7 + 9*f1*f2*f5*f6 + 48/7*f1*f2*f5*f7 + 27/7*f1*f2*f6*f7 + 8*f1*f3*f4*f5 + 12*f1*f3*f4*f6 +
48/7*f1*f3*f4*f7 + 12*f1*f3*f5*f6 + 64/7*f1*f3*f5*f7 + 36/7*f1*f3*f6*f7 + 8*f1*f4*f5*f6 + 48/7*f1*f4*f5*f7 + 36/7*f1*f4*f6*f7 + 20/7*f1*f5*f6*f7 + 5*f2*f3*f4*f5 + 8*f2*f3*f4*f6 + 32/7*f2*f3*f4*f7 + 9*f2*f3*f5*f6 + 48/7*f2*f3*f5*f7 + 27/7*f2*f3*f6*f7 + 8*f2*f4*f5*f6 + 48/7*f2*f4*f5*f7 + 36/7*f2*f4*f6*f7 + 20/7*f2*f5*f6*f7 + 5*f3*f4*f5*f6 + 32/7*f3*f4*f5*f7 + 27/7*f3*f4*f6*f7 + 20/7*f3*f5*f6*f7 + 11/7*f4*f5*f6*f7 - 585849123,
4*f1*f2*f3 + 6*f1*f2*f4 + 6*f1*f2*f5 + 6*f1*f2*f6 + 24/7*f1*f2*f7 + 6*f1*f3*f4 + 8*f1*f3*f5 + 8*f1*f3*f6 + 32/7*f1*f3*f7 + 6*f1*f4*f5 + 8*f1*f4*f6 + 32/7*f1*f4*f7 + 6*f1*f5*f6 + 32/7*f1*f5*f7 + 18/7*f1*f6*f7 + 4*f2*f3*f4 + 6*f2*f3*f5 + 6*f2*f3*f6 + 24/7*f2*f3*f7 + 6*f2*f4*f5 + 8*f2*f4*f6 + 32/7*f2*f4*f7 + 6*f2*f5*f6 + 32/7*f2*f5*f7 + 18/7*f2*f6*f7 + 4*f3*f4*f5 + 6*f3*f4*f6 + 24/7*f3*f4*f7 + 6*f3*f5*f6 + 32/7*f3*f5*f7 + 18/7*f3*f6*f7 + 4*f4*f5*f6 + 24/7*f4*f5*f7 + 18/7*f4*f6*f7 + 10/7*f5*f6*f7 - 11675085,
3*f1*f2 + 4*f1*f3 + 4*f1*f4 + 4*f1*f5 + 4*f1*f6 + 16/7*f1*f7 + 3*f2*f3 + 4*f2*f4 + 4*f2*f5 + 4*f2*f6 + 16/7*f2*f7 + 3*f3*f4 + 4*f3*f5 + 4*f3*f6 + 16/7*f3*f7 + 3*f4*f5 + 4*f4*f6 + 16/7*f4*f7 + 3*f5*f6 + 16/7*f5*f7 + 9/7*f6*f7 - 116053,
2*f1 + 2*f2 + 2*f3 + 2*f4 + 2*f5 + 2*f6 + 8/7*f7 - 553}):
st := time[real]():
Basis(J, tdeg(f1,f2,f3,f4,f5,f6,f7), characteristic=2^31-1):
time[real]() - st;


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

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

(* type: mgga_exc *)

(* replace: "mbrxc_x\(" -> "xc_mgga_x_mbrxc_get_x(" *)

mbrxc_a1 := 0.074746:
mbrxc_a2 := 0.147:
mbrxc_a3 := 0.0032:

(* This is the derivative of f = (1+x)^(5/3)*exp(-2/3*x)/(x - 3) = (32*Pi)^(2/3)/(6*Q) *)
mbrxc_aux_dfdx := x -> -2/3 * (1 + x)^(2/3) * exp(-2*x/3) * (x^2 - 3*x + 6) / (x - 3)^2:

`diff/mbrxc_x` := proc(Q, g)
  - (32*Pi)^(2/3)/6 * diff(Q, g)/(Q^2 * mbrxc_aux_dfdx(mbrxc_x(Q)))
end proc:

mbrxc_Q := (x, t) ->
        mbrxc_a1*(2*t) - K_FACTOR_C + mbrxc_a2*x^2 + mbrxc_a3*x^4:

mbrxc_min_Q := 5.0e-13:
mbrxc_cQ := Q -> my_piecewise3(abs(Q) < mbrxc_min_Q,
  my_piecewise3(Q > 0, mbrxc_min_Q, -mbrxc_min_Q), Q):

mbrxc_v := x ->
  - (32*Pi)^(1/3)/(8*X_FACTOR_C) * exp(x/3)*(8 - exp(-x)*(x^2 + 5*x + 8))/(x*(1 + x)^(1/3)):

mbrxc_f := (x, u, t) ->
  - mbrxc_v(mbrxc_x(mbrxc_cQ(mbrxc_Q(x, t))))/2:

f := (rs, z, xt, xs0, xs1, u0, u1, t0, t1) ->
  mgga_exchange(mbrxc_f, rs, z, xs0, xs1, u0, u1, t0, t1):


# Berechne kinematische Zwangsbedingungen für den Palettierroboter KUKA KR700PA aus 2 Viergelenkketten
# Einleitung
# Die kinematischen Zwangsbedingungen werden als Ersatzungsausdruck für die abhängigen Winkel aufgestellt.
#
# palh3m1TE->KUKA KR700PA, modellierung der Zwangsbedingungen mit Ausdrücken für trigonometrische Elimination
# kinematic_constraint->Kinematische Zwangsbedingungen
# Datenblatt des Roboters:
# unter :   https://www.kuka.com/en-de/products/robot-systems/industrial-robots/kr-700-pa
# Voraussetzung(sehr wichtig!!!!!):
# Viergelenkkette muss mit der Toolbox berechnet worden sein (Arbeitsblatt "fourbar1TE_kinematic_constrains.mv")
# Quelle:
# SA Shan: Shan2019_S828, "Reduktion der Modellkomplexität von seriell-hybriden Palettierrobotern"
# Autor:
# Weipu Shan
# Studienarbeit bei: Moritz Schappler, moritz.schappler@imes.uni-hannover.de, 2018-08
# (C) Institut fuer mechatronische Systeme, Leibniz Universitaet Hannover
# Initialisierung
# Import (Library)
interface(warnlevel=0): 		# Unterdrücke die folgende Warnung.
restart: 				# Gibt eine Warnung, wenn über Terminal-Maple mit read gestartet wird.
interface(warnlevel=3):
kin_constraints_exist := true:               # für Speicherung
;
with(StringTools):                                  # für Zeitausgabe
with(LinearAlgebra):
with(codegen):
with(CodeGeneration):
#with(ListTools):
codegen_act := true:
codegen_opt := 1:      # Geringerer Optimierungsgrad. Sonst zu lange.
codegen_debug := 0:    # Zur Code-Generierung auch für Nicht-Inert Ausdrücke
;
# Import(hybriddyn)
read "../helper/proc_MatlabExport":    #Matlab Export
read "../transformation/proc_rotx":      #Rotation um X
read "../transformation/proc_roty":      #Rotation um Y
read "../transformation/proc_rotz":      #Rotation um Z
read "../helper/proc_convert_s_t":        #zeitabhängige Variable für Ableitung
read "../helper/proc_convert_t_s":        #konstante Variable
read "../robot_codegen_constraints/proc_subs_kintmp_exp": #substitute Spalte 1 mit Spalte 2
with (RealDomain):            # Schränkt alle Funktionen auf den reellen Bereich ein. Muss nach Definition von MatlabExport kommen. Sonst geht dieses nicht.
;
read "../robot_codegen_definitions/robot_env":                                                      #aktuelle Roboter, MDH-Tabelle
read sprintf("../codeexport/%s/tmp/tree_floatb_definitions",robot_name):
# Variable Initialisierung
# Variable mit Winkeln der Nebenstruktur nur in Abhängigkeit der verallgemeinerten Koordinaten  (Nur Aktive Gelenke)
kintmp_qs := Matrix(RowDimension(kintmp_s),1):       	#kintmp_s von aktuellen Roboter, MDH
;
#
# Konstante Winkel bereits hineinschreiben (Passive Gelenk)
for i from 1 to RowDimension(kintmp_s) do
	if diff(kintmp_s(i,1),t) = 0 then
		#konstante Variable, passive Winkel von aktuellem Roboter, MDH
		kimtmp_qs(i,1) := kintmp_s(i,1):
  	end if:
end do
;
#
# Variable definieren für die Hilfswinkel
# Ersetzungsausdrücke definieren
# Speichere Sinus und Cosinus der Winkel direkt ab, da diese in den Rotationsmatrizen direkt auftreten.
# Spalte 1: Zusuchender Ausdruck (sin oder cos eines Winkels)	#第一列是要找到的三角函数表达
# Spalte 2: Einzusetzender Ausdruck			#第二列是代替的表达
# Dadurch werden arctan-Ausdrücke in der direkten Kinematik reduziert.
# Ähnliches Vorgehen wie in [1].
#
# #新建kintmp_subsexp 12X2, 第一列被动轴是sin cos 形式，第二列初始化和第一列相同，当前机器人的sin cos
kintmp_subsexp := Matrix(2*RowDimension(kintmp_s),2):
for i from 1 to RowDimension(kintmp_s) do 			#kintmp_s von aktuellen Roboter
	kintmp_subsexp(2*i-1,1) := sin(kintmp_s(i,1)):
	kintmp_subsexp(2*i,  1) := cos(kintmp_s(i,1)):
	# Initialisierung der rechten Spalte mit gleichen Werten. Später nur Ersetzung, wenn Vorteilhaft.
	kintmp_subsexp(2*i-1,2) := kintmp_subsexp(2*i-1, 1):
	kintmp_subsexp(2*i,  2) := kintmp_subsexp(2*i,   1):
end do:
#
# Sicherung der aktuelle Daten
backup_kintmp_qs := kintmp_qs:		#Backup von aktuellem Roboter, konstante Variable
backup_kintmp_qt := kintmp_qt:		#Backup von aktuellem Roboter, zeitabhängige Variable
backup_kintmp_subsexp := kintmp_subsexp:   	#Backup von aktuellem Roboter, sin, cos von 4 Winkeln

;
# Daten von Fourbar übernehmen
read sprintf("../codeexport/fourbar1TE/tmp/kinematic_constraints_maple_inert.m"):
# Winkeln von Fourbar会先覆盖原先的变量 kintmp_subsexp, kintmp_qs, kintmp_qt,所以一开始需要备份

;
# Speichern WInkeln von Fourbar, mit Fourbar Variable
kintmp_subsexp_fourbar := kintmp_subsexp:  	#sin,cos von 4 Winkeln, Fourbar
kintmp_qs_fourbar := kintmp_qs:		#konstante Variable, Fourbar
kintmp_qt_fourbar := kintmp_qt:		#zeitabhängige Variable, Fourbar
;
#
# 以下内容有疑问 Was ist der Sinn darunten
#kintmp_subsexp_fourbar:
#winkel(6,2):
#kintmp_subsexp_fourbar(6,2):
#kintmp_subsexp_fourbar(3,3):
#winkel_neu := Matrix(6,2):
winkel_neu(1,2) := subs({qJ1s=phi_s}, kintmp_subsexp_fourbar(3,2)):
winkel_neu(2,2) := subs({qJ1s=phi_s}, kintmp_subsexp_fourbar(4,2)):
winkel_neu(3,2) := subs({qJ1s=phi_s}, kintmp_subsexp_fourbar(1,2)):
winkel_neu(4,2) := subs({qJ1s=phi_s}, kintmp_subsexp_fourbar(2,2)):
winkel_neu(5,2) := subs({qJ1s=phi_s}, kintmp_subsexp_fourbar(5,2)):
winkel_neu(6,2) := subs({qJ1s=phi_s}, kintmp_subsexp_fourbar(6,2)):
#
# Vorherige Werte für dieses System wieder herstellen
kintmp_qs := backup_kintmp_qs:		#aktuellem Roboter, konstante Variable
kintmp_qt := backup_kintmp_qt:		#aktuellem Roboter, zeitabhängige Variable
kintmp_subsexp := backup_kintmp_subsexp:		#aktuellem Roboter, sin, cos von 4 Winkeln

;
winkel_neu(1..6,1);
# Viergelenkkette 1: A-B-C-D
# Von ABCD: eta1, eta3, eta4  -----> Von Fourbar: rho, eta, xi
winkel1 := <<sin_eta1|sin(eta1_s)>;<cos_eta1|cos(eta1_s)>;<sin_eta3|sin(eta3_s)>;<cos_eta3|cos(eta3_s)>;<sin_eta4|sin(eta4_s)>;<cos_eta4|cos(eta4_s)>>:
# Ausdrücke von Fourbar in aktuellem Roboter mitbringen
for i from 1 to 6 do
	winkel1(i,2) := kintmp_subsexp_fourbar(i,2):       		#Subsexpress von Fourbar übernehmen
	cos_phi_s := sin(qJ2s)*sin(phi2) - cos(qJ2s)*cos(phi2):	#phi_s ist unabhängige Winkel von VGK, hier ist phi_s = eta2_s
	sin_phi_s := sin(qJ2s)*cos(phi2) + cos(qJ2s)*sin(phi2):	#qJ2s ist echte aktive Winkel von Roboter, eta2 ^= phi = Pi - qJ2 - phi2
	winkel1(i,2) := subs({sin(qJ1s)=sin_phi_s},winkel1(i,2)):
	winkel1(i,2) := subs({cos(qJ1s)=cos_phi_s},winkel1(i,2)):
	winkel1(i,2) := subs({l1=AB}, winkel1(i,2)):
	winkel1(i,2) := subs({l2=DA}, winkel1(i,2)):
	winkel1(i,2) := subs({l3=DC}, winkel1(i,2)):
	winkel1(i,2) := subs({l4=BC}, winkel1(i,2)):
end do:
winkel1(1..6,1):
# eta1, eta3, eta4 wird wie rho, eta, xi in Fourbar darstellen
sin_eta1_s := winkel1(1,2):	#eta1 = qJ2s = rho
;
cos_eta1_s := winkel1(2,2):
sin_eta3_s := winkel1(3,2):	#eta3 = qJ3s = eta
;
cos_eta3_s := winkel1(4,2):
sin_eta4_s := winkel1(5,2):	#eta4 = qJ4s = xi
;
cos_eta4_s := winkel1(6,2):
# eta16, eta79, eta27, abhängige Winkeln von aktuellem Roboter
cos_eta16_s := cos_eta1_s*cos(phi1) + sin_eta1_s*sin(phi1):	#eta16 = eta1 - phi1
;
sin_eta16_s := sin_eta1_s*cos(phi1) - cos_eta1_s*sin(phi1):
cos_eta79_s := - cos_eta4_s:				#eta79 = Pi-eta4
;
sin_eta79_s := sin_eta4_s:
cos_eta27_s := cos_eta3_s*cos(phi79) + sin_eta3_s*sin(phi79):	#eta27 = eta3 - phi79
;
sin_eta27_s := sin_eta3_s*cos(phi79) - cos_eta3_s*sin(phi79):
# Viergelenkkette 2: B-E-F-G
winkel2 := <<sin_xi1|sin(xi1_s)>;<cos_xi1|cos(xi1_s)>;<sin_xi3|sin(xi3_s)>;<cos_xi3|cos(xi3_s)>;
<sin_xi4|sin(xi4_s)>;<cos_xi4|cos(xi4_s)>>:
# Ausdrücke von Fourbar in aktuellem Roboter mitbringen
for i from 1 to 6 do
	winkel2(i,2) := kintmp_subsexp_fourbar(i,2):       			#Subsexpress von Fourbar übernehmen
	#phi_s ist unabhängige Winkel von VGK, hier ist phi_s = xi2_s
	#qJ3s ist echte aktive Winkel von Roboter, xi2 ^= phi = Pi - qJ3 - (phi78-eta27)
	cos_phi_s := -cos(phi78+phi79)*(cos_eta3_s*cos(qJ3s)+sin_eta3_s*sin(qJ3s))-sin(phi78+phi79)*(sin_eta3_s*cos(qJ3s)-cos_eta3_s*sin(qJ3s)):
	sin_phi_s := sin(phi78+phi79)*(cos_eta3_s*cos(qJ3s)+sin_eta3_s*sin(qJ3s))-cos(phi78+phi79)*(sin_eta3_s*cos(qJ3s)-cos_eta3_s*sin(qJ3s)):
	#
	winkel2(i,2) := subs({sin(qJ1s)=sin_phi_s},winkel2(i,2)):
	winkel2(i,2) := subs({cos(qJ1s)=cos_phi_s},winkel2(i,2)):
	winkel2(i,2) := subs({l1=BG}, winkel2(i,2)):
	winkel2(i,2) := subs({l2=BE}, winkel2(i,2)):
	winkel2(i,2) := subs({l3=EP}, winkel2(i,2)):
	winkel2(i,2) := subs({l4=GP}, winkel2(i,2)):
end do:
winkel2(1..6,1):
# xi1, xi3, xi4 wird wie rho, eta, xi in Fourbar darstellen
sin_xi1_s := winkel2(1,2):	#xi1 = qJ2s = rho
;
cos_xi1_s := winkel2(2,2):
sin_xi3_s := winkel2(3,2):	#xi3 = qJ3s = eta
;
cos_xi3_s := winkel2(4,2):
sin_xi4_s := winkel2(5,2):	#xi4 = qJ4s = xi
;
cos_xi4_s := winkel2(6,2):
# xi78, xi34, xi410, abhängige Winkeln von aktuellem Roboter
cos_xi78_s := cos_xi1_s:				#xi78 = xi1
;
sin_xi78_s := sin_xi1_s:
cos_xi34_s := cos_xi3_s*cos(phi410) + sin_xi3_s*sin(phi410):	#xi34 = xi3 - phi410
;
sin_xi34_s := sin_xi3_s*cos(phi410) - cos_xi3_s*sin(phi410):
cos_xi410_s := -cos_xi4_s:				#xi410 = Pi - xi4
;
sin_xi410_s := sin_xi4_s:
# Kintmp_subsexp
kintmp_subsexp(1, 2) := sin_xi34_s:
kintmp_subsexp(2, 2) := cos_xi34_s:
kintmp_subsexp(3, 2) := sin_eta16_s:
kintmp_subsexp(4, 2) := cos_eta16_s:
kintmp_subsexp(5, 2) := sin_eta27_s:
kintmp_subsexp(6, 2) := cos_eta27_s:
kintmp_subsexp(7, 2) := sin_xi78_s:
kintmp_subsexp(8, 2) := cos_xi78_s:
kintmp_subsexp(9, 2) := sin_eta79_s:
kintmp_subsexp(10, 2) := cos_eta79_s:
kintmp_subsexp(11, 2) := sin_xi410_s:
kintmp_subsexp(12, 2) := cos_xi410_s:
kintmp_subsexp:

# Kintmp_qs
kintmp_qs(1,1) := %arctan(sin_xi34_s,cos_xi34_s):
kintmp_qs(2,1) := %arctan(sin_eta16_s,cos_eta16_s):
kintmp_qs(3,1) := %arctan(sin_eta27_s,cos_eta27_s):
kintmp_qs(4,1) := %arctan(sin_xi78_s,cos_xi78_s):
kintmp_qs(5,1) := %arctan(sin_eta79_s,cos_eta79_s):
kintmp_qs(6,1) := %arctan(sin_xi410_s,cos_xi410_s):

kintmp_subsexp:
# Export
winkel := <<sin_xi34|sin_xi34_s>; <cos_xi34|cos_xi34_s>; <sin_eta16 | sin_eta16_s>; <cos_eta16 | cos_eta16_s>;<sin_eta27 | sin_eta27_s>; <cos_eta27 | cos_eta27_s>;<sin_xi78|sin_xi78_s>;<cos_xi78|cos_xi78_s>;<sin_eta79|sin_eta79_s>;<cos_eta79|cos_eta79_s>;<sin_xi410|sin_xi410_s>;<cos_xi410|cos_xi410_s>>:
save winkel, sprintf("../codeexport/palh3m1TE/tmp/kinematic_constraints_maple_inert"):

kintmp_qt := convert_s_t(kintmp_qs):
save kintmp_subsexp, sprintf("../codeexport/%s/tmp/kinematic_constraints_kintmp_subsexp_maple", robot_name)
;
save kintmp_subsexp, sprintf("../codeexport/%s/tmp/kinematic_constraints_kintmp_subsexp_maple.m", robot_name)
;
#printf("Ausdrücke für kintmp_subsexp gespeichert (Maple). %s. CPU-Zeit bis hier: %1.2fs.\n", FormatTime("%Y-%m-%d %H:%M:%S"), time()-st):
for i from 1 to RowDimension(kintmp_s) do
  tmp := kintmp_qs(i):
  save tmp, sprintf("../codeexport/%s/tmp/kinematic_constraints_maple_inert_kintmpq_%d",robot_name, i):
  save tmp, sprintf("../codeexport/%s/tmp/kinematic_constraints_maple_inert_kintmpq_%d.m", robot_name, i):
end do:
save kin_constraints_exist, kintmp_qs, kintmp_qt,kintmp_subsexp, sprintf("../codeexport/%s/tmp/kinematic_constraints_maple_inert" ,robot_name):
save kin_constraints_exist, kintmp_qs, kintmp_qt, kintmp_subsexp, sprintf("../codeexport/%s/tmp/kinematic_constraints_maple_inert.m", robot_name):
save kintmp_qs, sprintf("../codeexport/%s/tmp/kinematic_constraints_kintmp_qs_maple_inert", robot_name):
#printf("Ausdrücke mit Inert-Arctan exportiert (Matlab). %s. CPU-Zeit bis hier: %1.2fs.\n", FormatTime("%Y-%m-%d %H:%M:%S"), time()-st):
# Liste mit abhängigen konstanten Kinematikparametern erstellen (wichtig für Matlab-Funktionsgenerierung)
read "../helper/proc_list_constant_expressions";
interface(rtablesize=20):
kc_symbols := Matrix(list_constant_expressions( kintmp_subsexp ));
#kc_symbols :=Transpose(kc_symbols);
save kc_symbols, sprintf("../codeexport/%s/tmp/kinematic_constraints_symbols_list_maple", robot_name):
kc_symbols:
MatlabExport(kc_symbols, sprintf("../codeexport/%s/tmp/kinematic_constraints_symbols_list_matlab.m",robot_name),2);
#printf("Fertig. %s. CPU-Zeit bis hier: %1.2fs. \n", FormatTime("%Y-%m-%d %H:%M:%S"), time() - st):


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

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

(* type: gga_exc *)
(* prefix:
  gga_x_hjs_params *params;

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

hjs_AA :=  0.757211:
hjs_BB := -0.106364:
hjs_CC := -0.118649:
hjs_DD :=  0.609650:

hjs_fH := s -> add(params_a_a[i]*s^(1+i), i=1..6)/(1 + add(params_a_b[i]*s^i, i=1..9)):

(* The m_max functions are necessary as in some cases the arguments of the
   sqrt become negative *)
hjs_zeta   := s -> m_max(s^2*hjs_fH(s), 1e-10):
hjs_eta    := s -> m_max(hjs_AA + hjs_zeta(s), 1e-10):
hjs_lambda := s -> hjs_DD + hjs_zeta(s):
hjs_chi    := (rs, z, s) -> nu(rs, z)/sqrt(hjs_lambda(s) + nu(rs, z)^2):

hjs_fF := (rs, z, s) ->
  1 - s^2/(27*hjs_CC*(1 + s^2/4)) - hjs_zeta(s)/(2*hjs_CC):

hjs_fG := (rs, z, s) ->
  - 2/5  * hjs_CC*hjs_fF(rs, z, s)*hjs_lambda(s)
  - 4/15 * hjs_BB*hjs_lambda(s)^2
  - 6/5  * hjs_AA*hjs_lambda(s)^3
  - hjs_lambda(s)^(7/2)*(4/5*sqrt(Pi) + 12/5*(sqrt(hjs_zeta(s)) - sqrt(hjs_eta(s)))):

hjs_f1 := (rs, z, s) ->
   + hjs_AA
   - 4/9 * hjs_BB*(1 - hjs_chi(rs, z, s))/hjs_lambda(s)
   - 2/9 * hjs_CC*hjs_fF(rs, z, s)*(2 - 3*hjs_chi(rs, z, s) + hjs_chi(rs, z, s)^3)/hjs_lambda(s)^2
   - 1/9 * hjs_fG(rs, z, s)*(8 - 15*hjs_chi(rs, z, s) + 10*hjs_chi(rs, z, s)^3 - 3*hjs_chi(rs, z, s)^5)/hjs_lambda(s)^3
   + 2*nu(rs, z)*(sqrt(hjs_zeta(s) + nu(rs, z)^2) -  sqrt(hjs_eta(s) + nu(rs, z)^2))
   + 2*hjs_zeta(s)*log((nu(rs, z) + sqrt(hjs_zeta(s) + nu(rs, z)^2))/(nu(rs, z) + sqrt(hjs_lambda(s) + nu(rs, z)^2)))
   - 2*hjs_eta(s)*log((nu(rs, z) + sqrt(hjs_eta(s) + nu(rs, z)^2))/(nu(rs, z) + sqrt(hjs_lambda(s) + nu(rs, z)^2))):

hjs_fx := (rs, z, x) -> hjs_f1(rs, z, X2S*x):

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


var X : int := 4 + (6 * 2);
print X;
print "\n";


(*
 Copyright (C) 2017 M.A.L. Marques
               2019 Susi Lehtola

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

(* type: gga_exc *)
(* prefix:
  gga_c_optc_params *params;

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

$include "gga_c_pw91.mpl"

optc_f2 := (rs, z, xt, xs0, xs1) ->
  + f_pw91(rs*(2/(1 + z))^(1/3),  1, xs0, xs0, 0)*opz_pow_n( z,1)/2
  + f_pw91(rs*(2/(1 - z))^(1/3), -1, xs1, 0, xs1)*opz_pow_n(-z,1)/2:

f  := (rs, z, xt, xs0, xs1) ->
  + params_a_c1*f_pw91(rs, z, xt, xs0, xs1) + (params_a_c2 - params_a_c1)*optc_f2(rs, z, xt, xs0, xs1):


# This is supposed to be a toy 2D model for issues that arise in
# computational geometry for computer aided design.
# We work everywhere in the real projective plane, and consider
# only straight lines and conic curves and segments thereof.
# This is supposed to make everything nicely computable.

dp3 := proc(x,y) local i; add(x[i]*y[i],i=1..3); end;
nm3 := proc(x) local i; sqrt(add(x[i]^2,i=1..3)); end;
xp3 := (u,v) -> [u[2]*v[3]-u[3]*v[2],
                 u[3]*v[1]-u[1]*v[3],
                 u[1]*v[2]-u[2]*v[1]];
tp3 := (u,v,w) -> Determinant(Matrix([u,v,w]));
eq3 := (u,v) -> evalb(xp3(u,v) = [0$3]);
sp3 := (u) -> [u[1]/u[3],u[2]/u[3]];

`plane_stereo/RP` := (x) -> [x[1]/x[3],x[2]/x[3]];
`plane_unstereo/RP` := (u) -> [u[1],u[2],1];

`disc_stereo/RP` := (x) -> [x[1],x[2]] *~ (signum(x[3])/nm3(x));

`disc_unstereo/RP` := (u) ->
  [u[1],u[2],sqrt(1-u[1]^2-u[2]^2)];

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

`is_element/RP_points` := proc(x)
 type(x,[numeric,numeric,numeric]);
end:

`is_leq/RP_points` := NULL:
`list_elements/RP_points` := NULL:
`count_elements/RP_points` := NULL:

`random_element/RP_points` := () -> `random_element/R`(3)();

`dist/RP_points` := proc(x,y)
 local i;
 1 - add(x[i]*y[i],i=1..3)^2/add(x[i]^2,i=1..3)
end:

`is_equal/RP_points` := (x,y) -> evalb(xp3(x,y) = [0$3]);

`in_general_position/RP_points` :=
 (u,v,w) -> evalb(Determinant(Matrix([u,v,w])) = 0);

`disc_plot/point` := (x) -> point(`disc_stereo/RP`(x),args[2..-1]);

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

`is_element/RP_lines` := proc(x)
 type(x,[numeric,numeric,numeric]);
end:

`is_leq/RP_lines` := NULL:
`list_elements/RP_lines` := NULL:
`count_elements/RP_lines` := NULL:

`random_element/RP_lines` := () -> `random_element/R`(3)();

`dist/RP_lines` := proc(x,y)
 local i;
 1 - add(x[i]*y[i],i=1..3)^2/add(x[i]^2,i=1..3)
end:

`is_equal/RP_lines` := (x,y) -> evalb(xp3(x,y) = [0$3]);

`in_general_position/RP_lines` :=
 (u,v,w) -> evalb(Determinant(Matrix([u,v,w])) = 0);

`track/RP_lines` := proc(x,t)
 local u,v;
 u,v := op(NullSpace(Matrix(x)));
 return (1-t) *~ u +~ t *~ v;
end:

`disc_plot/line` := proc(x)
 local u,v,w,p,t,t0,R;
 u,v := op(NullSpace(Matrix(x)));
 w := cos(Pi*t) *~ u +~ sin(Pi*t) *~ v;
 t0 := fsolve(w[3]);
 if evalf(subs(t = t0,diff(w[3],t))) > 0 then
  R := (t0 + 0.0001) .. (t0 + 0.9999);
 else
  R := (t0 - 0.9999) .. (t0 - 0.0001);
 fi;
 p := simplify(`disc_stereo/RP`(w));
 plot([op(p),t=R],args[2..-1]);
end:

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

`is_incident/RP` := proc(x,y) local i; evalb(add(x[i]*y[i],i=1..3) = 0); end;

`point_join/RP` := (x,y) -> xp3(x,y);

`line_meet/RP`  := (x,y) -> xp3(x,y);

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

`is_element/RP_conics` := proc(q)
 local c;
 if not(type(q,[numeric$6])) then
  return false;
 fi;

 # We now need to check whether the associated quadratic form
 # has one negative and two positive eigenvalues.  This works
 # out as follows.

 c := [-q[1]-q[2]-q[3],
       (q[1]*q[2]+q[2]*q[3]+q[3]*q[1]) - (q[4]^2+q[5]^2+q[6]^2)/4,
       (q[1]*q[4]^2+q[2]*q[5]^2+q[3]*q[6]^2-q[4]*q[5]*q[6])/4
         - q[1]*q[2]*q[3]
      ];

 if c[3] > 0 and (c[1] <= 0 or c[2] <= 0) then
  return true;
 fi;

 return false;
end:

`is_leq/RP_conics` := NULL:
`list_elements/RP_conics` := NULL:
`count_elements/RP_conics` := NULL:

`random_element/RP_conics` := proc()
 local q;

 q := `random_element/R`(6)();
 while not(`is_element/RP_conics`(q)) do
  q := `random_element/R`(6)();
 od:

 return q;
end:

`dist/RP_conics` := proc(q,r)
 local i,j;
 sqrt(add(add((q[i]*r[j]-q[j]*r[i])^2,j=i+1..6),i=1..6)/
      (add(q[i]^2,i=1..6) * add(r[i]^2,i=1..6)));
end:

`is_equal/RP_conics` := proc(q,r)
 evalb(`dist/RP_conics`(q,r) = 0);
end:

`conic_matrix/RP` := (q) ->
  <<q[1]|q[6]/2|q[5]/2>,<q[6]/2|q[2]|q[4]/2>,<q[5]/2|q[4]/2|q[3]>>;

`conic_unmatrix/RP` := (Q) ->
 [Q[1,1],Q[2,2],Q[3,3],2*Q[2,3],2*Q[3,1],2*Q[1,2]];

`conic_eval/RP` := (q) -> (x) ->
 q[1]*x[1]^2 + q[2]*x[2]^2 + q[3]*x[3]^2 +
 q[4]*x[2]*x[3] + q[5]*x[3]*x[1] + q[6]*x[1]*x[2];

`conic_bilin/RP` := (q) -> (x,y) ->
 (`conic_eval/RP`(q)(x +~ y) - `conic_eval/RP`(q)(x -~ y))/4;

`conic_coeffs/RP` := (qx,x) -> [
 coeff(qx,x[1],2),
 coeff(qx,x[2],2),
 coeff(qx,x[3],2),
 coeff(coeff(qx,x[2],1),x[3],1),
 coeff(coeff(qx,x[3],1),x[1],1),
 coeff(coeff(qx,x[1],1),x[2],1)
];

`disc_implicitplot/conic` := proc(q)
 local u,v,qq;

 qq := numer(simplify(`conic_eval/RP`(q)(`disc_unstereo/RP`([u,v]))));
 implicitplot(qq,u=-1.1..1.1,v=-1.1..1.1,args[2..-1]);
end:

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

`is_element/RP_arcs` := proc(xxc)
 if not(type(xxc,[[numeric$3]$3])) then
  return false;
 fi;

 if Determinant(Matrix(xxc)) = 0 then return false; fi;

 return true;
end:

`random_element/RP_arcs` := proc()
 local xxc,i,j;
 xxc := [[0$3]$3];

 while Determinant(Matrix(xxc)) = 0 do
  xxc := [seq([seq(rand(-10..10)(),i=1..3)],j=1..3)];
 od;

 return xxc;
end:

`ratio/RP_arcs` := proc(xxc1,xxc2)
 local u,v,w,i;

 u := [seq(dp3(xxc1[i],xxc2[i]),i=1..3)];
 v := [seq(dp3(xxc1[i],xxc1[i]),i=1..3)];
 w := [seq(dp3(xxc2[i],xxc2[i]),i=1..3)];

 if (u *~ u = v *~ w) then
  return u /~ w;
 else
  return NULL;
 fi;
end:

`is_equal/RP_arcs` := proc(xxc1,xxc2)
 local r;
 r := `ratio/RP_arcs`(xxc1,xxc2);

 if r = NULL then return false; fi;
 if r[1] <> r[2] or r[2] <> r[3] then
  return false;
 fi;

 return true;
end:

`is_similar/RP_arcs` := proc(xxc1,xxc2)
 local r;
 r := `ratio/RP_arcs`(xxc1,xxc2);

 if r = NULL then return false; fi;
 if r[1]*r[2] - r[3]^2 <> 0 then
  return false;
 fi;

 return true;
end:

`is_leq/RP_arcs` := NULL:
`list_elements/RP_arcs` := NULL:
`count_elements/RP_arcs` := NULL:

`arc_eval/RP` := (xxc) -> (t) ->
 (1-t)^2 *~ xxc[1] +~ t^2 *~ xxc[2] +~ (t*(1-t)) *~ xxc[3];

`conic_arc_eval/RP` := (q,xxc) -> (t) ->
 `conic_eval/RP`(q)(`arc_eval/RP`(xxc)(t));

`conic_contains_point/RP` := proc(q,x)
 local err;
 err := abs(`conic_eval/RP`(q)(x));
 return evalb(err = 0);
end:

`conic_contains_arc/RP` := proc(q,xxc)
 local t,err;
 err := max(map(abs,[coeffs(expand(`conic_arc_eval/RP`(q,xxc)(t)),t)]));
 return evalb(err = 0);
end:

`normalise_similar/RP_arcs` := proc(xxc)
 local x,c,n;
 x[1] := xxc[1];
 x[2] := xxc[2];
 c := xxc[3];
 n[1] := nm3(x[1]);
 n[2] := nm3(x[2]);
 return [x[1]/~n[1],x[2]/~n[2],c/~sqrt(n[1]*n[2])];
end:

`arc_coeffs/RP` := proc(st,t)
 local su,u;
 su := factor((1+u)^2 *~ subs(t=u/(1+u),st));
 [map(coeff,su,u,0),
  map(coeff,su,u,2),
  map(coeff,su,u,1)];
end:

`arc_from_tangents/RP` := proc(x1,x2,u1,u2)
 local m1,m2,n,c;
 m1 := Determinant(Matrix([x1,x2,u2]));
 m2 := Determinant(Matrix([x1,x2,u1]));
 n := - Determinant(Matrix([x1,u1,u2])) * m2/m1;
 c := n *~ x2 +~ m2 *~ u2;
 return [m1 *~ x1,m2 *~ x2,n *~ c];
end:

`arc_inv/RP` := (xxc) -> proc(y)
 local u1,u2,u3;
 u1 := Determinant(Matrix(x1,x2,y));
 u2 := Determinant(Matrix(x2,c ,y));
 u3 := Determinant(Matrix(c ,x1,y));
 return u2/(u1+u2); # or u1/(u1+u3);
end:

`conic_from_arc/RP` := proc(xxc)
 local x1,x2,c,M;
 x1,x2,c := op(xxc);

 M := Matrix(
  [[x1[1]^2, x1[2]^2, x1[3]^2,
     x1[2]*x1[3], x1[1]*x1[3], x1[1]*x1[2]],
   [x2[1]^2, x2[2]^2, x2[3]^2,
     x2[2]*x2[3], x2[1]*x2[3], x2[1]*x2[2]],
   [2*c[1]*x1[1], 2*c[2]*x1[2], 2*c[3]*x1[3], c[2]*x1[3]+c[3]*x1[2],
     c[1]*x1[3]+c[3]*x1[1], c[1]*x1[2]+c[2]*x1[1]],
   [2*c[1]*x2[1], 2*c[2]*x2[2], 2*c[3]*x2[3], c[2]*x2[3]+c[3]*x2[2],
     c[1]*x2[3]+c[3]*x2[1], c[1]*x2[2]+c[2]*x2[1]],
   [c[1]^2+2*x1[1]*x2[1], c[2]^2+2*x1[2]*x2[2], c[3]^2+2*x1[3]*x2[3],
     c[2]*c[3]+x1[2]*x2[3]+x1[3]*x2[2],
      c[1]*c[3]+x1[1]*x2[3]+x1[3]*x2[1],
       c[1]*c[2]+x1[1]*x2[2]+x1[2]*x2[1]]]
 );
 return NullSpace(M)[1];
end:

`arc_from_rational_conic/RP` := proc(q)
 local x,y,z,f,sol,u0,u1,u2,u,t,Z;
 if not(type(q,[rational$6])) then
  return NULL;
 fi;

 f := `conic_eval/RP`(q)([x,y,z]);
 sol := isolve(f);
 if sol = NULL then return NULL; fi;

 u0 := subs(sol,[x,y,z]);
 u1 := eval(subs(igcd = (() -> 1),u0));
 u2 := u1;
 for Z in indets(u1) do
  if degree(u1[1],Z) = 1 then u2 := subs(Z = 1,u2); fi;
 od:
 u := subs({indets(u2)[1] = t,indets(u2)[2] = 1-t},u2);
 return `arc_coeffs/RP`(u,t);
end:

`arc_from_conic_eigenvalues/RP` := proc(q)
 local Q,E,V,i,v,xxc;
 Q := evalf(Matrix(`conic_matrix/RP`(q),shape=symmetric));
 E,V := Eigenvectors(Q);
 for i from 1 to 3 do
  v[i] := convert(Column(V,i)/sqrt(abs(E[i])),list);
 od;
 xxc := [(v[1] +~ v[2])/~2,(v[1] -~ v[2])/~2,v[3]];
 return xxc;
end:

`cut_arc/RP` := proc(xxc,t1,t2)
 local y1,y2,d;
 y1 := `arc_eval/RP`(xxc)(t1);
 y2 := `arc_eval/RP`(xxc)(t2);
 d := (2*(1-t1)*(1-t2)) *~ xxc[1] +~
      (2*t1*t2) *~ xxc[2] +~
      (t1 + t2 - 2*t1*t2) *~ xxc[3];
 return [y1,y2,d];
end:

`shift_arc/RP` := proc(xxc,u)
 [exp(u),exp(-u),1] *~ xxc;
end:

`bulge_arc/RP` := proc(xxc,u)
 local x1,x2,c;
 x1,x2,c := op(xxc);
 if u >= 0 then
  return [x1,x2,u*~c];
 else
  return [x1,x2,u*~c];
 fi;
end:

`disc_plot/arc` := proc(xxc)
 local u,v,tt,m,i,P,e,t0,t1;
 u := `arc_eval/RP`(xxc)(t);
 tt := sort(evalf([op({0,1,fsolve(u[3],t=0..1)})]));
 m := nops(tt);
 P := NULL;
 e := 10.^(-4);
 for i from 1 to m-1 do
  t0 := (1-e) *~ tt[i] +~ e *~ tt[i+1];
  t1 := e *~ tt[i] +~ (1-e) *~ tt[i+1];
  v := simplify(`disc_stereo/RP`(u)) assuming t > t0 and t < t1;
  P := P,plot([op(v),t=t0..t1],args[2..-1]);
 od:
 display(P);
end:

`disc_point_plot/arc` := proc(xxc)
 local i,N,P,u,v,p;
 N := 12;
 P := NULL;
 for i from 0 to N do
  u := evalf(`arc_eval/RP`(xxc)(i/N));
  v := `disc_stereo/RP`(u);
  p := point(v,args[2..-1]);
  P := P,p;
 od:
 display(P);
end:


with(Groebner):
with(Ore_algebra):

find_koszul_homology := proc(rels,vars_,p_)
 local vars,char,A,T,P,ix_P,S,B0,B1,d,i,j,k,u,e_K,e_Z,e_B,de_K,ee_K,dd,K,
  K_basis,K_rank,Z_basis,Z_rank,B_basis,B_rank,BZ_basis,BZ_rank;

 if nargs > 1 then
  vars := vars_;
 else
  vars := [op(indets(rels,symbol))];
 fi;

 if nargs > 2 then
  char := (characteristic = p_);
 else
  char := NULL;
 fi;

 A := poly_algebra(op(vars),e_K,e_Z,e_B,char);
 T := MonomialOrder(A,lexdeg([e_K,e_B],vars,[e_Z]),{e_K,e_Z,e_B});

 d := nops(rels);
 # P = list of all subsets of 1,..,d
 P := combinat[powerset]([seq(i,i=1..d)]);

 # Now build index for P e.g. if {1,4,6} appears as 10th
 # element of P then if_P[{1,4,6}] should be 10.
 ix_P := table():
 for i from 1 to 2^d do ix_P[P[i]] := i; od:

 # de_K[i] will be the differential applied to the i'th basis
 # element of the exterior algebra (for 1 <= i <= 2^d).
 de_K := table():
 for i from 1 to 2^d do
  S := P[i];
  de_K[i] := add((-1)^(j-1) * e_K^ix_P[subsop(j=NULL,S)] * rels[S[j]],j=1..nops(S));
  ee_K[i] := e_K^i + e_K^(2^d+1) * de_K[i];
 od:

 # dd = the differential = linear extension of the map
 # sending e_K^i to de_K[i]
 dd := (u) -> add(coeff(u,e_K,i) * de_K[i],i=1..2^d);

 # Basis() calculates Groebner basis
 B0 := Basis([seq(ee_K[i],i=1..2^d)],T,char);
 K_basis := [seq(e_K^i,i=1..2^d)];
 K_rank  := 2^d;
 Z_basis := select(u -> degree(u,e_K) <= 2^d,B0);
 Z_rank  := nops(Z_basis);
 B_basis := select(u -> u <> 0,expand(map(quo,B0,e_K^(2^d+1),e_K)));
 B_rank  := nops(B_basis);

 B1 := Basis([seq(e_B^i + B_basis[i],i=1..B_rank),
              seq(e_Z^i + Z_basis[i],i=1..Z_rank)],T,char);

 BZ_basis := [seq(NormalForm(e_B^i,B1,T,char),i=1..B_rank)];
 BZ_rank  := nops(BZ_basis);

 K := table():
 K["num_rels"] := d;
 K["A"] := A;
 K["T"] := T;
 K["P"] := P;
 K["ix_P"] := eval(ix_P);
 K["de_K"] := eval(de_K);
 K["K_basis"] := K_basis;
 K["K_rank"]  := K_rank;
 K["Z_basis"] := Z_basis;
 K["Z_rank"]  := Z_rank;
 K["B_basis"] := B_basis;
 K["B_rank"]  := B_rank;
 K["BZ_basis"] := BZ_basis;
 K["BZ_rank"]  := BZ_rank;

 K["Z_basis_matrix"] :=
  Matrix([seq([seq(coeff(u,e_K,i),i=1..2^d)],u in Z_basis)]);
 K["B_basis_matrix"] :=
  Matrix([seq([seq(coeff(u,e_K,i),i=1..2^d)],u in B_basis)]);
 K["BZ_basis_matrix"] :=
  Matrix([seq([seq(coeff(u,e_Z,i),i=1..Z_rank)],u in BZ_basis)]);

 K["B0"] := B0;
 K["B1"] := B1;

 return eval(K);
end:


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

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

(* type: gga_exc *)
(* prefix:
  gga_x_mpbe_params *params;

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

mpbe_f0 := s -> s^2/(1 + params_a_a*s^2):
mpbe_f := x -> 1
  + params_a_c1*mpbe_f0(X2S*x)
  + params_a_c2*mpbe_f0(X2S*x)^2
  + params_a_c3*mpbe_f0(X2S*x)^3:

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


input := FileTools:-Text:-ReadFile("AoC-2021-14-input.txt" ):

split := StringTools:-Split(input,"\n"):
polymer := split[1];
rules := table(map(`=`@op,
    map(s->StringTools:-Split(s)[[1,3]], split[3..-1]))):

# initial count
paircount := table(sparse=0):
for i to length(polymer)-1 do
   paircount[polymer[i..i+1]] += 1;
end do:

for i to 40 do
    update := indices(paircount, 'pairs');
    paircount := table(sparse=0):
    lettercount := table(sparse=0):
    for u in update do
        b := lhs(u); c := rules[lhs(u)];
        paircount[ cat(b[1],c) ] += rhs(u);
        paircount[ cat(c,b[2]) ] += rhs(u);
        lettercount[ b[1] ] += rhs(u);
        lettercount[ b[2] ] += rhs(u);
        lettercount[ c ] += 2*rhs(u);
    end do:
    lettercount[polymer[1]] += 1; lettercount[polymer[-1]] += 1;
    if i = 10 or i = 40 then
        t:=[entries(lettercount, 'nolist')];
        print( i=(t[max[index](t)] - t[min[index](t)]) / 2);
    end if;
end do:


#@ Not autoload

with(GroupTheory):
with(LinearAlgebra):

S4 := SymmetricGroup(4);

x2 := [[1,2]];
y2 := [[2,3]];
z2 := [[3,4]];
u2 := [[1,2],[3,4]];
v2 := [[1,3],[2,4]];
x3 := [[1,2,3]];
x4 := [[1,3,2,4]];

H[ 1] := Subgroup({},S4);
H[ 2] := Subgroup({x2},S4);
K[ 2] := Subgroup({u2},S4);
H[ 3] := Subgroup({x3},S4);
H[ 4] := Subgroup({x4},S4);
K[ 4] := Subgroup({x2,z2},S4);
L[ 4] := Subgroup({u2,v2},S4);
H[ 6] := Subgroup({x2,x3},S4);
H[ 8] := Subgroup({x2,x4},S4);
H[12] := Subgroup({u2,x3},S4);
H[24] := S4;

S4_subgroups := [H[1],H[2],K[2],H[3],H[4],K[4],L[4],H[6],H[8],H[12],H[24]]:

# Burnside matrix of numbers |Map_G(G/H_i,G/H_j)|
n := nops(S4_subgroups);
M := Matrix(n,n):
for i from 1 to n do
 for j from 1 to n do
  Hi := S4_subgroups[i];
  Zi := {op(Generators(Hi))};
  Hj := S4_subgroups[j];
  C := map(Representative,LeftCosets(Hj,S4));
  M[i,j] := nops(select(c -> `and`(op(map(x -> SubgroupMembership(c^(-1) . x . c,Hj),Zi))),C));
 od:
od:

unassign('C'):

# Skeleton of the poset of conjugacy classes of subgroups
N := {seq(i,i=1..n)};
R := select(ij -> M[ij[1],ij[2]] <> 0,{seq(seq([i,j],j=1..n),i=1..n)});

# Conjugacy classes

C[1] := ConjugacyClass([],S4);
C[2] := ConjugacyClass(x2,S4);
C[3] := ConjugacyClass(u2,S4);
C[4] := ConjugacyClass(x3,S4);
C[5] := ConjugacyClass(x4,S4);

chars := [
 [ 1, 1, 1, 1, 1],
 [ 1,-1, 1, 1,-1],
 [ 2, 0, 2,-1, 0],
 [ 3, 1,-1, 0,-1],
 [ 3,-1,-1, 0, 1]
];

char_names := [1,epsilon,sigma,rho,epsilon*rho];

char_rels := [
 epsilon^2 - 1,
 epsilon * sigma - sigma,
 sigma^2 - 1 - epsilon - sigma,
 sigma * rho - rho - epsilon * rho,
 rho^2 - 1 - sigma - rho - epsilon * rho
];

char_psi_rels := [
 psi(2,epsilon) = 1,
 psi(2,sigma) = 1 - epsilon + sigma,
 psi(3,sigma) = 1 + epsilon,
 psi(2,rho) = 1 + sigma + rho - epsilon * rho,
 psi(3,rho) = 1 + epsilon - sigma + rho
];

char_lambda_rels := [
 lambda(2,sigma) = epsilon,
 lambda(2,rho) = epsilon * rho,
 lambda(3,rho) = epsilon
];


Q := [b*c+a, a*c-b, b*c-c^2+a-1, b*c+c^2+a+1, a*c-c^2-b-1, a*c+c^2-b+1, a*c-b*
c-a-b, a*c+b*c+a-b, a^2+b^2-3*c^2-3, a^2+b^2-c^2-1, 3*a^2+3*b^2-c^2-1, a^2+b^2
-b*c-a, a^2+b^2+b*c+a, a^2-a*c+b^2+b, a^2+a*c+b^2-b, a^2+b^2-4*b*c+c^2-4*a+1,
a^2+b^2-2*b*c-c^2-2*a-1, a^2+b^2+2*b*c-c^2+2*a-1, a^2+b^2+4*b*c+c^2+4*a+1, a^2
-4*a*c+b^2+c^2+4*b+1, a^2-2*a*c+b^2-c^2+2*b-1, a^2+2*a*c+b^2-c^2-2*b-1, a^2+4*
a*c+b^2+c^2-4*b+1, a^2-2*a*c+b^2-2*b*c+c^2-2*a+2*b+1, a^2-2*a*c+b^2+2*b*c+c^2+
2*a+2*b+1, a^2+2*a*c+b^2-2*b*c+c^2-2*a-2*b+1, a^2+2*a*c+b^2+2*b*c+c^2+2*a-2*b+
1, -b*c+a, a*b+c, -b^2-b*c+a-1, b^2-b*c+a+1, a*b-b*c+a+c, a*b+b*c-a+c, a*b-b^2
+c-1, a*b+b^2+c+1, a^2-b*c+c^2+a, a^2+b*c+c^2-a, a^2-3*b^2+c^2-3, a^2-b^2+c^2-\
1, 3*a^2-b^2+3*c^2-1, a^2-a*b+c^2-c, a^2+a*b+c^2+c, a^2-b^2-2*b*c+c^2+2*a-1, a
^2-b^2+2*b*c+c^2-2*a-1, a^2+b^2-4*b*c+c^2+4*a+1, a^2+b^2+4*b*c+c^2-4*a+1, a^2-\
4*a*b+b^2+c^2-4*c+1, a^2-2*a*b-b^2+c^2-2*c-1, a^2+2*a*b-b^2+c^2+2*c-1, a^2+4*a
*b+b^2+c^2+4*c+1, a^2-2*a*b+b^2-2*b*c+c^2+2*a-2*c+1, a^2-2*a*b+b^2+2*b*c+c^2-2
*a-2*c+1, a^2+2*a*b+b^2-2*b*c+c^2+2*a+2*c+1, a^2+2*a*b+b^2+2*b*c+c^2-2*a+2*c+1
, a*c+b, a*b-c, a*c-b^2-c^2+b, a*c+b^2+c^2+b, a*b-b^2-c^2-c, a*b+b^2+c^2-c, a*
b-a*c-b-c, a*b+a*c+b-c, a^2-3*b^2-3*c^2+1, a^2-b^2-c^2+1, 3*a^2-b^2-c^2+3, a^2
-a*c-b+1, a^2+a*c+b+1, a^2-a*b+c+1, a^2+a*b-c+1, a^2-4*a*c+b^2+c^2-4*b+1, a^2-\
2*a*c-b^2-c^2-2*b+1, a^2+2*a*c-b^2-c^2+2*b+1, a^2+4*a*c+b^2+c^2+4*b+1, a^2-4*a
*b+b^2+c^2+4*c+1, a^2-2*a*b-b^2-c^2+2*c+1, a^2+2*a*b-b^2-c^2-2*c+1, a^2+4*a*b+
b^2+c^2-4*c+1, a^2-2*a*b-2*a*c+b^2+c^2-2*b+2*c+1, a^2-2*a*b+2*a*c+b^2+c^2+2*b+
2*c+1, a^2+2*a*b-2*a*c+b^2+c^2-2*b-2*c+1, a^2+2*a*b+2*a*c+b^2+c^2+2*b-2*c+1];


A_infinity_rel := (m) -> proc(n::posint)
 local p,r,s,t,u,i;
 p := 0;
 for r from 0 to n do
  for s from 1 to n-r do
   t := n - r - s;
   u := r + 1 + t;
   p := p + (-1)^(r+s*t) *
    m(u)(seq(x[i],i=1..r),
      m(s)(seq(x[i],i=r+1..r+s)),
      seq(x[i],i=r+s+1..n));
  od;
 od;
 return unapply(p,seq(x[i],i=1..n));
end:

A_infinity_deg := (n) -> n - 2;

twisted_complex_rel := (d) -> proc(u) local i;
 unapply(add((-1)^i * d(i)(d(u-i)(x)),i=0..u),x);
end:

twisted_complex_bideg := (i) -> [i,i-1];

DA_infinity_rel := (mm) -> proc(i::nonnegint,n::posint)
 local p,r,s,t,u,j,k,l,x;
 p := 0;
 for r from 0 to n do
  for s from 1 to n-r do
   for j from 0 to i do
    t := n - r - s;
    u := r + 1 + t;
    k := i - j;
    p := p + (-1)^(r*s+t+k*u) *
     mm(j,u)(seq(x[l],l=1..r),
       mm(k,s)(seq(x[l],l=r+1..r+s)),
       seq(x[l],l=r+s+1..n));
   od;
  od;
 od;
 return unapply(p,seq(x[l],l=1..n));
end:

DA_infinity_bideg := (i,n) -> [i,i+n-2];


program gcd3;
procedure sort_pair_descending(pair: array[2] of integer);
begin
    if pair[0] < pair[1] then
    begin
        var tmp: integer;
        tmp := pair[0];
        pair[0] := pair[1];
        pair[1] := pair[0];
    end;
end;

procedure gcd(pair: array[2] of integer, var result: integer);
begin
    sort_pair_descending(pair);

    var new: integer;
    new := pair[0] % pair[1];
    pair[0] := pair[1];
    pair[1] := new;

    if pair[1] > 0 then
        return gcd(pair, result) {* semicolons are only used between statements in a block *}
    else
        result := pair[0]
    ;
end;

begin
    var pair: array[2] of integer;
    read(pair[0]);
    read(pair[1]);

    var result: integer;
    gcd(pair, result);
    writeln(result);
end.


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

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

(* type: work_gga_c *)
(* prefix:
  gga_c_zvpbeint_params *params;

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

params_a_gamma := (1 - log(2))/Pi^2:
params_a_BB    := 1:
$include "gga_c_pbe.mpl"

nu := (rs, z, t) ->
  t*mphi(z)*(3/rs)^(1/6):
ff := (rs, z, t) ->
  exp(-params_a_alpha*nu(rs, z, t)^3*m_abs(1*z)^params_a_omega):

f  := (rs, z, xt, xs0, xs1) ->
  f_pw(rs, z) + ff(rs, z, tp(rs, z, xt))*fH(rs, z, tp(rs, z, xt)):


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

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

(* type: mgga_vxc *)

(* replace: "BesselI\(0, " -> "xc_bessel_I0(" *)
(* replace: "BesselI\(1, " -> "xc_bessel_I1(" *)

$define xc_dimensions_2d
$include "mgga_x_2d_prhg07.mpl"

# we add here a threshold of 1e-10 for either tau or the Fermi curvature
prp10_f := (rs, z, x, u, t) -> -(X_FACTOR_2D_C*prhg07_v(prhg07_y(prhg07_C(x, u, t)))
  - (2*sqrt(2)/(3*Pi)) * sqrt(2*m_max(t - x^2/8, 1e-10)))*n_spin(rs, z)^(1/2):

f := (rs, z, xt, xs0, xs1, u0, u1, t0, t1) ->
  prp10_f(rs, z, xs0, u0, t0):


restart;
writeto(terminal);
NULL;
S := readdata("s.txt", float, 3)[1];
X1 := S[1];
X2 := S[2];
T := S[3];
Y_str := parse(readdata("y.txt", string, 3)[1][1], statement);
y := unapply(Y_str, x1, x2, t);
y(0, 0, 42);
L_str := parse(readdata("L_eq.txt", string, 100)[1][1], statement);
G_str := parse(readdata("G.txt", string, 100)[1][1], statement);
c := 1;
L := unapply(L_str, x1, x2, t);
u := (x1, x2, t) -> L(x1, x2, t);
G := unapply(G_str, x1, x2, t);
;
u(0.5, 0.5, 0.5);
G(0, 1/5, 0.3);
y(0, 0, 42);

plotsetup(maplet);
with(plots);
animate3d(y(x1, x2, t), x1 = -X1 .. X1, x2 = -X2 .. X2, t = 0 .. 1, color = sin(x1*x2));
Y0rl := Matrix([[1/2, 1/2, 0], [1/3, 1/3, 0], [1/4, 1/4, 0], [1/5, 1/5, 0], [1/6, 1/6, 0]]);
L0 := 5;
Y0i := Vector(5);
for i to 5 do
    Y0i[i] := y(Y0rl[i, 1], Y0rl[i, 2], Y0rl[i, 3]);
end do;
YGrl := Matrix([[1/2, 1, 1/7], [0, 0, 1/2], [0, 1/3, 1/5], [1/2, 0, 1/4], [0, 1/2, 1/8]]);
LG := 5;
YGi := Vector(5);
for i to 5 do
    YGi[i] := evalf(y(YGrl[i, 1], YGrl[i, 2], YGrl[i, 3]));
end do;
Sm0 := Matrix([[1/2, 1/2, -1], [1/3, 1/3, -2]]);
M0 := 2;
SmG := Matrix([[1.1, 1.5, 1/2], [-0.5, 2, 1/2]]);
MG := 2;

yI := 0;
for i1 to 10 do
    for i2 to 10 do for i3 to 10 do yI1 := piecewise(c(i3/10)^4 + (-(i1/10)^2 - (i2/10)^2) <> 0, 0.001*1/(2*Pi*c*(c(t - i3/10)^4 + (-(x1 - i1/10)^2 - (x2 - i2/10)^2)))*L(i1/10, i2/10, i3/10), 0); yI := yI + yI1; end do; end do;
end do;
yInf := unapply(yI, x1, x2, t);
evalf(yInf(0, 0.65, 0.3));
Y0 := Vector(L0);
for l to L0 do
    Y0[l] := Y0i[l] - evalf(yInf(Y0rl[l, 1], Y0rl[l, 2], Y0rl[l, 3]));
end do;
YG := Vector(LG);
for l to LG do
    YG[l] := YGi[l] - evalf(yInf(YGrl[l, 1], YGrl[l, 2], YGrl[l, 3]));
end do;
Ybar := Vector(L0 + LG);
for i to L0 do
    Ybar[i] := Y0[i];
end do;
for i to LG do
    Ybar[L0 + i] := YG[i];
end do;
A11 := Matrix(L0, M0);
A := Matrix(L0 + LG, M0 + MG);
for i to L0 do
    for j to M0 do A11[i, j] := evalf(G(Y0rl[i, 1] - Sm0[j, 1], Y0rl[i, 2] - Sm0[j, 2], Y0rl[i, 3] - Sm0[j, 3])); A[i, j] := A11[i, j]; end do;
end do;
A11;
A12 := Matrix(L0, MG);
for i to L0 do
    for j to MG do A12[i, j] := evalf(G(Y0rl[i, 1] - SmG[j, 1], Y0rl[i, 2] - SmG[j, 2], Y0rl[i, 3] - SmG[j, 3])); A[i, j + M0] := A12[i, j]; end do;
end do;
i := 2;
j := 1;
A12[i, j] := evalf(G(Y0rl[i, 1] - SmG[j, 1], Y0rl[i, 2] - SmG[j, 2], Y0rl[i, 3] - SmG[j, 3]));
A12;
A21 := Matrix(LG, M0);
for i to LG do
    for j to M0 do A21[i, j] := evalf(G(YGrl[i, 1] - Sm0[j, 1], YGrl[i, 2] - Sm0[j, 2], YGrl[i, 3] - Sm0[j, 3])); A[L0 + i, j] := A21[i, j]; end do;
end do;
A21;
A22 := Matrix(LG, MG);
for i to LG do
    for j to MG do A22[i, j] := evalf(G(YGrl[i, 1] - SmG[j, 1], YGrl[i, 2] - SmG[j, 2], YGrl[i, 3] - SmG[j, 3])); A[i + L0, j + M0] := A22[i, j]; end do;
end do;
A22;
A;
# Псевдообернена:
with(LinearAlgebra);
At := Multiply(Transpose(A), MatrixInverse(Multiply(A, Transpose(A))));
ufinal := Multiply(At, Ybar);
u0 := Vector(M0);
y0 := 0;
for i to M0 do
    u0[i] := ufinal[i];
end do;
for i to M0 do
    y0 := y0 + G(x1 - Sm0[i, 1], x2 - Sm0[i, 2], t - Sm0[i, 3])*u0[i];
end do;
uG := Vector(MG);
for i to MG do
    uG[i] := ufinal[M0 + i];
end do;
yG := 0;
for i to MG do
    yG := yG + G(x1 - SmG[i, 1], x2 - SmG[i, 2], t - SmG[i, 3])*uG[i];
end do;
yfinal := unapply(evalf(yInf(x1, x2, t) + y0 + yG), x1, x2, t);

save yfinal, "y_final.log";
animate3d(yfinal(x1, x2, t), x1 = -X1 .. X1, x2 = -X2 .. X2, t = 0 .. T, color = sin(x1*x2));


# This code is for the cohomology of F(A,R^3), or F(A,R^{2n+1}) for
# any n > 0.  This is concentrated in even degrees so we do not
# need to worry about sign rules or gradings.

with(Groebner):

`vars/poisson` := proc(A::set)
 local a,b;
 [seq(seq(u[a,b],b in A),a in A)];
end:

`rels/poisson` := proc(A::set)
 local n,i,j,k,uf;
 n := nops(A);
 uf := (i,j) -> u[A[i],A[j]];

 return
  [seq(uf(i,i),i = 1..n),
   seq(seq(uf(i,j)+uf(j,i),j=i+1..n),i=1..n-1),
   seq(seq(uf(i,j)^2,j=1..n),i=1..n),
   seq(seq(seq(
    uf(i,j)*uf(j,k) + uj(j,k)*uf(k,i) + uf(k,i)*uf(i,j),
    k=j+1..n),j=i+1..n),i=1..n)
  ];
end:

`groebner_basis/poisson` := proc(A::set)
 Basis(`rels/poisson`(A),tdeg(`vars/poisson`(A)));
end:

`basis/poisson` := proc(A::set)
 local n,a,x,v,B,U,V;

 n := nops(A);
 if n <= 1 then
  return [1];
 fi;
 a := A[n];
 B := A minus {a};
 U := `basis/poisson`(A minus {a});
 V := [1,seq(u[x,a],x in B)];
 return map(op,[seq(U *~ v,v in V)]);
end:


program sample16;	/* prime numbers */
var furui : array[20000] of boolean;
    i, j : integer;
begin
  i := 2;
  while i < 20000 do begin
    furui[i] := true;
    i := i + 1
  end;
  furui[0] := false;
  furui[1] := false;
  i := 2;
  while i < 20000 do begin
    if furui[i] then begin
      writeln(i, ' is a prime number');
      j := i;
      if i < 16384 then
        while j < 20000 do begin
          furui[j] := false;
          j := j + i
        end
    end;
    i := i + 1
  end
end.


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

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

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

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

hcth_coeff_a := [0, 1, 0, -2, 0, 1]:

(* Equation (29) *)
hcth_gamX := 0.004:
hcth_ux   := x -> hcth_gamX*x^2/(1 + hcth_gamX*x^2):

hcth_gxl  := x -> add(params_a_cx_local [i]*hcth_ux(x)^(i-1), i=1..4):
hcth_gxnl := x -> add(params_a_cx_nlocal[i]*hcth_ux(x)^(i-1), i=1..4):

hcth_f    := (x, u, t) -> hcth_gxl(x) + hcth_gxnl(x)*mgga_series_w(hcth_coeff_a, 6, t):

f := (rs, z, xt, xs0, xs1, u0, u1, t0, t1) -> mgga_exchange(hcth_f, rs, z, xs0, xs1, u0, u1, t0, t1):


input := FileTools:-Text:-ReadFile("AoC-2021-5-input.txt" ):
lines:=map(l->[[parse(l[1])],[parse(l[-1])]],
    {op(map(StringTools:-Split, StringTools:-Split(input,"\n"), "->"))}):

pointcounts1 := table(sparse=0):
pointcounts2 := table(sparse=0):

for l in lines do
    step := signum~(l[2] - l[1]);
    ls := l[1];
    pointcounts2[op(ls)] += 1;
    if 0 in step then
        pointcounts1[op(ls)] += 1;
    end if;
    while ls <> l[2] do
        ls := ls + step;
        pointcounts2[op(ls)] += 1;
        if 0 in step then
            pointcounts1[op(ls)] += 1;
        end if;
    end do;
end do:

answer1:=nops(select(i->i>1,[entries(pointcounts1, nolist)]));
answer2:=nops(select(i->i>1,[entries(pointcounts2, nolist)]));

# Visualization

# just the lines
plots:-display(seq(plottools:-line(l[], thickness=0.01),l in lines));

# fancy hotspots
rng := [min,max](entries(pointcounts2,nolist));
colors := [ColorTools:-Color("CVD 8"),ColorTools:-Gradient("CVD 2".."CVD 9", number=rng[2]-rng[1]-2)[]];
epc := [seq(Array(map([lhs], select(p->rhs(p)=i,[entries(pointcounts2,pairs)]))),i=rng[1]..rng[2])]:

plots:-display(
   seq(plottools:-point(epc[i], symbol=solidcircle, color=colors[i], symbolsize=i),i=rng[1]..rng[2] ),
   size=[5000,5000], axes=none, background="Black");


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

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

(* type: gga_exc *)
(* prefix:
  gga_xc_th3_params *params;

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

params_a_n := 19:

params_a_a := [
    7/6,  8/6,  9/6, 10/6, 17/12, 9/6, 10/6, 11/6,
   10/6, 11/6, 12/6, 10/6, 11/6, 12/6,  7/6,  8/6,
    9/6, 10/6, 13/12.0
]:

params_a_b := [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 0]:
params_a_c := [0, 0, 0, 0, 1, 1, 1, 1, 2, 2, 2, 0, 0, 0, 0, 0, 0, 0, 0]:
params_a_d := [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0]:

$include "th.mpl"

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


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

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

(* type: gga_exc *)

$include "gga_c_zvpbeint.mpl"
$include "gga_c_pbeloc.mpl"

params_a_alpha := 0.5:
params_a_omega := 2:

(* redefine nu of zbpbeint *)
zvpbeint_nu := (rs, z, t) ->
  2*(4/(3*Pi^2))^(1/18) * rs^(1/3):

(* Note that f_pbe here is, in fact, pbeloc *)
f  := (rs, z, xt, xs0, xs1) ->
  zvpbeint_ff(rs, z, 0) * f_pbe(rs, z, xt, xs0, xs1):


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

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

(* type: gga_exc *)
(* prefix:
  gga_x_kt_params *params;

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

kt_fx := (rs, z, xs) ->
   1 - params_a_gamma/X_FACTOR_C*n_spin(rs, z)^(4/3)*xs^2/(n_spin(rs, z)^(4/3) + params_a_delta):

(* we want energy per particle *)
f := (rs, zeta, xt, xs0, xs1) -> gga_exchange_nsp(kt_fx, rs, zeta, xs0, xs1):


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

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

(* type: mgga_exc *)

mbeef_n := 5:
mbeef_coefs := [
    [ 1.17114923e+00,  1.15594371e-01, -5.32167416e-02, -2.01131648e-02,  1.41417107e-03],
    [-6.76157938e-02,  4.53837246e-02, -2.22650139e-02,  1.92374554e-02,  9.19317034e-07],
    [ 1.48659502e-02,  3.18024096e-02, -5.21818079e-03,  1.33707403e-07, -5.00749348e-07],
    [ 1.40794142e-03, -6.08338264e-03, -6.57949254e-07, -5.49909413e-08,  5.74317889e-08],
    [ 1.41530486e-04, -1.00478906e-07,  2.01895739e-07,  3.97324768e-09, -3.40722258e-09]
]:

$include "mbeef.mpl"

mbeefvdw_f := (x, u, t) -> mbeef_expansion(x, t):

f := (rs, z, xt, xs0, xs1, u0, u1, t0, t1) ->
  mgga_exchange(mbeefvdw_f, rs, z, xs0, xs1, u0, u1, t0, t1):


program numberlist;  { sample15 }
var e, n: integer;
begin
	writeln('Number list');
	writeln('    n  ', '   2n  ', ' n**2  ', ' n**3  ', ' 2**n  ');
	n := 0;
	e := 1;
	while n < 15 do begin
		writeln(n:6, ' ', 2*n:6, ' ', n*n:6, ' ', n*n*n:6, ' ', e:6);
		e := e * 2;
		n := n + 1;
	end
end.


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

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

(* type: gga_exc *)
(* prefix:
  gga_c_zvpbeint_params *params;

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

params_a_gamma := (1 - log(2))/Pi^2:
params_a_BB    := 1:
$include "gga_c_pbe.mpl"

zvpbeint_nu := (rs, z, t) ->
  t*mphi(z)*(3/rs)^(1/6):

(* we write (z^2)^(omega/2) instead of z^omega in order to
   avoid the use of abs(z). Max is required not to get float
   exceptions for z->0 *)
zvpbeint_ff := (rs, z, t) ->
  exp(-params_a_alpha*zvpbeint_nu(rs, z, t)^3*m_max(z^2, 1e-20)^(params_a_omega/2)):

f  := (rs, z, xt, xs0, xs1) ->
  f_pw(rs, z) + zvpbeint_ff(rs, z, tp(rs, z, xt))*fH(rs, z, tp(rs, z, xt)):


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

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

(* type: work_gga_c *)
(* prefix:
  gga_x_kt_params *params;

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

fx := (rs, z, xs) ->
   params_a_gamma*n_spin(rs, z)^(4/3)*xs^2/(n_spin(rs, z)^(4/3) + params_a_delta):

f0 := (rs, zeta, xt, xs0, xs1) ->
  - (X_FACTOR_C - fx(rs,  zeta, xs0))*n_spin(rs,  zeta)^(4/3)
  - (X_FACTOR_C - fx(rs, -zeta, xs1))*n_spin(rs, -zeta)^(4/3):

(* we want energy per particle *)
f := (rs, zeta, xt, xs0, xs1) -> f0(rs, zeta, xt, xs0, xs1)/n_total(rs):


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

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

# Minimum and maximum functions that I can differentiate

m_min := (x1, x2) -> my_piecewise3(x1 > x2, x2, x1):
m_max := (x1, x2) -> my_piecewise3(x1 > x2, x1, x2):
m_abs := (x)      -> my_piecewise3(x > 0, x, -x):

# Teach maple to differentiate piecewise functions

`diff/my_piecewise3` :=
    proc(c, x1, x2, x) my_piecewise3(c, diff(x1, x), diff(x2, x)) end proc:

`diff/my_piecewise5` :=
    proc(c1, x1, c2, x2, x3, x) my_piecewise5(c1, diff(x1, x), c2, diff(x2, x), diff(x3,x)) end proc:

# This is the derivative of xc_E1_scaled = -exp(x)*Ei(-x) = exp(x)E1(x)

`diff/xc_E1_scaled` :=
  proc(y, x) (xc_E1_scaled(y) - 1/y) * diff(y, x) end proc:

# The derivative of xc_erfcx = exp(x^2)*erfc(x) = 2*x*xc_erfcx(x) - 2/sqrt(Pi)
`diff/xc_erfcx` :=
  proc(y, x) (2*y*xc_erfcx(y) - 2/sqrt(Pi)) * diff(y, x) end proc:

# a series of useful definitions

M_C         := 137.0359996287515: (* speed of light *)

X2S         := 1/(2*(6*Pi^2)^(1/3)):
X2S_2D      := 1/(2*(4*Pi)^(1/2)):

X_FACTOR_C    := 3/8*(3/Pi)^(1/3)*4^(2/3):
X_FACTOR_2D_C := 8/(3*sqrt(Pi)):
K_FACTOR_C    := 3/10*(6*Pi^2)^(2/3):

MU_GE       := 10/81:
MU_PBE      := 0.06672455060314922*(Pi^2)/3:
KAPPA_PBE   := 0.8040:

# generic conversion functions

$ifdef xc_dimensions_1d
DIMENSIONS   := 1:
RS_FACTOR    := 1/2:
$elif xc_dimensions_2d
DIMENSIONS   := 2:
RS_FACTOR    := 1/sqrt(Pi):
LDA_X_FACTOR := -X_FACTOR_2D_C:
$else
DIMENSIONS   := 3:
RS_FACTOR    := (3/(4*Pi))^(1/3):
LDA_X_FACTOR := -X_FACTOR_C:
$endif

r_ws       := n  -> RS_FACTOR/n^(1/DIMENSIONS):
n_total    := rs -> (RS_FACTOR/rs)^DIMENSIONS:

n_spin     := (rs, z) -> simplify((1 + z)*n_total(rs)/2):
sigma_spin := (rs, z, xs) -> simplify(xs^2*n_spin(rs, z)^(8/3)):
t_total    := (z, ts0, ts1) ->
  (ts0*((1 + z)/2)^(5/3) + ts1*((1 - z)/2)^(5/3)):
u_total    := (z, us0, us1) -> t_total(z, us0, us1):

# useful formulas that enter several functionals follow

# von Weizsäcker term
t_vw := (z, xt, us0, us1) -> (xt^2 - u_total(z, us0, us1))/8:

# Screening for extreme values of zeta
z_thr := z -> my_piecewise5(
  1 + z <= p_a_zeta_threshold, p_a_zeta_threshold - 1,
  1 - z <= p_a_zeta_threshold, 1 - p_a_zeta_threshold,
  z):

opz_pow_n := (z, n) -> my_piecewise3(1 + z <= p_a_zeta_threshold, (p_a_zeta_threshold)^n, (1 + z)^n):

# See Eq. (9) of Perdew1992_13244
f_zeta    := z -> (opz_pow_n(z,4/3) + opz_pow_n(-z,4/3) - 2)/(2^(4/3) - 2):
f_zeta_2d := z -> 1/2*(opz_pow_n(z,3/2) + opz_pow_n(-z,3/2)):

# used in several correlation functionals
mphi := z -> (opz_pow_n(z,2/3) + opz_pow_n(-z,2/3))/2:
tt   := (rs, z, xt) -> xt/(4*2^(1/3)*mphi(z)*sqrt(rs)):

# in the paper it is beta_a = 0.066725
beta_Hu_Langreth := rs -> 0.066724550603149220*(1 + 0.1*rs)/(1 + 0.1778*rs):

# Generate exchange and kinetic functionals from the expression for the
# enhancement factor
lda_x_spin := (rs, z) -> simplify(LDA_X_FACTOR*opz_pow_n(z,1 + 1/DIMENSIONS)*2^(-1-1/DIMENSIONS)*(RS_FACTOR/rs)):
lda_k_spin := (rs, z) -> simplify(K_FACTOR_C*opz_pow_n(z,5/3)*2^(-5/3)*(RS_FACTOR/rs)^2):

# Screen out small densities as well as the zero component from fully spin polarized densities due to terms of the form (1+z)^{-n}
screen_dens := (rs, z) -> (n_spin(rs,  z) <= p_a_dens_threshold):

# For most functionals zeta screening occurs inside the funcitonal,
#  but for B88 and B94 correlation need to screen out also outside
screen_dens_zeta := (rs, z) -> screen_dens(rs, z) or (1 + z <= p_a_zeta_threshold):

# non-separable GGA exchange
gga_exchange_nsp := (func, rs, z, xs0, xs1) ->
  + my_piecewise3(screen_dens(rs,  z), 0, lda_x_spin(rs, z_thr( z))*func(rs, z_thr( z), xs0))
  + my_piecewise3(screen_dens(rs, -z), 0, lda_x_spin(rs, z_thr(-z))*func(rs, z_thr(-z), xs1)):
# GGA exchange
gga_exchange := (func, rs, z, xs0, xs1) ->
  + my_piecewise3(screen_dens(rs,  z), 0, lda_x_spin(rs, z_thr( z))*func(xs0))
  + my_piecewise3(screen_dens(rs, -z), 0, lda_x_spin(rs, z_thr(-z))*func(xs1)):
# GGA kinetic energy
gga_kinetic := (func, rs, z, xs0, xs1) ->
  + my_piecewise3(screen_dens(rs,  z), 0, lda_k_spin(rs, z_thr( z))*func(xs0))
  + my_piecewise3(screen_dens(rs, -z), 0, lda_k_spin(rs, z_thr(-z))*func(xs1)):

# non-separable meta-GGA exchange
mgga_exchange_nsp := (func, rs, z, xs0, xs1, u0, u1, t0, t1) ->
  + my_piecewise3(screen_dens(rs,  z), 0, lda_x_spin(rs, z_thr( z))*func(rs, z_thr( z), xs0, u0, t0))
  + my_piecewise3(screen_dens(rs, -z), 0, lda_x_spin(rs, z_thr(-z))*func(rs, z_thr(-z), xs1, u1, t1)):
# meta-GGA exchange
mgga_exchange := (func, rs, z, xs0, xs1, u0, u1, t0, t1) ->
  + my_piecewise3(screen_dens(rs,  z), 0, lda_x_spin(rs, z_thr( z))*func(xs0, u0, t0))
  + my_piecewise3(screen_dens(rs, -z), 0, lda_x_spin(rs, z_thr(-z))*func(xs1, u1, t1)):
# meta-GGA kinetic energy
mgga_kinetic := (func, rs, z, xs0, xs1, u0, u1) ->
  + my_piecewise3(screen_dens(rs,  z), 0, lda_k_spin(rs, z_thr( z))*func(xs0, u0))
  + my_piecewise3(screen_dens(rs, -z), 0, lda_k_spin(rs, z_thr(-z))*func(xs1, u1)):

# This is the Stoll decomposition in our language
lda_stoll_par  := (lda_func, rs, z) ->
  my_piecewise3(screen_dens_zeta(rs,  z), 0, opz_pow_n(z, 1)/2 * lda_func(rs*2^(1/3)*opz_pow_n(z, -1/3), 1)):

lda_stoll_perp := (lda_func, rs, z) ->
  + lda_func(rs, z)
  - lda_stoll_par(lda_func, rs,  z)
  - lda_stoll_par(lda_func, rs, -z):

gga_stoll_par  := (gga_func, rs, z, xs, spin) ->
  my_piecewise3(screen_dens_zeta(rs, z), 0,
    gga_func(rs*2^(1/3)*opz_pow_n(z,-1/3), spin, xs, xs*(1 + spin)/2, xs*(1 - spin)/2) * opz_pow_n(z,1)/2):

# Curvature of the Fermi hole (without the current term)
Fermi_D := (xs, ts) -> 1 - xs^2/(8*ts):

# correction to Fermi_D similar to the one found in
#  JCP 127, 214103 (2007); doi: http://dx.doi.org/10.1063/1.2800011
Fermi_D_corrected := (xs, ts) -> (1 - xs^2/(8*ts)) * (1 - exp(-4*ts^2/params_a_Fermi_D_cnst^2)):

# Becke function used in several correlation functionals
b88_R_F := (f_x, rs, z, xs) -> 1/(2*X_FACTOR_C*n_spin(rs, z)^(1/3)*f_x(xs)):
b88_zss := (css, f_x, rs, z, xs) -> 2*css*b88_R_F(f_x, rs, z, xs):
b88_zab := (cab, f_x, rs, z, xs0, xs1) -> cab*(
  + my_piecewise3(screen_dens(rs,  z), 0, b88_R_F(f_x, rs, z_thr( z), xs0))
  + my_piecewise3(screen_dens(rs, -z), 0, b88_R_F(f_x, rs, z_thr(-z), xs1))
  ):

# The meta-GGA version
b94_R_F := (f_x, rs, z, xs, us, ts) -> 1/(2*X_FACTOR_C*n_spin(rs, z)^(1/3)*f_x(xs,us,ts)):
b94_zss := (css, f_x, rs, z, xs, us, ts) -> 2*css*b94_R_F(f_x, rs, z, xs, us, ts):
b94_zab := (cab, f_x, rs, z, xs0, xs1, us0, us1, ts0, ts1) -> cab*(
  + my_piecewise3(screen_dens(rs,  z), 0, b94_R_F(f_x, rs, z_thr( z), xs0, us0, ts0))
  + my_piecewise3(screen_dens(rs, -z), 0, b94_R_F(f_x, rs, z_thr(-z), xs1, us1, ts1))
  ):

# Power series often used in mggas
mgga_w := t -> (K_FACTOR_C - t)/(K_FACTOR_C + t):
mgga_series_w := (a, n, t) -> add(a[i]*mgga_w(t)^(i-1), i=1..n):

# Used in screened functionals
kF := (rs, z) -> (3*Pi^2)^(1/3) * opz_pow_n(z,1/3) * RS_FACTOR/rs:
nu := (rs, z) -> p_a_hyb_omega_0_/kF(rs, z):

(* Maple 2020 has a bug where series aren't computed to the order requested; this circumvents that *)
padding_order := 30:

(* Cap polynomial expansion to given order (throws out the padded terms, if any) *)
throw_out_large_n := proc(X,n) select(t -> abs(degree(t,{b}))<=n, X); end proc:

(* Function that makes f(a) smooth for a->infty *)
enforce_smooth_lr := proc(f, a, a_cutoff, expansion_order);
  (* Calculate large-a expansion *)
  f_large := a -> eval(throw_out_large_n(convert(series(f(b), b=infinity, expansion_order+padding_order), polynom), expansion_order), b=a):
  (* Return the series expansion for large a; also remove any numerical overflows from the original branch  *)
  my_piecewise3(a >= a_cutoff, f_large(m_max(a, a_cutoff)), f(m_min(a, a_cutoff))):
end proc:


######################################################################
# single_cubes(k) is the usual set of injective maps [0,1]^k -> [0,1]^k

`is_element/single_cubes` := (k::posint) -> proc(xy)
 local i,x,y;
 global reason;

 if not(type(xy,[[realcons$k],[realcons$k]])) then
  reason := [convert(procname,string),"xy is not in R^k x R^k",xy];
  return false;
 fi;

 x,y := op(xy);
 for i from 1 to k do
  if not(0 <= x[i] and x[i] < y[i] and y[i] <= 1) then
   reason := [convert(procname,string),"not (0 <= x[i] < y[i] <= 1)",i,x[i],y[i]];
   return false;
  fi;
 od;

 return true;
end;

`is_equal/single_cubes` := (k::posint) -> proc(xy1,xy2)
 global reason;

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

 return true;
end:

`is_leq/single_cubes` := NULL;

`random_element/single_cubes` := (k::posint) -> proc(d := 6)
 local r,x,y,i,s,t;

 r := rand(0..d);
 x := NULL;
 y := NULL;
 for i from 1 to k do
  s := 0;
  t := 0;
  while s = t do s := r(); t := r(); od;
  x := x,min(s,t)/d;
  y := y,max(s,t)/d;
 od;
 return [[x],[y]];
end;

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

`act/single_cubes` := (k::posint) -> (xy) -> (t) ->
 xy[1] +~ (t *~ (xy[2] -~ xy[1]));

`id/single_cubes` := (k::posint) -> [[0$k],[1$k]];

`compose/single_cubes` := (k::posint) -> (xy,uv) ->
  map(`act/single_cubes`(k)(xy),uv);

`overlap/single_cubes` := (k::posint) -> proc(xy,uv)
 local x,y,u,v,i;

 x,y := op(xy);
 u,v := op(uv);
 for i from 1 to k do
  if max(x[i],u[i]) >= min(y[i],v[i]) then
   return false;
  fi;
 od;
 return true;
end;

`centre/single_cubes` := (k::posint) -> proc(xy)
 (xy[1] +~ xy[2]) /~ 2;
end;


with(DifferentialThomas):
with(Tools):
Ranking([t], [[S, A, E, C, Ninv, J, I], [y2, y] ]):
sys := [
diff(S(t), t) - (-b*S(t)*Ninv(t)*A(t)*q - b*S(t)*Ninv(t)*II(t) - b*S(t)*Ninv(t)*J(t)),
diff(A(t), t) - (-E(t)*k*r + E(t)*k - A(t)*g1),
diff(E(t), t) - (b*S(t)*Ninv(t)*A(t)*q + b*S(t)*Ninv(t)*II(t) + b*S(t)*Ninv(t)*J(t) - E(t)*k),
diff(C(t), t) - (alpha*II(t)),
diff(Ninv(t), t) - (0),
diff(J(t), t) - (alpha*II(t) - g2*J(t)),
diff(II(t), t) - (-alpha*II(t) + E(t)*k*r - g1*II(t)),
y2(t) - (Ninv(t)),
y(t) - (C(t))
];
res := CodeTools[CPUTime](ThomasDecomposition(sys));


# https://www.reddit.com/r/adventofcode/comments/ra3f5i/2021_day_6_part_3_day_googol/
# Get the 10^100th generation of Lantern fish

input := "3,1,1,0,3,7,5,5,2,4,2,1,0,2,6,4,3,0,2,1,5,1,4,2,3,0,6,3,0,5,0,5,6,0,0,6,7,0,1,6,3,2,1,1,2,2,0,1,1,1,6,0,2,1,0,5,1,4,7,6,3,0,7,2,0,0,2,0,2,7,3,7,2,4,6,1,6,6,1,1,6,3,3,1,0,4,5,0,5,1,2,0,2,0,7,4,6,1,6,1,5,0,0,2,3":
tally := table(sparse=0,Statistics:-Tally(StringTools:-Split(input,","))):
lanternfish := Vector([seq(tally[cat("",i)],i=0..8)]):

U := Matrix([
 [0, 1, 0, 0, 0, 0, 0, 0, 0],
 [0, 0, 1, 0, 0, 0, 0, 0, 0],
 [0, 0, 0, 1, 0, 0, 0, 0, 0],
 [0, 0, 0, 0, 1, 0, 0, 0, 0],
 [0, 0, 0, 0, 0, 1, 0, 0, 0],
 [0, 0, 0, 0, 0, 0, 1, 0, 0],
 [1, 0, 0, 0, 0, 0, 0, 1, 0],
 [0, 0, 0, 0, 0, 0, 0, 0, 1],
 [1, 0, 0, 0, 0, 0, 0, 0, 0]]):

minpoly := LinearAlgebra:-MinimalPolynomial(U,x);

q:=10^20:
n := 10^100: # googol

# reduce x^n modulo the minpoly to get g so g(U) = U^n
g := Powmod(x, n, minpoly, x) mod q:

add(eval(g, x=U) . lanternfish) mod q;
# 80595178351181834124


#@ Not autoload

with(LinearAlgebra):
with(Groebner):

Q8 := table():

Q8["element_names"] := ["1","-1","i","-i","j","-j","k","-k"];
Q8["conjugacy_classes"] := [[1],[2],[3,4],[5,6],[7,8]];
Q8["character_table"] :=
 [[1$8],
  [ 1, 1,-1,-1, 1, 1,-1,-1],
  [ 1, 1, 1, 1,-1,-1,-1,-1],
  [ 1, 1,-1,-1,-1,-1, 1, 1],
  [ 2,-2, 0, 0, 0, 0, 0, 0]];
Q8["character_names"] := [1,alpha,beta,gamma,rho];

Q8["character_relations"] :=
 [alpha^2-1,beta^2-1,gamma^2-1,alpha*beta*gamma-1,
  (alpha-1)*rho,(beta-1)*rho,(gamma-1)*rho,
  rho^2-1-alpha-beta-gamma];

Q8["euler_class"] := table([
 1 = 0,
 alpha = x,
 beta = y,
 gamma = z,
 rho = c2
]):

# Morava K-theory information from the Chern approximations paper

p := 2;
n := 3;
q := p^n;

Q8["morava_K_vars"]     := plex(v,x,y,c2);
Q8["morava_K_vars_alt"] := plex(v,c2,x,y);

Q8["morava_K_rels"] := [
 c2^((q^2+q)/2),
 c2^((q^2-q)/2) * x,
 c2^((q^2-q)/2) * y,
 x^2 - v*x,
 y^2 - v*y,
 x*y - v*x - v*y - c2^q,
 v - add(c2^(q^2/2 - 2^i*(q-1)),i=0..n-1)
];

Q8["morava_K_groebner"] :=
 Basis(Q8["morava_K_rels"],Q8["morava_K_vars"],characteristic=p);

Q8["morava_K_basis"] :=
 [seq(c2^i,i=0..(q^2+q)/2-1),
  seq(c2^i*x,i=0..(q^2-q)/2-1),
  seq(c2^i*y,i=0..(q^2-q)/2-1)
 ];

Q8["vec_table"] := table():
d := nops(Q8["morava_K_basis"]):
for i from 1 to d do
 Q8["vec_table"][Q8["morava_K_basis"][i]] := [0$(i-1),1,0$(d-i)];
od:

Q8["vec"] := proc(u)
 local ub,uc;
 if u = 0 then
  return [0$d];
 elif type(u,`+`) then
  return modp(map(Q8["vec"],u),p);
 else
  if type(u,`*`) then
   uc,ub := selectremove(type,u,integer);
  else
   ub := u;
   uc := 1;
  fi;
  return modp(uc *~ Q8["vec_table"][u],p);
 fi;
end:

Q8["morava_K_groebner_alt"] :=
 Basis(Q8["morava_K_rels"],Q8["morava_K_vars_alt"],characteristic=p);

Q8["morava_K_basis_alt"] :=
 [seq(seq(seq(x^i*y^j*c2^k,k=0..3),j=0..1),i=0..7),
  seq(seq(y^j*c2^k,k=0..3),j=2..7),
  seq(c2^k,k=4..7)
 ];


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

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

(* type: mgga_exc *)

gvt4_alpha  := 0.00186726:
gvt4_coeff_d := [-9.800683e-01, -3.556788e-03, 6.250326e-03, -2.354518e-05, -1.282732e-04, 3.574822e-04]:

$include "gvt4.mpl"

gvt4_f := (x, u, t) -> -gtv4(gvt4_alpha, gvt4_coeff_d, x, 2*(t - K_FACTOR_C))/X_FACTOR_C:

f := (rs, z, xt, xs0, xs1, u0, u1, t0, t1) ->
  mgga_exchange(gvt4_f, rs, z, xs0, xs1, u0, u1, t0, t1):


  ReparamDetermined := proc(lo :: LO(name, anything))
    local h;
    h := op(1,lo);
    LO(h,
       evalindets(op(2,lo),
                  'And'('specfunc({Int,int})',
                        'anyfunc'(anything, 'name=anything')),
                  g -> `if`(determined(op(1,g),h), Reparam(g,h), g)))
  end proc;

  determined := proc(e, h :: name)
    local i;
    for i in indets(e, 'specfunc({Int,int})') do
      if hastype(IntegrationTools:-GetIntegrand(i),
           'applyintegrand'('identical'(h),
             'dependent'(IntegrationTools:-GetVariable(i)))) then
        return false
      end if
    end do;
    return true
  end proc;

  #Beginning of Carl's code devoted to disintegration and the reparametrization (aka change
  #of variables) of integrals and sums.

  #Finds the innermost Ints or Sums in an expression, that is, those which
  #don't contain further Ints or Sums
  innermostIntSum:= proc(e::anything, $)::set(specfunc({Int,Sum}));
       select(IS-> nops(indets(IS, specfunc({Int,Sum}))) = 1, indets(e, specfunc({Int,Sum})))
  end proc;

  #my substitute for IntegrationTools:-Change
  ChangeVarInt:= proc(J::specfunc(Int), target::algebraic, $)
  local
       newJ, #What J will become.
       x::name:= op([2,1], J),
       u::name:= gensym('u'),  #new variable of integration
       s,                      #What x will become
       F                       #Boolean: flip integral?
  ;
       s:= {solve({u = target}, {x})};
       if nops(s) = 0 then
            userinfo(1, reparam, "Can't solve substitution target.");
            return e
       end if;
       if nops(s) > 1 then
            userinfo(1, reparam, "Case of multi-branched substitution not handled.");
            return e
       end if;
       s:= s[];

       newJ:= Int(
            eval(implicitdiff(u = target, x, u)*op(1,J), s),
            u=
                 limit(target, x= op([2,2,1], J), right).. #lower limit
                 limit(target, x= op([2,2,2], J), left),   #upper limit
            op(3.., J) #optional Int args (unlikely to be used)
       );

       #If lower limit > upper limit, then flip limits of integration.
       F:= is(op([2,2,1], newJ) > op([2,2,2], newJ));
       if F::truefalse then
            if F then
                 userinfo(2, reparam, "Switching limits:", op([2,2], newJ));
                 newJ:= IntegrationTools:-Flip(newJ)
            end if
       else #If inequality can't be decided, then don't reverse.
            userinfo(1, reparam, "Can't order new limits:", op([2,2], newJ))
       end if;

       newJ
  end proc;

  #main procedure for int/sum reparamterizations
  reparam:= proc(e::LO(symbol, algebraic), {ctx::list:= []}, $)
  local
       J:= innermostIntSum(e),   #the integral or sum
       newJ, #What J will become
       #possible subs target(s)
       oldarg::{algebraic, set(algebraic)}:= map2(op, 2, indets(e, specfunc(applyintegrand)))
  ;
       if nops(J) = 0 then
            userinfo(2, procname, "No sum or integral found.");
            return e
       end if;
       if nops(J) > 1 then
            userinfo(1, reparam, "Case of multiple innermost Int or Sums not yet handled.");
            return 'procname'(e)
       end if;
       J:= J[];
       if J::specfunc(Sum) then
            userinfo(1, reparam, "Sums not yet handled.");
            return 'procname'(e)
       end if;

       if nops(oldarg) <> 1 then
            userinfo(1, thisproc, "More than 1 reparam possible:", oldarg);
            return 'procname'(e)
       end if;
       oldarg:= oldarg[];   #Extract the reparam target.

       #If the target is simply a name, return input unchanged.
       if oldarg::symbol then
            userinfo(2, procname, "No need for a reparameterization.");
            return e
       end if;

       #Make the change of vars.
       newJ:= simplify_assuming('ChangeVarInt(J, oldarg)', build_kb(ctx,"reparam"));

       if newJ = 0 then
            WARNING("Integral is 0, likely due to improper handling of an infinity issue.");
            userinfo(
                 1, procname, "u subs:",
                 print(
                      #Reformat the ChangeVarInt command for readability.
                      subs(
                           x= ':-x',
                           'ChangeVarInt'(
                                subsindets(
                                     J,
                                     specfunc(applyintegrand),
                                     f-> ':-h'(op(2,f))
                                )
                           ),
                           oldarg
                      )
                 )
            )
       end if;

       subs(J= newJ, e)
  end proc;


# int foo(void) {
#   int n = 1;
#   int i;
#   for (i=1; i<10; i++)
#     n = n * i;
# }

func $foo (var %i i32) i32 {
  while (
    lt i32 i32 ( dread i32 %i, constval i32 10) ) {
      dassign %i (
	mul i32 (dread i32 %i, dread i32 %i))
      dassign %i (
        add i32 (dread i32 %i, constval i32 1) )}
  return ( constval i32 1 )
}
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


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

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

(* type: mgga_exc *)

$include "hyb_mgga_x_pjs18.mpl"

(* This expression (10) has \tilde A, and not A *)
js18_f_SR := (rs, z, x, t) -> tm_w(x, t)*js18_DME_SR(rs, z, x, t)
  + (1 - tm_w(x, t))*attenuation_erf(a_cnst*rs/opz_pow_n(z,1/3))*tm_fx_SC(x, t):

js18_f := (rs, z, x, u, t) -> -p_a_hyb_coeff_0_*js18_f_SR(rs, z, x, t) + tm_f(x, u, t):

f := (rs, z, xt, xs0, xs1, u0, u1, t0, t1) ->
  mgga_exchange_nsp(js18_f, rs, z, xs0, xs1, u0, u1, t0, t1):


$radius:20

main()inline{
	once{
		[x0, y0] = CurrentCoords();
		[x, y, err] = radius, 0, 0;

		while (x >= y){
			SetVoid(x0 + x, y0 + y);
			SetVoid(x0 + y, y0 + x);
			SetVoid(x0 - y, y0 + x);
			SetVoid(x0 - x, y0 + y);
			SetVoid(x0 - x, y0 - y);
			SetVoid(x0 - y, y0 - x);
			SetVoid(x0 + y, y0 - x);
			SetVoid(x0 + x, y0 - y);

			if (err <= 0){
				y += 1;
				err += 2*y + 1;
			}

			if (err > 0){
				x -= 1;
				err -= 2*x + 1;
			}
		}
	}
}


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

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

 func $foo8 (
  var %i f64
  ) f64 {
   return (
     sqrt f64(constval f64 4.0))}

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


# File: MapleCodePrime.mpl
#
# Description:
#  This file contains code written by external developers -- users of mapleprimes.com
# Author:
#  Alec, Mihailovs
#
#
# Date:
#  27/12/2016
#
# License:
#  Contact the authors.
#
# Copyright (c) Alec Mihailovs
# All rights reserved.

RigidMotionsMaplePrimesCode := module()
  option package;

  export Isort;

# Procedure: Isort
#   Sort elements and return their indices in original order after sorting
#
# Author:
#   Alec Mihailovs - http://www.mapleprimes.com/posts/43507-Sorting-With-Indices#comment80473
# Parameters:
#   L            - a container to be sorted.
#
# Output:
#   indices of original order after sorting, sorted collection.
Isort:=proc(L)
  local a;
  a := sort([$1..nops(L)],(i,j)->L[i]<=L[j]);
  return a, [seq(L[i],i=a)];
end:

end module;


bc :=
[
    [
        [2-7*x1+x1^2*x2-1/2*(x3-x1),
         6*x1-x1^2*x2-5*(x4-x2),
         2-7*x3+x3^2*x4-1/2*(x1-x3),
         6*x3-x3^2*x4+1+1/2*(x2-x4)
        ],
        [x4,x3,x2,x1]
    ],
    [
        [1-c*x-x*y^2-x*z^2,
         1-c*y-y*x^2-y*z^2,
         1-c*z-z*x^2-z*y^2,
         8*c^6+378*c^3-27
        ],
        [z, y, x, c]
    ],
    [
        [a+b+c+d+h1,
         a*b+b*c+c*d+d*h1+h1*a,
         a*b*c+b*c*d+c*d*h1+d*h1*a+h1*a*b,
         a*b*c*d+b*c*d*h1+c*d*h1*a+d*h1*a*b+h1*a*b*c,
         a*b*c*d*h1-1
        ],
        [h1, d, c, b, a]
    ],
    [
        [2*x1*(2-x1-y1)+x2-x1,
         2*x2*(2-x2-y2)+x1-x2,
         2*y1*(5-x1-2*y1)+y2-y1,
         y2*(3-2*x2-4*y2)+y1-y2
        ],
        [x2, x1, y2, y1]
    ],
    [
        [1/100-4*s*(s-1)*(s-b)*(s-c),
         1/5-b*c,
         2*s-1-b-c
        ],
        [s, c, b]
    ],
    [
        [x^2+y^2-x*y-1,
         y^2+z^2-y*z-a^2,
         z^2+x^2-z*x-b^2,
         a^2-1+b-b^2,
         3*b^6+56*b^4-122*b^3+56*b^2+3
        ],
        [z, y, x, b, a]
    ]
]:


(*
 Copyright (C) 2020 Susi Lehtola

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

(* type: gga_exc *)
(* prefix:
  gga_k_rational_p_params *params;

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

rational_p_f0 := s -> (1 + params_a_C2/params_a_p * s^2)^(-params_a_p):
rational_p_f := x -> rational_p_f0(X2S*x):

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


$ifndef _GEN_SOL_
$define _GEN_SOL_

$include "Utils.mpl"

# 寻找一般解,考虑存在常数约束和多个单变量非零约束
# 若只存在一个极大元，则直接返回下标
# 否则分组返回极大元，相等的极大元放在一组中
findGenSolInd:=proc(icons::list(set),n::posint)
    return findGenVec(con2vec~(icons,n));
end proc:

# 将约束条件转化为向量
con2vec:=proc(c::set,n::posint)
    local v,t;
    v:=Array(1..n,2);
    for t in c do
        if op(0,t)=`=` then
            v[op([1,1],indets(t,name))]:=0;
        elif op(0,t)=`<>` then
            v[op([1,1],indets(t,name))]:=1;
        end if;
    end do;
    return convert(v,list);
end proc:

# 寻找一般解
# 等价于寻找偏序集的极大元
# 返回下标的list
findGenVec:=proc(v::list)
    local mInd,i,j,n,isAdd,ind,t,gen,mgen,maxind;
    n:=numelems(v);
    mInd:=table();
    mInd[1]:=1;
    for i from 2 to n do
        isAdd:=true;
        for j in indices(mInd,nolist) do
            if v[i] &> v[j] then
                unassign(evaln(mInd[j]));
            elif v[j] &> v[i]  then
                isAdd:=false;
                break;
            end if;
        end do;
        if isAdd then
            mInd[i]:=1;
        end if;
    end do;
    ind:=[indices(mInd,nolist)];
    if numelems(ind)=1 then
        return ind[1];
    else
        # 分组返回，相等的元素放在一组
        t:=table();
        for i in ind do
            tappend(t,v[i],i);
        end do;
        ind:=[entries(t,nolist)];
        # 选择一般性最大的分组
        gen:=map(x->add(v[x[1]]),ind);
        mgen:=max(gen);
        maxind:=find(gen,mgen);
        ind:=ind[maxind];
        return ind;
    end if;
end proc:

`&>=`:=proc(x::list,y::list)
    local n:=numelems(x);
    return andmap(k->evalb(x[k]>=y[k]),[seq(1..n)]);
end proc:

`&>`:=proc(x::list,y::list)
    local n:=numelems(x);
    return x &>= y and ormap(k->evalb(x[k]>y[k]),[seq(1..n)]);
end proc:

$endif


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

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

(* type: work_gga_x *)

c1 := 0.003:

f := x -> 1 + c1/X_FACTOR_C * x^2:


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

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

(* type: mgga_exc *)

$include "gga_c_scan_e0.mpl"
$include "mgga_x_scan.mpl"

scan_b1c := 0.0285764:
scan_b2c := 0.0889:
scan_b3c := 0.125541:
scan_eclda0 := rs -> -scan_b1c/(1 + scan_b2c*sqrt(rs) + scan_b3c*rs):

scan_chi_infty := 0.12802585262625815:
scan_g_infty := s -> 1/(1 + 4*scan_chi_infty*s^2)^(1/4):

(* in the paper it is 2.3631 *)
scan_G_cnst := 2.363:
scan_Gc := z -> (1 - scan_G_cnst*(2^(1/3) - 1)*f_zeta(z))*(1 - z^12):

scan_H0 := (rs, s) ->
  scan_b1c*log(1 + (exp(-scan_eclda0(rs)/scan_b1c) - 1)*(1 - scan_g_infty(s))):
scan_e0 := (rs, z, s) ->
  (scan_eclda0(rs) + scan_H0(rs, s))*scan_Gc(z):

scan_alpha := (z, xt, ts0, ts1) ->
  (t_total(z, ts0, ts1) - xt^2/8)/(K_FACTOR_C*t_total(z, 1, 1)):

(* set parameters of f_alpha *)
params_a_c1 := 0.64:
params_a_c2 := 1.5:
params_a_d  := 0.7:

scan_f := (rs, z, xt, xs0, xs1, ts0, ts1) ->
  f_pbe(rs, z, xt, xs0, xs1) + scan_f_alpha(scan_alpha(z, xt, ts0, ts1))*(
    + scan_e0(rs, z, X2S*2^(1/3)*xt)
    - f_pbe(rs, z, xt, xs0, xs1)
  ):

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


`is_element/YC` := (N::posint) -> (A::set) -> proc(x)
 local a,b,i,j,k,t,G,J,E,B;
 global reason;

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

 if map(op,{indices(x)}) <> A then
  reason := [convert(procname,string),"x is not indexed by A",x,A];
  return false;
 fi;

 for a in A do
  if not `is_element/R`(N)(x[a]) then
   reason := [convert(procname,string),"x[a] is not in R^N",a,x[a],N];
   return false;
  fi;
 od;

 for i from 1 to N do
  if min(seq(x[a][i],a in A)) <> 0 then
   reason := [convert(procname,string),"min(x[i]) <> 0",i,x];
   return false;
  fi;
 od;

 G := `gaps/F`(N)(A)(x);

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

 J := select(j -> G[j] = 1,[seq(k,k=1..N)]);
 E := {seq(seq([a,b],b in A),a in A)};
 for j in J do
  t := table();
  for a in A do t[a] := x[a][j]; od;
  B := blur_preorder(A)(t,1);
  E := E intersect B intersect `op/preord`(A)(B);
 od:

 if E <> {seq([a,a],a in A)} then
  reason := [convert(procname,string),"E <> Delta",E];
  return false;
 fi;

 return true;
end;

`is_equal/YC` := (N::posint) -> (A::set) -> proc(x,y)
 local a;
 global reason;

 for a in A do
  if x[a] <> y[a] then
   reason := [convert(procname,string),"x[a] <> y[a]",a,x[a],y[a]];
   return false;
  fi;
 od;

 return true;
end;

`inc/YC/F` := (N::posint) -> (A::set) -> (x) -> x;

`mu_bar/YC/PP` := (N::posint) -> (A::set) -> proc(x)
 local i,j,k,p,m,a,b,L,A0,T0,g0,g,t,s,AA,R,RR;

# DEBUG();

 L := NULL;
 m := nops(A);

 for i from 1 to N do
  A0 := sort([op(A)],(a,b) -> x[a][i] <= x[b][i]);
  T0 := [seq(x[A0[j]][i],j=1..m)];
  for j from 1 to m-1 do
   L := L,[i,A0[j],A0[j+1],T0[j+1]-T0[j]];
  od;
 od;

 L := sort([L],(a,b) -> a[4] <= b[4]);
 k := nops(L);

 R := table():
 t := table():

 R[1] := `mu/F/PP`(N)(A)(x);
 t[1] := L[1][4];
 s := table():
 s[R[1]] := t[1];

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

 for p from 2 to k do
  i,a,b,g := op(L[p-1]);
  RR := R[p-1][i];
  RR := RR union select(xy -> member([xy[1],b],RR) and member([a,xy[2]],RR),AA);
  R[p] := [seq(R[p-1][j],j=1..i-1),RR,seq(R[p-1][j],j=i+1..N)];
  t[p] := L[p][4] - L[p-1][4];
  if t[p] > 0 then s[R[p]] := t[p]; fi;
 od;

 return eval(s);
end:

`sigma_bar/PP/YC` := (N::posint) -> (A::set) -> proc(t)
 local x,y,a,C,s,R;

 x := table();
 for a in A do x[a] := [0$N]; od;

 C := map(op,[indices(t)]);
 for R in C do
  s := t[R];
  y := `sigma/PP/F`(N)(A)(R);
  for a in A do
   x[a] := x[a] +~ s *~ y[a];
  od;
 od;

 return eval(x);
end:


# 尽可能的化简解的约束

$ifndef _CON_REFINE_
$define _CON_REFINE_

$include "Condition.mpl"
$include "../seg/Seg.mpl"

# 总的简化函数
conRefine:=proc(r::RepSol)
    signRefine(r);
    epRefine(r);
    uniqueAndSort(r);# 简化之后重新对条件进行排序
    return;
end proc:

# 对于代表元v[k]删去a[k]>0.
# 对于代表元-v[k]删去a[k]<0.
# 这里只删去了acon的条件，对于osol并没有进行修改
signRefine:=proc(r::RepSol)
    local vs,k,rc;
    vs:=indets(r:-rep,name);
    if numelems(vs)<>1 then
        return;
    end if;
    k:=op([1,1],vs);
    rc:=eval({a[k]>0,a[k]<0});
    r:-acon:=map(x->x minus rc,r:-acon);
    return;
end proc:

# 尽可能删去和epsilon有关的约束
epRefine:=proc(r::RepSol)
    r:-acon:=epDeal~(r:-acon);
end proc:

# 处理每个可能情况的约束条件
epDeal:=proc(s::set)
    local ca,ce,r;
    ce,ca:=selectremove(has,s,epsilon);
    ce:=ceDeal~(ce);
    r:=ce union ca;
    r:=classifySolve(r);
    return r;
end proc:

# 单个关于epsilon的条件处理
ceDeal:=proc(e)
    local rs;
    # 有的时候solve会抽，对于这种情况不做处理
    try
        rs:=conSolve(e);
    catch :
        return e;
    end try;
    if numelems(rs)=0 then
        # 无解则原样返回
        return e;
    elif numelems(rs)=1 then
        # 只有一个解，则不论有多少条件都可以
        return rs[][];
    else
       return multiConRefine(rs);
    end if;
end proc:

multiConRefine:=proc(rs)
    local s;
    # 单变量约束的并集，只处理无约束和，x<>c的约束
    if numelems(indets(rs,name))=1 and
        andmap(x->evalb(numelems(x)=1),rs) then
        s:=`union`(seq(Seg(x),x in rs));
        if s=real then
            return NULL;
        end if;
        s:=&C s;
        if type(s:-bound,numeric) then
            return indets(rs,name)[]<>s:-bound;
        else
            return e;
        end if;
    # 删去一个共同条件之后能够构成单变量约束的并集
    elif numelems(`intersect`(rs[]))=1 then
        s:=`intersect`(rs[]);
        return s[],multiConRefine(map(x->x minus s,rs));
    else
        return e;
    end if;
end proc:

# 求解不等式，
# 在解中删除自由变量
# 删除和epsilon有关的约束
conSolve:=proc(c)
    local r;
    r:=[RealDomain:-solve(c)];
    r:=map(x->remove(t->evalb(lhs(t)=rhs(t)),x),r);
    r:=map(x->remove(has,x,epsilon),r);
    r:=[{r[]}[]];# 去重
    return r;
end proc:

$endif