(*
 Copyright (C) 2020 Susi Lehtola

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

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

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

lk_p := x -> X2S^2*x^2:
lk_q := u -> X2S^2*u:

(* Equation (10) *)
lk_delta := (p, q) -> 8/81*q^2 - 1/9*p*q + 8/243*p^2:
(* Equation (15) *)
lk_f0 := (x1, x2) -> 1 + params_a_kappa*(2 - 1/(1+x1/params_a_kappa) - 1/(1+x2/params_a_kappa)):
(* Equation (16) *)
lk_x1 := (p, q) -> 5/27*p + lk_delta(p,q) + (5/27*p)^2/params_a_kappa:
(* Equation (17) *)
lk_x2 := (p, q) -> 2*(5/27*p)*lk_delta(p,q)/params_a_kappa + (5/27*p)^3/params_a_kappa^2:

(* Full functional *)
lk_f := (x, u) ->
  lk_f0(lk_x1(lk_p(x),lk_q(u)), lk_x2(lk_p(x),lk_q(u))):

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


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

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

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

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

pc07_p := x -> X2S^2*x^2:
pc07_q := u -> X2S^2*u:

(* Equation (15) redefined with decaying exponentials to avoid inf/inf situations *)
pc07_fab0 := z -> exp(-params_a_a*params_a_b/z) * (1+exp(-params_a_a/(params_a_a-z)))^params_a_b/(exp(-params_a_a/z) + exp(-params_a_a/(params_a_a-z)))^params_a_b:
(* The function is ill-behaving at z=0 and z=a.
   However, it also goes to 0 and 1 very quickly near these points.
   pc07_fab0(params_a_a/40) is ~ 1.6e-17, which is smaller than machine epsilon.
*)
pc07_thr := 1/40:
pc07_zlo := pc07_thr*params_a_a:
pc07_zhi := (1-pc07_thr)*params_a_a:
pc07_fab := z -> my_piecewise5(z<=pc07_zlo, 0, z>=pc07_zhi, 1, pc07_fab0( m_min(pc07_zhi, m_max(pc07_zlo, z)) ) ):

(* Equation (7) *)
pc07_Delta := (x, u) ->
  8*pc07_q(u)^2/81 - pc07_p(x)*pc07_q(u)/9 + 8*pc07_p(x)^2/243:

pc07_f_W    := x -> 5*pc07_p(x)/3:

(* Equation (8) *)
pc07_GE4  := (x, u) ->
  1 + 5*pc07_p(x)/27 + 20*pc07_q(u)/9 + pc07_Delta(x, u):

(* Equation (11) *)
pc07_GE4_M := (x, u) ->
  pc07_GE4(x, u)/sqrt(1 + pc07_Delta(x, u)^2/(1 + pc07_f_W(x))^2):

(* Equation (17) *)
pc07_f := (x, u) ->
  pc07_f_W(x) + (pc07_GE4_M(x, u) - pc07_f_W(x))*pc07_fab(pc07_GE4_M(x, u) - pc07_f_W(x)):

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


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

`is_element/partord` := (A::set) -> proc(R)
 global reason;

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

 if not(`is_reflexive/autorel`(A)(R)) then
  reason := ["is_element/partord","R is not reflexive",R];
  return false;
 fi;

 if not(`is_transitive/autorel`(A)(R)) then
  reason := ["is_element/partord","R is not transitive",R];
  return false;
 fi;

 if not(`is_separated/autorel`(A)(R)) then
  reason := ["is_element/partord","R is not separated",R];
  return false;
 fi;

 return true;
end;

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

`is_equal/partord`     := eval(`is_equal/autorel`);
`is_leq/partord`       := eval(`is_leq/autorel`);
`is_separated/partord` := eval(`is_separated/autorel`);

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

`op/partord` := eval(`op/autorel`);

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

`random_element/partord` := (A::set) -> proc()
 local M,B,E,RB,RA,DS,xy,x,y,d,m,a,e;
 if nops(A) <= 1 then return {seq([a,a],a in A)}; fi;

 M := `random_element/nonempty_subsets`(A)();
 B := A minus M;
 RB := `random_element/partord`(B)();
 DS := `list_elements/subsets`(B);
 for xy in RB do
  x,y := op(xy);
  if x <> y then
   DS := select(S -> (member(x,S) or not(member(y,S))),DS);
  fi;
 od;
 d := nops(DS);
 RA := RB union {seq([m,m],m in M)};
 for m in M do
  E := DS[rand(1..d)()];
  RA := RA union {seq([e,m],e in E)};
 od;

 return RA;
end:

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

`top_element/partord` := (A) -> proc(R)
 local n,a,U;
 n := nops(A);
 for a in A do
  U := select(e -> e[2] = a,R);
  if nops(U) = n then
   return a;
  fi;
 od:

 return FAIL;
end:

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

`bottom_element/partord` := (A) -> proc(R)
 local n,a,U;
 n := nops(A);
 for a in A do
  U := select(e -> e[1] = a,R);
  if nops(U) = n then
   return a;
  fi;
 od:

 return FAIL;
end:

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

`rank_table/partord` := (A::set) -> proc(R)
 local pi,pi0,a,b,r,k,B;

 r := table():
 for a in A do
  r[a] := nops(select(x -> member([x,a],R),A)) - 1;
 od;

 return eval(r);
end;

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

`hasse_diagram/partord` := (A::set) -> proc(R)
 local R1,R2;
 R1 := R minus `id/autorel`(A);
 R2 := `o/autorel`(A)(R1,R1);
 return R1 minus R2;
end:

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

`maximal_chains/partord` := (A::set) -> proc(R)
 local H,LC,UC,a,C,C0,extra,c,u;

 H := `hasse_diagram/partord`(A)(R);
 LC := table():
 UC := table():
 for a in A do
  LC[a] := map(e -> e[1],select(e -> e[2] = a,H));
  UC[a] := map(e -> e[2],select(e -> e[1] = a,H));
 od:

 C := map(a -> [a],select(a -> LC[a] = {},A));
 extra := true;
 while extra do
  extra := false;
  C0 := C;
  C := NULL;
  for c in C0 do
   u := UC[c[-1]];
   if u = {} then
    C := C,c;
   else
    C := C,seq([op(c),a],a in u);
    extra := true;
   fi;
  od:
  C := {C};
 od;

 return C;
end:

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

`partord_is_leq` := (A::set) -> (R) -> (a,b) -> member([a,b],R);

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

`partord_is_equiv` := (A::set) -> (R) -> (a,b) ->
  member([a,b],R) and member([b,a],R);

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

`partord_is_less` := (A::set) -> (R) -> (a,b) ->
  member([a,b],R) and not(member([b,a],R));

######################################################################
# Returns [A0,R0] where A0 is of the form {1,...,n} and
# (A0,R0) is isomorphic to (A,R).

`skeleton/partord` := (A::set) -> proc(R)
 local n,i,A0,Ai,R0;
 n := nops(A);
 A0 := {seq(i,i=1..n)};
 Ai := table():
 for i from 1 to n do Ai[A[i]] := i; od;
 R0 := map(u -> [Ai[u[1]],Ai[u[2]]],R);
 return [A0,R0];
end:

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

`partord/from_comparator` := (A::set) -> proc(C)
 local R,a,b;

 R := {seq(seq([a,b],b in A),a in A)};
 R := select(ab -> C(op(ab)),R);

 return [A,R];
end:

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

`skeleton/partord/from_comparator` := (A::{set,list}) -> proc(C)
 local n,i,j,A0,R0;

 n := nops(A);
 A0 := {seq(i,i=1..n)};
 R0 := {seq(seq([i,j],j = 1..n),i = 1..n)};
 R0 := select(ij -> C(A[ij[1]],A[ij[2]]),R0);

 return [A0,R0];
end:

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

`homology/partord` := (A::set) -> proc(R,p::nonnegint := 0)
 local U,C,Cn,Ci,dM,rdM,BN,H,c,c1,d,d_max,a,i,i1,j,k,t;

 U := table():
 for a in A do
  U[a] := select(b -> (b <> a and member([a,b],R)),A):
 od:
 C[0] := [seq(chain(a),a in A)]:
 d := 0;
 while C[d] <> [] do
  d := d+1;
  C[d] := [seq(seq(chain(op(c),a),a in U[op(d,c)]),c in C[d-1])]:
 od:
 d_max := d - 1;
 for d from 0 to d_max do
  Cn[d] := nops(C[d]):
  Ci[d] := table():
  for i from 1 to nops(C[d]) do
   Ci[d][C[d][i]] := i;
  od:
 od:

 dM := table():
 rdM := table():
 rdM[0] := 0;
 rdM[d_max+1] := 0;

 for d from 1 to d_max do
  dM[d] := Matrix(Cn[d-1],Cn[d]);
  for i from 1 to Cn[d] do
   c := [op(C[d][i])];
   for j from 0 to d do
    c1 := chain(seq(c[k+1],k=0..j-1),seq(c[k+1],k=j+1..d));
    i1 := Ci[d-1][c1];
    dM[d][i1,i] := (-1)^j;
   od:
  od:
  if p = 0 then
   rdM[d] := LinearAlgebra[Rank](dM[d]);
  else
   rdM[d] := LinearAlgebra[Modular][Rank](p,dM[d]);
  fi;
 od:

 BN := table():
 for d from 0 to d_max do
  BN[d] := Cn[d] - rdM[d] - rdM[d+1];
 od:

 H := table():
 H["characteristic"] := p;
 H["dim"] := d_max;
 H["chains"] := eval(C);
 H["chain_index"] := eval(Ci);
 H["differential_matrix"] := eval(dM);
 H["chain_number"] := eval(Cn);
 H["betti_number"] := eval(BN):
 H["poincare_series"] := unapply(add(BN[i]*t^i,i=0..d_max),t);
 H["euler_characteristic"] := add((-1)^d * BN[d],d = 0..d_max):

 return eval(H):
end:

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

`simplex/partord` := proc(n)
 local i,j;
 return [{seq(i,i=0..n)},{seq(seq([i,j],j=i..n),i=0..n)}];
end:

`crown/partord` := proc(n)
 local A,R,i;
 A := {seq(i,i=1..2*n)};
 R := {seq([i,i],i=1..2*n),
       seq([2*i-1,2*i],i=1..n),
       seq([2*i+1,2*i],i=1..n-1),
       [1,2*n]};
 return [A,R];
end:

`saw/partord` := proc(n)
 local A,R,i;
 A := {seq(i,i=1..n)};
 R := {seq([i,i],i=1..n),
       seq([2*i-1,2*i],i=1..floor(n/2)),
       seq([2*i+1,2*i],i=1..floor((n-1)/2))};
 return [A,R];
end:

`diamond/partord` := proc(n)
 local A,R,i,j;

 A := {seq(i,i=1..2*n)};
 R := {seq([i,i],i=1..2*n),
       seq(seq([2*i-1,j],j=2*i+1..2*n),i=1..n),
       seq(seq([2*i  ,j],j=2*i+1..2*n),i=1..n)};
 return [A,R];
end:


restart;
kernelopts(printbytes=false):
partitions := proc(c::list(integer),subtotal::integer) :: integer:
  local i,m,total,cards;
  cards := c;
  m := 0;
  # Hit
  for i from 1 to 10 do
    if (cards[i]>0) then
      total := subtotal+i;
      if (total < 21) then
        # Stand
        m := m+1;
	# Hit again
        cards[i] := cards[i]-1;
        m := m+partitions(cards, total);
        cards[i] := cards[i]+1;
      elif (total=21) then
        # Stand; hit again is an automatic bust
        m := m+1;
      end if;
    end if;
  end do;
  return m;
end proc:

deck := [4,4,4,4,4,4,4,4,4,16]:
d := 0:

for i from 1 to 10 do
  # Dealer showing
  p := 0:
  deck[i] := deck[i]-1:
  for j from 1 to 10 do
    deck[j] := deck[j]-1:
    p := p+partitions(deck,j):
    deck[j] := deck[j]+1:
  end do:
  deck[i] := deck[i]+1:
  printf("Dealer showing %d partitions = %d\n",i-1,p):
  d := d+p:
end do:
printf("Total partitions = %d\n",d):


check_koszul := proc()
 local A,n,dA,u,J,i;

 printf("%a()\n",procname);

 A := <<1|5|4|9>,<2|2|7|5>,<3|9|9|6>,<4|3|2|1>>;
 n := Dimension(A)[1];
 dA := Determinant(A);
 u := [4,5,6,11];

 J := Matrix(n,n);
 for i from 1 to n do J[i,n+1-i] := (-1)^(i-1); od;

 _ASSERT(
  Equal(koszul_adjoint(0,A), <<Determinant(A)>>),
  "koszul adjoint(0,A) = det(A)"
 );

 _ASSERT(
  Equal(koszul_adjoint(1,A), Adjoint(A)),
  "koszul_adjoint(1,A) = adj(A)"
 );

 _ASSERT(
  Equal(koszul_adjoint(n-1,A), Transpose((-1)^(n-1) * J . A . J)),
  "koszul_adjoint(n-1,A) is conjugate to A^T"
 );

 _ASSERT(
  Equal(koszul_adjoint(n,A), <<1>>),
  "koszul_adjoint(n,A) = 1"
 );

 _ASSERT(
  `and`(seq(Equal(exterior_power(k,A) . koszul_adjoint(k,A),
                  dA * IdentityMatrix(binomial(n,k))),k=0..n)),
  "exterior_power(k,A) o koszul_adjoint(k,A) = det(A) in all degrees"
 );

 _ASSERT(
  `and`(seq(Equal(koszul_d(k,u) . koszul_d(k+1,u),
                  Matrix(binomial(n,k-1),binomial(n,k+1))),k=1..n-1)),
  "koszul_d ^ 2 = 0"
 );
end:

check_koszul_comparison := proc()
 global v,n,u_vec,v_vec,w_vec,x_vec,x_vars,Iv,Mv,Nv,
        soc_u,soc_v,soc_w,A,B,p;

 v := [x[1]^2+x[2]^3,x[1]*x[2]+x[3],x[1]^4-x[3]^2*x[2],x[4]-x[2]^3];
 koszul_setup(v);

 _ASSERT(
  Equal(map(koszul_pmod,map(expand,u_vec)),
        map(koszul_pmod,map(expand,v_vec . A))),
  "u = v . A"
 );

 _ASSERT(
  Equal(map(koszul_pmod,map(expand,v_vec)),
        map(koszul_pmod,map(expand,w_vec . B))),
  "v = w . B"
 );

 _ASSERT(
   Equal(map(koszul_pmod,map(Nv,soc_v * x_vec)),Transpose(Vector(n))),
   "soc_v is in the socle"
 );

 _ASSERT(
   not(koszul_pmod(Nv(soc_v)) = 0),
   "soc_v is nonzero"
 );

 _ASSERT(
  `and`(seq(
   Equal(map(expand,koszul_d(k,v_vec) . exterior_power(k,A)),
	 map(expand,exterior_power(k-1,A) . koszul_d(k,u_vec))),
   k=1..n
  )),
  "exterior_power(*,A) is a chain map"
 );

 _ASSERT(
  `and`(seq(
   Equal(map(expand,koszul_d(k,w_vec) . exterior_power(k,B)),
	 map(expand,exterior_power(k-1,B) . koszul_d(k,v_vec))),
   k=1..n
  )),
  "exterior_power(*,B) is a chain map"
 );

 _ASSERT(
  `and`(seq(
   Equal(map(expand,koszul_d(k,u_vec) . koszul_adjoint(k,A)),
	 map(expand,koszul_adjoint(k-1,A) . koszul_d(k,v_vec))),
   k=1..n
  )),
  "koszul_adjoint(*,A) is a chain map"
 );

 _ASSERT(
  `and`(seq(
   Equal(map(expand,koszul_d(k,v_vec) . koszul_adjoint(k,B)),
	 map(expand,koszul_adjoint(k-1,B) . koszul_d(k,w_vec))),
   k=1..n
  )),
  "koszul_adjoint(*,B) is a chain map"
 );

end:


######################################################################
# simplex(A) is the set of maps x : A -> [0,1] with sum = 1.

`is_element/simplex` := (A::set) -> proc(x)
 local a,u,v;
 global reason;

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

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

 v := 0;
 for a in A do
  u := x[a];
  if not (`is_element/RR`(u) and u >= 0 and u <= 1) then
   reason := [convert(procname,string),"x[a] is not in the unit interval",a,u];
   return false;
  fi;

  v := v + u;
 od;

 if simplify(v - 1) <> 0 then
  reason := [convert(procname,string),"entries in x do not sum to 1",x,v];
  return false;
 fi;

 return true;
end;

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

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

`is_leq/simplex` := NULL;

`random_element/simplex` := (A::set) -> proc(d::posint := 5)
 local x,a,r1,r2,u;
 if A = {} then return FAIL; fi;

 r1 := rand(0..d);
 r2 := rand(1..d);
 x := table();
 u := 0;
 while u = 0 do
  for a in A do
   x[a] := r1()/r2();
   u := u + x[a];
  od;
 od;

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

 return eval(x);
end;

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


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

`is_element/height_functions` := (A::set) -> proc(h)
 local P,U,V,a,u;
 global reason;

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

 P := {op(`list_elements/nonempty_subsets`(A))};
 if map(op,{indices(h)}) <> P then
  reason := [convert(procname,string),"h is not indexed by the nonempty subsets of A",h,A];
  return false;
 fi;

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

 for U in P do
  u := h[U];
  if not (`is_element/RR`(u) and u >= 0 and u <= 1) then
   reason := [convert(procname,string),"h(U) is not in the unit interval",U,u];
   return false;
  fi;
 od;

 for U in P do
  for V in P do
   if U intersect V <> {} and
      h[U union V] <> max(h[U],h[V]) then
    reason := [convert(procname,string),"h(U u V) <> max(h(U),h(V))",U,V,h[U],h[V],h[U union V]];
    return false;
   fi;
  od;
 od;

 return true;
end;

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

`is_equal/height_functions` := (A::set) -> proc(h1,h2)
 local P,U;
 P := `list_elements/nonempty_subsets`(A);
 for U in P do
  if h1[U] <> h2[U] then return false; fi;
 od;
 return true;
end;

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

`is_leq/height_functions` := NULL;

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

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

`is_critical/height_functions` := (A::set) -> proc(h,U)
 local V,a;

 V := A minus U;

 if V = {} then return evalb(h[A] < 1); fi;

 for a in V do
  if h[U union {a}] = h[U] then return false; fi;
 od;

 return true;
end;

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

`critical_tree/height_functions` := (A::set) -> proc(h)
 local P;

 P := `list_elements/nonempty_subsets`(A);

 return {op(select(U ->`is_critical/height_functions`(A)(h,U),P))};
end;

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

`theta/partitions/height_functions` := (A::set) -> proc(pi)
 local h,P,T,B,Q;

 h := table();
 P := `list_elements/nonempty_subsets`(A);
 for T in P do h[T] := 1; od;
 for B in pi do
  Q := `list_elements/nonempty_subsets`(B);
  for T in Q do h[T] := 0; od;
 od;

 return eval(h);
end;

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

`theta/realisation/partitions/height_functions` := (A::set) -> proc(x)
 local P,T,C,pi,t,k,h;

 h := table();
 P := `list_elements/nonempty_subsets`(A);
 for T in P do h[T] := 0; od;

 C := map(op,[indices(x)]);

 for pi in C do
  t := x[pi];
  k := `theta/partitions`(A)(pi);
  for T in P do
   h[T] := h[T] + t * k[T];
  od;
 od;

 return eval(h);
end:

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

`theta_inv/realisation/partitions/height_functions` := (A::set) -> proc(h)
 local TT,TTT,S,r,s,t,x,U,X,Y,pi,a,m,i;

 TT := `critical_tree/height_functions`(A)(h);
 S := map(T -> h[T],TT) minus {1};
 r := nops(S) - 1;
 s := table();
 s[-1] := 1;
 for i from 0 to r do s[i] := S[r+1-i]; od;
 TTT := table();
 x := table();
 for i from 0 to r do
  TTT[i] := select(U -> h[U] <= s[i],TT);
  X := TTT[i];
  pi[i] := {};
  while X <> {} do
   a := X[1][1];
   Y := select(T -> member(a,T),X);
   m := max(map(nops,Y));
   U := select(T -> nops(T) = m,Y)[1];
   pi[i] := {op(pi[i]),U};
   X := X minus Y;
  od;
  x[pi[i]] := s[i-1] - s[i];
 od;

 return eval(x);
end:


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

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

(* type: work_gga_x *)

ad  := 1e-8:
b   := 0.024974:
a2  := (ad + 0.1234)/b:
a4  := 29.790:
a6  := 22.417:
a8  := 12.119:
a10 := 1570.1:
a12 := 55.944:

f0 := s-> 1 + a2*s^2 + a4*s^4 + a6*s^6 + a8*s^8 + a10*s^10 + a12*s^12:
f1 := s-> f0(s)^b/(1 + ad*s^2):

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


DV := NumberTheory[Divisors]:

ghost_coeff := (n) -> proc(x)
 local d;
 return add(d * x[d]^(n/d), d in DV(n));
end:

ghost_vector := (n::posint) -> proc(x)
 local m;
 return [seq(ghost_coeff(m)(x),m=1..n)];
end:

unghost_vector := (n::posint) -> proc(w)
 local x,m,d;
 x := []:
 for m from 1 to n do
  x := [op(x),expand((w[m] - add(d*x[d]^(m/d),d in DV(m) minus {m}))/m)];
 od:
 return x;
end:

witt_add_term := proc(n::posint)
 option remember;
 local x,y,u,d,rel;

 for d in DV(n) minus {n} do
  u[d] := witt_add_term(d)(x,y);
 od:

 rel := ghost_coeff(n)(u) - ghost_coeff(n)(x) - ghost_coeff(n)(y);
 u[n] := expand(solve(rel,u[n]));
 return unapply(u[n],x,y);
end:

witt_add := (n::posint) -> proc(x,y)
 local m;
 return [seq(witt_add_term(m)(x,y),m=1..n)];
end:

witt_mult_term := proc(n::posint)
 option remember;
 local x,y,u,d,rel;

 for d in DV(n) minus {n} do
  u[d] := witt_mult_term(d)(x,y);
 od:

 rel := ghost_coeff(n)(u) - ghost_coeff(n)(x) * ghost_coeff(n)(y);
 u[n] := expand(solve(rel,u[n]));
 return unapply(u[n],x,y);
end:

witt_mult := (n::posint) -> proc(x,y)
 local m;
 return [seq(witt_mult_term(m)(x,y),m=1..n)];
end:

witt_series := (n::posint) -> proc(x)
 local m;
 return expand(rem(mul(1 - x[m]*t^m,m=1..n),t^(n+1),t));
end:

witt_unseries := (n::posint) -> proc(f)
 local c,g,d;
 c := []:
 g := f;
 for d from 1 to n do
  c := [op(c),-coeff(g,t,d)];
  g := expand(convert(series(g/(1-c[d]*t^d),t=0,n+1),polynom,t));
 od:
 return c;
end:

ghost_p_coeff := (n) -> proc(x)
 local i;
 return add(p^i * x[i]^(p^(n-i)), i=0..n);
end:

ghost_p_vector := (n::nonnegint) -> proc(x)
 local i;
 return table([seq(i = ghost_p_coeff(i)(x),i=0..n-1)]);
end:

ghost_p_add := (n::nonnegint) -> proc(a,b)
 local i;
 return table([seq(i=expand(a[i]+b[i]),i=0..n-1)]);
end:

ghost_p_sub := (n::nonnegint) -> proc(a,b)
 local i;
 return table([seq(i=expand(a[i]-b[i]),i=0..n-1)]);
end:

ghost_p_mult := (n::nonnegint) -> proc(a,b)
 local i;
 return table([seq(i=expand(a[i]*b[i]),i=0..n-1)]);
end:

ghost_p_is_equal := (n::nonnegint) -> proc(a,b)
 local i;
 return `and`(seq(evalb(simplify(a[i]-b[i])=0),i=0..n-1));
end:

unghost_p_vector := (n::nonnegint) -> proc(w)
 local x,m,k;
 x := table:
 for m from 0 to n-1 do
  x[m] := expand((w[m] - add(p^k*x[k]^(p^(m-k)),k=0..m-1))/p^m);
 od:
 return eval(x);
end:

witt_p_add_term := proc(n::nonnegint)
 option remember;
 local x,y,u,m,rel;
 u := table():
 for m from 0 to n-1 do
  u[m] := witt_p_add_term(m)(x,y);
 od:

 rel := ghost_p_coeff(n)(u) - ghost_p_coeff(n)(x) - ghost_p_coeff(n)(y);
 u[n] := expand(solve(rel,u[n]));
 return unapply(u[n],x,y);
end:

witt_p_add := (n::posint) -> proc(x,y)
 local m;
 return table([seq(m=witt_p_add_term(m)(x,y),m=0..n-1)]);
end:

witt_p_mult_term := proc(n::nonnegint)
 option remember;
 local x,y,u,m,rel;
 u := table():
 for m from 0 to n-1 do
  u[m] := witt_p_mult_term(m)(x,y);
 od:

 rel := ghost_p_coeff(n)(u) - ghost_p_coeff(n)(x) * ghost_p_coeff(n)(y);
 u[n] := expand(solve(rel,u[n]));
 return unapply(u[n],x,y);
end:

witt_p_mult := (n::posint) -> proc(x,y)
 local m;
 return table([seq(m=witt_p_mult_term(m)(x,y),m=0..n-1)]);
end:


program sample29;
var unused1 : integer;
    UnusedArrayForTest : array[200] of char;
procedure gcmlcm(m, n, gc, lc : integer);
var a, b, r : integer;
    begin
        a := m;
        b := n;
        while b <> 0 do begin
            r := a - (a div b) * b;
            a := b;
            b := r
        end;
        gc := a;
        lc := (m div gc) * n
    end;
procedure abs(a, b : integer);
        if a < 0 then
            b := -a
        else
            b := a
    end;
procedure gcm(a, b, gc : integer);
var lc, aa, bb : integer;
        if (a = 0) or (b = 0) then
            gc := 1
        else
                call abs(a, aa);
                call abs(b, bb);
                call gcmlcm(aa, bb, gc, lc)
            end
    end;
procedure lcm(a, b, lc : integer);
var gc, aa, bb : integer;
        if (a = 0) or (b = 0) then
            lc := 1
        else
                call abs(a, aa);
                call abs(b, bb);
                call gcmlcm(aa, bb, gc, lc)
            end
    end;
var unusedchar : char;
procedure reduce(a1, a2 : integer);
var gc : integer;
        if a1 = 0 then
                a2 := 1;
                return
            end;
        if a2 = 0 then
                a1 := 1;
                return
            end;
        if a2 < 0 then
                a1 := -a1;
                a2 := -a2
            end;
        call gcm(a1, a2, gc);
        a1 := a1 div gc;
        a2 := a2 div gc
    end;
procedure sum(x1, x2, y1, y2 : integer);
var lc, y11 : integer;
        call lcm(x2, y2, lc);
        x1 := x1 * (lc div x2);
        y11 := y1 * (lc div y2);
        x1 := x1 + y11;
        x2 := lc;
        call reduce(x1, x2)
    end;
procedure sub(x1, x2, y1, y2 : integer);
var lc, y11 : integer;
        call sum(x1, x2, -y1, y2)
    end;
procedure mult(x1, x2, y1, y2 : integer);
var gc, y22, y11 : integer;
        call gcm(x1, y2, gc);
        x1 := x1 div gc;
        y22 := y2 div gc;
        call gcm(x2, y1, gc);
        x2 := x2 div gc;
        y11 := y1 div gc;
        x1 := x1 * y11;
        x2 := x2 * y22;
        call reduce(x1, x2)
    end;
procedure divide(x1, x2, y1, y2 : integer);
        call mult(x1, x2, y2, y1)
    end;
var unusedarray : array[100] of char;
procedure printfinal(a, b : integer);
        if a = 0 then
            writeln('Final Result =', a)
        else if b = 1 then
            writeln('Final Result =', a)
        else
            writeln('Final Result =', a, '/', b)
    end;
procedure printtemp(a, b : integer);
        if a = 0 then
            writeln('Temporary Result =', a)
        else if b = 1 then
            writeln('Temporary Result =', a)
        else
            writeln('Temporary Result =', a, '/', b)
    end;
var x1, x2, y1, y2 : integer;
var com : char;
    endflag : boolean;
    writeln('   *** Calculator -- h for help ***');
    x1 := 0;
    x2 := 1;
    endflag := false;
    while notendflag do begin
        writeln(' Please input command :');
        readln(com,y1);
        y2 := 1;
        if (com = 'c') or (com = 'C') then
                x1 := y1;
                x2 := y2
            end
        else if com = '+' then
            call sum(x1, x2, y1, y2)
        else if com = '-' then
            call sub(x1, x2, y1, y2)
        else if com = '*' then
            call mult(x1, x2, y1, y2)
        else if com = '/' then
            call divide(x1, x2, y1, y2)
        else if (com = 'o') or (com = 'O') then
            endflag := true
        else
                writeln;
                writeln('Calculator Usage:');
                writeln('  c number : clear & set it');
                writeln('  + number : add it');
                writeln('  - number : subtract it');
                writeln('  * number : multiply it');
                writeln('  / number : divide by it');
                writeln('  o        : off(terminate execution)');
                writeln
            end;
        if endflag then
            call printfinal(x1, x2)
        else
            call printtemp(x1, x2)
    end
end.


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

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

(* type: gga_exc *)

$include "gga_c_tca.mpl"

msinc := x -> my_piecewise3(x = 0, 1, sin(x)/x):
revtca_aa := Pi*(9*Pi/4)^(1/3):

revtca_fD := (rs, z, s) -> 1 - z^4*(1 - msinc(revtca_aa*s/rs)^2):

f := (rs, z, xt, xs0, xs1) ->
  f_tcs(rs, z, xt)*revtca_fD(rs, z, X2S*2^(1/3)*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: gga_exc *)

hcth_a_beta  :=  0.0042:
hcth_a_gamma :=  6:
hcth_a_c0    :=  1.09878:
hcth_a_c1    := -2.51173:
hcth_a_c2    :=  0.0156233:

hcth_a_aux := x -> 1 + hcth_a_gamma*hcth_a_beta*x*arcsinh(x):

hcth_a_f := x -> hcth_a_c0 + hcth_a_beta/X_FACTOR_C*x^2*(hcth_a_c1/hcth_a_aux(x)
     + hcth_a_c2/(hcth_a_beta*hcth_a_aux(x)^2)):

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


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

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

(* type: lda_exc *)

$define xc_dimensions_1d

eta0 := -log(sqrt(2*Pi)) - 3/4:
eta1 := 0.359933:
eps0 := -Pi^2/360:
eps1 := 0.00714:

kappa := 0.3083:

c0 := kappa*eta0:
c1 := 4*kappa*eta0 + kappa*sqrt(kappa)*eta1:
c2 := 5*eps0 + eps1/kappa:
c3 := eps1:

t := rs -> (sqrt(1 + 4*kappa*rs) - 1)/(2*kappa*rs):

f := (rs, z) ->
  t(rs)^2*(c0*(1 - t(rs))^3 + c1*t(rs)*(1 - t(rs))^2 + c2*t(rs)^2*(1 - t(rs)) + c3*t(rs)^3):