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

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

(* Functional is based on Chachiyo correlation *)
$include "lda_c_chachiyo.mpl"
(* .. but with a different scaling function *)
g := z -> (opz_pow_n(z,2/3) + opz_pow_n(-z,2/3))/2:
g_zeta := zeta -> 2*(1 - g(zeta)^3):

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


# If X ~ Exponential(λ) then k*exp(X) ~ Pareto(λ, k)

# Proof:

PDF_exponential := (alpha, x) -> exp(-x/alpha)/alpha;

PDF_pareto := (lambda, k, x) -> lambda * k ^ lambda / x ^ (lambda + 1);

simplify(PDF_exponential(1/lambda, log(x/k))*diff(log(x/k), x));

simplify(PDF_pareto(lambda, k, x));


   {  InformerScen.mpl  }

TITLE
   InformerScen;

STOCHASTIC

TREE
   TwoStage;

SCENARIOS
   scen := 1..10;

RANDOM DATA
   Demand[scen] := (210, 290, 335, 370, 415, 450, 460, 495, 540, 585);

PROBABILITIES
   prob[scen] := (0.03,  0.134, 0.086, 0.188, 0.226, 0.08, 0.056, 0.132, 0.06,  0.008);

DATA
   Budget    := 1500;
   ProdCost  := 0.81;
   SellPrice := 0.90;
   Margin    := SellPrice - ProdCost;

DECISION VARIABLES
   Production;

STAGE2 VARIABLES
   Shortfall;
   Excess;

MODEL

   MAX Profit =  Margin * Production
               - Margin * Shortfall
               - SellPrice * Excess;

SUBJECT TO

   BudgetLimit:    Production * ProdCost <= Budget;

   Balance:        Production + Shortfall - Excess = Demand;

END

--------------------------------------------------------------------------------------
VarCount = 3
ConCount = 2
StageCount = 2
VarStages[vars] := (1,2,2)
ConStages[cons] := (1,2)

ScenCount = 10
RandomCount = 10

TreeType = TWOSTAGE
TreeStage[scen] := (1,2,2,2,2,2,2,2,2,2)

ProbData[scen] := (0.03, 0.134, 0.086, 0.188, 0.226, 0.08, 0.056, 0.132, 0.06,  0.008)

RandomScen[random] := (1, 2, 3, 4, 5, 6, 7, 8, 9, 10)
RandomVar[random]  := (RHS, RHS, RHS, RHS, RHS, RHS, RHS, RHS, RHS, RHS)
RandomCon[random]  := (2, 2, 2, 2, 2, 2, 2, 2, 2, 2)
RandomData[random] := (210, 290, 335, 370, 415, 450, 460, 495, 540, 585)
--------------------------------------------------------------------------------------


macro(Multiply=LinearAlgebra[Multiply]):
macro(Copy=LinearAlgebra[Copy]):
macro(mInverse=LinearAlgebra[Modular][Inverse]):

# DoublePlusOneLift : Computes a sparse inverse expansion of the matrix A by using Double Plus One Lifting
#
# Input :
#		A : Integer matrix n x n
#		X : Integer which must be relatively prime with the determinant of A and >= max(10000, 3.61 * n^2 * ||A||)
#		n : Dimension of A
#		k : Determines the number of the times to lift and the precision of the inverse, i.e. X^(2^(k+1)-1)
#
# Precondition : gcd(X, det(A)) = 1 and X >= max(10000, 3.61 * n^2 * ||A||)
#
# Output:
#		A_0 : It is the inverse of A modulo X (Initialisation of the inverse)
#		R : A table from 0 to k needed for the sparse inverse expansion
#		M : A table from 0 to k - 1 needed for the sparse inverse expansion
#
# All together it will be : (...(A_0(I + R_0 * X_0) + M_0 * X_0^2) * (I + R_1 * X_1) + M_1 * X_1^2)...) = A^(-1) mod X^(2^(k+1)-1
#
DoublePlusOneLift := proc(A, X, n, k)
	A_0 := mInverse(X, A):
	R[0] := map(iquo, 1 - Multiply(A, A_0), X):
	for i from 0 to (k - 1) do
		R_bar := Multiply(R[i], R[i]):
		M[i] := map(modp , Multiply(A_0, R_bar), X):
		R[i+1] := map(iquo, R_bar - Multiply(A, M[i]), X):
	od:
	return A_0, eval(R), eval(M):
end proc:

# XadicRepresentationMatrixCreate : Computes the X-adic representation of a matrix and stores it compactly in a new larger one
#
# Input :
#		A : Input integer matrix n x m
#		X : Integer for the X-adic representation
#		n, m : Dimensions of A
#		p : Length of the X-adic representation to output
#
# Output :
#		A_xadic : Integer matrix n x (m*p) where every vertical slice contains one term from the X-adic representation of A
#
XadicRepresentationMatrixCreate := proc(A, X, n, m, p)
	A_xadic := Matrix(n, m*p):
	for i to n do
		for j to m do
			temp := convert(A[i, j], 'base', X):
			for k to min(p, nops(temp)) do
				A_xadic[i, j + m * (k - 1)] := temp[k]:
			od:
		od:
	od:
	return A_xadic:
end proc:

# XadicRepresentationMatrixCollapse : Computes the actual matrix from its X-adic representation
#
# Input :
#		A_xadic : Input integer matrix n x (m*p) containing the X-adic representation of A
#		X : Integer for the X-adic representation
#		n, m : Dimensions of A to output
#		p : Length of the input X-adic representation
#
# Output :
#		A : Integer matrix n x m collapsed from its X-adic representation
#
XadicRepresentationMatrixCollapse := proc(A_xadic, X, n, m, p)
	A := Matrix(n, m):
	for i to n do
		for j to m do
			sum := 0:
			for k to p do
				sum := sum + A_xadic[i, j + m * (k - 1)] * X^(k - 1)
			od:
			A[i, j] := sum:
		od:
	od:
	return A:
end proc:

# SwiftRightXadic : Multiplies an X-adic representation by X^swift, i.e.,
#	slides the vertical slices of the matrix swift times at the right
#
# Input :
#		A : Input integer matrix n x (m*p) containing an X-adic representation
#		swift : Exponent of X, i.e., A will be multiplied by X^swift
#		n, m : Dimensions of each slice in A
#		p : Length of the X-adic representation, i.e., number of slices
#
# Output :
#		A_slided : Integer matrix n x (m*p) containing the input X-adic representation multiplied by X^swift
#
SwiftRightXadic := proc(A, swift, n, m, p)
	A_slided := Matrix(n, m*p):
	if swift < p then
		A_slided[1..n, swift*m+1..m*p] := A[1..n, 1..m*(p-swift)]:
	fi:
	return A_slided:
end proc:

# SwiftRightAndMultiply : Computes the product of 2 matrices A, B, multiplied by X^swift
#
# Input :
#		A : Integer matrix n x n
#		B : Integer matrix n x (m*p) containing an X-adic representation
#		swift : Exponent of X, i.e., A*B will be multiplied by X^swift
#		n: Dimension of A, and the number of rows in B
#		m : Number of collumns of each slice in B
#		p : Length of the X-adic representation in B, i.e., number of slices
#
# Output :
#		C : Integer matrix n x (m*p) containing the X-adic representation of A * B * X^swift
#
SwiftRightAndMultiply := proc(A, B, swift, n, m, p)
	C := Matrix(n, m*p):
	if swift < p then
		C[1..n, swift*m+1..m*p] := Multiply(A, B[1..n, 1..m*(p-swift)]):
	fi:
	return C:
end proc:

# CleanUpXadic : Cleans up an X-adic representation, i.e.,
#	scans the matrix, looking for overflowed elements which will reduce mod X, and it will forward the carry to the next slice
#
# Input :
#		A : Input integer matrix n x (m*p) containing an X-adic representation to be cleaned up
#		X : Integer for the X-adic representation
#		n, m : Dimensions of each slice in A
#		p : Length of the X-adic representation, i.e., number of slices
#
# Output :
#		A : Integer matrix n x (m*p) containing the input X-adic representation that has been cleaned up
#
CleanUpXadic := proc(A, X, n, m, p)
	for k to p-1 do
#		A[1..n, 1+m*k..m*(k+1)] := A[1..n, 1+m*k..m*(k+1)] + map(iquo, A[1..n, 1+m*(k-1)..m*k], X):
#		A[1..n, 1+m*(k-1)..m*k] := map(modp, A[1..n, 1+m*(k-1)..m*k], X):
		for i to n do
			for j to m do
				entry := A[i, j + m * (k - 1)]:
				if entry >= X then
					A[i, j + m * (k - 1)] := modp(entry, X):
					A[i, j + m * k] := A[i, j + m * k] + iquo(entry, X):
				fi:
			od:
		od:
	od:
	# Take care of the last slice as well
#	A[1..n, 1+m*(p-1)..m*p] := map(modp, A[1..n, 1+m*(p-1)..m*p], X):
	for i to n do
		for j to m do
			A[i, j + m * (p - 1)] := modp(A[i, j + m * (p - 1)], X):
		od:
	od:
	return A:
end proc:

# ApplyDPOL : Applies the Double Plus One Lifting formula to a matrix B
#
# Input :
#		A_0, R, M : The output from the DoublePlusOneLift procedure, i.e., matrices that form the expansion of the inverse of a matrix A
#		B : Integer matrix n x (m*p) containing an X-adic representation on which the Double Plus One Lifting formula will be applied
#		X : Integer for the X-adic representation
#		n: Dimension of A_0, R[i], M[i], and the number of rows in B
#		m : Number of collumns of each slice in B
#		p : Length of the X-adic representation in B, i.e., number of slices
#		k : Length of the lists R and M
#
# Precondition : p <= 2^(k+1) - 1
#
# Output :
#		Expansion : Integer matrix n x (m*p) containg the X-adic representation of A^(-1) * B, where A is represented by its sparse inverese expansion here
#
ApplyDPOL := proc(A_0, R, M, B, X, n, m, p, k)
	Expansion := Matrix(n, m*p):
	Factor := Copy(B):
	for i from k-1 by -1 to 0 do
		Expansion := CleanUpXadic(Expansion + SwiftRightAndMultiply(M[i], Factor, 2^(i + 2) - 2, n, m, p), X, n, m, p):
		Factor := CleanUpXadic(Factor + SwiftRightAndMultiply(R[i], Factor, 2^(i + 1) - 1, n, m, p), X, n, m, p):
	od:
	Expansion := CleanUpXadic(Expansion + Multiply(A_0, Factor), X, n, m, p):
	return Expansion:
end proc:

# SolveLinearSystem : Solves a linear system A*x=B <=> x=A^(-1)*B over the integers
#
# Input :
#		A : Integer matrix n x n
#		B : Integer matrix n x m
#		n: Dimension of A, and the number of rows in B
#		m : Number of collumns in B
#
# Output :
#		Solution : Integer matrix n x m containg the solution x of the linear system A*x=B
#
SolveLinearSystem := proc(A, B, n, m)

	X := 10007:
	k := 5:
	p := 2^(k+1)-1:

	A_0, R, M := DoublePlusOneLift(A, X, n, k):

	B_xadic := XadicRepresentationMatrixCreate(B, X, n, m, p):

	Solution_xadic := ApplyDPOL(A_0, R, M, B_xadic, X, n, m, p, k):

	Solution := XadicRepresentationMatrixCollapse(Solution_xadic, X, n, m, p):

	return Solution:

end proc:


with(simplex);

Constraints := [
# conservation of units at each node
e13+e14 = 300, # CHI
e23+e24 = 300, # DC
e13+e23 = 300, # HOU
e14+e24 = 300, # BOS
# maximum flow on individual edges
0 <= e13, e13 <= 200,
0 <= e14, e14 <= 200,
0 <= e23, e23 <= 280,
0 <= e24, e24 <= 350
];

Cost := 7*e13 + 6*e14 + 4*e23 + 6*e24;
# Invoke linear programming to solve problem
minimize (Cost, Constraints, NONNEGATIVE);


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

$define gga_x_rpw86_params
$include "gga_x_pw86.mpl"

malpha := 0.02178:
mbeta  := 1.15:
muLV   := 0.8491/9:

f0 := s ->
   + (1 + muLV*s^2)/(1 + malpha*s^6)
   + malpha*s^6*f0_pw86(s)/(mbeta + malpha*s^6):

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


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

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

(* type: gga_exc *)

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

beefvdw_k  := 4:
beefvdw_xi := p -> 2*p/(beefvdw_k + p) - 1:

with(orthopoly):
beefvdw_f := x -> add(beefvdw_coeffs[i]*P(i-1, beefvdw_xi(X2S^2*x^2)), i=1..30):

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


    {  Planning.mpl  }

    {  Aggregate production planning for 12 months  }

TITLE
    Production_Planning;

INDEX
    product  :=  1..3;

    month    :=  (January,February,March,April,May,June,July,
                  August,September,October,November,December);
DATA
    price[product]              :=  (105.09, 234.00, 800.00);   [$/Boxes]
    Demand[month,product]       :=  1000 DATAFILE(Demand.dat);  [Boxes/month]
    ProductionCapacity[product] :=  1000 (10, 42, 14);          [Boxes/month]
    ProductionCost[product]     :=  (94.0, 188.10, 653.20);     [$/Boxes]
    InventoryCost               :=  8.8;                        [$/Boxes/month]

DECISION VARIABLES
    Inventory[product,month]   ->  Invt;                        [Boxes]
    Production[product,month]  ->  Prod;                        [Boxes/month]
    Sales[product,month]       ->  Sale;                        [Boxes/month]

MACRO
    Revenues   :=  SUM(product,month: price * Sales);                [$]

    TotalCost  := SUM(product,month: ProductionCost[product] * Production[product,month]
                                    + InventoryCost * Inventory[product,month]);    [$]

MODEL

   MAX   Profit =  Revenues - TotalCost;

SUBJECT TO

   InvtBal[product,month] : Inventory  =  Inventory[month-1] + Production - Sales;

BOUNDS
    Sales <  Demand ;

    Production  <  ProductionCapacity ;

    Inventory[month=January..November]  <  90000 ;
    Inventory[month=December]   =  20000 ;

END


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

# A full tree on A is a tree that contains A, and also contains {a}
# for all a in A.
# (Definition defn-full-trees)

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

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

 for a in A do
  if not(member({a},TT)) then
   reason := [convert(procname,string),"The singleton {a} is not in TT",a,TT];
   return false;
  fi;
 od;

 return true;
end;

`is_equal/full_trees` := eval(`is_equal/trees`);
`is_leq/full_trees` := eval(`is_leq/trees`);

# A full tree TT on A is binary if every non-minimal set in TT has
# precisely two children.  This holds iff |TT| = 2|A|-1.

`is_binary/full_trees` := (A) -> proc(TT)
 return evalb(nops(TT) = 2*nops(A)-1);
end:

`list_elements/full_trees`:= proc(A::set)
 local n,a,A1,TTT1,TTT,TT1,T1;

 # Degenerate cases for small A
 if A={} then return []; fi;
 if nops(A)=1 then return [{A}]; fi;

 # If A is not too small, we write it as {a} union A1.  Then we recursively
 # choose a random tree on A1, and attach a to it.

 n := nops(A);
 a := A[n];
 A1 := A minus {a};
 TTT1 := `list_elements/full_trees`(A1);

 TTT := [];
 for TT1 in TTT1 do
  for T1 in TT1 do
   TTT := [op(TTT),`attach_to_tree`(A1)(TT1,T1,a,true)];
   if n > 2 and nops(T1) > 1 then
    TTT := [op(TTT),`attach_to_tree`(A1)(TT1,T1,a,false)];
   fi;
  od;
 od;

 return TTT;
end:

# A000311 from OEIS

`count_elements/full_trees` := proc(A::set)
 local n,i,j,k;
 n := nops(A);
 if n = 0 then
  return 0;
 elif n  = 1 then
  return 1;
 else
  return
   add(
    (n+k-1)!*
    add(
     1/(k-j)! *
     add(
     (2^i*(-1)^(i)*Stirling2(n+j-i-1,j-i))/((n+j-i-1)!*i!),
     i=0..j),
    j=1..k),
   k=1..n-1);
 fi;
end;

`random_element/full_trees`:= (A::set) -> proc()
 local n,a,A1,T0,T1,T,above;

 # Degenerate cases for small A
 if A={} then return FAIL; fi;
 if nops(A)=1 then return {A}; fi;

 # If A is not too small, we write it as {a} union A1.  Then we recursively
 # choose a random tree on A1, and attach a to it.

 n := nops(A);
 a := A[rand(1..n)()];
 A1 := A minus {a};
 if n = 2 then
  above := true;
 else
  above := evalb(rand(0..1)() = 1);
 fi;

 T0 := `random_element/full_trees`(A1)();
 T1 := select(U -> nops(U) > 1,T0);

 if above then
  T := T0[rand(1..nops(T0))()];
 else
  T := T1[rand(1..nops(T1))()];
 fi;

 T := `attach_to_tree`(A1)(T0,T,a,above);

 return T;
end;


# real 3 metric for BSSN in spherical symmetry.
Ndim_ := 3:
x1_ := x:
x2_ := theta:
x3_ := phi:
complex_ := {}:
g11_ := A(x)*exp(4*phi(x)):
g12_ := 0:
g13_ := 0:
g22_ := x^2*B(x)*exp(4*phi(x)):
g23_ := 0:
g33_ := x^2*B(x)*(sin(theta))^2*exp(4*phi(x)):


   {  DakotaScen.mpl  }

TITLE
   DakotaScen;

INDEX
   product  := (Desk, Tble, Chair);
   resource := (Lumber, Finishing, Carpentry);

STOCHASTIC

TREE
   TWOSTAGE;

SCENARIOS
   scen := 1..3;

PROBABILITIES
   Prob[scen] := (0.3, 0.4, 0.3);

RANDOM DATA
   Demand[product,scen] := (50, 150, 250,
                            20, 110, 250,
                           200, 225, 500);

DATA
   Cost[resource] := (2, 4, 5.2);
   ProdReq[resource, product] := (8,   6,   1,
                                  4,   2,   1.5,
                                  2,   1.5, 0.5);
   Price[product] := (60, 40, 10);

   Budget := 8000;

DECISION VARIABLES
   Acquire[resource]

STAGE2 VARIABLES
   Produce[product];

MODEL
   Max Profit =  SUM(product: Price * Produce)
               - SUM(resource:  Cost * Acquire);

SUBJECT TO
   MaxBudget[resource]: Cost * Acquire <= Budget;

   MaxProduce[product]:  Produce <= Demand;

   MinAcquire[resource]: SUM(product: ProdReq * Produce) <= Acquire;

END


    {   Diet.mpl   }

{
    This model determines a least cost diet which meets the daily
    allowances of nutrients for a man weighing 154 lbs.

    Reference:  G. B. Dantzig, Linear Programming and Extensions,
                Princeton University Press, Princeton, New Jersey, 1963.
}

TITLE
    Stiglers_nutrition_model

INDEX
    nutrients  =  (Calorie,Protein,Calcium,Iron,Avitamin
                   Thiamine,Riboflavin,Niacin,Cvitamin) : 10

    foods      =  (WheatFlour,CornMeal,EvapMilk,Margarine,
                   Cheese,Lard,Liver,PorkRoast,Salmon,
                   GreenBeans,Cabbage,Onions,Potatoes,Spinach,
                   SweetPot,Peaches,Prunes,LimaBeans,NavyBeans) : 10

DATA
    Required[nutrients]  =  (  3       ! Calories        [thousands]
                              70       ! Protein         [grams]
                               0.8     ! Calcium         [grams]
                              12       ! Iron            [milligrams]
                               5       ! Avitamin        [thousand ius]
                               1.8     ! Thiamine (B1)   [milligrams]
                               2.7     ! Riboflavin (B2) [milligrams]
                              18       ! Niacin          [milligrams]
                              75 ) ;   ! Cvitamin        [milligrams]

    A[foods,nutrients] = DATAFILE(nutri.dat)  !  Nutritive values of foods
                                              !  per dollar expenditure.

DECISION
    x[foods]   ->  ""    !  dollars of food to be purchased daily

MODEL

    MIN  Cost = SUM(foods: x) ;

SUBJECT TO

    NutrBal[nutrients] -> "" :  SUM(foods: A*x)  >  Required[nutrients];

END


################################
# Derivation of BSSN equations
# Using GR-Tensor
# See bssn_spher.mw for interactive
# version of this script
################################
grtw();
grload(g,"metrics/spher_3.mpl");
grdisplay(g(dn,dn));
grcalc(g(up,up));
grdisplay(g(up,up));
grdef(`g_f{a b} := kdelta{a $x}*kdelta{b $x}*1 + kdelta{a $theta}*kdelta{b $theta}*x^2 + kdelta{a $phi}*kdelta{b $phi}*x^2*(sin(theta))^2`); grcalc(g_f(dn,dn)); grdisplay(g_f(dn,dn));
grdef(`g_f_inv{^a ^b} := kdelta{^a $x}*kdelta{^b $x}*1 + kdelta{^a $theta}*kdelta{^b $theta}*1/x^2 + kdelta{^a $phi}*kdelta{^b $phi}*1/(x^2*(sin(theta))^2)`); grcalc(g_f_inv(up,up)); grdisplay(g_f_inv(up,up));
grdef(`ChL_f{d a b} := 1/2*( g_f{b d ,a} + g_f{a d,b} - g_f{a b,d})`);
grdef(`MCh_f{^c a b} := g_f_inv{^c ^d} * ChL_f{d a b}`):
grcalc(MCh_f(up,dn,dn)); grdisplay(MCh_f(up,dn,dn));
grdef(`ChL{d a b} := 1/2*( g{b d ,a} + g{a d,b} - g{a b,d})`):
grdef(`MCh{^c a b} := g{^c ^d} * ChL{d a b}`):
grcalc(MCh(up,dn,dn));
gralter(MCh(up,dn,dn),simplify,expand);
grdisplay(MCh(up,dn,dn));
grdef(`TG{^i} := g{^j ^k}*MCh{^i j k}`);
grcalc(TG(up));
grdisplay(TG(up));
grdef(`TG2{^i} := g{^j ^k}*(MCh{^i j k}-MCh_f{^i j k})`); grcalc(TG2(up)); gralter(TG2(up),simplify,expand); grdisplay(TG2(up));
grdef(`Lam{^a} := [Lamx(t,x),0,0]`);
grcalc(Lam(up)); grdisplay(Lam(up));
grdef(`GA{^i} := Lam{^i} + g{^j ^k}*MCh_f{^i j k}`);  grcalc(GA(up)); grdisplay(GA(up));
grdef(`SS{i j} := 2*g{^l ^m}*MCh{^k l (i}*ChL{j) k m} + g{^l ^m}*MCh{^k i m}*ChL{k l j}`);
grcalc(SS(dn,dn));
gralter(SS(dn,dn),simplify);
grdisplay(SS(dn,dn));
grdef(`RB{i j} := -1/2*g{^l ^m}*g{i j ,l ,m} + g{k (i}*GA{^k ,j)} + GA{^k}*ChL{(i j) k} + SS{i j}`);
grcalc(RB(dn,dn));
gralter(RB(dn,dn),simplify,expand);
grdisplay(RB(dn,dn));
grdef(`CF{} := phi(t,x)`);
grcalc(CF);
grdef(`DCF{i} := CF{;i}`);
grcalc(DCF(dn));
grdisplay(DCF(dn));
grdef(`Rphi{i j} := -2*DCF{j ;i} - 2*g{i j}*DCF{^k ;k} + 4*DCF{i}*DCF{j} - 4*g{i j}*DCF{^k}*DCF{k}`);
grcalc(Rphi(dn,dn));
gralter(Rphi(dn,dn),expand,simplify,expand);
grdisplay(Rphi(dn,dn));
grcalc(R(dn,dn)); grdisplay(R(dn,dn));
grdef(`RBtest{i j} := -1/2*g{^l ^m}*g{i j ,l ,m} + g{k (i}*TG{^k ,j)} + TG{^k}*ChL{(i j) k} + SS{i j}`);
grdef(`Rresid{i j} := RBtest{i j} - R{i j}`);
grcalc(Rresid(dn,dn));
gralter(Rresid(dn,dn),simplify);
grdisplay(Rresid(dn,dn));
grdef(`Sh{^a}:=[beta(t,x),0,0]`);
grcalc(Sh(up));
grdisplay(Sh(up));
grdef(`Q{i j} := Sh{^k}*g{i j ,k} + g{i k}*Sh{^k ,j} + g{k j}*Sh{^k ,i} -2/3*g{i j}*vee*divbeta(t,x)`);
grcalc(Q(dn,dn));
grdisplay(Q(dn,dn));
grdef(`A{a b} := kdelta{a $x}*kdelta{b $x}*Axx(t,x)/1 + kdelta{a $theta}*kdelta{b $theta}*x^2*Athth(t,x) + kdelta{a $phi}*kdelta{b $phi}*x^2*(sin(theta))^2*Athth(t,x)`);
grcalc(A(dn,dn));grdisplay(A(dn,dn));
grdef(`P{i j} := Sh{^k}*A{i j,k} + A{i k}*Sh{^k ,j} + A{k j}*Sh{^k ,i} - 2/3*A{i j}*vee*divbeta(t,x)`):
grcalc(P(dn,dn));
grdisplay(P(dn,dn));
grdef(`Extc{} := K(t,x)`);
grcalc(Extc);
grdef(`Lapse{} := alpha(t,x)`);
grcalc(Lapse);
grdef(`S{i} :=[Sx(t,x),0,0]`);
grcalc(S(dn));

grdef(`DBS{} := divbeta(t,x)`);
grdef(`DGA{^i} := g{^l ^j}*Sh{^i ,l ,j} - 2*A{^i ^j}*Lapse{,j} + 2*Lapse*(MCh{^i j k}*A{^k ^j} - 2/3*g{^i ^j}*Extc{,j} - g{^i ^j}*S{j} + 6*A{^i ^j}*DCF{j}) + Sh{^j}*GA{^i ,j} - GA{^j}*Sh{^i ,j} +vee/3*(2*GA{^i}*divbeta(t,x)+g{^i ^l}*DBS{,l})`);
grcalc(DGA(up));

gralter(DGA(up),simplify,expand,trigsin,factor,expand);
grdisplay(DGA(up));
grdef(`met{a b} := exp(4*CF)*(kdelta{a $x}*kdelta{b $x}*A(t,x) + kdelta{a $theta}*kdelta{b $theta}*B(t,x)*x^2 + kdelta{a $phi}*kdelta{b $phi}*B(t,x)*x^2*sin(theta)^2)`);
grcalc(met(dn,dn));
grdisplay(met(dn,dn));

grdef(`met_s{a b} := kdelta{a $x}*kdelta{b $x}*metxx(t,x) + kdelta{a $theta}*kdelta{b $theta}*x^2*metthetatheta(t,x) + kdelta{a $phi}*kdelta{b $phi}*x^2*(sin(theta))^2*metthetatheta(t,x)`);
grcalc(met_s(dn,dn));grdisplay(met_s(dn,dn));
grdef(`invmet_s{^a ^b}:=kdelta{^a $x}*kdelta{^b $x}*1/metxx(t,x) + kdelta{^a $theta}*kdelta{^b $theta}*1/(x^2*metthetatheta(t,x)) + kdelta{^a $phi}*kdelta{^b $phi}*1/(x^2*(sin(theta))^2*metthetatheta(t,x))`);
grcalc(invmet_s(up,up));
grdisplay(invmet_s(up,up));
grdef(`rChL{d a b} := 1/2*( met_s{b d ,a} + met_s{a d,b} - met_s{a b,d})`);
grdef(`rMCh{^c a b} := invmet_s{^c ^d} * rChL{d a b}`);
grdef(`DDL{b c} :=   Lapse{,c ,b} - rMCh{^d b c}*Lapse{,d}`);
grcalc(DDL(dn,dn));
grdisplay(DDL(dn,dn));
grdef(`rR{u p} := rMCh{^v u p ,v} - rMCh{^v v p ,u} + rMCh{^a u p}*rMCh{^v a v} - rMCh{^a v p}*rMCh{^v a u}`);
grdef(`RHO{} := rho(t,x)`);
grcalc(RHO);
grdef(`TraceS{} := TS(t,x)`);
grcalc(TraceS);
grdef(`DDL_s{a b} := kdelta{a $x}*kdelta{b $x}*DDLxx(t,x) + kdelta{a $theta}*kdelta{b $theta}*x^2*DDLthetatheta(t,x) + kdelta{a $phi}*kdelta{b $phi}*x^2*DDLthetatheta(t,x)*(sin(theta))^2`);
grcalc(DDL_s(dn,dn)); grdisplay(DDL_s(dn,dn));
grdef(`TD{} := invmet_s{^i ^j} * DDL_s{i j}`);
grcalc(TD);
grdisplay(TD);
grdef(`DDLTF{i j} := DDL_s{i j} - 1/3*TD*met_s{i j}`);
grcalc(DDLTF(dn,dn));
grdisplay(DDLTF(dn,dn));

grdef(`DTK{} := -TD +Lapse*(A{i j}*A{^i ^j} +1/3*Extc^2) +1/2*Lapse*(RHO+TraceS) +Sh{^i}*Extc{,i}`);
grcalc(DTK);
gralter(DTK,simplify,expand);
grdisplay(DTK);
grdef(`JS{a b} := kdelta{a $x}*kdelta{b $x}*JSxx(t,x) + kdelta{a $theta}*kdelta{b $theta}*x^2*JSthth(t,x) + kdelta{a $phi}*kdelta{b $phi}*x^2*(sin(theta))^2*JSthth(t,x)`);
grcalc(JS(dn,dn));
grdisplay(JS(dn,dn));
grdef(`TJS := invmet_s{^i ^j}*JS{i j}`);
grcalc(TJS);
gralter(TJS,simplify,expand);
grdisplay(TJS);
grdef(`U{i j} := (Extc*A{i j} - 2*A{i l}*A{^l j})`);
grcalc(U(dn,dn));
gralter(U(dn,dn),simplify,expand);
grdisplay(U(dn,dn));
grdef(`dg{i j} := -2*Lapse*A{i j} + Q{i j}`);
grcalc(dg(dn,dn));
gralter(dg(dn,dn),simplify,factor);
grdisplay(dg(dn,dn));
grdef(`dgu{^i ^j} := -g{^i ^l}*dg{l m}*g{^m ^j}`); grcalc(dgu(up,up)); grdisplay(dgu(up,up));
grdef(`deltaDGA{^i} := -dgu{^j ^k}*MCh_f{^i j k}`); grcalc(deltaDGA(up)); grdisplay(deltaDGA(up));
grdef(`DLAM{^i} := DGA{^i} + deltaDGA{^i}`); grcalc(DLAM(up)); gralter(DLAM(up),simplify,expand); grdisplay(DLAM(up));
grdef(`DPH{} := -1/6*Lapse*Extc + Sh{^i}*CF{,i} + 1/6*divbeta(t,x)`);
grcalc(DPH); grdisplay(DPH);
grdef(`TRB{} := g{^i ^j}*RB{i j}`);
grcalc(TRB);
gralter(TRB,simplify);
grdisplay(TRB);
grdef(`PSI{} := psi(t,x)`);
grcalc(PSI);
grdef(`C1 {} := -1/8*TRB`); grcalc(C1); gralter(C1,simplify,expand,factor,expand); grdisplay(C1);
grdef(`C5{} := 1/8*A{i j}*A{^i ^j} -1/12*Extc^2 + 1/4*rho(t,x)`);
grcalc(C5); gralter(C5,simplify,expand); grdisplay(C5);
grdef(`HS3{} := g{^i ^j}*PSI{;j ;i} + C5psi(t,x) + C1s(t,x)*PSI`);
grdef(`HS{} := g{^i ^j}*PSI{;j ;i} + C5s(t,x)*PSI^5 + C1s(t,x)*PSI`); grdef(`HSR{} := g{^i ^j}*PSI{;i ;j} - 1/8*TRB*PSI + 1/8*A{i j}*A{^i ^j}*PSI^5 -1/12*PSI^5*Extc^2 + 1/4*rho(t,x)*PSI^5`); grcalc(HSR);gralter(HSR,simplify,expand,factor,expand);grdisplay(HSR);
grcalc(HS);
gralter(HS,simplify,expand,factor,expand);
grdisplay(HS);
grcalc(HS3); grdisplay(HS3);gralter(HS3,expand);
grdef(`RR{i j} := RB{i j} + Rphi{i j}`);
grcalc(RR(dn,dn));
gralter(RR(dn,dn),simplify,expand,factor,expand);
grdisplay(RR(dn,dn));
grdef(`RR_s{a b} := kdelta{a $x}*kdelta{b $x}*RRxx(t,x) + kdelta{a $theta}*kdelta{b $theta}*x^2*RRthetatheta(t,x) + kdelta{a $phi}*kdelta{b $phi}*x^2*(sin(theta))^2*RRthetatheta(t,x)`);
grcalc(RR_s(dn,dn)); grdisplay(RR_s(dn,dn));
grdef(`TR{} := invmet_s{^i ^j}*RR_s{i j}`);
grcalc(TR);
grdisplay(TR);

grdef(`RRTF{i j} := RR_s{i j} - 1/3*met_s{i j}*TR`);
grcalc(RRTF(dn,dn));
grdisplay(RRTF(dn,dn));
grdef(`P_s{a b} := kdelta{a $x}*kdelta{b $x}*Pxx(t,x) + kdelta{a $theta}*kdelta{b $theta}*x^2*Pthetatheta(t,x) + kdelta{a $phi}*kdelta{b $phi}*x^2*(sin(theta))^2*Pthetatheta(t,x)`);
grcalc(P_s(dn,dn)); grdisplay(P_s(dn,dn));
grdef(`U_s{a b} := kdelta{a $x}*kdelta{b $x}*Uxx(t,x) + kdelta{a $theta}*kdelta{b $theta}*x^2*Uthetatheta(t,x) + kdelta{a $phi}*kdelta{b $phi}*x^2*(sin(theta))^2*Uthetatheta(t,x)`);
grcalc(U_s(dn,dn));
grdisplay(U_s(dn,dn));
grdef(`DAA{i j} := em4phi(t,x)*(-DDLTF{i j} +  Lapse*(RRTF{i j} - ( JS{i j} - 1/3*met_s{i j}*TJS)    )) + Lapse*U_s{i j} + P_s{i j}`);
grcalc(DAA(dn,dn));
gralter(DAA(dn,dn),simplify,expand);
grdisplay(DAA(dn,dn));
grdef(`EMPH{} := exp(-4*CF)`);grcalc(EMPH);grdisplay(EMPH);
grdef(`MKTR1{^j ^i} := PSI^6*A{^j ^i}`);
grdef(`MK{^i} := MKTR1{^j ^i ;j} - 2/3*PSI^6*g{^i ^j}*Extc{;j} - PSI^6*g{^i ^j}*S{j}`); grcalc(MK(up)); gralter(MK(up),simplify,expand); grdisplay(MK(up));
grdef(`DB:= Sh{^i ;i}`); grcalc(DB); grdisplay(DB);gralter(DB,simplify,expand); grdisplay(DB);


# Proof by PDF that X <~ rayleigh(1) == X^2 <~ weibull(1,1)

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

PDF_transform := (x) -> PDF_rayleigh(1,sqrt(x))*diff(sqrt(x),x);
simplify(PDF_transform(x));

PDF_weibull := (k, t, x) -> k/t*x^(k-1)*exp(-1*(1/t)*x^k);
simplify(PDF_weibull(1, 1, x));

evalb(PDF_weibull(1, 1, x) = PDF_transform(x));


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

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

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

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

 if not(`is_symmetric/autorel`(A)(R)) then
  reason := [convert(procname,string),"R is not symmetric",R];
  return false;
 fi;

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

 return true;
end;

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

`is_total/equiv`     := (A::set) -> proc(R)
 local U,a,b;

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

 return evalb(U = {});
end;

`block_partition/equiv` := (A::set) -> proc(R)
 local pi,X,x,B;

 pi := NULL;
 X := A;

 while X <> {} do
  x := X[1];
  B := map(ab -> ab[2],select(ab -> ab[1] = x,R));
  pi := pi,B;
  X := X minus B;
 od:

 pi := {pi};

 return pi;
end:

`block_equiv/partition` := (A::set) -> proc(pi)
 local B,x,y;
 {seq(seq(seq([x,y],y in B),x in B),B in pi)};
end;

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

`random_element/equiv` := (A::set) -> proc()
 `block_equiv/partition`(A)(`random_element/partitions`(A)());
end;

`list_elements/equiv` := proc(A::set)
 map(`block_equiv/partition`(A),
     `list_elements/partitions`(A));
end:

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


TITLE BetterBreadBakery;

MAX

    Profit = 0.05 Sun + 0.08 Moon - 4000/30 ;

SUBJECT TO

    1/10 Sun + 1/5 Moon <= 10 * 140 ;

    Sun  <=  8000;
    Moon <=  5000;
END


with(BinomSums):
with(CodeTools):

### rser
Test(
  coeff(rser(1/(1-2*t), [t], 10),t,8),
  2^8);

Test(
  coeff(rser(1/(1-2*t)/u[1], [t,u[1]], 10),t,8),
  2^8);

Test(
  coeff(rser(1/(1-2*t)/u[1]/(u[2]-u[1]), [t,u[1],u[2]], 10),t,8),
  2^8);

### packvars
Test(
  BinomSums[packvars]([ 1/(x[4]+x[6]), x[7] ], x),
  [{x[4] = x[1], x[6] = x[2]}, {x[7] = x[3]}]
);

### geomsum
Test(
  BinomSums[geomsum](1, k=0..n),
  n+1
);

Test(
  BinomSums[geomsum](k, k=0..n),
  n*(n+1)/2,
  `expand`
);

# when the sum is infinite, geomsum add a variable
Test(
  BinomSums[geomsum](k, k=0..infinity),
  _W[_k]/(1-_W[_k])^2,
  `normal`
);

# when the sum is infinite on the left, geomsum yields an error
Test(
  BinomSums[geomsum](k, k=-infinity..0),
  "",
  `testerror`
);

# it should recognize when the input does not really depend on the summation variable
Test(
  BinomSums[geomsum]((-1+u[1])^(-n-1+j)*(-1+u[2])^(-n+j-1)*(1-u[1])^(-j)*(1-u[2])^(-j)*u[1]^(-n)*u[2]^(-n), j=0..n),
  u[1]^(-n)*u[2]^(-n)*(-1+u[1])^(-n-1)*(-1+u[2])^(-n-1)*(n+1),
  `normal`
);


#If X ~ Pareto(λ, 1) then log(X) ~ Exp(λ).

# Proof:
PDF_pareto := (lambda, k, x) -> lambda * k ^ lambda / x ^ (lambda + 1);

PDF_exponential := (alpha, x) -> exp(-x/alpha)/alpha;

simplify(PDF_pareto(lambda, 1, exp(x))*diff(exp(x),x));

simplify(PDF_exponential(1/lambda, x));


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

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

(* type: work_gga_x *)

s1 := 0.6:
s2 := 2.6:

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

cc0 :=  s1^3*(s1^2 - 5*s1*s2 + 10*s2^2)/(s1 - s2)^5:
cc1 := -30*s1^2*s2^2/(s1 - s2)^5:
cc2 :=  30*s1*s2*(s1 + s2)/(s1 - s2)^5:
cc3 := -10*(s1^2 + 4*s1*s2 + s2^2)/(s1 - s2)^5:
cc4 :=  15*(s1 + s2)/(s1 - s2)^5:
cc5 := -6/(s1 - s2)^5:

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

g := s -> cc0 + cc1*s + cc2*s^2 + cc3*s^3 + cc4*s^4 + cc5*s^5:

f0 := s -> convert(piecewise(
   s < s1, f0_wc(s),
   s > s2, f0_rpbe(s),
   g(s)*f0_rpbe(s) + (1 - g(s))*f0_wc(s)
), 'Heaviside'):

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


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

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

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

 return true;
end;

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

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

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

 return true;
end;

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

`is_nonnegative/vector_functions` := (N::posint) -> (A::set) -> proc(x)
 local a,i;

 for a in A do
  for i from 1 to N do
   if x[a][i] < 0 then
    return false;
   fi;
  od;
 od;

 return true;
end:

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

`is_zero/vector_functions` := (N::posint) -> (A::set) -> proc(x)
 local a,i;

 for a in A do
  for i from 1 to N do
   if x[a][i] <> 0 then
    return false;
   fi;
  od;
 od;

 return true;
end:

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

`is_leq/vector_functions` := (N::posint) -> (A::set) -> proc(x,y)
 local a,i;

 for a in A do
  for i from 1 to N do
   if x[a][i] > y[a][i] then
    return false;
   fi;
  od;
 od;

 return true;
end:

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

`plus/vector_functions` := (N) -> (A::set) -> proc(x,y)
 local z,a;

 z := table();
 for a in A do
  z[a] := x[a] +~ y[a];
 od:

 return eval(z):
end:

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

`times/vector_functions` := (N) -> (A::set) -> proc(t,x)
 local z,a;

 z := table();
 for a in A do
  z[a] := t *~ x[a];
 od:

 return eval(z):
end:

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

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

 n := 0;
 for a in A do n := n + `norm_2/R`(N)(x[a])^2; od;

 return sqrt(n);
end:

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

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

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

 return u;
end:

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

`average/vector_functions` := (N::posint) -> (A::set) -> proc(x)
 if A = {} then
  return FAIL;
 fi;

 return `sum/vector_functions`(N)(A)(x) /~ nops(A);
end:

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

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

 n := 0;
 for a in A do n := n + `d_2/R`(N)(x[a],y[a])^2; od;

 return sqrt(n);
end:

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

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

 d := 0;
 for a in A do d := d + `dot/R`(N)(x[a],y[a]); od;

 return d;
end:

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

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

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

 return eval(x);
end;

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

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


TITLE
    Invest3Scen;

INDEX
    invtype := (Stock, Bond) -> (S,B);

STOCHASTIC

STAGES
    period := 1..3;

SCENARIOS
    sc := 1..4;

TREE
    BINARY;

PROBABILITIES
    prob[sc] := ALLEQUAL;

RANDOM DATA
    Returns[invtype, period, sc] :=
      [Stock, 1, 1, 1.25,
       Stock, 1, 2, 1.25,
       Stock, 1, 3, 1.06,
       Stock, 1, 4, 1.06,
       Stock, 2, 1, 1.25,
       Stock, 2, 2, 1.06,
       Stock, 2, 3, 1.25,
       Stock, 2, 4, 1.06,
       Bond, 1, 1, 1.14,
       Bond, 1, 2, 1.14,
       Bond, 1, 3, 1.12,
       Bond, 1, 4, 1.12,
       Bond, 2, 1, 1.14,
       Bond, 2, 2, 1.12,
       Bond, 2, 3, 1.14,
       Bond, 2, 4, 1.12];

DATA
    InitialWealth = 55;
    Goal := 80;
    SurplusReward := 1;
    ShortPenalty  := 4;

VARIABLES
    Invest[period<LAST(period),invtype] -> x;

LASTSTAGE VARIABLES
    Shortage -> Sh;
    Excess -> Ex;

MODEL

   MAX obj = SurplusReward*Excess - ShortPenalty*Shortage;

SUBJECT TO

   InitInvest[period=1] -> InitInv:
       InitialWealth
     =
       SUM(invtype: Invest);

   InvestBal[period=2..LAST(period)-1] -> InvBal:
       SUM(invtype: Invest[period-1] * Returns[period-1])
     =
       SUM(invtype: Invest);

   EndInvest[period=LAST(period)] -> EndInv:
       SUM(invtype: Invest[period-1]* Returns[period-1])  + Shortage - Excess
     =
       Goal;

END


`is_element/shuffles` := (n::nonnegint,m::nonnegint) -> proc(s)
 local i;

 if not(`is_element/permutations`(n+m)(s)) then
  return false;
 fi;

 for i from 1 to n+m-1 do
  if i <> n and s[i+1] < s[i] then
   return false;
  fi;
 od:

 return true;
end:

`is_equal/shuffles` := (n,m) -> (s,t) -> evalb(s = t);

`is_leq/shuffles` := NULL;

`from_subset/shuffles` := (n::nonnegint,m::nonnegint) -> proc(A)
 option remember;
 local X,B,i;

 X := {seq(i,i=1..n+m)};
 if A minus X <> {} then return FAIL; fi;
 if nops(A) <> n then return FAIL; fi;

 B := X minus A;
 return [op(sort(A)),op(sort(B))];
end:

`to_subset/shuffles` := (n::nonnegint,m::nonnegint) -> proc(s)
 local i;
 {seq(s[i],i=1..n)};
end:

`to_grid_path/shuffles` := (n::nonnegint,m::nonnegint) -> proc(s)
 local t,si,i;

 t := table():
 t[0] := [0,0];
 si := `inv/permutations`(n+m)(s);
 for i from 1 to n+m do
  t[i] := `if`(si[i] <= n,[1,0],[0,1]) +~ t[i-1];
 od:

 return eval(t);
end:

`from_grid_path/shuffles` := (n::nonnegint,m::nonnegint) -> proc(t)
 local A,i;

 A := select(i -> t[i][1] > t[i-1][1],{seq(i,i=1..n+m)});
 return `from_subset/shuffles`(n,m)(A);
end:

`random_element/shuffles` := (n::nonnegint,m::nonnegint) -> proc()
 local u,A,i;
 u := combinat[randperm](n+m);
 A := {seq(u[i],i=1..n)};
 return `from_subset/shuffles`(n,m)(A);
end:

`list_elements/shuffles` := proc(n::nonnegint,m::nonnegint)
 local AA;
 AA := map(A -> {op(A)},combinat[choose](n+m,n));
 return map(`from_subset/shuffles`(n,m),AA);
end:

`list_elements/inverse_shuffles` := proc(n::nonnegint,m::nonnegint)
 option remember;

 map(`inv/permutations`(n+m),`list_elements/shuffles`(n,m));
end:

`count_elements/shuffles` := (n::nonnegint,m::nonnegint) -> binomial(n+m,n);

`sgn/shuffles` := (n::nonnegint,m::nonnegint) -> proc(s)
 local i,j;
 return signum(mul(mul(s[j]-s[i],j=i+1..n+m),i=1..n+m-1));
end:


read "../ComputeIdentifiableFunctions.mpl";

cases := [
    [
        [[
            diff(x1(t), t) - (a * x1(t) - b * x1(t) * x2(t)),
            diff(x2(t), t) - (-c * x2(t) + d * x1(t) * x2(t) + u(t)),
            y(t) = x1(t)
        ],
        [x1, x2], [y], [u], [a, b, c, d]],
        [y(t) * diff(diff(y(t), t), t) - diff(y(t), t)^2 - y(t)^2 * diff(y(t), t) * d + y(t) * diff(y(t), t) * c + a * d * y(t)^3 + u(t) * y(t)^2 * b - a * c * y(t)^2]
    ],
    [
        [[
            diff(xa(t), t) + k1 * xa(t),
            diff(xb(t), t) - k1 * xa(t) + k2 * xb(t),
            diff(xc(t), t) - k2 * xb(t),
            diff(eA(t), t),
            diff(eC(t), t),
            y1(t) - xc(t),
            y2(t) - eA(t) * xa(t) - eB * xb(t) - eC(t) * xc(t),
            y3(t) - eA(t),
            y4(t) - eC(t)
        ],
        [xa, xb, xc, eA, eC], [y2, y1, y3, y4], [], [k1, k2, eB]],
        [
            k1 * k2 * (y2(t) - y1(t) * y4(t)) - eB * k1 * diff(y1(t), t) - k2 * y3(t) * diff(y1(t), t) - y3(t) * diff(diff(y1(t), t), t),
            diff(diff(diff(y1(t), t), t), t) + (k1 + k2) * diff(diff(y1(t), t), t) + k1 * k2 * diff(y1(t), t),
            diff(y3(t), t),
            diff(y4(t), t)
        ]
    ]
]:

num_passed := 0:
num_failed := 0:

for case in cases do
    input := case[1]:
    print(input);
    correct := case[2]:
    result := GetIOEquations(op(input), 0):
    passed := true:
    if nops(result) <> nops(correct) then
        passed := false:
    else
        for i from 1 to nops(result) do
            if simplify(result[i] - correct[i]) <> 0 then
                passed := false:
            end if:
        end do:
    end if:
    if passed = true then
        printf("PASSED");
        num_passed := num_passed + 1:
    else
        printf("FAILED");
        print(result);
        print(correct);
        num_failed := num_failed + 1:
    end if:
end do:

printf("Passed: %a, failed %a \n", num_passed, num_failed);


(*
 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 lda_c_pw_params
$include "lda_c_pw.mpl"

pw91_C_c0  := 4.235e-3:
pw91_alpha := 0.09:
pw91_nu    := 16/Pi * (3*Pi^2)^(1/3):
pw91_beta  := pw91_nu*pw91_C_c0:

pw91_c1 := pw91_beta^2/(2*pw91_alpha):
pw91_c2 := 2*pw91_alpha/pw91_beta:

(* Equation (14) *)
A := (rs, z) -> pw91_c2/(exp(-2*pw91_alpha*f_pw(rs, z)/(mphi(z)^3*pw91_beta^2)) - 1):

(* Equation (13) *)
H0 := (rs, z, t) -> pw91_c1*mphi(z)^3*log(1
  + pw91_c2*(t^2 + A(rs, z)*t^4) / (1 + A(rs, z)*t^2 + A(rs, z)^2*t^4)
):

(* Pade parametrized form of C-xc found in
   M Rasolt & DJW Geldart, Phys. Rev. B 34, 1325 (1986)
*)
RS_a := [2.568, 23.266, 0.007389]:
RS_b := [1, 8.723, 0.472]:
RG_C_xc := rs -> (RS_a[1] + RS_a[2]*rs + RS_a[3]*rs^2)/(1000*(RS_b[1] + RS_b[2]*rs + RS_b[3]*rs^2)):

(* Equation (15) *)
C_xc0 := 2.568e-3:
C_x   := -0.001667:
h_a1  := -100 * 4/Pi * (4/(9*Pi))^(1/3):

H1 := (rs, z, t) -> pw91_nu * (RG_C_xc(rs) - C_xc0 - 3*C_x/7)
 * mphi(z)^3*t^2*exp(h_a1*rs*mphi(z)^4*t^2):

f_pw91 := (rs, z, xt, xs0, xs1) ->
  f_pw(rs, z) + H0(rs, z, tt(rs, z, xt)) + H1(rs, z, tt(rs, z, xt)):
f      := (rs, z, xt, xs0, xs1) -> f_pw91(rs, z, xt, xs0, xs1):


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

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

(* type: work_lda *)

$define lda_x_params
$include "lda_x.mpl"

(* attenuation function *)
aux1_erf := a -> sqrt(Pi)*erf(1/(2*a)):
aux2_erf := a -> exp(-1/(4*a^2)) - 1:
aux3_erf := a -> 2*a^2*aux2_erf(a) + 1/2:
attenuation_erf := a -> 1 - 8/3*a*(aux1_erf(a) + 2*a*(aux2_erf(a) - aux3_erf(a))):

a_cnst := (4/(9*Pi))^(1/3)*p_a_cam_omega/2:

lda_x_erf_s := (rs, z) -> convert(piecewise(z = -1, 0,
  (1 + z)^(4/3)*attenuation_erf(a_cnst*rs/(1 + z)^(1/3))
), 'Heaviside'):

f_lda_x_erf := (rs, z) -> lda_x_ax*(
   lda_x_erf_s(rs, z) + lda_x_erf_s(rs, -z)
)/rs:

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


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

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

(* type: mgga_exc *)

(* replace: "BesselI\(0, " -> "xc_bessel_I0(" *)
(* replace: "BesselI\(1, " -> "xc_bessel_I1(" *)

$define xc_dimensions_2d

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

(* This is the solution of solve((y-1)*exp(y) = x/Pi) *)
prhg07_y := x -> LambertW(m_max(x/Pi, -0.9999999999) * exp(-1)) + 1:

prhg07_v := y -> Pi/X_FACTOR_2D_C * BesselI(0, y/2):

prhg07_f := (x, u, t) ->
  prhg07_v(prhg07_y(prhg07_C(x, u, t)))/2:

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


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

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

(* type: work_mgga_x *)

(* bottom left column on page 687 of article *)
e1 := -1.6665:
c1 :=  0.7438:

(* equation 10 *)
fa := a -> (1 - a) / ((1 + e1*a^2)^2 + c1*a^4)^(1/4):

(* between eqs 8 and 9 *)
k0 := 0.174:
(* after eq 11 *)
b  := 0.0233:

(* eq 7 *)
f := (rs, x, t, u) -> (1 + k0*fa((t-x^2/8)/K_FACTOR_C)) / (1 + b*(X2S*x)^4)^(1/8):


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

a0 := 0.93222*RS_FACTOR:
kk := 9.47362e-3*RS_FACTOR:

f := (rs, zeta) -> -a0*(1 - kk*log(1 + rs/kk)/rs)/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: lda_exc *)
(* prefix:
  lda_c_2d_prm_params *params;

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

  assert(params->N > 1);
*)

$define xc_dimensions_2d

prm_q := 3.9274: (* 2.258 *)

(* Equation (4) *)
beta := rs -> prm_q/(sqrt(Pi)*rs):

phi  := rs -> beta(rs)/(beta(rs) + sqrt(Pi)/2):

f0 := rs ->
  + sqrt(Pi)*beta(rs)*(phi(rs) - 1)/(2*sqrt(2 + params_a_c)) (* original version has (phi-1)^2 *)
  + phi(rs)*(phi(rs) - 1)/(2 + params_a_c)
  + sqrt(Pi)*phi(rs)*phi(rs)/(4*beta(rs)*(2 + params_a_c)^1.5)
  + sqrt(Pi)*beta(rs)*(phi(rs) - 1)/sqrt(1 + params_a_c)
  + phi(rs)/(1 + params_a_c):

f  := (rs, z) -> f0(rs)*Pi/(2*prm_q*prm_q):


`is_element/raw_matroids` := proc(M)
 global reason;
 local n,s,t,s1,t1,u,a,b;

 if not(type(M,set(set))) then
  reason := ["not a set of sets"];
  return false;
 fi;

 n := nops(M);
 for s in M do
  for t in M do
   if s <> t then
    s1 := s minus t;
    t1 := t minus s;
    if s1 = {} or t1 = {} then
     reason := ["s and t are nested",s,t];
     return false;
    fi;
    for a in s1 do
     u := select(b -> member((s minus {a}) union {b},M),t1);
     if u = {} then
      reason := ["exchange fails",s,t];
      return false;
     fi;
    od;
   fi;
  od;
 od;

 return true;
end:

`vertices/raw_matroid` := (M) -> map(op,{op(M)});

`is_basis/raw_matroid` := (M,s) -> member(s,M);

`is_independent/raw_simplicial_complex` := proc(M,s)
 local s0,u;

 if not(type(s,{list,set})) then return false; fi;

 s0 := {op(s)};

 for u in M do
  if s0 minus {op(u)} = {} then
   return true;
  fi;
 od:
 return false;
end:

`is_dependent/raw_simplicial_complex` := proc(M,s)
 local s0,u;

 if not(type(s,{list,set})) then return false; fi;

 s0 := {op(s)};

 for u in M do
  if s0 minus {op(u)} = {} then
   return false;
  fi;
 od:
 return true;
end:

`is_element/matroids` := proc(T)
 global reason;

 if not(type(T,table)) then
  return false;
 fi;

 if not (`is_element/raw_matroids`(T["bases"])) then
  return false;
 fi;

 if `vertices/raw_matroid`(T["bases"]) minus T["vertices"] <> {} then
  reason := ["vertex mismatch",T["vertices"],`vertices/raw_matroid`(T["bases"])];
  return false;
 fi;

 return true;
end:

`cook/raw_matroid` := proc(M,V_)
 local T;

 T := table():
 if nargs > 1 then
  T["vertices"] := V_;
 else
  T["vertices"] := `vertices/raw_matroid`(M);
 fi;
 T["bases"] := M;

end:

`set_rank/matroid` := proc(T)
 local m,r,n,P,A;

 m := nops(T["vertices"]);
 r := table():
 n := table():
 P := combinat[powerset](T["vertices"]);
 for A in P do
  r[A] := max(op(map(s -> nops(s intersect A),T["bases"])));
  n[A] := m - r[A];
 od:

 T["rank"] := eval(r);
 T["nullity"] := eval(r);
end:

`set_closure/matroid` := proc(T)
 local r,V,P,c,A,m;

 if not(type(T["rank"],table)) then `set_rank/matroid`(T); fi;

 r := eval(T["rank"]);
 V := T["vertices"];
 P := combinat[powerset](T["vertices"]);
 c := table():
 for A in P do
  m := r[A];
  c[A] := A union select(b -> r[A union {b}] = m + 1,V minus A);
 od:

 T["closure"] := eval(c):
 T["flats"] := select(A -> nops(c[A]) = nops(A),P);
end:

`res/matroid` := proc(T,A)
 local U,B,m;

 if not(type(A,set) and A minus T["vertices"] = {}) then
  error("A is not a subset of the vertices of T");
 fi;

 U := table():
 U["vertices"] := A;
 B := map(s -> s intersect A,T["bases"]);
 m := max(map(nops,B));
 U["bases"] := select(s -> nops(s) = m,T["bases"]);
end:

uniform_matroid := proc(A_::{nonnegint,set},k)
 local T,A;

 if type(A_,nonnegint) then
  A := {seq(i,i=1..A_)};
 else
  A := A_;
 fi;

 T := table():
 T["vertices"] := A;
 T["bases"] := combinat[choose](A,k);

 return eval(T);
end:

linear_matroid := proc(p,d)
 local T,V,i,j,B,f;

 V := [[]];

 for i from 1 to d do
  V := [seq(seq([op(v),j],j=0..p-1),v in V)];
 od:

 B := [seq([j],j=2..p^d)];
 for i from 2 to d do
  B := [seq(seq([op(b),j],j=b[-1]+1..p^d),b in B)];
 od:

 f := b -> modp(Determinant(Matrix(map(i -> V[i],b))),p);
 B := select(b -> f(b) <> 0,B);

 T := table():
 T["vectors"] := V;
 T["vertices"] := {seq(i,i=1..p^d)};
 T["bases"] := map(b -> {op(b)},{op(B)});

 return eval(T);
end:


! Tsp36.mpl

TITLE
    Tsp36;

DATA
    NumCity := 36;

INDEX
    city := 1..NumCity;
    city2 := city;

DATA
    Cost[city, city2] := DATAFILE("Tsp36.dat");

BINARY VARIABLE
    Route[city, city2] WHERE (city <> city2) -> x;

INTEGER VARIABLE
    SeqNr[city] -> s;

MODEL

    MIN TotalCost = SUM(city, city2: Cost * Route);

SUBJECT TO

    Horz[city]: SUM(city2: Route) = 1;

    Vert[city2]: SUM(city: Route) = 1;

    SetSeq[city, city2 > 1]  WHERE (city <> city2):

        SeqNr[city] - SeqNr[city:=city2] + NumCity * Route <= NumCity - 1;

BOUNDS
    Tour[city]:  1 <= SeqNr <= NumCity;

END


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

testinput := "6,10
0,14
9,10
0,3
10,4
4,11
6,0
6,12
4,1
0,13
10,12
3,4
3,0
8,4
1,10
2,14
8,10
9,0

fold along y=7
fold along x=5";

split:=StringTools:-Split(input, "\n"):
member("", split, 'loc'); loc;

coords := split[1..loc-1]:
folds := split[loc+1..-1];
coords := {map(p->[parse(p)], coords)[]}:
folds := parse~(map(s->StringTools:-SubstituteAll(s, "fold along ", ""), folds));

vis := coords->plots:-display(plottools:-point(map(c->[c[1],-c[2]], [coords[]]),
    symbol=solidbox, symbolsize=20), axes=boxed, scaling=constrained):

newcoords := coords:
for f in folds do
    if lhs(f) = 'y' then
        (c1,c2) := selectremove(p->p[2]<rhs(f), newcoords);
        c2 := map(p->[p[1], 2*rhs(f)-p[2]], c2);
        newcoords := c1 union c2;
    else
        (c1,c2) := selectremove(p->p[1]<rhs(f), newcoords);
        c2 := map(p->[2*rhs(f)-p[1], p[2]], c2);
        newcoords := c1 union c2;
    end if;
    if f = folds[1] then
        answer1 := nops(newcoords);
    end if;
end do:
answer1;
vis(newcoords);


# Proof by PDF that
#	if X <~ standardChiSq(n) then cX <~ gamma(k = n/2, t = 2*c)

PDF_chisq := (n, x) -> x^(n/2-1)*exp(-x/2)/(2^(n/2)*GAMMA(n/2));
PDF_cX := (n, c, x) -> PDF_chisq(n, x/c)/c;
PDF_sub := (k, t, x) -> PDF_cX(2*k, t/2, x);
simplify(PDF_sub(k, t, x));

PDF_gamma := (k, t, x) -> x^(k-1)*exp(-x/t)/(GAMMA(k)*t^k);
simplify(PDF_gamma(k, t, x));

# NOTE: Doesn't evaluate true, but inspection of forms given by
#		the 2 calls to simplify prove it so
evalb(PDF_sub(k, t, x) = PDF_gamma(k, t, x));


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

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

(* type: work_lda *)
(* prefix:
  lda_c_ml1_params *params;

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

C := 6.187335:
b := [2.763169, 1.757515, 1.741397, 0.568985, 1.572202, 1.885389]:

malpha := z -> params_a_fc*((1 + z)^params_a_q + (1 - z)^params_a_q):
mbeta  := z -> (1 + z)^(1/3)*(1 - z)^(1/3)/((1 + z)^(1/3) + (1 - z)^(1/3)):

k := (rs, z) -> C*malpha(z)*mbeta(z)*RS_FACTOR/rs:
Q := (rs, z) ->
  - b[1]/(1 + b[2]*k(rs, z))
  + b[3]*log(1 + b[4]/k(rs, z))/k(rs, z)
  + b[5]/k(rs, z)
  - b[6]/k(rs, z)^2:

f := (rs, zeta) -> 1/2*(RS_FACTOR/rs)^3 * (1 - zeta^2)/4 * Q(rs, zeta):


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

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

(* type: gga_exc *)

pbea_mu    := 0.00361218645365094697:
pbea_alpha := 0.52:

pbea_f  := x -> 1 + KAPPA_PBE*(1 - (1 + pbea_mu*x^2/(pbea_alpha*KAPPA_PBE))^(-pbea_alpha)):

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


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

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

(* type: work_mgga_x *)

mlambda := 0.6866:
mbeta   := 79.873:

(* below Equation (6) *)
y  := p -> (2*mlambda - 1)^2 * p:

(* Equation (7) *)
f0 := x -> (1 + 10*70*y(X2S^2*x^2)/27 + mbeta*y(X2S^2*x^2)^2)^(1/10):

R  := (x, t) -> 1 + 595*(2*mlambda - 1)^2 * X2S^2*x^2/54 \
   - (t - 3*(mlambda^2 - mlambda + 1/2)*(t - K_FACTOR_C - x^2/72))/K_FACTOR_C:

fx_DME := (x, t) -> 1/f0(x)^2 + 7*R(x, t)/(9*f0(x)^4):

malpha := (x, t) -> (t - x^2/8)/K_FACTOR_C:
qtilde := (x, t) -> 9/20*(malpha(x, t) - 1) + 2*X2S^2*x^2/3:

fx_SC_aux := (x, t) -> (1 + 10*( \
       + (MU_GE + 50*X2S^2*x^2/729)*X2S^2*x^2 \
       + 146*qtilde(x, t)^2/2025 \
       - 73*qtilde(x,t)/405*(3*K_FACTOR_C/(5*t))*(1 - K_FACTOR_C/t))
       ):

(* It turns out that the quantity fx_SC_aux can become negative, leading to NaN.
   this appears, for example, for the following densities

   ./xc-get_data 540 1 729.292719352103 0 365940004.708665 0 0 -970050.160877395 0 64600.7149099035 0

   As a turn around, I demand that the function is always larger than 1e-16
*)
fx_SC  := (x, t) -> m_max(fx_SC_aux(x,t), 1e-16)^(0.1):

w := t-> (K_FACTOR_C^2/t^2 + 3*K_FACTOR_C^3/t^3)/(1 + K_FACTOR_C^3/t^3)^2:

f := (rs, x, t, u) -> w(t)*fx_DME(x, t) + (1 - w(t))*fx_SC(x, t):


# Euler found rational curves on the surface given by
# w+x+y+z = wxyz + a = 0.  The formula here is similar to Euler's
# but simpler, and is taken from slides of Elkies

`f/euler_quartic` := proc(a,x) local i; [add(x[i],i=1..4),mul(x[i],i=1..4)+a]; end:

`g/euler_quartic` := (a,s) -> [
 1/2*s^(-3)*(s^4-4*a)^( 2)*(s^4+12*a)^(-1),
 2*a*s^(-3)*(s^4-4*a)^(-1)*(s^4+12*a)^(-1)*(3*s^4+4*a)^2,
 1/2*s     *               (s^4+12*a)     *(3*s^4+4*a)^(-1),
  -2*s^5   *(s^4-4*a)^(-1)*(s^4+12*a)     *(3*s^4+4*a)^(-1)
];

check_euler_quartic := proc()
 local a,s;

 _ASSERT(
  simplify(`f/euler_quartic`(a,`g/euler_quartic`(a,s))) = [0,0],
  "Euler quartic relation"
 );
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 *)

a5  := 133.983631:
a6  :=   3.217063:
a7  := 136.707378:
a8  :=   3.223476:
a9  :=   2.675484:
a10 :=   3.473804:

f1 := s -> (1 - a5*s^a6 + a7*s^a8)/(1 + a9*s^a10):

$include "gga_x_lag.mpl"
unassign('f'):

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


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

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

(* type: work_mgga_x *)

a := 0.5389:
b := 3:

p := x -> X2S^2*x^2:
q := u -> X2S^2*u:

(* Equation (15) *)
fab := z -> piecewise( \
    z<=0, 0, \
    z>=a, 1, \
    (1 + exp(a/(a-z)))^b/(exp(a/z) + exp(a/(a-z)))^b \
):

(* Equation (7) *)
mDelta := (x, u) -> 8*q(u)^2/81 - p(x)*q(u)/9 + 8*p(x)^2/243:

f_W    := x -> 5*p(x)/3:

(* Equation (8) *)
f_GE4  := (x, u) -> 1 + 5*p(x)/27 + 20*q(u)/9 + mDelta(x, u):

(* Equation (11) *)
f_GE4_M := (x, u) -> f_GE4(x, u)/sqrt(1 + mDelta(x, u)^2/(1 + f_W(x))^2):

(* Equation (17) *)
f   := (rs, x, t, u) -> f_W(x) + (f_GE4_M(x, u) - f_W(x))*fab(f_GE4_M(x, u) - f_W(x)):


# If X ~ Exp(α) then e^−X ~ Beta(1/α, 1).

# Proof:

PDF_exponential := (alpha, x) -> exp(-x/alpha)/alpha;

PDF_beta := (beta, gamma, x) -> GAMMA(beta+gamma) * x^(beta-1) * (x - 1)^(gamma-1) / GAMMA(beta) / GAMMA(gamma);

simplify(PDF_exponential(1/lambda, -log(x))*diff(log(x), x));

simplify(PDF_beta(lambda, 1, 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 *)

(* eqn (5) *)
meyer_feta := y -> 1/2*(1 + (1 - y^2)*log((1 + y)/abs(1 - y))/(2*y)):

(* eqn (7) *)
meyer_lambda := y -> (1 - meyer_feta(y)) / (3 * y^2 * meyer_feta(y)):

(* enhancement factor from eqn (1) *)
meyer_f := x -> 1 + meyer_lambda(X2S*x/6)*x^2/(8*K_FACTOR_C):

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


######################################################################
# epi(A,B) is the set of surjective maps from A to B

`is_element/epi` := (A::set,B::set) -> proc(p)
 local a,b,hit;
 global reason;

 if not `is_element/maps`(A,B)(p) then
  reason := [convert(procname,string),"p is not a map from A to B",p,A,B,reason];
  return false;
 fi;

 hit := table();
 for b in B do hit[b] := false; od;
 for a in A do hit[p[a]] := true; od;
 for b in B do if not hit[b] then
  reason := [convert(procname,string),"b is not hit",b];
  return false;
 fi; od;
 return true;
end;

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

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

 return true;
end;

`is_leq/epi` := NULL;

`random_element/epi` := (A::set,B::set) -> proc()
 local p,m,n,A0,r,i;

 n := nops(A);
 m := nops(B);
 if m > n then return FAIL; fi;

 p := table();
 A0 := combinat[randperm]([op(A)]);

 for i from 1 to m do p[A0[i]] := B[i]; od;

 r := rand(1..m);

 for i from m+1 to n do p[A0[i]] := B[r()]; od;

 return eval(p);
end;

`list_elements/epi` := proc(A::set,B::set)
 local n,m,B0,b,E,E0,k,CC,C,c,p0,p;

 n := nops(A);
 m := nops(B);

 if n < m then return []; fi;
 if m = 0 then
  if n = 0 then
   return [table()];
  else
   return [];
  fi;
 fi;

 B0 := sort(B);
 b := B0[1];
 B0 := {op(2..-1,B0)};

 E := [];

 for k from 1 to n-m+1 do
  CC := combinat[choose](A,k);
  for C in CC do
   E0 := `list_elements/epi`(A minus C,B0);
   for p0 in E0 do
    p := copy(p0);
    for c in C do p[c] := b; od;
    E := [op(E),eval(p)];
   od;
  od;
 od;

 return E;
end;

`count_elements/epi` := (A::set,B::set) -> Stirling2(nops(A),nops(B)) * nops(B)!;


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

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

(* type: lda_exc *)
(* replace: "BesselK\(0," -> "xc_bessel_K0(" *)
(* replace: "BesselK\(1," -> "xc_bessel_K1(" *)
(* replace: "int1\(" -> "xc_integrate(func1, NULL, 0.0, " *)
(* replace: "int2\(" -> "xc_integrate(func2, NULL, 0.0, " *)
(* prefix:
  lda_x_1d_exponential_params *params;

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

$include "lda_x_1d_exponential.mpl"

x1d_inter := x -> 2.0*BesselK(0, x):


`is_element/young_partitions` := (k,n) -> proc(lambda)
 local i;

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

 if nops(lambda) <> k then
  return false;
 fi;

 if k > 0 and lambda[1] > n-k then
  return false;
 fi;

 for i from 1 to k-1 do
  if lambda[i] < lambda[i+1] then
   return false;
  fi;
 od;

 return true;
end:

`young_partition/from_set` := (n,k) -> proc(P)
 local i;
 return [seq(n-k+i-P[i],i=1..k)];
end:

`list_elements/young_partitions` := proc(n,k)
 map(`young_partition/from_set`(n,k),combinat[choose](n,k));
end:

`random_element/young_partitions` := (n,k) -> proc()
 if k > n then return FAIL; fi;
 `young_partition/from_set`(n,k)(combinat[randcomb](n,k));
end:

`count_elements/young_partitions` := (n,k) -> binomial(n,k);

`weight/young_partitions` := (lambda) -> `+`(op(lambda)):

`length/young_partitions` := (lambda) -> nops(lambda):

`cell_dim/young_partitions` := (n,k) ->
 k * (n - k) - `weight/young_partitions`(lambda):

`matrix/young_partitions` := (n,k) -> (lambda) -> proc(a)
 local A,P,S,u,i,j;
 A := Matrix(k,n);
 P := [seq(n-k+i-lambda[i],i=1..k)];
 S := {op(P)};
 u := 1;
 for i from 1 to k do
  for j from 1 to P[i] - 1 do
   if not(member(j,S)) then
    A[i,j] := a[u];
    u := u+1;
   fi;
  od:
  A[i,P[i]] := 1;
 od:
 return A;
end:

`giambelli_matrix/young_partitions` := proc(lambda)
 local i,j,k,f;
 k := nops(lambda);
 f := (i) -> `if`(i < 0,0,`if`(i = 0,1,c[i]));
 Matrix([seq([seq(f(lambda[i]-i+j),j=1..k)],i=1..k)]);
end:

`schur_function/young_partitions` := (lambda) ->
 Determinant(`giambelli_matrix/young_partitions`(lambda)):


`mu/BA` := proc()
 apply_bilinear_assoc(`mu_aux0/BA`,`bar/BA`())(args);
 local xx,ca,cb,pa,pb;
 if nargs > 2 then
  return `mu/BA`(`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/BA`,a,b);
 elif type(b,`+`) then
  return map2(`mu/BA`,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,`bar/BA`)) and
    type(pb,specfunc(anything,`bar/BA`)) then
  return expand(ca*cb*`mu_aux0/BA`(pa,pb));
 else
  return('`mu/BA`'(args))
 fi;
end:

`mu/EA` := proc()
 apply_linear_assoc(`mu0/EA`,`bar/EA`())(args);
end:

`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:


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

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

ak13_f0 := s -> 1 + params_a_B1*s*log(1 + s) + params_a_B2*s*log(1 + log(1 + s)):
ak13_f  := x -> ak13_f0(X2S*x):

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

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

ml1_C := 6.187335:
ml1_b := [2.763169, 1.757515, 1.741397, 0.568985, 1.572202, 1.885389]:

ml1_alpha := z -> params_a_fc*((1 + z)^params_a_q + (1 - z)^params_a_q):
ml1_beta  := z -> (1 - z^2)^(1/3)/((1 + z)^(1/3) + (1 - z)^(1/3)):

(* From the paper: "Note that the antiparailel-spin correlation length
   diverges when the spin-polarization parameter tends to 1", which means
   that Q diverges for a ferromagnetic density *)
ml1_k := (rs, z) -> ml1_C*n_total(rs)^(1/3) * ml1_alpha(z)*ml1_beta(z):

(* Eq. 32 *)
ml1_Q := (rs, z) ->
  - ml1_b[1]/(1 + ml1_b[2]*ml1_k(rs, z))
  + ml1_b[3]*log(1 + ml1_b[4]/ml1_k(rs, z))/ml1_k(rs, z)
  + ml1_b[5]/ml1_k(rs, z)
  - ml1_b[6]/ml1_k(rs, z)^2:

(* screen for small spin densities to avoid divergences in the
  potentials.  Note that beta is zero for any polarized density and
  the whole expression for alpha*beta is symmetric in z.  Note also
  that in the expression for Q one divides by k that is zero for
  ferromagnetic densities. *)

(* there is a factor of 1/2 wrong in Eq. 31 as explained in the Erratum *)
(* With the formula below we can reproduce exactly the values of Table I.
   Note that in the Erratum the authors afirm that all the results are correct,
   and only the formulas had misspells. *)
ml1_f := (rs, z) -> n_total(rs) *
  my_piecewise3(1 - abs(z) <= p_a_zeta_threshold, 0, (1 - z^2)/4 * ml1_Q(rs, z_thr(z))):

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


# Generated using bssn_4d_spher_matter.mw
eq_evol_rPIb2:=
diff(rPIb2(t,x) ,t) =
expand( simplify (
(-mass*rpsi(t,x) + 2*(diff(rpsi(t, x), x))/(a1(t, x)^2*x)+(diff(diff(rpsi(t, x), x), x))/a1(t, x)^2-(diff(rpsi(t, x), x))*(diff(a1(t, x), x))/a1(t, x)^3+2*rPIb2(t, x)*beta(t, x)/(alpha(t, x)*b1(t, x)^2*a1(t, x)*x)+beta(t, x)*(diff(rPIb2(t, x), x))/(alpha(t, x)*b1(t, x)^2*a1(t, x))+rPIb2(t, x)*(diff(beta(t, x), x))/(alpha(t, x)*b1(t, x)^2*a1(t, x))+2*(diff(rpsi(t, x), x))*(diff(b1(t, x), x))/(b1(t, x)*a1(t, x)^2)+(diff(rpsi(t, x), x))*(diff(alpha(t, x), x))/(alpha(t, x)*a1(t, x)^2) ) * (alpha(t,x)*b1(t,x)^2*a1(t,x))
) );

eq_evol_iPIb2:=
(diff(iPIb2(t, x), t)) = expand( simplify (

( -mass*ipsi(t,x) + 2*(diff(ipsi(t, x), x))/(a1(t, x)^2*x)+(diff(diff(ipsi(t, x), x), x))/a1(t, x)^2-(diff(ipsi(t, x), x))*(diff(a1(t, x), x))/a1(t, x)^3+2*iPIb2(t, x)*beta(t, x)/(alpha(t, x)*b1(t, x)^2*a1(t, x)*x)+iPIb2(t, x)*(diff(beta(t, x), x))/(alpha(t, x)*b1(t, x)^2*a1(t, x))+2*(diff(ipsi(t, x), x))*(diff(b1(t, x), x))/(b1(t, x)*a1(t, x)^2)+(diff(ipsi(t, x), x))*(diff(alpha(t, x), x))/(alpha(t, x)*a1(t, x)^2)+beta(t, x)*(diff(iPIb2(t, x), x))/(alpha(t, x)*b1(t, x)^2*a1(t, x))) * (alpha(t,x)*b1(t,x)^2*a1(t,x))
) );

eq_evol_rpsi := diff(rpsi(t,x),t) = alpha(t,x)/a1(t,x)*rPI(t,x)+beta(t,x)*rPHI(t,x);

eq_evol_ipsi := diff(ipsi(t,x),t) = alpha(t,x)/a1(t,x)*iPI(t,x)+beta(t,x)*iPHI(t,x);


read "../ComputeIdentifiableFunctions.mpl":

cases := [
    [
        [[a * b, b], [a]],
        [1 / a]
    ],
    [
        [[a + b, a * b], [b]],
        []
    ],
    [
        [[a * b + c, b], [a, c]],
        []
    ],
    [
        [[a * b, c * b, d * b], [a, c, d]],
        [a / c, a / d]
    ],
    [
        [[a + b + c, a^2 + b^2 + c^2, a^3 + b^3 + c^3, c], [a, b]],
        [a + b, a * b]
    ],
    [
        [[a + b, a * b, x, a * x + b * c], [a, b, c]],
        [a + b, a * b]
    ]
]:

num_passed := 0:
num_failed := 0:

for case in cases do
    input := case[1]:
    correct := case[2]:
    if IdealsEq(FieldIntersection(op(input)), FieldToIdeal(correct)) then
        printf("PASSED\n");
        num_passed := num_passed + 1:
    else
        printf("FAILED\n");
        num_failed := num_failed + 1:
        print("Expected: ", correct);
        print("Got: ", FieldIntersection(op(input)));
    end if:
end do:

printf("Passed: %a, failed %a \n", num_passed, num_failed);


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

ogrid := ((parse~)@StringTools:-Explode)~(subs(""=NULL,StringTools:-Split(input))):
gridw := nops(ogrid[1]);
gridl := nops(ogrid);
grid := [ [ 9 $ (gridw+2) ], map(l->[9,l[],9], ogrid)[],  [ 9 $ (gridw+2) ] ]:

lowpoints := NULL:
risklevel := 0:
for i from 2 to gridl+1 do
    for j from 2 to gridw+1 do
        if      grid[i][j] < grid[i-1][j]
            and grid[i][j] < grid[i+1][j]
            and grid[i][j] < grid[i][j-1]
            and grid[i][j] < grid[i][j+1]
        then
            lowpoints := lowpoints, [i,j];
            risklevel := risklevel + grid[i][j]+1;
        end if;
    end do;
end do:

answer1 := risklevel;

counted := table(sparse=0):
basinsize := proc( input )
global grid, counted;
local nb, x, y, v;

    x, y, v := op(input);

    if v = 9 or counted[input] <> 0 then
        return 0;
    end if;

    nb := [[x, y-1], [x, y+1], [x-1, y], [x+1,y]];
    nb := remove( n->(min(n)<2 or n[1]>gridl+2 or n[2]>gridw+2), nb);
    nb := map(n->[n[1], n[2], grid[n[1]][n[2]]], nb);
    #nb := remove(n->n[3]=9 or n[3] < v, nb); # for non-9 bounded basins

    counted[ input ] := 1;

    if nb = [] then
        return 1;
    else
        return add(map(thisproc, nb))+1;
    end if;
end proc:

bs := map(l->basinsize([l[], grid[l[1]][l[2]]]), [lowpoints]):
answer2 := mul( sort(bs)[-3..-1] );


# Proof by PDF that X <~ rayleigh(1) == X^2 <~ gamma(1,2)

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

PDF_gamma := (k, t, x) -> x^(k-1)*exp(-x/t)/(GAMMA(k)*t^k);
simplify(PDF_gamma(1, 2, x));

PDF_transform := (x) -> PDF_rayleigh(2,sqrt(x))*diff(sqrt(x),x);
simplify(PDF_transform(x));

evalb(PDF_gamma(1, 2, x) = PDF_transform(x));


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

(* error function:
    Toulouse et al, Int. J. of Quant. Chem. 100, 1047 (2004); doi:10.1002/qua.20259
    Tawada et al, J. Chem. Phys. 120, 8425 (2004); doi:10.1063/1.1688752
*)
att_erf_aux1 := a -> sqrt(Pi)*erf(1/(2*a)):
att_erf_aux2 := a -> exp(-1/(4*a^2)) - 1:
att_erf_aux3 := a -> 2*a^2*att_erf_aux2(a) + 1/2:
(* This is the full function, which is numerically unstable for large a *)
attenuation_erf0 := a ->
  1 - 8/3*a*(att_erf_aux1(a) + 2*a*(att_erf_aux2(a) - att_erf_aux3(a))):
(* The cutoff and order are determined by check_attenuation.mpl *)
attenuation_erf := a -> enforce_smooth_lr(attenuation_erf0, a, 1.35, 16):

(* These are for hyb_mgga_x_js18 and hyb_mgga_x_pjs18. This is the
bracket in eqn (10) in Patra et al, 2018 *)
attenuation_erf_f20 := a ->
  1 + 24*a^2*( (20*a^2 - 64*a^4)*exp(-1/(4*a^2))
    - 3 - 36*a^2 + 64*a^4
    + 10*a*sqrt(Pi)*erf(1/(2*a))):
(* The cutoff and order are determined by check_attenuation.mpl *)
attenuation_erf_f2 := a -> enforce_smooth_lr(attenuation_erf_f20, a, 0.27, 46):

(* This is eqn (11) in Patra et al, 2018  *)
attenuation_erf_f30 := a ->
  1 + 8/7*a*(
        (-8*a + 256*a^3 - 576*a^5 + 3840*a^7 - 122880*a^9)*exp(-1/(4*a^2))
      + 24*a^3*(-35 + 224*a^2 - 1440*a^4 + 5120*a^6)
      + 2*sqrt(Pi)*(-2 + 60*a^2)*erf(1/(2*a))):
(* The cutoff and order are determined by check_attenuation.mpl *)
attenuation_erf_f3 := a -> enforce_smooth_lr(attenuation_erf_f30, a, 0.32, 38):

(* erf_gau - screening function = + 2 mu/sqrt(pi) exp(-mu^2 r^2)
    Song et al, J. Chem. Phys. 127, 154109 (2007); doi:10.1063/1.2790017
    You can recover the result in Int. J. of Quant. Chem. 100, 1047 (2004)
    by putting a = a/sqrt(3) and multiplying the whole attenuation function by -sqrt(3)
*)
attenuation_gau0 := a -> -8/3*a*(att_erf_aux1(a) + 2*a*att_erf_aux2(a)*(1 - 8*a^2) - 4*a):
(* The cutoff and order are determined by check_attenuation.mpl *)
attenuation_gau := a -> enforce_smooth_lr(attenuation_gau0, a, 2.07, 14):

(* yukawa
    Akinaga and Ten-no, Chem. Phys. Lett. 462, 348 (2008); doi:10.1016/j.cplett.2008.07.103
*)
att_yuk_aux1 := a -> arctan(1, a):
att_yuk_aux2 := a -> log(1 + 1/a^2):
att_yuk_aux3 := a -> a^2 + 1:
attenuation_yukawa0 := a -> 1 - 8/3*a*(att_yuk_aux1(a) + a/4*(1 - (att_yuk_aux3(a) + 2)*att_yuk_aux2(a))):
(* The cutoff and order are determined by check_attenuation.mpl *)
attenuation_yukawa := a -> enforce_smooth_lr(attenuation_yukawa0, a, 1.92, 36):


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

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

(* type: lda_exc *)

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

f := (rs, zeta) -> a*log(rs) + b + c*rs*log(rs) + d*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 *)

(* constants from text in section 2 *)
pbetrans_kappa_pbe := 0.814: (* This is probably a misprint in the manuscript as KAPPA_PBE is 0.8040 *)
pbetrans_kappa_revpbe := 1.227:
pbetrans_mu := 0.219:

(* parameters from section 4 *)
pbetrans_alpha := 2*(3*Pi^2)^(1/3):
pbetrans_beta := 3:

(* eq 3 *)
pbetrans_fermi := s -> 1/(1+exp(-pbetrans_alpha*(s-pbetrans_beta))):
(* eq 5 *)
pbetrans_kappa := s -> (1-pbetrans_fermi(s))*pbetrans_kappa_revpbe + pbetrans_fermi(s)*pbetrans_kappa_pbe:
(* eq 4 *)
pbetrans_f0 := s -> 1 + pbetrans_kappa(s)*(1 - pbetrans_kappa(s)/(pbetrans_kappa(s) + pbetrans_mu*s^2)):

pbetrans_f  := x -> pbetrans_f0(X2S*x):

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


Fun2 := module()

  description "fun2";

  # Module defined as a package (i.e.) collection of procedures
  option package, load = ModuleLoad, unload = ModuleUnLoad;

  export fun, grad, hess, F, JF;

  local ModuleLoad,
        ModuleUnLoad,
        f1, f2, f12,
        CST;

  uses LinearAlgebra;

  ModuleLoad := proc()
    CST := 53/27;
    NULL;
  end proc;

  ModuleUnLoad := proc()
    NULL;
  end proc:

  # Explicitly call ModuleLoad here so the type is registered when this
  # code is cut&pasted in.  ModuleLoad gets called when the module is
  # read from the repository, but the code used to define a module
  # (like the command below) is not called at library read time.
  ModuleLoad();

  f1  := unapply( sin(3*x+5*y)+x+exp(3*(x-y))-1, (x,y) );
  f2  := unapply( (CST*x^2+2*y^2+cos(x-y)^2), (x,y) );
  f12 := unapply( f1(x,y)^2+f2(x,y)^2, (x,y) );

  fun := proc( X::Vector )
    local x, y;
    x := X[1];
    y := X[2];
    f12(x,y);
  end proc;

  grad := proc( X::Vector )
    local x, y;
    x := X[1];
    y := X[2];
    eval(<D[1](f12)(x,y),D[2](f12)(x,y)>);
  end proc;

  hess := proc( X::Vector )
    local x, y, d11, d12, d22;
    x   := X[1];
    y   := X[2];
    d11 := eval(D[1,1](f12)(x,y));
    d12 := eval(D[1,2](f12)(x,y));
    d22 := eval(D[2,2](f12)(x,y));
    <<d11,d12>|<d12,d22>>;
  end proc;

  F := proc( X::Vector )
    local x, y;
    x := X[1];
    y := X[2];
    <f1(x,y),f2(x,y)>;
  end proc;

  JF := proc( X::Vector )
    local x, y;
    x := X[1];
    y := X[2];
    <<D[1](f1)(x,y),D[1](f2)(x,y)>|
     <D[2](f1)(x,y),D[2](f2)(x,y)>>;
  end proc;

end module:


moore_net_complex := proc(n::posint)
 local T,m,i;

 m := 3*n;

 T["vertices"] := {seq(i,i=1..2*m+1)};
 T["faces"] := {
  seq({1,2+i,2+modp(i+1,m)},i=0..m-1),
  seq({2+i,2+modp(i+1,m),m+2+modp(i+1,m)},i=0..m-1),
  seq({2+i,m+2+i,m+2+modp(i+1,m)},i=0..m-1)
 };

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

 T["embedding_dim"] := 2;
 T["embedding"] := table([
  1 = [0,0],
  seq(i = [2*cos(2*Pi*(i-2)/m),2*sin(2*Pi*(i-2)/m)],i=2..m+1),
  seq(i = [3*cos(2*Pi*(i-m-2)/m),3*sin(2*Pi*(i-m-2)/m)],i=m+2..2*m+1)
 ]);

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

 return eval(T);
end:

moore_complex := proc(n::posint)
 local T0,T,m,i;

 m := 3*n;

 T["vertices"] := {seq(i,i=1..m+4)};
 T["faces"] := {
  seq({1,2+i,2+modp(i+1,m)},i=0..m-1),
  seq({2+i,2+modp(i+1,m),m+2+modp(i+1,3)},i=0..m-1),
  seq({2+i,m+2+modp(i,3),m+2+modp(i+1,3)},i=0..m-1)
 };
 T["max_simplices"] := T["faces"];

 return eval(T);
end:

punctured_moore_complex := proc(n::posint)
 local T,E,F,m,a,R0,R1,tor,tor_arc,i,v;

 m := 3*n;

 T["vertices"] := {seq(i,i=2..m+4)};
 F := {
  seq({2+i,2+modp(i+1,m),m+2+modp(i+1,3)},i=0..m-1),
  seq({2+i,m+2+modp(i,3),m+2+modp(i+1,3)},i=0..m-1)
 };
 T["faces"] := F;
 T["max_simplices"] := T["faces"];
 E := map(op,map(f -> {{f[1],f[2]},{f[1],f[3]},{f[2],f[3]}},F));
 T["edges"] := E;

 R0 := 3;
 R1 := 1;

 tor := u ->
  (R0+R1*u[3]*cos(2*Pi*u[2])) *~ [cos(2*Pi*u[1]),sin(2*Pi*u[1]),0] +~
   [0,0,R1*u[3]*sin(2*Pi*u[2])];

 a := table([
  seq(  2+i = evalf([i/3,i/m,1]),i=0..m-1),
  seq(m+2+i = evalf([i/3,i/m,0]),i=0..2)
 ]);

 T["tor_embedding"] := eval(a);

 T["embedding_dim"] := 2;
 T["embedding"] := table([
  seq(v = tor(a[v]),v in T["vertices"])
 ]);

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

 tor_arc := proc(u,v)
  local w;
  w := v -~ u;
  w := [w[1] - round(w[1]),w[2] - round(w[2]),w[3]];
  spacecurve(tor(u +~ t *~ w),t=0..1);
 end:

 T["curved_plot"] :=
  display(map(e -> tor_arc(a[e[1]],a[e[2]]),E),
   axes=none,scaling=constrained);

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

(* type: gga_exc *)

$define gga_c_pbe_params
$include "gga_c_pbe.mpl"

(* in the paper we have beta_a = 0.066725 *)
beta_a := 0.066724550603149220:
beta_b := 0.1:
beta_c := 0.1778:

(* we redefine beta here *)
(* this is the Hu and Langreth expression *)
mbeta := (rs, t) -> beta_a*(1 + beta_b*rs)/(1 + beta_c*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 *)

$define gga_c_pbe_params
$include "gga_c_pbe.mpl"

pbeloc_b0 := 0.0375:
pbeloc_a  := 0.08:

(* we redefine beta here *)
mbeta := (rs, t) -> pbeloc_b0 + pbeloc_a*t^2*(1 - exp(-rs^2)):


# Differential geometry of curves in R^3

analyse_curve := proc(x,t)
 local T;
 T := table():
 T["x"] := x;
 T["t"] := t;
 T["v"] := map(diff,x,t);
 T["speed"] := simplify(`norm_2/R`(3)(T["v"]));
 T["s"] := int(T["speed"],t);
 T["v_hat"] := simplify(T["v"] /~ T["speed"]);
 T["T"] := T["v_hat"];
 T["a"] := map(diff,T["v"],t);
 T["v_hat_dot"] := simplify(map(diff,T["v_hat"],t));
 T["curvature"] := simplify(`norm_2/R`(3)(T["v_hat_dot"]));
 T["N"] := simplify(T["v_hat_dot"] /~ T["curvature"]);
 T["radius_of_curvature"] := simplify(1/T["curvature"]);
 T["B"] := `cross_product`(T["T"],T["N"]);

 return eval(T);
end:


program primefactor;	{ program18 }
var factor : array[200] of integer;
	i, n, can : integer;
begin
	i := 0;
	while i < 200 do begin
		factor[i] := 0;
		i := i + 1
	end;
	writeln('Input positive integer');
	readln(n);
	can := 2;
	while (can <= n div 2) and (can < 200) do begin
		if (n - (n div can) * can) <> 0 then can := can + 1
		else begin
			factor[can] := factor[can] + 1;
			n := n div can
		end
	end;
	i := 0;
	if n < 200 then begin
		factor[n] := factor[n]+1;
		n := 1
	end;
	while i < 200 do begin
		if factor[i] <> 0 then begin
			writeln('    ', i, ' ** ', factor[i]);
		end;
		i := i + 1
	end;
	if n > 1 then writeln('    ', n, ' ** ', 1)
end.