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

$define xc_dimensions_2d

ax := -4/3*sqrt(2)/Pi:

f := (rs, z) -> ax*f_zeta_2d(z)/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 *)

mbeta  := 0.003317:
mgamma := 0.008323:

f := x -> 1 + mbeta/X_FACTOR_C*x^2/(1 + mgamma*x^2)^(3/4):


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

airy_a5  := 133.983631:
airy_a6  :=   3.217063:
airy_a7  := 136.707378:
airy_a8  :=   3.223476:
airy_a9  :=   2.675484:
airy_a10 :=   3.473804:

airy_f1 := s -> (1 - airy_a5*s^airy_a6 + airy_a7*s^airy_a8)/(1 + airy_a9*s^airy_a10):

$include "gga_x_lag.mpl"

airy_f := x -> lag_f0(X2S*x) + airy_f1(X2S*x):

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

(* Equation (7) from the paper *)

p     := x -> X2S^2*x^2:
z     := (x, t) -> x^2/(8*t):

alpha := (x, t) -> (t - x^2/8)/K_FACTOR_C:
qb    := (x, t) -> \
      9/20 * (alpha(x, t) - 1)/sqrt(1 + params_a_b*alpha(x, t)*(alpha(x, t) - 1)) \
      + 2*p(x)/3:

(* Equation (10) in all its glory *)
fxnum := (x, t) -> \
      + (MU_GE + params_a_c*z(x, t)^ff(z(x, t))/(1 + z(x, t)^2)^2)*p(x) \
      + 146/2025 * qb(x, t)^2 \
      - 73/405 * qb(x, t) * sqrt(1/2*(9/25*z(x, t)^2 + p(x)^2)) \
      + MU_GE^2/mkappa(x, t) * p(x)^2 \
      + 2*sqrt(params_a_e)*MU_GE*9/25*z(x, t)^2 \
      + params_a_e*params_a_mu*p(x)^3:

fxden := x -> \
      (1 + sqrt(params_a_e)*p(x))^2:

fx    := (x, t) -> fxnum(x, t)/fxden(x):


`is_element/binary_trees` := (A::set) -> proc(TT)
 global reason;

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

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

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

`is_equal/binary_trees` := eval(`is_equal/full_trees`);

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

`is_leq/binary_trees` := eval(`is_leq/full_trees`);

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

`list_elements/binary_trees` := proc(A::set)
 option remember;
 local n,L,P,B,C,UUU,VVV,UU,VV;

 n := nops(A);

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

 L := NULL;
 P := `list_elements/nonempty_subsets`(A minus {A[n]});

 for B in P do
  C := A minus B;
  UUU := `list_elements/binary_trees`(B);
  VVV := `list_elements/binary_trees`(C);
  L := L,seq(seq({op(UU),op(VV),A},VV in VVV),UU in UUU);
 od;
 return [L];
end:

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

`random_element/binary_trees` := (A::set) -> proc()
 local n,B,C,UU,VV;

 n := nops(A);
 if n = 0 then return FAIL; fi;
 if n = 1 then return {A}; fi;
 B := `random_element/nonempty_subsets`(A minus {A[n]})();
 C := A minus B;
 UU := `random_element/binary_trees`(B)();
 VV := `random_element/binary_trees`(C)();
 return {op(UU),op(VV),A};
end:

######################################################################
# OEIS: A001147
`count_elements/binary_trees` := proc(A::set) local k; mul(2*k-1,k=1..nops(A)-1); end:


     {   ProdPlan.mpl   }

TITLE
    Production_Planning;

INDEX
    product  =  1..5
    month    =  (Jan,Feb,Mar,Apr,May,Jun)
    machine  =  (Grind,Vdrill,Hdrill,Boring,Planing) : 2

DATA
    price[product]          =        SPARSEFILE(price.dat);
    time[machine,product]   =  1/100 DATAFILE(time.dat);

    MaxSales[month,product] =        DATAFILE(sales.dat);

    DaysPerMonth   =  6*4;
    HoursPerDay    =  2*8;
    HoursPerMonth  =  HoursPerDay * DaysPerMonth;

    NrOfMachines[machine]   =  (4,2,3,3,3);

    Repairs[machine,month]  =  [Grind,   Jan:  1
                                Grind,   May:  1
                                Vdrill,  Apr:  1
                                Vdrill,  May:  1
                                Hdrill,  Feb:  2
                                Hdrill,  Jun:  1
                                Boring,  Mar:  1
                                Boring,  May:  1
                                Planing, Jun:  1]

    MachineHours[machine,month] :=

         HoursPerMonth * DENSE(NrOfMachines - Repairs) ;

    InventoryCost   =   0.50 ;

DECISION VARIABLES
    Sale[product,month]
    Prod[product,month]
    Invt[product,month] ;

MODEL

   MAX   Contribution   =

           SUM(product,month: price*Sale - InventoryCost*Invt) ;

SUBJECT TO

   Capacity[month,machine] -> Cap :  SUM(product: time*Prod)  <  MachineHours ;

   Balance[product,month] -> Bal  :  Invt  =  Invt[month-1] + Prod - Sale ;

BOUNDS
    MaximumSales  :  Sale  <  MaxSales;
    InvtCapacity  :  Invt[month<Jun]  <  100 ;
    InvtCapacity  :  Invt[month=Jun]  =   50 ;

END


# We use the definition below for generalised Narayana numbers because it is
# good for m > 0 and for n = 0.  In the most common case where m = 0 and
# n > 0 it is equivalent to the function narayana_number_basic(n,j).

narayana_number := proc(n,j,m := 0)
 (m+1)/(n+1)*binomial(n+1,j) * binomial(n-m-1,j-1);
end:

narayana_number(0,0) := 1;

narayana_number_basic := (n,j) ->
 binomial(n,j) * binomial(n,j-1) / n;

# This is the sum of narayana_number(n,j,0) x^n y^j for n,j >= 0
narayana_series := (x,y) ->
 (1 + x*(1-y) - sqrt(1-2*x*(1+y)+x^2*(1-y)^2))/(2*x);

# This is the series used by Stanley which has slightly different
# conventions for n = 0 and so ends up as 1 + narayana_series(x,y)

narayana_series_stanley := (x,y) ->
 (1-x-x*y - sqrt((1-x-x*y)^2-4*x^2*y))/(2*x);

`is_element/narayana_paths` := (len::posint,peaks::posint) -> proc(u)
 local v,w,y,i;

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

 if {op(u),1,-1} <> {1,-1} then
  return false;
 fi;

 if nops(u) <> 2*len then
  return false;
 fi;

 v := 0;
 y := 0;
 for i from 1 to 2*len do
  y := y + u[i];
  v := v,y;
 od:
 v := [v];

 if v[2*len+1] <> 0 then
  return false;
 fi;

 if min(op(v)) < 0 then
  return false;
 fi;

 w := select(i -> (u[i] = 1 and u[i+1] = -1),[seq(i,i=1..2*len-1)]);
 if nops(w) <> peaks then
  return false;
 fi;

 return true;
end:

`list_elements/narayana_paths` := proc(len,peaks)
 local A,B,L,a,b,u,ok,y,i;
 A := map(a -> [0,op(a),len+1],combinat[choose](len  ,peaks-1));
 B := map(b -> [0,op(b),len  ],combinat[choose](len-1,peaks-1));
 L := NULL;
 for a in A do
  for b in B do
   u := map(op,[seq([(+1)$(a[i+1]-a[i]),(-1)$(b[i+1]-b[i])],i=1..peaks)]);
   ok := true;
   y := 0;
   for i from 1 to 2*len+1 do
    y := y + u[i];
    if y = 0 then
     ok := false;
     break;
    fi;
   od:
   if ok then
    L := L,u[2..-1];
   fi;
  od:
 od:
 return [L];
end:

# This is very unintelligent
`list_elements_basic/narayana_paths` := proc(len,peaks)
 local L,M,i,k,u,h;
 L := [[1]]:
 for i from 1 to 2*len-1 do
  M := NULL;
  for u in L do
   h := `+`(op(u));
   if h > 0 then
    M := M,[op(u),-1],[op(u),1];
   else
    M := M,[op(u),1];
   fi;
  od:
  L := [M];
 od:
 M := NULL;
 for u in L do
  k := nops(select(i -> (u[i]=1 and u[i+1]=-1),[seq(i,i=1..2*len-1)]));
  if k = peaks and `+`(op(u)) = 0 then
   M := M,u;
  fi;
 od:
 return [M];
end:

`count_elements/narayana_paths` := (len,peaks) ->
 narayana_number(len,peaks);

`plot/narayana_path` := proc(u)
 local P,y,i;
 P := NULL;
 y := 0;
 for i from 1 to nops(u) do
  P := P,line([i-1,y],[i,y+u[i]]);
  y := y + u[i];
 od:
 display(P,scaling=constrained,axes=none);
end:

`digraph/narayana_path` := proc(u)
 local n,y,v,V,E,i,j,h;
 n := nops(u);
 y := 0;
 v := NULL;
 for i from 1 to n do
  y := y + u[i];
  v := v,y;
 od:
 v := [v];
 V := [0,op(select(i -> u[i] = 1,[seq(i,i=1..n)]))];
 E := NULL;
 for i in V do
  if i = 0 then h := 0; else h := v[i]; fi;
  j := i+1;
  while j <= n and v[j] >= h do
   if v[j] = h + 1 and u[j] = 1 then
    E := E,[i,j];
   fi;
   j := j+1;
  od;
 od:
 return [V,[E]];
end:

`extended_stasheff_tree/narayana_path` := proc(u)
 local n,V,E,L,ix,c,v,e,m,i,T,T0,t,UU;
 n := nops(u);
 V,E := op(`digraph/narayana_path`(u));
 L := select(i -> nops(select(e -> e[1]=i,E))=0,V);

 ix := table():
 for i from 1 to nops(L) do ix[L[i]] := i; od:

 c := table();
 for v in V do
  c[v] := {};
 od:
 c[0] := {};
 for e in E do
  c[e[1]] := {op(c[e[1]]),e[2]};
 od:
 m := nops(V);
 for i from m to 1 by -1 do
  v := V[i];
  if member(v,L) then
   T[v] := {v};
  else
   T[v] := map(j -> op(T[j]),c[v]);
  fi;
 od:

 t := table():
 for v in V do
  T0 := T[v];
  if type(t[T0],integer) then
   t[T0] := t[T0] + 1;
  else
   t[T0] := 0;
  fi;
 od:

 UU := NULL;
 for T0 in map(op,[indices(t)]) do
  UU := UU,[map(v -> ix[v],T0),t[T0]];
 od:
 UU := {UU};

 return UU;
end:

check_narayana := proc()
 local x,y,d,j,n,m,F0,F1,F2,F3;

 _ASSERT(
  `and`(seq(seq(evalb(narayana_number(n,j) = narayana_number_basic(n,j)),j=0..20),n=1..20)),
  "narayana_number_basic(n,j) = narayana_number(n,j,0) for n > 0"
 );

 F0 := narayana_series(x,y);
 _ASSERT(
  simplify(x * F0^2 + (x*y-x-1) * F0 + 1) = 0,
  "Quadratic relation for Narayana series"
 );

 F1 := narayana_series_stanley(x,y);

 _ASSERT(
  simplify(F0 - F1 - 1) = 0,
  "narayana_series(x,y) = narayana_series_stanley(x,y) + 1"
 );

 d := 9;
 m := 4;
 F2 := expand(convert(expand(series(
  (e*x)^m * narayana_series(e*x,e*y)^(m+1),
  e=0,d+2)),polynom,e));
 F3 := add(add(narayana_number(n,j,m) * x^n * y^j * e^(n+j),j=0..min(n-m,d-n)),n=m..d);
 _ASSERT(simplify(F3 - F2) = 0,"generating function");
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: lda_exc *)
(* prefix:
  lda_x_sloc_params *params;

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

# https://onlinelibrary.wiley.com/doi/full/10.1002/qua.25312

f_sloc := (rs, z) ->
  -params_a_a/(2*(params_a_b + 1)) * n_total(rs)^params_a_b *
  (opz_pow_n(z,params_a_b + 1) + opz_pow_n(-z,params_a_b + 1)):

f := (rs, z) -> f_sloc(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 *)
(* prefix:
  lda_c_chachiyo_params *params;

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

e0 := rs -> params_a_ap*log(1 + params_a_bp/rs + params_a_bp/rs^2):
e1 := rs -> params_a_af*log(1 + params_a_bf/rs + params_a_bf/rs^2):

f_chachiyo := (rs, zeta) -> e0(rs) + (e1(rs) - e0(rs))*f_zeta(zeta):
f := (rs, zeta) -> f_chachiyo(rs, zeta):


######################################################################
# nonempty_subsets(A) is the set of all nonempty subsets of A

`is_element/nonempty_subsets` := (A::set) -> proc(B)
 type(B,set) and B minus A = {} and nops(B) > 0;
end;

`is_equal/nonempty_subsets` := (A::set) -> (B,C) -> evalb(B = C):

`is_leq/nonempty_subsets` := (A::set) -> (B,C) -> evalb(B minus C = {}):

`random_element/nonempty_subsets` := (A::set) -> proc()
 local r,B;

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

 r := rand(2);
 B := {};

 while nops(B) = 0 do
  B := select(a -> (r() = 1),A);
 od;

 return B;
end;

`list_elements/nonempty_subsets` := (A::set) ->
 sort(map(sort,[op(combinat[powerset](A) minus {{}})])):

`count_elements/nonempty_subsets` := (A::set) -> 2^nops(A) - 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: lda_exc *)
(* replace: "int1\(" -> "xc_integrate(func1, NULL, 1e-20, " *)
(* replace: "int2\(" -> "xc_integrate(func2, NULL, 1e-20, " *)
(* prefix:
  lda_x_1d_exponential_params *params;

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

$define xc_dimensions_1d

`diff/int1` := proc(g, x) diff(g, x) * x1d_inter(g)   end proc:
`diff/int2` := proc(g, x) diff(g, x) * x1d_inter(g)*g end proc:

x1d_inter := x -> xc_E1_scaled(x^2):

x1d_R := rs -> Pi*params_a_beta/(2*rs):
x1d_fs := (rs, z) ->
  -((1 + z)*int1((1 + z)*x1d_R(rs)) - int2((1 + z)*x1d_R(rs))/x1d_R(rs))
    / (4.0*Pi*params_a_beta):

x1d_f := (rs, z) ->
  + my_piecewise3(screen_dens_zeta(rs,  z), 0, x1d_fs(rs, z_thr( z)))
  + my_piecewise3(screen_dens_zeta(rs, -z), 0, x1d_fs(rs, z_thr(-z)))
:

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


# A Groebner basis is by definition a set of generators for an ideal
# I in a polynomial ring over a field k.  Given such a set, one can
# deduce a basis for the quotient ring P/I as a vector space over k.
# We call that a cobasis for I.  The function below calculates the
# cobasis, assuming that it is finite.  (It will just give an infinite
# loop if the cobasis is infinite.)

cobasis := proc(basis,vars)
 local lm,nf,L,L0,x,m,i;

 lm := map(LeadingMonomial,basis,vars);
 nf := (u) -> NormalForm(u,lm,vars);
 L := [1];
 for x in [op(vars)] do
  L0 := L;
  L := NULL;
  for m in L0 do
   i := 0;
   while nf(m*x^i) <> 0 do
    L := L,m*x^i;
    i := i+1;
   od;
  od:
  L := [L];
 od:

 return L;
end:


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

`is_element/P2` := (N::posint) -> (A::set) -> proc(u)
 local n,A2,ab,ba,v,i;
 global reason;

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

 n := nops(A);

 A2 := `list_elements/pairs`(A);
 if {indices(u)} <> {op(A2)} then
  reason := [convert(procname,string),"u is not indexed by pairs in A",u,A2];
  return false;
 fi;

 for ab in A2 do
  v := u[op(ab)];
  if not(`is_element/R`(N)(v)) then
   reason := [convert(procname,string),"u[a,b] is not in R^N",op(ab),v,N];
   return false;
  fi;
  if simplify(add(v[i]^2,i=1..N) - 1) <> 0 then
   reason := [convert(procname,string),"u[a,b] is not in S^(N-1)",op(ab),v,N];
   return false;
  fi;
 od;

 for ab in A2 do
  ba := [ab[2],ab[1]];
  if u[op(ab)] +~ u[op(ba)] <> [0$N] then
   reason := [convert(procname,string),"u[a,b]+u[b,a] <> 0",op(ab),u[op(ab)],u[op(ba)],N];
   return false;
  fi;
 od;

 return true;
end:

`phi2/Fbar/P2` := (N::posint) -> (A::set) -> proc(x)
 local A2,u,ab,a,b,f;

 A2 := `list_elements/pairs`(A);
 u := table();

 for ab in A2 do
  a,b := op(ab);
  f := `normalise_2/F`(N)({a,b})(x[{op(ab)}]);

  u[op(ab)] := combine(sqrt(2) *~ f[b]);
 od:

 return(eval(u));
end:


#@ Not autoload

# (This has been partially converted to autoloadable form, but
# needs more work.)

# This file contains formulae for elliptic curves taken from
# "Courbes Elliptiques: Formulaire (d'apr\`es J. Tate)"
# by P. Deligne (pages 53-73 of Modular Functions of One
# Variable IV, LNM 476, edited by B.J. Birch and W. Kuyk, 1975)

`is_element/weierstrass_vectors` := proc(a,t := constant)
 return type(a,[t $ 5]);
end:

`weierstrass_cubic` := (a) -> proc(xy)
 local a1,a2,a3,a4,a6,x,y;
 a1,a2,a3,a4,a6 := op(a);
 x,y := op(xy);
 return y^2 + a1 * x * y + a3 * y - x^3 - a2 * x^2 - a4 * x - a6;
end:

`homogeneous_cubic` := (a) -> proc(xyz)
 local a1,a2,a3,a4,a6,x,y,z;
 a1,a2,a3,a4,a6 := op(a);
 x,y,z := op(xyz);
 return y^2*z + a1*x*y*z + a3*y*z^2 - x^3 - a2*x^2*z - a4*x*z^2 - a6*z^3;
end:

`a_to_b/weierstrass_vectors` := proc(a)
 local a1,a2,a3,a4,a6,b2,b4,b6,b8;

 a1,a2,a3,a4,a6 := op(a);

 b2 := a1^2 + 4 * a2;
 b4 := a1 * a3 + 2 * a4;
 b6 := a3^2 + 4 * a6;
 b8 := a1^2 * a6 - a1 * a3 * a4 + 4 * a2 * a6 + a2 * a3^2 - a4^2;

 return [b2,b4,b6,b8];
end:

`b_to_c/weierstrass_vectors` := proc(b)
 local b2,b4,b6,b8,c4,c6,delta;

 b2,b4,b6,b8 := op(b);

 c4 := b2^2 - 24 * b4;
 c6 := - b2^3 + 36 * b2 * b4 - 216 * b6;

 delta := -b2^2 * b8 - 8 * b4^3 - 27 * b6^2 + 9 * b2 * b4 * b6;

 return [c4,c6,delta];
end:

`c_to_j/weierstrass_vectors` := proc(c)
 local c4,c6,delta;

 c4,c6,delta := op(c);

 return c4^3/delta;
end:

`b_to_j/weierstrass_vectors` := proc(b)
 `c_to_j/weierstrass_vectors`(`b_to_c/weierstrass_vectors`(b));
end:

`a_to_c/weierstrass_vectors` := proc(a)
 `b_to_c/weierstrass_vectors`(`a_to_b/weierstrass_vectors`(a));
end:

`a_to_j/weierstrass_vectors` := proc(a)
 `b_to_j/weierstrass_vectors`(`a_to_b/weierstrass_vectors`(a));
end:

`b_rel/weierstrass_vectors` := proc(b)
 local b2,b4,b6,b8;

 b2,b4,b6,b8 := op(b);

 return 4 * b8 - b2 * b6 + b4^2;
end:

`c_rel/weierstrass_vectors` := proc(c)
 local c4,c6,delta;

 c4,c6,delta := op(c);

 return 1728 * delta - c4^3 + c6^2;
end:

`invariant_differential0/weierstrass_vectors` :=
 (a) -> (y * dx - x * dy)/diff(homogeneous_cubic(a)([x,y,z],z);

`invariant_differential1/weierstrass_vectors` :=
 (a) -> (z * dy - y * dz)/diff(homogeneous_cubic(a)([x,y,z],x);

`invariant_differential2/weierstrass_vectors` :=
 (a) -> (x * dz - z * dx)/diff(homogeneous_cubic(a)([x,y,z],y);

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

`id/weierstrass_group` := [1,0,0,0]:

`o/weierstrass_group` := proc(urst1,urst0)
 local u0,u1,u2,r0,r1,r2,s0,s1,s2,t0,t1,t2;

 u1,r1,s1,t1 := op(urst1);
 u0,r0,s0,t0 := op(urst0);
 u2 := u0 * u1;
 s2 := s1 + s0 * u1;
 r2 := r1 + r0 * u1^2;
 t2 := t1 + t0 * u1^3 + r0 * s1 * u1^2;
 return [u2,r2,s2,t2];
end:

`inv/weierstrass_group` := proc(urst)
 local u,r,s,t;
 u,r,s,t := op(urst);
 return [1/u,-r/u^2,-s/u,(r*s-t)/u^3];
end:

`act/vector/weierstrass_group` := (urst) -> proc(a)
 local u,r,s,t,a1,a2,a3,a4,a6;
 u,r,s,t := op(urst);
 a1,a2,a3,a4,a6 := op(a);
 return [
  a1 * u - 2 * s,
  a2 * u^2 + a1 * s * u - 3 * r - s^2,
  a3 * u^3 - a1 * r * u + 2 * r * s - 2 * t,
  a4 * u^4 + a3 * s * u^3 - 2 * a2 * r * u^2 +
    a1 * (t - 2 * r * s) * u + 3 * r^2 + 2 * r * s^2 - 2 * s * t,
  a6 * u^6 - a4 * r * u^4 +
    a3 * (t - r * s) * u^3 + a2 * r^2 * u^2 +
    a1 * (r^2 * s - r * t) * u + 2 * r * s * t - t^2 - r^2 * s^2 - r^3
 ];
end:

`act/curve/weierstrass_group` := (urst) -> proc(xyz)
 local u,r,s,t,x,y,z;
 u,r,s,t := op(urst);
 x,y,z := op(xyz);
 return [u^2 * x + r * z,u^3 * y + s * u^2 * x + t * z,z];
end:

#### UNFINISHED

# Three expressions for the invariant differential
alpha0 := (y * dx - x * dy)/diff(HomogeneousCubic,z);
alpha1 := (z * dy - y * dz)/diff(HomogeneousCubic,x);
alpha2 := (x * dz - z * dx)/diff(HomogeneousCubic,y);

eta := y + (a1 * x + a3)/2;
xi  := x + b2 / 12;

WeierstrassCubic2 := eta^2 - x^3 - b2/4 * x^2 - b4/2 * x + b6/4;
WeierstrassCubic6 := eta^2 - xi^3 + c4/48 * xi + c6/864;

Pu := xi;
Pdashu := 2 * eta;
g2 := c4/12;
g3 := c6/216;
du := omega;
dxi := 2 * eta * omega;

# alpha[t_Plus]    := Expand[alpha /@ t]
# alpha[t_Times]   := Expand[alpha /@ t]
# alpha[t_^n_]     := Expand[alpha[t]^n]
# alpha[n_Integer] := n

checkalpha := {
alpha[b2] - (b2 * u^2 - 12 * r),
alpha[b4] - (b4 * u^4 - b2 * r * u^2 + 6 * r^2),
alpha[b6] - (b6 * u^6 - 2 * b4 * r * u^4 + b2 * r^2 * u^2 - 4 * r^3),
alpha[b8] - (b8 * u^8 - 3 * b6 * r * u^6 + 3 * b4 * r^2 * u^4 - b2 * r^3 * u^2 + 3 * r^4),
alpha[c4] - c4 * u^4,
alpha[c6] - c6 * u^6,
alpha[Delta] - Delta * u^12
};

CurveRule := proc(F)
  [a1 =   coeff(coeff(F,x,1),y,1),
   a2 = - coeff(coeff(F,x,2),y,0),
   a3 =   coeff(coeff(F,x,0),y,1),
   a4 = - coeff(coeff(F,x,1),y,0),
   a6 = - coeff(coeff(F,x,0),y,0)
  ]
end:

GenericCubic := y^2 + x * y - x^3 + 36/(jj - 1728) * x + 1/(jj - 1728);

mChord := proc(P,Q)
 (Q[2] - P[2])/(Q[1] - P[1]);
end:

mTangent := proc(P)
 (3 * P[1]^2 + 2 * a2 * P[1] + a4 - a1 * P[2]) / (2 * P[2] + a1 * P[1] + a3);
end:

bChord := proc(P,Q)
 (P[2] * Q[1] - Q[2] * P[1])/(Q[1] - P[1]);
end:

bTangent := proc(P)
 (- P[1]^3 + a4 * P[1] + 2 * a6 - a3 * P[2]) / (2 * P[2] + a1 * P[1] + a3);
end:

EllipticSumChord := proc(P,Q)
 local m,b,x3;
  m := mChord(P,Q);
  b := bChord(P,Q);
  x3 := m^2 + a1 * m - a2 - P[1] - Q[1];
  [x3, -(m + a1) * x3 - b - a3];
end:

EllipticSumTangent := proc(P,Q)
 local m,b,x3;
  m := mTangent(P);
  b := bTangent(P);
  x3 := m^2 + a1 * m - a2 - P[1] - Q[1];
  [x3, -(m + a1) * x3 - b - a3]
end:

Negate := proc(P)
 if nops(P) = 2 then
  return([P[1],-P[2]-a1*P[1]-a3]);
 else
  return([P[1],-P[2]-a1*P[1]-a3*P[3],P[3]]);
 fi;
end:

Double := proc(x)
 (x^4 - b4 * x^2 - 2 * b6 * x - b8)/(4 * x^3 + b2 * x^2 + 2 * b4 * x + b6);
end:

# xTate = sum[q^n u / (1 - q^n u)^2 , {n,-Infinity,Infinity}] -
#         sum[n q^n / (1 - q^n) , {n,1,Infinity}]

# yTate = sum[q^(2 n) u^2 / (1 - q^n u)^3 , {n,-Infinity,Infinity}] +
#         sum[n q^n / (1 - q^n) , {n,1,Infinity}]

# TateCubic = y^2 + x y - x^3 - aTate4 x - aTate6

# aTate4 = - 5 sum[ DivisorSigma[3,n] q^n , {n,1,Infinity}]
# aTate6 = - sum[ (5 DivisorSigma[3,n] + 7 DivisorSigma[5,n])/12 q^n,
#                  {n,1,Infinity}]

# cTate4 = E4
# cTate6 = -E6

# E4 = 1 + 240 sum[ DivisorSigma[3,n] q^n , {n,1,Infinity}]
# E6 = 1 - 504 sum[ DivisorSigma[5,n] q^n , {n,1,Infinity}]
# DeltaTate = q product[ (1 - q^n)^24 , {n,1,Infinity}]


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

a  := [0.4581652932831429, 2.217058676663745,  0.7405551735357053, 0.01968227878617998 ]:
ap := [0.119086804055547,  0.6157402568883345, 0.1574201515892867, 0.003532336663397157]:
b  := [1.0000000000000000, 4.504130959426697,  1.110667363742916,  0.02359291751427506 ]:
bp := [0.000000000000000,  0.2673612973836267, 0.2052004607777787, 0.004200005045691381]:

f  := (rs, zeta) ->
  - add((a[i] + f_zeta(zeta)*ap[i])*rs^(i-1), i=1..4) /
    add((b[i] + f_zeta(zeta)*bp[i])*rs^i,     i=1..4):


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

sa_a := 2.413:
sa_b := 0.348:

params_a_b      := 0.40:
params_a_c      := 1.59096:
params_a_e      := 1.537:
params_a_mu     := 0.21951:

sa_alpha           := (x, t) -> (t - x^2/8)/K_FACTOR_C:

(* Equation (8) *)

tpss_ff    := z -> 2:
tpss_kappa := (x, t) -> 2*Pi/(3*sqrt(5)) * \
          sqrt(sa_alpha(x, t) + 1)/sqrt(sa_a + log(sa_alpha(x, t) + sa_b)):

$include "tpss_x.mpl"

sa_a1  := (x, t) -> tpss_kappa(x, t)/(tpss_kappa(x, t) + tpss_fx(x, t)):
sa_f   := (x, u, t) -> 1 + tpss_kappa(x, t)*(1 - sa_a1(x, t)):

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


# Compute the actual repartition of nodes between the different application classes:
# We have 17784 nodes
N := 17784;
# We want 66% / 5.5% / 15.5% and 12.5% overall
workload := [.66, 0.55e-1, .155, .12];
# Each app has q[i] nodes and lasts for wall[i] hours
wall := [262.4, 64, 128, 157.2];
q := [16384*(1/16), 4096*(1/16), 32768*(1/16), 30000*(1/16)];
# ress[i] represents the CPU.h used by an application of class i
ress := [q[1]*wall[1], q[2]*wall[2], q[3]*wall[3], q[4]*wall[4]];
# t represents the resource necessary to run one app of each class
t := sum(ress[i], i = 1 .. 4);
# ressratio[i] is the proportion of CPU.h neede to run one app of class i
ressratio := [ress[1]/t, ress[2]/t, ress[3]/t, ress[4]/t];
# nratio[i] is the relative number of applications of class i to run in order to get the workload goal
nratio := [workload[1]/ressratio[1], workload[2]/ressratio[2], workload[3]/ressratio[3], workload[4]/ressratio[4]];
# m is a scaling factor so that the total number of nodes is N
m := N/evalf(sum(q[i]*nratio[i], i = 1 .. 4));
# n[i] is thus the number of applications of class i that we run in steady state
n := m*nratio;

# Waste(C, mu) computes Equation (7) of the paper
Waste := proc (C, mu)
   local P, r, Period;
   # Pi is computed for each qi/Ci following equation (8)
   P := [sqrt(2*mu*N*(q[1]/N+L)*C[1]/q[1]^2), sqrt(2*mu*N*(q[2]/N+L)*C[2]/q[2]^2), sqrt(2*mu*N*(q[3]/N+L)*C[3]/q[3]^2), sqrt(2*mu*N*(q[4]/N+L)*C[4]/q[4]^2)];
   # r is the lambda that solves equation (6), assuming we want the smallest lambda that is still positive
   r := fsolve(sum(n[i]*C[i]/P[i], i = 1 .. 4)-1 = 0, L);
   # Periodi is the numerical value corresponding to equation (8) with lambda instanciated
   Period := eval(P, L = min(0, r));
   # and we return Equation (7) for the computed Periodi
   return evalf(sum(n[i]*q[i]*(C[i]/Period[i]+q[i]*((1/2)*Period[i]+C[i])/mu)/N, i = 1 .. 4))
end proc;

# We extracted the checkpoint duration for each application class at 40 GB/s from the simulation trace
# and scale up the checkpoint time for variable bandwidth
# We convert the time in hours (as for the rest of this file)
CkptTime := proc (bw)
    return [1310.72*0.4e11/(3600*bw), 378.88*0.4e11/(3600*bw), 5734.4*0.4e11/(3600*bw), 1275*0.4e11/(3600*bw)]
end proc;

# For each bandwidth in the figure, and each MTBF in the figure, compute the theoretical waste and store it into model.dat
fd := fopen("celio.dat", WRITE);
for bw from 0.4e11 by 0.1e11 to 0.16e12 do
    for M in [1, 2, 4, 8, 16, 24] do
    	# M*N is the node MTBF in hours
        fprintf(fd, "%g\t%g\t%g\n", bw, M, Waste(CkptTime(bw), M*N))
    end do
end do;
fclose(fd);


# P(N) is the set of real polynomials in epsilon of degree less than N

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

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

 if not type(u,polynom(realcons,epsilon)) then
  reason := [convert(procname,string),"u is not polynomial in epsilon",u];
  return false;
 fi;

 if degree(u,epsilon) >= N then
  reason := [convert(procname,string),"deg(u) >= N",u,N];
  return false;
 fi;

 return true;
end;

`is_leq/P` := (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:

`random_element/P` := (N::posint) -> proc(d::posint := 4)
 local r,i;
 r := rand(-d^2..d^2);
 add(r()/d * epsilon^i,i=0..N-1);
end;

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


############################################
#  Performing finite differencing  using
#  FD toolkit. See previous script
#  'compactification.mpl' for how the tt table
#  is generated
############################################

read "/home/arman/FD/FD.mpl":
CFD();
MFD();

interface(warnlevel=0);
with(StringTools):

##############################################################
# By default FD uses second order centered in Gen_Sten for RHS
# which is exactly what we want
##############################################################

for ii from 1 to nops(all_tensors) do
  nm:= all_tensors[ii][1]:
  rank := all_tensors[ii][2]:
  tp  := all_tensors[ii][3]:

  printf("Discretizing %a\n",nm);
  if rank <> 0 then
      # Note the collect operator on powers of 1/hx, it will help the compiler's O3 flag a lot!
      tt[nm][dis] := table( [ seq(  coord[jj] = collect(Gen_Sten(tt[nm][all][coord[jj]]),1/hx) ,jj=1..2 ) ] );
      tt[nm][disreg] := table( [seq( coord[jj] = collect(Gen_Sten(tt[nm][reg][coord[jj]]),1/hx) ,jj=1..2 ) ] );
  else
      tt[nm][dis] := collect(Gen_Sten(tt[nm][all]),1/hx);
      tt[nm][disreg] := collect(Gen_Sten(tt[nm][reg]),1/hx);
  end if;

end do:

###################################################
# Bounday condition at infinity for the tensors:
# Note that we use 'myzero*x' to indicate '0' grid
# function at infinity, See documentation of FD
# for why this is neccessary
# The overhead of this is almost zero!
###################################################

inf_b_cond:= table( [
EMPH = myzero*x+1,
DPH = myzero*x,
DB  = myzero*x,
dg  = [myzero*x,myzero*x],
met = [myzero*x+1,myzero*x+1],
DDL = [myzero*x,myzero*x],
DTK = myzero*x,
RR  = [myzero*x,myzero*x],
U   = [myzero*x,myzero*x],
P   = [myzero*x,myzero*x],
DAA = [myzero*x,myzero*x],
DLAM = [myzero*x,myzero*x],
C1 = myzero*x,
C5 = myzero*x,
HS = psi(t,x)-1 + myzero*x,
HS3 = psi(t,x)-1 + myzero*x,
EQRPIb2 = myzero*x,
EQIPIb2 = myzero*x,
EQIPSI = myzero*x,
EQRPSI = myzero*x,
DRPSI = myzero*x,
DIPSI = myzero*x
]);

# Discretizing the infinity boundary conditions

for ii from 1 to nops(all_tensors) do
  nm:= all_tensors[ii][1]:
  rank := all_tensors[ii][2]:
  tp  := all_tensors[ii][3]:

  printf("Discretizing %a\n",nm);
  if rank <> 0 then
      tt[nm][disinf] := table( [ seq(  coord[jj] = Gen_Sten(inf_b_cond[nm][jj]) ,jj=1..2 ) ] );
  else
      tt[nm][disinf] := Gen_Sten(inf_b_cond[nm]);
  end if;

end do:

# Updating FD's table to default centered in all coordinates

pl:=table([ t=[-1,-1],x=[-1,-1],y=[-1,-1],z=[-1,-1] ]):
Update_FD_Table(2,pl):

############################################
# A table to hold the LHS of BSSN equations
# in their continuous form
############################################

evol_eq_LHS_tbl := table ( [
DPH = diff(phi(t,x),t),
dg = [diff(A(t,x),t),diff(B(t,x),t)],
DTK = diff(K(t,x),t),
DAA = [diff(Axx(t,x),t),diff(Athth(t,x),t)],
DLAM = [diff(Lamx(t,x),t),0],
EQRPIb2 = diff(rPIb2(t,x),t),
EQIPIb2 = diff(iPIb2(t,x),t),
EQRPSI  = diff(rpsi(t,x),t),
EQIPSI  = diff(ipsi(t,x),t)
] );

###############################################
# A table to hold what each tensorial equation
# is actually will be solved for, this will be
# needed by FD to decide what to solve the FDA
# for!
###############################################

solve_for_tbl := table ( [
   DPH = phi(n+1,i),
   dg  = table( [ x = A(n+1,i) , theta=B(n+1,i)  ] ),
   DTK = K(n+1,i),
   DAA = table( [ x = Axx(n+1,i), theta=Athth(n+1,i) ] ),
   DLAM = table( [ x = Lamx(n+1,i), theta = 0 ] ),
   EQRPIb2 = rPIb2(n+1,i),
   EQIPIb2 = iPIb2(n+1,i),
   EQRPSI = rpsi(n+1,i),
   EQIPSI = ipsi(n+1,i)
] );

#################################################
# A table to hold what are the actual discrete
# form of the functions are, this will be needed
# by FD
#################################################

dis_func_tbl := table ( [
   DPH = phi(n,i),
   dg  = table( [ x = A(n,i) , theta=B(n,i)  ] ),
   DTK = K(n,i),
   DAA = table( [ x = Axx(n,i), theta=Athth(n,i) ] ),
   DLAM = table( [ x = Lamx(n,i), theta = 0 ] ),
   EQRPIb2 = rPIb2(n,i),
   EQIPIb2 = iPIb2(n,i),
   EQRPSI = rpsi(n,i),
   EQIPSI = ipsi(n,i)
] );

##########################################################
# The implementaion of the famous Kreiss/Oliger disspation
# using FD's 'FD' operator, will be used in the RHS of the
# evolution equations to suppress numerical noise
# See FD's documentation on how 'FD' operator works, but
# if you are familiar with RNPL, it should be pretty clear
# what is happening here!
##########################################################

DISS := f-> -zepsdis / (16*ht) * ( 6*FD(f,[[0],[0,0,0]])
                                   + FD(f,[[0],[2,0,0]])
                                   + FD(f,[[0],[-2,0,0]])
                                 - 4*FD(f,[[0],[1,0,0]])
                                 - 4*FD(f,[[0],[-1,0,0]])
                                );

# Defining average operator for Crank-Nickelson second order update
AVGT := f -> (FD(f,[[1],[0,0,0]]) + FD(f,[[0],[0,0,0]]))/2 ;

# Advanced time operator
NT := f -> FD(f,[[1],[0,0,0]]);

# 2nd order interpolation at the boundary (used at origin)
QFIT := f-> FD(f,[[0],[0,0,0]]) - 4*FD(f,[[0],[1,0,0]])/3 + FD(f,[[0],[2,0,0]])/3 ;

######################################################################
# Shift operator, will be used for the point next to origin condition
# See Eq. (58) in the paper: http://arxiv.org/pdf/1508.01614v2.pdf
#######################################################################

SB := f -> FD(f,[[0],[-1,0,0]]);

# Updating FD's table to default in all coordinates
pl:=table([ t=[-1,-1],x=[-1,-1],y=[-1,-1],z=[-1,-1] ]):
Update_FD_Table(2,pl):

# The evolutionary type equations:
evol_trm := [[DPH,0],[dg,2],[DTK,0],[DAA,2],[DLAM,1], [EQRPIb2,0] , [EQIPIb2,0], [EQRPSI,0], [EQIPSI,0] ];

# Initiating a table to hold the actual equations (residuals) in discrete form
evol_eq_tbl := table ( [] );

# Updating to forward in time differencing scheme, i.e. Crank-Niecklson when combined with AVGT
FD_table[t] := [ [0] , [0,1] ];

# List of all even/odd functions, will be used by FD for imposing inner-boundary conditions
set_of_even_funcs:={alpha,K,phi,Axx,Athth,A,B,psi,a1,a2,b1,ipsi,rpsi,iPIb2,rPIb2,rPI,iPI,divbeta}:
set_of_odd_funcs:={beta,Lamx,rPHI,iPHI}:

for ii from 1 to nops(evol_trm) do
  nm := evol_trm[ii][1];
  rank := evol_trm[ii][2];
  if rank <> 0 then
    for jj from 1 to 2 do
       cn := coord[jj];
       #######  THIS IS THE EQUATION IN FDA FORM ############
       evol_eq_tbl[nm][dis][cn] := Gen_Sten(evol_eq_LHS_tbl[nm][jj]) - AVGT(tt[nm][dis][cn]);
       evol_eq_tbl[nm][disreg][cn] := Gen_Sten(evol_eq_LHS_tbl[nm][jj]) - AVGT(tt[nm][disreg][cn]);
       # Applying boundary conditions using FD's facilities at the origin
       t_mp_1:= A_FD_Even(tt[nm][disreg][cn],x,set_of_even_funcs,0,"forward");
       t_mp_2:= A_FD_Odd(t_mp_1,x,set_of_odd_funcs,0,"forward");
       # Storing  (in 'disorg') a version of FDA that can be used next to the origin
       evol_eq_tbl[nm][disorg][cn] := Gen_Sten(evol_eq_LHS_tbl[nm][jj]) - AVGT(t_mp_2);
       # Storing the form of the equation at infinity:
       evol_eq_tbl[nm][disinf][cn] := Gen_Sten(evol_eq_LHS_tbl[nm][jj]) - AVGT(tt[nm][disinf][cn]);
    end do
  else
      # Same as above
      evol_eq_tbl[nm][dis] := Gen_Sten(evol_eq_LHS_tbl[nm]) - AVGT(tt[nm][dis]);
      evol_eq_tbl[nm][disreg] := Gen_Sten(evol_eq_LHS_tbl[nm]) - AVGT(tt[nm][disreg]);
      t_mp_1:= A_FD_Even(tt[nm][disreg],x,set_of_even_funcs,0,"forward");
      t_mp_2:= A_FD_Odd(t_mp_1,x,set_of_odd_funcs,0,"forward");
      evol_eq_tbl[nm][disorg] := Gen_Sten(evol_eq_LHS_tbl[nm]) - AVGT(t_mp_2);
      evol_eq_tbl[nm][disinf] := Gen_Sten(evol_eq_LHS_tbl[nm]) - AVGT(tt[nm][disinf]);
  end if;
end do;

# The evaluation type equations, i.e. 'work variables'
eval_term := [[EMPH,0] , [DB,0] ,[met,2],[DDL,2] ,[RR,2],[U,2], [P,2] ,[C1,0], [C5,0], [DIPSI,0], [DRPSI,0]];

eval_expr_tbl := table ( [] );

for ii from 1 to nops(eval_term) do
  nm := eval_term[ii][1];
  rank := eval_term[ii][2];
  if rank <> 0 then
    for jj from 1 to 2 do
      cn := coord[jj];
      eval_expr_tbl[nm][dis][cn] := (tt[nm][dis][cn]);
      eval_expr_tbl[nm][disreg][cn] := (tt[nm][disreg][cn]);
      eval_expr_tbl[nm][disinf][cn] := (tt[nm][disinf][cn]);
      # Same as evolution case
      t_mp_1:= A_FD_Even(tt[nm][disreg][cn],x,set_of_even_funcs,0,"forward");
      t_mp_2:= A_FD_Odd(t_mp_1,x,set_of_odd_funcs,0,"forward");
      eval_expr_tbl[nm][disorg][cn] := t_mp_2;
    end do;
  else
      eval_expr_tbl[nm][dis]:= (tt[nm][dis]);
      eval_expr_tbl[nm][disreg]:= (tt[nm][disreg]);
      eval_expr_tbl[nm][disinf]:= (tt[nm][disinf]);
      t_mp_1:= A_FD_Even(tt[nm][disreg],x,set_of_even_funcs,0,"forward");
      t_mp_2:= A_FD_Odd(t_mp_1,x,set_of_odd_funcs,0,"forward");
      eval_expr_tbl[nm][disorg] := t_mp_2;
  end if;
end do;

# Switching to forward in 'x' (ie 'r') for doing FDA at the origin
pl:=table([ t=[-1,-1],x=[0,-1],y=[-1,-1],z=[-1,-1] ]):
Update_FD_Table(2,pl):

# Again in time, we use CN scheme
FD_table[t] := [ [0] , [0,1] ];

#######################################################
# Table for boundary conditions at the origin
# See the paper: http://arxiv.org/pdf/1508.01614v2.pdf
#######################################################

org_bdc_tbl := table ( [
   # d phi / dx must be zero at origin
   DPH = NT(Gen_Sten(diff(phi(t,x),x))),
   # conformal metric components are 1 at the origin
   dg  = table( [ x = A(n+1,i) - 1 +myzero*x(i) , theta= B(n+1,i) -1 + myzero*x(i)  ] ),
   # exterinsic curvature has zero spatial derivative at origin:
   DTK = NT(Gen_Sten(diff(K(t,x),x))),
   # (from dg eq above) conformal extrinsic curvature are fixed 0 at the origin
   DAA = table( [ x = Axx(n+1,i) +myzero*x(i), theta= Athth(n+1,i)+myzero*x(i) ] ),
   # Conformal connection is vector thus zero at the origin
   DLAM = table( [ x = Lamx(n+1,i) +myzero*x(i), theta= 0 ] ),
   # We use interpolation for matter fields
   EQRPIb2 = NT(QFIT(rPIb2(n,i))),
   EQIPIb2 = NT(QFIT(iPIb2(n,i))),
   EQRPSI  = NT(QFIT(rpsi(n,i))),
   EQIPSI  = NT(QFIT(ipsi(n,i)))
] );

##################################################################
# Extra boundary conditions for the point next to the origin
# as explained in the paper: http://arxiv.org/pdf/1508.01614v2.pdf
# See eq. 58 in the paper
###################################################################

orgp1_bdc_tbl := table ( [
   # Just using the original version, (no extra condition)
   DPH = evol_eq_tbl[DPH][dis],
   # Using higher order derivative condition (see the paper)
   dg  = table( [ x = NT(SB(Gen_Sten(diff(A(t,x),x)))) ,theta= NT(SB(Gen_Sten(diff(B(t,x),x)))) ] ),
   # No BC here
   DTK = evol_eq_tbl[DTK][dis],
   # Same as dg
   DAA  = table( [ x = NT(SB(Gen_Sten(diff(Axx(t,x),x)))) +hx*myzero ,theta= hx*myzero+NT(SB(Gen_Sten(diff(Athth(t,x),x))))  ] ),
   # Same as dg
   DLAM = table( [ x = NT(SB(Gen_Sten(diff(Lamx(t,x),x,x))) ), theta= 0 ] ),
   # No BC here
   EQRPIb2 = evol_eq_tbl[EQRPIb2][dis],
   EQIPIb2 = evol_eq_tbl[EQIPIb2][dis],
   EQRPSI  = evol_eq_tbl[EQRPSI][dis],
   EQIPSI  = evol_eq_tbl[EQIPSI][dis]

] );

# Adding the newly defined FDA's to the original table:
for ii from 1 to nops(evol_trm) do
  nm := evol_trm[ii][1];
  rank := evol_trm[ii][2];
  if rank <> 0 then
    for jj from 1 to 2 do
       cn := coord[jj];
        evol_eq_tbl[nm][disorg][cn] := org_bdc_tbl[nm][cn];
        evol_eq_tbl[nm][disorgp1][cn] := orgp1_bdc_tbl[nm][cn];
    end do
  else
       evol_eq_tbl[nm][disorg] := org_bdc_tbl[nm];
       evol_eq_tbl[nm][disorgp1] := orgp1_bdc_tbl[nm];
  end if;
end do:

# BC for work variables, in reality the values will never be used
e_org_bdc_tbl := table ( [
EMPH = myzero*x+1,
met = [myzero*x+1,myzero*x+1],
DDL = [myzero*x,myzero*x],
RR  = [myzero*x,myzero*x],
U   = [myzero*x,myzero*x],
P   = [myzero*x,myzero*x],
C1 = myzero*x,
C5 = myzero*x,
DRPSI = myzero*x,
DIPSI = myzero*x,
DB  = myzero*x
 ] );

pl:=table([ t=[-1,-1],x=[-1,-1],y=[-1,-1],z=[-1,-1] ]):
Update_FD_Table(2,pl):

# Adding them to the equation table:
for ii from 1 to nops(eval_term) do
  nm := eval_term[ii][1];
  rank := eval_term[ii][2];
  if rank <> 0 then
    for jj from 1 to 2 do
       cn := coord[jj];
        eval_expr_tbl[nm][disorg][cn] := Gen_Sten(e_org_bdc_tbl[nm][jj]);
    end do
  else
        eval_expr_tbl[nm][disorg] := Gen_Sten(e_org_bdc_tbl[nm]);
  end if;
end do:

# Treating Hamiltonian constraint seperately
pl:=table([ t=[-1,-1],x=[-1,-1],y=[-1,-1],z=[-1,-1] ]):
Update_FD_Table(2,pl):

nm := HS;

const_eq_tbl := table ( [] );

const_eq_tbl[nm][dis] := tt[nm][dis];
const_eq_tbl[nm][disreg] := tt[nm][disreg];
t_mp_1 := A_FD_Even(tt[nm][disreg],x,set_of_even_funcs,0,"forward");
t_mp_2 := A_FD_Odd(t_mp_1,x,set_of_odd_funcs,0,"forward");
const_eq_tbl[nm][disorg] := t_mp_2;

pl:=table([ t=[-1,-1],x=[-1,0],y=[-1,-1],z=[-1,-1] ]):
Update_FD_Table(2,pl):

# BC for Hamiltonian constraint at infinity:
const_eq_tbl[nm][inf] := Gen_Sten(ctfm(x)*diff(psi(t,x),x)/ctfmp(x) + psi(t,x) - 1);

pl:=table([ t=[-1,-1],x=[0,-1],y=[-1,-1],z=[-1,-1] ]):
Update_FD_Table(2,pl):

const_eq_tbl[nm][disorg] := Gen_Sten(diff(psi(t,x),x));

pl:=table([ t=[-1,-1],x=[-1,-1],y=[-1,-1],z=[-1,-1] ]):
Update_FD_Table(2,pl):

# Will store header files, to pre-generate the C routine
Other_Headers := NULL;

# DDS for HC is easy:

spec := [
  { i = [1,1,1],  b=xmin } =  const_eq_tbl[nm][disorg] ,
  { i = [2,Nx-1,1] } = const_eq_tbl[nm][dis] ,
  { i = [Nx,Nx,1], b=xmax  } = const_eq_tbl[nm][inf]
 ];

# Residual evaluator for HC
A_Gen_Res_Code(spec,input="d",proc_name="resid_hs");
Other_Headers := Other_Headers , "resid_hs";

# Solver for HC
A_Gen_Solve_Code(spec,{psi(n,i)},proc_name="solve_hs");
Other_Headers := Other_Headers , "solve_hs";

# Now working with momentum constraint
pl:=table([ t=[-1,-1],x=[-1,-1],y=[-1,-1],z=[-1,-1] ]):
Update_FD_Table(2,pl):

nm := MK;

const_eq_tbl := table ( [] );

const_eq_tbl[nm][dis] := tt[nm][dis][x];
const_eq_tbl[nm][disreg] := tt[nm][disreg][x];
t_mp_1 := A_FD_Even(tt[nm][disreg][x],x,set_of_even_funcs,0,"forward");
t_mp_2 := A_FD_Odd(t_mp_1,x,set_of_odd_funcs,0,"forward");
const_eq_tbl[nm][disorg] := t_mp_2;

spec := [
  { i = [1,1,1],  b=xmin } =  const_eq_tbl[nm][disorg] ,
  { i = [2,Nx-1,1] } = const_eq_tbl[nm][dis] ,
  { i = [Nx,Nx,1], b=xmax  } = myzero*x(i)
 ];

# Evaluator routine for momentum constraint, for testing purposes
A_Gen_Eval_Code(spec,input="d",proc_name="ire_mk");

##########################################################
# See the bssn_spher.mw for what HS3 is, another form of
# Hamiltonian constraint
##########################################################
pl:=table([ t=[-1,-1],x=[-1,-1],y=[-1,-1],z=[-1,-1] ]):
Update_FD_Table(2,pl):

nm := HS3;

const_eq_tbl := table ( [] );

const_eq_tbl[nm][dis] := tt[nm][dis];

pl:=table([ t=[-1,-1],x=[-1,0],y=[-1,-1],z=[-1,-1] ]):
Update_FD_Table(2,pl);

const_eq_tbl[nm][inf] := Gen_Sten(psi(t,x) - 1 +myzero*ctfm(x));

pl:=table([ t=[-1,-1],x=[0,-1],y=[-1,-1],z=[-1,-1] ]):
Update_FD_Table(2,pl):

const_eq_tbl[nm][disorg] := Gen_Sten(diff(psi(t,x),x)):

pl:=table([ t=[-1,-1],x=[-1,-1],y=[-1,-1],z=[-1,-1] ]):
Update_FD_Table(2,pl):

Other_Headers := NULL;

spec := [
  { i = [1,1,1],  b=xmin } =  const_eq_tbl[nm][disorg] ,
  { i = [2,Nx-1,1] } = const_eq_tbl[nm][dis] ,
  { i = [Nx,Nx,1], b=xmax  } = const_eq_tbl[nm][inf]
 ]:

A_Gen_Res_Code(spec,input="d",proc_name="resid_hs3");
Other_Headers := Other_Headers , "resid_HS3";

A_Gen_Solve_Code(spec,{psi(n,i)},proc_name="solve_hs3");
Other_Headers := Other_Headers , "solve_HS3";

# End of constraint equation solvers / evaluators

# Initializer expressions for grid functions:

init_alpha_expr:=myzero*x+1;
init_beta_expr:=myzero*x;
init_A_expr:=myzero*x+1;
init_B_expr:=myzero*x+1;
init_Axx_expr:=myzero*x;
init_Athth_expr:=myzero*x;
init_TK_expr:=myzero*x;
init_Lamx_expr:=myzero*x;

# Some redefintion of variables:

phi_expr:=log(psi(t,x));
psi_expr := exp(phi(t,x));
a2_expr:= psi(t,x)^4*A(t,x);
a1_expr := sqrt(a2(t,x));
b1_expr := psi(t,x)^2*sqrt(B(t,x));

lv := 'lv';
rv := 'rv';

# Initializer for matter field (Gaussian pulse on real coordinate)
rpsi_expr :=  amp*exp( - ( ctfm(x) - x0 )^2 / deltx^2 );
ipsi_expr := myzero*x*x;

# Note the correction due to compactification
init_rPHI_expr := diff(rpsi_expr, x)/ctfmp(x);
init_iPHI_expr := diff(ipsi_expr, x)/ctfmp(x);

rpsidot_expr := myzero*x;
ipsidot_expr := omega*rpsi_expr;

# PI = a/alpha(psidot - beta*psiprime)

init_rPI_expr := a1(t,x)/alpha(t,x)*(rpsidot(t,x) - beta(t,x)*rPHI(t,x));
init_iPI_expr := a1(t,x)/alpha(t,x)*(ipsidot(t,x) - beta(t,x)*iPHI(t,x));

init_rPIb2_expr := rPI(t,x)*b1(t,x)^2;
init_iPIb2_expr := iPI(t,x)*b1(t,x)^2;

rPI_comp_expr :=  rPIb2(t,x)/b1(t,x)^2;
iPI_comp_expr :=  iPIb2(t,x)/b1(t,x)^2;

PI2_expr := (rPI(t,x)^2 + iPI(t,x)^2);
PHI2_expr := (rPHI(t,x)^2 + iPHI(t,x)^2);

# Energy-momentum tensor expressions:

U_expr := mass*(rpsi(t,x)^2 + ipsi(t,x)^2);

rho_expr:= ( PI2(t,x) + PHI2(t,x) ) / ( 2*a2(t,x)) + U(t,x)/2;

JSxx_expr:=  ( PI2(t,x) + PHI2(t,x) ) / (2) - a2(t,x)*U(t,x)/2;

JSthetatheta_expr :=  (  (PI2(t,x) - PHI2(t,x)) / ( 2*a2(t,x) ) - U(t,x)/2  ) * b1(t,x)^2;

TS_expr := ( 3*PI2(t,x) - PHI2(t,x) ) / (2*a2(t,x) ) - 3/2*U(t,x) ;
Sx_expr := - (  rPI(t,x)*rPHI(t,x) + iPI(t,x)*iPHI(t,x)  ) / (a1(t,x))  ;

############################################################
# all_expr will be used for pre-generation of main.c routine
# this is an experimental feature in FD
############################################################
all_expr := rPHI_expr+mass+omega;

# Creating initializer routines

Gen_Eval_Code(init_alpha_expr,input="c",proc_name="init_alpha");
Gen_Eval_Code(init_beta_expr,input="c",proc_name="init_beta");

Gen_Eval_Code(init_A_expr,input="c",proc_name="init_a");
Gen_Eval_Code(init_B_expr,input="c",proc_name="init_b");

Gen_Eval_Code(init_TK_expr,input="c",proc_name="init_tk");
Gen_Eval_Code(init_Axx_expr,input="c",proc_name="init_axx");
Gen_Eval_Code(init_Athth_expr,input="c",proc_name="init_athth");
Gen_Eval_Code(init_Lamx_expr,input="c",proc_name="init_lamx");

Gen_Eval_Code(rpsi_expr,input="c",proc_name="init_rpsi");
Gen_Eval_Code(ipsi_expr,input="c",proc_name="init_ipsi");

Gen_Eval_Code(init_iPHI_expr,input="c",proc_name="init_iphi");
Gen_Eval_Code(init_rPHI_expr,input="c",proc_name="init_rphi");

Gen_Eval_Code(rpsidot_expr,input="c",proc_name="init_rpsidot");
Gen_Eval_Code(ipsidot_expr,input="c",proc_name="init_ipsidot");

Gen_Eval_Code(init_rPI_expr,input="c",proc_name="init_rpi");
Gen_Eval_Code(init_iPI_expr,input="c",proc_name="init_ipi");

Gen_Eval_Code(init_iPIb2_expr,input="c",proc_name="init_ipib2");
Gen_Eval_Code(init_rPIb2_expr,input="c",proc_name="init_rpib2");

Gen_Eval_Code(phi_expr,input="c",proc_name="compute_phi");
Gen_Eval_Code(psi_expr,input="c",proc_name="compute_psi");
Gen_Eval_Code(a2_expr,input="c",proc_name="compute_a2");
Gen_Eval_Code(a1_expr,input="c",proc_name="compute_a1");
Gen_Eval_Code(b1_expr,input="c",proc_name="compute_b1");

Gen_Eval_Code(iPI_comp_expr,input="c",proc_name="compute_ipi");
Gen_Eval_Code(rPI_comp_expr,input="c",proc_name="compute_rpi");

Gen_Eval_Code(PHI2_expr,input="c",proc_name="compute_phi2");
Gen_Eval_Code(PI2_expr,input="c",proc_name="compute_pi2");

Gen_Eval_Code(U_expr,input="c",proc_name="compute_u");

Gen_Eval_Code(rho_expr,input="c",proc_name="compute_rho");
Gen_Eval_Code(JSxx_expr,input="c",proc_name="compute_jsxx");
Gen_Eval_Code(JSthetatheta_expr,input="c",proc_name="compute_jsthth");
Gen_Eval_Code(TS_expr,input="c",proc_name="compute_ts");
Gen_Eval_Code(Sx_expr,input="c",proc_name="compute_sx");

C5psi_expr := C5s(t,x)*psi(t,x)^5;
Gen_Eval_Code(C5psi_expr,input="c",proc_name="compute_c5psi");

# Newly generated header files, will be passed to C code generator
Other_Headers := Other_Headers , "init_alpha", "init_beta", "init_A" , "init_B", "init_TK", "init_Axx", "init_Athth",
                "init_Lamx", "compute_phi", "compute_psi", "compute_a2", "compute_a1",
                "compute_b1", "init_rpsi", "init_ipsi", "init_iphi", "init_rphi",
                "init_ipib2", "init_rpib2", "compute_ipi", "compute_rpi",
                "compute_phi2", "compute_pi2", "compute_u", "compute_rho", "compute_jsxx",
                "compute_jsthth", "compute_ts", "compute_sx", "init_rpsidot", "init_ipsidot", "init_rpi","init_ipi";

# Creating DDS for work variables and calculator routines
all_work_tensors:=[
      [EMPH,0,dn], [DB,0,dn],
         [met,2,dn], [DDL,2,dn],
         [RR,2,dn], [U,2,dn] , [P,2,dn],
         [C1,0,dn], [C5,0,dn], [DRPSI,0,dn], [DIPSI,0,dn]
             ];

for ii from 1 to nops(all_work_tensors) do
  nm:= all_work_tensors[ii][1]:
  rank := all_work_tensors[ii][2]:
  if rank <> 0 then
     for jj from 1 to 2 do
       cn := coord[jj];
       # DDS for work variables
       spec := [
                     { i = [1,1,1] , b=xmin }     = eval_expr_tbl[nm][disorg][cn]    ,
                     { i = [2,Nx-1,1] }  = eval_expr_tbl[nm][dis][cn]  ,
                     { i = [Nx,Nx,1] , b=xmax }  = eval_expr_tbl[nm][disinf][cn]
               ];
      # creating calculator routines fortran routines for work variables
      A_Gen_Eval_Code(spec,input="d",proc_name=LowerCase(cat("compute_",nm,cn)));
      Other_Headers := Other_Headers , LowerCase(cat("compute_",nm,cn));
     end do;
  else
        spec := [
                     { i = [1,1,1] , b=xmin }     = eval_expr_tbl[nm][disorg]    ,
                     { i = [2,Nx-1,1] }  = eval_expr_tbl[nm][dis]  ,
                     { i = [Nx,Nx,1] , b=xmax  }  = eval_expr_tbl[nm][disinf]
               ];
      A_Gen_Eval_Code(spec,input="d",proc_name=LowerCase(cat("compute_",nm)));
      Other_Headers := Other_Headers , LowerCase(cat("compute_",nm));
  end if;
end do:

# Treating conformal connection equation first:

spec := [
  { i = [1,1,1] , b=xmin } = myzero*x(i),
  { i = [2,Nx-1,1] } = tt[DLAM][dis][x] ,
  { i = [Nx,Nx,1] , b=xmax  } = myzero*x(i)
];

A_Gen_Eval_Code(spec, input="d",proc_name="eval_dlam");

# Creating a table to hold the K/O dissipation at various points of discrete domain
dis_tbl := table([]);
for ii from 1 to nops(evol_trm) do
  nm := evol_trm[ii][1];
  rank := evol_trm[ii][2];
  if rank <> 0 then
    for jj from 1 to 2 do
       cn := coord[jj];
       fn := dis_func_tbl[nm][cn];

       dis_tbl[nm][mid][cn] := -AVGT(DISS(fn));
       dis_tbl[nm][org][cn] := -AVGT(DISS(fn));
       dis_tbl[nm][orgp1][cn] :=  -AVGT(DISS(fn));

       # Using FD's even odd facility to built the correct version of FDA
       # That can be used at the origin / infinity
       t_mp_1:= A_FD_Even(dis_tbl[nm][org][cn],x,set_of_even_funcs,0,"forward");
       dis_tbl[nm][org][cn]:= A_FD_Odd(t_mp_1,x,set_of_odd_funcs,0,"forward");

       t_mp_1:= A_FD_Even(dis_tbl[nm][orgp1][cn],x,set_of_even_funcs,-1,"forward");
       dis_tbl[nm][orgp1][cn]:= A_FD_Odd(t_mp_1,x,set_of_odd_funcs,-1,"forward");

    end do
  else
      fn := dis_func_tbl[nm];

       dis_tbl[nm][mid] := -AVGT(DISS(fn));
       dis_tbl[nm][org] := -AVGT(DISS(fn));
       dis_tbl[nm][orgp1] :=  -AVGT(DISS(fn));

       t_mp_1:= A_FD_Even(dis_tbl[nm][org],x,set_of_even_funcs,0,"forward");
       dis_tbl[nm][org]:= A_FD_Odd(t_mp_1,x,set_of_odd_funcs,0,"forward");

       t_mp_1:= A_FD_Even(dis_tbl[nm][orgp1],x,set_of_even_funcs,-1,"forward");
       dis_tbl[nm][orgp1]:= A_FD_Odd(t_mp_1,x,set_of_odd_funcs,-1,"forward");

  end if;
end do:

####### NOW EVOLUTION EQUATIONS ##########

for ii from 1 to nops(evol_trm) do
  nm := evol_trm[ii][1]:
  rank := evol_trm[ii][2]:
  if rank <> 0 then
    for jj from 1 to 2 do
      cn := coord[jj];
      fn := dis_func_tbl[nm][cn]:
      # there are 5 conditions, origin, next to origin, middle, next to infinity and infinity
      # here is the glory of FD! (Also we are adding the right dissipation expression)
      spec := [
                 {i = [1,1,1] , b=xmin }    =  evol_eq_tbl[nm][disorg][cn],
                 {i = [2,2,1] , b=xmin }    =  evol_eq_tbl[nm][disorgp1][cn] + dis_tbl[nm][orgp1][cn],
                 {i = [3,Nx-2,1] } =  evol_eq_tbl[nm][dis][cn] + dis_tbl[nm][mid][cn],
                 {i = [Nx-1,Nx-1,1] } =  evol_eq_tbl[nm][dis][cn],
                 {i = [Nx,Nx,1] , b = xmax } =  evol_eq_tbl[nm][disinf][cn]
              ];
      if not( nm=DLAM and cn=theta) then
         print(cat("Solve code for:",nm,cn," Generated."));
         A_Gen_Solve_Code(spec,{solve_for_tbl[nm][cn] },input="d",proc_name=LowerCase(cat("evolve_",nm,cn)));
         Other_Headers := Other_Headers , cat("evolve_",nm,cn);
         A_Gen_Res_Code(spec,input="d",proc_name=LowerCase(cat("resid_",nm,cn)));
         Other_Headers := Other_Headers , cat("resid_",nm,cn);
         print(cat("Res code for:",nm,cn," Generated."));
      end if;
    end do;
  else
      fn := dis_func_tbl[nm];
      spec := [
                 {i = [1,1,1] , b=xmin }    =  evol_eq_tbl[nm][disorg],
                 {i = [2,2,1] , b=xmin }    =  evol_eq_tbl[nm][disorgp1] + dis_tbl[nm][orgp1],
                 {i = [3,Nx-2,1] } =  evol_eq_tbl[nm][dis] + dis_tbl[nm][mid],
                 {i = [Nx-1,Nx-1,1] } =  evol_eq_tbl[nm][dis],
                 {i = [Nx,Nx,1] , b=xmax  } =  evol_eq_tbl[nm][disinf]

              ];
    A_Gen_Solve_Code(spec,{solve_for_tbl[nm]},proc_name=LowerCase(cat("evolve_",nm)));
    Other_Headers := Other_Headers , cat("evolve_",nm);
    print(cat("Solve code for:",nm," Generated."));
    A_Gen_Res_Code(spec,input="d",proc_name=LowerCase(cat("resid_",nm)));
    Other_Headers := Other_Headers , cat("resid_",nm);
    print(cat("Res code for:",nm," Generated."));
  end if;
end do:

#Generating driver header:
pl:=table([ t=[-1,-1],x=[-1,-1],y=[-1,-1],z=[-1,-1] ]):
Update_FD_Table(2,pl):

#############################################################
# This is where I use the Other_Headers in FD
# GDC is an experimental feature, it generates a tempalte
# for a main C driver routine.
# It uses all_expr variable to learn all necessary definition
# for a solver routine, enable it and see what it generates
#############################################################

#GDC(all_expr+myzero,input="c",output="main",other_headers={Other_Headers});

# Creating IRE for BSSN equations (notice how quick this is!)

printf("Generating IREs...\n");
pl:=table([ t=[-1,-1],x=[-1,-1],y=[-1,-1],z=[-1,-1] ]):
Update_FD_Table(2,pl):
interface(warnlevel = 0):

for ii from 1 to nops(evol_trm) do
  nm := evol_trm[ii][1];
  rank := evol_trm[ii][2];
  if rank <> 0 then
    for jj from 1 to 2 do
       cn := coord[jj];
       all_expr:=all_expr + ( evol_eq_LHS_tbl[nm][jj] -  tt[nm][all][cn] );
       sten := Gen_Sten( evol_eq_LHS_tbl[nm][jj] -  tt[nm][all][cn]);
       if (sten <> 0 ) then
         Gen_Res_Code(sten,input="d",proc_name=LowerCase(cat("ire_",nm,cn)));
         Gen_Eval_Code(sten,input="d",proc_name=LowerCase(cat("irev_",nm,cn)));
         Other_Headers := Other_Headers , cat("ire_",nm,cn);
       end if;
    end do
  else
       all_expr:=all_expr + ( evol_eq_LHS_tbl[nm] -  tt[nm][all] );
       sten := Gen_Sten( evol_eq_LHS_tbl[nm] -  tt[nm][all]);
       if (sten <> 0) then
         Gen_Res_Code(sten,input="d",proc_name=LowerCase(cat("ire_",nm)));
         Gen_Eval_Code(sten,input="d",proc_name=LowerCase(cat("irev_",nm)));
         Other_Headers := Other_Headers , cat("ire_",nm);
       end if;
  end if;
end do:


# 求解的成立条件

$ifndef _CONDITION_
$define _CONDITION_

$include "Utils.mpl"

(*
* 求 解的 定义域
* 返回的条件中求解了单变量约束
* 如果无解则返回 x=undefined 的约束用作标记
* 保留了多变量约束
*)
findSolutionDomain:=proc(s)
    local con;
    con:=`union`(findDomain~(rhs~({s[]}))[]);
    return remove(x->type(x,`=`) and (lhs(x)=rhs(x)),classifySolve(con))
        union select(x->type(rhs(x),numeric),{s[]});
end proc:

(*
* 求解表达式的定义域
* 只考虑 + * ^ ln
*)
findDomain:=proc(ee)
    local S,r;
    S:={};
    findDomainCondtions(ee,S);
    return S;
end proc:

(*
* 求解表达式的定义域约束条件
* 只考虑 + * ^ ln
*)
findDomainCondtions:=proc(e,S::evaln(set))
    local _e;
    if type(e,`^`) and (not type(op(1,e),numeric)) then
        if (op(2,e)<0) then
            if type(op(2,e),fraction) and type(denom(op(2,e)),even) then
                S:=eval(S) union {op(1,e)>0};
            else
                S:=eval(S) union {op(1,e)<>0};
            end if;
        else
            if type(op(2,e),fraction) and type(denom(op(2,e)),even) then
                S:=eval(S) union {op(1,e)>=0};
            end if;
        end if;
    elif type(e,`+`) or type(e,`*`) then
        for _e in e do
            findDomainCondtions(_e,S);
        end do;
    elif (op(0,e)='ln') and (not type(op(1,e),numeric)) then
        S:=eval(S) union {op(e)>0};
    end if;
end proc:

# 不等式约束分类求解
# 合并单变量约束
# 保留多变量约束
classifySolve:=proc(con::set)
    local t,sd,ns,c,ind,x,sol;
    t:=table();
    ns,sd:=selectremove(x->(numelems(indets(x,name))=1),con);
    for c in ns do
        tappend(t,indets(c,name)[],c);
    end do;
    ind:=[indices(t,nolist)];
    for x in ind do
        sol:=RealDomain:-solve(t[x],{x});
        if (sol=NULL) then
            t[x]:={x=undefined};
        else
            t[x]:=sol;
        end if;
    end do;
    ns:=`union`(entries(t,nolist));
    return sd union ns;
end proc:

$endif


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

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

(* type: mgga_exc *)

(* prefix:
  mgga_x_br89_params *params;

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

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

(* This is the derivative of f = x*exp(-2.0/3.0*x)/(x - 2) = y = 2*Pi^(2/3)/(3*Q) *)
br89_aux_dfdx := x -> -2/3 * exp(-2*x/3) * (x^2 - 2*x + 3) / (x - 2)^2:

`diff/br89_x` := proc(Q, g)
  -2/3 * Pi^(2/3) * diff(Q, g)/(Q^2 * br89_aux_dfdx(br89_x(Q)))
end proc:

br89_Q := (x, u, t) ->
  (u - 4*params_a_gamma*t + params_a_gamma*x^2/2)/6:

br89_min_Q := 5.0e-13:
br89_cQ := Q -> my_piecewise3(abs(Q) < br89_min_Q,
  my_piecewise3(Q > 0, br89_min_Q, -br89_min_Q), Q):

br89_v := x ->
  -2*Pi^(1/3)/X_FACTOR_C * exp(x/3)*(1 - exp(-x)*(1 + x/2))/x:

br89_mx := Q -> br89_x(Q):

br89_f := (x, u, t) ->
  - br89_v(br89_mx(br89_cQ(br89_Q(x, u, t))))/2 *
  (1 + params_a_at*mgga_series_w([0, 1, 0, -2, 0, 1], 6, t)):

f := (rs, z, xt, xs0, xs1, u0, u1, t0, t1) ->
  mgga_exchange(br89_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: work_mgga_x *)

a := 2.413:
b := 0.348:

params_a_b      := 0.40:
params_a_c      := 1.59096:
params_a_e      := 1.537:
params_a_mu     := 0.21951:

alpha           := (x, t) -> (t - x^2/8)/K_FACTOR_C:

(* Equation (8) *)

mkappa := (x, t) -> 2*Pi/(3*sqrt(5)) * \
          sqrt(alpha(x, t) + 1)/sqrt(a + log(alpha(x, t) + b)):
ff     := 2:

$include "tpss_x.mpl"

a1  := (x, t) -> mkappa(x, t)/(mkappa(x, t) + fx(x, t)):
f   := (rs, x, t, u) -> 1 + mkappa(x, t)*(1 - a1(x, t)):


`is_element/hasse_diagrams` := (A::set) -> proc(G)
 global reason;
 local D,R;

 if not(`is_element/autorel`(A)(G)) then
  reason := ["is_element/hasse_diagrams","G is not a relation on A",G,reason];
  return false;
 fi;

 if not(`is_antisymmetric/autorel`(A)(G)) then
  reason := ["is_element/hasse_diagrams","G is not antisymmetric",G];
  return false;
 fi;

 D := `id/autorel`(A);
 R := `o/autorel`(A)(G,G);

 while R <> {} do
  if R intersect G <> {} then
   reason := ["is_element/hasse_diagrams","G has an arrow parallel to a longer path",G,R intersect G];
   return false;
  fi;

  if R intersect D <> {} then
   reason := ["is_element/hasse_diagrams","G has a loop",G,R intersect D];
   return false;
  fi;

  R := `o/autorel`(A)(R,G);
 od;

 return true;
end:

`is_element/ranked_hasse_diagrams` := (A::set) -> proc(Gr)
 local G,r,AA,rA,d,A1,r1,a,b,AA1,G1,M1,M2,Aa,A0,Ma,rMa,i;
 global reason;

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

 G,r := op(Gr);

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

 if not(type(G,set) and G minus AA = {}) then
  reason := [convert(procname,string),"G is not a subset of A^2 minus Delta",G,A];
  return false;
 fi;

 if not(type(r,table) and [indices(r)] = map(a -> [a],[op(A)])) then
  reason := [convert(procname,string),"r is not a table indexed by A",r,A];
  return false;
 fi;

 if A = {} then return true; fi;

 rA := map(a -> r[a],A);
 if not(type(rA,list(integer)) and min(op(rA)) = 0) then
  reason := [convert(procname,string),"The values of r are not integers starting from 0",r,A];
  return false;
 fi;

 d := max(rA);
 if rA <> {seq(i,i=0..d)} then
  reason := [convert(procname,string),"The values of r do not form an interval starting from 0",r,A];
  return false;
 fi;

 if d = 0 then
  if G = {} then
   return true;
  else
   reason := [convert(procname,string),"All ranks are zero but G is not empty",G];
   return false;
  fi;
 fi;

 A1 := select(a -> (r[a] < d),A);
 r1 := table();
 for a in A1 do r1[a] := r[a]; od;
 AA1 := {seq(seq([a,b],b in A1),a in A1)} minus {seq([a,a],a in A1)};
 G1 := G intersect AA1;

 if not(`is_element/ranked_hasse_diagrams`(A1)([G1,r1])) then
  return false;
 fi;

 M1 := NULL;
 for a in A1 do
  Aa := select(b -> member([a,b],G1),A1);
  if Aa = {} then M1 := M1,a; fi;
 od:
 M1 := {M1};
 M2 := select(a -> (r[a] = d-1),M1);

 A0 := A minus A1;

 for a in A0 do
  Ma := select(b -> member([b,a],G),A);
  rMa := map(b -> r[b],Ma);
  if not(member(d-1,rMa)) then
   reason := [convert(procname,string),"a has rank d but does not cover anything of rank d-1",a,d,Ma];
   return false;
  fi;
 od:
end:


TITLE

    DakotaModel_deterministic;
    ! Objective value 4165.0

INDEX

    PRODUCTS := (Desk, Table, Chair);
    RESOURCES := (Lumber, Finishing, Carpentry);

DATA

    Price[PRODUCTS] := (60, 40, 10);
    Cost[RESOURCES] := (2, 4, 5.2);
    Consumption[RESOURCES, PRODUCTS] := (8, 6, 1
					4, 2, 1.5
					2, 1.5, .5);
    Demand[PRODUCTS] := (150, 125, 300);

BINARY VARIABLES

   BinVec[PRODUCTS];

VARIABLES

   Purchase[RESOURCES];
   Production[PRODUCTS];
   BinaryVar;

MIN

    Profit = -sum(PRODUCTS: Price * Production) + sum(RESOURCES: Cost * Purchase) - BinaryVar - sum(PRODUCTS: BinVec);

SUBJECT TO

    ResourceConstraint[RESOURCES]: sum(PRODUCTS: Consumption * Production) <= Purchase;
    DemandConstraint[PRODUCTS]: Production <= Demand;

BOUNDS

    DeskBound: Production[PRODUCTS=Desk] <= 160 ;
    TableBound: 130 >= Production[PRODUCTS=Table] ;

FREE

    Purchase[RESOURCES=Lumber];

BINARY

   BinaryVar;

INTEGER

   Production[PRODUCTS];

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

tih_par := [
  -1.0953, -0.0334789, 0.414661, -0.152399, -0.354691,
  0.0390837, -0.0748531, -0.136598, -1.41063, 0.00496577,
  0.48315, 4.02905, -0.420166, 0.0104352, -1.47409,
  -0.442455, 0.625039, 1.30351, 1.37026, -1.29598,
  -1.04305, -0.909651, -0.991782, -0.915745, 1.95026
]:

tih_zj := (j, n) -> tanh(tih_par[2*j-1] + tih_par[2*j]*n):

tih_vxc := n ->
  tih_par[17] + add(tih_par[i]*tih_zj(i-17, n), i=18..25):

f  := (rs, z) ->
  tih_vxc(n_total(rs)):


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

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

(* type: mgga_exc *)

$define mgga_x_revtpss_params
$include "mgga_x_tpss.mpl"

reg_c := 3:
reg_d := 1.475:

reg_f_a :=  a -> (1 - a)^3/(1 + (reg_d*a)^2)^(3/2):

(* Eq. (12). Note that alpha = 0 => t = x^2/8 *)
reg_f := (x, u, t) ->
  tpss_f(x, u, t) + reg_f_a(tpss_alpha(x, t))*exp(-reg_c*X2S^2*x^2)*(tpss_f(x, u, x^2/8) - tpss_f(x, u, t)):

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


# This file is about Zagier's proof that every prime congruent to 1 mod 4
# is the sum of two squares.

# The following matrices generate a dihedral group of order 12 that
# acts on Z ^ 3 preserving the quadratic form Q

S := <<-1| 2| 0>,< 0| 1| 0>,< 1|-1| 1>>;
R := << 1| 0| 2>,< 0| 0| 1>,<-1| 1|-1>>;

Q := << 1| 0| 0>,< 0| 0| 2>,< 0| 2| 0>>;
I3 := IdentityMatrix(3);

G := [seq(seq(R ^ i . S ^ j, i = 0..5),j = 0..1)];

_ASSERT("Dihedral relations",
  Equal(S . S, I3) and Equal(R . R . R, -I3) and Equal(S . R . S, 1/R));

_ASSERT("Quadratic form relations",
  Equal(Transpose(S) . Q . S, Q) and Equal(Transpose(R) . Q . R, Q));

# The following map F gives an involution on the set X

F := proc(x)
  if (R . x)[3] > 0 then
    return R . x;
  elif ((1/R) . x)[1] > 0 then
    return (1/R) . x;
  else
    return S . x;
  fi;
end:

p := ithprime(10);

X := select(u -> type(u[3],posint),
  {seq(seq(<i,j,(p - i ^ 2)/(4 * j)>,j=1..p-1),i=1..p-1)}):

_ASSERT("F preserves X",
  evalb(map(convert,map(F,X),list) = map(convert,X,list)));

_ASSERT("F is an involution on X",
  `and`(seq(Equal(F(F(x)),x),x in X)));

_ASSERT("F has a unique fixed point on X",
  evalb(map(convert,select(x -> Equal(F(x),x),X),list) = {[1,1,(p - 1)/4]}));

fix := (T) -> subs(solve(convert(T . <x,y,z> - <x,y,z>,list),{x,y,z}),[x,y,z]);


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

`is_element/ord_simplex_interior` := (A::set) -> proc(Rx)
 local R,x;
 global reason;

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

 R,x := op(Rx);

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

 if not(`is_element/simplex_interior`(A)(x)) then
  reason := [convert(procname,string),"x is not in the interior of the A-simplex",x,A,reason];
  return false;
 fi;

 return true;
end;

`is_equal/ord_simplex_interior` := (A::set) -> proc(Rx,Sy)
 global reason;

 if not `is_equal/ord`(A)(Rx[1],Sy[1]) then
  reason := [convert(procname,string),"R <> S",Rx[1],Sy[1],reason];
  return false;
 fi;

 if not `is_equal/simplex`(A)(Rx[2],Sy[2]) then
  reason := [convert(procname,string),"x <> y",Rx[2],Sy[2],reason];
  return false;
 fi;

 return true;
end;

`is_leq/ord_simplex_interior` := NULL;

`random_element/ord_simplex_interior` := (A::set) -> proc(d::posint := 5)
 [`random_element/ord`(A)(),
  `random_element/simplex_interior`(A)(d)];
end;

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

`phi/ord_simplex_interior/one_cubes_prime` := (A::set) -> proc(Rx)
 local R,x,y,n,i,j,p,q;

 R,x := op(Rx);
 y := table();
 n := nops(R);

 for i from 1 to n do
  p := add(x[R[j]],j=1..i-1);
  q := p + x[R[i]];
  y[R[i]] := [[p],[q]];
 od;

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


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

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

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

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

$ifdef gga_x_pw91_params
params_a_a     :=   0.19645:
params_a_b     :=   7.7956:
params_a_c     :=   0.2743:
params_a_d     :=  -0.1508:
params_a_f     :=   0.004:
params_a_alpha := 100:
params_a_expo  :=   4:
$endif

pw91_num := s -> (params_a_c + params_a_d*exp(-params_a_alpha*s^2))*s^2
         - params_a_f*s^params_a_expo:
pw91_den := s -> 1 + s*params_a_a*arcsinh(params_a_b*s) + params_a_f*s^params_a_expo:

pw91_f  := x -> 1 + pw91_num(X2S*x)/pw91_den(X2S*x):

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

(* Equations are from the Appendix of Kurth1999_889 *)

$include "gga_c_gapc.mpl"

gap_par0[10] = 0.06483*((9*Pi)/4)^(2/3): (* this is approximately equal to 0.23878 *)

(* Eq. (A4) *)
kcis_G := (rs, xt) -> xt^2*n_total(rs)^(2/3)/8:

(* Eq. (A9) *)
kcis_t := (rs, xt) -> 2^(2/3)*xt/(8*sqrt(rs)):

kcis_beta := 0.066725:

(* Eq. (A7) *)
kcis_gga0 := (rs, xt) -> f_pw(rs, 0)/(1 + kcis_beta*log(1 + kcis_t(rs, xt)^2/m_abs(f_pw(rs, 0)))):

(* Eq. (A8) *)
kcis_gga1 := (rs, xt) -> f_pw(rs, 1)/(1 + kcis_beta*log(1 + 2^(-1/3)*kcis_t(rs, xt)^2/m_abs(f_pw(rs, 1)))):

(* Eq. (A5) *)
(* The polarized parameters are the same as the unpolarized ones *)
(* except that c_1, c_2, c_3 are multiplied by 0.7. 1.5, and 2.59 respectively *)
kcis_eps_0 := (rs, xt) ->
  + (kcis_gga0(rs, xt) + gap_c1(rs, 0, gap_par0)*kcis_G(rs, xt))
  / (1 + gap_c2(rs, 0, gap_par0)*kcis_G(rs, xt) + gap_c3(rs, 0, gap_par0)*kcis_G(rs, xt)^2):

(* Eq. (A6) *)
kcis_eps_1 := (rs, xt) ->
  + (kcis_gga1(rs, xt) + 0.7*gap_c1(rs, 0, gap_par0)*kcis_G(rs, xt))
  / (1 + 1.5*gap_c2(rs, 0, gap_par0)*kcis_G(rs, xt) + 2.59*gap_c3(rs, 0, gap_par0)*kcis_G(rs, xt)^2):

(* Eq. (A2) *)
gap_f := (rs, z, xt) ->
  + kcis_eps_0(rs, xt)
  + f_zeta(z)*(kcis_eps_1(rs, xt) - kcis_eps_0(rs, xt)):

(* Eq. (A1) *)
kcis_f := (rs, z, xt, xs0, xs1, ts0, ts1) ->
  + gap_f(rs, z, xt)
  - xs0^2/(8*ts0) * opz_pow_n( z,1)/2 * gap_f(rs*(2/(1 + z))^(1/3),  1, xs0)
  - xs1^2/(8*ts1) * opz_pow_n(-z,1)/2 * gap_f(rs*(2/(1 - z))^(1/3), -1, xs1):

f  := (rs, z, xt, xs0, xs1, us0, us1, ts0, ts1) ->
  kcis_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: mgga_exc *)

pkzb_a2 := 146/2025:
pkzb_a3 := -73/405:
pkzb_a4 := 0.131957187845257783631757384393: (* DD + 100/(81*81*kappa) *)

pkzb_kappa := 0.804:

pkzb_xx := (p, qt) -> MU_GE*p + pkzb_a2*qt*qt + pkzb_a3*qt*p + pkzb_a4*p*p:

pkzb_f := (x, u, t) -> 1 + pkzb_kappa - \
  pkzb_kappa^2/(pkzb_kappa + pkzb_xx(X2S^2*x^2, 6*X2S^2*t - 9/20 - X2S^2*x^2/12)):

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


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

 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]];
   return false;
  fi;
 od;

 return true;
end;

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

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

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

 return true;
end;

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

`random_element/real_functions` := (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/real_functions` := NULL;
`count_elements/real_functions` := NULL;

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

`is_nonnegative/real_functions` := (A::set) -> proc(x)
 local a;

 for a in A do
  if is(x[a] < 0) then
   return false;
  fi;
 od;

 return true;
end:

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

`is_leq/real_functions` := (A::set) -> proc(x,y)
 local a;

 for a in A do
  if is(x[a] > y[a]) then
   return false;
  fi;
 od;

 return true;
end:

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

`norm/real_functions` := (A::set) -> proc(x)
 local a,n;

 n := 0;
 for a in A do n := n + x[a]^2; od;

 return sqrt(n);
end:

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

`sum/real_functions` := (A::set) -> proc(x)
 local a,u;

 u := 0;
 for a in A do u := u + x[a]; od;

 return u;
end:

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

`max/real_functions` := (A::set) -> proc(x)
 local a,u;

 u := -infinity;
 for a in A do u := max(u,x[a]); od;

 return u;
end:

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

`min/real_functions` := (A::set) -> proc(x)
 local a,u;

 u := infinity;
 for a in A do u := min(u,x[a]); od;

 return u;
end:

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

`dist/real_functions` := (A::set) -> proc(x,y)
 local a,n;

 n := 0;
 for a in A do n := n + (x[a]-y[a])^2; od;

 return sqrt(n);
end:

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

`dot/real_functions` := (A::set) -> proc(x,y)
 local a,d;

 d := 0;
 for a in A do d := d + x[a]*y[a]; od;

 return d;
end:

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

`width/real_functions` := (A::set) -> proc(x)
 local V;
 V := map(a -> x[a],A);
 return max(op(V)) - min(op(V));
end:

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

`gap/real_functions` := (A::set) -> proc(x)
 local V,n,i;
 V := sort([op(map(a -> x[a],A))]);
 n := nops(V);
 return max(0,seq(V[i+1]-V[i],i=1..n-1));
end:

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

`relative_gap/real_functions` := (A::set) -> proc(x)
 return `gap/real_functions`(A)(x)/`width/real_functions`(A)(x);
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);

inc := a -> (a mod 9) +~ 1;
gb:= Matrix([seq([seq((inc@@(i+j-2))(grid),j=1..5)],i=1..5)] );
(gbw,gbl) := upperbound(gb);

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:

with(GraphTheory):
G := MakeWeighted(MakeDirected(SpecialGraphs:-GridGraph(gridl,gridw)));

for e in Edges(G) do
    SetEdgeWeight(G, e, grid[parse(e[2])]);
end do:

DijkstrasAlgorithm(G, "1,1", cat("",gridl,",",gridw))[2];
BG := MakeWeighted(MakeDirected(SpecialGraphs:-GridGraph(gbl,gbw)));

W := WeightMatrix(BG, copy=false);

for i from 1 to gbl do for j from 1 to gbw do
       a := j + (i-1)*(gbw);
       for n in nbs(i,j,gbw) do
           b := n[2] + (n[1]-1)*gbw; W[b,a] := gb[i,j];
       end do;
end do; end do:

answer2 := DijkstrasAlgorithm(BG, "1,1", cat("",gbl,",",gbw))[2];


make_upper_unitriangular := proc(n,p)
  local G,i,j,k,m,g,L,f;

  m := n * (n - 1) / 2;

  G := table():
  G["p"] := p;
  G["id"] := IdentityMatrix(n);
  G["o"] := (g,h) -> map(mods,g . h,G["p"]);
  G["inv"] := g -> map(mods,1/g,G["p"]);
  G["order"] := p ^ m;

  G["elementary"] := table():
  for i from 1 to n do
   for j from i+1 to n do
    g := Matrix(n,n);
    for k from 1 to n do g[k,k] := 1; od:
    g[i,j] := 1;
    G["elementary"][i,j] := g;
   od:
  od:

  L := [[]];
  for i from 1 to m do
   L := [seq(seq([op(u),j],j=0..p-1),u in L)];
  od:

  f := proc(u)
   local i,j,k,g;
   g := Matrix(n,n);
   for k from 1 to n do g[k,k] := 1; od:
   k := 1;
   for i from 1 to n do
    for j from i+1 to n do
     g[i,j] := mods(u[k],p); k := k + 1;
    od:
   od:
   return g;
  end:

  G["elements"] := map(f,L);

  return eval(G);
end:


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

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

$include "mgga_x_ms.mpl"

(* eq (5) in the paper *)
msb_beta := (t, x) -> ms_alpha(t, x)*K_FACTOR_C/(t + K_FACTOR_C):

(* eq (14) in the supplement *)
msb_fa := b -> (1 - (2*b)^2)^3 / (1 + (2*b)^3 + params_a_b*(2*b)^6):

msb_f := (x, u, t) -> ms_f0(X2S^2*x^2, 0) + \
  msb_fa(msb_beta(t,x))*(ms_f0(X2S^2*x^2, params_a_c) - ms_f0(X2S^2*x^2, 0)):

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


############################################################
# Generic conformal 3 metric for BSSN in spherical symmetry
# See: BSSN_Spher.mw or BSSN_Spher.mpl
############################################################

Ndim_ := 3:
x1_ := x:
x2_ := theta:
x3_ := phi:
complex_ := {}:
g11_ := (A(t,x)):
g12_ := 0:
g13_ := 0:
g22_ := x^2*(B(t,x)):
g23_ := 0:
g33_ := x^2*(B(t,x))*(sin(theta))^2:


# Velocity Calculation for the Robot based on MDH frames
# Introduction
# Berechnung der Geschwindigkeit von Koordinatensystemen und Schwerpunkten
#
# Dateiname:
# robot -> Berechnung für allgemeinen Roboter
# tree -> Berechnung für eine beliebige Baumstruktur (ohne Schleifen)
# floatb_twist -> floating base wird durch base twist (Geschwindigkeit der Basis) berücksichtigt
# rotmat -> Kinematik wird mit Rotationsmatrizen berechnet
# velocity -> Berechnung der Geschwindigkeit aller Segmente
# linkframe -> Berechnung der Geschwindigkeit im Körper-KS (KSi)
# 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":
printf("%s. Generiere Geschwindigkeit für %s (Herleitung im Körper-KS)\n", FormatTime("%Y-%m-%d %H:%M:%S"), robot_name):
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: # nur zum Abschätzen der Komplexität
;
# Term-Vereinfachungen einstellen
if not assigned(simplify_options) or simplify_options(4)=-1 then # Standard-Einstellungen:
  if not kin_constraints_exist then # normale serielle Ketten und Baumstrukturen
    use_simplify := 0: # Standardmäßig aus
  else # mit kinematischen Zwangsbedingungen
    use_simplify := 1: # standardmäßig simplify-Befehle anwenden
  end if:
else # Benutzer-Einstellungen:
  use_simplify := simplify_options(4): # vierter Eintrag ist für Geschwindigkeit
end if:

# Ergebnisse der Kinematik laden
read sprintf("../codeexport/%s/tmp/kinematics_floatb_%s_rotmat_maple.m", robot_name, base_method_name):
Trf := Trf:
Trf_c := Trf_c:
# Zeitableitungen der MDH-Drehwinkel laden.
# Die Berechnung soll nur an einer Stelle erfolgen. Siehe robot_tree_velocity_mdh_angles.mw.
read sprintf("../codeexport/%s/tmp/velocity_mdh_angles_maple.m", robot_name):
thetaD := thetaD:

# Calculate Velocities
# First assume fixed base model with base velocity and acceleration set to zero
# Anfangsgeschwindigkeit definieren für floating base model
# Velocities of Frames
#
# Analog zu [Ortmaier2014], Gl. (7.6)
# Geschwindigkeit der Basis der Koordinatensysteme der Körper (ausgedrückt im Körper-KS)
rD_i_i := Matrix(3, NL):
# Winkelgeschwindigkeit von Körper i ausgedrückt im Körper-KS
omega_i_i := Matrix(3, NL):
# Anfangsgeschwindigkeit der Basis:
# twist: Basis-Geschwindigkeit bzgl Welt-KS ausgedrückt im Basis-KS
# eulxyz: V_base_t beinhaltet die Geschwindigkeit der Basis im Welt-KS, ausgedrückt im Welt-KS. Daher ist für eine Darstellung im Körper-KS noch die Rotation erforderlich.
if base_method_name = "twist" then:
  rD_i_i(1..3,1) := V_base_t(1..3,1):
  omega_i_i(1..3,1) := V_base_t(4..6,1):
end:
if base_method_name = "eulxyz" then:
  rD_i_i(1..3,1) := Transpose(Trf_c(1..3, 1..3, 1)) . V_base_t(1..3,1):
  omega_i_i(1..3,1) := Transpose(Trf_c(1..3, 1..3, 1)) . T_basevel . V_base_t(4..6,1):
end:
# Erhöhe die Geschwindigkeit jedes Körpers
# Betrachte dazu nur die durch Gelenke angetriebenen Körper, nicht die Basis
for i from 1 to NJ do # Gelenke durchgehen
  # Körper der von Gelenkwinkel i bewegt wird: Körperindex i+1
  # Vorgängerkörper bestimmen
  j := v(i) + 1:
  # Geschwindigkeit des Vorgängers; Trf_c(...,i+1) enthält z-Achse des Körperkoordinatensystems, das von qi bewegt wird.
  # [Ortmaier2014] (7.7) (S.115) (dort falsche Indizes für MDH), [KhalilDombre2002] (9.14)
  R_j_i := Trf(1..3,1..3,i): # Rotation vom Vorgänger-Körper (j) zu diesem Körper (i+1)
  R_i_j := Transpose(R_j_i):
  # [GautierKhalil1988], equ.7: omega_jj aus [GautierKhalil1988] entspricht omega_i_i(1 .. 3, i+1) hier
  if sigma(i) = 0 then # Drehgelenk
    omega_i_i(1 .. 3, i+1) := Multiply(R_i_j,Matrix(3,1,omega_i_i(1 .. 3, j))) + thetaD(i,1)*<0;0;1>:
  else: # Schubgelenk
    omega_i_i(1 .. 3, i+1) := Multiply(R_i_j,Matrix(3,1,omega_i_i(1 .. 3, j)))
  end if:
  # Terme vereinfachen (Teil 1)
  if use_simplify>=1 then
    tmp_t11:=time():
    tmp_l11 := length(omega_i_i(1 .. 3, i+1)):
    omega_i_i(1 .. 3, i+1) := simplify2(omega_i_i(1 .. 3, i+1)):
    tmp_l21 := length(omega_i_i(1 .. 3, i+1)):
    tmp_t21:=time():
  end if:
  # Vektor vom Ursprung des vorherigen Koordinatensystems zu diesem KS
  r_j_j_i := Trf(1 .. 3, 4, i):
  # [GautierKhalil1988], equ.8: v_jj aus [GautierKhalil1988] entspricht rD_i_i(1 .. 3, i+1) hier
  if sigma(i) = 0 then # Drehgelenk
    rD_i_i(1 .. 3, i+1) := Multiply( R_i_j, ( rD_i_i(1 .. 3, j) + CrossProduct(omega_i_i(1 .. 3, j), r_j_j_i) ) ):
  else: # Schubgelenk
    rD_i_i(1 .. 3, i+1) := Matrix(Multiply( R_i_j, ( rD_i_i(1 .. 3, j) + CrossProduct(omega_i_i(1 .. 3, j), r_j_j_i) ) ) ) + Matrix(dD(i,1)*<0;0;1>):
  end if:
  printf("%s. Geschwindigkeit für Körperkoordinatensystem %d aufgestellt (Herleitung im Körper-KS).\n", \
     FormatTime("%Y-%m-%d %H:%M:%S"), i-1): #0=Basis
  # Terme vereinfachen (Teil 2)
  if use_simplify>=1 then
    tmp_t12:=time():
    tmp_l12 := length(rD_i_i(1 .. 3, i+1)):
    rD_i_i(1 .. 3, i+1) := simplify2(rD_i_i(1 .. 3, i+1)):
    tmp_l22 := length(rD_i_i(1 .. 3, i+1)):
    tmp_t22:=time():
    printf("%s: Terme für Geschwindigkeiten vereinfacht. Länge: %d->%d / %d->%d. Rechenzeit %1.1fs und %1.1fs.\n", \
      FormatTime("%Y-%m-%d %H:%M:%S"), tmp_l11, tmp_l21, tmp_l12, tmp_l22, tmp_t21-tmp_t11, tmp_t22-tmp_t12):
  end if:
end do:
# Export
# Maple Export
save omega_i_i, rD_i_i, sprintf("../codeexport/%s/tmp/velocity_linkframe_floatb_%s_maple.m", robot_name, base_method_name):
printf("%s. Maple-Ausdrücke exportiert.\n", FormatTime("%Y-%m-%d %H:%M:%S")):

# Matlab Export
if codegen_act then
  MatlabExport(convert_t_s(omega_i_i), sprintf("../codeexport/%s/tmp/velocity_omegaii_floatb_%s_linkframe_matlab.m", robot_name, base_method_name), codegen_opt):
  MatlabExport(convert_t_s(rD_i_i), sprintf("../codeexport/%s/tmp/velocity_rDii_floatb_%s_linkframe_matlab.m", robot_name, base_method_name), codegen_opt):
  printf("%s. Geschwindigkeiten in Matlab exportiert.\n", FormatTime("%Y-%m-%d %H:%M:%S")):
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: gga_exc *)

$define xc_dimensions_2d

_2d_pbe_kappa := 0.4604:
_2d_pbe_mu    := 0.354546875:

_2d_pbe_f0 := s -> 1 + _2d_pbe_kappa*(1 - _2d_pbe_kappa/(_2d_pbe_kappa + _2d_pbe_mu*s^2)):
_2d_pbe_f  := x -> _2d_pbe_f0(X2S_2D*x):

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

$define gga_x_b88_params
$include "gga_x_b88.mpl"
$include "lda_x_erf.mpl"

ityh_enhancement := xs -> b88_f(xs):
ityh_attenuation := a  -> attenuation_erf(a):

ityh_k_GGA := (rs, z, xs) -> sqrt(9*Pi/(2*X_FACTOR_C*ityh_enhancement(xs))) * n_spin(rs, z)^(1/3):
ityh_f_aa  := (rs, z, xs) -> ityh_attenuation(p_a_hyb_omega_0_/(2*ityh_k_GGA(rs, z, xs))):

ityh_f := (rs, z, xs) -> ityh_f_aa(rs, z, xs) * ityh_enhancement(xs):

f := (rs, zeta, xt, xs0, xs1) -> gga_exchange_nsp(ityh_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/.
*)

(* One should be able to simplify this by evaluating explicitly the Stoll
   decomposition of the exchange functional *)

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

b97mv_ux    := (mgamma, x) -> mgamma*x^2/(1 + mgamma*x^2):

(* article uses t = 2 tau convention *)
b97mv_wx_ss := (t, dummy) -> (K_FACTOR_C - t)/(K_FACTOR_C + t):
b97mv_wx_os := (ts0, ts1) -> (K_FACTOR_C*(ts0 + ts1) - 2*ts0*ts1)/(K_FACTOR_C*(ts0 + ts1) + 2*ts0*ts1):

b97mv_g := (mgamma, wx, cc, n, xs, ts0, ts1) ->
  add(cc[i][1]*wx(ts0, ts1)^cc[i][2]*b97mv_ux(mgamma, xs)^cc[i][3], i=1..n):

b97mv_fpar  := (rs, z, xs0, xs1, ts0, ts1) ->
  + lda_stoll_par(f_pw    , rs,  z,  1) * b97mv_g(b97mv_gamma_ss, b97mv_wx_ss, b97mv_par_ss, b97mv_par_n, xs0, ts0, 0)
  + lda_stoll_par(f_pw    , rs, -z, -1) * b97mv_g(b97mv_gamma_ss, b97mv_wx_ss, b97mv_par_ss, b97mv_par_n, xs1, ts1, 0):

b97mv_fos := (rs, z, xs0, xs1, ts0, ts1) ->
  lda_stoll_perp(f_pw, rs, z)
  * b97mv_g(b97mv_gamma_os, b97mv_wx_os, b97mv_par_os, b97mv_par_n, sqrt(xs0^2 + xs1^2)/sqrt(2), ts0, ts1):

b97mv_f :=  (rs, z, xs0, xs1, ts0, ts1) ->
  + b97mv_fpar(rs, z, xs0, xs1, ts0, ts1)
  + b97mv_fos(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: gga_exc *)

$include "gga_x_ityh.mpl"

ityh_attenuation := a  -> attenuation_yukawa(a):


(*
 Copyright (C) 2020 Susi Lehtola

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

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

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

csk_p := x -> X2S^2*x^2:
csk_q := u -> X2S^2*u:

(* Equation (21) *)
csk_z  := (p, q) -> 20/9*q - 40/27*p:

(* Equation (22) *)
csk_f0 := (p, q, z) ->  1 + 5*p/3 + z*csk_I(z):

(*
   The function I(z) contains exp(-1/|z|^a) which is numerically
   challenging for small |z|. Because of this, we truncate the term
   close to z=0 for negative z, since I(z) -> 1 for small |z|.
   For positive z, I(z)=1 identically, because of the step function.
*)
csk_I_negz := z -> (1 - exp(-1/abs(z)^params_a_csk_a))^(1/params_a_csk_a):
csk_I_cutoff_small := (-log(DBL_EPSILON))^(-1/params_a_csk_a):
csk_I_cutoff_large := (-log(1 - DBL_EPSILON))^(-1/params_a_csk_a):

csk_I := z -> my_piecewise5(
      z < -csk_I_cutoff_large, 0,
      z > -csk_I_cutoff_small, 1,
      csk_I_negz(m_max(m_min(z, -csk_I_cutoff_small), -csk_I_cutoff_large))
  ):

csk_f := (x, u) ->
  csk_f0(csk_p(x), csk_q(u), csk_z(csk_p(x), csk_q(u))):

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


function mandel_calc(a)
    z = 0
    for i in 1:100
        z = z^2 + a
    end
    return z
end

function mandelbrot()
    "starting mandelbrot"
    for i in 0:30
    	y = 0.066666*i - 1
	s = ""
	for j in 0:78
	    x = 0.0315*j - 2
	    if abs(mandel_calc((x, y))) < 2 then
	        s = s + "*"
	    else
	        s = s + " "
	    end
	end
	s
    end
end

mandelbrot()


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

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

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

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

lyp_Cf := 3/10 * (3*Pi^2)^(2/3):

lyp_omega := rr -> params_a_b*exp(-params_a_c*rr)/(1 + params_a_d*rr):
lyp_delta := rr -> (params_a_c + params_a_d/(1 + params_a_d*rr))*rr:

lyp_aux6 := 1/2^(8/3):
lyp_aux4 := lyp_aux6/4:
lyp_aux5 := lyp_aux4/(9*2):

lyp_t1 := (rr, z) ->
  -(1 - z^2)/(1 + params_a_d*rr):
lyp_t2 := (rr, z, xt) ->
  -xt^2*((1 - z^2)*(47 - 7*lyp_delta(rr))/(4*18) - 2/3):
lyp_t3 := (z) ->
  -lyp_Cf/2*(1 - z^2)*(opz_pow_n(z,8/3) + opz_pow_n(-z,8/3)):
lyp_t4 := (rr, z, xs0, xs1) ->
  lyp_aux4*(1 - z^2)*(5/2 - lyp_delta(rr)/18)*(xs0^2*opz_pow_n(z,8/3) + xs1^2*opz_pow_n(-z,8/3)):
lyp_t5 := (rr, z, xs0, xs1) ->
  lyp_aux5*(1 - z^2)*(lyp_delta(rr) - 11)*(xs0^2*opz_pow_n(z,11/3) + xs1^2*opz_pow_n(-z,11/3)):
lyp_t6 := (z, xs0, xs1) ->
  -lyp_aux6*(2/3*(xs0^2*opz_pow_n(z,8/3) + xs1^2*opz_pow_n(-z,8/3))
  -opz_pow_n(z,2)*xs1^2*opz_pow_n(-z,8/3)/4 - opz_pow_n(-z,2)*xs0^2*opz_pow_n(z,8/3)/4):

f_lyp_rr := (rr, z, xt, xs0, xs1) -> params_a_a*(lyp_t1(rr, z) + lyp_omega(rr)*(
  + lyp_t2(rr, z, xt) + lyp_t3(z) + lyp_t4(rr, z, xs0, xs1)
  + lyp_t5(rr, z, xs0, xs1) + lyp_t6(z, xs0, xs1)
)):

(* rr = rs/RS_FACTOR is equal to n_total(rs)^(-1/3) *)
f_lyp := (rs, z, xt, xs0, xs1) -> f_lyp_rr(rs/RS_FACTOR, z, xt, xs0, xs1):

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


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

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

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

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

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

mbeta  := 15.75592*0.004235: (* the usual value of 0.066726 *)
malpha := mbeta/(16*2^(2/3)):

sogga11_yy := (rs, z, xt) -> -malpha*mphi(z)*xt^2/(rs*f_pw(rs, z)):

sogga11_f0 := (rs, z, xt) -> 1 - 1/(1 + sogga11_yy(rs, z, xt)):
sogga11_f1 := (rs, z, xt) -> 1 - exp(-sogga11_yy(rs, z, xt)):

sogga11_t0 := (rs, z, xt) -> add(params_a_sogga11_a[i]*sogga11_f0(rs, z, xt)^(i-1), i=1..6):
sogga11_t1 := (rs, z, xt) -> add(params_a_sogga11_b[i]*sogga11_f1(rs, z, xt)^(i-1), i=1..6):

sogga11_f := (rs, z, xt, xs0, xs1) ->
  f_pw(rs, z)*(sogga11_t0(rs, z, xt) + sogga11_t1(rs, z, xt)):

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


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

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

(* type: gga_exc *)

C0 := (1 - log(2))/(2*Pi^2): (* Equation (9) *)
C1 := 4*C0/3:                (* Equations (13), (28), (33) *)
C2 := RS_FACTOR:             (* Equation (8) *)
C3 := C2/3:

(* several cutoffs *)
big     := 1.0e4:
cutoff  := 1.0e7:
ei_xmax := 7.0183341467e+02:

(* Equation (39) *)
kssp0_k0 := 1.291551074:
kssp0_k1 := 0.349064173:
kssp0_r1 := 0.08327588:

kssp0 := rs ->
  kssp0_k0 - kssp0_k1*(1 - exp(-kssp0_r1*rs^(4/5))):

(* Equation (45) *)
fssp_A1 := 1.622118767:
fssp_A2 := 0.489958076:
fssp_A3 := 1.379021941:

fssp := (rs, gr) ->
  (1 + fssp_A1*gr + fssp_A2^2*gr^2)*exp(-fssp_A2^2*gr^2)/sqrt(1 + fssp_A3*gr/rs):

(* Equation (34) *)
fa_a1 := 0.939016:
fa_a2 := 1.733170:

f_factor := rs -> exp(-rs^2/(fa_a1*sqrt(rs) + fa_a2*rs)^2):

(* Equation (40) *)
kss0_k0 :=  1.200801774:
kss0_k1 :=  0.859614445:
kss0_k2 := -0.812904345:
kss0_r1 :=  1.089338848:
kss0_r2 :=  0.655638823:

kss0 := (rs, gr) ->
  + kss0_k0
  + kss0_k1*(1 - exp(-kss0_r1*sqrt(rs)))
  + kss0_k2*(1 - exp(-kss0_r2*rs^(2/5))):

fss_A4 := 4.946281353:
fss_A5 := 3.600612059:

fss := (rs, gr) ->
  (1 + fss_A4^2*gr^2)*exp(-fss_A4^2*gr^2)/sqrt(1 + fss_A5*gr/rs):

(* Equation (15) *)
eq15 := mu -> (3 + 2*(sqrt(mu) + mu))/(3 + 6*(sqrt(mu) + mu)):

f_eab := mu ->
  C0*(-xc_E1_scaled(mu)*(1 + 2*mu*eq15(mu)) + 2*eq15(mu)):

(* Equation (13) *)
(*
   This is numerically suboptimal - the max function cuts off f_eab to
   around 10^-6. This is too large. The other possibility that was used
   before in the code was to put term to zero if mu > ei_xmax
*)
mu_ba := (rsa, ga2) -> C1*rsa/m_max(kssp0(rsa)^2*fssp(rsa, ga2)^2, 1e-60):
term1 := (rsa, z, ga2) -> my_piecewise3(mu_ba(rsa, ga2) >= cutoff, 0,
  f_eab(mu_ba(rsa, ga2))*(1 - z)/2):

mu_aa := (rsa, ga2) -> C1*rsa/m_max(kss0(rsa)^2*fss(rsa, ga2)^2, 1e-60):
term2 := (rsa, z, ga2) -> my_piecewise3(mu_aa(rsa, ga2) >= cutoff, 0,
  f_eab(mu_aa(rsa, ga2))*f_factor(rsa)*(1 + z)/2):

f_ft97 := (rs, z, xs) ->
  + term1(rs*(2/(1 + z))^(1/3), z, C3^2*xs^2)
  + term2(rs*(2/(1 + z))^(1/3), z, C3^2*xs^2):

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


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

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

(* type: mgga_exc *)

zlp_c := 0.828432   *RS_FACTOR:
zlp_d := 2.15509e-2 *RS_FACTOR:
zlp_k := 2.047107e-3*RS_FACTOR:

zlp_f := (rs, z, xt, us0, us1) ->
  - (zlp_c + zlp_d*t_vw(z, xt, us0, us1))
  * (1 - zlp_k*log(1 + rs/zlp_k)/rs)/rs:

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


######################################################################
# subsets(A) is the set of all subsets of A

`is_element/subsets` := (A::set) -> proc(B)
 type(B,set) and B minus A = {};
end;

`is_equal/subsets` := (A::set) -> (B,C) -> evalb(B = C):

`is_leq/subsets` := (A::set) -> (B,C) -> evalb(B minus C = {}):

`random_element/subsets` := (A::set) -> proc()
 local r,B,a;
 r := rand(2);

 B := select(a -> (r() = 1),A);

 return B;
end;

`list_elements/subsets` := (A::set) ->
 sort(map(sort,[op(combinat[powerset](A))])):

`count_elements/subsets` := (A::set) -> 2^nops(A);

`functor/subsets` := (A::set,B::set) -> (f) -> proc(T)
 map(t -> f[t],T);
end:

`cofunctor/subsets` := (A::set,B::set) -> (f) -> proc(T)
 select(a -> member(f[a],T),A);
end:


######################################################################
# Partitions of the set {1,...,n} into intervals

`is_element/interval_partitions` := (n::posint) -> proc(pi)
 local A,U,i;
 global reason;

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

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

 for U in pi do
  if not(`is_element/posint_intervals`(U)) then
   reason := [convert(procname,string),"U is not a posint interval",U];
   return false;
  fi;
 od;

 return true;
end:

`is_equal/interval_partitions` := (n::posint) -> proc(pi,rho)
 local A,i;

 A := {seq(i,i=1..n)};
 return `is_equal/partitions`(A)(pi,rho);
end:

`is_leq/interval_partitions` := (n::posint) -> proc(pi,rho)
 local A,i;

 A := {seq(i,i=1..n)};
 return `is_leq/partitions`(A)(pi,rho);
end:

# Given an integer n > 0 and a subset C of {1/2,3/2,...,(2n-1)/2}, this
# returns the partition of {1,...,n} obtained by cutting at the points
# of C.

`cut_partition` := proc(n::posint,C)
 local m,C0,C1,i,j;

 m := 1 + nops(C);
 C0 := sort([1,op(map(c->c+1/2,C))]);
 C1 := sort([op(map(c->c-1/2,C)),n]);
 return {seq({seq(j,j=C0[i]..C1[i])},i=1..m)};
end;

`random_element/interval_partitions` := (n::posint) -> proc()
 local C,i;

 C := `random_element/subsets`({seq(i+1/2,i=1..n-1)})();
 return cut_partition(n,C);
end;

`list_elements/interval_partitions` := proc(n)
 local G,P,i;

 G := {seq(i+1/2,i=1..n-1)};
 P := `list_elements/subsets`(G);
 return map(C -> cut_partition(n,C),P);
end;

`count_elements/interval_partitions` := (n) -> 2^(n-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: lda_exc *)
(* prefix:
  lda_k_gds08_params *params;

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

gds08_fs := (rs, z) -> (1 + z)/2 *(
  + params_a_A
  + params_a_B*log(2*n_spin(rs, z))
  + params_a_C*log(2*n_spin(rs, z))^2
):

# Eq. (12)
gds08_f := (rs, z) ->
  + my_piecewise3(screen_dens(rs,  z), 0, gds08_fs(rs, z_thr( z)))
  + my_piecewise3(screen_dens(rs, -z), 0, gds08_fs(rs, z_thr(-z))):

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


klein_embedding := (x) ->
[(0.1*sin(3*Pi*x[1])+0.1*sin(Pi*x[1])+0.4*cos(Pi*x[1]))*sin(2*Pi*x[2])-0.5*sin(4*Pi*x[1])+sin(2*Pi*x[1]),
  0.2*sin(2*Pi*x[2])*sin(3*Pi*x[1])+2.*cos(2*Pi*x[1])+0.5,
  0.25*cos(2*Pi*x[2])*sin(2*Pi*x[1])+0.4*cos(2*Pi*x[2])];


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

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

(* type: work_mgga_x *)
(* prefix:
  mgga_x_ms_params *params;

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

fa := a -> (1 - a^2)^3 / (1 + a^3 + params_a_b*a^6):
f0 := (p, c) -> 1 + params_a_kappa*(1 - params_a_kappa/(params_a_kappa + MU_GE*p + c)):

f := (rs, x, t, u) -> f0(X2S^2*x^2, 0) + \
  fa((t - x^2/8)/K_FACTOR_C)*(f0(X2S^2*x^2, params_a_c) - f0(X2S^2*x^2, 0)):


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

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

$include "gga_x_vmt.mpl"

vmt84_f0 := s -> (1 - exp(-params_a_alpha*s^4))/s^2 - 1 + exp(-params_a_alpha*s^4):
vmt84_f  := x -> vmt_f(x) + vmt84_f0(X2S*x):

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