(*
 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 *)

$define xc_dimensions_2d

_2d_b86_beta  := 0.002105:
_2d_b86_gamma := 0.000119:

_2d_b86_f := x -> (1 + _2d_b86_beta*x^2)/(1 + _2d_b86_gamma*x^2):

f := (rs, zeta, xt, xs0, xs1) -> gga_exchange(_2d_b86_f, 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: work_lda *)
(* prefix:
  lda_c_hl_params *params;

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

$ifdef lda_c_vbh_params
params_a_r := [30, 75.0]:
params_a_c := [0.0252, 0.0127]:
$endif

xx := (k, rs) -> rs/params_a_r[k]:
hl := (k, rs) -> -params_a_c[k]*
  ((1 + xx(k, rs)^3)*log(1 + 1/xx(k, rs)) - xx(k, rs)^2 + 1/2*xx(k, rs) - 1/3):

f_hl := (rs, zeta) -> hl(1, rs) + f_zeta(zeta)*(hl(2, rs) - hl(1, rs)):
f    := (rs, zeta) -> f_hl(rs, zeta):


(*
 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 *)
(* replace: "my_dilog\(" -> "xc_dilogarithm(" *)

`diff/my_dilog` := proc(g, x) -log(1 - g)/g * diff(g, x) end proc:

gg99_a := 3^(1/4)/(2*sqrt(2)*Pi^(3/2)):
gg99_b := 4*sqrt(3)*Pi^3:

(* Equation 22 in the paper, i.e.
   the solution of x = 2*Pi*sinh(r)/(3*cosh(r))^(1/3) *)

gg99_r_branch1 := x -> arcsinh( (gg99_a * x * sqrt(x^2 + (gg99_b + sqrt(gg99_b^2 - x^6))^(2/3))) / (gg99_b + sqrt(gg99_b^2 - x^6))^(1/6) ):

(* The second branch is from Andrew Gilbert via email *)

gg99_r_branch2 := x-> arcsinh(sqrt(x^3*(3/gg99_b)*cos(arctan(sqrt(1/(gg99_b^2)*x^6-1))/3))):

(* Glue the pieces together. The min and max are required
   to avoid float exceptions *)
gg99_r := x -> my_piecewise3(x < gg99_b^(1/3),
  gg99_r_branch1(m_min(x, gg99_b^(1/3) - 1e-10)),
  gg99_r_branch2(m_max(x, gg99_b^(1/3) + 1e-10))
  ):

(* Equation 21 *)
gg99_f0 := r -> (Pi^2 - 12*r*log(1 + exp(-2*r)) +
12*my_dilog(-exp(-2*r))) / (2*3^(1/3)*Pi*r*sech(r)^(2/3)) / X_FACTOR_C:

(* Assemble the function *)
gg99_f := x -> gg99_f0(gg99_r(x)):

f := (rs, zeta, xt, xs0, xs1) ->
  gga_exchange(gg99_f, rs, zeta, xs0, xs1):


# This checks some formulae in the LaTeX file Out_SL2.tex

check_aut_SL2 := proc()
 local i2,alpha,beta,beta0,gamma,mu,sigma,rho,
  m,n,g,h,a,b,c,d,t,u,v,rels,
  is_in_U,is_in_T,is_in_B,err;

 i2 := IdentityMatrix(2);
 alpha := (v) -> <<1|v>,<0|1>>;
 mu := (u) -> <<u|0>,<0|1/u>>;

 is_in_U := (g) -> g[2,1] = 0 and g[1,2] = 0 and g[1,1] * g[2,2] = 1;
 is_in_T := (g) -> g[2,1] = 0 and g[1,1] = 1 and g[2,2] = 1;
 is_in_B := (g) -> g[2,1] = 0 and g[1,1] * g[2,2] = 1;
 rho := (u) -> g[1,1];
 sigma := (a) -> <<0|1>,<1|a>>;
 beta := (a,b) -> alpha(b) . sigma(a) . (1/alpha(b)) . (1/sigma(a));
 beta0 := (b) -> <<1+b^2|b>,<b|1>>;
 gamma := (b,u) -> <<1/u|0>,<(1+b^2)/u|u>>;

 _ASSERT(
  Equal(map(modp,simplify(beta(a,b)),2),beta0(b)),
  "Formula for beta(b)"
 ):

 err := gamma(b,u).beta0(b).(1/gamma(b,u)) - sigma(b^2);
 err := map(modp,simplify(subs(b = u^2,err)),2);
 _ASSERT(
  Equal(err,<<0|0>,<0|0>>),
  "beta(b) is conjugate to sigma(b^2)"
 ):

 m := <<1/u|0>,<0|u>>;
 n := <<u|u>,<0|1/u>>;
 _ASSERT(
  Equal(m.n,alpha(1)),
  "m n = alpha(1)"
 );

 g := <<a|b>,<c|d>>;
 g := subs(solve(map(op,convert(g.alpha(1) - alpha(1).g,listlist)),{c,d}),g);
 _ASSERT(
  Equal(g,<<a|b>,<0|a>>),
  "Centraliser of alpha(1)"
 );

 g := <<u|v>,<0|1/u>>;
 h := alpha(v/(1/u-u));
 _ASSERT(
  Equal(simplify(h.mu(u).(1/h)),g),
  "D_u is conjugate to mu(u) in B"
 );

 g := <<a|b>,<c|d>>;
 rels := map(numer,map(op,convert(mu(u).g.mu(u).g - i2,listlist)));
 rels := map(coeffs,expand(rels),u);
 g := subs(solve(rels,{a,c,d}),g);
 _ASSERT(
  Equal(g,<<0|b>,<1/b|0>>),
  "(mu(u) . g)^2 = 1 only on U"
 );

 _ASSERT(
  Equal(mu(u) . alpha(t) . (1/mu(u)),alpha(u^2*t)),
  "Conjugate of alpha(t) by mu(u)"
 );
end:


(*
 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: mgga_exc *)

$include "mgga_x_tm.mpl"

(* revtm uses the tpss definition of qtilde *)
tm_b := 0.4:
tm_qtilde := (x, t) ->
     9/20 * (tm_alpha(x, t) - 1)/sqrt(1 + tm_b*tm_alpha(x, t)*(tm_alpha(x, t) - 1))
     + 2*tm_p(x)/3:


(*
 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 *)

mu1     := 0.042:
mu2     := 0.26 - mu1:
nu_MGE4 := -0.195:
k2      := -mu2^2/nu_MGE4:
k1      := 0.804 - k2:

f0 := s -> 1 + k1 + k2
   - k1*(1 - mu1*s^2/k1)/(1 - (mu1*s^2/k1)^5)
   - k2/(1 + mu2*s^2/k2):

f:= x -> f0(X2S*x):


(*
 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_dk87_params *params;

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

dk87_betag := 7/(432*Pi*(6*Pi^2)^(1/3))/X_FACTOR_C:

dk87_f := x -> 1 + dk87_betag*x^2*(1 + params_a_a1*x^params_a_alpha)/(1 + params_a_b1*x^2):

f := (rs, z, xt, xs0, xs1) -> gga_exchange(dk87_f, rs, z, 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: work_gga_x *)

kappa := 0.8040:

den := s -> kappa + 1*MU_GE*s^2 + MU_GE^2*s^4/kappa:
f0  := s -> 1 + kappa * (1 - kappa/den(s)):
f   := x -> f0(X2S * x):


(*
 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: mgga_exc *)
(* prefix:
  mgga_k_pgslb_params *params;

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

# Equation (4) and (8)
pgslb_f0 := (s, q) -> 5/3*s^2 + exp(-params_a_pgslb_mu * s^2) + params_a_pgslb_beta*q^2:
pgslb_f := (x, u) -> pgslb_f0(X2S*x, X2S^2*u):

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


(*
 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 *)

$define lda_c_vbh_params
$include "lda_c_hl.mpl"

malpha := (4*Pi/3)^(1/6):

(* 4.28e-3/2, where the 2 comes from the covertion from Ryd. to Hartree *)
a1     := Pi/(16*(3*Pi^2)^(4/3)):
a2     := -0.262:
a3     := -7/(9*2^(5/3)):

t1 := (rs, z, xt) ->
  + xt^2*exp(a2*xt/(malpha*sqrt(rs)))
  * sqrt(2)/sqrt((1 + z)^(5/3) + (1 - z)^(5/3)):
t2 := (z, xs0, xs1) ->
  + a3*(xs0^2*(1 + z)^(4/3) + xs1^2*(1 - z)^(4/3)):

f := (rs, z, xt, xs0, xs1) ->
  + f_hl(rs, z)
  + a1/(malpha^2*rs)*(t1(rs, z, xt) + t2(z, 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_pbe_params *params;

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

(* standard PBE *)
$ifdef gga_x_pbe_params
params_a_kappa := 0.8040:
params_a_mu    := 0.2195149727645171:
$endif

(* PBE_SOL *)
$ifdef gga_x_pbe_sol_params
params_a_kappa := 0.8040:
params_a_mu    := MU_GE:
$endif

$ifdef gga_x_pbe_tca_params
params_a_kappa := 1.227:
params_a_mu    := 0.2195149727645171:
$endif

pbe_f0 := s -> 1 + params_a_kappa*(1 - params_a_kappa/(params_a_kappa + params_a_mu*s^2)):
pbe_f  := x -> pbe_f0(X2S*x):

f := (rs, z, xt, xs0, xs1) -> gga_exchange(pbe_f, rs, z, 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: work_mgga_x *)

a1 := (10/(3*(6*Pi*Pi)^(2/3)))^(4/5): (* (2/C_F)^(4/5) *):

f := (rs, x, t, u) -> a1*t^(4/5):


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

# Real numbers

`is_element/RR` := (x) -> type(x,realcons):

`is_equal/RR` := (x,y) -> evalb(simplify(y-x) = 0):

`is_leq/RR` := (x,y) -> is(simplify(y-x) >= 0);

`random_element/RR` := proc() rand(-720..720)()/(360); end:

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

`random_element/RR_plus` := proc() rand(1..720)()/(360); end:

######################################################################
# R(N) is the vector space RR^N

`is_element/R` := (N::posint) -> (x) -> type(x,[realcons$N]);

`is_equal/R` := (N::posint) -> (x,y) -> evalb(simplify(x -~ y) = [0$N]);

`is_leq/R` := (N::posint) -> proc(x,y) local i; `and`(seq(`is_leq/RR`(x[i],y[i]),i=1..N)); end:

`is_leq_lex/R` := (N::posint) -> proc(x,y)
 local i,z;
 for i from 1 to n do
  z := simplify(y[i] - x[i]);
  if is(z > 0) then
   return true;
  elif is(z < 0) then
   return false;
  fi;
 od;
 return true;
end:

`is_zero/R` := (N::posint) -> (x) -> evalb(simplify(x) = [0$N]);

`norm_2/R` := (N::posint) -> proc(x) local i; sqrt(add(x[i]^2,i=1..N)); end:

`dot/R` := (N::posint) -> proc(x,y) local i; add(x[i]*y[i],i=1..N); end:

`d_2/R` := (N::posint) -> (x,y) -> `norm_2/R`(N)(x -~ y);

`norm_infinity/R` := (N::posint) -> (x) -> max(map(abs,x));

`d_infinity/R` := (N::posint) -> (x,y) -> `norm_infinity/R`(N)(x -~ y);

`random_element/R` := (N::posint) -> proc() local i; [seq(`random_element/RR`(),i=1..N)] end;

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

`cross_product` := proc(x,y)
 [x[2]*y[3] - x[3]*y[2],
  x[3]*y[1] - x[1]*y[3],
  x[1]*y[2] - x[2]*y[1]];
end:


input := StringTools:-Trim(FileTools:-Text:-ReadFile("AoC-2021-15-input.txt"));

grid := Matrix(map(s->parse~(StringTools:-Explode(s)),StringTools:-Split(input,"\n"))):

(gridw,gridl) := upperbound(grid);

nbs := proc(i,j,gridsize)
local out := NULL;
    if i < gridsize then
       out := out, [i+1, j];
    end if;
    if j < gridsize then
       out := out, [i, j+1];
    end if;

    if i > 1 then
      out := out, [i-1,j];
    end if;
    if j > 1 then
       out := out, [i, j-1];
    end if;

    return [out];
end proc:

Dijkstra := proc(start, theend, grid)
local pq, costsofar, curr, nb, newcost, pt, gridsize;
uses priqueue;

gridsize := upperbound(grid)[1];
costsofar := table(sparse=infinity):

initialize(pq):
insert([0,start], pq):
costsofar[start] := 0:

while pq[0] <> 0 do
   curr := extract(pq)[2];
   if curr = theend then
       return costsofar[theend];
   end if;
   nb := nbs(curr[], gridsize);
   for pt in nb do
       newcost := costsofar[curr] + grid[pt[]];
       if newcost < costsofar[pt] then
           costsofar[pt] := newcost;
           insert([-newcost,pt], pq);
       end if;
   end do;
end do:

end proc:

answer1 := Dijkstra([1,1], [gridl,gridw], grid);
# should really do this lazily
inc := a -> (a mod 9) +~ 1;
biggrid:= Matrix([seq([seq((inc@@(i+j-2))(grid),j=1..5)],i=1..5)] );
(biggridw,biggridl) := upperbound(biggrid);
answer2 := Dijkstra([1,1], [biggridl,biggridw], biggrid);


`is_element/total_preord` := (A::set) -> proc(R)
 local AA,a,b,ab,U;

 global reason;

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

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

 if not(`is_total/preord`(A)(R)) then
  reason := [convert(procname,string),"R is not a total preorder on A",R,A];
  return false;
 fi;

 return true;
end;

`is_equal/total_preord` := (A::set) -> (R1,R2) -> `is_equal/preord`(A)(R1,R2);
`is_leq/total_preord`   := (A::set) -> (R1,R2) -> `is_leq/preord`(A)(R1,R2);

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

`build/total_preord` := (A::set) -> proc(pi)
 local m,r,i,a,b,R;

 m := nops(pi);
 r := table();
 for i from 1 to m do
  for a in pi[i] do
   r[a] := i;
  od;
 od;

 R := NULL;
 for a in A do
  for b in A do
   if r[a] <= r[b] then R := R,[a,b]; fi;
  od;
 od;
 R := {R};

 return R;
end;

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

`random_element/total_preord` := (A::set) -> proc()
 local pi,pi0,pi1,m,r,i,a,b,R;

 pi := `random_element/partitions`(A)();
 pi0 := map(u -> sort([op(u)]),pi);
 pi0 := sort([op(pi0)]);
 pi1 := combinat[randperm](pi0);
 return `build/total_preord`(A)(pi1);
end;

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

`list_elements/total_preord` := proc(A::set)
 local PI,pi,pi0,pi1,L;

 PI := `list_elements/partitions`(A);
 L := NULL;
 for pi in PI do
  pi0 := map(u -> sort([op(u)]),pi);
  pi0 := sort([op(pi0)]);
  for pi1 in combinat[permute](pi0) do
   L := L,`build/total_preord`(A)(pi1);
  od;
 od;
 L := [L];
 return L;
end;

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

`count_elements/total_preord` := proc(A::set)
 local n,k;
 n := nops(A);
 add(k! * Stirling2(n,k),k=1..n);
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_x *)

mu    := 0.2195149727645171:
c     := (146/2025)*(4/9) - (73/405)*(2/3) + (mu - 10/81):
kappa := 0.8040:

f0_aux := s -> kappa + MU_GE * s^2 + (mu - MU_GE) * s^2 * exp(-s^2) + log(1 + c * s^4):
f0_wc  := s -> 1 + kappa*(1 - kappa/f0_aux(s)):
f_wc   := x -> f0_wc(X2S*x):

f      := x -> f_wc(x):


with(BinomSums):
with(CodeTools):

### sumtoct

S := Sum(Binomial(n,k),k=0..n);
R := sumtoct(S, u);

Test(residue(subs(n=10,R)/u[1], u[1]=0), 2^10);

### sumtores

S := Sum(t^n*Sum(Binomial(n,k),k=0..n), n=0..infinity);
R, ord := sumtores(S, u);

Test(nops(ord), 1);
Test(R, 1/(1-2*t), `normal`);


(*
 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: lda_exc *)

$include "vwn.mpl"

f_vwn := (rs, z) ->
  + f_aux(A_rpa[1], b_rpa[1], c_rpa[1], x0_rpa[1], rs)*(1 - f_zeta(z))
  + f_aux(A_rpa[2], b_rpa[2], c_rpa[2], x0_rpa[2], rs)*f_zeta(z):

f := (rs, z) -> f_vwn(rs, z):


(*
 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: lda_exc *)

AA := -0.655868:
BB :=  4.888270:
CC :=  3.177037:
DD :=  0.897889:

phi := z -> 1/2*(opz_pow_n(z,2/3) + opz_pow_n(-z,2/3)):

f_rc04 := (rs, zeta) -> phi(zeta)^3 * (AA*arctan(BB + CC*rs) + DD)/rs:

f      := (rs, zeta) -> f_rc04(rs, zeta):


# Proof by PDF that X <~ standardChiSq(2) == Y <~ exponential(1/2)

PDF_chisq := (n, x) -> x^(1/2*n-1)*exp(-1/2*x)/(2^(1/2*n))/GAMMA(1/2*n);
simplify(PDF_chisq(2,x));

PDF_exponential := (l, x) -> l*exp(-l*x);
simplify(PDF_exponential(1/2,x));

evalb(PDF_chisq(2,x) = PDF_exponential(1/2,x));


(*
 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 *)

mkappa := 0.4604:
mmu    := 0.354546875:

f0 := s -> 1 + mkappa*(1 - mkappa/(mkappa + mmu*s^2)):
f  := x -> f0(X2S_2D*x):


(*
 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: mgga_exc *)
$include "mgga_xc_b98.mpl"

(* Fitted parameters, given below Eq. 50 *)
edmgga_mu := 0.21:
edmgga_a  := 0.704:

(* Eq. 40: F_x'(0) *)
edmgga_fp0   := 27*edmgga_mu/50:
(* Eq. 27: lim_(x -> -infinity) F_x(x) *)
edmgga_fminf := 1/3 * (4*Pi^2/3)^(1/3):
(* Eq. 44 *)
edmgga_b := 2*Pi/9 * sqrt(6/5):

(* Eq. 47 *)
edmgga_c1 := edmgga_fminf:
(* Eq. 48 *)
edmgga_c2 := 1 - edmgga_c1:
(* Eq. 49 *)
edmgga_c3 := edmgga_c2*sqrt(2*edmgga_a)/(2*edmgga_b):

(* Eq. 50. There's some problem in the equation, since the first line,
1/edmgga_c3^3 * (edmgga_c3^2 - edmgga_fp0/(2*edmgga_b^2)) * edmgga_c2,
does not agree with the second line. The first line evaluates to a
negative value, which makes the functional blow up. The second line
yields values that are close to the reported ones, but Tao might have
used a more accurate numerical value in his implementation since the
agreement is not perfect. Unfortunately there's no way to check this
as he has passed away. *)
edmgga_c4 := 1/edmgga_c3^3 * (edmgga_c3^2 - 0.09834*edmgga_mu):

(* Eq. 46 *)
(* Apparently, edmgga_x can sometimes be smaller than 0,
   as Qb can be very negative. The expansion for -infinity
   has an error of 1e-13 *)
edmgga_x_large := y -> -1/(2*y) + 1/(8*y^3):

edmgga_x := Qb -> my_piecewise3(
  Qb < -1e4/edmgga_a,
  edmgga_x_large(m_min(edmgga_a*Qb, -1e-4/edmgga_a)),
  edmgga_a*Qb + sqrt(1 + (edmgga_a*Qb)^2)
):

(* Eq. 45 *)
edmgga_f_x :=  x -> edmgga_c1 + edmgga_c2*x/(1 + edmgga_c3*sqrt(x)*arcsinh(edmgga_c4*(x - 1))):

(* the evalf is absolutely necessary to avoid exceptions *)
edmgga_f := (x, u, t) -> edmgga_f_x(edmgga_x(b98_q(x, u, t))):

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


#######################################################################
# This file is part of the crlibm library, and is distributed under
# the  LGPL.
# To use:
# restart; read "sqrt.mpl";
Digits := 120:

interface(quiet=true):

read "common-procedures.mpl":
read "triple-double.mpl":
mkdir("TEMPSQRT"):

polyDegree := 4:

ERecSqrtmMin := 0.707:
ERecSqrtmMax := 1.4143:

xErrMin := evalf((1/(ERecSqrtmMax^2))):
xErrMax := evalf((1/(ERecSqrtmMin^2))):

printf("Using a %d degree polynomial for computing the iteration seed\n",polyDegree);

polyExact := numapprox[minimax](1/sqrt(x),x=1/2..2,[polyDegree,0],1,'err'):
poly := poly_exact(polyExact):
eps := numapprox[infnorm]((poly*sqrt(x))-1,x=xErrMin..xErrMax):

printf("Relative approximation error eps = 2^(%f)\n",log[2](abs(eps))):

printf("Writing tables...\n");

filename:="TEMPSQRT/sqrt.h":
fd:=fopen(filename, WRITE, TEXT):

fprintf(fd, "\n/* File generated by maple/sqrt.mpl */\n"):

for i from 0 to polyDegree do
	fprintf(fd, "\#define SQRTPOLYC%d %1.50e\n",i,coeff(poly,x,i)):
od:
fprintf(fd, "\#define TWO52 %1.50e\n",evalf(2^(52))):

fclose(fd):

filename:="TEMPSQRT/sqrt.sed":
fd:=fopen(filename, WRITE, TEXT):

fprintf(fd, "s/_epsilonApprox/%1.50e/g\n",eps):
fprintf(fd, "s/_ERecSqrtmMin/%1.50e/g\n",ERecSqrtmMin):
fprintf(fd, "s/_ERecSqrtmMax/%1.50e/g\n",ERecSqrtmMax):

for i from 0 to polyDegree do
   fprintf(fd, "s/_SQRTPOLYC%d/%1.50e/g\n",i,coeff(poly,x,i)):
od:

fclose(fd):

printf("... done\n");


######################################################################
# Maps of finite sets

`is_element/maps` := (A::set,B::set) -> proc(p)
 local dom,cod;
 global reason;

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

 # Note, if p has indices 5, 6 and 7 then indices(p) will return
 # [5],[6],[7] (an unbracketed list with each individual entry in
 # square brackets).  The construct map(op,{indices(p)}) gives
 # {5,6,7} instead.
 dom := map(op,{indices(p)});
 if dom <> A then
  reason := [convert(procname,string),"wrong domain",dom,A];
  return false;
 fi;

 # Similarly, if p[5]=55 and p[6]=66 and p[7]=77 then entries(p)
 # is [55],[66],[77] but map(op,{entries(p)}) is {55,66,77}.
 cod := map(op,{entries(p)});
 if cod minus B <> {} then
  reason := [convert(procname,string),"wrong codomain",cod,B];
  return false;
 fi;

 return true;
end;

`is_equal/maps` := (A::set,B::set) -> proc(p,q)
 local a;
 global reason;

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

 return true;
end;

`is_leq/maps` := NULL;

`random_element/maps` := (A::set,B::set) -> proc()
 local p,n,r,a;

 p := table();
 if B = {} then
  if A = {} then
   return eval(p);
  else
   return FAIL;
  fi;
 fi;

 # nops(B) gives the number of operands in B.  Here B is supposed
 # to be a set, so the operands are just the elements.
 n := nops(B);

 # Note that the line below defines r to be a function such that each
 # invocation of r() will return a new random number in the range
 # {1,...,n}.
 r := rand(1..n);

 for a in A do p[a] := B[r()]; od;

 return eval(p);
end;

# To list the maps from A to B, we let a be the first element in A,
# and put A0 = A \ {a}.  By induction we can enumerate all the maps
# p0 : A0 -> B, and we generate all possible extensions of p0 by
# sending a to each possible element of B.

`list_elements/maps` := proc(A::set,B::set)
 local A0,a,b,M0,M,p0,p;

 # The unique map from the empty set to B is represented by a
 # table with no entries; this starts the induction.
 if A = {} then
  return [table()];
 fi;

 A0 := sort([op(A)]);
 a := A0[1];
 A0 := {op(2..-1,A0)};
 M0 := `list_elements/maps`(A0,B);
 M := [];

 for b in B do
  for p0 in M0 do
   p := copy(p0);
   p[a] := b;

   # The next line is the standard way to append an element to the
   # list M.  We use op() to strip off the square brackets, and then
   # put them back in with the new element eval(p) inside.  The
   # reason for eval(p) instead of p is technical and will not be
   # explained here, except to say that p is a table and it is
   # often good to apply eval() to tables if they are going to be
   # returned as values of functions or otherwise passed around.
   M := [op(M),eval(p)];
  od;
 od;

 return M;
end;

`count_elements/maps` := (A::set,B::set) -> nops(B) ^ nops(A);

# fibres(A,B)(p) assumes that p is a function from A to B, and
# returns a table indexed by the elements of B, whose entries
# are the fibres p^{-1}{b}.

fibres := (A::set,B::set) -> proc(p)
 local F,a,b;

 F := table();
 for b in B do F[b] := {}; od;
 for a in A do F[p[a]] := {op(F[p[a]]),a}; od;
 for b in B do F[b] := sort(F[b]); od;

 return eval(F);
end;

# `id/maps`(A) is the identity map A -> A
`id/maps` := proc(A::set) local a; table({seq(a=a,a in A)}); end:

# `compose/maps`(A,B,C)(p,q) assumes that p : A -> B and q : B -> C,
# and it returns the composite q o p : A -> C.
`compose/maps` := (A::set,B::set,C::set) -> proc(p,q) local a;
  table({seq(a = q[p[a]],a in A)}); 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_x *)

a1 := 199.81:
a2 := 4.3476:
c1 := 0.8524:
c2 := 1.2264:

# This is Eq. (40) of the paper.
f0 := s -> c1*(1 - exp(-a1*s^2)) + c2*(1 - exp(-a2*s^4)):

f  := x -> f0(X2S*x):


(*
 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_x_am05_params *params;

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

am05_d     := 28.23705740248932030511071641312341561894: (* POW(CBRT(4/3) * 2*M_PI/3, 4) *)

am05_csi  := s -> (3/2 * LambertW(s^(3/2) / (2*sqrt(6))))^(2/3):
am05_fb   := s -> Pi/3 * s/(am05_csi(s) * (am05_d + am05_csi(s)^2)^(1/4)):
am05_flaa := s -> (1 + params_a_c*s^2)/(1 + params_a_c*s^2/am05_fb(s)):
am05_XX   := s -> 1 - params_a_alpha*s^2/(1 + params_a_alpha*s^2):

am05_f    := x ->  am05_XX(X2S*x) + (1 - am05_XX(X2S*x))*am05_flaa(X2S*x):

f := (rs, zeta, xt, xs0, xs1) -> gga_exchange(am05_f, rs, zeta, xs0, xs1):


# ClusterComplexRoots.mpl
#
# clusteredList := ClusterComplexRoots( rootList, tolerance=s, MaxOrder=M );
#
# Take a list rootList of complex numbers and cluster them
# according to apparent multiplicity.
#
# This routine is heuristic (the problem is hard) and is intended
# to work only up to the given maximum order (default MaxOrder is 3)
#
# The routine uses distances and a fuzz factor F[m] and only considers
# neighbouring points up to about |r[i]-r[j]| <= F[m]*s^(1/m) to be
# possible candidates for a cluster; it also uses approximate
# angle symmetry, looking for angles between adjacent roots to be
# approximately 2*Pi/m .
#
# The returned clusteredList will be a list of pairs [r,m] where
# r is the mean of the original cluster of m roots.
# -----------------------------------------------------------------------------
# (c) Robert M. Corless and Leili Rafiee Sevyeri 2020 (MIT Release licence)
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to deal
# in the Software without restriction, including without limitation the rights
# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in all
# copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
# SOFTWARE.
# -------------------------------------------------------------------------------

ClusterComplexRoots := proc( rootList::list,
                            {tolerance::numeric := Float(1,2-Digits)},
                            {MaxOrder::nonnegint := 3}, $ )
    local anglesequal,
          c, closeenough, closeNeighbours, clustered, combos, countem,
          DistanceMatrix, exactangle, finished_combos, Fuzz,
          i, j, k, m, max_radius, mean,
          n, neighbours, notInAcluster, nroots,
          phasedifference, phases, phaseorder,
          r, radius, trialcluster, trialindices, unseen_m;

    # Safety factors for distance computations.
    # They essentially replace the factor m!*B(r)/(D@@m)(f)(r)
    # which connects the root semimetric with the coefficient
    # metric; in this implementation, no account is taken of
    # the problem in this way (but it can be done in a post-
    # processing validation step).
    Fuzz := Array(2..MaxOrder);
    for m from 2 to MaxOrder do
      Fuzz[m] := evalf(2^(1/m));
    od;

    # Process small rootlists
    nroots := numelems( rootList );
    if nroots=0 then
      error "cannot cluster an empty list of roots";
    elif nroots=1 then
      # Return a cluster of 1
      return [[rootList[1],1]];
    end if;

    # nroots>=2 from now on
    # We will need distances between roots
    # -- to identify "close" roots
    # -- to ignore "far" roots
    DistanceMatrix := Matrix( nroots, nroots, 'shape'='symmetric' );
    for i to nroots do
      for j to nroots do
        DistanceMatrix[i,j] := evalf( abs( rootList[i] - rootList[j]) ) ;
      od;
    od;

    # We order neighbours from nearest to farthest
    neighbours := Array(1..nroots);
    for i to nroots do
      neighbours[i] := sort( [seq(DistanceMatrix[i,j],j=1..nroots)],
                              'output'='permutation');
      # neighbours[i] should be a list of integers such that
      # the nearest root to rootList[i] should be
      # rootList[neighbours[i][1]] (itself), the next nearest should be
      # rootList[neighbours[i][2]], and so on
    od;

    # Now begin the clustering.  We start with no clustered roots at all.
    clustered := NULL;
    # The notInAcluster roots are, at the start, all of them.
    # This states that we *assume* these are not in any m-cluster
    # for m > MaxOrder.
    notInAcluster := seq(k,k=1..nroots);
    for m from MaxOrder by -1 to 2 do
      # The sequence "notInAcluster" can shrink inside this loop
      # The list unseen_m tracks which roots we haven't yet
      # considered for any cluster at level m
      unseen_m := [notInAcluster]; # never any duplicates
      notInAcluster := NULL; # means known not to be part of any m-cluster
      # Assert nroots in clustered, notInAcluster,unseen_m +0(i)
      while numelems(unseen_m) >= m do
        # Checking for m-cycles over all elements of unseen_m
        i := unseen_m[1];
        # print("considering root", i, "or", rootList[i], "for cycles of length", m);
        unseen_m := unseen_m[2..numelems(unseen_m)]; # Assert nroots-1 + 1(i)
        # the root under consideration is rootList[i]
        # we try to find an m-cluster with this in it
        # No need to consider roots farther away than
        # twice the distance to the centre of any m-cluster
        # to this tolerance
        k := nroots;
        while k > 0 and
              DistanceMatrix[i,neighbours[i][k]] > 2*Fuzz[m]*tolerance^(1/m) do
          k := k-1;
        od;
        closeNeighbours := {seq(neighbours[i][j], j=2..k)}; # might be empty
        closeNeighbours := closeNeighbours intersect convert(unseen_m,set);
        closeNeighbours := convert(closeNeighbours,list);
        # examine all sets of m-1 close neighbours
        n := numelems(closeNeighbours); # <= k-1
        if n>=m-1 then
          # Now look at all possible choices of m-clusters
          # from the set of close neighbours
          combos := Iterator:-Combination( n, m-1 ); # at least 1
          finished_combos := false;
          for c in combos do
            # Iterator:-Combination indexes from 0 but lists index from 1
            trialindices := [i,seq(closeNeighbours[c[k]+1],k=1..m-1)];
            trialcluster := seq( rootList[k], k in trialindices );
            mean := evalf( add( r, r in [trialcluster] )/m );
            # Check the distances
            closeenough := true;
            max_radius := 0;
            for r in trialcluster do
              radius := abs(r-mean);
              max_radius := max( max_radius, radius );
              if radius > Fuzz[m]*tolerance^(1/m) then
                closeenough := false;
                break;
              end if;
            od;
            if closeenough then
              # Now check the angles
              # May be nonsense if max_radius=0
              anglesequal := true;
              if max_radius >= Float(1,1-Digits) then
                phases := [seq( argument( trialcluster[k]-mean), k=1..m) ];
                phaseorder := sort( phases, 'output'='permutation' );
                trialcluster := [seq( trialcluster[phaseorder[k]], k=1..m)];
                phases := [seq( phases[phaseorder[k]], k=1..m)];
                # Now check if all the angles are approximately equal
                exactangle := evalf(2*Pi/m);
                for k from 2 to m do
                  phasedifference := phases[k]-phases[k-1];
                  # Heuristic: what constitutes approximately equal angle?
                  if 0.75*exactangle > phasedifference or
                      phasedifference > 1.25*exactangle then
                    anglesequal := false;
                    break; # no need to consider this trial cluster further
                  end if;
                end do; # exit this loop on break for unequal angles
              end if;
              # closeenough is true, remember
              if anglesequal then
                # We have found a cluster of m roots
                clustered := [mean,m,trialcluster],clustered;
                # print([clustered], unseen_m);
                unseen_m := remove( k->member(k,convert(trialindices,set)),
                                    unseen_m );
                # print("removed",trialindices,"got",unseen_m);
                # Assert nroots + 1(i)
                break; # stop considering rootList[i]
              end if;
            # else Not close enough to be a cluster.
            end if;
            finished_combos := Rank(combos)=Number(combos);
            # Go look at the other choices of m-1 elements
          end do; # end for c in combos do; exit this loop via break for found cluster
          # stop looking at rootList[i] but keep looking for m-clusters
          if finished_combos then
            # Loop finished without finding a cluster
            notInAcluster := i,notInAcluster;
            # else We did find a cluster and have seen i
          end if;
          # print(m,"unseen_m",unseen_m);
        else
          # Not enough close neighbours to form an m-cycle
          notInAcluster := i, notInAcluster;
        end if;
      end do; # end while unseen_m has more than m elts do
      # Now look at clusters of smaller order
      for k in unseen_m do
        notInAcluster := k,notInAcluster;
      od;
      unseen_m := [];
    end do;
    # Everything left over is a 1-cluster
    notInAcluster := [notInAcluster];
    return [clustered, seq( [rootList[notInAcluster[k]],1],
                            k=1..numelems(notInAcluster)) ];
  end proc:


(*
 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_rpbe_params *params;

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

$ifdef gga_x_rpbe_params
params_a_rpbe_kappa := KAPPA_PBE:
params_a_rpbe_mu    := MU_PBE:
$endif

rpbe_f0 := s -> 1 + params_a_rpbe_kappa * (
  1 - exp(-params_a_rpbe_mu*s^2/params_a_rpbe_kappa)
):
rpbe_f  := x -> rpbe_f0(X2S*x):

f := (rs, zeta, xt, xs0, xs1) -> gga_exchange(rpbe_f, rs, zeta, xs0, xs1):


# Subspaces of (Z/p)^d are represented as pairs [U,V], where
# U and V are lists of lists, which correspond to RREF matrices.
# The rows of U are a basis for the subspace, and the rows
# of V are a basis for the annihilator.

`dim/subspaces`   := (p,d) -> U -> nops(U[1]);
`codim/subspaces` := (p,d) -> U -> nops(U[2]);

`span/subspaces` := (p,d) -> proc(U)
 local U0,r,c,i;

 if U = [] then return [[],convert(IdentityMatrix(d),listlist)]; fi;

 U0 := map(modp,U,p);
 if type(U0,list) then U0 := Matrix(U0); fi;
 r,c := Dimension(U0);
 if c <> d then error("Dimension mismatch"); fi;
 r := LinearAlgebra[Modular][MatBasis](p,U0,r,false);
 U0 := Matrix([op(1..r,convert(U0,listlist)),
               seq([0$c],i=1..c-r)]);
 LinearAlgebra[Modular][MatBasis](p,U0,r,true);
 U0 := convert(U0,listlist);
 return [[op(1..r,U0)],[op(r+1..c,U0)]];
end:

`ann/subspaces` := (p,d) -> proc(U)
 local U0;
 U0 := U;
 if type(U,list(list(integer))) then
  U0 := `span/subspaces`(p,d)(U0);
 fi;
 return `span/subspaces`(p,d)(U0[2]);
end:

`bot/subspaces`   := (p,d) -> [[],convert(IdentityMatrix(d),listlist)];

`top/subspaces`   := (p,d) -> [convert(IdentityMatrix(d),listlist),[]];

`sum/subspaces`   := (p,d) -> (U,V) -> `span/subspaces`(p,d)([op(U[1]),op(V[1])]);

`inter/subspaces` := (p,d) -> (U,V) -> `ann/subspaces` (p,d)([op(U[2]),op(V[2])]);

`is_member/subspaces` := (p,d) -> proc(u,V)
 if V[2] = [] then return true; fi;
 return is_all_zero(map(modp, Matrix(V[2]) . Vector(u),p));
end:

`is_le/subspaces` := (p,d) -> proc(U,V)
  if U[1] = [] or V[2] = [] then return true; fi;
  return is_all_zero(map(modp, Matrix(V[2]) . Transpose(Matrix(U[1])),p));
end:

`random_element/subspaces` := (p,d) -> proc()
  local r,U,i,j;
  r := rand(0..d)();
  U := [seq([seq(rand(0..p-1)(),j=1..d)],i=1..r)];
  return `span/subspaces`(p,d)(U);
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_x *)

lambda := y -> 1/2*(1 + (1 - y^2)*log((1 + y)/abs(1 - y))/(2*y)):

f := x -> 1 + lambda(X2S*x/6)*x^2/(8*K_FACTOR_C):


Primes:=[2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41, 43, 47, 53, 59]:
L:=1000;
S:=[1,7,11,13,17,19,23,29,31,37,41,43,47,49,53,59];
W:=[seq(i,i=1..ceil(L/60)-1)]:

for w in W do
	for s in S do
		n:=60*w+s;
		a:=0;

 		########3.1
		if modp(s,4)=1 then
			for x from 1 to ceil(sqrt(n)/2) do
				for y from 1 to ceil(sqrt(n)) do
					if 4*x^2+y^2=n then a:=1-a;end if;
				end do;
			end do;
		end if;

		########3.2
		if modp(s,6)=1 and modp(s,4)<>1 then
			for x from 1 to ceil(sqrt(n/3)) do
				for y from 1 to ceil(sqrt(n)) do
					if 3*x^2+y^2=n then a:=1-a;end if;
				end do;
			end do;
		end if;

		########3.3
		if modp(s,12)=11 and modp(s,6)<>1 and modp(s,4)<>1 then
			for x from 2 to n do
				for y from 1 to x-1 do
					if 3*x^2-y^2=n then a:=1-a;end if;
				end do;
			end do;
		 end if;

		##### squares
		if a=1 then
			for q in Primes while q^2<=n and a=1 do if irem(n,q^2)=0 then a:=0;fi;end do;
		end if;

		if a=1 then Primes:=[op(Primes),n]; end if;
		end do;
end do;


(*
 Copyright (C) 2017 M.A.L. Marques
               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 *)

pbepow_kappa := KAPPA_PBE:
pbepow_mu    := 0.2195149727645171:

(* pbepow_m has to be written in float format otherwise the code is converted to C
   in a numerically unstable way *)
pbepow_m     := 100.0:

(* The geometrical series 1 + pbepow_kappa/pbepow_m * add(pbepow_yy(X2S*s)^i, i=1..pbepow_m)
   is summed analytically and simplified *)
pbepow_f0 := s -> 1 - pbepow_mu*s^2 * ( ((pbepow_m * pbepow_mu * s^2) / (pbepow_m * pbepow_mu * s^2 + pbepow_kappa))^pbepow_m - 1):

pbepow_f  := x -> pbepow_f0(X2S*x):

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


!Properties from TestCase_0 that are present in this test case:
! - no matrix A
! - only bin vars on the first stage
! - standard bounds for 1st stage cont vars (if any)
! - only vector rhs is stochastic

!Properties specific for this TestCase:
! all scenarios have the same RHS
! integer vars on the 2nd stage

!These properties of are present in all TestCases:
! - MIN obj - always the case for smps files
! - 2 stages - only such problems are in scope of the research
! - only cont vars on the 2nd stage - we will solve the relaxation otherwise
! - >= constraints in subproblems - we do not care about subproblems
! - bin and cont (if any) vars on the first - int vars are prohibited

! Solution value: -17600
! Solution value 2nd stage relaxation: -17600.4
! Solution value all stages relaxation: -17900.1

TITLE
	SNDP_TestCase_14;

STOCHASTIC

SCENARIO
	SCEN := 1..3;

PROBABILITIES
	Prob[SCEN] := (0.25, 0.5, 0.25);

RANDOM DATA
	Demand[SCEN] := (5000, 5000, 5000);

STAGE1 INTEGER VARIABLES
	yc2;
	yc3;

STAGE2 VARIABLES
	x_c24;
	x_c34;
	x_a12;
	x_b12;
	x_a13;

STAGE2 INTEGER VARIABLES
	x_b13;
	x_a32;
	x_a33;

MIN	! should be min for solver
	- 13*(x_c24 + x_c34) + 2*x_a12 + 2*x_b12 + 2*x_a13 + 2*x_b13 + 1*x_a32 + 2*x_c24 + 3*x_c34 + 2000*yc2 + 2000*yc3;

SUBJECT TO
	x_a12 + x_a32 >= 2*x_c24;
	-x_a12 + -x_a32 >= -2*x_c24;

	x_a13 + x_a33 >= 2*x_c34;
	-x_a13 + -x_a33 >= -2*x_c34;

	x_b12 >= 3*x_c24;
	-x_b12 >= -3*x_c24;

	x_b13 >= 3*x_c34;
	-x_b13 >= -3*x_c34;

	-x_c24 >= -5000*yc2;
	-x_c34 >= -5000*yc3;
	-x_c24 + -x_c34 >= -Demand;

	-x_b13 + -x_a33 >= -24500.5; ! in the original problem these vars get 15K and 10K values

BOUNDS
	!x_b13 <= 100000;  ! integer should have UB to be treated as not binary in MPS
	!x_a32 <= 100000;
	!x_a33 <= 100000;
	yc2 <= 1;
	yc3 <= 1;
END


# Example from Section 5.2 of the paper

read "../ComputeIdentifiableFunctions.mpl";

model := [
     diff(xa(t), t) = -k1 * xa(t),
     diff(xb(t), t) = k1 * xa(t) - k2 * xb(t),
     diff(xc(t), t) = k2 * xb(t),
     diff(eA(t), t) = 0,
     diff(eC(t), t) = 0,
     y1(t) = eA(t) * xa(t) + eB * xb(t) + eC(t) * xc(t),
     y2(t) = xc(t),
     y3(t) = eA(t),
     y4(t) = eC(t)
]:

# Computing function identifiable from a single experiment
printf("Single-experiment identifiable functions: %a\n", SingleExperimentIdentifiableFunctions(model)):

me := MultiExperimentIdentifiableFunctions(model, simplified_generators=true):
printf("The multi-experiment identifiable functions are %a; This is not the same as for a single experiment!\n", me[3]):
printf("The bound from the theorem is %a showing that %a experiments are sufficient to identify these functions\n", me[1], me[1]):


`is_element/binary_standard_stasheff_trees` := (n::posint) -> proc(TT)
 global reason;

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

 if not(`is_binary/standard_stasheff_trees`(n)(TT)) then
  reason := [convert(procname,string),"TT is not binary",TT,reason];
  return false;
 fi;

 return true;
end:

`is_equal/binary_standard_stasheff_trees` :=
 eval(`is_equal/standard_stasheff_trees`);

`is_leq/binary_standard_stasheff_trees` :=
 eval(`is_leq/standard_stasheff_trees`);

`list_elements/binary_standard_stasheff_trees` := proc(n::posint)
 option remember;
 local L,A,UUU,VVV,UU,VV,p,i;

 if n = 0 then
  return [];
 elif n = 1 then
  return [{{1}}];
 fi;

 L := NULL;
 A := {seq(i,i=1..n)};

 for p from 1 to n-1 do
  UUU := `list_elements/binary_standard_stasheff_trees`(p);
  VVV := `list_elements/binary_standard_stasheff_trees`(n-p);
  VVV := map(VV -> map(V -> map(v -> v+p,V),VV),VVV);
  L := L,seq(seq({op(UU),op(VV),A},VV in VVV),UU in UUU);
 od;
 return [L];
end:

`random_element/binary_standard_stasheff_trees` := (n::posint) -> proc()
 local L;

 L := `list_elements/binary_standard_stasheff_trees`(n);
 L[rand(1..nops(L))()];
end:

`count_elements/binary_standard_stasheff_trees` :=
 (n::posint) -> binomial(2*(n-1),n-1)/n;


# This is the problem 11914 the American Mathematical Monthly (May 2016)
# The following sum is zero.

S := Sum(Sum(x^n*y^m*Sum((-4)^(-k)*Binomial(n-k,k-1)*Sum((-2)^(-j)*Binomial(n+1-2*k,j-1)*Binomial(m-k,3*m-j),j=1..3*m), k=1..n), n=1..infinity), m=1..infinity);

R, ord := BinomSums[sumtores](S, u);
#  -> 0, []


mobius_complex := proc()
 local T,V,E,F,R,r,v,a,mob,mob_arc,i,e;

 V := [seq(seq([i,a],a=0..2),i=0..1)];
 F := [
  seq([[0,a],[0,modp(a+1,3)],[1,a]],a=0..2),
  seq([[0,a],[0,modp(a+1,3)],[1,modp(a+1,3)]],a=0..2),
  seq([[0,a],[1,modp(a+1,3)],[1,modp(a+2,3)]],a=0..2)
 ];

 E := map(f -> ([f[1],f[2]],[f[1],f[3]],[f[2],f[3]]),F);

 T := table([]);

 T["vertices"] := V;
 T["edges"] := E;
 T["faces"] := F;
 T["max_simplices"] := T["faces"];

 T["all_simplices"] := [map(v -> [v],V),op(E),op(F)];

 v := table():
 for a from 0 to 2 do
  v[0,a] := [a/6,0];
  v[1,a] := [a/3,1];
 od:

 R := 1;
 r := 1/3:
 mob := mobius_embedding(R,r);

 mob_arc := mobius_arc(R,r);

 T["plot"] :=
  display(
   spacecurve(mob(t,1),t=0..1,colour=blue),
   plot3d(mob(t,u),t=0..1,u=0..1,style=wireframe,colour="LightGray"),
   seq(mob_arc(op(v[op(e[1])]),op(v[op(e[2])]),colour=red),e in E),
   axes=none,scaling=constrained
  );

 return eval(T);
end():

flat_mobius_complex := proc(n::posint)
 local f,g,T,V,E,F,r,v,a,i;

 f := (i) -> modp(i+1,4*n+2);
 g := (i) -> modp(i+2*n+3/2+(-1)^i/2,4*n+2);

 V := [seq(i,i=0..4*n+1)];
 E := [seq([i,f(i)],i=0..4*n+1),seq([i,g(i)],i=0..4*n+1)];
 F := [seq([i,f(i),g(i)],i=0..4*n+1)];

 T := table([]);

 T["vertices"] := V;
 T["edges"] := E;
 T["faces"] := F;
 T["max_simplices"] := T["faces"];
 T["all_simplices"] := [map(v -> [v],V),op(E),op(F)];

 T["embedding_dim"] := 3;
 T["embedding"] := table([seq(i = evalf(mobius_embedding(0.2)(i/(4*n+2),1)),i=0..4*n+1)]);

 T["plot"] := `plot/raw_simplicial_complex`(T["vertices"])(T["faces"],3,T["embedding"]);

 return eval(T);

end:


program sample14;
	/* Calculator program	*/
	/*  c n : clear & set n	*/
	/*  + n : add n			*/
	/*  - n : subtract n	*/
	/*  * n : multiply n	*/
	/*  / n : divide n		*/
	/*  o : off				*/
var com :char;
	x, y : integer;
	endflag : boolean;
begin
	writeln('   *** Calculator -- h for help ***');
	x := 0;
	endflag := false;
	while not endflag do begin
		writeln(' Please input command :');
		readln(com, y);
		if (com = 'c')  or (com = 'C') then begin
			x := y;
		end
		else if com = '+' then begin
			x := x + y;
		end
		else if com = '-' then begin
			x := x - y;
		end
		else if com = '*' then begin
			x := x * y;
		end
		else if com = '/' then begin
			x := x div y;
		end
		else if (com = 'o') or (com = 'O') then begin
			endflag := true
		end
		else begin
			writeln;
			writeln('Calculator Usage:');
			writeln('  c number : clear & set it');
			writeln('  + number : add it');
			writeln('  - number : subtract it');
			writeln('  * number : multiply it');
			writeln('  / number : divide it');
			writeln('  o        : off(terminate execution)');
			writeln
		end;
		if endflag then
			writeln('Final Result =', x)
		else
			writeln('Temporary Result =', x)
	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: lda_exc *)

params_a_alpha := 1:
$include "lda_x.mpl"

beta := rs -> (9*Pi/4)^(1/3)/(rs*M_C):
phi  := rs -> 1 - 1.5*(sqrt(1 + beta(rs)^2)/beta(rs) - arcsinh(beta(rs))/beta(rs)^2)^2:

f    := (rs, z) -> f_lda_x(rs, z)*phi(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/.
*)

(* type: work_gga_x *)

kappa := 0.8040:
mu    := 0.2195149727645171:
m     := 100:

gamm  := m*mu/kappa:
Cx    := kappa/m:

f0 := s -> 1 + add(Cx * (gamm*s^2/(1 + gamm*s^2))^i, i=1..m):

f  := x -> f0(X2S*x):


(*
 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 "lda_c_rc04.mpl"

msigma := 1.43:
malpha := 2.30:

Bs := s -> 1/(1 + msigma*s^malpha):

f_tcs := (rs, z, xt) -> f_rc04(rs, z)*Bs(X2S*2^(1/3)*xt):

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


program gcd2;

function gcd(n1: integer, n2: integer): integer;
begin
    if n2 > n1 then
    begin
        var new: integer;
        new := n2 % n1;
        n2 := new;
    end
    else
    begin
        var new: integer;
        new := n1 % n2;
        n1 := n2;
        n2 := new;
    end;

    if n2 > 0 then
    begin
        return gcd(n1, n2);
    end
    else
    begin
        return n1;
    end;
end;

begin
    var n1, n2: integer;
    read(n1);
    read(n2);
    writeln(gcd(n1, n2));
end.


# Energy Calculation for the Robot based on MDH frames
# Introduction
# Berechnung von potentieller und kinetischer Energie für den Roboter.
#
# Dateiname:
# robot -> Berechnung für allgemeinen Roboter
# tree -> Berechnung für eine beliebige Baumstruktur (ohne Schleifen)
# floatb -> floating base wird durch base twist (Geschwindigkeit der Basis) oder vollständige Orientierung (Euler-Winkel) berücksichtigt
# rotmat -> Kinematik wird mit Rotationsmatrizen berechnet
# energy -> Berechnung der Energie
# worldframe -> Berechnung der Positionen und Geschwindigkeiten im Welt-KS (KS W) anstatt im Basis-KS (KS 0)
# par1 -> Parametersatz 1 (Schwerpunkt als Parameter: SX,SY,SZ)
# Authors
# Moritz Schappler, schappler@irt.uni-hannover.de, 2016-03
# (C) Institut fuer Regelungstechnik, Leibniz Universitaet Hannover
#
# Sources
# [GautierKhalil1990] Direct Calculation of Minimum Set of Inertial Parameters of Serial Robots
# [KhalilDombre2002] Modeling, Identification and Control of Robots
# [Ortmaier2014] Vorlesungsskript Robotik I (WS 2014/15)
# [Ott2008] Cartesian Impedance Control of Redundant and Flexible-Joint Robots
# Initialization
interface(warnlevel=0): # Unterdrücke die folgende Warnung.
restart: # Gibt eine Warnung, wenn über Terminal-Maple mit read gestartet wird.
interface(warnlevel=3):
with(LinearAlgebra):
with(ArrayTools):
with(codegen):
with(CodeGeneration):
with(StringTools):
codegen_act := true:
codegen_opt := 2:
read "../helper/proc_convert_s_t":
read "../helper/proc_convert_t_s":
read "../helper/proc_MatlabExport":
read "../helper/proc_simplify2":
read "../transformation/proc_rotx":
read "../transformation/proc_roty":
read "../transformation/proc_rotz":
read "../transformation/proc_trotx":
read "../transformation/proc_troty":
read "../transformation/proc_trotz":
read "../transformation/proc_transl":
read "../transformation/proc_trafo_mdh":
read "../robot_codegen_definitions/robot_env":
read sprintf("../codeexport/%s/tmp/tree_floatb_definitions", robot_name):
read sprintf("../codeexport/%s/tmp/kinematic_constraints_maple_inert.m", robot_name):
kin_constraints_exist := kin_constraints_exist: # Laden zur Einstellung der Term-Vereinfachung
;
# Einstellungen für Term-Vereinfachungen: 0=keine, 1=E_pot, 2=auch E_kin (einzelne), 3=auch E_kin (komplett)
if not assigned(simplify_options) or simplify_options(6)=-1 then
  # Die Vereinfachung ist ein Kompromiss aus Laufzeit des Programms und Güte der Ergebnisse
  # Bei zu komplizierten Termen stürzt Maple bei der Vereinfachung unvorhersehbar ab.
  # Die folgenden Regeln sind konservative Einstellungen, damit die Code-Generierung nicht zu lange dauert.
  if not kin_constraints_exist then # ohne Zwangsbedingungen. Annahme: Bringt dann sowieso nicht so viel
    use_simplify := 0:
  else # für Systeme mit Zwangsbedingungen
    if NJ <= 7 then
      use_simplify := 3: # standardmäßig bei einfachen Systemen alle simplify-Befehle anwenden
    elif NJ <= 11 then # das ist nur eine grobe Abschätzung
      use_simplify := 2: # Simplify reduzieren (Annahme: Optimierung Gesamt-Energie dauer länger)
    else
      use_simplify := 1: # simplify-Befehle weiter begrenzen (sonst hängt Maple sich auf)
    end if:
  end if:
else
  use_simplify := simplify_options(6): # sechster Eintrag ist für Energie
end if:

# Ergebnisse der Kinematik laden (Rotationsmatrizen, Schwerpunktskoordinaten, Geschwindigkeiten)
read sprintf("../codeexport/%s/tmp/kinematics_floatb_%s_rotmat_maple.m", robot_name, base_method_name):
Trf := Trf:
Trf_c := Trf_c:
read sprintf("../codeexport/%s/tmp/kinematics_com_worldframe_floatb_%s_par1_maple.m", robot_name, base_method_name):
r_W_W_Si := r_W_W_Si:
r_W_i_Si := r_W_i_Si:
read sprintf("../codeexport/%s/tmp/velocity_worldframe_floatbase_%s_par1_maple.m", robot_name, base_method_name):
omega_W_i := omega_W_i:
rD_W_i := rD_W_i:
rD_W_Si := rD_W_Si:

# Potential Energy
U_b := Matrix(NL, 1):
U_grav := 0:
for i to NL do
  U_b[i] := -M[i, 1]*Multiply(Transpose(g_world), r_W_W_Si(1 .. 3, i)):
  printf("%s. Potentielle Energie aus Gravitation für Körper %d berechnet (im Welt-KS, Parametersatz 1).\n", \
    FormatTime("%Y-%m-%d %H:%M:%S"), i-1): #0=Basis
  # Terme vereinfachen (nur einzelne Energien und nicht die Summe.
  # Annahme: Zusammenfassung verschiedener Körper nicht zielführend
  if use_simplify>=1 then
    tmp_t1:=time(): tmp_l1 := length(U_b[i,1]):
    printf("%s. Beginne Vereinfachung für potentielle Energie (Param. 1; Körper %d). Länge: %d.\n", \
      FormatTime("%Y-%m-%d %H:%M:%S"), i-1, tmp_l1):
    U_b[i,1] := simplify2(U_b[i,1]):
    tmp_t2:=time(): tmp_l2 := length(U_b[i,1]):
    printf("%s. Terme für potentielle Energie (Param. 1) vereinfacht (Körper %d). Länge: %d->%d. Rechenzeit %1.1fs.\n", \
      FormatTime("%Y-%m-%d %H:%M:%S"), i-1, tmp_l1, tmp_l2, tmp_t2-tmp_t1):
  end if:
  U_grav := U_grav+U_b[i, 1]:
  # Terme vereinfachen
  if use_simplify>=1 then
    tmp_t1:=time(): tmp_l1 := length(U_grav):
    printf("%s. Beginne Vereinfachung für potentielle Energie (Param. 1; Summe bis Körper %d). Länge: %d.\n", \
      FormatTime("%Y-%m-%d %H:%M:%S"), i-1, tmp_l1):
    U_grav := simplify2(U_grav):
    tmp_t2:=time(): tmp_l2 := length(U_grav):
    printf("%s. Terme für potentielle Energie vereinfacht (Param. 1; Summe bis Körper %d). Länge: %d->%d. Rechenzeit %1.1fs.\n", \
      FormatTime("%Y-%m-%d %H:%M:%S"), i-1, tmp_l1, tmp_l2, tmp_t2-tmp_t1):
  end if:
end do:
# Maple Export
save U_grav, sprintf("../codeexport/%s/tmp/energy_potential_floatb_%s_worldframe_par1_maple.m", robot_name, base_method_name):
# Kinetic Energy
# Use velocities in base frame and SX,SY,SZ as a parameter
# Berechne kinetische Energie aller durch Gelenkwinkel bewegter Körper.
T_b := Matrix(NL, 1):
T := 0:
for i to NL do
  # Trägheitstensor (3x3) um den Körperschwerpunkt in Körper-KS
  I_i_Si_Tensor := Matrix([[I_i_Si[1, i], I_i_Si[2, i], I_i_Si[3, i]], [I_i_Si[2, i], I_i_Si[4, i], I_i_Si[5, i]], [I_i_Si[3, i], I_i_Si[5, i], I_i_Si[6, i]]]):
  # Rotation vom Welt-KS zum jeweiligen Körper-KS (Die Basis ist dabei laufende Nummer 1)
  R_W_i := Matrix(Trf_c(1 .. 3, 1 .. 3, i)):
  # Trägheitstensor (3x3) um den Körperschwerpunkt in Basis-KS
  I_i_W := Multiply(R_W_i, Multiply(I_i_Si_Tensor, Transpose(R_W_i))):
  T_b[i] := (1/2)*M[i, 1]*Multiply(Transpose(rD_W_Si(1 .. 3, i)), rD_W_Si(1 .. 3, i))+(1/2)*Multiply(Transpose(omega_W_i(1 .. 3, i)), Multiply(I_i_W, omega_W_i(1 .. 3, i))):
  printf("%s. Kinetische Energie für Körper %d berechnet (im Welt-KS, Parametersatz 1)\n", FormatTime("%Y-%m-%d %H:%M:%S"), i-1):#0=Basis
  # Terme vereinfachen (nur einzelne Energien und nicht die Summe.
  # Annahme: Zusammenfassung verschiedener Körper nicht zielführend
  if use_simplify>=2 then
    tmp_t1:=time(): tmp_l1 := length(T_b[i,1]):
    printf("%s. Beginne Vereinfachung für kinetische Energie (Param. 1; Körper %d). Länge: %d.\n", \
      FormatTime("%Y-%m-%d %H:%M:%S"), i-1, tmp_l1):
    T_b[i,1] := simplify2(T_b[i,1]):
    tmp_t2:=time(): tmp_l2 := length(T_b[i,1]):
    printf("%s. Terme für kinetische Energie (Param. 1) vereinfacht (Körper %d). Länge: %d->%d. Rechenzeit %1.1fs.\n", \
      FormatTime("%Y-%m-%d %H:%M:%S"), i-1, tmp_l1, tmp_l2, tmp_t2-tmp_t1):
  end if:
  T := T+T_b[i, 1]:

  # Terme vereinfachen (optional, Standardmäßig nur kinetische Energie einzelner Körper optimieren)
  # Für komplizierte Systeme hängt sich Maple hier auf.
  if use_simplify>=3 then
    tmp_t1:=time(): tmp_l1 := length(T):
    printf("%s. Beginne Vereinfachung für kinetische Energie (Param. 1; Summe bis Körper %d). Länge: %d.\n", \
      FormatTime("%Y-%m-%d %H:%M:%S"), i-1, tmp_l1):
    T := simplify2(T):
    tmp_t2:=time(): tmp_l2 := length(T):
    printf("%s. Terme für kinetische Energie (Param. 1; Summe bis Körper %d) vereinfacht. Länge: %d->%d. Rechenzeit %1.1fs\n", \
      FormatTime("%Y-%m-%d %H:%M:%S"), i-1, tmp_l1, tmp_l2, tmp_t2-tmp_t1):
  end if:
end do:
# Maple Export
save T, sprintf("../codeexport/%s/tmp/energy_kinetic_floatb_%s_worldframe_par1_maple.m", robot_name, base_method_name):
# Matlab Export
printf("%s: Energie (Param. 1) berechnet und gespeichert. Beginne Matlab-Export.\n", \
      FormatTime("%Y-%m-%d %H:%M:%S")):
# Potential Energy
# Floating Base
U_s:=convert_t_s(U_grav):
if codegen_act then
  MatlabExport(U_s, sprintf("../codeexport/%s/tmp/energy_potential_floatb_%s_worldframe_par1_matlab.m", robot_name, base_method_name), codegen_opt):
end if:
# Fixed Base
U_s_fixb:=U_s:
for i from 1 to NQB do
  U_s_fixb := subs({X_base_s[i,1]=0},U_s_fixb):
end do:
if codegen_act then
  MatlabExport(U_s_fixb, sprintf("../codeexport/%s/tmp/energy_potential_fixb_worldframe_par1_matlab.m", robot_name), codegen_opt):
end if:
# Maple Export (Fixed-Base)
save U_s_fixb, sprintf("../codeexport/%s/tmp/energy_potential_fixb_worldframe_par1_maple.m", robot_name):
# Kinetic Energy
# Floating Base
# Eliminiere die Basis-Position (nicht: Orientierung). Die kinetische Energie kann nicht davon abhängen.
# Falls die Ausdrücke doch vorkommen, liegt es daran, dass Maple diese nicht wegoptimieren konnte.
T_s:=convert_t_s(T):
for i from 1 to 3 do
  T_s := subs({X_base_s[i,1]=0},T_s):
end do:
if codegen_act then
  MatlabExport(T_s, sprintf("../codeexport/%s/tmp/energy_kinetic_floatb_%s_worldframe_par1_matlab.m", robot_name, base_method_name), codegen_opt):
end if:
# Fixed Base
T_s_fixb:=T_s:
for i from 1 to NQB do
  T_s_fixb := subs({X_base_s[i,1]=0},T_s_fixb):
end do:
for i from 1 to 6 do
  T_s_fixb := subs({V_base_s[i,1]=0},T_s_fixb):
end do:
if codegen_act then
  MatlabExport(T_s_fixb, sprintf("../codeexport/%s/tmp/energy_kinetic_fixb_worldframe_par1_matlab.m", robot_name), codegen_opt):
end if:
# Maple Export (Fixed-Base)
save T_s_fixb, sprintf("../codeexport/%s/tmp/energy_kinetic_fixb_worldframe_par1_maple.m", robot_name):


(*
 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 *)

exp4_a1 := 199.81:
exp4_a2 := 4.3476:
exp4_c1 := 0.8524:
exp4_c2 := 1.2264:

# This is Eq. (40) of the paper.
exp4_f0 := s -> exp4_c1*(1 - exp(-exp4_a1*s^2)) + exp4_c2*(1 - exp(-exp4_a2*s^4)):
exp4_f  := x -> exp4_f0(X2S*x):

f := (rs, zeta, xt, xs0, xs1) -> gga_kinetic(exp4_f, rs, zeta, xs0, xs1):


(*
 Copyright (C) 2017 M.A.L. Marques
 Copyright (C) 2018 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_x_lsrpbe_params *params;

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

lsrpbe_f0 := s -> 1 + params_a_kappa * (
  1 - exp(-params_a_mu*s^2/params_a_kappa)
) - (params_a_kappa+1)*(1 - exp(-params_a_alpha*s^2)):
lsrpbe_f  := x -> lsrpbe_f0(X2S*x):

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


(*
 Copyright (C) 2017 M.A.L. Marques
 Copyright (C) 2018 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_x_lspbe_params *params;

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

lspbe_f0 := s -> 1 + params_a_kappa*(1 - params_a_kappa/(params_a_kappa + params_a_mu*s^2))
            - (params_a_kappa+1)*(1-exp(-params_a_alpha*s^2)):
lspbe_f  := x -> lspbe_f0(X2S*x):

f := (rs, z, xt, xs0, xs1) -> gga_exchange(lspbe_f, rs, z, 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: lda_exc *)

(* eq 26 *)
a1 := -0.0357:
a2 :=  0.0562:
b1 := -0.0311:
b2 :=  2.39:

(* eq 25 *)
f := (rs, zeta) -> a1/(1 + a2*rs/RS_FACTOR)
  + b1*log((rs/RS_FACTOR + b2)/(rs/RS_FACTOR)):


(*
 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: lda_exc *)

$include "vwn.mpl"

f_vwn := (rs, z) ->
  + f_aux(A_vwn[1], b_vwn[1], c_vwn[1], x0_vwn[1], rs)
  + f_aux(A_rpa[3], b_rpa[3], c_rpa[3], x0_rpa[3], rs)*f_zeta(z)*(1 - z^4)/fpp_vwn
  - DRPA(rs, z)*f_zeta(z)*(1 - z^4)
  +  DMC(rs, z)*f_zeta(z):

f := (rs, z) -> f_vwn(rs, z):


######################################################################
# partitions(A) is the set of all partitions of A
# (Section sec-partitions)

# Partitions are represented as nonempty sets of nonempty subsets, so
# {{1,2},{3},{4,5}} is an element of partitions({1,2,3,4,5}).

`is_element/partitions` := (A::set) -> proc(pi)
 local n,T,U;
 global reason;

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

 n := nops(pi);
 if n = 0 then
  reason := [convert(procname,string),"pi is empty"];
  return false;
 fi;

 T := {};

 for U in pi do
  if U = {} then
   reason := [convert(procname,string),"pi contaisn the empty set",pi];
   return false;
  fi;

  if U minus A <> {} then
   reason := [convert(procname,string),"U is not contained in A",U,A];
   return false;
  fi;

  if T intersect U <> {} then
   reason := [convert(procname,string),"sets in pi are not disjoint",U,T];
   return false;
  fi;

  T := T union U;
 od;

 if A minus T <> {} then
  reason := [convert(procname,string),"sets in pi do not cover A",T,A];
  return false;
 fi;

 return true;
end;

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

`is_equal/partitions` := (A::set) -> (pi,rho) -> evalb(pi = rho):

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

`is_leq/partitions` := (A::set) -> proc(pi,rho)
 local T,U,ok;
 global reason;

 for T in rho do
  ok := false;
  for U in pi do
   if T minus U = {} then
    ok := true;
    break;
   fi;
  od;

  if not ok then
   reason := [convert(procname,string),"T is not contained in any block of pi",T,pi];
   return false;
  fi;
 od;

 return true;
end;

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

`random_element/partitions` := (A::set) -> proc()
 local n,m,r,t,i,a,pi;

 if A = {} then return FAIL; fi;

 n := nops(A);
 m := rand(1..n)();
 r := rand(1..m);
 t := table();
 for i from 1 to m do t[i] := NULL; od;
 for a in A do
  i := r();
  t[i] := t[i],a;
 od:

 pi := NULL;
 for i from 1 to m do
  if t[i] <> NULL then pi := pi,{t[i]}; fi;
 od;

 pi := {pi};

 return pi;
end;

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

`list_elements/partitions` := proc(A::set)
 local n,a,A0,B0,B,C,S,P,Q,rho,pi;

 n := nops(A);
 if n = 0 then return {}; fi;
 if n = 1 then return {{A}}; fi;

 A0 := sort([op(A)]);
 a := A0[1];
 A0 := {op(2..-1,A0)};
 P := {A};
 S := `list_elements/subsets`(A0);

 for B0 in S do
  B := {a,op(B0)};
  Q := `list_elements/partitions`(A minus B);
  for rho in Q do
   pi := {B,op(rho)};
   P := P,pi;
  od;
 od;

 P := [P];
 return P;
end;

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

`count_elements/partitions` := (A::set) -> combinat[bell](nops(A));

`top/partitions` := (A::set) -> `if`(A = {},FAIL,map(a -> {a},A));

`bot/partitions` := (A::set) -> `if`(A = {},FAIL,{A});


(*
 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_mgga_x *)

a2 := 146/2025:
a3 := -73/405:
a4 := 0.131957187845257783631757384393: (* DD + 100/(81*81*kappa) *)

kappa := 0.804:

xx := (p, qt) -> MU_GE*p + a2*qt*qt + a3*qt*p + a4*p*p:

f := (rs, x, t, u) -> 1 + kappa - \
  kappa^2/(kappa + xx(X2S^2*x^2, 6*X2S^2*t - 9/20 - X2S^2*x^2/12)):


`find_bases/homology` := proc(H)
 local dM,dZM,nC,nZ,nB,nH,d,d_max,i,j,r,LM,ZM,BZM,BM,HZM,HM,
  S,M0,M1,M2,M3,pivots,non_pivots;

 dM := H[differential_matrix]:
 nC := eval(H['chain_number']);
 d_max := H['dim'];
 for d from 0 to d_max do
  if d = 0 then
   LM[0] := Matrix(nC[0],0):
   ZM[0] := IdentityMatrix(nC[0]):
   nZ[0] := nC[0];
  else
   ZM[d] := [op(NullSpace(dM[d]))];
   nZ[d] := nops(ZM[d]);
   ZM[d] := Matrix(nC[d],nZ[d],ZM[d]);
  fi;

  if d = d_max then
   BZM[d] := Matrix(nZ[d],0);
   BM[d] := Matrix(nC[d],0);
   nB[d] := 0;
   HZM[d] := IdentityMatrix(nZ[d]);
   HM[d] := ZM[d];
   nH[d] := nZ[d];
  else
   dZM[d+1] := LinearSolve(ZM[d],dM[d+1]);
   S := LUDecomposition(Transpose(dZM[d+1]),output=['P','L','U1','R']):
   M0,M1 := Transpose(S[4]),Transpose(S[1].S[2].S[3]):
   pivots := {}:
   j := 1:
   i := 1:
   while i <= nC[d+1] do
    while j <= nZ[d] and M0[j,i] = 0 do j := j+1; od;
    if j <= nZ[d] then pivots := {op(pivots),j}; fi;
    i := i+1;
   od:
   r := nops(pivots);
   nB[d] := r;
   nH[d] := nZ[d]-r;

   non_pivots := {seq(j,j=1..nZ[d])} minus pivots;

   M2 := Matrix(nZ[d],nZ[d]-r);
   for i from 1 to nZ[d]-r do M2[non_pivots[i],i] := 1; od:
   M3 := SubMatrix(M0,1..nZ[d],1..r);
   HM[d] := ZM[d] . M2;
   BM[d] := ZM[d] . M3;
   ZM[d] := <HM[d]|BM[d]>;
   HZM[d] := <IdentityMatrix(nH[d]),Matrix(nZ[d]-nH[d],nH[d])>;
   BZM[d] := <Matrix(nZ[d]-nB[d],nB[d]),IdentityMatrix(nB[d])>;
   LM[d+1] := (1/M1).<IdentityMatrix(r),Matrix(nC[d+1]-r,r)>;
  fi;
 od:

 H['cycle_matrix'] := eval(ZM);
 H['boundary_matrix'] := eval(BM);
 H['boundary_cycle_matrix'] := eval(BZM);
 H['boundary_lift_matrix'] := eval(LM);
 H['homology_matrix'] := eval(HM);
 H['homology_cycle_matrix'] := eval(HZM);

 H['cycle_number'] := eval(nZ);
 H['boundary_number'] := eval(nB);
 H['homology_number'] := eval(nH);

 return NULL;
end:

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

`check_bases/homology` := proc(H)
 local dM,dZM,nC,nZ,nB,nH,d,d_max,i,j,r,LM,ZM,BZM,BM,HZM,HM,
  checks;

 nC  := eval(H['chain_number']);
 nZ  := eval(H['cycle_number']);
 nB  := eval(H['boundary_number']);
 nH  := eval(H['homology_number']);
 ZM  := eval(H['cycle_matrix']);
 BM  := eval(H['boundary_matrix']);
 BZM := eval(H['boundary_cycle_matrix']);
 LM  := eval(H['boundary_lift_matrix']);
 HM  := eval(H['homology_matrix']);
 HZM := eval(H['homology_cycle_matrix']);
 d_max := H['dim'];
 dM := eval(H['differential_matrix']):

 for d from 0 to d_max do
  checks := [
   [Dimension( ZM[d])] = [nC[d],nZ[d]],
   [Dimension( BM[d])] = [nC[d],nB[d]],
   [Dimension(BZM[d])] = [nZ[d],nB[d]],
   [Dimension( LM[d])] = [nC[d],`if`(d>0,nB[d-1],0)],
   [Dimension( HM[d])] = [nC[d],nH[d]],
   [Dimension(HZM[d])] = [nZ[d],nH[d]],
   nC[d] = nH[d] + nB[d] + `if`(d>0,nB[d-1],0),
   nH[d] = H['betti_number'][d]
  ];

  if not(`and`(op(map(evalb,checks)))) then
   print([d,checks]);
   return false;
  fi;
 od:

 for d from 1 to d_max do
  checks := [
   Equal(dM[d] . ZM[d],Matrix(nC[d-1],nZ[d])),
   Equal(dM[d] . BM[d],Matrix(nC[d-1],nB[d])),
   Equal(dM[d] . LM[d],BM[d-1]),
   Rank(dM[d]) = nB[d-1],
   Rank(ZM[d]) = nZ[d],
   Rank(BM[d]) = nB[d],
   Rank(HM[d]) = nH[d],
   Rank(BZM[d]) = nB[d],
   Rank(HZM[d]) = nH[d]
  ];
  if not(`and`(op(map(evalb,checks)))) then
   print([d,checks]);
   return false;
  fi;
 od:
 return true;
end:

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

`vec/chains` := (H) -> (d::nonnegint) -> proc(u)
 local v,i,uc,uv;

 if u = 0 then
  return Vector(H['chain_number'][d]);
 elif type(u,`+`) then
  # Slightly convoluted because of funny behaviour of + on vectors
  return `+`(op(map(`vec/chains`(H)(d),[op(u)])));
 elif type(u,`*`) then
  uc,uv := selectremove(type,u,rational);
  if uc <> 1 then
   return uc * `vec/chains`(H)(d)(uv);
  fi;
 elif type(u,specfunc(chain)) then
  v := Vector(H['chain_number'][d]);
  i := H['chain_index'][d][u];
  v[i] := 1;
  return v;
 fi;
 return 'procname'(args);
end:

`vec/cycles/vec` := (H) -> (d::nonnegint) -> proc(v)
 LinearSolve(H['cycle_matrix'][d],v);
end:

`vec/cycles` := (H) -> (d::nonnegint) -> proc(u)
 `vec/cycles/vec`(H)(d)(`vec/chains`(H)(d)(u));
end:

`vec/homology/vec` := (H) -> (d::nonnegint) -> proc(v)
 SubVector(LinearSolve(H['cycle_matrix'][d],v),1..H['homology_number'][d]);
end:

`vec/homology` := (H) -> (d::nonnegint) -> proc(u)
 `vec/homology/vec`(H)(d)(`vec/chains`(H)(d)(u));
end:

`basis/homology` := (H) -> proc(d::nonnegint)
 convert(Transpose(H['homology_matrix'][d]) . Vector(H['chains'][d]),list);
end:

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

is_homology_sphere := proc(H,d_)
 local d,d1,b,i;
 d1 := H['dim'];
 if nargs > 1 then
  d := d_;
 else
  d := d1;
 fi;
 b := eval(H['betti_number']);

 if d = -1 then # The -1 sphere is empty
  return evalb(d1 = -1);
 fi;

 for i from 0 to d1 do
  if i <> 0 and i <> d and b[i] <> 0 then
   return false;
  fi;
 od;

 if d = 0 then
  return evalb(b[0] = 2);
 else
  return evalb(b[0] = 1 and b[d] = 1);
 fi;
end:

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

is_homology_bouquet := proc(H,d,r)
 local d1,b,i;
 d1 := H['dim'];
 b := eval(H['betti_number']);

 for i from 0 to d1 do
  if i <> 0 and i <> d and b[i] <> 0 then
   return false;
  fi;
 od;

 if d = 0 then
  return evalb(b[0] = r+1);
 else
  return evalb(b[0] = 1 and b[d] = r);
 fi;
end:

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

is_homology_acyclic := proc(H)
 local d1,b,i;
 d1 := H['dim'];
 if d1 = -1 then return false; fi;

 b := eval(H['betti_number']);
 if b[0] <> 1 then return false; fi;

 for i from 1 to d1 do
  if b[i] <> 0 then
   return false;
  fi;
 od;

 return true;
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 *)

htbs_s1 := 0.6:
htbs_s2 := 2.6:

(* The equations to solve in order to obtain the coeficients cc are
  G(s1) = 0
  G(s2) = 1
 G'(s1) = 0
 G'(s2) = 0
G''(s1) = 0
G''(s2) = 0
*)

htbs_cc0 :=  htbs_s1^3*(htbs_s1^2 - 5*htbs_s1*htbs_s2 + 10*htbs_s2^2)/(htbs_s1 - htbs_s2)^5:
htbs_cc1 := -30*htbs_s1^2*htbs_s2^2/(htbs_s1 - htbs_s2)^5:
htbs_cc2 :=  30*htbs_s1*htbs_s2*(htbs_s1 + htbs_s2)/(htbs_s1 - htbs_s2)^5:
htbs_cc3 := -10*(htbs_s1^2 + 4*htbs_s1*htbs_s2 + htbs_s2^2)/(htbs_s1 - htbs_s2)^5:
htbs_cc4 :=  15*(htbs_s1 + htbs_s2)/(htbs_s1 - htbs_s2)^5:
htbs_cc5 := -6/(htbs_s1 - htbs_s2)^5:

$define gga_x_rpbe_params
$include "gga_x_rpbe.mpl"
$include "gga_x_wc.mpl"

htbs_g := s -> htbs_cc0 + htbs_cc1*s + htbs_cc2*s^2 + htbs_cc3*s^3 + htbs_cc4*s^4 + htbs_cc5*s^5:

htbs_f0 := s -> my_piecewise3(
   s < htbs_s1, wc_f0(s),
   my_piecewise3(s > htbs_s2, rpbe_f0(s), htbs_g(s)*rpbe_f0(s) + (1 - htbs_g(s))*wc_f0(s))
):

htbs_f  := x -> htbs_f0(X2S*x):

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


# Proof by PDF that
# If R ~ rayleigh(2) then R^2 ~ stdChiSq(2)

PDF_rayleigh := (a, x) -> 2*x*exp(-x^2/a)/a;

# Transform on random variable is f(R)=R^2. Inverse function is g(x) = sqrt(x)
PDF_transform := (x) -> PDF_rayleigh(2,sqrt(x))*diff(sqrt(x),x);

PDF_chisq := (n, x) -> x^(1/2*n-1)*exp(-1/2*x)/(2^(1/2*n))/GAMMA(1/2*n);
simplify(PDF_chisq(2,x));

evalb(PDF_chisq(2,x) = PDF_transform(x));


#Symetry operators#

#I need Kw, the superN2symetry operator

Kzij:= proc(poly, i, j, forceVars:=1)
    local p_poly;
    p_poly:= sort(subs({z||i = z||j, z||j = z||i}, poly));
    return p_poly;
end proc:

Kscrypt_ij:= proc(poly, ijvec)
    local KsijPoly, i,j;
    i:= ijvec[1];
    j:= ijvec[2];
	KsijPoly:= sort(subs({z||i = z||j, z||j = z||i, theta||i = theta||j, theta||j= theta||i, phi||i=phi||j, phi||j = phi||i}, poly));
    return KsijPoly;
end proc:

Ksigma_j:= proc(poly, someSet)
    local sigma_j, sigma_1, non_fixed_points, permVect, KsigmaPoly, RcycleIndex, theSubSeq, Ksigma_jPoly, table_index;
    sigma_j:= someSet;
    sigma_1:= [seq(i, i=1..nops(someSet))];
    non_fixed_points:= map(x -> if sigma_j[x]=x then NULL; else x; end if, [seq(i, i=1..nops(someSet))]);
    permVect:= [seq( [  z||(sigma_1[k]) = z||(sigma_j[k]), phi||(sigma_1[k]) = phi||(sigma_j[k]), theta||(sigma_1[k]) = theta||(sigma_j[k])  ], k in non_fixed_points )];
    permVect:= Flatten(permVect);
    KsigmaPoly:= subs(permVect, poly);
    return KsigmaPoly;
end proc:
Kw:= proc(poly, forceVars:=0)
    # alias K_omega
	#Somme sur toutes les permutations de S_N
#Ajout pour obtenir l<action diagonale seulement
    local NbVars, Vars, N, KwPoly, permutations;
	Vars:= giveVars(poly);
	#print(Vars);
	#print(poly);
	NbVars:= max(nops(Vars[1]), nops(Vars[2]), nops(Vars[3])); #Number of variables, (particles in CMS)
	if forceVars <> 0 then N:= forceVars; else N:=NbVars; end if;
	if N < NbVars then print(`Error, not enough variables`); N:= NbVars; end if;
	permutations:= permute(N);
    	#ici
	KwPoly:= map(onePerm->sort(expand(Ksigma_j(poly, onePerm))), permutations);
	#keeping only distinct permutations
	#KwPoly:= map(sort,KwPoly);
	KwPoly:= MakeUnique(KwPoly);
	KwPoly:= add(k, k in KwPoly);
	return KwPoly;
end proc:
kappa_ij:= proc(poly, i,j)
	local kappaij;
	kappaij:= sort(subs({phi||i = phi||j, phi||j=phi||i, theta||i=theta||j, theta||j=theta||i}, poly));
	return kappaij;
end proc:
MakeSubListFromList:= proc( identity_list, permutation_list)
	return [ seq( z||(identity_list[k]) = z||(permutation_list[k]), k=1..nops(identity_list))];
end proc:
AntiSymetrize:= proc(poly, variables_indices::list)
	local Apoly, perms_of_poly, subs_list, omega_sign, omega_perm, identity_perm, nbVars;
	if nops(variables_indices) < 2 then return poly; end if;
	nbVars:= nops(variables_indices);
	identity_perm:= variables_indices;
	omega_perm:= permute(variables_indices);
	omega_sign:= map(x-> sign_of_permutation(x), omega_perm);
	subs_list := map(x-> MakeSubListFromList(identity_perm, x), omega_perm);
	perms_of_poly:= map(x-> subs(x, poly), subs_list);
	Apoly:= add( omega_sign[k]*perms_of_poly[k], k=1..nops(omega_perm));
	return Apoly;
end proc:

Var_Symmetrize:= proc(poly, variables_indices::list)
	local Spoly, perms_of_poly, subs_list, omega_sign, omega_perm, identity_perm, nbVars;
	if nops(variables_indices) < 2 then return poly; end if;
	nbVars:= nops(variables_indices);
	identity_perm:= variables_indices;
	omega_perm:= permute(variables_indices);
	subs_list := map(x-> MakeSubListFromList(identity_perm, x), omega_perm);
	perms_of_poly:= map(x-> subs(x, poly), subs_list);
	Spoly:= add(perms_of_poly[k], k=1..nops(omega_perm));
	return Spoly;
end proc:
# Dunkl-Cherednik
Dunkl_i_n:= proc(i, n, poly, Nin:=0, parameter:= beta)
    local something, Vars, N, term1, term2, term3, term4, Dpoly, beta;
    option remember;
	#The Dunkl-like-Cherednik-... operator, still pretty clear code
	# i: the Dunkl index, n: the exponent, Nin: number of variables, parameter : beta, 1/alpha ...
	if n = 0 then return poly; end if;
	if n < 0 then return 0; end if;
	Vars:= giveVars(poly);
	N:= max(nops(Vars[1]), nops(Vars[2]), nops(Vars[3])); #Number of variables, (particles in CMS)
    	if Nin > N then N:= Nin; end if;
	if parameter <> beta then beta := parameter end if;
	term1:= z||i * diff(poly, z||i);
	term2:= beta*add(z||i/(z||i - z||j)*(poly- Kzij(poly,i,j)), j in seq(k, k=(i-1)..1, -1));
	term3:= beta*add(z||j/(z||i - z||j)*(poly- Kzij(poly,i,j)), j in seq(k, k=(i+1)..N, 1));
	term4:= -1*beta*(i-1)*poly;
	Dpoly:= factor(term1 + term2+ term3 + term4);

	if n=1 then return Dpoly; end if;
	if n>1 then return Dunkl_i_n(i,n-1, expand(sort(Dpoly)), Nin, beta); end if;
end proc:

sign_of_permutation:= proc(L::list)
	local n, N, i, j;

	n:=nops(L);
	if nops(convert(L,set))=n then
		N:=0;
		for i to n-1 do
			for j from i+1 to n do
				if L[i]>L[j] then N:=N+1; fi;
			end do;
		end do;
	else print(`Invalid input`);
	end if;

	return (-1)^N;
end proc:

#Operations regarding the representation of S_N only with the generators s_i
get_list_perm_rep:= proc(sigma, N)
	return map(x->PermApply(sigma,x), [seq(k, k=1..N)]);
end proc:

inversion_number:= proc(k, a_list)
	local inversion_number, chopped_list, inversions;
	if k = nops(a_list) then return 0; end if;
	if nops(a_list) = 0 then return 0; end if;
	chopped_list:= a_list[(k+1)..-1];
	inversions:= map(x-> if x < a_list[k] then 1; else 0; end if, chopped_list);
	return add(l, l in inversions);
end proc:

Total_inversions:= proc(a_list)
	local all_inversions;
	all_inversions:=map(x->inversion_number(x,a_list), [seq(k, k=1..(nops(a_list)-1))]);
	return add(k, k in all_inversions);
end proc:

gen_coxeter_rep_of_SN:=proc(N)
	local all_perms, adj_rep, generators, longest_chain, N_terms, permutations, number_of_inversions, perms_with_numb_of_inv, wanted_perms, choose_from, choices, numb_of_inv, new_elements, stop_it, a_choice, serie_of_perm, effective_perm, permuted, where_is_it; remember;
	#Trivial terms [0] is the identity and is not included in the generators;
	generators:= [ seq([k], k=1..(N-1))];
	adj_rep:= [[0],op(generators)];
	#This is the chain that reverses completly [1...N],
	#The idea is that you carry the 1 up to the end, then carry the 2 up to the 1, and so on and so forth
	#We see that this as exactly N(N-1)/2 terms, just like the maximal number of inversions.
	longest_chain:= [ seq(seq( j, j=1..i), i=(N-1)..1,-1)];
	adj_rep:=[op(adj_rep), longest_chain];
	N_terms:= [seq(k, k=1..N)];
	permutations:= permute(N);
	number_of_inversions:= map(Total_inversions, permutations);
	#We start the folling loop at 2 since we have the identity and the generators which have
	#total number of inversion of 0 and 1
	#We also skip the last length in the number of inversion since we have longest_chain
	for numb_of_inv from 2 to (N*(N-1)/2-1) do
		perms_with_numb_of_inv := ListTools:-SearchAll(numb_of_inv, number_of_inversions);
		wanted_perms := map(x-> op(x,permutations), [perms_with_numb_of_inv]);
		choose_from:= [ seq( op(generators), k=1..ceil(numb_of_inv/2)) ];
		choices:= permute(choose_from, numb_of_inv);
		choices:= map(void_redundant_list, choices);
		new_elements:=[];
		stop_it:= nops(wanted_perms);
		for a_choice in choices do
			serie_of_perm:= list_of_index_to_perm(a_choice);
			effective_perm:= prod_of_perm(serie_of_perm);
			permuted:= get_list_perm_rep(effective_perm, N);
			where_is_it:=ListTools:-Search(permuted, wanted_perms);
			if where_is_it <> 0 then
				new_elements:= [op(new_elements), a_choice];
				wanted_perms:= subsop(where_is_it=NULL, wanted_perms);
			end if;
			if nops(new_ele) = stop_it then break; end if;
		end do:
		adj_rep:=[op(adj_rep), op(new_elements)];
	end do:
		adj_rep:= map(x-> Flatten(x), adj_rep);
	return adj_rep;
end proc:

restricted_coxeter_rep:= proc(n1,n2,N)
	local SNrep, unallowed, valid_terms;
	SNrep:= gen_coxeter_rep_of_SN(N);
	#We remove the identity
	#SNrep:= SNrep[2..-1];
	unallowed:= { seq(k, k=1..(n1-1)), seq(k, k=(n2)..N)};
	valid_terms:=map(x-> if {op(x)} intersect unallowed = {} then x; else NULL; end if, SNrep);
	return valid_terms;
end proc:

SNcheckCoxeter:= proc(mbarbar, mbar, mubar, N)
	local S1, S2, S3, S4, Stot, doneS, Scheck;
	S1:= restricted_coxeter_rep(1,mbarbar,N);
	S2:= restricted_coxeter_rep(1+mbarbar,mbarbar+mbar,N);
	S3:= restricted_coxeter_rep(1+mbarbar+mbar,mbarbar+mbar+mubar,N);
	S4:= restricted_coxeter_rep(1+mbarbar+mbar+mubar,N,N);
	Stot:= {op(gen_coxeter_rep_of_SN(N))};
	doneS:= {op(S1), op(S2), op(S3), op(S4)};
	Scheck:= Stot minus doneS;
	Scheck:= [[0], op(Scheck)];
	return Scheck;
end proc:

void_redundant_list:= proc(list)
	local k;
	for k from 1 to nops(list)-1 do
		if list[k] = list[k+1] then return NULL;
		elif k+3 < nops(list) then
			if list[k..k+1] = list[k+2..k+3] then return NULL; end if;
		end if
	end do:
	return list;
end proc:

index_coxeter_gen_to_perm:= proc(a_gen)
	local the_val;
	the_val:= op(a_gen);
	return Perm([[the_val, the_val+1]]);
end proc:

list_of_index_to_perm:= proc(a_list)
	return map(index_coxeter_gen_to_perm, a_list);
end proc:

prod_of_perm:= proc(list_of_perm)
	local k, out;
	out:= Perm([]);
	for k from 1 to nops(list_of_perm) do
		out:=PermProduct(out,list_of_perm[k]);
	end do:
end proc:

#Operators related to nsMacdo
#T_sigma operation
opTi:= proc(i, expr_z, N)
	local expr, out, out1, out2, out2b;
	if i = N then return 0; end if;
	if i = 0 then return expr_z; end if;
	expr:= expr_z;
	out1:= t*expr;
	out2:= ((t*z||i - z||(i+1))/(z||i-z||(i+1)));
	out2b:= Kzij(expr, i, i+1) - expr;
	out2:= out2*out2b;
	out:= out1 + out2;
#	out:= t*expr + ((t*z||i - z||(i+1))/(z||i-z||(i+1)))*(Kzij(expr,i, i+1) - expr);
	#out:= simplify(factor(out));
	return out;
end proc:

inv_opTi:= proc(i, expr_z, N)
	local expr, out;
	return simplify(factor((t^(-1) - 1)*expr_z + t^(-1)*opTi(i, expr_z, N)));
end proc:

opT_sigma:= proc(sigma, expr, N)
	local out,k;
	out:= expr;
	for k from 1 to nops(sigma) do
		out:= factor(opTi(sigma[-k], out, N));
	end do:
	return out;
end proc:

tSymmetrize:= proc(expr_z, N, n1:=0, n2:=0)
	local coxeterSN, out, sigma;
	if n1 = 0 then
		coxeterSN:= gen_coxeter_rep_of_SN(N);
	else
		coxeterSN:= restricted_coxeter_rep(n1,n2,N);
	end if;
	out:= 0;
	for sigma in coxeterSN do
		out:= out + opT_sigma(sigma, expr_z,N);
	end do:
	out:= factor(out);
	return out;
end proc:
tVandermonde:= proc(the_range, remove_t:=0)
	local N, out;
	N:= the_range[2]-the_range[1];
	out:= t^(-N*(N-1)/2)*mul(mul( t*z||i - z||j, i=the_range[1]..(j-1)), j=the_range[1]..the_range[2]);
	if remove_t <> 0 then out:= subs(t=1, out); end if;
	return out;
end proc:
tantiSymmetrize:= proc(expr_z, n1:=0, n2:=0)
	local coxeterSN, out, sigma;
	out:= AntiSymetrize(expr_z, [seq(k,k=n1..n2)]);
	out:= tVandermonde([n1,n2])/tVandermonde([n1,n2],1)*out;
	out:= factor(out);
	return out;
end proc:
bkp_tantiSymmetrize:= proc(expr_z, N, n1:=0, n2:=0)
	local coxeterSN, out, sigma, permsign;
	if n1 = 0 then
		coxeterSN:= gen_coxeter_rep_of_SN(N);
	else
		coxeterSN:= restricted_coxeter_rep(n1,n2,N);
	end if;
	out:= 0;
	for sigma in coxeterSN do
		permsign:= nops(sigma);
		out:= out + (-1*t)^permsign*opT_sigma(sigma, expr_z,N);
	end do:
	out:= factor(out);
	return out;
end proc:
apply_sigma_si:= proc(expr, sigma)
	local out, k,i;
	if sigma = [0] then return expr; end if;
	out:= expr;
	for k from 1 to nops(sigma) do
		i := sigma[-k];
		out:= Kscrypt_ij(out, [i, i+1])
	end do:
	return out;
end proc:

var_omega:= proc(expr, N)
	local out, k;
	out:= opTaui(1,expr);
	for k from 1 to (N-1) do
		out:= Kzij(out,k,k+1);
	end do:
	return out;
end proc:

opTaui:= proc(i,expr)
	return factor(subs(z||i = q*z||i, expr));
end proc:

opYi:= proc(i, expr, N)
	local out, k;
	out:=expr;
	if i > 1 then
		for k from (i-1) to 1 by -1 do
			out:= inv_opTi(k, out, N);
		end do:
	end if;
	out:= var_omega(out, N);
	if i <> N then
		for k from (N-1) to i by -1 do
			out:= opTi(k,out, N);
		end do:
	end if;
	out:=factor(t^(-N+i)*out);
	return out;
end proc:

eigen_val_opYi:= proc(i, eta)
	local qexp,leta1,leta2,leta, out;
	qexp:= eta[i];
	if i >1 then
		leta1:= map(x-> if x>= eta[i] then 1; else 0; end if, eta[1..(i-1)]);
	else
		leta1:=0;
	end if;
	if i<nops(eta) then
		leta2:= map(x-> if x>eta[i] then 1; else 0; end if, eta[(i+1)..-1]);
	else
		leta2:= 0;
	end if;
	leta:= add(k, k in leta1) + add(k, k in leta2);
	out:= q^(qexp)*t^(-leta);
	return out;
end proc:


(*
 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 *)

theta0 := 1.0008:
theta1 := 0.1926:
theta2 := 1.8962:

f0 := s -> s^2/(1 + s)^2:
f  := x -> theta0 + f0(X2S*x)* (theta1 + f0(X2S*x) * theta2):


(*
 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 *)

coeffs_beefvdw := [
   1.516501714e0,   4.413532099e-1, -9.182135241e-2, -2.352754331e-2,
   3.418828455e-2,  2.411870076e-3, -1.416381352e-2,  6.975895581e-4,
   9.859205137e-3, -6.737855051e-3, -1.573330824e-3,  5.036146253e-3,
  -2.569472453e-3, -9.874953976e-4,  2.033722895e-3, -8.018718848e-4,
  -6.688078723e-4,  1.030936331e-3, -3.673838660e-4, -4.213635394e-4,
   5.761607992e-4, -8.346503735e-5, -4.458447585e-4,  4.601290092e-4,
  -5.231775398e-6, -4.239570471e-4,  3.750190679e-4,  2.114938125e-5,
  -1.904911565e-4,  7.384362421e-5
]:

k  := 4:
xi := p -> 2*p/(k + p) - 1:

with(orthopoly):
f  := x -> add(coeffs_beefvdw[i]*P(i-1, xi(X2S^2*x^2)), i=1..30):


(*
 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 *)

$define xc_dimensions_2d

_2d_b86_mgc_beta  := 0.003317:
_2d_b86_mgc_gamma := 0.008323:

_2d_b86_mgc_f := x -> 1 + _2d_b86_mgc_beta/X_FACTOR_2D_C*x^2/(1 + _2d_b86_mgc_gamma*x^2)^(3/4):

f := (rs, zeta, xt, xs0, xs1) -> gga_exchange(_2d_b86_mgc_f, 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: work_gga_x *)

mu    := 0.0617:
kappa := 1.245:
alpha := 0.0483:

f0 := s -> 1 + mu*s^2*exp(-alpha*s^2) + kappa*(1 - exp(-1/2*alpha*s^2)):
f  := x -> f0(X2S*x):


with(Groebner):
with(PolynomialIdeals):

J := PolynomialIdeal({x0^2 - x0 + 2*x1^2 + 2*x2^2 + 2*x3^2 + 2*x4^2 + 2*x5^2 + 2*x6^2 + 2*x7^2 + 2*x8^2,
2*x0*x1 + 2*x1*x2 - x1 + 2*x2*x3 + 2*x3*x4 + 2*x4*x5 + 2*x5*x6 + 2*x6*x7 + 2*x7*x8, 2*x0*x2 + x1^2 + 2*x1*x3 + 2*x2*x4 - x2 + 2*x3*x5 + 2*x4*x6 + 2*x5*x7 + 2*x6*x8,
2*x0*x3 + 2*x1*x2 + 2*x1*x4 + 2*x2*x5 + 2*x3*x6 - x3 + 2*x4*x7 + 2*x5*x8,
2*x0*x4 + 2*x1*x3 + 2*x1*x5 + x2^2 + 2*x2*x6 + 2*x3*x7 + 2*x4*x8 - x4,
2*x0*x5 + 2*x1*x4 + 2*x1*x6 + 2*x2*x3 + 2*x2*x7 + 2*x3*x8 - x5,
2*x0*x6 + 2*x1*x5 + 2*x1*x7 + 2*x2*x4 + 2*x2*x8 + x3^2 - x6,
2*x0*x7 + 2*x1*x6 + 2*x1*x8 + 2*x2*x5 + 2*x3*x4 - x7,
x0 + 2*x1 + 2*x2 + 2*x3 + 2*x4 + 2*x5 + 2*x6 + 2*x7 + 2*x8 - 1}):
st := time[real]():
Basis(J, tdeg(x0,x1,x2,x3,x4,x5,x6)):
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: gga_exc *)

$define gga_x_pbe_tca_params
$include "gga_x_pbe.mpl"

$define gga_x_pw91_params
$include "gga_x_pw91.mpl"

bpccac_malpha :=  1:
bpccac_mbeta  := 19:

bpccac_fab := x -> 1/(1 + exp(-bpccac_malpha*(x - bpccac_mbeta))):
bpccac_f   := x -> (1 - bpccac_fab(x))*pbe_f(x) + bpccac_fab(x)*pw91_f(x):

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


function pascal(n)
    if n < 7 then
        field_width = 4
    else
        field_width = floor((lgamma(n+1) - 2*lgamma((n+1)/2))/log(10) + 1)
        if field_width mod 2 == 1 then
            field_width = field_width + 1
        end
    end
    line_width = (n+1)*field_width
    p = list(n+1)
    for i in 0:n
        p[i] = 1
	for j in i-1:1:-1
	    p[j] = p[j-1] + p[j]
	end
        s = ""
	for j in 0:i
	    s = s + center(ffmt(p[j], 0), field_width)
	end
	center(s, line_width)
    end
end

pascal(13)


(*
 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 *)

params_a_beta  := 0:
params_a_alpha := 0.8:
$include "gga_c_zpbeint.mpl"

(* parameters for beta of SG4, b0 = 3 mu^MGE2/pi^2, mu^MGE2 = 0.26 *)
sg4_b0    := 3*0.262/Pi^2:
sg4_sigma := 0.07:

(* we redefine beta here *)
mbeta := (rs, t) -> sg4_b0 + sg4_sigma*t*(1 - exp(-rs^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: work_mgga_x *)

params_a_mu := MU_GE:
params_a_b  := 0.4:
params_a_c  := 2.14951:
params_a_e  := 1.987:

mgamma      := 0.000023:
ff          := 3:

mkappa := (x, t) ->
  1/(mgamma/params_a_mu^2 + mgamma/params_a_mu + 1):

$include "tpss_x.mpl"

(* Equation (8) *)

f   := (rs, x, t, u) -> 1 + fx(x, t)*exp(-mgamma*fx(x, t)/params_a_mu)/(1 + fx(x, t)) \
    + (1 - exp(-mgamma*fx(x, t)^2/params_a_mu^2))*(params_a_mu/fx(x, t) - 1):


(*
 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 *)

$define lda_c_pw_params
$define lda_c_pw_modified_params
$include "lda_c_pw.mpl"

malpha := 2.804:
mgamma := 0.8098:

XX := s -> 1/(1 + malpha*s^2):
ff := s -> XX(s) + mgamma*(1 - XX(s)):

f := (rs, z, xt, xs0, xs1) -> f_pw(rs, z)*(
  + (1 + z)/2 * ff(X2S*xs0)
  + (1 - z)/2 * ff(X2S*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: lda_exc *)
(* prefix:
  lda_c_hl_params *params;

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

$ifdef lda_c_vbh_params
params_a_hl_r := [30, 75.0]:
params_a_hl_c := [0.0252, 0.0127]:
$endif

hl_xx := (k, rs) -> rs/params_a_hl_r[k]:
hl_f0 := (k, rs) -> -params_a_hl_c[k]*
  ((1 + hl_xx(k, rs)^3)*log(1 + 1/hl_xx(k, rs)) - hl_xx(k, rs)^2 + 1/2*hl_xx(k, rs) - 1/3):

hl_f := (rs, zeta) -> hl_f0(1, rs) + f_zeta(zeta)*(hl_f0(2, rs) - hl_f0(1, rs)):
f    := (rs, zeta) -> hl_f(rs, zeta):


(*
 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 *)

mkappa := KAPPA_PBE:
mmu    := 0.00361218645365094697:
malpha := 0.52:

f  := x -> 1 + mkappa*(1 - (1 + mmu*x^2/(malpha*mkappa))^(-malpha)):


(*
 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_pbe_vwn_params *params;

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

$include "lda_c_vwn.mpl"
$ifdef gga_c_pbe_params
params_a_beta  := 0.06672455060314922:
params_a_gamma := (1 - log(2))/Pi^2:
params_a_BB    := 1:
$endif

mgamma := params_a_gamma:
mbeta  := (rs, t) -> params_a_beta:
BB     := params_a_BB:

tp   := (rs, z, xt) -> tt(rs, z, xt):

(* Equation (8) *)
A := (rs, z, t) ->
  mbeta(rs, t)/(mgamma*(exp(-f_vwn(rs, z)/(mgamma*mphi(z)^3)) - 1)):

(* Equation (7) *)
f1 := (rs, z, t) -> t^2 + BB*A(rs, z, t)*t^4:
f2 := (rs, z, t) -> mbeta(rs, t)*f1(rs, z, t)/(mgamma*(1 + A(rs, z, t)*f1(rs, z, t))):

fH := (rs, z, t) -> mgamma*mphi(z)^3*log(1 + f2(rs, z, t)):

f_pbe  := (rs, z, xt, xs0, xs1) ->
  f_vwn(rs, z) + fH(rs, z, tp(rs, z, xt)):

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


with(Groebner):
with(PolynomialIdeals):

J := PolynomialIdeal({x1*x2*x11 + x1*x11 + x2*x3*x11 + x3*x4*x11 + x4*x5*x11 + x5*x6*x11 + x6*x7*x11 + x7*x8*x11 + x8*x9*x11 + x9*x10*x11 - 1, x1*x3*x11 + x2*x4*x11 + x2*x11 + x3*x5*x11 + x4*x6*x11 + x5*x7*x11 + x6*x8*x11 + x7*x9*x11 + x8*x10*x11 - 2, x1*x4*x11 + x2*x5*x11 + x3*x6*x11 + x3*x11 + x4*x7*x11 + x5*x8*x11 + x6*x9*x11 + x7*x10*x11 - 3, x1*x5*x11 + x2*x6*x11 + x3*x7*x11 + x4*x8*x11 + x4*x11 + x5*x9*x11 + x6*x10*x11 - 4, x1*x6*x11 + x2*x7*x11 + x3*x8*x11 + x4*x9*x11 + x5*x10*x11 + x5*x11 - 5, x1*x7*x11 + x2*x8*x11 + x3*x9*x11 + x4*x10*x11 + x6*x11 - 6, x1*x8*x11 + x2*x9*x11 + x3*x10*x11 + x7*x11 - 7, x1*x9*x11 + x2*x10*x11 + x8*x11 - 8, x1*x10*x11 + x9*x11 - 9, x10*x11 - 10, x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 + 1}):
st := time[real]():
Basis(J, tdeg(x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11), characteristic=2^31-1):
time[real]() - st;

J := PolynomialIdeal({x1*x2*x12 + x1*x12 + x2*x3*x12 + x3*x4*x12 + x4*x5*x12 + x5*x6*x12 + x6*x7*x12 + x7*x8*x12 + x8*x9*x12 + x9*x10*x12 + x10*x11*x12 - 1,
x1*x3*x12 + x2*x4*x12 + x2*x12 + x3*x5*x12 + x4*x6*x12 + x5*x7*x12 + x6*x8*x12 + x7*x9*x12 + x8*x10*x12 + x9*x11*x12 - 2,
x1*x4*x12 + x2*x5*x12 + x3*x6*x12 + x3*x12 + x4*x7*x12 + x5*x8*x12 + x6*x9*x12 + x7*x10*x12 + x8*x11*x12 - 3,
x1*x5*x12 + x2*x6*x12 + x3*x7*x12 + x4*x8*x12 + x4*x12 + x5*x9*x12 + x6*x10*x12 + x7*x11*x12 - 4,
x1*x6*x12 + x2*x7*x12 + x3*x8*x12 + x4*x9*x12 + x5*x10*x12 + x5*x12 + x6*x11*x12 - 5,
x1*x7*x12 + x2*x8*x12 + x3*x9*x12 + x4*x10*x12 + x5*x11*x12 + x6*x12 - 6,
x1*x8*x12 + x2*x9*x12 + x3*x10*x12 + x4*x11*x12 + x7*x12 - 7,
x1*x9*x12 + x2*x10*x12 + x3*x11*x12 + x8*x12 - 8,
x1*x10*x12 + x2*x11*x12 + x9*x12 - 9, x1*x11*x12 + x10*x12 - 10,
x11*x12 - 11,
x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 + x11 + 1}):
st := time[real]():
Basis(J, tdeg(x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12), characteristic=2^31-1):
time[real]() - st;

J := PolynomialIdeal({x1*x2*x13 + x1*x13 + x2*x3*x13 + x3*x4*x13 + x4*x5*x13 + x5*x6*x13 + x6*x7*x13 + x7*x8*x13 + x8*x9*x13 + x9*x10*x13 + x10*x11*x13 + x11*x12*x13 - 1,
x1*x3*x13 + x2*x4*x13 + x2*x13 + x3*x5*x13 + x4*x6*x13 + x5*x7*x13 + x6*x8*x13 + x7*x9*x13 + x8*x10*x13 + x9*x11*x13 + x10*x12*x13 - 2,
x1*x4*x13 + x2*x5*x13 + x3*x6*x13 + x3*x13 + x4*x7*x13 + x5*x8*x13 + x6*x9*x13 + x7*x10*x13 + x8*x11*x13 + x9*x12*x13 - 3,
x1*x5*x13 + x2*x6*x13 + x3*x7*x13 + x4*x8*x13 + x4*x13 + x5*x9*x13 + x6*x10*x13 + x7*x11*x13 + x8*x12*x13 - 4,
x1*x6*x13 + x2*x7*x13 + x3*x8*x13 + x4*x9*x13 + x5*x10*x13 + x5*x13 + x6*x11*x13 + x7*x12*x13 - 5,
x1*x7*x13 + x2*x8*x13 + x3*x9*x13 + x4*x10*x13 + x5*x11*x13 + x6*x12*x13 + x6*x13 - 6,
x1*x8*x13 + x2*x9*x13 + x3*x10*x13 + x4*x11*x13 + x5*x12*x13 + x7*x13 - 7, x1*x9*x13 + x2*x10*x13 + x3*x11*x13 + x4*x12*x13 + x8*x13 - 8,
x1*x10*x13 + x2*x11*x13 + x3*x12*x13 + x9*x13 - 9,
x1*x11*x13 + x2*x12*x13 + x10*x13 - 10,
x1*x12*x13 + x11*x13 - 11, x12*x13 - 12,
x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 + x11 + x12 + 1}):
st := time[real]():
Basis(J, tdeg(x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13), characteristic=2^31-1):
time[real]() - st;


    {    MultPlan.MPL    }

TITLE
    Multistage_Production_Planning ;

INDEX
    time     =  (June,July,August)  -> (Jun,Jul,Aug);
    tire     =  (Nylon,Glass)       -> (Nyl,Gls);
    machine  =  (Wheel,Regular)     -> (W,R);

DATA
    ProdHours[machine,time]  =  (( 700, 300,1000),
                                 (1500, 400, 300));

    Delivery[tire,time]      =  ((4000, 8000, 3000),
                                 (1000, 5000, 5000));

    ProdRates[machine,tire]  =  ((0.15, 0.12),
                                 (0.16, 0.14));

    Prices[tire]             =  (7.00, 9.00)
    PurchasePrice[tire]      =  (3.10, 3.90)

DECISION
    Prod[machine,tire,time]   ->  P
    Invt[tire,time];

MACRO
    TotalRevenues   :=  SUM(tire,time: Prices * Delivery) ;
    ProductionCost  :=  0.50 SUM(machine,tire,time: ProdRates * Prod) ;
    InventoryCost   :=  0.10 SUM(tire,time: Invt) ;

    RawMaterialCost :=  SUM(tire,time: PurchasePrice * Delivery);
    Post&PackCost   :=  0.23 SUM(tire,time: Delivery) ;
    FixedCost       :=  RawMaterialCost + Post&PackCost ;

{----------------------------------------------------------------------------}

  MAX Profit   =  TotalRevenues
                  -  ProductionCost
                  -  InventoryCost
                  -  FixedCost ;

SUBJECT TO

  ProdCap[machine,time] :

     SUM(tire: ProdRates * Prod)  <  ProdHours ;

  Inventory[tire,time] :

     Invt[time-1] + SUM(machine: Prod)  =  Invt + Delivery ;

BOUNDS
     CloseInvt[tire,time=August]  :  Invt = 0 ;
END


`bideg0/Lambda` := proc(u)
 if type(u,specfunc(nonnegint,lambda)) then
  return [nops(u),`+`(op(u)) + nops(u)];
 else
  return [0,0];
 fi;
end:

`bideg/Lambda` := apply_deg(`bideg0/Lambda`);

`mu0/Lambda` := (u,v) -> `reduce/Lambda`(op(u),op(v));

`mu/Lambda` := apply_linear_assoc_mod(`mu0/Lambda`,lambda(),2);

`is_admissible/Lambda` := proc()
 if nargs = 1 and type(args[1],specfunc(nonnegint,lambda)) then
  return `is_admissible/Lambda`(op(args[1]));
 elif type([args],list(nonnegint)) then
  return evalb(min(op((2 *~ [infinity,args]) -~ [args,0])) >= 0);
 else
  return FAIL;
 fi;
end:

`reduce/Lambda` := proc()
 local K,t,left,right,i,j,n,u,c;

 option remember;

 if `is_admissible/Lambda`(args) then
  return lambda(args);
 fi;

 K := [args];
 t := 1;
 while t < nargs and K[t+1] <= 2*K[t] do t := t+1; od;
 left := lambda(seq(K[i],i=1..t-1));
 right := `reduce/Lambda`(seq(K[i],i=t+2..nops(K)));
 i := K[t];
 n := K[t+1] - 2*i - 1;
 u := 0;
 for j from 0 to floor((n-1)/2) do
  c := modp(binomial(n-1-j,j),2);
  if c <> 0 then
   u := modp(u + c * `mu/Lambda`(left,`reduce/Lambda`(i+n-j,2*i+1+j),right),2);
  fi;
 od;
 return u;
end:

`d0/Lambda` := proc(n::nonnegint)
 local u,j,c;
 option remember;

 u := 0;
 for j from 1 to floor(n/2) do
  c := modp(binomial(n-j,j),2);
  if c <> 0 then
   u := u + `reduce/Lambda`(n-j,j-1);
  fi;
 od;
 u := modp(u,2);
 return u;
end:

`d1/Lambda` := proc(u)
 local K,n,v,i,j,x,y,z;
 option remember;

 if not(type(u,specfunc(nonnegint,lambda))) then
  return FAIL;
 fi;

 K := [op(u)];
 n := nops(K);
 v := 0;
 for i from 1 to n do
  x := lambda(seq(K[j],j=1..i-1));
  y := `d0/Lambda`(K[i]);
  z := lambda(seq(K[j],j=i+1..n));
  v := modp(v + `mu/Lambda`(x,y,z),2);
 od;
 return v;
end:

`d/Lambda` := apply_linear_mod(`d1/Lambda`,2);

`basis/Lambda` := proc(s::integer,t::integer)
 local B,C,r;
 option remember;

 if s < 0 then
  return [];
 elif s = 0 then
  if t = 0 then
   return [lambda()];
  else
   return [];
  fi;
 elif s = 1 then
  if t >= 1 then
   return [lambda(t-1)];
  else
   return [];
  fi;
 else
  B := NULL;
  for r from 0 to t-1 do
   C := `basis/Lambda`(s-1,r);
   C := select(v -> (op(-1,v) >= t-r-1),C);
   C := map(v -> lambda(op(v),t-r-1),C);
   B := B,op(C);
  od;
  return [B];
 fi;
end:

`vec/Lambda` := (s,t) -> proc(u)
 local m;

 [seq(modp(coeff(u,m,1),2),m in `basis/Lambda`(s,t))];
end:

`d_matrix/Lambda` := proc(s,t)
 local M;
 option remember;

 M := map(m -> `vec/Lambda`(s+1,t)(`d/Lambda`(m)),`basis/Lambda`(s,t));
 M := LinearAlgebra[Modular][Mod](2,Transpose(Matrix(M)),integer[]);
 return M;
end: