with(networks):

# encode an array as a single number.
encode := (x,F) -> ( F[output](x[1])*100
	           + F[output](x[2])*10
	           + F[output](x[3])*1 ):

# Define the switch function.
switch := proc(a,b,c,F)
       local x3,x1;
       x1 := F[input](1);
       x3 := F[`+`]( x1, F[`+`]( x1,x1 ) ) ;
       F[`-`]( F[`*`]( x3, F[`*`](a,b) ),c );
end:

# Define my three cluster functions.
f:= (x,F) -> [x[1],x[2],switch(x[1],x[2],x[3],F)]:
g:= (x,F) -> [x[1],switch(x[1],x[3],x[2],F),x[3]]:
h:= (x,F) -> [switch(x[2],x[3],x[1],F),x[2],x[3]]:

# Give me the graph neighbors of x.
N := x -> neighbors(x,G):

# Given a prime F, return a graph G(M,F)
makegraph := proc(F,firstelement)
   local g;
   g := graph({encode(firstelement,F)},{}):
   bleg(g, firstelement, 1, F):
   eval(g);
end:

# useful function
bleg := proc(G,x,depth,F)
  if depth < 100 then
    step(G,x,f(x,F),depth,F);
    step(G,x,g(x,F),depth,F);
    step(G,x,h(x,F),depth,F);
  fi;
end:

# useful function
step := proc(G,x,y,depth,F)
  if (encode(y,F) in vertices(G)) then
    addedge({encode(x,F),encode(y,F)},G):
  else
  #  if markoff(x,F) then
      addvertex(encode(y,F),G):
      addedge({encode(x,F),encode(y,F)},G):
      bleg(G,y,depth+1,F);
  #  fi
  fi
end:

# Usefull functions.
# is this a markoff solution?  For debuging
markoff := (x,F) -> markoff2(x[1],x[2],x[3],F):
markoff2 := proc(x,y,z,F)
    local lhs,rhs,x1,x3;
    x1 := F[input](1);
    x3 := F[`+`](x1,x1,x1) ;
    lhs := F[`+`]( F[`^`](x,2), F[`^`](y,2), F[`^`](z,2));
    rhs := F[`*`]( x3, x,y,z);
    if lhs = rhs then true else false fi;
    #if (x^2 + y^2 + z^2 - 3*x*y*z) mod p = 0 then true else false fi;
end:

decode2 := proc(x)
    local n,one,ten,hun;
    n := 10;
    one := x mod n;
    ten := ((x-one)/n) mod n;
    hun := (x-one-(n*ten))/n^2;
    [hun,ten,one];
end:
decode := proc(x,F)
    local y;
    y := decode2(x);
    [F[input](y[1]), F[input](y[2]), F[input](y[3])];
end:

# Enumerate ALL of the solutions
enumerate := proc(p,k,F)
	local a,b,c,A,B,C,sols;
	sols := {}:
	for a from 0 to p^k-1 do
	    for b from 0 to p^k-1 do
		for c from 0 to p^k-1 do
		    A := F[input](a):
		    B := F[input](b):
		    C := F[input](c):
		    if markoff([A,B,C],F) then
			sols := sols union {[A,B,C]};
		    fi
		od
	    od
	od:
	sols;
end:

# here is where things begin to happen.
#let our field F be
p:=2:
k:=2:
F := GF(p,k):
#seq(F[input](x),x=0..p^k-1);
#G := makegraph(F,[F[input](1),F[input](1),F[input](1)]):
#nops(vertices(G));
#vertices(G);
#draw3d(G);
#draw(G);
sols := enumerate(p,k,F):
nops(sols);
sols;

#found solutions.
u := {}:
# set of connected components.
Gees := {}:
for x in sols do
    if not(x in u)  then
        G := makegraph(F, x);
        for y in vertices(G) do
            u := u union {decode(y,F)};
        od:
        Gees := Gees union {eval(G)};
    fi
od:
nops(Gees);
draw3d(Gees[1]);
seq(nops(vertices(Gees[i])), i = 1..nops(Gees));
#seq((vertices(Gees[i])), i = 1..nops(Gees));


SL2_11 := table():

SL2_11["elements"] := {
 seq(seq(seq(seq(<<e*a|b>,<c|mods(e*(1+b*c)/a,11)>>,c=-5..5),b=-5..5),a=1..5),e in {-1,1}),
 seq( seq(seq(<<0|e*b>,<mods(-e/b,11)|d>>,d=-5..5),b=1..5),e in {-1,1})
}:

SL2_11["projective_line"] := {seq(i,i=-5..5),infinity};

SL2_11["action"] := proc(g,u)
 local a,b,c,d,nn,dd;

 a := g[1,1]; b := g[1,2];
 c := g[2,1]; d := g[2,2];
 if u = infinity then
  if c = 0 then
   return infinity;
  else
   return mods(a/c,11);
  fi;
 else
  nn := mods(a * u + b,11);
  dd := mods(c * u + d,11);
  if dd = 0 then
   return infinity;
  else
   return mods(nn/dd,11);
  fi;
 fi;
end:

SL2_11["first_hexad"] := {seq(mods(i^2,11),i=0..5)};

SL2_11["hexads"] :=
 {seq(map2(SL2_11["action"],g,SL2_11["first_hexad"]),g in SL2_11["elements"])};

# `is_element/steiner_systems`(SL2_11["projective_line"])(5,6)(SL2_11["hexads"]);


with(DifferentialAlgebra):
ring_diff := DifferentialRing(blocks = [[s, x2, i, r, x1], [y1, y2] ], derivations = [t]):
sys := [
diff(s(t), t) - (-b1*b0*s(t)*x1(t)*i(t) - b0*s(t)*i(t) - s(t)*mu + mu + g*r(t)),
diff(x2(t), t) - (M*x1(t)),
diff(i(t), t) - (-nu*i(t) + b1*b0*s(t)*x1(t)*i(t) + b0*s(t)*i(t) - mu*i(t)),
diff(r(t), t) - (nu*i(t) - mu*r(t) - g*r(t)),
diff(x1(t), t) - (-M*x2(t)),
y1(t) - (i(t)),
y2(t) - (r(t))
];
res := CodeTools[CPUTime](RosenfeldGroebner(sys, ring_diff, singsol=none));


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

ol1_f  := x -> 1 + (x^2/72 + 0.00677*2^(1/3)*x)/K_FACTOR_C:

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


#---------------------------------------------------------------------
# ieeedouble converts a number to IEEE double extended format.
# returns sign (-1 or 1), exponent between -16383 and 16383, mantissa as a fraction between 0.5 and 1.

# TODO : use JMM procedure; check subnormals etc
ieeedoubleExt:=proc(xx)
local x, sign, logabsx, exponent, mantissa, infmantissa;
    x:=evalf(xx):
    if (x=0) then
        sign,exponent,mantissa := 0,0,0;
    else
        if (x<0) then sign:=-1:
        else sign:=1:
        fi:
        exponent := floor(log2(sign*x));
        if (exponent>16383) then mantissa:=infinity: exponent:=16383:
        elif (exponent< -16382) then
            # denorm
            exponent := -16383
        fi:
        infmantissa := sign*x*2^(63-exponent);
        if frac(infmantissa) <> 0.5 then mantissa := round(infmantissa)
        else
            mantissa := floor(infmantissa);
            if type(mantissa,odd) then mantissa := mantissa+1 fi;
        fi;
        mantissa := mantissa*2^(-63);
    fi;
    sign,exponent,mantissa;
end:

nearestExt := proc(x)
    local sign, exponent, mantissa;

    sign, exponent, mantissa := ieeedoubleExt(x);
    sign*mantissa*2^(exponent);
end:

ieeehexaExt:= proc(x)
local resultat, sign, exponent, mantissa, t;

    if(x=0) then resultat:=["0000","0000","0000","0000","0000"];
    elif(x=-0) then resultat:=["8000","0000","0000","0000","0000"];
    else
        sign,exponent,mantissa := ieeedoubleExt(x);
        t := 2**80 +  (exponent+16383)*2^64 + mantissa*2^63;
        if (sign=-1) then
            t := t + 2**79;
        fi:
   t := convert(t, hex);
   t:=convert(t, string):

   resultat:=[substring(t, 2..5),
              substring(t, 6..9 ),  substring(t, 10..13 ),
              substring(t, 14..17 ),  substring(t, 18..21 )];

    end if:
    resultat;
end proc:

printDoubleAsShort:=proc(x)
    local ss;
    ss:=ieeehexa(x);
    cat( "DOUBLE_HEX(",
         substring(ss[1], 1..4),  ", " ,
         substring(ss[1], 5..8),  ", " ,
         substring(ss[2], 1..4),  ", " ,
         substring(ss[2], 5..8)) ;
end proc:

printDoubleExtAsShort:=proc(x)
    local ss;
    ss:=ieeehexaExt(x);
    cat( "LDOUBLE_HEX(", ss[1],  ", ", ss[2],  ", ",ss[3],  ", ", ss[4],  ", ", ss[5],  ")");
end proc:

printDoubleAsULL:=proc(x)
    local ss;
    ss:=ieeehexa(x);
    cat( "ULL(", ss[1], ss[2],  ")");
end proc:

printDoubleAsHexInt:=proc(x)
    local ss;
    ss:=ieeehexa(x);
    cat(ss[1], ss[2]);
end proc:

#---------------------------------------------------------------------
# hi_lo takes an arbitrary precision number x and returns two doubles such that:
# x ~ x_hi + x_lo
hiloExt:= proc(x)
local x_hi, x_lo, res:
    x_hi:= nearestExt(evalf(x)):
    res:=x-x_hi:
    if (res = 0) then
        x_lo:=0:
    else
        x_lo:=nearestExt(evalf(res)):
    end if;
    x_hi,x_lo;
end:

#---------------------------------------------------------------------
# Like poly_exact, but the n first coefficients are exactly representable as the sum of two doubles.
# (to actually get the two doubles, use procedure hi_lo)

polyExact2Ext:=proc(P,n)
local deg,i, coef, coef_hi, coef_lo, Q:
    Q:= 0:
    convert(Q, polynom):
    deg:=degree(P,x):
    for i from 0 to deg do
        coef :=coeff(P,x,i):
        coef_hi, coef_lo:=hiloExt(coef):
        Q:= Q + coef_hi*x^i:
        if(i<n) then
            Q := Q + coef_lo*x^i:
        fi:
    od:
    return(Q);
end:

printPolyExt := proc(fd,P,n, name_of_poly)
local deg,i, coef, coef_hi, coef_lo;
    convert(Q, polynom):
    deg:=degree(P,x):
    fprintf(fd, " static const long double %s[%d][2] = {\n", name_of_poly, deg+1);
    for i from 0 to deg do
        coef :=coeff(P,x,i):
        coef_hi, coef_lo:=hiloExt(coef):

        fprintf(fd,"{ %1.50eL, ",coef_hi);

        if(i<n) then
            fprintf(fd," %1.50eL},\n",coef_lo);
        else
            fprintf(fd,"0},\n");
        fi:
    od:
    fprintf(fd,"}; \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: mgga_exc *)

b97mv_par_n := 5:

b97mv_gamma_x := 0.004:
b97mv_par_x := [
    [  1.000, 0, 0],
    [  1.308, 0, 1],
    [  1.901, 0, 2],
    [  0.416, 1, 0],
    [  3.070, 1, 1]
]:

b97mv_gamma_ss := 0.2:
b97mv_par_ss := [
    [  1.000, 0, 0],
    [ -1.855, 0, 2],
    [ -5.668, 1, 0],
    [-20.497, 3, 2],
    [-20.364, 4, 2]
]:

b97mv_gamma_os := 0.006:
b97mv_par_os := [
    [  1.000, 0, 0],
    [  1.573, 0, 1],
    [ -6.298, 0, 3],
    [  2.535, 1, 0],
    [ -6.427, 3, 2]
]:

$define lda_x_params
$include "lda_x.mpl"
$include "b97mv.mpl"

b97mv_f_aux := (rs, z, xs0, xs1, ts0, ts1) ->
  + opz_pow_n( z,1)/2 * f_lda_x(rs*(2/(1 + z))^(1/3),  1)
    * b97mv_g(b97mv_gamma_x,  b97mv_wx_ss, b97mv_par_x,  b97mv_par_n, xs0, ts0, 0)
  + opz_pow_n(-z,1)/2 * f_lda_x(rs*(2/(1 - z))^(1/3),  1)
    * b97mv_g(b97mv_gamma_x,  b97mv_wx_ss, b97mv_par_x,  b97mv_par_n, xs1, ts1, 0):

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


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

f0 := s -> 1 + B1*s*log(1 + s) + B2*s*log(1 + log(1 + s)):
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 *)

$define gga_c_pbe_params
$include "gga_c_pbe.mpl"

$include "lda_c_2d_amgb.mpl"
$undef xc_dimensions_2d

rs2D_factor := 1.704:
q2d_dd := 1e6:

q2d_rs2D := (rs, xt) -> rs2D_factor*rs*sqrt(X2S*xt)/RS_FACTOR:

q2d_fac := t -> t^4*(1 + t^2)/(q2d_dd + t^6):

q2d_f := (rs, z, xt, xs0, xs1) ->
  (1 - q2d_fac(tt(rs, z, xt)))*f_pbe(rs, z, xt, xs0, xs1) + q2d_fac(tt(rs, z, xt))*f_amgb(q2d_rs2D(rs, xt), z):

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


with(DifferentialThomas):
with(Tools):
Ranking([t], [[x1, x2], [y1] ]):
sys := [
diff(x1(t), t) - (a*x1(t) + b*x1(t) - x2(t)*c*x1(t)),
diff(x2(t), t) - (-a*b*x2(t) + d*x2(t)*x1(t)),
y1(t) - (x1(t))
];
res := CodeTools[CPUTime](ThomasDecomposition(sys));


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

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

g := [2/3, -0.0139261, 0.183208]:
l := [1.064009, 0.572565]:

alpha := (t, rs) ->
      2 - (g[1] + g[2]*rs)/(1 + g[3]*rs)*exp(-t*(l[1] + l[2]*t*sqrt(rs))):

phi := (malpha, z) -> (opz_pow_n(z,malpha) + opz_pow_n(-z,malpha) - 2)/(2^malpha - 2):

lambda := (4/(9*Pi))^(1/3):
a0     := 1/(Pi*lambda):

a     := [0.750, 3.043630, -0.0922700, 1.703500, 8.310510, 5.11050]:

aa := t -> a0*tanh(1/t)*(a[1] + a[2]*t^2 + a[3]*t^3 + a[4]*t^4)/(1 + a[5]*t^2 + a[6]*t^4):
bb := (b, t) -> tanh(1/sqrt(t))*(b[1] + b[2]*t^2 + b[3]*t^4)/(1 + b[4]*t^2 + b[5]*t^4):
dd := (d, t) -> bb(d, t):
ee := (e, t) -> tanh(1/t)*(e[1] + e[2]*t^2 + e[3]*t^4)/(1 + e[4]*t^2 + e[5]*t^4):
cc := (c, e, t) -> (c[1] + c[2]*exp(-c[3]/t))*ee(e, t):

fxc := (omega, b, c, d, e, rs, t) ->
    -(omega*aa(t) + bb(b, t)*sqrt(rs) + cc(c, e, t)*rs)/(rs*(1 + dd(d, t)*sqrt(rs) + ee(e, t)*rs)):

# (T/T_F)*opz_pow_n(z,2/3)
mtt := (rs, z) ->
    2*(4/(9*Pi))^(2/3)*params_a_T*rs^2*(1 + params_a_thetaParam*z)^(2/3):

f := (rs, z) ->
  + fxc(1,
        params_a_b_0_, params_a_c_0_, params_a_d_0_, params_a_e_0_,
        rs, mtt(rs, z))*(1 - phi(alpha(mtt(rs, z), rs), z))
  + fxc(2^(1/3),
        params_a_b_1_, params_a_c_1_, params_a_d_1_, params_a_e_1_,
        rs, mtt(rs, z)/2^(2/3))*phi(alpha(mtt(rs, z), 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: mgga_exc *)

$define xc_dimensions_2d

js17_lambda := 0.74:
js17_beta   := 30.0:

(*
Notes:
  rho -> 2 rho_sigma, from the spin sum rule
  tsu2d_unif_sigma/n_sigma^2 = 4 Pi, tau is missing 1/2 in paper
*)

(* Eq. (18) *)
js17_ff := s ->
  (1 + 90*(2*js17_lambda - 1)^2*s^2 + js17_beta*(2*js17_lambda - 1)^4*s^4)^(1/15):

(* Eq. (23) *)
js17_R := (s, t) ->
  1 + 128/21*(2*js17_lambda - 1)^2*s^2 +
  (3*(js17_lambda^2 - js17_lambda + 1/2)*(t - 4*Pi) - t)/(4*Pi):

js17_f := (x, u, t) -> 1/js17_ff(X2S_2D*x)
  + 2/5 * js17_R(X2S_2D*x, t)/js17_ff(X2S_2D*x)^3:

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


# The Boys embedding, as a map from the Riemann sphere to R^3

complex_boys_embedding := proc(z)
 local a,V,M,B,rM,i;

 if z = 0 then return [0,0,2]; fi;

 a := 1/(z^3-1/z^3+sqrt(5)):
 V := [I*(z^2-1/z^2), z^2+1/z^2, 2/3*I*(z^3+1/z^3)]:
 M := map(Re, a *~ V +~ [0, 0, 1/2]):
 rM := add(M[i]^2,i=1..3);
 B := M /~ rM;
 return B;
end:

sphere_reduce0 := (x) -> (u) -> rem(u,x[1]^2+x[2]^2+x[3]^2-1,x[3]);

sphere_reduce1 := (x) -> proc(u)
  local n,d,n0,d0,n1,d1,f;
  if type(u,list) then return map(sphere_reduce1(x),u); fi;

  n := sphere_reduce0(x)(numer(u));
  d := sphere_reduce0(x)(denom(u));
  n0 := coeff(n,x[3],0);
  n1 := coeff(n,x[3],1);
  d0 := coeff(d,x[3],0);
  d1 := coeff(d,x[3],1);
  n := sphere_reduce0(x)(expand(n * (d0 - d1*x[3])));
  d := sphere_reduce0(x)(expand(d * (d0 - d1*x[3])));
  return factor(n/d);
end:

# The map boys_embedding() is the Boys embedding, as a map from the
# round sphere S^2 to R^3.
make_boys_embedding := proc()
 local x,Z,B,BN,dB,i;
 global boys_embedding0,boys_normal0;

 assume(x[1] > 0, x[2] > 0, x[3] > 0);
 Z := (x[1] + I * x[2])/(1 - x[3]);
 B := complex_boys_embedding(Z);
 B := map(sphere_reduce1(x),B);
 dB := denom(B[1]);
 B := factor(dB *~ B);
 B := [op(B),dB];
 boys_embedding0 := unapply(B,x);

 BN := subs({seq(x[i] = t*x[i],i=1..3)},
            [B[1]/B[4],B[2]/B[4],B[3]/B[4]]);
 BN := subs(t = 1, map(diff,BN,t));
 BN := sphere_reduce1(x)(BN);
 BN := expand(factor(BN *~ denom(BN[1]) /~ 480)):

 boys_normal0 := unapply(BN,x);
end:

boys_embedding := proc(x)
 local B;
 B := boys_embedding0(x);
 return [B[1]/B[4],B[2]/B[4],B[3]/B[4]];
end:

boys_normal := proc(x)
 local n,M,i;
 if x = [0,0,1] then return [0,0,1]; fi;
 M := evalf(boys_jacobian_matrix(x));
 n := convert((1/Transpose(Matrix(M))) . Vector(x),list);
 n := n /~ sqrt(add(n[i]^2,i=1..3));
 return n;
end:

make_boys_jacobian := proc()
 local x,p,xred,B,BJM,BJN,BJNP,DBJNP,p_rule,x0,rot,i,j;
 global boys_jacobian_matrix,boys_jacobian_square_norm,boys_poly,boys_p0,boys_corners;

 B := boys_embedding(x);

 # The embedding map extends naturally over a neighbourhood of S2 in R3,
 # and this is the Jacobian of that extension.
 BJM := [seq([seq(sphere_reduce1(x)(diff(B[i],x[j])),j=1..3)],i=1..3)];
 boys_jacobian_matrix := unapply(BJM,x);

 # This is the square norm of the Jacobian restricted to S2
 BJN := sphere_reduce1(x)(expand(add(add(BJM[i][j]^2,j=1..3),i=1..3) -
                          add(add(BJM[i][j]*x[j],j=1..3)^2,i=1..3))):
 boys_jacobian_square_norm := unapply(BJN,x);

 p_rule := {x[1] = (1-p^2)/(1+p^2)/sqrt(2),
            x[2] = (1-p^2)/(1+p^2)/sqrt(2),
	    x[3] = 2 * p/(1+p^2)};

 BJNP := factor(expand(simplify(subs(p_rule,BJN))));
 DBJNP := factor(expand(diff(BJNP,p)));
 boys_poly := unapply(select(g -> degree(g,p) = 18,{op(numer(DBJNP))})[1],p);
 boys_p0 := fsolve(boys_poly(p),p=0.15..0.16);

 x0 := evalf(subs(p = boys_p0,subs(p_rule,[x[1],x[2],x[3]])));

 rot := (x) -> [(-x[1]-sqrt(3)*x[2])/2,(sqrt(3)*x[1]-x[2])/2,x[3]];
 boys_corners :=
  evalf([x0,rot(x0),rot(rot(x0)),
         -~ x0, -~ rot(x0), -~ rot(rot(x0))]);
end:

# We now construct a map boys_embedding_alt() which is obtained by precomposing
# boys_embedding() with a linear map and then postcomposing with an affine map.
# This has the effect that boys_embedding_alt sends [1,1,1]/sqrt(3) to itself
# and is equivariant for the third-twist about that axis.  Moreover, the
# "corner points" for boys_embedding_alt are at the other points of the form
# [+/- 1, +/- 1, +/- 1]/sqrt(3), where the three signs are not all the same.

make_boys_embedding_alt := proc()
 global boys_M0,boys_M1,boys_a1,boys_embedding_alt;
 local u,a,x,M,M0,be0,F,F0,rels,sol,i;

 if not(type(boys_corners,list(list))) then
  make_boys_jacobian():
 fi;

 u := table():
 u[ 0] := [ 1, 1, 1] /~ sqrt(3):
 u[ 1] := [ 1, 1,-1] /~ sqrt(3):
 u[ 2] := [ 1,-1, 1] /~ sqrt(3):
 u[ 3] := [-1, 1, 1] /~ sqrt(3):

 M := Matrix(3,3,[seq(a[i],i=1..9)]):

 M0 := subs(solve(evalf(map(op,[seq(convert(M . Vector(u[i]),list) -~ boys_corners[i],i=1..3)]))),M):
 boys_M0 := M0;
 be0 := unapply(simplify(expand(evalf(boys_embedding(M0 . <x[1],x[2],x[3]>)))),x):

 F := (y) -> convert(M . Vector(y),list) +~ [a[10],a[11],a[12]]:
 rels := map(op,evalf([
  F(be0(u[0])) -~ u[0], F(be0(u[1])) +~ u[1], F(be0(u[2])) +~ u[2], F(be0(u[3])) +~ u[3]
 ])):
 sol := solve(rels);
 boys_M1 := subs(sol,M);
 boys_a1 := subs(sol,[a[10],a[11],a[12]]);

 boys_embedding_alt := (x) ->
  evalf(convert(boys_M1 . Vector(boys_embedding(boys_M0 . <x[1],x[2],x[3]>)),list) +~
   boys_a1);

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/.
*)

(* The B97 function g *)
b97_g := (gamma, cc, x) -> add(cc[i]*(gamma*x^2/(1 + gamma*x^2))^(i-1), i=1..5):

(* The parallel and perpendicular components of the energy *)
b97_fpar  := (lda_func, mgamma, cc, rs, z, xs0, xs1) ->
  + lda_stoll_par(lda_func, rs,  z) * b97_g(mgamma, cc, xs0)
  + lda_stoll_par(lda_func, rs, -z) * b97_g(mgamma, cc, xs1):

b97_fperp := (lda_func, mgamma, cc, rs, z, xs0, xs1) ->
  lda_stoll_perp(lda_func, rs, z) * b97_g(mgamma, cc, sqrt(xs0^2 + xs1^2)/sqrt(2)):

b97_f := (lda_func, gamma_ss, cc_ss, gamma_ab, cc_ab, rs, z, xs0, xs1) ->
  + b97_fpar (lda_func, gamma_ss, cc_ss, rs, z, xs0, xs1)
  + b97_fperp(lda_func, gamma_ab, cc_ab, rs, z, xs0, xs1):


# Base Parameter Properties for Robot based on MDH frames
# Einleitung
# Untersuchung von Eigenschaften der Regressorform und des Minimalparametervektors
#
# Dateiname:
# robot -> Berechnung für allgemeinen Roboter
# tree -> Berechnung für eine allgemeine Baumstruktur (aber bisher nur für serielle Strukturen getestet)
# base_parameter_transformations -> Umwandlung der Minimalparameterform in andere Darstellungen
# Authors
# Moritz Schappler, schappler@irt.uni-hannover.de, 2016-04
#
# (C) Institut fuer Regelungstechnik, Leibniz Universitaet Hannover
# Quellen
# [SousaCor2014] Sousa, C. D. and Cortesao, R.: Physical feasibility of robot base inertial parameter identification: A linear matrix inequality approach (2014)
# Initialisierung
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_opt := true:
codegen_act := true:
read "../helper/proc_convert_s_t":
read "../helper/proc_convert_t_s":
read "../helper/proc_MatlabExport":
read "../robot_codegen_definitions/robot_env":
read sprintf("../codeexport/%s/tmp/tree_floatb_definitions", robot_name):
# Ergebnisse der Minimalparametergruppierung laden

if base_method_name="twist" then
  paramfile := sprintf("../codeexport/%s/tmp/minimal_parameter_vector_fixb_maple", robot_name):
  expstring:="fixb":
  PV2:=Matrix(PV2_vec[11..10*NL,1]):
elif base_method_name="eulxyz" then
  paramfile := sprintf("../codeexport/%s/tmp/minimal_parameter_vector_floatb_eulxyz_maple", robot_name):
  expstring:="floatb_eulxyz":
  PV2:=PV2_vec:
else
  printf("Nicht behandelte Basis-Methode: %s\n", base_method_name):
fi:
if FileTools[Exists](paramfile) then
  read paramfile:
else
  printf("%s. Minimalparametervektor wurde nicht berechnet. Abbruch der Untersuchung der Parameter-Abhängigkeiten.\n", FormatTime("%Y-%m-%d %H:%M:%S")):
  quit: # Funktioniert in GUI nicht richtig...
  robot_name := "": # ...Daher auch Löschung des Roboternamens.
end if:
MPV := Paramvec2:

printf("Generiere Minimalparameter-Transformationen für %s (%s)\n", robot_name, expstring):

# Minimalparametervektor als Matrixdarstellung
# Siehe [SousaCor2014] equ. (38)
# Beispielrechnung:
# U=dU/dPV2*PV2=dU/dMPV*MPV # Parameterlineare Form
# MPV=dMPV/dPV2 * PV2 # Minimalparametervektor MPV hängt nur linear von den normalen Parametern im Parametervektor PV2 ab
# dU/dMPV = dU/dPV2 * dMPV/dPV1
# Benutze Fixed-Base Parameter: Ignoriere Parameter der Basis
Paramvec_size := RowDimension(MPV):
K := Matrix(Paramvec_size, RowDimension(PV2)):
for i to Paramvec_size do
  for j from 1 to RowDimension(PV2) do
    K[i,j] := diff(MPV[i, 1], PV2[j,1]):
  end do:
end do:
# Export der Umwandlung von Parametersatz 2 nach Minimalparameter (Matrix)
if codegen_act then
  MatlabExport(K, sprintf("../codeexport/%s/tmp/PV2_MPV_transformation_linear_%s_matlab.m", robot_name, expstring), 2):
end:
save K, sprintf("../codeexport/%s/tmp/PV2_MPV_transformation_linear_dependant_%s_maple", robot_name, expstring):
# Aufteilung der Matrixdarstellung in einzelne Teilmatrizen
# Generate the Matrices required in [SousaCor2014] equ. (33)
# Wenn ein Inertialparameter zu einer linear unabhängigen Spalte der Regressormatrizen gehört,
# steht er in K als 1, alle anderen Spalteneinträge dieser Zeile sind Null und der Inertialparameter steht auch in keiner anderen Zeile.
# Falls er zu einer linear abhängigen Spalte der Regressormatrix gehört, steht er in mehreren Spalten von K oder nur in einer Spalte aber dort nicht alleine.
# Die Permutationsmatrizen P_b, P_d wählen die jeweiligen Parameter aus dem Gesamt-Inertialparametervektor aus
n_b := RowDimension(K):
n_d := ColumnDimension(K)-RowDimension(K):
n := n_b+n_d: # [SousaCor2014] equ. (31)
;
P_b := Matrix(n, n_b): # für [SousaCor2014] equ. (33)
P_d := Matrix(n, n_d): # für [SousaCor2014] equ. (33)
;

for i from 1 to n_b do:
  # gehe alle Zeilen durch und prüfe, ob der MPV nur aus einem Inertialparameter-Eintrag besteht
  # falls er nicht aus einem Inertialparameter-Eintrag besteht, kommt der Basis-Eintrag nur in dieser Zeile vor.
  # falls der MPV-Eintrag aus mehreren Inertialparameter-Einträgen besteht, die nur hier vorkommen, wird der kleinere genommen (der weiter unten steht)

  # gehe alle Spalten durch und prüfe, wenn dieser Eintrag 1 ist, ob er noch in einer anderen Zeile vorkommt.
  linunabh_gefunden :=false: # Merker, ob ein Basis-Inertialparameter gefunden wurde.
  for j from 1 to n do: # alle Spalten durchgehen
    if K(i,j)=1 then
      # printf("In MPV-Zeile %d kommt Inertialparameter %d (%s) direkt vor.\n", i, j, convert(PV2(j,1), string)):
      # gehe alle anderen Zeilen durch
      Index_j_lin_unabh := true: # Merker, dass aktueller Index Basis-Inertialparameter ist.
      for i2 from 1 to n_b do:
        if i = i2 then # die selbe Zeile die gegengeprüft wird ausschließen
          next
        end if:
        if not (K(i2,j) = 0) then
          # Der Inertialparameter kommt auch in einem anderen MPV-Eintrag vor, damit ist er kein Basisparameter
          # printf("Inertialparameter %d (%s) kommt sowohl in MPV-Zeile %d als auch in Zeile %d vor. Kein Basisparameter.\n", j, convert(PV2_vec(10+j,1), string), i, i2):
          Index_j_lin_unabh := false:
          break:
        end if:
      end do:
      if Index_j_lin_unabh then
        # linear unabhängigen Parameter speichern
        P_b(j,i):=1:
        # printf("Für MPV-Zeile %d ist %d (%s) der Basisparameter\n", i, j, convert(PV2(j,1), string)):
        linunabh_gefunden:=true:
      end if:
    end if:
    if linunabh_gefunden then
      # Nicht weiter nach einem Basisparameter suchen, da bereits einer gefunden wurde.
      break:
    end if
  end do: # j-Schleife über Inertialparameter
  if not linunabh_gefunden then
    # printf("Keinen Basis-Inertialparameter in MPV Zeile %d gefunden.\n", i):
  end if:
end do:

# Alle linear abhängigen Parameter (der Rest) in andere Permutationsmatrix P_d packen

i_d := 0:
for j from 1 to n do:
  # Prüfe ob der betrachtete Parameter in der Permutationsmatrix für linear unabhängige vorkommt
  # Summe über die Zeilen von P_b: Prüfe, ob linear unabhängig
  linunabh := false:
  for i_b from 1 to ColumnDimension(P_b) do:
    if P_b(j, i_b) = 1 then:
      linunabh := true: # kommt in P_b vor: Linear unabhängig!
      break:
    end if:
  end do:

  if not (linunabh) then
    i_d := i_d+1;
    P_d(j, i_d) := 1
  end if
end do:
# Transformationsmatrix K_d füllen. Setze K_d nur aus den Spalten von K für die linear abhängigen Inertialparameter zusammen
# K_d: Matrix zur Aufteilung des Minimalparametervektors in linear abhängige und unabhängige Inertialparameter
K_d:=Matrix(n_b, n_d):
j_Kd := 0:
for j from 1 to n do:
  # Prüfe, ob der Inertialparameter j linear abhängig ist.
  linabh := false:
  for j_d from 1 to ColumnDimension(P_d) do:
    # j: Index des untersuchten Inertialparameters
    # j_d: Index der untersuchten Spalte von P_d. Ein Eintrag hier bedeutet, dass der Inertialparameter abhängig ist.
    if P_d(j, j_d) = 1 then:
      linabh := true:
      break:
    end if:
  end do:

  if linabh then
    j_Kd := j_Kd + 1:
    K_d(..,j_Kd) := K(..,j):
  end if:
end do:
printf("Inertialparametervektor hat %d linear abhängige und %d linear unabhängige Einträge\n", n_d, n_b):
delta_b := Transpose(P_b) . PV2: # Zur Überprüfung
;
delta_d := Transpose(P_d) . PV2: # Zur Überprüfung
;
if codegen_act then
  MatlabExport(K_d, sprintf("../codeexport/%s/tmp/PV2_MPV_transformation_linear_dependant_%s_matlab.m", robot_name, expstring), 2):
  MatlabExport(P_b, sprintf("../codeexport/%s/tmp/PV2_permutation_linear_independant_%s_matlab.m", robot_name, expstring), 2):
  MatlabExport(P_d, sprintf("../codeexport/%s/tmp/PV2_permutation_linear_dependant_%s_matlab.m", robot_name, expstring), 2):
end if:


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

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

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

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

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

$define gga_c_pbe_params
$include "gga_c_pbe.mpl"

(* the prefactor of t was chosen to get the right K_FACTOR_C in mgga_series_w *)
m08_f := (rs, z, xt, xs0, xs1, ts0, ts1) ->
  + mgga_series_w(params_a_m08_a, 12, 2^(2/3)*t_total(z, ts0, ts1))
    * f_pw(rs, z)
  + mgga_series_w(params_a_m08_b, 12, 2^(2/3)*t_total(z, ts0, ts1))
    * (f_pbe(rs, z, xt, xs0, xs1) - f_pw(rs, z)):

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


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

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

$ifdef gga_x_b88_params
params_a_beta  := 0.0042:
params_a_gamma := 6.0:
$endif

b88_f := x -> 1 + params_a_beta/X_FACTOR_C*x^2/(1 + params_a_gamma*params_a_beta*x*arcsinh(x)):

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


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

`is_element/PP` := (N::posint) -> (A::set) -> proc(R)
 local E,i,a,b;
 global reason;

 if not(type(R,list) and nops(R) = N) then
  reason := [convert(procname,string),"R is not a list of length N",R,N];
  return false;
 fi;

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

 for i from 1 to N do
  if not `is_element/preord`(A)(R[i]) then
   reason := [convert(procname,string),"R[i] is not a preorder on A",R,i,A,reason];
   return false;
  fi;

  E := E intersect R[i] intersect `op/preord`(A)(R[i]);
 od;

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

 return true;
end:

`is_equal/PP` := (N::posint) -> (A::set) -> proc(R,S)
 local i;
 global reason;

 for i from 1 to N do
  if not(`is_equal/preord`(A)(R[i],S[i])) then
   reason := [convert(procname,string),"R[i] <> S[i]",i,R[i],S[i]];
   return false;
  fi;
 od;

 return true;
end:

`is_leq/PP` := (N::posint) -> (A::set) -> proc(R,S)
 local i;
 global reason;

 for i from 1 to N do
  if not(`is_leq/preord`(A)(R[i],S[i])) then
   reason := [convert(procname,string),"R[i] is not a subset of S[i]",i,R[i],S[i]];
   return false;
  fi;
 od;

 return true;
end:

`mu/F/PP` := (N::posint) -> (A::set) -> proc(x)
 local AA,a,b,i;

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

 [seq(select(ab -> x[ab[1]][i] <= x[ab[2]][i],AA),i=1..N)];
end:

`sigma/PP/F` := (N::posint) -> (A::set) -> proc(R)
 local x0,x,r,a,i;

 x0 := table();
 for i from 1 to N do
  r := eval(`rank_table/preord`(A)(R[i]));
  for a in A do x0[a,i] := r[a]; od;
 od;

 x := table();
 for a in A do x[a] := [seq(x0[a,i],i=1..N)]; od;

 return eval(x);
end;

`random_element/PP` := (N::posint) -> (A::set) -> proc()
 local R,ok,i;

 ok := false;
 while not(ok) do
  R := [seq(`random_element/preord`(A),i=1..N)];
  ok := `is_element/PP`(N)(A)(R);
 od;

 return R;
end;

`list_elements/PP` := (N::posint) -> proc(A::set)
 local RR,QQ,R,Q,i;

 RR := `list_elements/preord`(A);
 QQ := [[]];
 for i from 1 to N do
  QQ := [seq(seq([op(Q),R],R in RR),Q in QQ)];
 od;

 QQ := select(`is_element/PP`(N)(A),QQ);

 return QQ;
end;

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

`is_element/realisation/PP` := (N::posint) -> (A::set) ->
 `is_element/realisation/generic`("PP",
  eval(`is_element/PP`(N)(A)),
  eval(`is_leq/PP`(N)(A))
 );

`is_equal/realisation/PP` := (N::posint) -> (A::set) ->
 `is_equal/realisation/generic`("PP",
  eval(`is_equal/PP`(N)(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: gga_exc *)

rge2_kappa := 0.8040:

rge2_den := s -> rge2_kappa + 1*MU_GE*s^2 + MU_GE^2*s^4/rge2_kappa:
rge2_f0  := s -> 1 + rge2_kappa * (1 - rge2_kappa/rge2_den(s)):
rge2_f   := x -> rge2_f0(X2S * x):

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


(*
 Copyright (C) 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_s12_params *params;

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

s12g_f := x -> params_a_bx*(params_a_A + params_a_B*(1 - 1/(1 + params_a_C*x^2 + params_a_D*x^4))*(1 - 1/(1 + params_a_E*x^2))):

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


fd := fopen("nonlinfit.txt", APPEND):
with(plots):
with(Statistics):
with(LinearAlgebra):

dta := ImportMatrix("/tmp/dta.csv"):
len := RowDimension(dta):
x := dta[1 .. len, 1]; y := dta[1 .. len, 2]:
#pointplot([x, y]);
N:=15;
tmp := NonlinearFit(c*exp(a*ln(binomial(N, v))-(b-a)*ln(factorial(v))), x, y, v, output = [parametervalues, residualmeansquare], initialvalues = [a = 1, b = 1, c = 0.1e-5]):
print(tmp);
fprintf(fd,"%f , %f, %f,%f\n", eval(a, tmp[1]), eval(b, tmp[1]), eval(c, tmp[1]), tmp[2]):
fclose(fd):


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

(* prefix:
  mgga_x_mbr_params *params;

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

(* replace: "br89_x\(" -> "xc_mgga_x_br89_get_x(" *)

$include "mgga_x_br89.mpl"

params_a_at := 0:

(*Equation 15. The three equations below are from mgga_x_tm.mpl; note
that the numerical factors in the denominator in eqn 15 just
correspond to going from 'x' to 's'.*)
tm_p  := x -> (X2S*x)^2:
tm_y  := x -> (2*params_a_lambda - 1)^2 * tm_p(x):
tm_f0 := x -> (1 + 10*(70/27)*tm_y(x) + params_a_beta*tm_y(x)^2)^(1/10):

(* definition below equation 16 *)
mbr_D := (ts, xs) -> 2*ts - 1/4 * (2*params_a_lambda - 1)^2 * xs^2:

(* k_\sigma is not defined in the paper, but Subrata Jana
said on GitLab that k_\sigma = (6\pi^2\rho_\sigma)^{1/3} *)
k_sigma := (6*Pi^2)^(1/3):

(* Equation 18. Note that there's a typo in the paper: since Becke's
tau is two times the kinetic energy density, there should be a factor
of two in front of tau uniform as well. *)
br89_Q := (x, u, t) ->
  1/6*(
  + 6*(params_a_lambda^2 - params_a_lambda + 1/2)*(2*t - 2*K_FACTOR_C - 1/36*x^2)
  + 6/5*k_sigma^2*(tm_f0(x)^2 - 1)
  - 2*params_a_gamma*mbr_D(t, 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: mgga_exc *)
(* prefix:
  mgga_x_m06l_params *params;

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

$define gga_x_pbe_params
$include "gga_x_pbe.mpl"
$include "gvt4.mpl"

m06_alpha  := 0.00186726:
m06_coeff_d := params_a_d:

(* there is a factor if 2 in the definition of z, as in Theor. Chem. Account 120, 215 (2008) *)
(* A MINUS was missing in Eq. (7) of the paper *)

m06_f := (x, u, t) ->
  + pbe_f(x)*mgga_series_w(params_a_a, 12, t)
  + gtv4(m06_alpha, m06_coeff_d, x, 2*(t - K_FACTOR_C)):

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


(*
 Copyright (C) 2019 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"
$include "lda_x_erf.mpl"

(* See text after eq 7  *)
js18_H := x -> (2*tm_lambda - 1)^2 * tm_p(x):
(* See text after eq 7 *)
js18_G := (x, t) ->
  (3*(tm_lambda^2 - tm_lambda + 1/2)*(t - K_FACTOR_C - x^2/72) - (t - K_FACTOR_C)
   + 7/18*(2*tm_lambda - 1)^2*x^2)/K_FACTOR_C:

(* not to run into problems with erfs and exp *)
js18_A := (rs, z, x) -> m_max(1e-10, a_cnst*rs/(tm_f0(x)*opz_pow_n(z,1/3))):

js18_DME_SR := (rs, z, x, t) ->
  + attenuation_erf   (js18_A(rs, z, x))/tm_f0(x)^2
  + attenuation_erf_f2(js18_A(rs, z, x))*7*js18_G(x, t)/(9*tm_f0(x)^4)
  + attenuation_erf_f3(js18_A(rs, z, x))*245*js18_H(x)/(54*tm_f0(x)^4):

pjs18_f := (rs, z, x, u, t) -> js18_DME_SR(rs, z, x, t):

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


######################################################################
# W(N)(A) is Map(A,RR^N) modulo translation, except that we take
# W(N)(emptyset) to be empty.
#
# Elements are represented as tables indexed by A, whose values
# are lists of length N of real numbers.  The equivalence relation
# is built into the definition of the function `is_equal/W` rather
# than the representation of the elements.

`is_element/W` := (N::posint) -> (A::set) -> proc(x)
 local a;
 global reason;

 if A = {} then
  reason := [convert(procname,string),"W(N)(emptyset) = emptyset"];
  return false;
 fi;

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

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

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

 return true;
end;

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

 if A = {} then
  reason := [convert(procname,string),"W(N)(emptyset) = emptyset"];
  return false;
 fi;

 a0 := A[1];
 u0 := x[a0] -~ y[a0];

 for a in A do
  if not(`is_equal/R`(N)(x[a] -~ y[a],u0)) then
   reason := [convert(procname,string),"x[a] - y[a] <> x[a0] - y[a0]",a,a0];
   return false;
  fi;
 od;

 return true;
end;

`is_leq/W` := NULL;

`random_element/W` := (N::posint) -> (A::set) -> proc()
 local x,a;

 x := table();
 for a in A do
  x[a] := `random_element/R`(N)();
 od:

 return eval(x);
end;

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


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

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

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

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

$define lda_x_params
$include "lda_x.mpl"

mn12_omega_x := 2.5:
mn12_gamma_x := 0.004:

mn12_vx := (rs, z) -> 1/(1 + rs/(mn12_omega_x*RS_FACTOR)*(2/(1 + z))^(1/3)):
mn12_ux := x -> mn12_gamma_x*x^2/(1 + mn12_gamma_x*x^2):
mn12_wx := t -> (K_FACTOR_C - t)/(K_FACTOR_C + t):

mn12_pol1  := t-> params_a_c[ 1] + params_a_c[ 2]*mn12_wx(t) + params_a_c[ 3]*mn12_wx(t)^2 + params_a_c[ 4]*mn12_wx(t)^3
  + params_a_c[ 5]*mn12_wx(t)^4 + params_a_c[ 6]*mn12_wx(t)^5:
mn12_pol2  := t-> params_a_c[ 7] + params_a_c[ 8]*mn12_wx(t) + params_a_c[ 9]*mn12_wx(t)^2 + params_a_c[10]*mn12_wx(t)^3
   + params_a_c[11]*mn12_wx(t)^4:
mn12_pol3  := t-> params_a_c[12] + params_a_c[13]*mn12_wx(t) + params_a_c[14]*mn12_wx(t)^2 + params_a_c[15]*mn12_wx(t)^3:
mn12_pol4  := t-> params_a_c[16] + params_a_c[17]*mn12_wx(t) + params_a_c[18]*mn12_wx(t)^2:
mn12_pol5  := t-> params_a_c[19] + params_a_c[20]*mn12_wx(t) + params_a_c[21]*mn12_wx(t)^2 + params_a_c[22]*mn12_wx(t)^3
   + params_a_c[23]*mn12_wx(t)^4:
mn12_pol6  := t-> params_a_c[24] + params_a_c[25]*mn12_wx(t) + params_a_c[26]*mn12_wx(t)^2 + params_a_c[27]*mn12_wx(t)^3:
mn12_pol7  := t-> params_a_c[28] + params_a_c[29]*mn12_wx(t) + params_a_c[30]*mn12_wx(t)^2:
mn12_pol8  := t-> params_a_c[31] + params_a_c[32]*mn12_wx(t) + params_a_c[33]*mn12_wx(t)^2 + params_a_c[34]*mn12_wx(t)^3:
mn12_pol9  := t-> params_a_c[35] + params_a_c[36]*mn12_wx(t) + params_a_c[37]*mn12_wx(t)^2:
mn12_pol10 := t-> params_a_c[38] + params_a_c[39]*mn12_wx(t) + params_a_c[40]*mn12_wx(t)^2:

mn12_f := (rs, z, x, u, t) ->
  + mn12_pol1(t)
  + mn12_pol2(t)*mn12_ux(x)
  + mn12_pol3(t)*mn12_ux(x)^2
  + mn12_pol4(t)*mn12_ux(x)^3
  + mn12_pol5(t)*mn12_vx(rs, z)
  + mn12_pol6(t)*mn12_ux(x)*mn12_vx(rs, z)
  + mn12_pol7(t)*mn12_ux(x)^2*mn12_vx(rs, z)
  + mn12_pol8(t)*mn12_vx(rs, z)^2
  + mn12_pol9(t)*mn12_ux(x)*mn12_vx(rs, z)^2
  + mn12_pol10(t)*mn12_vx(rs, z)^3:

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


(*
 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 "attenuation.mpl"
$define gga_x_b88_params
$include "gga_x_b88.mpl"

(* Eq. 5 - Note that their K_s = 2*X_FACTOR_C*b88_f
   Note that there is a misprint sqrt(mu) -> sqrt(pi)
*)
lcgau_arg := (rs, z, xs) ->
  sqrt(2*X_FACTOR_C*b88_f(xs)/Pi)/(6*n_spin(rs, z)^(1/3)):

(* Eq. 4 + Eq. 8 *)
lcgau_f := (rs, z, xs) ->  b88_f(xs) * (
  + attenuation_erf(p_a_hyb_omega_0_*lcgau_arg(rs, z, xs))
  +  p_a_hyb_coeff_2_*attenuation_gau(p_a_hyb_omega_2_*lcgau_arg(rs, z, xs))
  +  p_a_hyb_coeff_3_*attenuation_gau(p_a_hyb_omega_3_*lcgau_arg(rs, z, xs))
  ):

f := (rs, zeta, xt, xs0, xs1) -> gga_exchange_nsp(lcgau_f, rs, zeta, xs0, xs1):


# E(N) is the set of polynomials of the form 0 or +/- epsilon^d
# with 0 <= d < N.

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

`is_element/E` := (N::posint) -> proc(u)
 local d;
 global reason;

 if not(`is_element/P`(N)(u)) then
  reason := [convert(procname,string)];
  return false;
 fi;

 if (u = 0) then return true; fi;

 d := degree(u,epsilon);
 if u <> epsilon^d and u <> -epsilon^d then
  reason := [convert(procname,string),"u <> +/- epsilon^d",u,d];
  return false;
 fi;

 return true;
end;

######################################################################
# `is_leq/E`(N)(u,v) is true if v-u is zero or is c epsilon^d + higher
# with c > 0.

`is_leq/E` :=  (N::posint) -> proc(u,v)
 local w,d,c;

 w := expand(v-u);
 if (w = 0) then return true; fi;
 d := ldegree(w,epsilon);
 c := coeff(w,epsilon,d);
 return evalb(c >= 0);
end:

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

`is_preceq/E` := (N::posint) -> proc(u,v)
 if (u = v) then return true; fi;
 if (u = 0) then return true; fi;
 if (v = 0) then return false; fi;
 return evalb(ldegree(u,epsilon) > ldegree(v,epsilon));
end:

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

`list_elements/E` := proc(N::posint)
 local i;
 return [seq(-epsilon^i,i=0..N-1),0,seq(epsilon^(N-1-i),i=0..N-1)];
end:

`random_element/E` := (N::posint) -> proc()
 local L;
 L := `list_elements/E`(N);
 L[rand(1..nops(L))()];
end:

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

`count_elements/E` := (N::posint) -> 2*N+1;

`abs/E` := (N::posint) -> proc(u)
 if (u = 0) then return 0; fi;
 return epsilon^degree(u,epsilon);
end:

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

`lambda/P/E` := (N::posint) -> proc(u)
 local c,d;

 if u = 0 then
  return 0;
 else
  d := ldegree(u,epsilon);
  c := coeff(u,epsilon,d);
  return signum(c) * epsilon^d;
 fi;
end:

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

`delta/P` := (N::posint) -> (u,v) -> `lambda/P/E`(N)(v-u);


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

with(StringTools):
scanners := map(l->[parse]~(l[2..-1]),
     map(Split,Split(SubstituteAll(input, "\n\n", "X"),"X"),"\n")):

truelocs := table();
truelocs[1] := scanners[1]; # base 0

sunknown := [seq(2..nops(scanners))];
knownscans := [1=[0,0,0]];

dist := (v,u) -> add((v[i]-u[i])^2,i=1..3):

# used to generate equations
M := Matrix(3,3,(i,j)->a[i,j]):
A := <a[0,1], a[0,2], a[0,3]>:

for k1 to nops(scanners)-1 do

    # find a scanner that overlaps with a known scanner
    for j1 from 1 to nops(knownscans) do
        sn1 := lhs(knownscans[j1]);
        scan0 := truelocs[sn1];

        for i1 from 1 to nops(sunknown) do
            # compute all pairwise distances
                sn2 := sunknown[i1];
                scan1 := scanners[sn2];
                n0 := nops(scan0); n1 := nops(scan1);
                # building pairs"
                M0 := Matrix([seq([seq(dist(scan0[i],scan0[j]),j=1..n0)],i=1..n0)]):
                M1 := Matrix([seq([seq(dist(scan1[i],scan1[j]),j=1..n1)],i=1..n1)]):

            ints01 := {entries(M0,'nolist')} intersect {entries(M1,'nolist')} minus {0};

            if nops(ints01) < 50 then
#                printf("scanner %d can not overlap  scanner %d -- only %d common pairs\n", sn1, sn2, nops(ints01) );
                next;
            end if; # at least 66 needed for 12 in common

                # looking up pair from their common distances
            pairs0 := NULL: pairs1 := NULL:
            for i from 1 to nops(ints01) do
                member(ints01[i], M0, 'loc0'); pairs0 := pairs0, [loc0];
                member(ints01[i], M1, 'loc1'); pairs1 := pairs1, [loc1];nu
            end do:
            pairs0 := [pairs0];
            pairs1 := [pairs1];

            # these are the overlapping sets of beacons
            o0 := [seq](ifelse(numboccur(pairs0,i)=11,i,NULL),i=1..n0);
            o1 := [seq](ifelse(numboccur(pairs1,i)=11,i,NULL),i=1..n1);
            if nops(o0) <> 12 then
                #printf("found only %d=%d overlaps between %d and %d skipping\n", nops(o0), nops(o1), sn1, sn2);
                next;
            end if;

            # determine the pairings
            pot01matches := table(sparse={o1[]});

            for i from 1 to nops(pairs0) do
                if pairs0[i][1] in o0 and pairs0[i][2] in o0 then # check o2 too?
                pot01matches[pairs0[i][1]] := pot01matches[pairs0[i][1]] intersect {pairs1[i][]};
                pot01matches[pairs0[i][2]] := pot01matches[pairs0[i][2]] intersect {pairs1[i][]};
                end if;
            end do;

            if {} in {entries(pot01matches,'nolist')} then
                printf("found a contradiction in the potential pairings\n");
                next;
            end if;

            matches01 := map(p->lhs(p)=rhs(p)[], [entries(pot01matches,'pairs')]);

            # use symbolic computation to build the equations to solve for the rotation
            # and translation
            eqs := {seq(seq((M . Vector(scan1[rhs(matches01[k])]) + A)[j]
                = Vector(scan0[lhs(matches01[k])])[j], j=1..3),k=1..4)};
            sol := solve( eqs );

            Mo := eval(M, sol);
            a0 := eval(<a[0,1], a[0,2], a[0,3]>, sol);

            scan1 := [seq(convert(Mo . Vector(scan1[i]) + a0,list), i=1..nops(scan1))];
            knownscans := [knownscans[], sn2=convert(a0,list)];
            sunknown := subsop(i1=NULL, sunknown); # remove this scan from the unknowns
            truelocs[sn2] := scan1;
            break;

        end do;
    end do;
end do;

ASSERT(nops(knownscans) = nops(scanners));
answer1 := nops( map(op, {entries}(truelocs,'nolist') ) );

# compute the Manhatten distance between scanners
mdist := (u,v) -> add(abs(u[i]-v[i]),i=1..3):
scannerlocs := map(rhs, knownscans);
answer2 := max( seq(seq(mdist(scannerlocs[i],scannerlocs[j]),j=i+1..nops(scannerlocs)),i=1..nops(scannerlocs)));


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

  assert(pt->params != NULL);
  params = (mgga_x_m08_params * ) (pt->params);
*)

params_a_rpbe_kappa := 0.552:
params_a_rpbe_mu    := MU_GE:
$include "gga_x_rpbe.mpl"

params_a_kappa := KAPPA_PBE:
params_a_mu    := 0.21951:
$include "gga_x_pbe.mpl"

m08_f := (a, b, x, t) ->
  + f_pbe(x) *mgga_series_w(a, 12, t)
  + f_rpbe(x)*mgga_series_w(b, 12, t):

f_m08 := (x, t) ->
  m08_f(params_a_a, params_a_b, x, t):

f := (rs, x, t, u) ->
  f_m08(x, t):


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

par_n := 6:

gamma_x := 0.004:
par_x := [
    [  0.85,  0, 0],
    [  1.007, 0, 1],
    [  0.259, 1, 0],
    [  0,   0, 0],
    [  0,   0, 0],
    [  0,   0, 0]
]:

gamma_ss := 0.2:
par_ss := [
    [  0.443,  0, 0],
    [ -1.437,  0, 4],
    [ -4.535,  1, 0],
    [ -3.39,   2, 0],
    [  4.278,  4, 3],
    [  0,    0, 0]
]:

gamma_os := 0.006:
par_os := [
    [  1.000,  0, 0],
    [  1.358,  1, 0],
    [  2.924,  2, 0],
    [ -8.812,  2, 1],
    [ -1.39,   6, 0],
    [  9.142,  6, 1]
]:

$include "lda_x_erf.mpl"
$include "b97mv.mpl"

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


read "../IdentifiabilityODE.mpl";

sys := [
diff(s(t), t) = -b1*b0*s(t)*x1(t)*i(t) - b0*s(t)*i(t) - s(t)*mu + mu + g*r(t),
diff(x2(t), t) = M*x1(t),
diff(i(t), t) = -nu*i(t) + b1*b0*s(t)*x1(t)*i(t) + b0*s(t)*i(t) - mu*i(t),
diff(r(t), t) = nu*i(t) - mu*r(t) - g*r(t),
diff(x1(t), t) = -M*x2(t),
y1(t) = i(t),
y2(t) = r(t)
];
CodeTools[CPUTime](IdentifiabilityODE(sys, GetParameters(sys)));


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

(* Equation (7) from the paper *)

tpss_p := x -> X2S^2*x^2:
tpss_z := (x, t) -> x^2/(8*t):

tpss_alpha := (x, t) -> (t - x^2/8)/K_FACTOR_C:
tpss_qb    := (x, t) -> \
      9/20 * (tpss_alpha(x, t) - 1)/sqrt(1 + params_a_b*tpss_alpha(x, t)*(tpss_alpha(x, t) - 1)) \
      + 2*tpss_p(x)/3:

(* Equation (10) in all its glory *)
tpss_fxnum := (x, t) -> \
      + (MU_GE + params_a_c*tpss_z(x, t)^tpss_ff(tpss_z(x, t))/(1 + tpss_z(x, t)^2)^2)*tpss_p(x) \
      + 146/2025 * tpss_qb(x, t)^2 \
      - 73/405 * tpss_qb(x, t) * sqrt(1/2*(9/25*tpss_z(x, t)^2 + tpss_p(x)^2)) \
      + MU_GE^2/tpss_kappa(x, t) * tpss_p(x)^2 \
      + 2*sqrt(params_a_e)*MU_GE*9/25*tpss_z(x, t)^2 \
      + params_a_e*params_a_mu*tpss_p(x)^3:

tpss_fxden := x -> \
      (1 + sqrt(params_a_e)*tpss_p(x))^2:

tpss_fx    := (x, t) -> tpss_fxnum(x, t)/tpss_fxden(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_rda_params *params;

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

rda_s := x -> X2S*x:
rda_p := u -> X2S^2*u:

(* Equation (61) *)
rda_k4 := (s, p, b) -> sqrt(s^4 + b*p^2):
(* Equation (63) *)
rda_k2 := (s, p, b) -> s^2 + b*p:

(* Equation (71); first term is von Weiszäcker according to equation (13) *)
rda_f0 := (s, p) ->
       5/3*s^2 + params_a_A0
       + params_a_A1 * (rda_k4(s,p,params_a_a) / (1 + params_a_beta1*rda_k4(s,p,params_a_a)))^2
       + params_a_A2 * (rda_k4(s,p,params_a_b) / (1 + params_a_beta2*rda_k4(s,p,params_a_b)))^4
       + params_a_A3 * (rda_k2(s,p,params_a_c) / (1 + params_a_beta3*rda_k2(s,p,params_a_c))):

(* Complete functional *)
rda_f := (xs, us) -> rda_f0(rda_s(xs), rda_p(us)):

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


with(DifferentialThomas):
with(Tools):
Ranking([t], [[x15, x13, x7, x9, x2, x8, x14, x5, x4, x12, x6, x1, x10, x11, x3], [y4, y6, y2, y1, y3, y5] , [u]]):
sys := [
diff(x15(t), t) - (-1/2500*x15(t) + 1/2000000*x7(t)),
diff(x13(t), t) - (e2a*x14(t) + 1/2*x10(t)*x6(t) - x2(t)*x13(t) - 1/50000*x13(t)),
diff(x7(t), t) - (5*i1*x6(t) - 1/2*x11(t)*x7(t)),
diff(x9(t), t) - (-1/2500*x9(t) - 1/2000000*x7(t)),
diff(x2(t), t) - (-1/5*x10(t)*x2(t) - x2(t)*x13(t) - x2(t)*k_deg - x2(t)*k2*u(t)*x8(t) - x2(t)*k3 + x1(t)*u(t)*k1 + x4(t)*t1 + x5(t)*t2),
diff(x8(t), t) - (1/2*x9(t) - c5*x8(t)),
diff(x14(t), t) - (-5*e2a*x14(t) + 1/2*x11(t)*x7(t)),
diff(x5(t), t) - (x2(t)*x13(t) - x5(t)*t2),
diff(x4(t), t) - (1/5*x10(t)*x2(t) - x4(t)*t1),
diff(x12(t), t) - (1/2000000*x7(t) - c3a*x12(t)),
diff(x6(t), t) - (-1/2*x10(t)*x6(t) + 1/50000*x13(t) - i1*x6(t) - x5(t)*t2),
diff(x1(t), t) - (-x1(t)*k_deg - x1(t)*u(t)*k1 + k_prod),
diff(x10(t), t) - (-1/5*x10(t)*x2(t) - x10(t)*i1a - 1/2*x10(t)*x6(t) - 1/10000*x10(t) + 1/2000*x11(t) + x12(t)*c4a),
diff(x11(t), t) - (5*x10(t)*i1a - 1/2*x11(t)*x7(t) - 1/400*x11(t)),
diff(x3(t), t) - (x2(t)*k2*u(t)*x8(t) + x2(t)*k3 - x3(t)*k_deg),
y4(t) - (x2(t) + x3(t) + x1(t)),
y6(t) - (x12(t)),
y2(t) - (x10(t) + x13(t)),
y1(t) - (x7(t)),
y3(t) - (x9(t)),
y5(t) - (x2(t))
];
res := CodeTools[CPUTime](ThomasDecomposition(sys));


######################################################################
# W1(A) is Map(A,RR) modulo translation, except that we take
# W1(emptyset) to be empty.
#
# Elements are represented as tables indexed by A, whose values
# are real numbers.  The equivalence relation
# is built into the definition of the function `is_equal/W1` rather
# than the representation of the elements.

`is_element/W1` := (A::set) -> proc(x)
 local a;
 global reason;

 if A = {} then
  reason := [convert(procname,string),"W1(emptyset) = emptyset"];
  return false;
 fi;

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

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

 return true;
end;

`is_equal/W1` := (A::set) -> proc(x,y)
 local a0,u0,a;
 global reason;

 if A = {} then
  reason := [convert(procname,string),"W1(emptyset) = emptyset"];
  return false;
 fi;

 a0 := A[1];
 u0 := x[a0] - y[a0];

 for a in A do
  if not(`is_equal/RR`(x[a] - y[a],u0)) then
   reason := [convert(procname,string),"x[a] - y[a] <> x[a0] - y[a0]",a,a0];
   return false;
  fi;
 od;

 return true;
end;

`is_leq/W1` := NULL;

`random_element/W1` := (A::set) -> proc()
 local x,a;

 x := table();
 for a in A do
  x[a] := `random_element/RR`();
 od:

 return eval(x);
end;

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


`is_element/graphs` := (V::set) -> proc(E)
 if not(`is_element/autorel`(V)(E)) then
  return false;
 fi;

 if not(`is_symmetric/autorel`(V)(E)) then
  return false;
 fi;

 if not(`is_irreflexive/autorel`(V)(E)) then
  return false;
 fi;

 return true;
end:

`is_leq/graphs` := (V::set) -> (E0,E1) -> evalb(E0 minus E1 = {}):

`list_elements/graphs` := proc(V::set)
 local n,E0,EE,i,j;

 n := nops(V);
 E0 := {seq(seq([V[i],V[j]],j=i+1..n),i=1..n-1)};
 EE := `list_elements/subsets`(E0);
 EE := map(E -> E union `op/autorel`(V)(E),EE);
 return EE;
end:

`count_elements/graphs` := (V::set) -> 2^(nops(V)*(nops(V)-1)/2);

`random_element/graphs` := (V::set) -> proc()
 local n,E0,E,i,j;

 n := nops(V);
 E0 := {seq(seq([V[i],V[j]],j=i+1..n),i=1..n-1)};
 E := `random_element/subsets`(E0)();
 E := E union `op/autorel`(V)(E);
 return E;
end:

`neighbour_table/graphs` := (V) -> proc(E)
 local N,v,e;

 N := table();
 for v in V do N[v] := {}; od:
 for e in E do
  N[e[1]] := {op(N[e[1]]),e[2]};
 od:

 return eval(N);
end:

`component_relation/graphs` := (V) -> (E) ->
 `transitive_closure/autorel`(V)(
  E union `id/autorel`(V)
 );

`components/graphs` := (V) -> (E) ->
 `block_partition/equiv`(`component_relation/graphs`(V)(E));

`is_connected/graphs` := (V) -> (E) ->
 evalb(`component_relation/graphs`(V)(E) = `top/autorel`(V));

`is_forest/graphs` := (V) -> proc(E)
 local CC,V0,E0;

 CC := `components/graphs`(V)(E);

 for V0 in CC do
  E0 := select(e -> member(e[1],V0),V0);

  if nops(E0) <> nops(V0) - 1 then
   return false;
  fi;
 od:

 return true;
end:

`is_tree/graphs` := (V) -> proc(E)
 `is_connected/graphs`(V)(E) and
  nops(E) = nops(V) - 1;
end:

`skeleton/graphs` := (V::set) -> proc(E)
 local n,V0,E0,ix,i;

 n := nops(V);
 V0 := {seq(i,i=1..n)};
 ix := table():
 for i from 1 to n do ix[V[i]] := i; od;
 E0 := map(e -> [ix[e[1]],ix[e[2]]],E);
 return [V0,E0];
end:

`is_element/paths` := (V) -> (E) -> proc(p)
 local i,n;

 if not type(p,list) then
  return false;
 fi;

 n := nops(p) - 1;

 if n < 0 then
  return false;
 fi;

 if {op(p)} minus V <> {} then
  return false;
 fi;

 for i from 1 to n do
  if not(member([p[i],p[i+1]],E)) then
   return false;
  fi;
 od;

 return true;
end:

`is_small_element/paths` := (V) -> (E) -> (n::nonnegint) -> proc(p)
 return evalb(`is_element/paths`(V)(E)(p) and (nops(p) = n+1));
end:

`random_small_element/paths` := (V) -> (E) -> (n::nonnegint) -> proc()
 local v,p,e,i;

 if E = {} then
  if V = {} or n > 0 then
   return FAIL;
  else
   return [random_element_of(V)()];
  fi;
 fi;

 v := random_element_of(E)()[1];
 p := v;
 for i from 1 to n do
  e := random_element_of(select(e -> member(v,e),E))();
  v := op({op(e)} minus {v});
  p := p,v;
 od;
 return [p];
end:

`list_small_elements/paths` := (V) -> (E) -> proc(n::nonnegint)
 option remember;
 local P,Q,p,v,F,e;

 if n = 0 then
  return map(v -> [v],V);
 else
  P := `list_small_elements/paths`(V)(E)(n-1);
  Q := NULL;
  for p in P do
   v := p[1];
   F := select(e -> e[2] = v,E);
   Q := Q,seq([e[1],op(p)],e in F);
  od:
  return [Q];
 fi;
end:

`is_leq/paths` := NULL;
`count_elements/paths` := NULL:
`count_small_elements/paths` := NULL:

`length/paths` := (V) -> (E) -> (p) -> nops(p) - 1;

`is_trail/paths` := proc(p)
 local n,e,i;
 n := nops(p) - 1;
 e := {seq([p[i],p[i+1]],i=1..n)};
 return evalb(nops(e) = n);
end:

`is_cycle/paths` := proc(p)
 local n,i;
 n := nops(p) - 1;
 return evalb(p[1] = p[n+1] and nops({seq(p[i],i=1..n)}) = n);
end:

`is_small_element/trails` := (V) -> (E) -> (n) -> proc(p)
 if not `is_small_element/paths`(V)(E)(n)(p) then
  return false;
 fi;

 return `is_trail/paths`(p);
end:

`is_element/trails` := (V) -> (E) -> proc(p)
 if not `is_element/paths`(V)(E)(p) then
  return false;
 fi;

 return `is_trail/paths`(p);
end:

`list_small_elements/trails` := (V) -> (E) -> proc(n)
 option remember;
 local E0,E1,P,Q,p,v,F,i,e;

 if n = 0 then
  return map(v -> [v],V);
 else
  P := `list_small_elements/trails`(V)(E)(n-1);
  Q := NULL;
  for p in P do
   E0 := {seq([p[i],p[i+1]],i=1..n-1),seq([p[i+1],p[i]],i=1..n-1)};
   E1 := E minus E0;
   v := p[1];
   F := select(e -> e[2] = v,E1);
   Q := Q,seq([e[1],op(p)],e in F);
  od:
  return [Q];
 fi;
end:

`random_small_element/trails` := (V) -> (E) -> (n) -> proc(num_tries := 10)
 local k,p,E0,E1,v,F,e,i;

 k := num_tries;

 if n = 0 then
  if V = {} then
   return FAIL;
  else
   return [random_element_of(V)()];
  fi;
 elif n = 1 then
  if E = {} then
   return FAIL;
  else
   return random_element_of(E)();
  fi;
 fi;

 while k > 0 do
  p := `random_small_element/trails`(V)(E)(n-1)();
  k := k - 1;
  if p <> FAIL then
   E0 := {seq([p[i],p[i+1]],i=1..n-1),seq([p[i+1],p[i]],i=1..n-1)};
   E1 := E minus E0;
   v := p[1];
   F := select(e -> e[2] = v,E1);
   if F <> {} then
    e := random_element_of(F)();
    return [e[1],op(p)];
   fi;
  fi;
 od;

 return FAIL;
end:

`is_leq/trails` := NULL:
`count_elements/trails` := NULL:
`count_small_elements/trails` := NULL:

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


with(DifferentialAlgebra):
ring_diff := DifferentialRing(blocks = [[x5, x6, x4, x2, x1, x3], [y1, y2] ], derivations = [t]):
sys := [
diff(x5(t), t) - (k5*x6(t) + k4*x6(t) - k6*x5(t)*x3(t)),
diff(x6(t), t) - (-k5*x6(t) - k4*x6(t) + k6*x5(t)*x3(t)),
diff(x4(t), t) - (-k3*x4(t) - k2*x4(t) + k1*x1(t)*x2(t)),
diff(x2(t), t) - (k3*x4(t) + k2*x4(t) + k1*x1(t)*x2(t)),
diff(x1(t), t) - (k4*x6(t) + k2*x4(t) - k1*x1(t)*x2(t)),
diff(x3(t), t) - (k5*x6(t) + k3*x4(t) - k6*x5(t)*x3(t)),
y1(t) - (x3(t)),
y2(t) - (x2(t))
];
res := CodeTools[CPUTime](RosenfeldGroebner(sys, ring_diff, singsol=none));


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

gea2_s := x -> X2S*x:
gea2_q := u -> X2S^2*u:

gea2_f0 := (s, q) -> 1 + 5/27*s^2 + 20/9*q:
gea2_f := (x, u) ->
  gea2_f0(gea2_s(x), gea2_q(u)):

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


(*
 Copyright (C) 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_c_scan.mpl"

(* Coefficients of the rSCAN switching function from SI, in reversed(!) order: 7, 6, ..., 0 *)
rscan_fc := [-0.051848879792, 0.516884468372, -1.915710236206, 3.061560252175, -1.535685604549, -0.4352, -0.64, 1]:

np53 := rs -> n_total(rs)^(5/3):
(* First regularization: tau^u -> tau^u + tau^r *)

rscan_alpha0 := (rs, z, xt, ts0, ts1) ->
  (np53(rs)*m_max(t_total(z, ts0, ts1) - xt^2/8, 0))/((K_FACTOR_C*np53(rs) + 2^(2/3)*params_a_taur)*t_total(z, 1, 1)):

(* Second regularization: alpha -> alpha^3/(alpha^2 + alpha_r) *)
rscan_alpha := (rs, z, xt, ts0, ts1) -> rscan_alpha0(rs, z, xt, ts0, ts1)^3/(rscan_alpha0(rs, z, xt, ts0, ts1)^2 + params_a_alphar):

(* f(alpha) replaced with a polynomial for alpha in [0, 2.5] *)
rscan_f_alpha_small := (a,ff) -> add(ff[8-i]*a^i, i=0..7):
rscan_f_alpha_large := a -> -params_a_d*exp(params_a_c2/(1 - a)):
rscan_f_alpha := (a, ff) -> my_piecewise3( a <= 2.5, rscan_f_alpha_small(m_min(a, 2.5),ff), rscan_f_alpha_large(m_max(a, 2.5)) ):

(* set parameters of f_alpha *)
params_a_alphar := 1e-3:
params_a_taur := 1e-4:

rscan_f := (rs, z, xt, xs0, xs1, ts0, ts1) ->
  f_pbe(rs, z, xt, xs0, xs1) + rscan_f_alpha(rscan_alpha(rs, z, xt, ts0, ts1), rscan_fc)*(
    + scan_e0(rs, z, X2S*2^(1/3)*xt)
    - f_pbe(rs, z, xt, xs0, xs1)
  ):

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


(*
 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_n := 19:

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

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

params_a_omega := [
   +0.678831e+00, -0.175821e+01, +0.127676e+01, -0.160789e+01, +0.365610e+00, -0.181327e+00,
   +0.146973e+00, +0.147141e+00, -0.716917e-01, -0.407167e-01, +0.214625e-01, -0.768156e-03,
   +0.310377e-01, -0.720326e-01, +0.446562e-01, -0.266802e+00, +0.150822e+01, -0.194515e+01,
   +0.679078e+00
]:

$include "th.mpl"

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


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

interface(quiet=true):

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

L := 12:

printf("   memory requirement for L = %d and two triple-double tables: %d bytes\n",L,48*2^(ceil(L/2)));

rmax := log(2) / (2^(L+1)):

printf("   maximal absolute value for rmax = 2^(%f)\n",log[2](rmax)):

MsLog2Div2L := evalf(-log(2)/(2^L)):

msLog2Div2Lh, msLog2Div2Lm, msLog2Div2Ll := hi_mi_lo(MsLog2Div2L):

epsMsLog2Div2L := evalf(abs(((msLog2Div2Lh + msLog2Div2Lm + msLog2Div2Ll) - MsLog2Div2L)/MsLog2Div2L)):
epsDDMsLog2Div2L := evalf(abs(((msLog2Div2Lh + msLog2Div2Lm) - MsLog2Div2L)/MsLog2Div2L)):

printf("   error made by storing MsLog2Div2L as a double-double: 2^(%f)\n",log[2](epsDDMsLog2Div2L)):
printf("   error made by storing MsLog2Div2L as a triple-double: 2^(%f)\n",log[2](epsMsLog2Div2L)):

gap := -floor(-log[2](abs(msLog2Div2Lm/msLog2Div2Lh))):

printf("   |msLog2Div2Lm| <= 2^(%f) * |msLog2Div2Lh|\n",gap):

log2InvMult2L := nearest(2^L / (log(2))):

shiftConst := 2^(52) + 2^(51):

indexmask1 := 2^(L/2) - 1:
indexmask2 := indexmask1 * 2^(L/2):

largest := 2^(1023) * ((2^(53) - 1) / 2^(52)):
smallest := 2^(-1023) * 1 * 2^(-51):

overflowbound := nearest(log(largest)):

overflowboundHex := ieeehexa(overflowbound):
overflowSimplebound := convert(overflowboundHex[1],decimal,hex):

underflowbound := nearest(log(2^(-1075))):

denormbound := nearest(log(2^(-1022) * 1)):

overUnderflowboundHex := ieeehexa(min(abs(underflowbound),min(abs(overflowbound),abs(denormbound)))):
overUnderflowSimplebound := convert(overUnderflowboundHex[1],decimal,hex):

twoPowerM1000 := 2^(-1000):
twoPower1000 := 2^(1000):

twoM52 := 2^(-52):
mTwoM53 := - 2^(-53):

for i from 0 to 2^(L/2) - 1 do
	twoPowerIndex1hi[i], twoPowerIndex1mi[i], twoPowerIndex1lo[i] := hi_mi_lo(evalf(2^(i/(2^L)))):
	twoPowerIndex2hi[i], twoPowerIndex2mi[i], twoPowerIndex2lo[i] := hi_mi_lo(evalf(2^(i/(2^(L/2))))):
od:

PolyDegreeQuick:=4:
printf("   degree of the polynomial used in the quick phase is %d\n",PolyDegreeQuick);

polyQuick:= poly_exact(1 + x + 0.5*x^2 + x^3 * (numapprox[minimax](((exp(x) - (1 + x + 0.5*x^2))/x^3),
				x=-rmax..rmax, [PolyDegreeQuick-3,0], 1 ,  'deltaApprox'))):

epsilonApproxQuick := numapprox[infnorm]( ((polyQuick-1)/(exp(x)-1))-1, x=-rmax..rmax):
printf("   approximation rel error for the quick phase is 2^(%2f)\n", log2(epsilonApproxQuick) ) :
deltaApproxQuick := numapprox[infnorm]( polyQuick-exp(x), x=-rmax..rmax):
printf("   approximation abs error for the quick phase is 2^(%2f)\n", log2(deltaApproxQuick) ) :

PolyDegreeAccurate:=7:

printf("   degree of the polynomial used in the accurate phase is %d\n",PolyDegreeAccurate):

DDNumberAccu:=5:

printf("   number of double doubles used for the coefficients is %d\n",DDNumberAccu):

polyAccurate:= poly_exact2(1 + x + 0.5*x^2 + x^3 * (numapprox[minimax](((exp(x) - (1 + x + 0.5*x^2))/x^3),
				x=-rmax..rmax, [PolyDegreeAccurate-3,0], 1 ,  'deltaApprox')),
				DDNumberAccu):

epsilonApproxAccurate := numapprox[infnorm]( ((polyAccurate-1)/(exp(x)-1))-1, x=-rmax..rmax):
printf("   approximation rel error for the accurate phase is 2^(%2f)\n", log2(epsilonApproxAccurate) ) :
deltaApproxAccurate := numapprox[infnorm]( polyAccurate-exp(x), x=-rmax..rmax):
printf("   approximation abs error for the accurate phase is 2^(%2f)\n", log2(deltaApproxAccurate) ) :

epsilonApproxRmAccurate := numapprox[infnorm]( (x/(exp(x)-1))-1, x=-rmax*2^(-52)..rmax*2^(-52)):
epsilonApproxRlAccurate := numapprox[infnorm]( (x/(exp(x)-1))-1, x=-rmax*2^(-105)..rmax*2^(-105)):

printf("   approximation rel error for approximating exp(rm) - 1 by rm is 2^(%2f)\n", log2(abs(epsilonApproxRmAccurate))):
printf("   approximation rel error for approximating exp(rl) - 1 by rl is 2^(%2f)\n", log2(abs(epsilonApproxRlAccurate))):

epsilonApproxAccurateSpecial := numapprox[infnorm]( ((polyAccurate-1)/(exp(x)-1))-1, x=-2^(-30)..2^(-30)):
printf("   approximation rel error for the accurate phase in the special interval (|r| \\leq 2^(-30)) is 2^(%2f)\n",
log2(epsilonApproxAccurateSpecial) ) :

epsilonApproxAccurateSpecial2 := numapprox[infnorm]( ((polyAccurate-1)/(exp(x)-1))-1, x=-2^(-18)..2^(-18)):
printf("   approximation rel error for the accurate phase in the special interval (|r| \\leq 2^(-18)) is 2^(%2f)\n",
log2(epsilonApproxAccurateSpecial2) ) :

epsilon_quick := 2^(-64): # The Gappa proof will show this bound

#-------------------------------------------------------------------
# Output

filename:="TEMPEXP/exp-td.h":
fd:=fopen(filename, WRITE, TEXT):

fprintf(fd, "#include \"crlibm.h\"\n#include \"crlibm_private.h\"\n"):

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

fprintf(fd, "\#define L %d\n",L):
fprintf(fd, "\#define LHALF %d\n",L/2):
fprintf(fd, "\#define log2InvMult2L %1.50e\n",log2InvMult2L):
fprintf(fd, "\#define msLog2Div2Lh %1.50e\n",msLog2Div2Lh):
fprintf(fd, "\#define msLog2Div2Lm %1.50e\n",msLog2Div2Lm):
fprintf(fd, "\#define msLog2Div2Ll %1.50e\n",msLog2Div2Ll):
fprintf(fd, "\#define shiftConst %1.50e\n",shiftConst):
fprintf(fd, "\#define INDEXMASK1 0x%08x\n",indexmask1):
fprintf(fd, "\#define INDEXMASK2 0x%08x\n",indexmask2):
fprintf(fd, "\#define OVRUDRFLWSMPLBOUND 0x%08x\n",overUnderflowSimplebound):
fprintf(fd, "\#define OVRFLWBOUND %1.50e\n",overflowbound):
fprintf(fd, "\#define LARGEST %1.50e\n",largest):
fprintf(fd, "\#define SMALLEST %1.50e\n",smallest):
fprintf(fd, "\#define DENORMBOUND %1.50e\n",denormbound):
fprintf(fd, "\#define UNDERFLWBOUND %1.50e\n",underflowbound):
fprintf(fd, "\#define twoPowerM1000 %1.50e\n",twoPowerM1000):
fprintf(fd, "\#define twoPower1000 %1.50e\n",twoPower1000):
fprintf(fd, "\#define ROUNDCST %1.50e\n", compute_rn_constant(epsilon_quick)):
fprintf(fd, "\#define RDROUNDCST %1.50e\n", epsilon_quick):
fprintf(fd, "\#define twoM52 %1.50e\n", twoM52):
fprintf(fd, "\#define mTwoM53 %1.50e\n", mTwoM53):

fprintf(fd,"\n\n"):

for i from 3 to PolyDegreeQuick do
	fprintf(fd, "\#define c%d %1.50e\n",i,coeff(polyQuick,x,i)):
od:

for i from 3 to DDNumberAccu-1 do
	(hi,lo) := hi_lo(coeff(polyAccurate,x,i)):
	fprintf(fd, "\#define accPolyC%dh %1.50e\n",i,hi):
	fprintf(fd, "\#define accPolyC%dl %1.50e\n",i,lo):
od:

for i from DDNumberAccu to PolyDegreeAccurate do
	fprintf(fd, "\#define accPolyC%d %1.50e\n",i,coeff(polyAccurate,x,i)):
od:

fprintf(fd,"\n\n"):

# Print the tables
fprintf(fd, "typedef struct tPi_t_tag {double hi; double mi; double lo;} tPi_t;  \n"):
fprintf(fd, "static const tPi_t twoPowerIndex1[%d] = {\n", 2^(L/2)):
for i from 0 to 2^(L/2)-1 do
      fprintf(fd, "  { \n"):
      fprintf(fd, "    %1.50e, /* twoPowerIndex1hi[%d] */ \n", twoPowerIndex1hi[i], i):
      fprintf(fd, "    %1.50e, /* twoPowerIndex1mi[%d] */ \n", twoPowerIndex1mi[i], i):
      fprintf(fd, "    %1.50e, /* twoPowerIndex1lo[%d] */ \n", twoPowerIndex1lo[i], i):
      fprintf(fd, "  } "):
      if(i<2^(L/2)-1) then  fprintf(fd, ", \n"): fi
od:
fprintf(fd, "}; \n \n"):
fprintf(fd, "static const tPi_t twoPowerIndex2[%d] = {\n", 2^(L/2)):
for i from 0 to 2^(L/2)-1 do
      fprintf(fd, "  { \n"):
      fprintf(fd, "    %1.50e, /* twoPowerIndex2hi[%d] */ \n", twoPowerIndex2hi[i], i):
      fprintf(fd, "    %1.50e, /* twoPowerIndex2mi[%d] */ \n", twoPowerIndex2mi[i], i):
      fprintf(fd, "    %1.50e, /* twoPowerIndex2lo[%d] */ \n", twoPowerIndex2lo[i], i):
      fprintf(fd, "  } "):
      if(i<2^(L/2)-1) then  fprintf(fd, ", \n"): fi
od:
fprintf(fd, "}; \n \n"):

fprintf(fd, "\n\n"):

fclose(fd):

filename:="TEMPEXP/exp-td-accurate.sed":
fd:=fopen(filename, WRITE, TEXT):
fprintf(fd, " s/_rhmax/%1.50e/g\n", rmax):
fprintf(fd, " s/_rmmax/%1.50e/g\n", rmax*2^(-52)):
fprintf(fd, " s/_rlmax/%1.50e/g\n", rmax*2^(-105)):
fprintf(fd, " s/_epsilonApproxAccurate/%1.50e/g\n", epsilonApproxAccurate):
fprintf(fd, " s/_epsilonApproxRmAccurate/%1.50e/g\n", epsilonApproxRmAccurate):
fprintf(fd, " s/_epsilonApproxRlAccurate/%1.50e/g\n", epsilonApproxRlAccurate):
fprintf(fd, " s/_epsilonApproxSpecial/%1.50e/g\n", epsilonApproxAccurateSpecial):

for i from 3 to DDNumberAccu-1 do
	(hi,lo) := hi_lo(coeff(polyAccurate,x,i)):
	fprintf(fd, "s/_accPolyC%dh/%1.50e/g\n",i,hi):
	fprintf(fd, "s/_accPolyC%dl/%1.50e/g\n",i,lo):
od:

for i from DDNumberAccu to PolyDegreeAccurate do
	fprintf(fd, "s/_accPolyC%d/%1.50e/g\n",i,coeff(polyAccurate,x,i)):
od:

fclose(fd):

printf("----DONE---\n") :