Digits := 120:

interface(quiet=true):

read "common-procedures.mpl":
read "triple-double.mpl":

#---------------------------------------------------------------------
# Procedure gal computes a number x and a boolean such that
#
# if the boolean is true
# - |x - xstart| is minimal
# - x = roundX(x) (x is a floating point number in format roundX)
# - |(roundY(f(x)) - f(x)) / f(x)| <= eps
#
# and the boolean is false if no such x could be found in iter iterations
#
# Limitations:
#
# - floating point numbers xp such that f(xp) = 0 are not considered
#
# Uses:
#
# - The successor function succX for floating point numbers roundX(t)

gal:=proc(xstart,roundX,f,roundY,epsi,succX,iter)
local xleft, xright, i, err, ima, d, x, eps, b;
d := Digits;
Digits := 120;
eps := abs(epsi);
xleft := roundX(xstart);
xright := roundX(succX(roundX(xstart)));
x := 0;
i := 0;
err := eps * 2;
while ((err > eps) and (i < iter)) do
	i := i + 1;
	if (type(i,odd)) then
		x := xright;
		xright := evalf(roundX(succX(roundX(xright))));
	else
		x := xleft;
		xleft := evalf(roundX(-succX(roundX(-xleft))));
	end if;
	ima := evalf(f(x));
	if (ima <> 0) then
		err := evalf(abs((ima - roundY(ima))/ima));
	end if;
end do;
b := false;
if (i < iter) then b := true; end if;
Digits := d;
(x,b);
end proc:

galDoubleToDouble:=proc(xstart,f,epsi,iter)
local g,b,xn;
(g,b) := gal(xstart,nearest,f,nearest,epsi,succDouble,iter);
if (b) then xn := g; else xn = xstart; end if;
xn;
end proc:

galDoubleToDoubleDouble:=proc(xstart,f,epsi,iter)
local g,b,xn;
(g,b) := gal(xstart,nearest,f,nearestDD,epsi,succDouble,iter);
if (b) then xn := g; else xn = xstart; end if;
xn;
end proc:


(* type: work_lda *)

a :=  0.0311:
b := -0.048:
c :=  0.009:
d := -0.017:

f_ls := (rs, zeta) -> a*log(rs) + b + c*rs*log(rs) + d*rs:
f_ms := (rs, zeta) -> -0.06156 + 0.01898*log(rs):
f_hs := (rs, zeta) -> 0.438/rs + 1.325/rs^(3/2) - 1.47/rs^2 - 0.4/rs^(5/2):

f := (rs, zeta) -> convert(piecewise(
  rs < 0.7, f_ls(rs, zeta),
  rs < 10,  f_ms(rs, zeta),
  f_hs(rs, zeta)), 'Heaviside'):


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

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

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

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

$define lda_c_pz_params
$include "lda_c_pz.mpl"

(* Equation (4) *)
p86_DD := z  -> sqrt(opz_pow_n(z,5/3) + opz_pow_n(-z,5/3))/sqrt(2):

(* Equation (6) *)
p86_CC := rs ->
  + params_a_aa
  + (params_a_bb + params_a_malpha*rs + params_a_mbeta*rs^2)/(1 + params_a_mgamma*rs + params_a_mdelta*rs^2 + 1.0e4*params_a_mbeta*rs^3):
p86_CCinf := params_a_aa + params_a_bb:

(* Equation (9) *)
p86_x1   := (rs, xt) -> xt/sqrt(rs/RS_FACTOR):
p86_mPhi := (rs, xt) -> params_a_ftilde*(p86_CCinf/p86_CC(rs))*p86_x1(rs, xt):

(* Equation (8) *)
p86_H := (rs, z, xt) -> p86_x1(rs, xt)^2*exp(-p86_mPhi(rs, xt))*p86_CC(rs)/p86_DD(z):

f_p86 := (rs, z, xt, xs0, xs1) ->
  f_pz(rs, z) + p86_H(rs, z, xt):

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


read "common-procedures.mpl":

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

#---------------------------------------------------------------------
# same as hi_mi_lo, but returns hexadecimal strings
ieeehexa3:=proc(x)
local x_hi, x_mi, x_lo;
  x_hi, x_mi, x_lo := hi_mi_lo(x):
  ieeehexa(x_hi), ieeehexa(x_mi), ieeehexa(x_lo):
end proc:

#---------------------------------------------------------------------
#Like poly_exact, but the first n coefficients as triple doubles,
#the next m coefiicients as double doubles and the rest as doubles
#
poly_exact32:=proc(P,n,m)
local deg,i, coef, coef_hi, coef_mi, coef_lo, Q:
Q:= 0:
convert(Q, polynom):
deg:=degree(P,x):
  for i from 0 to deg do
    coef :=coeff(P,x,i):
    coef_hi, coef_mi, coef_lo:=hi_mi_lo(coef):
    Q:= Q + coef_hi*x^i:
    if(i<m+n) then
        Q := Q + coef_mi*x^i:
    fi:
    if(i<n) then
	Q := Q + coef_lo*x^i:
    fi:
  od:
  return(Q):
end:

#---------------------------------------------------------------------
# Returns nearest double-double:
nearestDD := proc(x)
  local xh,xm:
  xh := nearest(x);
  xm := nearest(x - xh);
  evalf(xh + xm);
end:

#---------------------------------------------------------------------
# Returns nearest triple-double:
nearestTD := proc(x)
  local xh,xm,xl:
  xh := nearest(x);
  xm := nearest(x - xh);
  xl := nearest(x - (xh + xm));
  evalf(xh + xm + xl);
end:


# Example from Section 5.1 of the paper

read "../ComputeIdentifiableFunctions.mpl";

model := [
    diff(x1(t), t) = (a * x1(t) - b * x1(t) * x2(t)),
    diff(x2(t), t) = (-c * x2(t) + d * x1(t) * x2(t) + e * u(t)),
    y(t) = x1(t)
]:

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

me := MultiExperimentIdentifiableFunctions(model, simplified_generators=true):
printf("The bound for the number of experiments is %a, this means that the field of multi-experiment identifiable functions is the same, %a\n", me[1], me[3]):


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

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

(* type: work_gga_x *)
(* prefix:
  gga_x_vmt_params *params;

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

f0_vmt := s -> 1 + params_a_mu*s^2*exp(-params_a_alpha*s^2)/(1 + params_a_mu*s^2):

f_vmt  := x -> f0_vmt(X2S*x):
f      := x -> f_vmt(x):


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

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

gvt4_gamm := (alpha, x, z) -> 1 + alpha*(x^2 + z):

gtv4 := (alpha, dd, x, z) ->
  dd[1]/gvt4_gamm(alpha, x, z) +
  (dd[2]*x^2 + dd[3]*z)/gvt4_gamm(alpha, x, z)^2 +
  (dd[4]*x^4 + dd[5]*x^2*z + dd[6]*z^2)/gvt4_gamm(alpha, x, z)^3:


(*
 Copyright (C) 2019 Susi Lehtola

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

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

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

$include "mgga_x_scan.mpl"

(* Coefficients of the rSCAN switching function from SI, in reversed(!) order: 7, 6, ..., 0 *)
rscan_fx := [-0.023185843322, 0.234528941479, -0.887998041597, 1.451297044490, -0.663086601049, -0.4445555, -0.667, 1]:

np53 := (rs, z) -> n_spin(rs,z)^(5/3):

(* First regularization: tau^u -> tau^u + tau_r.
   tau_r gets scaled by 2^(2/3) due to the spin scaling. *)
rscan_alpha0 := (rs, z, x, t) -> (np53(rs,z)*m_max(t - x^2/8, 0))/(np53(rs,z)*K_FACTOR_C + params_a_taur/2):

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

(* f(alpha) replaced with a polynomial for alpha in [0, 2.5] *)
rscan_f_alpha_small := (a, ff) -> add(ff[8-i]*a^i, i=0..7):
rscan_f_alpha_large := a -> -params_a_d*exp(params_a_c2/(1 - a)):
rscan_f_alpha := (a, ff) -> my_piecewise3(a <= 2.5, rscan_f_alpha_small(m_min(a, 2.5), ff), rscan_f_alpha_large(m_max(a, 2.5))):
rscan_f   := (rs, z, x, u, t) -> (scan_h1x(scan_y(x, rscan_alpha(rs, z, x, t)))*(1 - rscan_f_alpha(rscan_alpha(rs, z, x, t), rscan_fx))
  + scan_h0x*rscan_f_alpha(rscan_alpha(rs, z, x, t), rscan_fx))*scan_gx(x):

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


make_icosahedron_complex := proc()
 global icosahedron_complex,dodecahedron_complex;
 local IC,DC,tau,vI,vD,i;

 IC := table():
 DC := table():

 IC["vertices"] := [seq(i,i=1..12)];
 DC["vertices"] := [seq(i,i=1..20)];

 IC["faces"] := [
  [ 1, 2, 9], [ 1, 2,11], [ 1, 5, 6], [ 1, 5, 9], [ 1, 6,11],
  [ 2, 7, 8], [ 2, 7, 9], [ 2, 8,11], [ 3, 4,10], [ 3, 4,12],
  [ 3, 5, 6], [ 3, 5,10], [ 3, 6,12], [ 4, 7, 8], [ 4, 7,10],
  [ 4, 8,12], [ 5, 9,10], [ 6,11,12], [ 7, 9,10], [ 8,11,12]
 ];

 IC["edges"] := {op(map(op,map(f -> [[f[1],f[2]],[f[1],f[3]],[f[2],f[3]]],IC["faces"])))};
 IC["edges"] := sort([op(IC["edges"])]);

 IC["max_simplices"] := IC["faces"];

 tau := (1+sqrt(5))/2;

 IC["embedding_dim"] := 3;

 vI := table([
   1 = [   0,   1, tau],
   2 = [   0,  -1, tau],
   3 = [   0,   1,-tau],
   4 = [   0,  -1,-tau],
   5 = [   1, tau,   0],
   6 = [  -1, tau,   0],
   7 = [   1,-tau,   0],
   8 = [  -1,-tau,   0],
   9 = [ tau,   0,   1],
  10 = [ tau,   0,  -1],
  11 = [-tau,   0,   1],
  12 = [-tau,   0,  -1]
 ]):

 for i from 1 to 12 do vI[i] := simplify(rationalize(vI[i] /~ tau^2)); od;

 IC["embedding"] := eval(vI);
 IC["normalised_embedding"] := table([
  seq(i = evalf(vI[i] /~ sqrt(5-2*sqrt(5))),i = 1..12)
 ]);

 IC["edge_centres"] :=
  map(e -> (vI[e[1]] +~ vI[e[2]]) /~ 2,IC["edges"]);

 IC["face_centres"] :=
  map(f -> (vI[f[1]] +~ vI[f[2]] +~ vI[f[3]]) /~ 3, IC["faces"]);

 `plot/simplicial_complex`(IC);

 icosahedron_complex := eval(IC);
 dodecahedron_complex := eval(DC);
 return eval(IC);
end:

make_icosahedron_complex():

icosphere_complex := proc(n::nonnegint)
 local T,T0,E,v,x,i,j;

 T := eval(icosahedron_complex);

 for i from 1 to n do
  T0 := eval(T);
  T := eval(`triangular_subdivision/simplicial_complex`(T0));
  T0 := eval(T);
  T := eval(`condense/simplicial_complex`(T0));
  E := T["embedding"];
  for v in T["vertices"] do
   x := E[v];
   x := evalf(x /~ sqrt(add(x[j]^2,j=1..3)));
   E[v] := x;
  od:
 od:

 return eval(T):
end:


`is_element/Xi/generic` := (gen_name,el_test) -> (A::set) -> (TT) -> proc(m)
 global reason;
 local pn,TT1,C,T;

 pn := cat("is_element/Phi/",gen_name);
 TT1 := `big_sets/trees`(A)(TT);

 if not is_table_on(TT1,m) then
  reason := [pn,"m is not a table on TT1",m,TT1];
  return false;
 fi;

 C := children_map(A)(TT);

 for T in TT1 do
  if not(el_test(C[T])(m[T])) then
   reason := [pn,"m[T] is not in M(C[T])",m[T],T,C[T]];
   return false;
  fi;
 od;

 return true;
end:

# If E is a strongly reduced operad, then there are natural maps
# \theta : (\Xi E)(TT) -> (\Xi E)(UU) whenever TT and UU are full trees
# on the same set A with UU contained in TT.

`theta/Xi/generic` := (gen_name,eta,gamma) -> (A::set) -> (TT,UU) -> proc(x)
 local VV,CV,CT,X,Y,Z,T,P,Q,p,y,w;

 if TT = UU then return x; fi;

 T := (TT minus UU)[1];
 VV := TT minus {T};
 P := parent_map(A)(TT)[T];
 CT := children_map(A)(TT);
 CV := children_map(A)(VV);
 Y := CT[T];
 X := CV[P];
 Z := CT[P];
 p := table();
 for Q in X do
  p[Q] := `if`(member(Q,Y),T,Q);
 od;
 y := table();
 y[T] := x[T];
 for Q in X minus Y do
  y[Q] := eta({Q});
 od;

 w := gamma(X,Z)(p)(x[P],y);
 return `theta/Xi/generic`(gen_name,eta,gamma)(A)(VV,UU)(w);
end:


# Elliptic curves in Edwards form
# (This is rudimentary; there is a LaTeX file with much more material.)

`rels/edwards` := (a) -> proc(u)
 [-u[1]^2 + u[2]^2 - u[3]^2 + u[4]^2,a * u[2]*u[4] - u[1]*u[3]];
end:

`is_element/edwards_curve` := (a) -> proc(u)
 if not(`is_element/CP`(3)(u)) then return false; fi;
 return evalb(simplify(`rels/edwards`(a)(u)) = [0,0]);
end:


######################################################################
# Here B is assumed to be a subset of A, and SWW(A,B,N) is the space
# denoted by S(NWA,NWB) in the LaTeX document.

`is_element/SWW` := (N::posint) -> (A::set,B::set) -> proc(xy)
 local x,y,x0,y0,a,b,r;
 global reason;

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

 x,y := op(xy);
 if not(`is_element/SW`(N)(A)(x)) then
  reason := [convert(procname,string),"x is not in SW(N)(A)",x,N,A];
  return false;
 fi;

 if not(`is_element/SW`(N)(B)(y)) then
  reason := [convert(procname,string),"y is not in SW(N)(B)",y,N,B];
  return false;
 fi;

 x0 := table();
 for b in B do x0[b] := x[b]; od;
 x0 := `normalise/W`(N)(B)(x0);
 y0 := `normalise/SW`(N)(B)(y);

 r := 0;
 for b in B do r := max(r,op(map(abs,x0[b]))); od;
 if r = 0 then return true; fi;
 for b in B do
  if simplify(x0[b] -~ r *~ y0[b]) <> [0$N] then
   reason := [convert(procname,string),"x0 and y0 are incompatible at b",x0,y0,b,r];
   return false;
  fi;
 od;

 return true;
end;

`normalise/SWW` := (N::posint) -> (A::set,B::set) -> proc(xy)
 [`normalise/SW`(N)(A)(xy[1]),
  `normalise/SW`(N)(B)(xy[2])];
end;

`is_equal/SWW` := (N::posint) -> (A::set,B::set) -> proc(x,y)
 local p,q,r,s;
 global reason;

 p,q := op(`normalise/SWW`(N)(A,B)(x));
 r,s := op(`normalise/SWW`(N)(A,B)(y));

 if not `is_equal/SW`(N)(A)(p,r) then
  reason := [convert(procname,string),"p <> r",p,r,reason];
  return false;
 fi;

 if not `is_equal/SW`(N)(B)(q,s) then
  reason := [convert(procname,string),"q <> s",q,s,reason];
  return false;
 fi;

 return true;
end;

`is_leq/SWW` := NULL;

`random_element/SWW` := (N::posint) -> (A::set,B::set) -> proc()
 local x,y,b,u,c;

 x := `random_element/SW`(N)(A)();

 if rand(1..3)() = 1 then
  u := `random_element/R`(N)();

  for b in B do
   x[b] := u;
  od;
  y := `random_element/SW`(N)(B)();
 else
  y := `rho/W`(A,B)(x);
  if `is_zero/W`(N)(B)(y) then
   y := `random_element/SW`(N)(B)();
  fi;
 fi;

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

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


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

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

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

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

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

omega := rs -> params_a_B*exp(-params_a_c*rs)/(1 + params_a_d*rs):
delta := rs -> (params_a_c + params_a_d/(1 + params_a_d*rs))*rs:

aux6 := 1/2^(8/3):
aux4 := aux6/4:
aux5 := aux4/(9*2):

t1 := (rs, z) ->
  -(1 - z^2)/(1 + params_a_d*rs):
t2 := (rs, z, xt) ->
  -xt^2*((1 - z^2)*(47 - 7*delta(rs))/(4*18) - 2/3):
t3 := (z) ->
  -Cf/2*(1 - z^2)*((1 + z)^(8/3) + (1 - z)^(8/3)):
t4 := (rs, z, xs0, xs1) ->
  aux4*(1 - z^2)*(5/2 - delta(rs)/18)*(xs0^2*(1 + z)^(8/3) + xs1^2*(1 - z)^(8/3)):
t5 := (rs, z, xs0, xs1) ->
  aux5*(1 - z^2)*(delta(rs) - 11)*(xs0^2*(1 + z)^(11/3) + xs1^2*(1 - z)^(11/3)):
t6 := (z, xs0, xs1) ->
  -aux6*(2/3*(xs0^2*(1 + z)^(8/3) + xs1^2*(1 - z)^(8/3))
  -(1 + z)^2*xs1^2*(1 - z)^(8/3)/4 - (1 - z)^2*xs0^2*(1 + z)^(8/3)/4):

f_lyp := (rs, z, xt, xs0, xs1) -> params_a_A*(t1(rs/RS_FACTOR, z) + omega(rs/RS_FACTOR)*(
  + t2(rs/RS_FACTOR, z, xt) + t3(z) + t4(rs/RS_FACTOR, z, xs0, xs1)
  + t5(rs/RS_FACTOR, z, xs0, xs1) + t6(z, xs0, xs1)
)):

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


ctfm_expr :=  exp(x) - exp(lv) + 1/(1-x/rv) - 1/(1-lv/rv);
ctfmp_expr := ((diff(ctfm_expr,x)));
octfmp_expr := -(diff(1/ctfmp_expr,x));

ss:=eval(diff(ctfm_expr,x),{lv=-12,rv=3});
evalf(eval(ss,x=2))/evalf(eval(ss,x=-12));
tval_ctfm:=eval((ctfm_expr),{lv=-12,rv=3});
(evalf(eval(tval_ctfm,x=2)));
read ("/home/arman/FD/FD.mpl"):
MFD(); grid_functions:={};
Gen_Eval_Code(ctfm_expr,input="c",proc_name="init_ctfm");
Gen_Eval_Code(ctfmp_expr,input="c",proc_name="init_ctfmp");
Gen_Eval_Code(octfmp_expr,input="c",proc_name="init_octfmp");

grid_functions:={};
ctfm_expr :=  x/(1-x/rv);
ctfmp_expr := simplify(diff(ctfm_expr,x));
octfmp_expr := -simplify(diff(1/ctfmp_expr,x));
Gen_Eval_Code(ctfm_expr,input="c",proc_name="init_ctfm2");
Gen_Eval_Code(ctfmp_expr,input="c",proc_name="init_ctfmp2");
Gen_Eval_Code(octfmp_expr,input="c",proc_name="init_octfmp2");


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

a := -0.74860:
b :=  0.06001:
c :=  3.60073:
d :=  0.90000:

f_num := (z, xt) -> sqrt(1 - z^2)*(a + b*xt):
f_den := (rs, xs0, xs1) -> c + d*(xs0 + xs1) + rs:

f := (rs, zeta, xt, xs0, xs1) -> f_num(zeta, xt)/f_den(rs, xs0, xs1):


TITLE
    AircraftAlloc;

INDEX
    aircraft := (A,B,C,D);

STOCHASTIC

INDEP
    route := (NL1, NL2, ND0, ND1, NB0) -> (r1,r2,r3,r4,r5);

OUTCOME
   out5 := 1..5;

EVENT
    RouteOut[route,out5] :=
       (NL1, 1..5,
        NL2, 1..2,
        ND0, 1..5,
        ND1, 1..5,
        NB0, 1..3);

PROBABILITIES
    p[route, out5 IN RouteOut] :=
[NL1, 1, 0.2,
 NL1, 2, 0.05,
 NL1, 3, 0.35,
 NL1, 4, 0.2,
 NL1, 5, 0.2,
 NL2, 1, 0.3,
 NL2, 2, 0.7,
 ND0, 1, 0.1,
 ND0, 2, 0.2,
 ND0, 3, 0.4,
 ND0, 4, 0.2,
 ND0, 5, 0.1,
 ND1, 1, 0.2,
 ND1, 2, 0.2,
 ND1, 3, 0.3,
 ND1, 4, 0.2,
 ND1, 5, 0.1,
 NB0, 1, 0.1,
 NB0, 2, 0.8,
 NB0, 3, 0.1];

RANDOM DATA
    Demand[route, out5 IN RouteOut] :=
[NL1, 1, 200,
 NL1, 2, 220,
 NL1, 3, 250,
 NL1, 4, 270,
 NL1, 5, 300,
 NL2, 1,  50,
 NL2, 2, 150,
 ND0, 1, 140,
 ND0, 2, 160,
 ND0, 3, 180,
 ND0, 4, 200,
 ND0, 5, 220,
 ND1, 1,  10,
 ND1, 2,  50,
 ND1, 3,  80,
 ND1, 4, 100,
 ND1, 5, 340,
 NB0, 1, 580,
 NB0, 2, 600,
 NB0, 3, 620];

DATA
    AircraftAvail[aircraft] := (10, 19, 25, 15);
    !Demand[route]  := (250, 120, 180, 90, 600);
    PriceTicket[route] := (13, 13, 7, 7, 1);

    PotentialPass[aircraft, route]
       := (16, 15, 28, 23, 81,
             , 10, 14, 15, 57,
             ,  5,   ,  7, 29,
            9, 11, 22, 17, 55);

    MonthlyCost[aircraft, route]
       := (18, 21, 18, 16, 10,
             , 15, 16, 14,  9,
             , 10,   ,  9,  6,
           17, 16, 17, 15, 10);

DECISION VARIABLES
   Assign[aircraft, route]  -> x
      WHERE (PotentialPass > 0);

STAGE2 VARIABLES
   EmptySeats[route] -> y1;
   TurnedAway[route] -> y2;

MACRO
   OperatingCost := SUM(aircraft, route: MonthlyCost * Assign);
   LostRevenue   := SUM(route: PriceTicket * TurnedAway);

MODEL

    MIN TotalCost = OperatingCost + LostRevenue;

SUBJECT TO
   AircraftCap[aircraft]:
       SUM(route: Assign)
    <=
       AircraftAvail;

   PassBal[route]:
       SUM(aircraft: PotentialPass * Assign)
       + TurnedAway[route]
       - EmptySeats[route]
     =
       Demand[route];
END


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

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

(* type: mgga_exc *)

cs_a := -0.04918:
cs_b :=  0.132:
cs_c :=  0.2533/RS_FACTOR:
cs_d :=  0.349/RS_FACTOR:

cs_thf := (z, u, t) ->
  opz_pow_n(z,8/3)*2^(-8/3)*(t - u/8):

(* This is Equation (15) of Lee1988_785 *)
(* Note that gamma = (1 - z^2) *)
f_cs := (rs, z, xt, xs0, xs1, u0, u1, t0, t1) ->
  cs_a*(1 - z^2)/(1 + cs_d*rs) * (1 + 2*cs_b*exp(-cs_c*rs)*(
    cs_thf(z, u0, t0) + cs_thf(-z, u1, t1) - t_vw(z, xt, u0, u1)
  )):

f := (rs, z, xt, xs0, xs1, u0, u1, t0, t1) ->
  f_cs(rs, z, xt, 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: lda_exc *)
(* prefix:
  lda_c_1d_csc_params *params;

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

$define xc_dimensions_1d

(* factor of 2 is the conversion from Ry to Hartree *)
f_aux := (a, rs) -> -(rs + a[5]*rs^2)*log(1+ a[8]*rs + a[9]*rs^a[10])
  / (2*(a[1] + a[2]*rs + a[3]*rs^a[6] + a[4]*rs^a[7])):

f := (rs, z) ->
  f_aux(params_a_para, rs) + (f_aux(params_a_ferro, rs) - f_aux(params_a_para, rs))*z^2:


(*
 Copyright (C) 2019 Susi Lehtola

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

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

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

(* Functional is based on Chachiyo correlation with modified spin scaling *)
$include "lda_c_chachiyo_mod.mpl"

(* Reduced gradient parameter *)
cha_t := (rs, xt) -> (Pi/3)^(1/6) / 4 * n_total(rs)^(1/6) * xt:

(* The full functional that agrees with the given reference values is *)
f_chachiyo_gga := (rs, z, xt, xs0, xs1) -> f_chachiyo(rs, z) * (1 + cha_t(rs, xt)^2)^(params_a_h / f_chachiyo(rs, z)):

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


######################################################################
# big_subsets(A) is the set of all subsets B of A with |B| > 1

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

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

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

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

 if nops(A) < 2 then return FAIL; fi;

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

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

 return B;
end;

`list_elements/big_subsets` := (A::set) ->
 select(B -> nops(B) > 1,sort(map(sort,[op(combinat[powerset](A))]))):

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


# 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 -> floating base wird durch base twist (Geschwindigkeit der Basis) oder vollständige Orientierung (Euler-Winkel) berücksichtigt
# rotmat -> Kinematik wird mit Rotationsmatrizen berechnet
# velocity -> Berechnung der Geschwindigkeit aller Segmente
# worldframe -> Berechnung der Geschwindigkeit im Welt-KS (KSW)
# 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 Welt-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
  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:
read sprintf("../codeexport/%s/tmp/kinematics_com_worldframe_floatb_%s_par1_maple.m", robot_name, base_method_name):
r_W_W_Si := r_W_W_Si:
r_W_i_Si := r_W_i_Si:
# 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
# Anfangsgeschwindigkeit der Basis
# Analog zu [Ortmaier2014], Gl. (7.6)
# Geschwindigkeit der Basis der Koordinatensysteme der Körper
rD_W_i := Matrix(3, NL):
rD_W_i(1..3,1) := V_base_t(1..3,1):
# Winkelgeschwindigkeit von Körper i ausgedrückt im KS W
omega_W_i := Matrix(3, NL):
if base_method_name = "twist" then:
  omega_W_i(1..3,1) := V_base_t(4..6,1):
end:
if base_method_name = "eulxyz" then:
  omega_W_i(1..3,1) := T_basevel . V_base_t(4..6,1):
end:
printf("%s. Nutze die Methode %s für die Basis-Drehgeschwindigkeit\n", FormatTime("%Y-%m-%d %H:%M:%S"), base_method_name):
# 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: Index i+1
  # Vorgängerkörper bestimmen
  j := v(i) + 1:
  if sigma(i) = 0 then # Drehgelenk
    # 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)
    omega_W_i(1 .. 3, i+1) := omega_W_i(1 .. 3, j) + thetaD(i,1)*Trf_c(1 .. 3, 3, i+1):
  else: # Schubgelenk
    # [Ortmaier2014] (7.12) (S.116)
    omega_W_i(1 .. 3, i+1) := omega_W_i(1 .. 3, j):
  end if:
  # Terme vereinfachen (Teil 1)
  if use_simplify=1 then
    tmp_t11:=time():
    tmp_l11 := length(omega_W_i(1 .. 3, i+1)):
    omega_W_i(1 .. 3, i+1) := simplify2(omega_W_i(1 .. 3, i+1)):
    tmp_l21 := length(omega_W_i(1 .. 3, i+1)):
    tmp_t21:=time():
  end if:
  # Vektor vom Ursprung des vorherigen Koordinatensystems zu diesem KS
  r_W_im1_i := -Trf_c(1 .. 3, 4, j) + Trf_c(1 .. 3, 4, i+1):
  if sigma(i) = 0 then # Drehgelenk
    # [Ortmaier2014] (7.10) (S.115), [KhalilDombre2002] (9.15)
    rD_W_i(1 .. 3, i+1) := rD_W_i(1 .. 3, j) + CrossProduct(omega_W_i(1 .. 3, j), r_W_im1_i):
  else: # Schubgelenk
    # [Ortmaier2014] (7.15) (S.116), [KhalilDombre2002] (9.15)
    rD_W_i(1 .. 3, i+1) := rD_W_i(1 .. 3, j) + CrossProduct(omega_W_i(1 .. 3, j), r_W_im1_i) + dD(i,1)*Trf_c(1 .. 3, 3, i+1):
  end if:
  printf("%s. Geschwindigkeit für Körperkoordinatensystem %d aufgestellt (Herleitung im Welt-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_W_i(1 .. 3, i+1)):
    rD_W_i(1 .. 3, i+1) := simplify2(rD_W_i(1 .. 3, i+1)):
    tmp_l22 := length(rD_W_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:
# Velocities of Center of Mass
#
rD_W_Si := Matrix(3, NL):
for i to NL do
  # [Ortmaier2014] (7.17) (S.118), [KhalilDombre2002] (9.15)
  rD_W_Si(1 .. 3, i) := Matrix(rD_W_i(1 .. 3, i)) + Matrix(CrossProduct(omega_W_i(1 .. 3, i), r_W_i_Si(1 .. 3, i))):
  printf("%s. Geschwindigkeit für Körperschwerpunkt %d aufgestellt.\n", FormatTime("%Y-%m-%d %H:%M:%S"), i-1):#0=Basis
  if use_simplify=1 then
    tmp_t1:=time():
    tmp_l1 := length(rD_W_Si(1 .. 3, i)):
    rD_W_Si(1 .. 3, i) := simplify2(rD_W_Si(1 .. 3, i)):
    tmp_l2 := length(rD_W_Si(1 .. 3, i)):
    tmp_t2:=time():
    printf("%s: Terme für Schwerpunkts-Geschwindigkeiten vereinfacht. Länge: %d->%d. Rechenzeit %1.1fs.\n", \
      FormatTime("%Y-%m-%d %H:%M:%S"), tmp_l1, tmp_l2, tmp_t2-tmp_t1):
  end if:
end do:

# Exportieren
# Basis-Position aus Termen entfernen. Die Basis-Position kann keinen Einfluss auf die Geschwindigkeiten der einzelnen Körper haben.
# Bei manchen komplexen Systemen scheint der Term aber trotzdem nicht zu verschwinden, da Maple die Vereinfachung nicht erkennt
for i from 1 to 3 do
  omega_W_i := subs({X_base_s[i,1]=0},omega_W_i):
  rD_W_i := subs({X_base_s[i,1]=0},rD_W_i):
  rD_W_Si := subs({X_base_s[i,1]=0},rD_W_Si):
end do:
# Maple Export
save omega_W_i, rD_W_i, rD_W_Si, sprintf("../codeexport/%s/tmp/velocity_worldframe_floatbase_%s_par1_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_W_i), sprintf("../codeexport/%s/tmp/velocity_omegai0_floatb_%s_worldframe_matlab.m", robot_name, base_method_name), codegen_opt):
  MatlabExport(convert_t_s(rD_W_i), sprintf("../codeexport/%s/tmp/velocity_rDi0_floatb_%s_worldframe_matlab.m", robot_name, base_method_name), codegen_opt):
  MatlabExport(convert_t_s(rD_W_Si), sprintf("../codeexport/%s/tmp/velocity_rDSi0_floatb_%s_worldframe_par1_matlab.m", robot_name, base_method_name), codegen_opt):
  printf("Geschwindigkeiten in Matlab exportiert. %s\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: work_mgga_x *)

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

$include "gvt4.mpl"

f := (rs, x, t, u) -> -gtv4(malpha, coeff_d, x, 2*(t - K_FACTOR_C))/X_FACTOR_C:


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

herman_c1 := 0.003:

herman_f := x -> 1 + herman_c1/X_FACTOR_C * x^2:

f := (rs, zeta, xt, xs0, xs1) -> gga_exchange(herman_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_c_pbe_params
$include "gga_c_regtpss.mpl"

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


TITLE

    DakotaModel_deterministic;
    ! Objective value 4165.0
    ! line 23 has a syntax error

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);

INTEGER VARIABLES

   ProductionPRODUCTS];

VARIABLES

   Purchase[RESOURCES];

MAX

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

SUBJECT TO

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

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_ft97_params *params;

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

ft97_beta := (rs, z, xs) -> params_a_beta0
  + params_a_beta1*sigma_spin(rs, z, xs)/(params_a_beta2 + sigma_spin(rs, z, xs)):

ft97_fx := (rs, z, xs) -> 1 + ft97_beta(rs, z, xs)*xs^2 /
  (X_FACTOR_C*sqrt(1 + 9*xs^2*ft97_beta(rs, z, xs)^2*arcsinh(xs^2)^2)):

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


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

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

(* type: gga_exc *)

bayesian_theta0 := 1.0008:
bayesian_theta1 := 0.1926:
bayesian_theta2 := 1.8962:

bayesian_f0 := s -> s^2/(1 + s)^2:
bayesian_f  := x -> bayesian_theta0 + bayesian_f0(X2S*x)* (bayesian_theta1 + bayesian_f0(X2S*x) * bayesian_theta2):

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


TITLE
	SNDP_10_5_0_1

STOCHASTIC

DATA
	NrOfScen := DATAFILE("10_5_0_1_ScalarData.dat");
	NrOfLocations := DATAFILE("10_5_0_1_ScalarData.dat"); !last location is a final location (market)
	Market := NrOfLocations; !last location is a final location (market)
	NrOfProducts := DATAFILE("10_5_0_1_ScalarData.dat");
	EndProduct := NrOfProducts;	!last product is the end product
	SalesPrice := DATAFILE("10_5_0_1_ScalarData.dat");
	PlantCost := DATAFILE("10_5_0_1_ScalarData.dat");
	PlantCapacity := DATAFILE("10_5_0_1_ScalarData.dat");

SCENARIO
	SCEN := 1..NrOfScen;

PROBABILITIES
	Prob[SCEN] := SPARSEFILE("10_5_0_1_Prob.dat");

RANDOM DATA
	Demand[SCEN] := SPARSEFILE("10_5_0_1_Demand.dat");

INDEX
	location := 1..NrOfLocations;
	start := location;
	finish := location;
	product := 1..NrOfProducts;
	material[product] WHERE (product <> EndProduct);
	arc[start, finish]:= INDEXFILE("10_5_0_1_arc.dat");

DATA
	ShipCost[start, finish]:= SPARSEFILE("10_5_0_1_ShipCost.dat");
	ArcProduct[product, start, finish] := SPARSEFILE("10_5_0_1_ArcProduct.dat");
	MaterialReq[material] := SPARSEFILE("10_5_0_1_MaterialReq.dat");

INDEX
	plantLocation[location] WHERE (ArcProduct[product:=EndProduct, start:=location, finish:=Market] = 1);

STAGE1 BINARY VARIABLES
	OpenProduction[plantLocation];

STAGE2 VARIABLES
	Ship[product, start, finish] WHERE (ArcProduct[product, start, finish] = 1);

MACROS
	TotalRevenue := SUM(start:  SalesPrice * Ship[product:=EndProduct, start, finish:=Market]);
	FixedCost := SUM(plantLocation: PlantCost * OpenProduction);
	TotalShipCost := SUM(product,start,finish: ShipCost * Ship);

MAX
	Profit = TotalRevenue - FixedCost - TotalShipCost;

SUBJECT TO
	BOMConstr[plantLocation, material]:
		MaterialReq[material] * Ship[product:=EndProduct, start:=plantLocation, finish:=Market] = SUM(start: Ship[product:=material, start, finish:=plantLocation]);

	DemandConstr -> DemConstr: SUM(start: Ship[product:=EndProduct,start,finish:=Market]) <= Demand;

	PlantConstr[plantLocation]:
		Ship[product:=EndProduct, start:=plantLocation, finish:=Market] <= PlantCapacity * OpenProduction[plantLocation];


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

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

(* type: work_gga_x *)

a1 := 1.647127:
a2 := 0.980118:
a3 := 0.017399:
b1 := 1.523671:
b2 := 0.367229:
b3 := 0.011282:

f0 := s -> (1 + a1*s^2 + a2*s^4 + a3*s^6)/(1 + b1*s^2 + b2*s^4 + b3*s^6):
f  := x -> f0(X2S*x):


######################################################################
# triples(A) is the set of all distinct triples (a,b,c) in A^3

`is_element/triples` := (A::set) -> proc(abc)
 type(abc,list) and nops(abc) = 3 and
 member(abc[1],A) and member(abc[2],A) and member(abc[3],A) and
 abc[1] <> abc[2] and abc[1] <> abc[3] and abc[2] <> abc[3];
end;

`is_equal/triples` := (A::set) -> (abc,def) -> evalb(abc = def):

`is_leq/triples` := NULL;

`random_element/triples` := (A::set) -> proc()
 local n,r,i,j,k,abc;
 n := nops(A);

 if n < 3 then return FAIL; fi;

 abc := [];

 while nops({op(abc)}) < 3 do
  i := rand(1..n)();
  j := rand(1..n)();
  k := rand(1..n)();
  abc := [A[i],A[j],A[k]];
 od;

 return abc;
end;

`list_elements/triples` := proc(A::set)
 local n,L,i,j,k;

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

 for i from 1 to n do
  for j from 1 to n do
   for k from 1 to n do
    if i <> j and i <> k and j <> k then
     L := L,[A[i],A[j],A[k]];
    fi;
   od;
  od;
 od;

 return [L];
end:

`count_elements/triples` := (A::set) ->
 nops(A) * (nops(A) - 1) * (nops(A) - 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: gga_exc *)

cac  := 1.467:
mtau := 4.5:
bcgp_pt := t -> t*sqrt((mtau + t)/(mtau + cac*t)):
arg := 0.5:
crg := 0.16667:
drg := 0.29633:
fbeta_modRasoltGeldart := rs -> (1.0 + arg*rs*(1+crg*rs)) / (1.0 + arg*rs*(1+drg*rs)):

$define gga_c_pbe_params
$include "gga_c_pbe.mpl"

(* override definition of tp *)
tp := (rs, z, xt) -> bcgp_pt(tt(rs, z, xt)):

(* override definition of mbeta *)
mbeta := (rs, t) -> params_a_beta*fbeta_modRasoltGeldart(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: gga_exc *)
(* prefix:
  gga_c_zpbeint_params *params;

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

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

ff := (z, t) -> mphi(z)^(params_a_alpha*t^3):

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


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

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

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

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

$define lda_x_params
$include "lda_x.mpl"

omega_x := 2.5:
gamma_x := 0.004:

vx := (rs, z) -> 1/(1 + rs/(omega_x*RS_FACTOR)*(2/(1 + z))^(1/3)):
ux := x -> gamma_x*x^2/(1 + gamma_x*x^2):
wx := t -> (K_FACTOR_C - t)/(K_FACTOR_C + t):

pol1  := t-> params_a_c[ 1] + params_a_c[ 2]*wx(t) + params_a_c[ 3]*wx(t)^2 + params_a_c[ 4]*wx(t)^3
  + params_a_c[ 5]*wx(t)^4 + params_a_c[ 6]*wx(t)^5:
pol2  := t-> params_a_c[ 7] + params_a_c[ 8]*wx(t) + params_a_c[ 9]*wx(t)^2 + params_a_c[10]*wx(t)^3
   + params_a_c[11]*wx(t)^4:
pol3  := t-> params_a_c[12] + params_a_c[13]*wx(t) + params_a_c[14]*wx(t)^2 + params_a_c[15]*wx(t)^3:
pol4  := t-> params_a_c[16] + params_a_c[17]*wx(t) + params_a_c[18]*wx(t)^2:
pol5  := t-> params_a_c[19] + params_a_c[20]*wx(t) + params_a_c[21]*wx(t)^2 + params_a_c[22]*wx(t)^3
   + params_a_c[23]*wx(t)^4:
pol6  := t-> params_a_c[24] + params_a_c[25]*wx(t) + params_a_c[26]*wx(t)^2 + params_a_c[27]*wx(t)^3:
pol7  := t-> params_a_c[28] + params_a_c[29]*wx(t) + params_a_c[30]*wx(t)^2:
pol8  := t-> params_a_c[31] + params_a_c[32]*wx(t) + params_a_c[33]*wx(t)^2 + params_a_c[34]*wx(t)^3:
pol9  := t-> params_a_c[35] + params_a_c[36]*wx(t) + params_a_c[37]*wx(t)^2:
pol10 := t-> params_a_c[38] + params_a_c[39]*wx(t) + params_a_c[40]*wx(t)^2:

FMN12 := (rs, z, x, t) ->
  + pol1(t)
  + pol2(t)*ux(x)
  + pol3(t)*ux(x)^2
  + pol4(t)*ux(x)^3
  + pol5(t)*vx(rs, z)
  + pol6(t)*ux(x)*vx(rs, z)
  + pol7(t)*ux(x)^2*vx(rs, z)
  + pol8(t)*vx(rs, z)^2
  + pol9(t)*ux(x)*vx(rs, z)^2
  + pol10(t)*vx(rs, z)^3:

f_spin := (rs, z, x, t) ->
  lda_x_ax*(1 + z)^(4/3)/rs*FMN12(rs, z, x, t):

f_mn12 := (rs, z, xt, xs0, xs1, ts0, ts1) ->
  f_spin(rs, z, xs0, ts0) + f_spin(rs, -z, xs1, ts1):

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


(*

区间对象
实现运算：
    + 交集
    + 并集
    + 补集
    + 子集
实现了三种初始化方法：
    + 不等式集合
    + RealRange表达式
    + 区间的字符串表达形式
导出了辅助RealRange计算的两个函数

*)
$ifndef _SEG_
$define _SEG_

Seg:=module()
    option object;
    export
            # 运算符，优先级从高到低
            ## 逻辑版本
            `not`::static,          # 区间补集
            `and`::static,          # 区间交集
            `or`::static,           # 区间并集
            `xor`::static,          # 区间差集
            `implies`::static,      # 区间子集
            ## 集合版本
            `&C`::static,           # 区间补集
            `intersect`::static,    # 区间交集
            `union`::static,        # 区间并集
            `minus`::static,        # 区间差集
            `subset`::static,       # 区间属于

            # 属性
            bound:=real,            # 对应的 RealRange 对象

            # 导出工具函数
            formatRange::static,    # 将RealRange转化为区间表示形式
            evalRange::static;      # RealRange彻底求值
    local
            # 初始化
            ModuleApply::static,    # 初始化
            conBuild::static,       # 使用约束集合初始化
            rangeBuild::static,     # 使用 RealRange 初始化
            con2range::static,      # 约束转化为 RealRange 对象
            strBuild::static,       # 使用字符串初始化
            exprOutput::static,     # 字符串解析辅助函数
            # 输出
            ModulePrint::static,    # 输出
            range2str::static,      # RealRange 对象转化为字符串
            sortOps::static,        # 输出时按左值排序
            leftBound::static,      # 获取 RealRange 左端值,用于排序
            # 计算
            expandRange::static,    # 化简 RealRange 对象
            subsRange::static,      # 替换Range表达式中的集合对象和Non表达式
            rangeNot::static;       # RealRange 对象取补集

    # 初始化
    ModuleApply:=proc(x)
        if type(x,set({`=`,`<`,`<=`,`<>`})) then
            return conBuild(x);
        elif type(x,string) then
            return strBuild(x);
        else
            return rangeBuild(x);
        end if;
    end proc:

    # 使用约束集合初始化
    conBuild:=proc(cons::set({`=`,`<`,`<=`,`<>`}))
        if numelems(indets(cons,name))<>1
        or ormap(x->numelems(indets(cons,name))<>1,cons) then
            error "每个不等式（等式）都只能使用同一个变量";
        end if;
        return rangeBuild(AndProp(con2range~(cons)[]));
    end proc:

    # 使用 RealRange 初始化
    rangeBuild:=proc(r)
        local this;
        this:=Object(Seg);
        this:-bound:=evalRange(r);
        return this;
    end proc:

    # 将约束转化为RealRange
    con2range:=proc(_c::{`=`,`<`,`<=`,`<>`})
        local c,v;
        c:=RealDomain:-solve({_c})[];
        if type(c,`<`) then
            if type(lhs(c),numeric) then
                return RealRange(Open(lhs(c)),infinity);
            else
                return RealRange(-infinity,Open(rhs(c)));
            end if;
        elif type(c,`<=`) then
            if type(lhs(c),numeric) then
                return RealRange(lhs(c),infinity);
            else
                return RealRange(-infinity,rhs(c));
            end if;
        else
            if type(c,`=`) then
                return rhs(c);
            else
                v:=Open(rhs(c));
                return OrProp(RealRange(-infinity,v),RealRange(v,infinity));
            end if;
        end if;
    end proc:

    # 交集
    `and`:=proc()
        option overload;
        return rangeBuild(AndProp(map(x->x:-bound,[_passed])[]));
    end proc:
    `intersect`:=`and`;

    # 并集
    `or`:=proc()
        option overload;
        return rangeBuild(OrProp(map(x->x:-bound,[_passed])[]));
    end proc:
    `union`:=`or`;

    # 补集
    `not`:=proc(x::Seg,$)
        option overload;
        return rangeBuild(rangeNot(x:-bound));
    end proc:
    `&C`:=`not`;

    # 差集
    `xor`:=proc(x::Seg,y::Seg,$)
        return x and (not y);
    end proc:
    `minus`:=`xor`;

    # 子集
    `subset`:=proc(x::Seg,y::Seg,$)
        local z;
        z:=x and y;
        return evalb(z:-bound=x:-bound);
    end proc:
    `implies`:=`subset`;

    # RealRange彻底求值
    evalRange:=proc(x)
        return expandRange(subsRange(x));
    end proc:

    # RealRange补集展开
    rangeNot:=proc(b)
        local lv,rv,lb,rb;
        if b=BottomProp then
            return RealRange(-infinity,infinity);
        elif type(b,infinity) then
            return real;
        elif type(evalf(b),numeric) then
            return OrProp(RealRange(-infinity,Open(b)),RealRange(Open(b),infinity));
        elif b=real then
            return BottomProp;
        elif op(0,b)=RealRange then
            if op([1,0],b)=Open then
                lv:=op([1,1],b);
            else
                lv:=Open(op(1,b));
            end if;
            if op([2,0],b)=Open then
                rv:=op([2,1],b);
            else
                rv:=Open(op(2,b));
            end if;
            if has(lv,infinity) then
                lb:=NULL;
            else
                lb:=RealRange(-infinity,lv);
            end if;
            if has(rv,infinity) then
                rb:=NULL;
            else
                rb:=RealRange(rv,infinity);
            end if;
            return OrProp(lb,rb);
        elif op(0,b)=AndProp then
            return OrProp(thisproc~([op(b)])[]);
        elif op(0,b)=OrProp then
            return AndProp(thisproc~([op(b)])[]);
        end if;
    end proc:

    # 把 property 表达式中的集合都替换为 OrProp
    # 把 Non 展开
    subsRange:=proc(x)
        if type(x,set) then
            return OrProp(op(x));
        elif op(0,x)=Non then
            return rangeNot(op(x));
        elif op(0,x)=AndProp or op(0,x)=OrProp then
            return op(0,x)(thisproc~([op(x)])[]);
        else
            return x;
        end if;
    end proc:

    # 展开计算RealRange
    expandRange:=proc(x)
        local orv,nxt,rst,tmp;
        if op(0,x)=AndProp then
            # 所有的交集操作的返回结果都不应该表示为交集的形式
            if has([op(x)],OrProp) then
                # A⋂(B⋃C)=(A⋂B)⋃(A⋂C)
                orv:=op(1,x);
                nxt:=op(2,x);
                rst:=op(3..-1,x);
                tmp:=OrProp(map(x->AndProp(x,nxt),[op(orv)])[]);
                tmp:=AndProp(tmp,rst);
            elif type(op(1,x),extended_numeric) then
                # 计算 AndProp(x,property)
                # 因为集合已经被事先展开，所以这里只可能有一个数值对象
                # 而且经测试，顺序为：numeric < OrProp < RealRange
                if is(op(1,x),op(2,x)) then
                    tmp:=op(1,x);
                else
                    tmp:=BottomProp;
                end if;
            else
                tmp:=x;
            end if;
            return thisproc(tmp);
        elif op(0,x)=OrProp and has([op(x)],AndProp) then
        	return thisproc(OrProp(thisproc~([op(x)])[]));
        else
            return x;
        end if;
    end proc:

    # 将RealRange转化为区间表示形式
    range2str:=proc(b)
        local lc,lv,rc,rv,bs,r;
        if b=BottomProp then
            return "∅";
        elif type(evalf(b),extended_numeric) then
            return sprintf("{%a}",b);
        elif b=real then
            return "( -∞ , +∞ )";
        elif op(0,b)=RealRange then
            if op([1,0],b)=Open then
                lc:="(";
                lv:=op([1,1],b);
            else
                lc:="[";
                lv:=op(1,b);
            end if;
            if op([2,0],b)=Open then
                rc:=")";
                rv:=op([2,1],b);
            else
                rc:="]";
                rv:=op(2,b);
            end if;
            if type(lv,infinity) then
                lv:="-∞";
                lc:="(";
            else
                lv:=convert(lv,string);
            end if;
            if type(rv,infinity) then
                rv:="+∞";
                rc:=")";
            else
                rv:=convert(rv,string);
            end if;
            return sprintf("%s %s , %s %s",lc,lv,rv,rc);
        elif op(0,b)=OrProp then
            bs:=thisproc~(sortOps([op(b)]));
            r:=cat(map(x->cat(x," ⋃ "),bs)[]);
            return sprintf("< %s >",r[1..(-length(" ⋃ ")-1)]);
        elif op(0,b)=AndProp then
            bs:=thisproc~(sortOps([op(b)]));
            r:=cat(map(x->cat(x," ⋂ "),bs)[]);
            return sprintf("< %s >",r[1..(-length(" ⋂ ")-1)]);
        end if;
    end proc:

    # 用于排序
    sortOps:=proc(x)
        return sort(x,key=leftBound);
    end proc:

    # 区间左值
    leftBound:=proc(b)
        if b=BottomProp then
            return evalf(-infinity);
        elif type(evalf(b),extended_numeric) then
            return evalf(b);
        else
            return thisproc(op(1,b));
        end if;
    end proc:

    # 默认输出
    ModulePrint:=proc(x::Seg)
        return formatRange(x:-bound);
    end proc:

    # 将RealRange转化为区间表示形式
    formatRange:=proc(x)
        local r:=range2str(x);
        if r[1]="<" then
            r:=r[3..-3];
        end if;
        return r;
    end proc:

    # 根据区间的字符串表达形式初始化
    strBuild:=proc(_s::string)
        local r,s,cb,cx,cz,i,n,os,st,md,ed;
        s:=_s;
        # 处理无穷和交并符号
        s:=StringTools:-SubstituteAll(s,"\x26\x69\x6E\x66\x69\x6E\x3B","infinity");
        s:=StringTools:-SubstituteAll(s,"\x26\x62\x69\x67\x63\x61\x70\x3B","and");
        s:=StringTools:-SubstituteAll(s,"\x26\x62\x69\x67\x63\x75\x70\x3B","or");
        # 内部默认使用逻辑版本的运算符
        s:=StringTools:-SubstituteAll(s,"&C","not");
        s:=StringTools:-SubstituteAll(s,"intersect","and");
        s:=StringTools:-SubstituteAll(s,"union","or");
        s:=StringTools:-SubstituteAll(s,"minus","xor");
        s:=StringTools:-SubstituteAll(s,"subset","implies");
        # 解析字符串
        r:=StringTools:-StringBuffer();
        n:=length(s);
        cb:=0;# 区间括号标记
        cx:=0;# 小括号标记
        cz:=0;# 中括号标记
        os:=1;# 未处理的字符串的开始下标
        st:=0;# 区间开始下标
        md:=0;# 区间分隔符下标
        ed:=0;# 区间结束下标
        for i from 1 to n do
            if   s[i]="(" then
                if cx=0 and cb=0 then
                    cb:=1;
                    st:=i;
                else
                    cx:=cx+1;
                end if;
            elif s[i]="[" then
                if cz=0 and cb=0 then
                    cb:=1;
                    st:=i;
                else
                    cz:=cz+1;
                end if;
            elif s[i]="," and cb=1 and cx=0 and cz=0 then
            # 这么写保证了只有在其它表达式的()[]匹配的情况下才会将读取的`,`作为区间的分隔符，
            # 考虑到了其它表达式中出现`,`的可能性。
                md:=i;
            elif s[i]=")" then
                if cx=0 and cb=1 then
                    ed:=i;
                    cb:=0;
                    r:-append(exprOutput(s,os,st,md,ed));
                    os:=i+1;
                else
                    cx:=cx-1;
                end if;
            elif s[i]="]" then
                if cz=0 and cb=1 then
                    ed:=i;
                    cb:=0;
                    r:-append(exprOutput(s,os,st,md,ed));
                    os:=i+1;
                else
                    cz:=cz-1;
                end if;
            end if;
        end do;
        r:-append(s[os..-1]);
        s:=r:-value();
        r:-clear();
        # 处理单点区间
        s:=StringTools:-RegSubs("{(.*)}"="Seg({\\1})",s);
        # 处理括号
        s:=StringTools:-SubstituteAll(s,"<","(");
        s:=StringTools:-SubstituteAll(s,">",")");
        # 返回结果
        return eval(subs(Open(infinity)=infinity,Open(-infinity)=-infinity,parse(s)));
    end proc:

    # 辅助转化区间表达式为Maple表达式
    exprOutput:=proc(s,os,st,md,ed)
        local lv,rv,res;
        if s[st]="(" then
            lv:=sprintf("Open(%s)",s[(st+1)..(md-1)]);
        else
            lv:=s[(st+1)..(md-1)];
        end if;
        if s[ed]=")" then
            rv:=sprintf("Open(%s)",s[(md+1)..(ed-1)]);
        else
            rv:=s[(md+1)..(ed-1)];
        end if;
        res:=sprintf("%sSeg(RealRange(%s,%s))",s[os..(st-1)],lv,rv);
        return res;
    end proc:

end module:

$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: gga_exc *)

wc_mu    := 0.2195149727645171:
wc_c     := (146/2025)*(4/9) - (73/405)*(2/3) + (wc_mu - MU_GE):
wc_kappa := KAPPA_PBE:

wc_f0_aux := s -> wc_kappa + MU_GE * s^2 + (wc_mu - MU_GE) * s^2 * exp(-s^2) + log(1 + wc_c * s^4):
wc_f0  := s -> 1 + wc_kappa*(1 - wc_kappa/wc_f0_aux(s)):
wc_f   := x -> wc_f0(X2S*x):

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


program sample13; { square root }
var x, high, low, mid, can : integer;
begin
	writeln('Input x for calculating root x');
	readln(x);
	if x < 0 then begin
		writeln('can not calculate a root of negative number')
	end
	else begin
		low := 0;
		high := 181;
		while (high - low) >= 2 do begin
			mid := (high + low) div 2;
			can := mid * mid;
			if x < can then high := mid
			else if can < x then low := mid
			else begin
				high := mid;
				low := mid
			end
		end;
		if high = low then writeln('root ', x, ' = ', low)
		else if (high * high - x) > (x - low * low) then
			writeln('root ', x, ' = ', low)
		else writeln('root ', x, ' = ', high)
	end
end.


# Given elements a[i] in A we have elements 1 - a[i] in the group ring.
# The tensor product of these is represented by `bar/BA`(a[1],...,a[n])

`bar/BA` := proc ()
 local i;
 for i to nargs do
  if args[i] = 1 then return 0 fi;
 od;
 return '`bar/BA`'(args);
end:

# The standard differential in the bar complex is `d/BA`

`d/BA` := (u) -> sort(expand(eval(subs(`bar/BA`=`d_bar/BA`,u))));

`d_bar/BA` := proc()
 local n,i,q;
 n := nargs;
 if n = 0 then
  return 0;
 else
  return -`bar/BA`(args[2..n]) +
         (-1)^(n+1)*`bar/BA`(args[1..n-1]) +
         add((-1)^(i+1)*`bar/BA`(args[1..i-1],args[i]*args[i+1],args[i+2..n]),
             i=1..n-1);
 fi;
end:

# The shuffle product in the bar complex is `mu/BA`

`mu/BA` := proc()
 apply_linear_assoc(`mu_aux0/BA`,`bar/BA`())(args);
end:

`mu_aux0/BA` := proc(u,v)
 local r,s,i,ii,j;
 r := nops(u);
 s := nops(v);
 if r = 0 then return v; fi;
 if s = 0 then return u; fi;
 ii := [seq([i],i=1..r+s)];
 for i from 2 to r do
  ii := map(`ext/BA`,ii,r+s);
 od;
 return add(`mu_aux1/BA`(u,v,ii[j]),j=1..nops(ii));
end:

`ext/BA` := proc (i, r)
 local j;
 seq([op(i), j], j = i[nops(i)]+1 .. r);
end:

`mu_aux1/BA` := proc (u, v, i)
 local r,s,q,j,k,m;
 r := nops(u);
 s := nops(v);
 q := [EMPTY$r+s];
 for j to r do
  q[i[j]] := op(j, u)
 od;
 k := 1;
 for j to r+s do
  if q[j] = EMPTY then
   q[j] := op(k, v);
   k := k+1;
  fi;
 od;
 m := `+`(op(i))-(1/2)*r*(r+1);
 return (-1)^m*`bar/BA`(op(q))
end:

`mu_bar/BA` := proc()
 `mu/BA`(op(map(`bar/BA`,[args])));
end:

######################################################################
# The element u = `tau/BA`(n,a) has du = n[a] - [a^n].
# Thus, if a^n = 1 then u is a 2-cycle modulo n.

`tau/BA` := proc(n,a)
 local k;
 add(-`bar/BA`(a^k,a),k=0..n-1);
end:

`zeta/BA` := proc(n,m,a)
 local i,j;
 - add(add(`bar/BA`(a^(m*i),a^j,a),j=0..m-1),i=0..n-1);
end:

# The element `sigma/BA`(n,a,b) is a chain of dimension 3.
# It is symmetric in a and b, and is a cycle if a^n = b^n = 1.

`sigma/BA` := proc(n,a,b)
 `mu/BA`(`tau/BA`(n, a), `bar/BA`(b)) +
 `mu/BA`(`tau/BA`(n, b), `bar/BA`(a))
end:

# The element u = `gamma/BA`(n,a) is a chain of dimension 2n+1.
# It is a cycle if a^n = 1.

`gamma/BA` := proc(n,k,a)
 local u,v,i;
 u := `bar/BA`(a);
 v := `tau/BA`(n,a);
 for i from 1 to k do
  u := `mu/BA`(u,v);
 od;
 u := expand(u/k!);
 return u;
end:

`rho/BA` := proc(n,a,b)
 `tau/BA`(n,a) +
 `tau/BA`(n,b) -
 `tau/BA`(n,a*b) +
 n*`bar/BA`(a, b);
end:

`omega/BA` := proc (n,a,b)
 local i,j;
 -add(add(`bar/BA`(a^i*b^j,b,a), j = i .. n-1), i = 0 .. n-1) +
  add(add(`bar/BA`(a^i*b^j,a,b), j = i+1 .. n-1), i = 0 .. n-2);
end:

######################################################################
# We now introduce the standard DGA for H_*(BZ/n).

# The k'th chain group is freely generated over Z[Z/n] by
# `e/EC`(n,k,0).  The orbit of this consists of elements `e/EC`(n,k,i).

`e/EC` := proc(n::posint,k::nonnegint,i::nonnegint)
 '`e/EC`'(n,k,modp(i,n));
end:

`de/EC` := proc(n::posint,k::nonnegint,i::nonnegint)
 local j;
 if k = 0 then
  return 0;
 elif modp(k,2) = 0 then
  return(add(`e/EC`(n,k-1,j),j=0..n-1));
 else
  return `e/EC`(n,k-1,modp(i+1,n)) - `e/EC`(n,k-1,i);
 fi;
end:

`d/EC` := (u) -> eval(subs(`e/EC` = `de/EC`,u));

`mu/EC` := proc(a,b)
 local xx,ca,cb,pa,pb,na,nb,ka,kb,la,lb,ia,ib;
 if nargs > 2 then
  return `mu/EC`(`mu/EC`(a,b),args[3..-1]);
 fi;
 if type(a,numeric) or type(b,numeric) then
  return expand(a*b);
 elif type(a,`+`) then
  return map(`mu/EC`,a,b);
 elif type(b,`+`) then
  return map2(`mu/EC`,a,b);
 fi;
 if type(a,`*`) then
  xx := selectremove(type,a,numeric);
  ca := xx[1];
  pa := xx[2];
 else
  ca := 1;
  pa := a;
 fi;
 if type(b,`*`) then
  xx := selectremove(type,b,numeric);
  cb := xx[1];
  pb := xx[2];
 else
  cb := 1;
  pb := b;
 fi;
 if type(pa,specfunc(anything,`e/EC`)) and
    type(pb,specfunc(anything,`e/EC`)) then
  na,ka,ia := op(pa);
  nb,kb,ib := op(pb);
  if nb <> na then return FAIL; fi;
  if modp(ka,2) = 1 and modp(kb,2) = 1 then
   return 0;
  fi;
  la := floor(ka/2);
  lb := floor(kb/2);
  return ca * cb * binomial(la+lb,la) * `e/EC`(na,ka+kb,modp(ia+ib,na));
 else
  return('`mu/EC`'(args))
 fi;
end:

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

`e/BC` := proc(n::posint,k::nonnegint)
 '`e/BC`'(n,k);
end:

`de/BC` := proc(n::posint,k::nonnegint)
 if k = 0 or modp(k,2) = 1 then
  return 0;
 else
  return n * `e/BC`(n,k-1);
 fi;
end:

`d/BC` := (u) -> eval(subs(`e/BC` = `de/BC`,u));

`mu/BC` := proc(a,b)
 local xx,ca,cb,pa,pb,na,nb,ka,kb,la,lb,ia,ib;
 if nargs > 2 then
  return `mu/BC`(`mu/BA`(a,b),args[3..-1]);
 fi;
 if type(a,numeric) or type(b,numeric) then
  return expand(a*b);
 elif type(a,`+`) then
  return map(`mu/BC`,a,b);
 elif type(b,`+`) then
  return map2(`mu/BC`,a,b);
 fi;
 if type(a,`*`) then
  xx := selectremove(type,a,numeric);
  ca := xx[1];
  pa := xx[2];
 else
  ca := 1;
  pa := a;
 fi;
 if type(b,`*`) then
  xx := selectremove(type,b,numeric);
  cb := xx[1];
  pb := xx[2];
 else
  cb := 1;
  pb := b;
 fi;
 if type(pa,specfunc(anything,`e/BC`)) and
    type(pb,specfunc(anything,`e/BC`)) then
  na,ka := op(pa);
  nb,kb := op(pb);
  if nb <> na then return FAIL; fi;
  if modp(ka,2) = 1 and modp(kb,2) = 1 then
   return 0;
  fi;
  la := floor(ka/2);
  lb := floor(kb/2);
  return ca * cb * binomial(la+lb,la) * `e/BC`(na,ka+kb);
 else
  return('`mu/BC`'(args))
 fi;
end:

`e/BC/BA` := proc(n::posint,k::nonnegint)
 option remember;

 if k = 0 then
  return `bar/BA`();
 elif k = 1 then
  return `bar/BA`(a);
 else
  return expand(`mu/BA`(`tau/BA`(n,a),`e/BC/BA`(n,k-2))/floor(k/2));
 fi;
end:

`phi/BC/BA` := proc(u)
 eval(subs(`e/BC` = `e/BC/BA`,u));
end:

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

check_abelian_group_homology := proc()
 local i,j,k,n,m,a,b,c,t,u,v,w,T,ok,err,exp_rel,diff_rel;

 ok := true;
 for i from 0 to 4 do
  for j from 0 to 4 do
   u := `bar/BA`(seq(a[m],m=1..i));
   v := `bar/BA`(seq(a[m],m=i+1..i+j));
   err := `mu/BA`(u,v) - (-1)^(i*j) * `mu/BA`(v,u);
   if err <> 0 then
    ok := false;
    break;
   fi;
  od:
  if not(ok) then break; fi;
 od:

 _ASSERT(ok,"`mu/BA` is graded-commutative");

 ok := true;
 for i from 0 to 4 do
  for j from 0 to 4 do
   for k from 0 to 4 do
    u := `bar/BA`(seq(a[m],m=1..i));
    v := `bar/BA`(seq(a[m],m=i+1..i+j));
    w := `bar/BA`(seq(a[m],m=i+j+1..i+j+k));
    err := `mu/BA`(`mu/BA`(u,v),w) - `mu/BA`(u,`mu/BA`(v,w));
    if err <> 0 then
     ok := false;
     break;
    fi;
   od:
   if not(ok) then break; fi;
  od:
  if not(ok) then break; fi;
 od:

 _ASSERT(ok,"`mu/BA` is associative");

 n := 5;
 err := `d/BA`(`tau/BA`(n,a)) - n * `bar/BA`(a);
 exp_rel := `bar/BA`(a^n);
 err := err + exp_rel;

 _ASSERT(err = 0,"d(tau_n(a))");

 err :=
  `d/BA`(`mu/BA`(`tau/BA`(n,a),`bar/BA`(b))) - n * `mu_bar/BA`(a,b);
 exp_rel := `mu_bar/BA`(a^n,b);
 err := err + exp_rel;

 _ASSERT(err = 0,"d(tau_n(a) b)");

 _ASSERT(
  {seq(seq(
   `tau/BA`(i*j,a) - `tau/BA`(i,a^j) - i * `tau/BA`(j,a) - `d/BA`(`zeta/BA`(i,j,a)),
  j=1..4),i=1..4)} = {0},
  "tau_{ij}(a)"
 );

 err := `d/BA`(`sigma/BA`(n,a,b));
 exp_rel := `mu_bar/BA`(a^n,b) - `mu_bar/BA`(a,b^n);
 err := err + exp_rel;

 _ASSERT(err = 0,"d(sigma_n(a,b))");

 _ASSERT(`sigma/BA`(n,a,b) = `sigma/BA`(n,b,a),"sigma_n is symmetric");

 err :=
  `sigma/BA`(n,a,b*c) - `sigma/BA`(n,a,b) - `sigma/BA`(n,a,c) +
    `mu/BA`(`bar/BA`(a),`rho/BA`(n,b,c));
 diff_rel := - `mu/BA`(`tau/BA`(n,a),`bar/BA`(b,c));
 exp_rel  := - `mu/BA`(`bar/BA`(a^n),`bar/BA`(b,c));
 err := err + `d/BA`(diff_rel) + exp_rel;

 _ASSERT(err = 0,"First formula for sigma_n(a,bc)");

 err :=
  `sigma/BA`(n,a,b*c)-`sigma/BA`(n,a,b)-`sigma/BA`(n,a,c)+
   binomial(n+1,2)*`mu_bar/BA`(a,b,c);

 diff_rel := -(`mu/BA`(`bar/BA`(a),`omega/BA`(n,b,c))+
  	       `mu/BA`(`tau/BA`(n,a),`bar/BA`(b,c)));
 exp_rel :=
  - `mu/BA`(`bar/BA`(a^n),`bar/BA`(b,c)) -
  add(`bar/BA`(a,b^i,b)-`bar/BA`(a,b^i*c^n,b),i=0..n-1)-
  add(`bar/BA`(b^i,b,a)-`bar/BA`(b^i*c^n,b,a),i=0..n-1)+
  add(`bar/BA`(b^i,a,b)-`bar/BA`(b^i*c^n,a,b),i=0..n-1);

 err := err + `d/BA`(diff_rel) + exp_rel;

 _ASSERT(err = 0,"Second formula for sigma_n(a,bc)");

 for k from 1 to 5 do
  err := `d/BA`(`gamma/BA`(n,k,a));
  T := [[]]:
  for i from 1 to k-1 do
   T := [seq(seq([op(t),a,a^j],j=1..n-1),t in T)]:
  od:
  exp_rel := (-1)^k*add(`mu/BA`(`bar/BA`(op(t),a),`bar/BA`(a^n)),t in T);
  err := err + exp_rel;
  _ASSERT(err = 0,sprintf("d(gamma_{n,%d}(u))",k));
 od:

 _ASSERT(simplify(`sigma/BA`(n,a,a) - 2 * `gamma/BA`(n,1,a)) = 0,
         "sigma_n(a,a) = 2 gamma_{n,1}(a)");

 err :=
  `gamma/BA`(n,1,a*b) - `gamma/BA`(n,1,a) - `gamma/BA`(n,1,b) -
    `sigma/BA`(n,a,b);

 diff_rel :=
  n*`bar/BA`(a,b,a,b) -
  `mu/BA`(`bar/BA`(a,b),`tau/BA`(n,a*b)) +
  `mu/BA`(`omega/BA`(n,a,b),`bar/BA`(a)+`bar/BA`(b));

 exp_rel :=
  add(`bar/BA`(a^i,b,a) - `bar/BA`(a^i*b^5,b,a),i=0..n-1) -
  add(`bar/BA`(a^i,a,b) - `bar/BA`(a^i*b^5,a,b),i=0..n-1) -
  add(`bar/BA`(b,a^i,a) - `bar/BA`(b,a^i*b^5,a),i=0..n-1) -
  add(`bar/BA`(a,a^i,a) - `bar/BA`(a,a^i*b^5,a),i=0..n-1) -
 `mu/BA`(`bar/BA`(a^n*b^n),`bar/BA`(a,b));

 err := err + `d/BA`(diff_rel) + exp_rel;

 _ASSERT(err = 0,"gamma_{n,1}(ab)");
end:

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

check_cyclic_group_homology := proc()
 local n,ok,u,v,w,ku,kv,kw,err;

 n := 5;

 ok := true;
 for ku from 0 to 4 do
  for kv from 0 to 4 do
   u := `e/BC`(n,ku);
   v := `e/BC`(n,kv);
   err := `mu/BC`(u,v) - (-1)^(ku*kv) * `mu/BC`(v,u);
   if err <> 0 then
    ok := false;
    break;
   fi;
  od:
  if not(ok) then break; fi;
 od:

 _ASSERT(ok,"`mu_BC` is graded-commutative");

 ok := true;
 for ku from 0 to 4 do
  for kv from 0 to 4 do
   for kw from 0 to 4 do
    u := `e/BC`(n,ku);
    v := `e/BC`(n,kv);
    w := `e/BC`(n,kw);
    err := `mu/BC`(`mu/BC`(u,v),w) - `mu/BC`(u,`mu/BC`(v,w));
    if err <> 0 then
     ok := false;
     break;
    fi;
   od:
   if not(ok) then break; fi;
  od:
 od:

 _ASSERT(ok,"`mu_BC` is associative",[u,v,w,err]);

 ok := true;
 for ku from 0 to 4 do
  for kv from 0 to 4 do
   u := `e/BC`(n,ku);
   v := `e/BC`(n,kv);
   err := `d/BC`(`mu/BC`(u,v)) - `mu/BC`(`d/BC`(u),v) - (-1)^ku * `mu/BC`(u,`d/BC`(v));
   if err <> 0 then
    ok := false;
    break;
   fi;
  od:
  if not(ok) then break; fi;
 od:

 _ASSERT(ok,"Leibniz rule for BC");
end:


(*
 Copyright (C) 2020 Susi Lehtola

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

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

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

(* Equation (26) *)
f_ccdf  := (rs, z, xt, xs0, xs1) ->
  params_a_c1 / (1 + params_a_c2*n_total(rs)^(-1/3)) * (1 - params_a_c3 / (1 + exp(-params_a_c4*(2^(1/3)*X2S*xt - params_a_c5)))):

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


# Metric for planer symmetry
Ndim_ := 4:
x1_ := t:
x2_ := x:
x3_ := theta:
x4_ := phi:
complex_ := {}:
g11_ := -alpha(t,x)^2+a1(t,x)^2*beta(t,x)^2:
g12_ := a1(t,x)^2*beta(t,x):
g22_ := a1(t,x)^2:
g33_ := b1(t,x)^2*x^2:
g44_ := b1(t,x)^2*x^2*(sin(theta))^2:


read "../IdentifiabilityODE.mpl";

sys := [
diff(x1(t), t) = a*x1(t) + b*x1(t) - x2(t)*c*x1(t),
diff(x2(t), t) = -a*b*x2(t) + d*x2(t)*x1(t),
y1(t) = x1(t)
];
CodeTools[CPUTime](IdentifiabilityODE(sys, GetParameters(sys)));


with(DifferentialAlgebra):
ring_diff := DifferentialRing(blocks = [[x1, x2], [y1] ], derivations = [t]):
sys := [
diff(x1(t), t) - (a*x1(t) + b*x1(t) - x2(t)*c*x1(t)),
diff(x2(t), t) - (-a*b*x2(t) + d*x2(t)*x1(t)),
y1(t) - (x1(t))
];
res := CodeTools[CPUTime](RosenfeldGroebner(sys, ring_diff, singsol=none));


inputfile := "AOC4-input.txt":

# parse input
input := subs(""=NULL,StringTools:-Split(
        FileTools:-Text:-ReadFile(inputfile), "\n\n")):
numbers := [parse(input[1])]: # list of numbers to "call"
# list of bingo boards stored as square lists of lists
boards := [seq(map(s->map(parse, StringTools:-Split(s)),
    input[(i-1)*5+2..(i*5+1)]), i=1..ceil( nops(input[2..]) / 5 ))]:

# helper to check for row or column bingos marked with the symbol X
checkbingo := b->ormap(r->numboccur(X,r)=5,b) or
     `or`(seq(numboccur(X,b[..,i])=5,i=1..5)):

answer1 := -1:
for n in numbers while answer1<0 do
    boards := subs(n=X, boards); # mark all the boards at once
    for b in boards while answer1<0 do
        if checkbingo(b) then
            answer1 := add(subs(X=0,map(op,b)))*n;
        end if;
    end do;
end do:
answer1;

for n in numbers while not checkbingo(boards[1]) do
    if nops(boards) > 1 then
        boards := remove(checkbingo, subs(n=X, boards));
    else
        boards := subs(n=X, boards);
        answer2 := add(subs(X=0,map(op,boards[1])))*n;
    end if;
end do:
answer2;


cube_complex := proc()
 local T,V,E,F,G0,G1,G,S,r,v,f,i,j,k,s,s1,t,g,eqs,sol;

 V := [seq(i,i=1..8)];

 T["vertices"] := V;

 T["short_edges"] := [
  [1,2],[1,3],[1,5],[2,4],[2,6],[3,4],[3,7],[4,8],[5,6],[5,7],[6,8],[7,8]
 ];

 T["long_edges"] := [[1,4],[1,6],[1,7],[2,8],[3,8],[4,8]];

 T["edges"] := sort([op(T["short_edges"]),op(T["long_edges"])]);

 T["squares"] := [
  [1,2,3,4],[1,2,5,6],[1,3,5,7],[2,4,6,8],[3,4,7,8],[5,6,7,8]
 ];

 T["faces"] := [
  [1,2,4],[1,3,4],[1,2,6],[1,5,6],[1,3,7],[1,5,7],
  [2,4,8],[2,6,8],[3,4,8],[3,7,8],[5,6,8],[5,7,8]
 ];

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

 T["vertex_index"]     := make_index(T["vertices"]):
 T["short_edge_index"] := make_index(T["short_edges"]):
 T["square_index"]     := make_index(T["squares"]):

 T["embedding_dim"] := 3;

 T["embedding"] := table([
  1 = [-1,-1,-1],
  2 = [ 1,-1,-1],
  3 = [-1, 1,-1],
  4 = [ 1, 1,-1],
  5 = [-1,-1, 1],
  6 = [ 1,-1, 1],
  7 = [-1, 1, 1],
  8 = [ 1, 1, 1]
 ]);

 v := eval(T["embedding"]);

 `plot/simplicial_complex`(T);

 S := NULL;
 for i from 1 to nops(T["squares"]) do
  f := T["squares"][i];
  f := [f[1],f[2],f[4],f[3]];
  S := S, polygon(map(j -> T["embedding"][j],f),colour=standard_colour(i));
 od:

 T["square_plot"] := display(S,scaling=constrained,axes=none);

 T["short_edge_centres"] :=
  map(e -> (v[e[1]] +~ v[e[2]]) /~ 2,T["short_edges"]);

 T["square_centres"] :=
  map(f -> (v[f[1]] +~ v[f[2]] +~ v[f[3]] +~ v[f[4]]) /~ 4, T["squares"]);

 f := (u) -> simplify(u /~ sqrt(add(u[i]^2,i=1..3)));

 T["poles"] := table([
  2 = map(f,T["short_edge_centres"]),
  3 = map(i -> f(v[i]),T["vertices"]),
  4 = map(f,T["square_centres"])
 ]);

 T["pole_plots"] := table([
  2 = map(u -> line(1.6 *~ u, -1.6 *~ u,color=green,thickness=4),T["poles"][2]),
  3 = map(u -> line(1.9 *~ u, -1.9 *~ u,color=red  ,thickness=4),T["poles"][3]),
  4 = map(u -> line(1.2 *~ u, -1.2 *~ u,color=blue ,thickness=4),T["poles"][4])
 ]);

 T["all_poles_plot"] := display(
  op(T["pole_plots"][2]),op(T["pole_plots"][3]),op(T["pole_plots"][4]),
  scaling=constrained,axes=none
 );

 G0 := [];
 G1 := [[2,4,1,3,6,8,5,7],[1,3,5,7,2,4,6,8]];
 G := [[1,2,3,4,5,6,7,8]];

 while G <> G0 do
  G0 := G;
  G := sort([op({seq(seq(`o/permutations`(8)(g,h),g in G1),h in G)})]);
 od:

 T["rotation_group"] := G;

 T["symmetry_group"] :=
   sort([op(G),op(map(s -> `o/permutations`(8)([8,7,6,5,4,3,2,1],s),G))]);

 r := table([1 = 1, 2 = 2, 3 = 3, 4 = 4, 5 = 4, 6 = 3, 7 = 2, 8 = 1]):

 T["to_axis_perm"]    := table():
 T["of_axis_perm"]    := table():
 T["symmetry_matrix"] := table():

 for s in T["rotation_group"] do
  s1 := `o/permutations`(8)([8,7,6,5,4,3,2,1],s);
  t := [r[s[1]],r[s[2]],r[s[3]],r[s[4]]];
  T["to_axis_perm"][s]  := t;
  T["to_axis_perm"][s1] := t;
  T["of_axis_perm"][t]  := s;

  g := Matrix(3,3,[seq(x[i],i=1..9)]);
  eqs := map(op,[seq(convert(g . Vector(v[i]) - Vector(v[s[i]]),list),i = 1..8)]);
  sol := solve(eqs);
  T["symmetry_matrix"][s ] := subs(sol,convert( g,listlist));
  T["symmetry_matrix"][s1] := subs(sol,convert(-g,listlist));
 od:

 return eval(T);
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/.
*)

(* These numbers are taken from the original reference, but divided by
     two to convert from Rydbergs to Hartrees *)

A_vwn  := [ 0.0310907, 0.01554535, -1/(6*Pi^2)]:
b_vwn  := [ 3.72744,   7.06042,    1.13107  ]:
c_vwn  := [12.9352,   18.0578,    13.0045   ]:
x0_vwn := [-0.10498,  -0.32500,   -0.0047584]:

A_rpa  := [ 0.0310907,  0.01554535,  -1/(6*Pi^2)]:
b_rpa  := [13.0720,    20.1231,      1.06835  ]:
c_rpa  := [42.7198,   101.578,      11.4813   ]:
x0_rpa := [-0.409286,  -0.743294,   -0.228344 ]:

Q_vwn  := (b, c)     -> sqrt(4*c - b^2):
f1_vwn := (b, c)     -> 2*b/Q_vwn(b, c):
f2_vwn := (b, c, x0) -> b*x0/(x0^2 + b*x0 + c):
f3_vwn := (b, c, x0) -> 2*(2*x0 + b)/Q_vwn(b, c):

fpp_vwn := 4/(9*(2^(1/3) - 1)):

fx_vwn := (b, c, rs) -> rs + b*sqrt(rs) + c:

f_aux := (A, b, c, x0, rs) -> A*(
  + log(rs/fx_vwn(b, c, rs))
  + (f1_vwn(b, c) - f2_vwn(b, c, x0)*f3_vwn(b, c, x0))*arctan(Q_vwn(b, c)/(2*sqrt(rs) + b))
  - f2_vwn(b, c, x0)*log((sqrt(rs) - x0)^2/fx_vwn(b, c, rs))
):

DMC  := (rs, z) ->
    + f_aux(A_vwn[2], b_vwn[2], c_vwn[2], x0_vwn[2], rs)
    - f_aux(A_vwn[1], b_vwn[1], c_vwn[1], x0_vwn[1], rs):

DRPA := (rs, z) ->
    + f_aux(A_rpa[2], b_rpa[2], c_rpa[2], x0_rpa[2], rs)
    - f_aux(A_rpa[1], b_rpa[1], c_rpa[1], x0_rpa[1], 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: gga_exc *)

cs1_gamma :=  0.006: (* as in B88 *)
cs1_d     :=  0.349: (* as in CS  *)
cs1_C1    := -0.018897:
cs1_C2    :=  0.155240:
cs1_C3    := -0.159068:
cs1_C4    :=  0.007953:

(* Equation (24) corrected in Equation (8) in Proynov2006_436 *)
cs1_ess := (rs, z, xs) ->
  + opz_pow_n(z,1)/2 * n_spin(rs, z)^(1/3)/(n_spin(rs, z)^(1/3) + cs1_d)
  * (cs1_C1 + cs1_C2*cs1_gamma^2*xs^4/(1 + cs1_gamma*xs^2)^2):

(* Equation (25) corrected in Equation (6) in Proynov2006_436 *)
cs1_eab := (rs, z, xt) ->
  + (1 - z^2)/4 * 1/(1 + cs1_d*n_total(rs)^(-1/3))
  * (cs1_C3 + cs1_C4*cs1_gamma^2*xt^4/(1 + cs1_gamma*xt^2)^2):

f_cs1 := (rs, z, xt, xs0, xs1) ->
  + cs1_eab(rs,  z, xt)
  + cs1_ess(rs,  z, xs0)
  + cs1_ess(rs, -z, xs1):

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


# The groupoid of sets of size 6 is equivalent to a certain groupoid of graphs which
# we have called Holder graphs.  Specifically, if A is a set of size 6, then we write
# DA for the set of subsets of size two, and we draw an edge between such subsets iff
# they are disjoint; this gives a Holder graph.  The code below sets up the
# relevant definitions.

`is_element/holder_graphs` := (V::set) -> proc(E)
 local non_edges,pentads,E0,e;

 if nops(V) <> 15 then
  return false;
 fi;

 if not `is_element/graphs`(V)(E) then
  return false;
 fi;

 if map(v -> nops(select(e -> e[1] = v,E)),V) <> {6} then
  return false;
 fi;

 non_edges := `top/autorel`(V) minus `id/autorel`(V) minus E;
 non_edges := map(e -> {op(e)},non_edges);

 pentads := combinat[choose](V,5);
 E0 := map(e -> {op(e)},E);

 for e in E0 do
  pentads := select(p -> e minus p <> {},pentads);
 od:

 for e in non_edges do
  if nops(select(p -> e minus p = {},pentads)) <> 1 then
   return false;
  fi;
 od;

 return true;
end:

`D/holder_graph` := proc(A::set)
 local V,E,v,w;

 if nops(A) <> 6 then
  error("A does not have size six");
 fi;

 V := combinat[choose](A,2);
 E := {seq(seq([v,w],w in V),v in V)};
 E := select(e -> e[1] intersect e[2] = {},E);
 return [V,E];
end:

`T/holder_graph` := (V::set) -> proc(E)
 local T,F,t,u;

 T := combinat[choose](V,3);
 T := select(t -> member([t[1],t[2]],E) and
                  member([t[2],t[3]],E) and
		  member([t[3],t[1]],E),T);

 F := {seq(seq([t,u],u in T),t in T)};
 F := select(e -> e[1] <> e[2],F);
 F := select(e -> e[1] intersect e[2] <> {},F);
 return [T,F];
end:

`P/holder_graph` := (V) -> proc(E)
 local P,E0,e;

 P := combinat[choose](V,5);
 E0 := map(e -> {op(e)},E);

 for e in E0 do
  P := select(p -> e minus p <> {},P);
 od:

 return P;
end:

`alpha/holder_graph` := (A) -> proc(a)
 local b;
 {seq({a,b},b in A minus {a})};
end:

`beta/holder_graph` := (V) -> (E) -> proc(v)
 local P;

 P := `P/holder_graph`(V)(E);

 return select(p -> member(v,p),P);
end:

`gamma/holder_graph` := (V) -> (E) -> proc(v)
 local T,F;

 T,F := op(`T/holder_graph`(V)(E));
 return select(t -> member(v,t),T);
end:

check_holder_graph := proc()
 local A0,A1,V0,V1,V2,V3,E0,E1,E2,E3,v,beta_table,gamma_table;

 A0 := {1,2,3,4,5,6};
 V0,E0 := op(`D/holder_graph`(A0)):
 _ASSERT(
  `is_element/holder_graphs`(V0)(E0),
  "D sends sets of size six to Holder graphs"
 );

 A1 := `P/holder_graph`(V0)(E0):
 _ASSERT(
  evalb(nops(A1) = 6),
  "P sends Holder graphs to sets of size six"
 );

 _ASSERT(
  evalb(map(`alpha/holder_graph`(A0),A0) = A1),
  "alpha : A -> PDA is bijective"
 );

 V1,E1 := op(`D/holder_graph`(A1)):

 _ASSERT(
  `is_element/holder_graphs`(V1)(E1),
  "DP sends Holder graphs to Holder graphs"
 );

 beta_table := table():
 for v in V0 do beta_table[v] := `beta/holder_graph`(V0)(E0)(v); od:
 _ASSERT(
  evalb(map(v -> beta_table[v],V0) = V1) and
  evalb(map(e -> [beta_table[e[1]],beta_table[e[2]]],E0) = E1),
  "beta : G -> DPG is an isomorphism"
 );

 V2,E2 := op(`T/holder_graph`(V0)(E0)):

 _ASSERT(
  `is_element/holder_graphs`(V2)(E2),
  "T sends Holder graphs to Holder graphs"
 );

 V3,E3 := op(`T/holder_graph`(V2)(E2)):
 _ASSERT(
  `is_element/holder_graphs`(V3)(E3),
  "T^2 sends Holder graphs to Holder graphs"
 );

 gamma_table := table():
 for v in V0 do gamma_table[v] := `gamma/holder_graph`(V0)(E0)(v); od:
 _ASSERT(
  evalb(map(v -> gamma_table[v],V0) = V3) and
  evalb(map(e -> [gamma_table[e[1]],gamma_table[e[2]]],E0) = E3),
  "gamma : G -> T^2G is an isomorphism"
 );
end:

# The code below is older.  It partially duplicates the code above and then
# sets up an embedding of a Holder graph in R^3 u {infinity}

make_holder_graph := proc()
 local i,j,k,l,ii,jj,kk,
  v,v_index,num_vertices,
  e,e_index,num_edges,
  t,t_index,num_triangles,
  col,vv,vi,ww,a,b,c,d,
  pol,draw_edge,sub_graph,full_sub_graph,G;

 i := 0:
 for j from 0 to 4 do
  for k from j+1 to 5 do
   v[i] := {j,k}:
   v_index[{j,k}] := i:
   i := i+1:
  od:
 od:
 num_vertices := i;

 i := 0:
 for j from 0 to num_vertices-2 do
  for k from j+1 to num_vertices-1 do
   if v[j] intersect v[k] = {} then
    e[i] := {j,k}:
    e_index[{j,k}] := i:
    i := i+1:
   fi:
  od:
 od:
 num_edges := i;

 i := 0:
 for j from 0 to num_vertices-1 do
  for k from j+1 to num_vertices-1 do
   for l from k+1 to num_vertices-1 do
    if nops({op(v[j]),op(v[k]),op(v[l])}) = 6 then
     ii := e_index[{j,k}]:
     jj := e_index[{j,l}]:
     kk := e_index[{k,l}]:
     t[i] := {ii,jj,kk}:
     t_index[{ii,jj,kk}] := i:
     col[ii] := i;
     col[jj] := i;
     col[kk] := i;
     i := i+1:
    fi:
   od:
  od:
 od:
 num_triangles := i;

 a := 0.3: b := 2: c := sqrt(3*b^2 - a^2): d := 1.5:

 t[0] := {};

 # Coordinates for a 3D picture
 vv[ 0] := infinity:
 vv[ 1] := [-b,-b, b]:
 vv[ 2] := [ b,-b,-b]:
 vv[ 3] := [-b, b,-b]:
 vv[ 4] := [ b, b, b]:
 vv[ 5] := [ b, b,-b]:
 vv[ 6] := [-b, b, b]:
 vv[ 7] := [ b,-b, b]:
 vv[ 8] := [-b,-b,-b]:
 vv[ 9] := [ 0,-c,-a]:
 vv[10] := [-c,-a, 0]:
 vv[11] := [-a, 0, c]:
 vv[12] := [-a, 0,-c]:
 vv[13] := [ c,-a, 0]:
 vv[14] := [ 0, c,-a]:

 vi[ 9] := [ 0, 0,-d]:
 vi[10] := [ 0,-d, 0]:
 vi[11] := [-d, 0, 0]:
 vi[12] := [-d, 0, 0]:
 vi[13] := [ 0,-d, 0]:
 vi[14] := [ 0, 0,-d]:

 # Coordinates for a planar picture
 pol := (r,t) -> simplify([r * cos(Pi/6*t), r * sin(Pi/6*t)]);

 ww[ 0] := pol(1, 0):
 ww[10] := pol(1, 1):
 ww[ 4] := pol(1, 2):
 ww[ 6] := pol(1, 3):
 ww[14] := pol(1, 4):
 ww[ 1] := pol(1, 5):
 ww[12] := pol(1, 6):
 ww[ 8] := pol(1, 7):
 ww[ 9] := pol(1, 8):
 ww[ 3] := pol(1, 9):
 ww[ 5] := pol(1,10):
 ww[13] := pol(1,11):
 ww[11] := pol(3, 0):
 ww[ 2] := pol(3, 4):
 ww[ 7] := pol(3, 8):

 G := table():

 G["v"] := eval(v);
 G["e"] := eval(e);
 G["t"] := eval(t);
 G["v_index"] := eval(v_index);
 G["e_index"] := eval(e_index);
 G["t_index"] := eval(t_index);
 G["num_vertices"] := num_vertices;
 G["num_edges"] := num_edges;
 G["num_triangles"] := num_triangles;
 G["col"] := eval(col);
 G["vv"] := eval(vv);
 G["vi"] := eval(vi);
 G["ww"] := eval(ww);

 draw_edge := proc(i)
  local u,p,q,r;
  u := e[i];
  p := vv[u[1]];
  q := vv[u[2]];
  if (p = infinity) then
   r := vi[u[2]];
   return(CURVES([q,[d*q[1],d*q[2],d*q[3]]],COLOR(HUE,col[i] * 0.07)));
  elif (p[1]*q[1] + p[2] * q[2] + p[3] * q[3] > 0) then
   return(great_arc(p,q,col[i] * 0.07));
  else
   return(CURVES([p,q],COLOR(HUE,col[i] * 0.07)));
  fi;
 end:

 sub_graph := proc(edge_test)
  local ee,i;
  ee := [];
  for i from 0 to num_edges-1 do
   if (edge_test(i)) then
    ee := [op(ee),i];
   fi;
  od:
  plots[display](PLOT3D(op(map(draw_edge,ee)),THICKNESS(3)),axes=none):
 end:

 full_sub_graph := proc(vertex_test)
  sub_graph(i -> vertex_test(e[i][1]) and vertex_test(e[i][2]));
 end:

 G["full_graph"] :=
  plots[display](PLOT3D(seq(draw_edge(i),i=0..num_edges-1),THICKNESS(3)),axes=none):

 G["outer_shell"] := full_sub_graph(i -> evalb(i < 9)):
 G["inner_shell"] := sub_graph(i -> evalb(e[i][1] > 8 and e[i][2] > 8)):
 G["joins"]       := sub_graph(i -> evalb(e[i][1] > 0 and e[i][1] < 9 and e[i][2] > 8)):

 G["plane_plot"] :=
  plots[display](
   seq(line(ww[e[i][1]],ww[e[i][2]]),i=0..num_edges-1),
   axes = none
  );

 return eval(G);
end:


(* type: work_gga_x *)
(* prefix:
  gga_x_b88_params *params;

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

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

f := x -> f0(x):


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

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

(* type: gga_exc *)

lg93_ad  := 1e-8:
lg93_b   := 0.024974:
lg93_a2  := (lg93_ad + 0.1234)/lg93_b:
lg93_a4  := 29.790:
lg93_a6  := 22.417:
lg93_a8  := 12.119:
lg93_a10 := 1570.1:
lg93_a12 := 55.944:

lg93_f0 := s-> 1 + lg93_a2*s^2 + lg93_a4*s^4
        + lg93_a6*s^6 + lg93_a8*s^8 + lg93_a10*s^10 + lg93_a12*s^12:

lg93_f1 := s-> lg93_f0(s)^lg93_b/(1 + lg93_ad*s^2):

lg93_f  := x->lg93_f1(X2S*x):

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


`is_element/cactus_trees` := (A::set) -> proc(J)
 global reason;
 local tag,B,C,E,a,j;

 tag := "is_element/cactus_trees";

 if A = {} then
  reason := [tag,"A is empty"];
  return false;
 fi;

 if not(type(J,set(set)) and map(op,J) minus A = {}) then
  reason := [tag,"J is not a set of subsets of A",J,A];
  return false;
 fi;

 if min(op(map(nops,J))) < 2 then
  reason := [tag,"J contains a set of size < 2",J];
  return false;
 fi;

 B := {};
 C := {A[1]};
 while nops(B) < nops(C) do
  B := C;
  C := map(op,{B,map(op,select(X -> X intersect B <> {},J))});
 od;
 if C <> A then
  reason := [tag,"The graph is not connected",A,J,C];
  return false;
 fi;

 E := {seq(seq([a,j],a in j),j in J)};
 if nops(E) <> (nops(A) + nops(J) - 1) then
  reason := [tag,"The graph is not a tree",A,E];
  return false;
 fi;

return true;
end:

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

`is_leq/cactus_trees` := (A::set) -> proc(J0,J1)
 local f,G,j0,j1,jj1,P,Q,p,q,U;

 # f will be the map J0 -> J1 with j0 a subset of f(j0)
 f := table():

 # G(j1) = f^{-1}{j1}
 G := table():

 for j1 in J1 do G[j1] := {}; od:

 for j0 in J0 do
  jj1 := select(u -> (j0 minus u) = {},J1);
  # Assuming that J1 really is a cactus tree, the set jj1 will
  # have size 0 or 1.
  if nops(jj1) <> 1 then
   return false;
  fi;
  j1 := op(1,jj1);
  f[j0] := j1;
  G[j1] := {op(G[j1]),j0};
 od:

 for j1 in J1 do
  P := G[j1];
  p := nops(P);
  if p = 0 then return false; fi; # f should be surjective
  Q := {P[1]};
  q := 0;
  while q < nops(Q) do
   q := nops(Q);
   U := map(op,Q);
   Q := select(j0 -> ((j0 intersect U) <> {}),P);
  od:
  if Q <> P then
   return false;
  fi;
 od;

 return true;
end:

`top/cactus_trees` := proc(A::set)
 if nops(A) > 1 then
  return {A};
 elif nops(A) = 1 then
  return {};
 else
  return FAIL;
 fi;
end:

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

`random_element/cactus_trees` := (A::set) -> proc()
 local a,b,B,J,K,k;

 if nops(A) = 0 then
  return FAIL;
 elif nops(A) = 1 then
  return {};
 elif nops(A) = 2 then
  return {A};
 fi;

 a := random_element_of(A);
 B := A minus {a};
 K := `random_element/cactus_trees`(B)();
 if rand(0..1)() = 0 then
  k := random_element_of(K);
  J := K minus {k} union {k union {a}};
 else
  b := random_element_of(B);
  J := K union {{a,b}};
 fi;

 return J;
end:

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

`list_elements/cactus_trees` := proc(A::set)
 option remember;
 local n,a,b,u,v,B,PP,pp,K,L,m,M,P,Q,i,k,f;

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

 a := A[1];
 B := A minus {a};
 PP := map(pp -> [op(pp)],`list_elements/partitions`(B));
 L := NULL;
 for pp in PP do
  m := nops(pp);
  M := map(`list_elements/cactus_trees`,pp);
  P := [seq([seq(seq([K,{b}],b in pp[i]),K in M[i]),
             seq(seq([K,k],k in K),K in M[i])],i=1..m)];
  Q := [[]];
  for i from 1 to m do
   Q := [seq(seq([op(u),v],u in Q),v in P[i])];
  od:
  f := (q) -> {seq(op(q[i][1] minus {q[i][2]}),i=1..m),seq({a,op(q[i][2])},i=1..m)};
  L := L,op(map(f,Q));
 od:
 return [L];
end:

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

# This is A030019 in OEIS

`count_elements/cactus_trees` := proc(A::set)
 local n,i;
 n := nops(A);
 add(Stirling2(n-1, i)*n^(i-1),i=0..n-1);
end:


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

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

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

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

AA :=  0.757211:
BB := -0.106364:
CC := -0.118649:
DD :=  0.609650:

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

mzeta   := s -> s^2*fH(s):
meta    := s -> AA + mzeta(s):
mlambda := s -> DD + mzeta(s):
mchi    := (rs, z, s) -> nu(rs, z)/sqrt(mlambda(s) + nu(rs, z)^2):

fF := (rs, z, s) ->
  1 - s^2/(27*CC*(1 + s^2/4)) - mzeta(s)/(2*CC):

fG := (rs, z, s) ->
  - 2/5  * CC*fF(rs, z, s)*mlambda(s)
  - 4/15 * BB*mlambda(s)^2
  - 6/5  * AA*mlambda(s)^3
  - mlambda(s)^(7/2)*(4/5*sqrt(Pi) + 12/5*(sqrt(mzeta(s)) - sqrt(meta(s)))):

f1 := (rs, z, s) ->
   + AA
   - 4/9 * BB*(1 - mchi(rs, z, s))/mlambda(s)
   - 2/9 * CC*fF(rs, z, s)*(2 - 3*mchi(rs, z, s) + mchi(rs, z, s)^3)/mlambda(s)^2
   - 1/9 * fG(rs, z, s)*(8 - 15*mchi(rs, z, s) + 10*mchi(rs, z, s)^3 - 3*mchi(rs, z, s)^5)/mlambda(s)^3
   + 2*nu(rs, z)*(sqrt(mzeta(s) + nu(rs, z)^2) -  sqrt(meta(s) + nu(rs, z)^2))
   + 2*mzeta(s)*log((nu(rs, z) + sqrt(mzeta(s) + nu(rs, z)^2))/(nu(rs, z) + sqrt(mlambda(s) + nu(rs, z)^2)))
   - 2*meta(s)*log((nu(rs, z) + sqrt(meta(s) + nu(rs, z)^2))/(nu(rs, z) + sqrt(mlambda(s) + nu(rs, z)^2))):

f_lda := (rs, z) -> -X_FACTOR_C*RS_FACTOR*((1 + z)/2)^(4/3)/rs:

f := (rs, z, xt, xs0, xs1) ->
  f_lda(rs, z)*f1(rs, z, X2S*xs0) + f_lda(rs, -z)*f1(rs, -z, X2S*xs1):


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

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

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

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

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

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

gxl  := x -> add(params_a_cx_local [i]*ux(x)^(i-1), i=1..4):
gxnl := x -> add(params_a_cx_nlocal[i]*ux(x)^(i-1), i=1..4):

f    := (rs, x, t, u) -> gxl(x) + gxnl(x)*mgga_series_w(coeff_a, 6, t):


# Suppose that u is in Lie(A), and that a is in A.  Then there is a unique
# way to express u as a linear combination of fully right associated words
# with a as the last term.  The function below calculates this.

`comb/lie_operad` := (a) -> proc(u)
 local x,y,z,n,ub,uc,t;
 if u = 0 then
  return 0;
 elif type(u,`+`) or type(u,list) or type(u,set) then
  return map(`comb/lie_operad`(a),u);
 elif type(u,`*`) then
  ub,uc := selectremove(type,[op(u)],specfunc(bracket));
  if nops(ub) <> 1 then
   return FAIL;
  fi;
  ub := ub[1];
  uc := `*`(op(uc));
  return(uc * `comb/lie_operad`(a)(ub));
 elif type(u,specfunc(bracket)) then
  n := nops(u);
  if n = 0 then
   return FAIL;
  fi;
  if n = 1 then
   if op(u) = a then
    return u;
   else
    return FAIL;
   fi;
  else
   x := op(1,u);
   y := op(2,u);
   z := op(3..n,u);
   if x = a then
    if n = 2 then
     return -bracket(y,x);
    else
     return `comb/lie_operad`(a)(bracket(y,bracket(a,z))) -
      eval(subs(t = bracket(y,a),`comb/lie_operad`(t)(bracket(t,z))));
    fi;
   elif has(x,a) then
    return eval(subs(t = `comb/lie_operad`(a)(x),
                     `comb/lie_operad`(t)(bracket(t,y,z))));
   else
    return bracket(x,`comb/lie_operad`(a)(bracket(y,z)));
   fi;
  fi;
 fi;
end:

# This returns the basis consisting of fully right associated words
# ending with a.

`basis/lie_operad` := proc(A::set,a_)
 local a,B;

 a := `if`(nargs > 1,a_,A[nops(A)]);
 if not member(a,A) then
  error "a not in A";
 fi;

 B := A minus {a};
 return map(u -> bracket(op(u),a),`list_elements/ord`(B));
end:

`vec0/lie_operad` := (A::set,a) -> proc(u)
 local n,m,ub,uc,T,B,i;
 global `vec_table/lie_operad`;

 n := nops(A);
 m := (n-1)!;
 if u = 0 then
  return [0$m];
 elif type(u,`+`) then
  return map(`vec0/lie_operad`(A,a),u);
 else
  if type(u,specfunc(bracket)) then
   ub := u;
   uc := 1;
  elif type(u,`*`) then
   ub,uc := selectremove(type,[op(u)],specfunc(bracket));
   if nops(ub) <> 1 then
    return FAIL;
   fi;
   ub := ub[1];
   uc := `*`(op(uc));
  else
   return FAIL;
  fi;
  if not(type(`vec_table/lie_operad`[A,a],table)) then
   T := table():
   B := `basis/lie_operad`(A,a);
   for i from 1 to m do
    T[B[i]] := [0$(i-1),1,0$(m-i)];
   od:
   `vec_table/lie_operad`[A,a] := eval(T);
  fi;
  return uc *~ `vec_table/lie_operad`[A,a][ub];
 fi;
end:

`vec/lie_operad` := (A::set,a) -> proc(u)
 `vec0/lie_operad`(A,a)(`comb/lie_operad`(a)(u));
end:

# This returns an alternative basis for Lie(X[n]), where
# X[n] = {x[1],...,x[n]}.  The basis elements for Lie(X[n]) are
# obtained from those for Lie(X[n-1]) by substitutions of the
# form x[i] |-> [x[i],x[n]].  Note that we use the inert Bracket
# operation to prevent automatic expansion by the Jacobi identity.
# One can convert using eval(subs(Bracket = bracket,...))

`alt_basis/lie_operad` := proc(n::nonnegint)
 option remember;
 local i,u;

 if n = 0 then
  return [];
 elif n = 1 then
  return [x[1]];
 else
  return [seq(seq(subs(x[i]=Bracket(x[i],x[n]),u),i=1..n-1),u in `alt_basis/lie_operad`(n-1))];
 fi;
end:


# Display contents of the packages since
# we might use them latter
with(LinearAlgebra):
with(Groebner):

writeto("output.txt"):

#F := [x^3 + 12, 2*y^2 - x]:
#a, b := Basis(F, plex(x, y), output=extended):

#simplify(Multiply(convert(b, Matrix), Transpose(convert(F, Matrix)))):
#simplify(Transpose(convert(a, Matrix))):

#_m_order_1 = [[1, 0, 0], [0, 1, 0], [0, 0, 1]]:
#order_1 = 'matrix'(_m_order_1, [x, y, z]):

#f_example_monomial_order := proc (poly, order_1::{MonomialOrder, ShortMonomialOrder})
#return sort([op(poly)], (b, a) -> TestOrder(a, b, order_1))
#end proc:

#F := 1/2*x + 2*y*z:

#print(f_example_monomial_order(F, 'matrix'([[1,0,0],[0,1,0],[0,0,1]], [x, y, z])        )):
#print(f_example_monomial_order(F, plex(x, y, z)   )):
#print(f_example_monomial_order(F, grlex(x, y, z)  )):

# ---------------------------------------------------------------------------
truncatePolynomial := proc (poly, order_1, order_2)
local leading_coeff_1, leading_mon_1, leading_term, curr_index, polys:

    leading_coeff_1, leading_mon_1 := LeadingTerm(poly, order_1):
    leading_term                   := leading_coeff_1 * leading_mon_1:
    curr_index                     := 1:

    polys := sort([op(poly)], (b, a) -> TestOrder(a, b, order_2)):

    while evalb(polys[curr_index] <> leading_term) do
        curr_index := curr_index + 1:
    end do:

    if curr_index = 1 then
        return polys[1]:
    else
        return add(x, x in polys[1..curr_index]):
    end if:
end proc:
# ---------------------------------------------------------------------------

# ---------------------------------------------------------------------------
# Test truncatePolynomial
print( truncatePolynomial(x^2 - y*z + 1, grlex(x, y, z), plex(x, y, z)) ):
print( truncatePolynomial(y^2 - x, grlex(x, y, z), plex(x, y, z)) ):
# ---------------------------------------------------------------------------

basisConversion := proc (basis, order_1, order_2)
local F, F_t, num_iter, F_t_gb, multipliers, G, repeat, curr_index, num_elements:

    print("Step 1"):
    F   := Basis(basis, order_1):
    F_t := map(v -> truncatePolynomial(v, order_1, order_2), F):
    print("Current F", F):
    print("Current F_t", F_t):

    num_iter := 1:

    while true do
        print("Iteration ", num_iter):
        num_iter := num_iter + 1:

        print("Step 3 & 4"):
        F_t_gb, multipliers := Basis(F_t, order_2, output=extended):
        print("Matrix of multipliers M': ", multipliers):
        print("H (= M' F_t): ", F_t_gb):

        print("Step 5"):
        G := convert(simplify(Multiply(convert(multipliers, Matrix), Transpose(convert(F, Matrix)))), list):
        print("G (= M' * F): ", G):

        print("Step 6 and 7"):
        repeat := false:
        curr_index := 1:
        num_elements := numelems(F_t_gb):
        while curr_index < num_elements do
            if evalb(LeadingMonomial(F_t_gb[curr_index], order_2) <> LeadingMonomial(G[curr_index], order_2)) then
                print("There are the witness polynomials that prove G_s is not empty (g_j, h_j) ", F_t_gb[curr_index], G[curr_index]):
                repeat := true:
                break:
            end if:
            curr_index := curr_index + 1:
        end do:

        if repeat = false then
            print("Done"):
            return InterReduce(G, order_2):
        else
            F := G:
            F_t := map(v -> truncatePolynomial(v, order_1, order_2), F):
        end if:
    end do:

end proc:

# ---------------------------------------------------------------------------
# Test basisConversion
print( basisConversion([y^2-x,x^2-y*z-1,z^2-x], grlex(x, y, z), plex(x, y, 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: gga_exc *)
(* prefix:
  gga_k_dk_params *params;

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

dk_f := x ->
  add(params_a_aa[i]*x^(2*(i-1)), i=1..5) /
  add(params_a_bb[i]*x^(2*(i-1)), i=1..5):

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


 # a function returning (i + j) * -998
 func $foo (
# var %i xxx,
  var %i i32,
   var %j i32) i32 {
   return (
     mul i32 (
       add i32 ( dread i32 %i, dread i32 %j),
       constval i32 -998))}

 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


ctfm_expr :=  exp(x) - exp(lv) + ((1/(1-x/rv) - 1/(1-lv/rv)))^(rv-x+1) ;
ctfmp_expr := ((diff(ctfm_expr,x)));
octfmp_expr := -(diff(1/ctfmp_expr,x));

read ("/home/arman/FD/FD.mpl"):
MFD(); grid_functions:={};
Gen_Eval_Code(ctfm_expr,input="c",proc_name="init_ctfm2");
Gen_Eval_Code(ctfmp_expr,input="c",proc_name="init_ctfmp2");
Gen_Eval_Code(octfmp_expr,input="c",proc_name="init_octfmp2");