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

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

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

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

$ifdef mgga_x_revtpss_params
params_a_b      := 0.40:
params_a_c      := 2.35203946:
params_a_e      := 2.16769874:
params_a_kappa  := 0.804:
params_a_mu     := 0.14:
params_a_BLOC_a := 3.0:
params_a_BLOC_b := 0.0:
$endif

tpss_ff     := z -> params_a_BLOC_a + params_a_BLOC_b*z:
tpss_kappa := (x, t) -> params_a_kappa:

$include "tpss_x.mpl"

(* Equation (5) *)

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

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

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

$include "mgga_x_br89.mpl"

mbrxh_a1 := 0.23432:
mbrxh_a2 := 0.089:
mbrxh_a3 := 0.0053:
params_a_at := 0:

(* new definition of Q. The rest of the functional remains the same *)
br89_Q := (x, u, t) ->
      mbrxh_a1*(2*t) - K_FACTOR_C + mbrxh_a2*x^2 + mbrxh_a3*x^4:


# Base Parameter Energy Regressor for Robot based on MDH frames
# Einleitung
# Erstellung einer parameterlinearen und -minimalen Regressorform
#
# Dateiname:
# robot -> Berechnung für allgemeinen Roboter
# chain -> Berechnung für eine serielle Struktur (nicht: Baumstruktur)
# floatb -> floating base. Zusätzliche Betrachtung der Dynamikparameter der Basis.
# rotmat -> Kinematik wird mit Rotationsmatrizen berechnet
# energy -> Berechnung der Energie
# regressor -> Regressorform (parameterlinear)
# Authors
# Alexander Tödtheide, toedtheide@irt.uni-hannover.de
# Moritz Schappler, schappler@irt.uni-hannover.de, 2017-02
#
# (C) Institut fuer Regelungstechnik, Leibniz Universitaet Hannover
# Quellen
# [HRL_IDR] Skript Humanoid Robotics Lab - Serial Chain Robot Identification
# [GautierKhalil1988] A Direct Determination of Minimum Inertial Parameters of Robots
# [GautierKhalil1990] Direct Calculation of Minimum Set of Inertial Parameters of Serial Robots
# [Gautier1990] M. Gautier: Numerical calculation of the base inertial parameters of robots
# Initialisierung
interface(warnlevel=0): # Unterdrücke die folgende Warnung.
restart: # Gibt eine Warnung, wenn über Terminal-Maple mit read gestartet wird.
interface(warnlevel=3):
interface(rtablesize=100): # Zur Anzeige von größeren Vektoren
;
with(LinearAlgebra):
with(ArrayTools):
with(codegen):
with(CodeGeneration):
with(StringTools):
codegen_act := true:
codegen_opt := 2:
read "../helper/proc_convert_s_t":
read "../helper/proc_convert_t_s":
read "../helper/proc_MatlabExport":
read "../robot_codegen_definitions/robot_env":
printf("Generiere Minimalparameterregressor (Floating Base %s) der Energie für %s\n", base_method_name, robot_name):
read sprintf("../codeexport/%s/tmp/tree_floatb_definitions", robot_name, base_method_name):
# Ergebnisse der Energie laden
read sprintf("../codeexport/%s/tmp/energy_potential_floatb_%s_worldframe_par2_maple.m", robot_name, base_method_name):
read sprintf("../codeexport/%s/tmp/energy_kinetic_floatb_%s_linkframe_par2_maple.m", robot_name, base_method_name):
T_floatb := T:
U_floatb := U_grav:
# Die kinetischen und potentiellen Energien aus (2) und (3) stehen ab hier durch T_floatb und U_floatb zur Verfügung.
# Der Parametervektor 'PV2_vec' aus (13) wurde in 'robot_tree_floatb_twist_definitions.mw' aufgestellt.
# Parameterlinearisierung
# Parameterlinearisierung auf Basis von [HRL_IDR] (14) und (15)
# Linearisierung
t_ges := Matrix(1, 10*NL):
u_ges := Matrix(1, 10*NL):
for i to 10*NL do
  t_ges[1,i] := diff(T_floatb,PV2_vec[i,1]);
  u_ges[1,i] := diff(U_floatb,PV2_vec[i,1]);
end do:
# Export
save t_ges, sprintf("../codeexport/%s/tmp/energy_kinetic_floatb_%s_regressor_maple.m", robot_name, base_method_name):
save u_ges, sprintf("../codeexport/%s/tmp/energy_potential_floatb_%s_regressor_maple.m", robot_name, base_method_name):
if codegen_act then
  MatlabExport(convert_t_s(t_ges), sprintf("../codeexport/%s/tmp/energy_kinetic_floatb_%s_regressor_matlab.m", robot_name, base_method_name), codegen_opt):
end if:
if codegen_act then
  MatlabExport(convert_t_s(u_ges), sprintf("../codeexport/%s/tmp/energy_potential_floatb_%s_regressor_matlab.m", robot_name, base_method_name), codegen_opt):
end if:
# Parameterminimierung
# Minimalparametervekor
# Definiere Parametermatrix
XX := Matrix(NL, 1, PV2_mat[1 .. NL, 1]):
XY := Matrix(NL, 1, PV2_mat[1 .. NL, 2]):
XZ := Matrix(NL, 1, PV2_mat[1 .. NL, 3]):
YY := Matrix(NL, 1, PV2_mat[1 .. NL, 4]):
YZ := Matrix(NL, 1, PV2_mat[1 .. NL, 5]):
ZZ := Matrix(NL, 1, PV2_mat[1 .. NL, 6]):
mX := Matrix(NL, 1, PV2_mat[1 .. NL, 7]):
mY := Matrix(NL, 1, PV2_mat[1 .. NL, 8]):
mZ := Matrix(NL, 1, PV2_mat[1 .. NL, 9]):
m :=  Matrix(NL, 1, PV2_mat[1 .. NL, 10]):
# Rekursive Berechnung der Minimalparameter
# Rekursive Berechnung der Minimalparameter mit [HRL_IDR] (23), siehe Abbildung 1.
# [GautierKhalil1990] (eq. 15, 16)
# Die Sonderfälle (eq. 19, 20) für parallele oder senkrechte Schubachsen scheinen für Floating-Base-Modelle nicht zu gelten, da die dadurch gruppierten Dynamikparameter auf die Basis einen voneinander unabhängigen Einfluss haben.
# Festgestellt durch Vergleich mit numerischer Berechnung der Minimalparameter nach [Gautier1990]
for i from NL by -1 to 2 do
  j := i-1: # Laufvariable für die MDH-Kinematikparameter (Inertialparameter von Segment 0 fangen auch bei 1 an).
  # printf("i=%d, j=%d, sigma=%d\n", i, j, sigma[j,1]):
  if sigma[j,1] = 0 then # Drehgelenk (eq. 15)
    XX[i,1] := XX[i,1]-YY[i,1]:
    XX[i-1,1] := XX[i-1,1] + YY[i,1]+d[j,1]^2*m[i,1]+2*d[j,1]*mZ[i,1]:
    XY[i-1,1] := XY[i-1,1] + a[j,1]*sin(alpha[j,1])*mZ[i,1]+a[j,1]*d[j,1]*sin(alpha[j,1])*m[i,1]:
    XZ[i-1,1] := XZ[i-1,1] - a[j,1]*cos(alpha[j,1])*mZ[i,1]-a[j,1]*d[j,1]*cos(alpha[j,1])*m[i,1]:
    YY[i-1,1] := YY[i-1,1] + cos(alpha[j,1])^2*YY[i,1]+2*d[j,1]*cos(alpha[j,1])^2*mZ[i,1]+(a[j,1]^2+d[j,1]^2*cos(alpha[j,1])^2)*m[i,1]:
    YZ[i-1,1] := YZ[i-1,1] + cos(alpha[j,1])*sin(alpha[j,1])*YY[i,1]+2*d[j,1]*cos(alpha[j,1])*sin(alpha[j,1])*mZ[i,1]+d[j,1]^2*cos(alpha[j,1])*sin(alpha[j,1])*m[i,1]:
    ZZ[i-1,1] := ZZ[i-1,1]+sin(alpha[j,1])^2*YY[i,1]+2*d[j,1]*sin(alpha[j,1])^2*mZ[i,1]+(a[j,1]^2+d[j,1]^2*sin(alpha[j,1])^2)*m[i,1]:
    mX[i-1,1] := a[j,1]*m[i,1]+mX[i-1,1]:
    mY[i-1,1] := mY[i-1,1]-sin(alpha[j,1])*mZ[i,1]-d[j,1]*sin(alpha[j,1])*m[i,1]:
    mZ[i-1,1] := mZ[i-1,1]+cos(alpha[j,1])*mZ[i,1]+d[j,1]*cos(alpha[j,1])*m[i,1]:
    m[i-1,1] := m[i-1,1]+m[i,1]:
  else: # Schubgelenk (eq. 16)
    XX[i-1,1] := XX[i-1,1] + cos(theta[j,1])^2*XX[i,1]
                           - 2*cos(theta[j,1])*sin(theta[j,1])*XY[i,1]
                           + sin(theta[j,1])^2*YY[i,1]:
    XY[i-1,1] := XY[i-1,1] + cos(theta[j,1])*sin(theta[j,1])*cos(alpha[j,1])*XX[i,1]
                           + (cos(theta[j,1])^2-sin(theta[j,1])^2)*cos(alpha[j,1])*XY[i,1]
                           - cos(theta[j,1])*sin(alpha[j,1])*XZ[i,1]
                           - cos(theta[j,1])*sin(theta[j,1])*cos(alpha[j,1])*YY[i,1]
                           + sin(theta[j,1])*sin(alpha[j,1])*YZ[i,1]:
    XZ[i-1,1] := XZ[i-1,1] + cos(theta[j,1])*sin(theta[j,1])*sin(alpha[j,1])*XX[i,1]
                           + (cos(theta[j,1])^2-sin(theta[j,1])^2)*sin(alpha[j,1])*XY[i,1]
                           + cos(theta[j,1])*cos(alpha[j,1])*XZ[i,1]
                           - cos(theta[j,1])*sin(theta[j,1])*sin(alpha[j,1])*YY[i,1]
                           - sin(theta[j,1])*cos(alpha[j,1])*YZ[i,1]:
    YY[i-1,1] := YY[i-1,1] + sin(theta[j,1])^2*cos(alpha[j,1])^2*XX[i,1]
                           + 2*cos(theta[j,1])*sin(theta[j,1])*cos(alpha[j,1])^2*XY[i,1]
                           - 2*sin(theta[j,1])*cos(alpha[j,1])*sin(alpha[j,1])*XZ[i,1]
                           + cos(theta[j,1])^2*cos(alpha[j,1])^2*YY[i,1]
                           - 2*cos(theta[j,1])*cos(alpha[j,1])*sin(alpha[j,1])*YZ[i,1]
                           + sin(alpha[j,1])^2*ZZ[i,1]:
    YZ[i-1,1] := YZ[i-1,1] + sin(theta[j,1])^2*cos(alpha[j,1])*sin(alpha[j,1])*XX[i,1]
                           + 2*cos(theta[j,1])*sin(theta[j,1])*cos(alpha[j,1])*sin(alpha[j,1])*XY[i,1]
                           + sin(theta[j,1])*(cos(alpha[j,1])^2-sin(alpha[j,1])^2)*XZ[i,1]
                           + cos(theta[j,1])^2*cos(alpha[j,1])*sin(alpha[j,1])*YY[i,1]
                           + cos(theta[j,1])*(cos(alpha[j,1])^2-sin(alpha[j,1])^2)*YZ[i,1]
                           - cos(alpha[j,1])*sin(alpha[j,1])*ZZ[i,1]:
    ZZ[i-1,1] := ZZ[i-1,1] + sin(theta[j,1])^2*sin(alpha[j,1])^2*XX[i,1]
                           + 2*cos(theta[j,1])*sin(theta[j,1])*sin(alpha[j,1])^2*XY[i,1]
                           + 2*sin(theta[j,1])*cos(alpha[j,1])*sin(alpha[j,1])*XZ[i,1]
                           + cos(theta[j,1])^2*sin(alpha[j,1])^2*YY[i,1]
                           + 2*cos(theta[j,1])*cos(alpha[j,1])*sin(alpha[j,1])*YZ[i,1]
                           + cos(alpha[j,1])^2*ZZ[i,1]:
    # Keine Sonderregeln (eq. 19,20)
  end if:
end do:
# Parameter ohne Einfluss "Markieren"
# Es kann keine Parameter mehr ohne Einfluss geben, da die Basis-Bewegung die Trägheit aller Segmente anregt.
# Parametervektor in Richtiger Reihenfolge aufstellen und Entfernen von mZ, YY, m
# Anwendung von [HRL_IDR] Regel 3 (S. 5) auf den Parametervektor
# [GautierKhalil1990] (eq. 18)
nt:=add(sigma[i,1],i=1..NJ): # Anzahl Translatorische Gelenke
nr:=NJ-nt: # Anzahl rotatorische Gelenke
;
MPV_n_max := 10+7*nr+4*nt: # ignoriere Abzüge in der Formel
Paramvec := Matrix(MPV_n_max, 1):
# Basis-Parameter direkt übernehmen
Paramvec(1..10,1) := <XX[1,1],XY[1,1],XZ[1,1],YY[1,1],YZ[1,1],ZZ[1,1],mX[1,1],mY[1,1],mZ[1,1],m[1,1]>:
# Formel für Parameter, die durch Gelenke bewegt werden, anwenden
ii := 11: # Indizes 1..10 für Basis s.o.
for i from 1 to NJ do
  if sigma[i,1] = 0 then # Drehgelenk (eq. 15)
    Paramvec[ii, 1] := XX[i+1, 1]: ii:= ii+1:
    Paramvec[ii, 1] := XY[i+1, 1]: ii:= ii+1:
    Paramvec[ii, 1] := XZ[i+1, 1]: ii:= ii+1:
    Paramvec[ii, 1] := YZ[i+1, 1]: ii:= ii+1:
    Paramvec[ii, 1] := ZZ[i+1, 1]: ii:= ii+1:
    Paramvec[ii, 1] := mX[i+1, 1]: ii:= ii+1:
    Paramvec[ii, 1] := mY[i+1, 1]: ii:= ii+1:
  else: # Schubgelenk (eq. 16)
    # Keine Sonderregeln (eq. 19,20)
    Paramvec[ii, 1] := mX[i+1, 1]: ii:= ii+1:
    Paramvec[ii, 1] := mY[i+1, 1]: ii:= ii+1:
    Paramvec[ii, 1] := mZ[i+1, 1]: ii:= ii+1:
    Paramvec[ii, 1] :=  m[i+1, 1]: ii:= ii+1:
  end if:
end do:
# Entfernung von Nullelementen
# Durch Entfernung der Nullelemente erfolgt 'beta_b' aus [HRL_IDR] (22)
p := 0:
for i to MPV_n_max do
  if Paramvec[i, 1] = 0 then
    p := p+1
  end if:
end do:
# Determine size of matrix dependent on number of Zeroes
Paramvec_size := MPV_n_max-p:
Paramvec2 := Matrix(Paramvec_size, 1):
p := 0:
for i to MPV_n_max do
  # count Zeroes
  if Paramvec[i, 1] = 0 then
    p := p+1:
  else
    # Shift by number of currently found Zeroes
    Paramvec2[i-p, 1] := Paramvec[i, 1]:
  end if:
end do:
printf("Dimension des Minimalparametervektors: %dx1\n", Paramvec_size):
Paramvec2;
# Export - Minimalparametervektor
save Paramvec2, sprintf("../codeexport/%s/tmp/minimal_parameter_vector_floatb_%s_maple", robot_name, base_method_name):
if codegen_act then
   MatlabExport(Paramvec2, sprintf("../codeexport/%s/tmp/minimal_parameter_vector_floatb_%s_matlab.m", robot_name, base_method_name), codegen_opt):
end if;
# Minimal geometrievektor t_i und u_i
# Markieren von t_mZ, t_YY, t_m, u_mZ, u_YY, u_m_j
# Anwendung von [HRL_IDR] Regel 3 (S. 5) auf die Geometrievektoren t und u der Energien T und U
# Die Regel bezieht sich auf  Körper, die durch Drehgelenke bewegt werden. Einträge für den Basiskörper werden daher nicht geändert.
# Die Parameter YY,MZ und M sind immer linear abhängig. Die entsprechenden Spalten der Regressormatrizen werden daher zum Entfernen markiert.
# [GautierKhalil1990], p.369
for i from 1 to NL-1 do
  if sigma[i,1] = 0 then: # Drehgelenk
    t_ges[1,i*10+ 4]:=REMOVE; #YY
    t_ges[1,i*10+ 9]:=REMOVE; #MZ
    t_ges[1,i*10+10]:=REMOVE; #M
    u_ges[1,i*10+ 4]:=REMOVE; #YY
    u_ges[1,i*10+ 9]:=REMOVE; #MZ
    u_ges[1,i*10+10]:=REMOVE; #M
  else:
    t_ges[1,i*10+ 1]:=REMOVE; #XX
    t_ges[1,i*10+ 2]:=REMOVE; #XY
    t_ges[1,i*10+ 3]:=REMOVE; #XZ
    t_ges[1,i*10+ 4]:=REMOVE; #YY
    t_ges[1,i*10+ 5]:=REMOVE; #YZ
    t_ges[1,i*10+ 6]:=REMOVE; #ZZ

    u_ges[1,i*10+ 1]:=REMOVE; #XX
    u_ges[1,i*10+ 2]:=REMOVE; #XY
    u_ges[1,i*10+ 3]:=REMOVE; #XZ
    u_ges[1,i*10+ 4]:=REMOVE; #YY
    u_ges[1,i*10+ 5]:=REMOVE; #YZ
    u_ges[1,i*10+ 6]:=REMOVE; #ZZ
  end if:
end do:
# Entfernungen von markierten Elementen
# Durch Entfernung der markierten Elemente, äquivalent zum Minimalparametervektor beta_b, haben t und u die gleiche Spaltenanzahl wie 'C_b'.
p:=0:
for i from 1 to 10*NL do       #Nullen Zählen um die Matrixgröße von t_ges zu bestimmen
  if t_ges[1,i]=REMOVE and u_ges[1,i]=REMOVE then
    p:=p+1;
  end if
end do:
size_Matrix:=10*NL-p:
t_ges_minpar:=Matrix(1,size_Matrix):
u_ges_minpar:=Matrix(1,size_Matrix):
printf("Dimension der Minimalparameter-Regressormatrix: 1x%d\n", size_Matrix):
p:=0:
for i from 1 to 10*NL do       #Nullen Zählen
   if t_ges[1,i]=REMOVE and u_ges[1,i]=REMOVE then
      p:=p+1;
   else
      t_ges_minpar[1,i-p]:=t_ges[1,i]; #Um die Anzahl der im Iterationsschritt gezählten Nullen verschieben
      u_ges_minpar[1,i-p]:=u_ges[1,i]; #Um die Anzahl der im Iterationsschritt gezählten Nullen verschieben
   end if
end do:
save t_ges_minpar, sprintf("../codeexport/%s/tmp/energy_kinetic_floatb_%s_regressor_minpar_maple.m", robot_name, base_method_name):
save u_ges_minpar, sprintf("../codeexport/%s/tmp/energy_potential_floatb_%s_regressor_minpar_maple.m", robot_name, base_method_name):
# Export
if codegen_act then
  MatlabExport(convert_t_s(t_ges_minpar), sprintf("../codeexport/%s/tmp/energy_kinetic_floatb_%s_regressor_minpar_matlab.m", robot_name, base_method_name), codegen_opt):
end if:
if codegen_act then
  MatlabExport(convert_t_s(u_ges_minpar), sprintf("../codeexport/%s/tmp/energy_potential_floatb_%s_regressor_minpar_matlab.m", robot_name, base_method_name), codegen_opt):
end if:


#@ Not autoload
# This is mostly superseded by alternating_five.mpl but some stuff at the end has not been transferred

with(group):

# Generators

x2 := [[1,2],[3,4]];
y2 := [[1,3],[2,4]];
z2 := [[2,3],[4,5]];
x3 := [[1,2,3]];
x5 := [[1,3,4,2,5]];
y5 := [[1,2,3,4,5]];

A5 := permgroup(5,{y2,x5});

# Subgroups, named according to their order

H[1 ] := permgroup(5,{}):
H[2 ] := permgroup(5,{x2}):
H[3 ] := permgroup(5,{x3}):
H[4 ] := permgroup(5,{x2,y2}):
H[5 ] := permgroup(5,{x5}):
H[6 ] := permgroup(5,{z2,x3}):
H[10] := permgroup(5,{x2,x5}):
H[12] := permgroup(5,{x2,x3}):
H[60] := A5:

mp := proc()
 if nargs = 0 then
  return [];
 elif nargs = 1 then
  return args[1];
 elif nargs = 2 then
  return mulperms(args);
 else
  return mulperms(args[1],mp(args[2..-1]));
 fi;
end:

ip := invperm:
pp := proc(sigma,n)
 local rho,tau,m;
 if (n >= 0) then
  tau := sigma; m := n;
 else
  tau := invperm(sigma);
  m := abs(n);
 fi;
 rho := [];
 while m > 0 do
  rho := mulperms(tau,rho);
  m := m-1;
 od;
 return(rho);
end:

ccl := proc(x) map(g->mulperms(mulperms(g,x),invperm(g)),elements(A5)); end:

# Conjugacy classes

C[1] := {[]}:
C[2] := ccl(x2):
C[3] := ccl(x3):
C[4] := ccl(mulperms(x5,x5)):
C[5] := ccl(x5):

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

# Dodecahedron representation

Rx1 := Matrix([[ 1,0,0],[0, 1,0],[0,0, 1]]):
Rx2 := Matrix([[ 1,0,0],[0,-1,0],[0,0,-1]]):
Ry2 := Matrix([[-1,0,0],[0,-1,0],[0,0, 1]]):
Rz2 := map(rationalize,Matrix([[1/tau,-tau,-1],[-tau,-1,1/tau],[-1,1/tau,-tau]])/2):
Rx3 := Matrix([[0,1,0],[0,0,1],[1,0,0]]):
Rx5 := map(rationalize,Matrix([[1/tau,tau,-1],[-tau,1,1/tau],[1,1/tau,tau]])/2):
Ry5 := map(rationalize,Matrix([[tau,-1,-1/tau],[1,1/tau,tau],[-1/tau,-tau,1]])/2):

prels := {
 pp(x2,2),
 pp(y2,2),
 pp(z2,2),
 pp(x3,3),
 pp(x5,5),
 pp(mp(x2,y2),2),
 pp(mp(x2,mp(y2,z2)),3),
 pp(mp(mp(z2,x2),mp(z2,y2)),3),
 pp(mp(x2,z2),5),
 pp(mp(y2,z2),5),
 mp(ip(x3),mp(y2,mp(z2,mp(x2,mp(z2,mp(y2,z2)))))),
 mp(ip(x5),mp(y2,mp(z2,mp(x2,y2)))),
 mp(ip(y5),mp(y2,mp(z2,mp(x2,mp(z2,x2)))))
};

mrels := [
 Rx2^2 - Rx1,
 Ry2^2 - Rx1,
 Rz2^2 - Rx1,
 Rx3^3 - Rx1,
 Rx5^5 - Rx1,
 (Rx2 . Ry2)^2 - Rx1,
 (Rx2 . Ry2 . Rz2)^3 - Rx1,
 (Rz2 . Rx2 . Rz2 . Ry2)^3 - Rx1,
 (Rx2 . Rz2)^5 - 1,
 (Ry2 . Rz2)^5 - 1,
 Rx3 - Ry2 . Rz2 . Rx2 . Rz2 . Ry2 . Rz2,
 Rx5 - Ry2 . Rz2 . Rx2 . Ry2,
 Ry5 - Ry2 . Rz2 . Rx2 . Rz2 . Rx2
]:

mrels := map(M -> map(expand,M),mrels):
rels := {op(map(expand,map(op,map(op,map(convert,mrels,listlist)))))};

ords := [1,2,4,3,6,12,5,10,60];

for n in ords do X[n] := [op(cosets(A5,H[n]))]: od:

is_fixed1 := (g,x,H) -> groupmember(mulperms(mulperms(x,g),invperm(x)),H):

is_fixed := proc(K,x,H)
 local gens,g;
 gens := op(2,K);
 for g in gens do
  if not(is_fixed1(g,x,H)) then return(false); end;
 od;
 return(true);
end:

phi := proc(i,j)
 local m,K,L,Y,y;
 K := H[i];
 L := H[j];
 Y := X[j];
 m := 0;
 for y in Y do
  if is_fixed(K,y,L) then
   m := m+1;
  fi;
 od;
 return(m);
end:

# Matrix of |(G/H_i)^{H_j}|

M := Matrix(9,9,[seq(seq(phi(ords[i],ords[j]),j=1..9),i=1..9)]);

# Cycle types of products of 5-cycles
P := matrix(12,12,[0$144]):
for i from 1 to 12 do
 for j from 1 to 12 do
  g := mulperms(C[5][i],invperm(C[5][j])):
  P[i,j] := map(nops,g):
 od:
od:

# Edges and faces of the icosahedron
E := []:
F := []:
for i from 1 to 12 do
 for j from i+1 to 12 do
  if (P[i,j] = [3]) then
   E := [op(E),[i,j]]:
   for k from j+1 to 12 do
    if (P[i,k] = [3] and P[j,k] = [3]) then
     F := [op(F),[i,j,k]]:
    fi:
   od:
  fi:
 od:
od:
E;
F;

# Words for all elements of A5
w[ 1] := []:
w[ 2] := [X2]:
w[ 3] := [Y2]:
w[ 4] := [Z2]:
w[ 5] := [X2,Y2]:
w[ 6] := [X2,Z2]:
w[ 7] := [Y2,Z2]:
w[ 8] := [Z2,X2]:
w[ 9] := [Z2,Y2]:
w[10] := [X2,Y2,Z2]:
w[11] := [X2,Z2,X2]:
w[12] := [X2,Z2,Y2]:
w[13] := [Y2,Z2,X2]:
w[14] := [Y2,Z2,Y2]:
w[15] := [Z2,X2,Y2]:
w[16] := [Z2,X2,Z2]:
w[17] := [Z2,Y2,Z2]:
w[18] := [X2,Y2,Z2,X2]:
w[19] := [X2,Y2,Z2,Y2]:
w[20] := [X2,Z2,X2,Y2]:
w[21] := [X2,Z2,X2,Z2]:
w[22] := [X2,Z2,Y2,Z2]:
w[23] := [Y2,Z2,X2,Y2]:
w[24] := [Y2,Z2,X2,Z2]:
w[25] := [Y2,Z2,Y2,Z2]:
w[26] := [Z2,X2,Y2,Z2]:
w[27] := [Z2,X2,Z2,X2]:
w[28] := [Z2,X2,Z2,Y2]:
w[29] := [Z2,Y2,Z2,X2]:
w[30] := [Z2,Y2,Z2,Y2]:
w[31] := [X2,Y2,Z2,X2,Z2]:
w[32] := [X2,Y2,Z2,Y2,Z2]:
w[33] := [X2,Z2,X2,Z2,X2]:
w[34] := [X2,Z2,X2,Z2,Y2]:
w[35] := [X2,Z2,Y2,Z2,X2]:
w[36] := [X2,Z2,Y2,Z2,Y2]:
w[37] := [Y2,Z2,X2,Z2,X2]:
w[38] := [Y2,Z2,X2,Z2,Y2]:
w[39] := [Y2,Z2,Y2,Z2,X2]:
w[40] := [Y2,Z2,Y2,Z2,Y2]:
w[41] := [Z2,X2,Z2,X2,Y2]:
w[42] := [Z2,X2,Z2,Y2,Z2]:
w[43] := [Z2,Y2,Z2,X2,Y2]:
w[44] := [Z2,Y2,Z2,X2,Z2]:
w[45] := [X2,Y2,Z2,X2,Z2,X2]:
w[46] := [X2,Y2,Z2,X2,Z2,Y2]:
w[47] := [X2,Y2,Z2,Y2,Z2,X2]:
w[48] := [X2,Y2,Z2,Y2,Z2,Y2]:
w[49] := [X2,Z2,X2,Z2,X2,Y2]:
w[50] := [X2,Z2,X2,Z2,Y2,Z2]:
w[51] := [X2,Z2,Y2,Z2,X2,Y2]:
w[52] := [X2,Z2,Y2,Z2,X2,Z2]:
w[53] := [Y2,Z2,X2,Z2,Y2,Z2]:
w[54] := [Y2,Z2,Y2,Z2,X2,Y2]:
w[55] := [Y2,Z2,Y2,Z2,X2,Z2]:
w[56] := [Z2,X2,Z2,Y2,Z2,Y2]:
w[57] := [Z2,Y2,Z2,X2,Z2,X2]:
w[58] := [X2,Y2,Z2,Y2,Z2,X2,Y2]:
w[59] := [Z2,Y2,Z2,Y2,Z2,X2,Z2]:
w[60] := [X2,Z2,Y2,Z2,Y2,Z2,X2,Z2]:

# Rotations for all elements
Rw[1] := IdentityMatrix(3):
for i from 2 to 60 do
 Rw[i] := map(expand,`.`(op(subs({X2=Rx2,Y2=Ry2,Z2=Rz2},w[i]))));
od:

# Permutations for all elements
Sw[1] := []:
for i from 2 to 60 do
 Sw[i] := mp(op(subs({X2=x2,Y2=y2,Z2=z2},w[i])));
od:

# Vertices of the icosahedron

V[ 1] := <   0,   1, tau>:
V[ 2] := <   0,  -1, tau>:
V[ 3] := <   0,   1,-tau>:
V[ 4] := <   0,  -1,-tau>:
V[ 5] := <   1, tau,   0>:
V[ 6] := <  -1, tau,   0>:
V[ 7] := <   1,-tau,   0>:
V[ 8] := <  -1,-tau,   0>:
V[ 9] := < tau,   0,   1>:
V[10] := < tau,   0,  -1>:
V[11] := <-tau,   0,   1>:
V[12] := <-tau,   0,  -1>:

for i from 1 to 12 do
 U := V[i];
 VV[U[1],U[2],U[3]] := i;
od:

Vix := proc(T)
 local T1;
 T1 := map(expand,T);
 return(VV[T1[1],T1[2],T1[3]]);
end:

# Permutation action on vertices

Px2 := convert([seq(Vix(Rx2 . V[i]),i=1..12)],disjcyc);
Py2 := convert([seq(Vix(Ry2 . V[i]),i=1..12)],disjcyc);
Pz2 := convert([seq(Vix(Rz2 . V[i]),i=1..12)],disjcyc);
Px3 := convert([seq(Vix(Rx3 . V[i]),i=1..12)],disjcyc);
Px5 := convert([seq(Vix(Rx5 . V[i]),i=1..12)],disjcyc);


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

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

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

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

cap_f0 := s -> 1 - params_a_alphaoAx*s*log(1 + s)/(1 + params_a_c*log(1 + s)):
cap_f  := x -> cap_f0(X2S*x):

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


input := StringTools:-Trim(FileTools:-Text:-ReadFile("AoC-2021-15-input.txt"));
grid := Matrix(map(s->parse~(StringTools:-Explode(s)),StringTools:-Split(input,"\n"))):

(gridw,gridl) := upperbound(grid);

nbs := proc(i,j,gridsize)
local out := NULL;
    if i < gridsize then out := out, [i+1, j]; end if;
    if j < gridsize then out := out, [i, j+1]; end if;
    if i > 1 then out := out, [i-1,j]; end if;
    if j > 1 then out := out, [i, j-1]; end if;
    return [out];
end proc:

# should really do this lazily
inc := a -> (a mod 9) +~ 1;
biggrid:= Matrix([seq([seq((inc@@(i+j-2))(grid),j=1..5)],i=1..5)] );
(biggridw,biggridl) := upperbound(biggrid);

with(GraphTheory):
G := MakeWeighted(MakeDirected(SpecialGraphs:-GridGraph(gridl,gridw)));
for e in Edges(G) do
    SetEdgeWeight(G, e, grid[parse(e[2])]);
end do:
DijkstrasAlgorithm(G, "1,1", cat("",gridl,",",gridw))[2];

BG := MakeWeighted(MakeDirected(SpecialGraphs:-GridGraph(biggridl,biggridw)));
for i from 1 to biggridl do
    for j from 1 to biggridw do
       a := j + (i-1)*(biggridw);
       for n in nbs(i,j,biggridw) do
           b := n[2] + (n[1]-1)*biggridw;
           W[b,a] := biggrid[i,j];
       end do;
    end do;
end do:
DijkstrasAlgorithm(BG, "1,1", cat("",biggridl,",",biggridw))[2];


with(DifferentialAlgebra):
ring_diff := DifferentialRing(blocks = [[x2, x4, x1, x3], [y] ], derivations = [t]):
sys := [
diff(x2(t), t) - (alpha*x1(t) - beta*x2(t)),
diff(x4(t), t) - ((gama*sigma*x2(t)*x4(t) - delta*sigma*x3(t)*x4(t)) / (x3(t))),
diff(x1(t), t) - ((-b*c*x1(t) - b*x1(t)*x4(t) + 1) / (c + x4(t))),
diff(x3(t), t) - (gama*x2(t) - delta*x3(t)),
y(t) - (x1(t))
];
res := CodeTools[CPUTime](RosenfeldGroebner(sys, ring_diff, singsol=none));


# This function assumes that u is a symmetric polynomial in
# x[1],...,x[n] and returns a polynomial in c[1],...,c[n]
# that agrees with u after replacing the variables c[i] by
# the elementary symmetric functions in x[1],...,x[n].
# If the optional argument p_ is supplied, then the calculation
# is done mod p_.

newton_rewrite := proc(u,n,x,c,p_)
 local p,f,i,v,w,a,m,k,cx,cxp,vars;

 p := `if`(nargs > 4,p_,0);

 f := expand(mul(t+x[i],i=1..n));
 for i from 1 to n do
  cx[i] := coeff(f,t,n-i);
 od:

 cxp := proc(i,j)
  option remember;
  local u;

  if j = 0 then
   return 1;
  else
   u := expand(cx[i]*cxp(i,j-1));
   if p > 0 then u := mods(u,p); fi;
   return u;
  fi;
 end:

 v := u;
 w := 0;
 vars := plex(seq(x[i],i=1..n));
 while v <> 0 do
  a,m := LeadingTerm(v,vars);
  k := [seq(degree(m,x[i]),i=1..n),0];
  w := w + a * mul(c[i]^(k[i]-k[i+1]),i=1..n);
  v := expand(v - a * mul(cxp(i,k[i]-k[i+1]),i=1..n));
  if nargs > 4 then v := modp(v,p_); fi;
 od:

 return w;
end:

orbit_sum := proc(m,n,x)
 local S,R,v,C,c,r,i;
 S := combinat[permute](n);
 R := map(s -> [seq(x[i]=x[s[i]],i=1..n)],S);
 v := add(subs(r,m),r in R);
 C := {coeffs(v,{seq(x[i],i=1..n)})};
 c := igcd(op(C));
 v := expand(v/c);
 return v;
end:


program gcd;
begin
var n1, n2: integer;
read(n1);
read(n2);
if n2 > n1 then
begin
var tmp: integer;
tmp := n1;
n1 := n2;
n2 := tmp;
end;
while n2 > 0 do
begin
var new: integer;
new := n1 % n2;
n1 := n2;
n2 := new;
end;
writeln(n1);
end.


# Base Parameter Energy Regressor for Robot based on MDH frames
# Einleitung
# Erstellung einer parameterlinearen und -minimalen Regressorform
#
# Dateiname:
# robot -> Berechnung für allgemeinen Roboter
# chain -> Berechnung für eine serielle Struktur (nicht: Baumstruktur)
# fixb -> fixed base. Kein Floating base Modell. Dort ist diese Form der Minimalparameterform nicht möglich.
# rotmat -> Kinematik wird mit Rotationsmatrizen berechnet
# energy -> Berechnung der Energie
# regressor -> Regressorform (parameterlinear)
# Authors
# Alexander Tödtheide, toedtheide@irt.uni-hannover.de
# Moritz Schappler, schappler@irt.uni-hannover.de, 2016-03
#
# (C) Institut fuer Regelungstechnik, Leibniz Universitaet Hannover
# Quellen
# [HRL_IDR] Skript Humanoid Robotics Lab - Serial Chain Robot Identification
# [GautierKhalil1988] A Direct Determination of Minimum Inertial Parameters of Robots
# [GautierKhalil1990] Direct Calculation of Minimum Set of Inertial Parameters of Serial Robots
# Initialisierung
interface(warnlevel=0): # Unterdrücke die folgende Warnung.
restart: # Gibt eine Warnung, wenn über Terminal-Maple mit read gestartet wird.
interface(warnlevel=3):
interface(rtablesize=100): # Zur Anzeige von größeren Vektoren
;
with(LinearAlgebra):
with(ArrayTools):
with(codegen):
with(CodeGeneration):
with(StringTools):
codegen_act := true:
codegen_opt := 2:
read "../helper/proc_convert_s_t":
read "../helper/proc_convert_t_s":
read "../helper/proc_MatlabExport":
read "../helper/proc_simplify2":
read "../robot_codegen_definitions/robot_env":
printf("%s. Generiere Minimalparameterregressor der Energie für %s (geometrischer Ansatz)\n", \
  FormatTime("%Y-%m-%d %H:%M:%S"), robot_name, codegen_dynpar):
read sprintf("../codeexport/%s/tmp/tree_floatb_definitions", robot_name, base_method_name):
read sprintf("../codeexport/%s/tmp/kinematic_constraints_maple_inert.m", robot_name):
kin_constraints_exist := kin_constraints_exist: # nur zum Abschätzen der Komplexität
;
# Term-Vereinfachungen einstellen
if not assigned(simplify_options) or simplify_options(7)=-1 then # Standard-Einstellungen:
  if not kin_constraints_exist then # normale serielle Ketten und Baumstrukturen
    use_simplify := 0: # Standardmäßig aus
  else # mit kinematischen Zwangsbedingungen
    use_simplify := 1: # standardmäßig simplify-Befehle anwenden
  end if:
else # Benutzer-Einstellungen:
  use_simplify := simplify_options(7): # siebter Eintrag ist für Energie-Regressor
end if:

# Ergebnisse der Energie laden
read sprintf("../codeexport/%s/tmp/energy_potential_floatb_%s_worldframe_par2_maple.m", robot_name, base_method_name):
read sprintf("../codeexport/%s/tmp/energy_kinetic_floatb_%s_linkframe_par2_maple.m", robot_name, base_method_name):
T_floatb := T:
U_floatb := U_grav:
# Einfluss der Basis-Geschwindigkeit und -Position entfernen
T_fixb:=T_floatb:
U_fixb:=U_floatb:
for i from 1 to 6 do
  T_fixb := subs({V_base_t[i,1]=0},T_fixb):
  U_fixb := subs({X_base_t[i,1]=0},U_fixb):
end do:
# Die kinetischen und potentiellen Energien aus (2) und (3) stehen ab hier durch T_fixb und U_fixb zur Verfügung.
# Der Parametervektor 'PV2_vec' aus (13) wurde in 'robot_tree_floatb_twist_definitions.mw' aufgestellt.

# Parameterlinearisierung
# Parameterlinearisierung auf Basis von [HRL_IDR] (14) und (15)
# Linearisierung
t_ges := Matrix(1, 10*(NL-1)):
u_ges := Matrix(1, 10*(NL-1)):
for i to 10*(NL-1) do
  t_ges[1,i] := diff(T_fixb,PV2_vec[10+i,1]);
  u_ges[1,i] := diff(U_fixb,PV2_vec[10+i,1]);
end do:
# Terme vereinfachen
if use_simplify=1 then
  tmp_t1:=time():
  tmp_l11 := length(t_ges):
  tmp_l12 := length(u_ges):
  t_ges := simplify2(t_ges):
  u_ges := simplify2(u_ges):
  tmp_t2:=time():
  tmp_l21 := length(t_ges):
  tmp_l22 := length(u_ges):
  printf("%s: Terme für Energie-Regressor vereinfacht. Länge: %d->%d / %d->%d. Rechenzeit %1.1fs.\n", \
    FormatTime("%Y-%m-%d %H:%M:%S"), tmp_l11, tmp_l21, tmp_l12, tmp_l22, tmp_t2-tmp_t1):
end if:
# Export
save t_ges, sprintf("../codeexport/%s/tmp/energy_kinetic_fixb_regressor_maple.m", robot_name):
save u_ges, sprintf("../codeexport/%s/tmp/energy_potential_fixb_regressor_maple.m", robot_name):
if codegen_act then
  MatlabExport(convert_t_s(t_ges), sprintf("../codeexport/%s/tmp/energy_kinetic_fixb_regressor_matlab.m", robot_name), codegen_opt):
end if:
if codegen_act then
  MatlabExport(convert_t_s(u_ges), sprintf("../codeexport/%s/tmp/energy_potential_fixb_regressor_matlab.m", robot_name), codegen_opt):
end if:
# Parameterminimierung
# Prüfe, ob der folgende Algorithmus funktionieren kann
# Bestimme, ob es eine Baumstruktur ist. Wenn ja, funktioniert der Algorithmus (noch) nicht (nicht implementiert).
tree:=false:
for i from 1 to NJ do
  if not v(i) = i-1 then
    tree := true: break:
  end if:
end do:

if assigned(user_CoM) or assigned(user_M) or assigned(user_inertia) \
  or kin_constraints_exist or tree then
  # es gibt einen Sonderfall, diese Berechnung der Minimalparameter funktioniert voraussichtlich nicht.
  printf("%s. Geometrische Berechnung der Minimalparameter nicht möglich.\n", FormatTime("%Y-%m-%d %H:%M:%S")):
  quit: # Funktioniert in GUI nicht richtig...
  robot_name := "": # ...Daher auch Löschung des Roboternamens.
end if:
# Minimalparametervekor
# Definiere Parametermatrix
# Nehme nur die Inertialparameter der bewegten Segmente, nicht die Basis.
XX := Matrix(NJ, 1, PV2_mat[2 .. NL, 1]):
XY := Matrix(NJ, 1, PV2_mat[2 .. NL, 2]):
XZ := Matrix(NJ, 1, PV2_mat[2 .. NL, 3]):
YY := Matrix(NJ, 1, PV2_mat[2 .. NL, 4]):
YZ := Matrix(NJ, 1, PV2_mat[2 .. NL, 5]):
ZZ := Matrix(NJ, 1, PV2_mat[2 .. NL, 6]):
mX := Matrix(NJ, 1, PV2_mat[2 .. NL, 7]):
mY := Matrix(NJ, 1, PV2_mat[2 .. NL, 8]):
mZ := Matrix(NJ, 1, PV2_mat[2 .. NL, 9]):
m :=  Matrix(NJ, 1, PV2_mat[2 .. NL, 10]):

# Rekursive Berechnung der Minimalparameter
# Rekursive Berechnung der Minimalparameter mit [HRL_IDR] (23), siehe Abbildung 1.
# [GautierKhalil1990] (eq. 15,16)
for i from NJ by -1 to 2 do
  # printf("i=%d, sigma=%d\n", i, sigma[i,1]):
  if sigma[i,1] = 0 then # Drehgelenk (eq. 15)
    XX[i,  1] := XX[i,  1]-YY[i,1]:
    XX[i-1,1] := XX[i-1,1] + YY[i,1] + d[i,1]^2*m[i,1]+2*d[i,1]*mZ[i,1]:
    XY[i-1,1] := XY[i-1,1] + a[i,1]*sin(alpha[i,1])*mZ[i,1]+a[i,1]*d[i,1]*sin(alpha[i,1])*m[i,1]:
    XZ[i-1,1] := XZ[i-1,1] - a[i,1]*cos(alpha[i,1])*mZ[i,1]-a[i,1]*d[i,1]*cos(alpha[i,1])*m[i,1]:
    YY[i-1,1] := YY[i-1,1] + cos(alpha[i,1])^2*YY[i,1]+2*d[i,1]*cos(alpha[i,1])^2*mZ[i,1]+(a[i,1]^2+d[i,1]^2*cos(alpha[i,1])^2)*m[i,1]:
    YZ[i-1,1] := YZ[i-1,1] + cos(alpha[i,1])*sin(alpha[i,1])*YY[i,1]+2*d[i,1]*cos(alpha[i,1])*sin(alpha[i,1])*mZ[i,1]+d[i,1]^2*cos(alpha[i,1])*sin(alpha[i,1])*m[i,1]:
    ZZ[i-1,1] := ZZ[i-1,1] + sin(alpha[i,1])^2*YY[i,1]+2*d[i,1]*sin(alpha[i,1])^2*mZ[i,1]+(a[i,1]^2+d[i,1]^2*sin(alpha[i,1])^2)*m[i,1]:
    mX[i-1,1] := mX[i-1,1] + a[i,1]*m[i,1]:
    mY[i-1,1] := mY[i-1,1] - sin(alpha[i,1])*mZ[i,1]-d[i,1]*sin(alpha[i,1])*m[i,1]:
    mZ[i-1,1] := mZ[i-1,1] + cos(alpha[i,1])*mZ[i,1]+d[i,1]*cos(alpha[i,1])*m[i,1]:
    m[i-1 ,1] := m[i-1 ,1] + m[i,1]:
  else: # Schubgelenk (eq. 16)
    # im Normalfall nicht geänderte Parameter initialisieren.
    # Wird durch Sonderregeln weiter unten überschrieben.
    mR_i := m[i-1 ,1]:
    mXR_i := mX[i-1,1]:
    mYR_i :=mY[i-1,1]:
    mZR_i:=mZ[i-1,1]:
    XXR_i := XX[i-1,1] + cos(theta[i,1])^2*XX[i,1]
                       - 2*cos(theta[i,1])*sin(theta[i,1])*XY[i,1]+sin(theta[i,1])^2*YY[i,1]:
    XYR_i := XY[i-1,1] + cos(theta[i,1])*sin(theta[i,1])*cos(alpha[i,1])*XX[i,1]
                       + (cos(theta[i,1])^2-sin(theta[i,1])^2)*cos(alpha[i,1])*XY[i,1]
                       - cos(theta[i,1])*sin(alpha[i,1])*XZ[i,1]
                       - cos(theta[i,1])*sin(theta[i,1])*cos(alpha[i,1])*YY[i,1]
                       + sin(theta[i,1])*sin(alpha[i,1])*YZ[i,1]:
    XZR_i := XZ[i-1,1] + cos(theta[i,1])*sin(theta[i,1])*sin(alpha[i,1])*XX[i,1]
                       + (cos(theta[i,1])^2-sin(theta[i,1])^2)*sin(alpha[i,1])*XY[i,1]
                       + cos(theta[i,1])*cos(alpha[i,1])*XZ[i,1]
                       - cos(theta[i,1])*sin(theta[i,1])*sin(alpha[i,1])*YY[i,1]
                       - sin(theta[i,1])*cos(alpha[i,1])*YZ[i,1]:
    YYR_i := YY[i-1,1] + sin(theta[i,1])^2*cos(alpha[i,1])^2*XX[i,1]
                       + 2*cos(theta[i,1])*sin(theta[i,1])*cos(alpha[i,1])^2*XY[i,1]
                       - 2*sin(theta[i,1])*cos(alpha[i,1])*sin(alpha[i,1])*XZ[i,1]
                       + cos(theta[i,1])^2*cos(alpha[i,1])^2*YY[i,1]
                       - 2*cos(theta[i,1])*cos(alpha[i,1])*sin(alpha[i,1])*YZ[i,1]
                       + sin(alpha[i,1])^2*ZZ[i,1]:
    YZR_i := YZ[i-1,1] + sin(theta[i,1])^2*cos(alpha[i,1])*sin(alpha[i,1])*XX[i,1]
                       + 2*cos(theta[i,1])*sin(theta[i,1])*cos(alpha[i,1])*sin(alpha[i,1])*XY[i,1]
                       + sin(theta[i,1])*(cos(alpha[i,1])^2-sin(alpha[i,1])^2)*XZ[i,1]
                       + cos(theta[i,1])^2*cos(alpha[i,1])*sin(alpha[i,1])*YY[i,1]
                       + cos(theta[i,1])*(cos(alpha[i,1])^2-sin(alpha[i,1])^2)*YZ[i,1]
                       - cos(alpha[i,1])*sin(alpha[i,1])*ZZ[i,1]:
    ZZR_i := ZZ[i-1,1] + sin(theta[i,1])^2*sin(alpha[i,1])^2*XX[i,1]
                       + 2*cos(theta[i,1])*sin(theta[i,1])*sin(alpha[i,1])^2*XY[i,1]
                       + 2*sin(theta[i,1])*cos(alpha[i,1])*sin(alpha[i,1])*XZ[i,1]
                       + cos(theta[i,1])^2*sin(alpha[i,1])^2*YY[i,1]
                       + 2*cos(theta[i,1])*cos(alpha[i,1])*sin(alpha[i,1])*YZ[i,1]
                       + cos(alpha[i,1])^2*ZZ[i,1]:
    # Im Kap. IV.C. sind Sonderfälle nur bezogen auf Schubgelenke definiert.
    # Diese scheinen aber noch überhaupt nicht gut zu funktionieren. Unklar, warum.
    # Sonderfall parallele Achsen (eq. 19)
    if sin(alpha[i,1]) = 0 and false then # deaktiviert. TODO: Klären, ob der Sonderfall sinnvoll ist
      ZZR_i := ZZ[i-1,1] + 2*a[i,1]*cos(theta[i,1])*mX[i,1] - 2*a[i,1]*sin(theta[i,1])*mY[i,1]:
      mXR_i := mX[i-1,1] + cos(theta[i,1])*mX[i,1] - sin(theta[i,1])*mY[i,1]:
      mYR_i := mY[i-1,1] + sin(theta[i,1])*cos(alpha[i,1])*mX[i,1] + cos(theta[i,1])*cos(alpha[i,1])*mY[i,1]:
    end if:
    # Sonderfall senkrechte Achsen (eq. 20)
    if cos(alpha[i,1]) = 0 and false then # deaktiviert.
      YYR_i := YY[i-1,1] + 2*a[i,1]*cos(theta[i,1])*mX[i,1] - 2*a[i,1]*sin(theta[i,1])*mY[i,1]:
      mXR_i := mX[i-1,1] + cos(theta[i,1])*mX[i,1] - sin(theta[i,1])*mY[i,1]:
      mZR_i := mZ[i-1,1] + sin(alpha[i,1])*sin(theta[i,1])*mX[i,1] + sin(alpha[i,1])*cos(theta[i,1])*mY[i,1]:
    end if:
    # Zuweisung der neuen Variable (wegen Fallunterscheidung parallel/senkrecht)
    # Nur für Schubgelenke notwendig
    m[i-1 ,1] := mR_i:
    mX[i-1,1] := mXR_i:
    mY[i-1,1] := mYR_i:
    mZ[i-1,1] := mZR_i:
    XX[i-1,1] := XXR_i:
    XY[i-1,1] := XYR_i:
    XZ[i-1,1] := XZR_i:
    YY[i-1,1] := YYR_i:
    YZ[i-1,1] := YZR_i:
    ZZ[i-1,1] := ZZR_i:
  end if: # Drehgelenk/Schubgelenk
end do:

# Parameter ohne Einfluss "Markieren"
# Markierung von Parametern ohne Einfluss an Hand von [HRL_IDR] (18)
printf("The following parameters don't have any effect:\n"):

for i to 10*NJ do
  effect := 0:
  if not (t_ges[1,i]=0) then
    # printf("t_ges[1,%d] not Null\n", i):
    effect := 1:
  else
    for j to NQJ do
      if has(u_ges[1,i],{qJ_t(j,1)}) then
        # printf("u_ges[1,%d] not constant\n", i):
        effect := 1:
        break:
      end if:
    end do:
  end if:
  if effect = 0 then
       t_ges[1,i] := REMOVE:
       u_ges[1,i] := REMOVE:

       if `mod`(i, 10) = 1 then XX[trunc((1/10)*i)+1, 1] := 0; printf("XX%d \n", trunc((1/10)*i)+1): end if:
       if `mod`(i, 10) = 2 then XY[trunc((1/10)*i)+1, 1] := 0; printf("XY%d \n", trunc((1/10)*i)+1): end if:
       if `mod`(i, 10) = 3 then XZ[trunc((1/10)*i)+1, 1] := 0; printf("XZ%d \n", trunc((1/10)*i)+1): end if:
       if `mod`(i, 10) = 4 then YY[trunc((1/10)*i)+1, 1] := 0; printf("YY%d \n", trunc((1/10)*i)+1): end if:
       if `mod`(i, 10) = 5 then YZ[trunc((1/10)*i)+1, 1] := 0; printf("YZ%d \n", trunc((1/10)*i)+1): end if:
       if `mod`(i, 10) = 6 then ZZ[trunc((1/10)*i)+1, 1] := 0; printf("ZZ%d \n", trunc((1/10)*i)+1): end if:
       if `mod`(i, 10) = 7 then mX[trunc((1/10)*i)+1, 1] := 0; printf("MX%d \n", trunc((1/10)*i)+1): end if:
       if `mod`(i, 10) = 8 then mY[trunc((1/10)*i)+1, 1] := 0; printf("MY%d \n", trunc((1/10)*i)+1): end if:
       if `mod`(i, 10) = 9 then mZ[trunc((1/10)*i)+1, 1] := 0; printf("MZ%d \n", trunc((1/10)*i)+1): end if:
       if `mod`(i, 10) = 0 then m[trunc((1/10)*i), 1] := 0;    printf(" M%d \n", trunc((1/10)*i)):   end if:
  end if:
end do:
# Speichere markierte Regressor-Vektoren
save t_ges, sprintf("../codeexport/%s/tmp/energy_kinetic_fixb_regressor_marked_maple.m", robot_name):
save u_ges, sprintf("../codeexport/%s/tmp/energy_potential_fixb_regressor_marked_maple.m", robot_name):
# Parametervektor in Richtiger Reihenfolge aufstellen und Entfernen von mZ, YY, m
# Anwendung von [HRL_IDR] Regel 3 (S. 5) auf den Parametervektor
# Bei Drehgelenken werden die Parameter YY, mZ und m mit denen des folgenden Körpers gruppiert. Bei Schubgelenken werden alle Trägheitsmomente gruppiert (da die Trägheitsmomente keinen Einfluss auf die translatorische Bewegung des Schubgelenkes haben).
# [GautierKhalil1990] (eq. 18)
nt:=add(sigma[i,1],i=1..NJ): # Anzahl Translatorische Gelenke
nr:=NJ-nt: # Anzahl rotatorische Gelenke
;
#Anzahl der Einträge im Minimalparametervektor
MPV_n_max := 7*nr+4*nt: # ignoriere Abzüge in der Formel
;
Paramvec := Matrix(MPV_n_max, 1):
ii := 1:
for i to NJ do
  if sigma[i,1] = 0 then # Drehgelenk (eq. 15)
    Paramvec[ii, 1] := XX[i, 1]: ii:= ii+1:
    Paramvec[ii, 1] := XY[i, 1]: ii:= ii+1:
    Paramvec[ii, 1] := XZ[i, 1]: ii:= ii+1:
    Paramvec[ii, 1] := YZ[i, 1]: ii:= ii+1:
    Paramvec[ii, 1] := ZZ[i, 1]: ii:= ii+1:
    Paramvec[ii, 1] := mX[i, 1]: ii:= ii+1:
    Paramvec[ii, 1] := mY[i, 1]: ii:= ii+1:
  else: # Schubgelenk (eq. 16)
    if sin(alpha[i,1]) = 0 and false then # Sonderregel (eq. 19).
      # Parameter wurden mit denen der Basisnäheren Achse zusammengelegt und werden hier nicht betrachtet.
      # Parameter mZ fällt weg, also bleiben mX und mY übrig
      # TODO: Unklar, was das für das Programm heißt. Folgendes noch falsch.
      Paramvec[ii, 1] := mX[i, 1]: ii:= ii+1:
      Paramvec[ii, 1] := mY[i, 1]: ii:= ii+1:
    elif cos(alpha[i,1]) = 0 and false then # Sonderregel (eq. 20)
      # Parameter mY fällt weg, also bleiben mX und mZ übrig
      # TODO: Unklar, was das für das Programm heißt. Folgendes noch falsch.
      Paramvec[ii, 1] := mX[i, 1]: ii:= ii+1:
      Paramvec[ii, 1] := mZ[i, 1]: ii:= ii+1:
    else
      Paramvec[ii, 1] := mX[i, 1]: ii:= ii+1:
      Paramvec[ii, 1] := mY[i, 1]: ii:= ii+1:
      Paramvec[ii, 1] := mZ[i, 1]: ii:= ii+1:
    end if:
    Paramvec[ii, 1] := m[i, 1]:  ii:= ii+1:
  end if:
end do:

# Entfernung von Nullelementen
# Durch Entfernung der Nullelemente erfolgt 'beta_b' aus [HRL_IDR] (22)
p := 0:
for i to MPV_n_max do
  if Paramvec[i, 1] = 0 then
    p := p+1
  end if:
end do:
# Determine size of matrix dependent on number of Zeroes
Paramvec_size := MPV_n_max-p:
Paramvec2 := Matrix(Paramvec_size, 1):
p := 0:
for i to MPV_n_max do
  # count Zeroes
  if Paramvec[i, 1] = 0 then
    p := p+1:
  else
    # Shift by number of currently found Zeroes
    Paramvec2[i-p, 1] := Paramvec[i, 1]:
  end if:
end do:
printf("Dimension des Minimalparametervektors: %dx1\n", Paramvec_size):
Paramvec2;
# Export - Minimalparametervektor
save Paramvec2, sprintf("../codeexport/%s/tmp/minimal_parameter_vector_fixb_maple", robot_name):
save Paramvec2, sprintf("../codeexport/%s/tmp/minimal_parameter_vector_fixb_maple_geom", robot_name): # zum Testen gegen andere Implementierung
if codegen_act then
   MatlabExport(Paramvec2, sprintf("../codeexport/%s/tmp/minimal_parameter_vector_fixb_matlab.m", robot_name), codegen_opt):
end if;
# Minimal geometrievektor t_i und u_i
# Markieren von t_mZ, t_YY, t_m, u_mZ, u_YY, u_m_j
# Anwendung von [HRL_IDR] Regel 3 (S. 5) auf die Geometrievektoren t und u der Energien T und U
# Der Basis-Körper wird nicht gezählt. Daher ignorieren der ersten zehn Einträge in t_ges
# [GautierKhalil1990], p.369 (rechts: "As a conclusion ..."
for i from 0 to NJ-1 do
  if sigma[i+1,1] = 0 then: # Drehgelenk
    t_ges[1,i*10+ 4]:=REMOVE; # YY
    t_ges[1,i*10+ 9]:=REMOVE; # mZ
    t_ges[1,i*10+10]:=REMOVE; # m
    u_ges[1,i*10+ 4]:=REMOVE; # YY
    u_ges[1,i*10+ 9]:=REMOVE; # mZ
    u_ges[1,i*10+10]:=REMOVE; # m
  else: # Schubgelenk
    u_ges[1,i*10+ 1]:=REMOVE; # XX
    u_ges[1,i*10+ 2]:=REMOVE; # XY
    u_ges[1,i*10+ 3]:=REMOVE; # XZ
    u_ges[1,i*10+ 4]:=REMOVE; # YY
    u_ges[1,i*10+ 5]:=REMOVE; # YZ
    u_ges[1,i*10+ 6]:=REMOVE; # ZZ
    t_ges[1,i*10+ 1]:=REMOVE; # XX
    t_ges[1,i*10+ 2]:=REMOVE; # XY
    t_ges[1,i*10+ 3]:=REMOVE; # XZ
    t_ges[1,i*10+ 4]:=REMOVE; # YY
    t_ges[1,i*10+ 5]:=REMOVE; # YZ
    t_ges[1,i*10+ 6]:=REMOVE; # ZZ
    # Sonderregel (eq. 19-20). Parameter zusammengelegt in Parametervektor. Werden daher hier entfernt.
    # Fälle vorerst auskommentiert (siehe oben). TODO: Das hat alles nicht funktioniert.
    if sin(alpha[i+1,1]) = 0 and false then # deaktiviert!
     u_ges[1,i*10+ 7]:=REMOVE; # mX
     t_ges[1,i*10+ 7]:=REMOVE; # mX
     u_ges[1,i*10+ 8]:=REMOVE; # mY
     t_ges[1,i*10+ 8]:=REMOVE; # mY
    end if:
    if cos(alpha[i+1,1]) = 0 and false then # deaktiviert!
     u_ges[1,i*10+ 7]:=REMOVE; # mX
     t_ges[1,i*10+ 7]:=REMOVE; # mX
     u_ges[1,i*10+ 9]:=REMOVE; # mZ
     t_ges[1,i*10+ 9]:=REMOVE; # mZ
    end if:
  end if:
end do:
# Entfernungen von markierten Elementen
# Durch Entfernung der markierten Elemente, äquivalent zum Minimalparametervektor beta_b, haben t und u die gleiche Spaltenanzahl wie 'C_b'.
p:=0:
for i from 1 to 10*NJ do       #Nullen Zählen um die Matrixgröße von t_ges zu bestimmen
  if t_ges[1,i]=REMOVE and u_ges[1,i]=REMOVE then
    p:=p+1;
  end if
end do:
size_Matrix:=10*NJ-p:
t_ges_minpar:=Matrix(1,size_Matrix):
u_ges_minpar:=Matrix(1,size_Matrix):
printf("Dimension der Regressormatrix: 1x%d\n", size_Matrix):

if size_Matrix <> Paramvec_size then
  printf("Achtung: Dimension der Regressormatrix passt nicht zu der des Parametervektors!\n"):
end if:

p:=0:
for i from 1 to 10*NJ do       #Nullen Zählen
   if t_ges[1,i]=REMOVE and u_ges[1,i]=REMOVE then
      p:=p+1;
   else
      t_ges_minpar[1,i-p]:=t_ges[1,i]; #Um die Anzahl der im Iterationsschritt gezählten Nullen verschieben
      u_ges_minpar[1,i-p]:=u_ges[1,i]; #Um die Anzahl der im Iterationsschritt gezählten Nullen verschieben
   end if
end do:
save t_ges_minpar, sprintf("../codeexport/%s/tmp/energy_kinetic_fixb_regressor_minpar_maple.m", robot_name):
save u_ges_minpar, sprintf("../codeexport/%s/tmp/energy_potential_fixb_regressor_minpar_maple.m", robot_name):
# Zum symbolischen Testen des minimierten Regressors gegen den ursprünglichen
(*
read sprintf("../codeexport/%s/tmp/energy_kinetic_fixb_regressor_maple.m", robot_name):
t_ges := t_ges: # Variable wurde im Arbeitsblatt verändert. Neu laden.
read sprintf("../codeexport/%s/tmp/energy_potential_fixb_regressor_maple.m", robot_name):
u_ges := u_ges:
# Muss Null sein.
test_u := simplify(u_ges_minpar.Paramvec2 - u_ges.PV2_vec(11..,..)):
test_t := simplify(t_ges_minpar.Paramvec2 - t_ges.PV2_vec(11..,..)):
*)
;
# Export
if codegen_act then
  MatlabExport(convert_t_s(t_ges_minpar), sprintf("../codeexport/%s/tmp/energy_kinetic_fixb_regressor_minpar_matlab.m", robot_name), codegen_opt):
end if:
if codegen_act then
  MatlabExport(convert_t_s(u_ges_minpar), sprintf("../codeexport/%s/tmp/energy_potential_fixb_regressor_minpar_matlab.m", robot_name), codegen_opt):
end if:


`is_element/permutations` := (n::nonnegint) -> proc(s)
 type(s,list(posint)) and
 nops(s) = n and
 min(op(s)) = 1 and
 max(op(s)) = n and
 nops({op(s)}) = n;
end:

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

`is_leq/permutations` := NULL;

`random_element/permutations` := (n::nonnegint) ->
 combinat[randperm](n);

`list_elements/permutations` := (n::nonnegint) ->
 combinat[permute](n);

`count_elements/permutations` := (n::nonnegint) -> n!;

`id/permutations` := proc(n::nonnegint) local i; [seq(i,i=1..n)]; end:

`o/permutations` := (n::nonnegint) -> proc()
 local i;
 apply_assoc((s,t) -> [seq(s[t[i]],i=1..n)],
             [seq(i,i=1..n)])(args);
end:

`inv/permutations` := (n::nonnegint) -> proc(s)
 local i,t;
 t := table();
 for i from 1 to n do t[s[i]] := i; od;
 return [seq(t[i],i=1..n)];
end:

`length_set/permutations` := (n::nonnegint) -> proc(s)
 local L,i,j;

 L := [seq(seq([i,j],j=i+1..n),i=1..n-1)];
 L := select(ij -> s[ij[1]] > s[ij[2]],L);
 return L;
end:

`unordered_length_set/permutations` := (n::nonnegint) -> (s) ->
  map(u -> {op(u)},{op(`length_set/permutations`(n)(s))});

`length/permutations` := (n::nonnegint) -> proc(s)
 nops(`length_set/permutations`(n)(s));
end:

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

`is_even/permutations` := (n::nonnegint) -> (s) ->
 evalb(`sgn/permutations`(n)(s) =  1);

`is_odd/permutations` := (n::nonnegint) -> (s) ->
 evalb(`sgn/permutations`(n)(s) = -1);

`switch/permutations` := (n::nonnegint) -> proc(i::posint)
  local j;
  if i >= n then error("Should have 1 <= i < n"); fi;

  return [seq(j,j=1..i-1),i+1,i,seq(j,j=i+2..n)];
end:

`t/permutations` := (n::nonnegint) -> proc(k::posint)
 local i;
 [seq(i,i=1..k-1),seq(i+1,i=k..n-1),k];
end:

`t_inv/permutations` := (n::nonnegint) -> proc(k::posint)
 local i;
 [seq(i,i=1..k-1),n,seq(i-1,i=k+1..n)];
end:

`t_word/permutations` := (n::nonnegint) -> proc(k::posint)
 local i;
 [seq(i,i=k..n-1)];
end:

`to_coxeter_word/permutations` := (n::nonnegint) -> proc(w)
 local m,v;

 if n <= 1 then return []; fi;

 m := w[n];
 v := `o/permutations`(n)(`t_inv/permutations`(n)(m),w);
 v := [op(1..(n-1),v)];
 return [op(`t_word/permutations`(n)(m)),
         op(`to_coxeter_word/permutations`(n-1)(v))];
end:

`from_coxeter_word/permutations` := (n::nonnegint) -> proc(x)
 `o/permutations`(n)(op(map(`switch/permutations`(n),x)));
end:

# Here are two kinds of Coxeter words that reduce to the identity.
# They are used in the proof of the completeness of the Coxeter relations.

`long_coxeter_rel0/permutations` := (n) -> proc(l)
 local i;
 [seq(i,i=l..n-1),seq(i,i=l..n-1),seq(i,i=n-2..l,-1),seq(i,i=n-1..l+1,-1)];
end:

`long_coxeter_rel1/permutations` := (n) -> proc(k,l)
 local i;
 `if`(k <= l,
       [seq(i,i=k..n-1),seq(i,i=l..n-1),seq(i,i=n-2..k,-1),seq(i,i=n-1..l+1,-1)],
       [seq(i,i=k..n-1),seq(i,i=l..n-1),seq(i,i=n-2..k-1,-1),seq(i,i=n-1..l,-1)]);
end:

`coxeter_reduce_once/permutations` := (n) -> proc(x)
 local i,j,k,l,l0,l1,m,p,d,y,z,i0,p0,d0,z0,z1,z2;

 # Move s[p] left of s[q] if p < q - 1
 y := x;
 m := nops(y);
 z := [];
 i := 1;
 while i <= m do
  j := i + 1;
  while j <= m and y[j] < y[i] - 1 do
   z := [op(z),y[j]];
   j := j + 1;
  od;
  z := [op(z),y[i]];
  i := j;
 od;
 y := z;
 m := nops(y);

 z := [];
 i := 1;
 j := 1;
 while i <= m do
  while (j < m and y[j+1] = y[i]) do j := j + 1; od;
  if modp(j - i + 1,2) = 1 then z := [op(z),y[i]]; fi;
  i := j + 1;
  j := i;
 od;
 y := z;
 m := nops(y);

 d := table():
 l := table():
 i0 := 0;
 l0 := 0;

 for i from 1 to m do
  if i < m and abs(y[i+1] - y[i]) = 1 then
   d[i] := y[i+1] - y[i];
   j := i + 1;
   while j <= m and y[j] = y[i] + modp(j - i,2) * d[i] do j := j + 1; od;
   l[i] := j - i;
  else
   d[i] := 0;
   l[i] := 1;
  fi;
  if l[i] > l0 then
   i0 := i;
   l0 := l[i];
  fi;
 od:

 if l0 < 3 then return y; fi;

 z0 := [seq(y[i],i=1..i0-1)];
 z2 := [seq(y[i],i=i0+l0..m)];
 l1 := mods(l0,6);
 p0 := y[i0];
 d0 := d[i0];

 if   l1 = 0             then z1 := [];
 elif l1 = 1             then z1 := [p0];
 elif l1 = 2             then z1 := [p0,p0+d0];
 elif l1 = 3 and d0 =  1 then z1 := [p0,p0+1,p0];
 elif l1 = 3 and d0 = -1 then z1 := [p0-1,p0,p0-1];
 elif l1 = -2            then z1 := [p0+d0,p0];
 elif l1 = -1            then z1 := [p0+d0];
 fi;

 return [op(z0),op(z1),op(z2)];
end:

`coxeter_reduce/permutations` := (n) -> proc(w)
 local u,v;
 u := NULL;
 v := w;
 while u <> v do
  u := v;
  v := `coxeter_reduce_once/permutations`(n)(u);
 od:
 return u;
end:


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

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

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

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

 return true;
end;

`is_equal/simplex_interior` := (A::set) -> proc(x,y)
 `is_equal/simplex`(A)(x,y);
end;

`is_leq/simplex_interior` := NULL;

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

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

 return eval(x);
end;

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


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

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

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

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

$define lda_c_vbh_params
$include "lda_c_hl.mpl"

(* Constant after equation (2.25) in Hu-Langreth. It is equal to the
   numerical constant in equation (12) of the Langreth-Mehl paper,
   4.28e-3, once one accounts for the factor 2 from the conversion
   from Rydberg to Hartree *)
lm_J := Pi/(16*(3*Pi^2)^(4/3)):

(* Equation (2.23) in Hu-Langreth *)
lm_d := z -> sqrt(opz_pow_n(z, 5/3) + opz_pow_n(-z, 5/3))/sqrt(2):

(* F parameter, see after eqn (2.25) in Hu-Langreth; this yields
0.26181 which is rounds to 0.262 given by Langreth and Mehl. Hu and
Langreth say the external parameter f = 0.15 for comparison with LM,
but that f = 0.17 is preferable *)
lm_F := 2*sqrt(3)*params_a_lm_f / (2*(3/Pi)^(1/6)):

(* First term in eqn (2.25) in Hu-Langreth *)
lm_t1 := (z, xs0, xs1) ->
  -7/(9*2^(5/3)) * (xs0^2*opz_pow_n(z, 4/3) + xs1^2*opz_pow_n(-z, 4/3)):

(* Second term in eqn (2.25) in Hu-Langreth *)
lm_t2 := (rs, z, xt) ->
  2/lm_d(z) * exp(-lm_F*xt*n_total(rs)^(1/6)) * xt^2:

f := (rs, z, xt, xs0, xs1) ->
  + hl_f(rs, z)
  + lm_J*(lm_t1(z, xs0, xs1) + lm_t2(rs, z, xt))*n_total(rs)^(1/3):


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

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

$include "gga_x_b88.mpl"

(* equation 11 *)
y := (x,u) -> x^2 - u:
(* equation 5 *)
gBecke := x -> b88_f(x)-1:
(* equation 24 *)
jk_f := (x,u,t) -> 1 + gBecke(x)/(1 + 2*y(x,u)/x^2):

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

br89_a := [0, 1, 0, -2, 0, 1]:
fw := t -> mgga_series_w(br89_a, 6, t):

br89_gamma := 0.8:
br89_Q := (x, t, u) -> (u - 4*t*br89_gamma*Fermi_D(x, t))/6:
br89_y := (x, t, u) -> 2*Pi^(2/3)/(3*br89_Q(x, t, u)):

(* lower piece *)
pgk_a1 := 1.5255251812009530:
pgk_a2 := 0.4576575543602858:
pgk_a3 := 0.4292036732051034:

pgk_b  := [0.4771976183772063, -1.7799813494556270, 3.8433841862302150,
       -9.5912050880518490, 2.1730180285916720, -30.425133851603660]:

pgk_c  := [0.7566445420735584, -2.6363977871370960, 5.4745159964232880,
       -12.657308127108290, 4.1250584725121360, -30.425133957163840]:

pgk_d  := [0.00004435009886795587, 0.58128653604457910, 66.742764515940610,
       434.26780897229770, 824.7765766052239000, 1657.9652731582120]:

pgk_e  := [0.00003347285060926091, 0.47917931023971350, 62.392268338574240,
       463.14816427938120, 785.2360350104029000, 1657.962968223273000000]:

pgk_UB := 2.085749716493756:

pgk_x_lower := y -> (-arctan(pgk_a1*y + pgk_a2) + pgk_a3) *
            add(pgk_c[i]*y^(i-1), i=1..6)/add(pgk_b[i]*y^(i-1), i=1..6):

pgk_x_upper := y -> (arccsch(pgk_UB*y) + 2) *
            add(pgk_d[i]*y^(i-1), i=1..6)/add(pgk_e[i]*y^(i-1), i=1..6):

pgk_x := (x, t, u) -> convert(piecewise(
  br89_y(x, t, u) <= 0, pgk_x_lower(br89_y(x, t, u)),
  pgk_x_upper(br89_y(x, t, u))), 'Heaviside'):

br89_v_full := x -> exp(x/3.0)*(1.0 - exp(-x)*(1.0 + x/2.0))/x:
br89_v_expa := x -> 1/2 + x/6 - x^2/18:

br89_v := (x, t, u) ->
       -2*Pi^(1/3)/X_FACTOR_C * br89_v_full(pgk_x(x, t, u)):

f   := (rs, x, t, u) -> -br89_v(x, t, u)/2:


with(plots):
with(plottools):

great_arc := proc(u,v,hue)
 local w,r,s,t,d,i;
 w := [u[2]*v[3]-u[3]*v[2],u[3]*v[1]-u[1]*v[3],u[1]*v[2]-u[2]*v[1]];
 r := evalf(sqrt(u[1]^2+u[2]^2+u[3]^2));
 d := u[1]*v[1]+u[2]*v[2]+u[3]*v[3];
 w := [v[1] - d * u[1]/r^2,v[2] - d * u[2]/r^2,v[3] - d * u[3]/r^2];
 s := evalf(sqrt(w[1]^2+w[2]^2+w[3]^2));
 w := [r*w[1]/s,r*w[2]/s,r*w[3]/s];
 t := evalf(arccos(d/r^2))/10;
 return(CURVES(
        [seq([cos(i*t)*u[1]+sin(i*t)*w[1],
              cos(i*t)*u[2]+sin(i*t)*w[2],
              cos(i*t)*u[3]+sin(i*t)*w[3]],i=0..10)],
        COLOR(HUE,hue)));
end:


# The function brent_fsolve uses Brent's algorithm to find a root of
# a real valued function of one variable.   This code is based on the
# Matlab implementation by John Burkardt, which is in turn based on the
# original Fortran implementation by Richard Brent.  However, this
# version is designed for the case where we want to retain a lot
# of additional information that is generated in the process of
# evaluating the relevant function.
#
# The first argument F should be a function which accepts a single
# real argument t and returns a table F(t).  This should contain an
# entry F(t)["err"], which we want to be zero.  The second and third
# arguments should be numbers a and b such that F(a)["err"] and
# F(b)["err"] have opposite signs.  Other entries in F(t) can contain
# auxiliary information generated during the calculation.
#
# If F(a) and/or F(b) have already been computed, then they can be
# supplied as the arguments Fa_ and Fb_.  Otherwise, these arguments
# should be set to false.

#@ brent_fsolve
brent_fsolve := proc(F,a,b,Fa_,Fb_,tol_,epsilon_)
 local tol,tol1,epsilon,c,sa,sb,sc,Fa,Fb,Fc,fa,fb,fc,d,e,m,p,q,r,s,steps,ret;

 tol := `if`(nargs > 5,tol_,10.^(-20));
 epsilon := `if`(nargs > 6,epsilon_,10.^(2 - Digits));

 sa := a;
 sb := b;
 if nargs < 4 or Fa_ = false then Fa := eval(F(sa)); else Fa := eval(Fa_); fi;
 if nargs < 5 or Fb_ = false then Fb := eval(F(sb)); else Fb := eval(Fb_); fi;
 fa := Fa["err"];
 fb := Fb["err"];

 if not((fa <= 0 and 0 <= fb) or
        (fb <= 0 and 0 <= fa)) then
  error("function has the same sign at endpoints");
 fi;

 c := sa;
 fc := fa;
 Fc := eval(Fa);
 e := sb - sa;
 d := e;

 steps := 0;

 while true do
  steps := steps+1;

  if ( abs ( fc ) < abs ( fb ) ) then
   sa := sb;
   sb := c;
   c := sa;
   fa := fb;
   fb := fc;
   fc := fa;
   Fa := eval(Fb);
   Fb := eval(Fc);
   Fc := eval(Fa);
  fi;

  tol1 := 2.0 * epsilon * abs ( sb ) + tol;
  m := 0.5 * ( c - sb );

  if ( abs ( m ) <= tol or fb = 0.0 ) then
   break;
  fi;

  if ( abs ( e ) < tol or abs ( fa ) <= abs ( fb ) ) then
   e := m;
   d := e;
  else
   s := fb / fa;
   if ( sa = c ) then
    p := 2.0 * m * s;
    q := 1.0 - s;
   else
    q := fa / fc;
    r := fb / fc;
    p := s * ( 2.0 * m * q * ( q - r ) - ( sb - sa ) * ( r - 1.0 ) );
    q := ( q - 1.0 ) * ( r - 1.0 ) * ( s - 1.0 );
   fi;

   if ( 0.0 < p ) then
    q := - q;
   else
    p := - p;
   fi;

   s := e;
   e := d;

   if ( 2.0 * p < 3.0 * m * q - abs ( tol * q ) and p < abs ( 0.5 * s * q ) ) then
    d := p / q;
   else
    e := m;
    d := e;
   fi;
  fi;

  sa := sb;
  fa := fb;
  Fa := eval(Fb);

  if ( tol < abs ( d ) ) then
   sb := sb + d;
  elif ( 0.0 < m ) then
   sb := sb + tol;
  else
   sb := sb - tol;
  fi;

  Fb := eval(F(sb));
  fb := Fb["err"];

  if ( ( 0.0 < fb and 0.0 < fc ) or ( fb <= 0.0 and fc <= 0.0 ) ) then
   c := sa;
   fc := fa;
   Fc := eval(Fa);
   e := sb - sa;
   d := e;
  fi;
 od;

 ret := eval(Fb);
 ret["steps"] := steps;

 return [sb,eval(ret)];
end:


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

`is_element/prime_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 := max(u,v);
 od;

 if simplify(v - 1) <> 0 then
  reason := [convert(procname,string),"max(x[a] : a in A) <> 1",a,v];
  return false;
 fi;

 return true;
end;

`is_equal/prime_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/prime_simplex` := NULL;

`random_element/prime_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 := max(u,x[a]);
  od;
 od;

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

 return eval(x);
end;

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

`phi/nonempty_subsets/prime_simplex` := (A::set) -> proc(U)
 local x,a;

 x := table();
 for a in A do x[a] := 0; od;
 for a in U do x[a] := 1; od;

 return eval(x);
end;

`supp/prime_simplex` := (A::set) -> proc(x)
 select(a -> x[a] > 0,A);
end:

`functor/prime_simplex` := (A::set,B::set) -> (f) -> proc(x)
 local a,b,y;

 y := table():
 for b in B do y[b] := 0; od:
 for a in A do y[f[a]] := max(y[f[a]],x[a]); od:
 return eval(y);
end:


with(DifferentialAlgebra):
ring_diff := DifferentialRing(blocks = [[v, x, z, w, y], [y2, y1] ], derivations = [t]):
sys := [
diff(v(t), t) - (k*y(t) - v(t)*u),
diff(x(t), t) - (lm - x(t)*d - x(t)*v(t)*beta),
diff(z(t), t) - (c*w(t)*q*y(t) - h*z(t)),
diff(w(t), t) - (-b*w(t) + c*w(t)*x(t)*y(t) - c*w(t)*q*y(t)),
diff(y(t), t) - (x(t)*v(t)*beta - a*y(t)),
y2(t) - (z(t)),
y1(t) - (w(t))
];
res := CodeTools[CPUTime](RosenfeldGroebner(sys, ring_diff, singsol=none));


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

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

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

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

params_a_a := [0.0253933, -0.0673075, 0.0891476, -0.0454168, -0.00765813, 0.0142506]:
params_a_b := [-2.6506, 3.91108, -3.31509, 1.54485, -0.198386,
  -0.136112, 0.0647862, 0.0159586, -0.000245066]:

xi := 1/(exp(20) - 1):
fs := s -> -log((exp(-s) + xi)/(1 + xi)):

$include "gga_x_hjs.mpl"

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


`is_element/morse_matchings` := (A::set) -> (R) -> proc(M)
 global reason;
 local e,H,F;

 if not(type(M,set)) then
  reason := ["is_element/morse_matchings","M is not a set",M];
  return false;
 fi;

 for e in M do
  if not(type(e,list)) and nops(e) = 2 then
   reason := ["is_element/morse_matchings","M is not a set of lists of length 2",M,e];
   return false;
  fi;

  if {op(e)} minus A <> {} then
   reason := ["is_element/morse_matchings","M is not a set of lists of length 2 in A",M,e];
   return false;
  fi;
 od:

 H := `hasse_diagram/partord`(A)(R);

 if M minus H <> {} then
  reason := ["is_element/morse_matchings","M is not a subset of the Hasse diagram",M,H];
  return false;
 fi;

 for e in M do
  if select(f -> {op(f)} intersect {op(e)} <> {}, M) <> {e} then
   reason := ["is_element/morse_matchings","edges in M are not disjoint",M,e];
   return false;
  fi;
 od:

 F := M union map(e -> [e[2],e[1]],H minus M);
 F := `transitive_closure/autorel`(A)(F);
 F := F intersect `op/autorel`(A)(F);
 if F minus `id/autorel`(A) <> {} then
  reason := ["is_element/morse_matchings","M has cycles",M,F];
  return false;
 fi;

 return true;
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_gapc.mpl"

(* The two parameters were fixed by fitting to the exact correlation
energy per particle of the He atom *)
gaploc_b  := 14.709046:
gaploc_a1 :=  6.54613 + 2:

gaploc_alpha := t  -> (gaploc_a1 + 3*t^3)/(1 + t^3):
gaploc_s     := xt -> X2S*xt*2^(1/3):

(* override definition of gap_G *)
(* The pre-factor is completely different from the one in
   Equation (7). I used the "gfac" from the original code. *)
gap_G := (rs, z, xt, par) -> (9*Pi/4)^(2/3)/2.0
  * gaploc_s(xt)^(gaploc_alpha(gap_t(rs, z, xt)))/rs^2
  * (gaploc_b + gaploc_s(xt)^2)/(1 + gaploc_s(xt)^(gaploc_alpha(gap_t(rs, z, xt)))):


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

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

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

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

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

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

b97mv_fpar  := (lda_func, rs, z, xs0, xs1, ts0, ts1) ->
  + lda_stoll_par(lda_func, rs,  z,  1) * b97mv_g(gamma_x,  wx_ss, par_x,  par_n, xs0, ts0, 0)
  + lda_stoll_par(f_pw    , rs,  z,  1) * b97mv_g(gamma_ss, wx_ss, par_ss, par_n, xs0, ts0, 0)
  + lda_stoll_par(lda_func, rs, -z, -1) * b97mv_g(gamma_x,  wx_ss, par_x,  par_n, xs1, ts1, 0)
  + lda_stoll_par(f_pw    , rs, -z, -1) * b97mv_g(gamma_ss, wx_ss, par_ss, par_n, xs1, ts1, 0):

b97mv_fos := (rs, z, xs0, xs1, ts0, ts1) ->
  lda_stoll_perp(f_pw, rs, z)
  * b97mv_g(gamma_os, wx_os, par_os, par_n, sqrt(xs0^2 + xs1^2)/sqrt(2), ts0, ts1):

f_b97mv :=  (lda_func, rs, z, xt, xs0, xs1, ts0, ts1) ->
  + b97mv_fpar(lda_func, rs, z, xs0, xs1, ts0, ts1)
  + b97mv_fos(rs, z, xs0, xs1, ts0, ts1):


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

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

(* type: gga_exc *)

$define lda_c_pw_params
$include "lda_c_pw.mpl"

(* Parameters from Table 6 *)
gap_par0 := [
   0.04953, 1.07924, 0.07928, (* a1, a2, a3 *)
  -2.504e-2, 7.026e-3, -1.268e-3, 1.136e-4, -3.841e-6, (* b3, b4, b5, b6, b7 *)
   0.031091,  (* params_a_a of lda_c_pw *)
   0.23878    (* pre-factor of C = 0.06483*((9*Pi)/4)^(2/3) *)
]:
gap_par1 := [
   0.0471985, 1.49676, 0.00179054,
  -3.24091e-2, 9.99978e-3, -1.93483e-3, 1.79118e-4, -6.15798e-6,
   0.015545,
   0.064535
]:

(* Equation (20): e'(rs) *)
gap_eps_1 := (rs, par) ->
  par[1]*rs^(3/2)/(1 + sqrt(rs)*(par[2] + par[3]*sqrt(rs) + par[1]*rs)):
(* Equation (21): e''(rs) *)
gap_eps_2 := (rs, par) ->
  add(par[i+1]*rs^i, i=3..7):

(* Equation (19) *)
gap_C := (rs, par) -> par[10]/rs^2:

(* Equation (17) *)
gap_c2 := (rs, z, par) ->
  + (2*f_pw(rs, z)*gap_eps_1(rs, par) - gap_C(rs, par)*gap_eps_2(rs, par))
  / (2*(gap_C(rs, par)*gap_eps_1(rs, par) - f_pw(rs, z)^2)):
(* Equation (18) *)
gap_c3 := (rs, z, par) ->
  - (2*gap_eps_1(rs, par)^2 - f_pw(rs, z)*gap_eps_2(rs, par))
  / (2*(gap_C(rs, par)*gap_eps_1(rs, par) - f_pw(rs, z)^2)):
(* Equation (16) *)
gap_c1 := (rs, z, par) ->
  - gap_C(rs, par) * gap_c3(rs, z, par):

(* after Equation (6): a = 30 is a parameter fixed by minimizing the
variance of the correlation energy error for the noble gas atoms He,
Ne, and Ar *)
gap_par_a := 30:

(* Equation (6) *)
gap_H := (rs, t, par) ->
  (gap_par_a  + par[9]*rs*log(rs)*t^2/beta_Hu_Langreth(rs))/(gap_par_a + t^2):

gap_t := (rs, z, xt) ->
  xt*n_total(rs)^(1/6)/(4*mphi(z)*(3/Pi)^(1/6)):

(* Gap function, Equation (5) *)
gap_G := (rs, z, xt, par) ->
  + mphi(z)^3*beta_Hu_Langreth(rs)*gap_t(rs, z, xt)^2
  * gap_H(rs, gap_t(rs, z, xt), par)
  / (gap_c1(rs, z, par) - gap_c2(rs, z, par)*f_pw(rs, z)):

(* Correlation energy per particle, Equation (4) *)
gap_eps := (rs, z, xt, par) ->
  + (f_pw(rs, z) + gap_c1(rs, z, par)*gap_G(rs, z, xt, par))
  / (1 + gap_c2(rs, z, par)*gap_G(rs, z, xt, par) + gap_c3(rs, z, par)*gap_G(rs, z, xt, par)^2):

(* Total energy, Equation (2) *)
f_gap := (rs, z, xt) ->
  + gap_eps(rs, 0, xt, gap_par0)
  + f_zeta(z)*(gap_eps(rs, 1, xt, gap_par1) - gap_eps(rs, 0, xt, gap_par0)):

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


# Generated using bssn_4d_spher_matter.mw

restx:=expand(simplify((-2*b1(t, x)*alpha(t, x)*(diff(a1(t, x), t))-2*x*alpha(t, x)*(diff(a1(t, x), t))*(diff(b1(t, x), x))+2*x*(diff(diff(b1(t, x), t), x))*alpha(t, x)*a1(t, x)+2*(diff(b1(t, x), t))*alpha(t, x)*a1(t, x)+2*beta(t, x)*alpha(t, x)*b1(t, x)*(diff(a1(t, x), x))+b1(t, x)*x*alpha(t, x)*a1(t, x)*(diff(rpsi(t, x), x))*(diff(rpsi(t, x), t))+b1(t, x)*x*alpha(t, x)*a1(t, x)*(diff(ipsi(t, x), x))*(diff(ipsi(t, x), t))-b1(t, x)*x*alpha(t, x)*a1(t, x)*beta(t, x)*(diff(rpsi(t, x), x))^2-b1(t, x)*x*alpha(t, x)*a1(t, x)*beta(t, x)*(diff(ipsi(t, x), x))^2-2*beta(t, x)*alpha(t, x)*a1(t, x)*x*(diff(diff(b1(t, x), x), x))+2*beta(t, x)*alpha(t, x)*x*(diff(a1(t, x), x))*(diff(b1(t, x), x))-4*beta(t, x)*(diff(b1(t, x), x))*alpha(t, x)*a1(t, x)-2*x*(diff(b1(t, x), t))*a1(t, x)*(diff(alpha(t, x), x))+2*beta(t, x)*a1(t, x)*x*(diff(alpha(t, x), x))*(diff(b1(t, x), x))+2*beta(t, x)*a1(t, x)*b1(t, x)*(diff(alpha(t, x), x)))/(alpha(t, x)^3*b1(t, x)*x*a1(t, x))));

ire_rpsi_direct:=
-2*(diff(rpsi(t, x), x))*beta(t, x)*(diff(beta(t, x), x))/alpha(t, x)^2+(diff(rpsi(t, x), t))*beta(t, x)*(diff(a1(t, x), x))/(alpha(t, x)^2*a1(t, x))-(diff(rpsi(t, x), t))*beta(t, x)*(diff(alpha(t, x), x))/alpha(t, x)^3-(diff(rpsi(t, x), x))*beta(t, x)*(diff(alpha(t, x), t))/alpha(t, x)^3+(diff(rpsi(t, x), x))*beta(t, x)^2*(diff(alpha(t, x), x))/alpha(t, x)^3+2*(diff(rpsi(t, x), t))*beta(t, x)*(diff(b1(t, x), x))/(alpha(t, x)^2*b1(t, x))+2*(diff(rpsi(t, x), x))*beta(t, x)*(diff(b1(t, x), t))/(alpha(t, x)^2*b1(t, x))-2*(diff(rpsi(t, x), x))*beta(t, x)^2*(diff(b1(t, x), x))/(alpha(t, x)^2*b1(t, x))+(diff(rpsi(t, x), x))*beta(t, x)*(diff(a1(t, x), t))/(alpha(t, x)^2*a1(t, x))-(diff(rpsi(t, x), x))*beta(t, x)^2*(diff(a1(t, x), x))/(alpha(t, x)^2*a1(t, x))-2*(diff(rpsi(t, x), t))*(diff(b1(t, x), t))/(alpha(t, x)^2*b1(t, x))+2*(diff(rpsi(t, x), t))*beta(t, x)/(alpha(t, x)^2*x)-2*(diff(rpsi(t, x), x))*beta(t, x)^2/(alpha(t, x)^2*x)+(diff(rpsi(t, x), t))*(diff(alpha(t, x), t))/alpha(t, x)^3+2*beta(t, x)*(diff(diff(rpsi(t, x), t), x))/alpha(t, x)^2+(diff(rpsi(t, x), t))*(diff(beta(t, x), x))/alpha(t, x)^2-(diff(rpsi(t, x), t))*(diff(a1(t, x), t))/(alpha(t, x)^2*a1(t, x))-beta(t, x)^2*(diff(diff(rpsi(t, x), x), x))/alpha(t, x)^2+(diff(rpsi(t, x), x))*(diff(beta(t, x), t))/alpha(t, x)^2-(diff(diff(rpsi(t, x), t), t))/alpha(t, x)^2+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*(diff(rpsi(t, x), x))*(diff(b1(t, x), x))/(b1(t, x)*a1(t, x)^2)-mass*rpsi(t, x)+(diff(rpsi(t, x), x))*(diff(alpha(t, x), x))/(alpha(t, x)*a1(t, x)^2);

resxx:=
(1/2)*(-alpha(t, x)^3*b1(t, x)^2*x^2*(diff(rpsi(t, x), x))^2-alpha(t, x)^3*b1(t, x)^2*x^2*(diff(ipsi(t, x), x))^2+alpha(t, x)*b1(t, x)^2*x^2*(diff(rpsi(t, x), x))^2*a1(t, x)^2*beta(t, x)^2+alpha(t, x)*b1(t, x)^2*x^2*(diff(ipsi(t, x), x))^2*a1(t, x)^2*beta(t, x)^2-2*b1(t, x)^2*a1(t, x)^2*alpha(t, x)*beta(t, x)^2-2*(diff(b1(t, x), t))^2*a1(t, x)^2*alpha(t, x)*x^2+4*b1(t, x)^2*x*alpha(t, x)^2*(diff(alpha(t, x), x))+4*(diff(b1(t, x), x))*alpha(t, x)^3*x*b1(t, x)+2*(diff(b1(t, x), x))^2*alpha(t, x)^3*x^2+2*alpha(t, x)^3*b1(t, x)^2-2*a1(t, x)^2*alpha(t, x)^3+alpha(t, x)^3*b1(t, x)^2*x^2*U(t, x)*a1(t, x)^2-alpha(t, x)*b1(t, x)^2*x^2*(diff(rpsi(t, x), t))^2*a1(t, x)^2-alpha(t, x)*b1(t, x)^2*x^2*(diff(ipsi(t, x), t))^2*a1(t, x)^2+4*a1(t, x)*beta(t, x)*b1(t, x)*x^2*alpha(t, x)*(diff(a1(t, x), t))*(diff(b1(t, x), x))-4*a1(t, x)*beta(t, x)^2*alpha(t, x)*b1(t, x)*x^2*(diff(a1(t, x), x))*(diff(b1(t, x), x))-4*a1(t, x)*beta(t, x)^2*alpha(t, x)*b1(t, x)^2*x*(diff(a1(t, x), x))+4*a1(t, x)*beta(t, x)*b1(t, x)^2*x*alpha(t, x)*(diff(a1(t, x), t))-4*b1(t, x)*x^2*a1(t, x)^2*alpha(t, x)*(diff(diff(b1(t, x), t), t))+4*b1(t, x)^2*x*a1(t, x)^2*alpha(t, x)*(diff(beta(t, x), t))-2*(diff(b1(t, x), x))^2*x^2*a1(t, x)^2*alpha(t, x)*beta(t, x)^2+4*b1(t, x)*x^2*(diff(alpha(t, x), t))*a1(t, x)^2*(diff(b1(t, x), t))-4*b1(t, x)^2*x*(diff(alpha(t, x), t))*a1(t, x)^2*beta(t, x)+4*b1(t, x)*x^2*alpha(t, x)^2*(diff(alpha(t, x), x))*(diff(b1(t, x), x))+4*b1(t, x)*x^2*a1(t, x)^2*alpha(t, x)*(diff(beta(t, x), t))*(diff(b1(t, x), x))+4*b1(t, x)*x^2*a1(t, x)^2*alpha(t, x)*beta(t, x)*(diff(diff(b1(t, x), t), x))+8*b1(t, x)*x*a1(t, x)^2*alpha(t, x)*beta(t, x)*(diff(b1(t, x), t))+4*(diff(b1(t, x), x))*x^2*a1(t, x)^2*alpha(t, x)*beta(t, x)*(diff(b1(t, x), t))-4*(diff(b1(t, x), x))*x*a1(t, x)^2*alpha(t, x)*beta(t, x)^2*b1(t, x)-4*alpha(t, x)*b1(t, x)^2*x*beta(t, x)*a1(t, x)^2*(diff(beta(t, x), x))-4*b1(t, x)*x^2*(diff(alpha(t, x), t))*a1(t, x)^2*beta(t, x)*(diff(b1(t, x), x))-4*alpha(t, x)*b1(t, x)*x^2*beta(t, x)*a1(t, x)^2*(diff(beta(t, x), x))*(diff(b1(t, x), x)))/(alpha(t, x)^3*a1(t, x)^2*b1(t, x)^2*x^2);

restt:=
(1/2)*(4*b1(t, x)^2*x*a1(t, x)^3*beta(t, x)^2*(diff(alpha(t, x), x))-2*(diff(b1(t, x), x))^2*x^2*a1(t, x)^3*alpha(t, x)*beta(t, x)^2+12*(diff(b1(t, x), x))*alpha(t, x)^3*a1(t, x)*x*b1(t, x)+4*alpha(t, x)^3*a1(t, x)*b1(t, x)*x^2*(diff(diff(b1(t, x), x), x))-4*alpha(t, x)^3*b1(t, x)*x^2*(diff(a1(t, x), x))*(diff(b1(t, x), x))-4*a1(t, x)^3*alpha(t, x)*b1(t, x)*x^2*beta(t, x)^2*(diff(diff(b1(t, x), x), x))+4*b1(t, x)*x^2*a1(t, x)^3*alpha(t, x)*beta(t, x)*(diff(diff(b1(t, x), t), x))+8*b1(t, x)*x*a1(t, x)^3*alpha(t, x)*beta(t, x)*(diff(b1(t, x), t))+4*(diff(b1(t, x), x))*x^2*a1(t, x)^3*alpha(t, x)*beta(t, x)*(diff(b1(t, x), t))-12*(diff(b1(t, x), x))*x*a1(t, x)^3*alpha(t, x)*beta(t, x)^2*b1(t, x)+4*a1(t, x)^3*(diff(b1(t, x), t))*alpha(t, x)*b1(t, x)*x^2*(diff(beta(t, x), x))-4*a1(t, x)^2*(diff(b1(t, x), t))*alpha(t, x)*b1(t, x)*x^2*(diff(a1(t, x), t))-4*alpha(t, x)*b1(t, x)^2*x*beta(t, x)*a1(t, x)^3*(diff(beta(t, x), x))-4*b1(t, x)*x^2*a1(t, x)^3*(diff(b1(t, x), t))*beta(t, x)*(diff(alpha(t, x), x))+4*b1(t, x)*x^2*a1(t, x)^3*beta(t, x)^2*(diff(b1(t, x), x))*(diff(alpha(t, x), x))+4*a1(t, x)^2*(diff(b1(t, x), t))*alpha(t, x)*b1(t, x)*x^2*beta(t, x)*(diff(a1(t, x), x))-4*alpha(t, x)*b1(t, x)*x^2*beta(t, x)*a1(t, x)^3*(diff(beta(t, x), x))*(diff(b1(t, x), x))-2*b1(t, x)^2*a1(t, x)^3*alpha(t, x)*beta(t, x)^2-2*(diff(b1(t, x), t))^2*a1(t, x)^3*alpha(t, x)*x^2+2*(diff(b1(t, x), x))^2*alpha(t, x)^3*a1(t, x)*x^2-4*alpha(t, x)^3*b1(t, x)^2*x*(diff(a1(t, x), x))+2*alpha(t, x)^3*a1(t, x)*b1(t, x)^2-2*a1(t, x)^3*alpha(t, x)^3+b1(t, x)^2*x^2*alpha(t, x)*a1(t, x)^3*(diff(rpsi(t, x), t))^2+b1(t, x)^2*x^2*alpha(t, x)*a1(t, x)^3*(diff(ipsi(t, x), t))^2+b1(t, x)^2*x^2*alpha(t, x)^3*a1(t, x)^3*U(t, x)+b1(t, x)^2*x^2*alpha(t, x)^3*a1(t, x)*(diff(rpsi(t, x), x))^2+b1(t, x)^2*x^2*alpha(t, x)^3*a1(t, x)*(diff(ipsi(t, x), x))^2-b1(t, x)^2*x^2*alpha(t, x)*a1(t, x)^3*(diff(rpsi(t, x), x))^2*beta(t, x)^2-b1(t, x)^2*x^2*alpha(t, x)*a1(t, x)^3*(diff(ipsi(t, x), x))^2*beta(t, x)^2)/(alpha(t, x)^3*b1(t, x)^2*x^2*a1(t, x)^3);

resthth:=
(1/2)*(-2*a1(t, x)^2*alpha(t, x)*b1(t, x)*x*(diff(diff(a1(t, x), t), t))+2*alpha(t, x)^2*a1(t, x)*b1(t, x)*x*(diff(diff(alpha(t, x), x), x))-2*alpha(t, x)*a1(t, x)^3*b1(t, x)*x*(diff(beta(t, x), x))^2-2*b1(t, x)*x*(diff(a1(t, x), x))*alpha(t, x)^2*(diff(alpha(t, x), x))+2*(diff(alpha(t, x), x))*a1(t, x)^2*b1(t, x)*x*beta(t, x)^2*(diff(a1(t, x), x))+2*(diff(alpha(t, x), x))*a1(t, x)^3*b1(t, x)*x*beta(t, x)*(diff(beta(t, x), x))-2*(diff(alpha(t, x), x))*a1(t, x)^2*b1(t, x)*x*beta(t, x)*(diff(a1(t, x), t))+2*a1(t, x)^2*(diff(b1(t, x), t))*alpha(t, x)*x*beta(t, x)*(diff(a1(t, x), x))-2*alpha(t, x)*x*beta(t, x)^2*a1(t, x)^2*(diff(a1(t, x), x))*(diff(b1(t, x), x))-4*alpha(t, x)*x*beta(t, x)*a1(t, x)^3*(diff(beta(t, x), x))*(diff(b1(t, x), x))+2*alpha(t, x)*x*beta(t, x)*a1(t, x)^2*(diff(a1(t, x), t))*(diff(b1(t, x), x))-2*a1(t, x)^2*(diff(alpha(t, x), t))*b1(t, x)*x*beta(t, x)*(diff(a1(t, x), x))+4*(diff(a1(t, x), t))*alpha(t, x)*a1(t, x)^2*b1(t, x)*x*(diff(beta(t, x), x))+2*a1(t, x)^2*alpha(t, x)*b1(t, x)*x*(diff(beta(t, x), t))*(diff(a1(t, x), x))+4*a1(t, x)^2*alpha(t, x)*b1(t, x)*x*beta(t, x)*(diff(diff(a1(t, x), t), x))-2*alpha(t, x)*a1(t, x)^2*b1(t, x)*x*beta(t, x)^2*(diff(diff(a1(t, x), x), x))-2*alpha(t, x)*a1(t, x)^3*b1(t, x)*x*beta(t, x)*(diff(diff(beta(t, x), x), x))-6*alpha(t, x)*a1(t, x)^2*b1(t, x)*x*beta(t, x)*(diff(a1(t, x), x))*(diff(beta(t, x), x))+2*b1(t, x)*a1(t, x)^3*beta(t, x)^2*(diff(alpha(t, x), x))+4*a1(t, x)^3*alpha(t, x)*beta(t, x)*(diff(b1(t, x), t))-4*(diff(b1(t, x), x))*a1(t, x)^3*alpha(t, x)*beta(t, x)^2-2*x*a1(t, x)^3*alpha(t, x)*(diff(diff(b1(t, x), t), t))+2*b1(t, x)*a1(t, x)^3*alpha(t, x)*(diff(beta(t, x), t))+2*a1(t, x)*b1(t, x)*alpha(t, x)^2*(diff(alpha(t, x), x))+2*x*(diff(alpha(t, x), t))*a1(t, x)^3*(diff(b1(t, x), t))-2*b1(t, x)*(diff(alpha(t, x), t))*a1(t, x)^3*beta(t, x)+2*alpha(t, x)^3*a1(t, x)*x*(diff(diff(b1(t, x), x), x))-2*alpha(t, x)^3*x*(diff(a1(t, x), x))*(diff(b1(t, x), x))+b1(t, x)*x*a1(t, x)^3*alpha(t, x)^3*U(t, x)-b1(t, x)*x*a1(t, x)^3*alpha(t, x)*(diff(rpsi(t, x), t))^2-b1(t, x)*x*a1(t, x)^3*alpha(t, x)*(diff(ipsi(t, x), t))^2+b1(t, x)*x*a1(t, x)*alpha(t, x)^3*(diff(rpsi(t, x), x))^2+b1(t, x)*x*a1(t, x)*alpha(t, x)^3*(diff(ipsi(t, x), x))^2-2*alpha(t, x)^3*b1(t, x)*(diff(a1(t, x), x))+4*(diff(b1(t, x), x))*alpha(t, x)^3*a1(t, x)+2*a1(t, x)^3*(diff(b1(t, x), t))*alpha(t, x)*x*(diff(beta(t, x), x))-2*a1(t, x)^2*(diff(b1(t, x), t))*alpha(t, x)*x*(diff(a1(t, x), t))-2*alpha(t, x)*b1(t, x)*beta(t, x)^2*a1(t, x)^2*(diff(a1(t, x), x))-4*alpha(t, x)*b1(t, x)*beta(t, x)*a1(t, x)^3*(diff(beta(t, x), x))+2*alpha(t, x)*b1(t, x)*beta(t, x)*a1(t, x)^2*(diff(a1(t, x), t))-2*a1(t, x)^3*(diff(alpha(t, x), t))*b1(t, x)*x*(diff(beta(t, x), x))+2*a1(t, x)^2*(diff(alpha(t, x), t))*b1(t, x)*x*(diff(a1(t, x), t))+2*a1(t, x)^3*alpha(t, x)*b1(t, x)*x*(diff(diff(beta(t, x), t), x))-2*a1(t, x)^3*alpha(t, x)*x*beta(t, x)^2*(diff(diff(b1(t, x), x), x))+2*x*a1(t, x)^3*alpha(t, x)*(diff(beta(t, x), t))*(diff(b1(t, x), x))+4*x*a1(t, x)^3*alpha(t, x)*beta(t, x)*(diff(diff(b1(t, x), t), x))+2*a1(t, x)*x*alpha(t, x)^2*(diff(alpha(t, x), x))*(diff(b1(t, x), x))-2*x*(diff(alpha(t, x), t))*a1(t, x)^3*beta(t, x)*(diff(b1(t, x), x))-2*x*a1(t, x)^3*(diff(b1(t, x), t))*beta(t, x)*(diff(alpha(t, x), x))+2*x*a1(t, x)^3*beta(t, x)^2*(diff(b1(t, x), x))*(diff(alpha(t, x), x))-b1(t, x)*x*a1(t, x)^3*alpha(t, x)*(diff(rpsi(t, x), x))^2*beta(t, x)^2-b1(t, x)*x*a1(t, x)^3*alpha(t, x)*(diff(ipsi(t, x), x))^2*beta(t, x)^2+2*b1(t, x)*x*a1(t, x)^3*alpha(t, x)*beta(t, x)*(diff(rpsi(t, x), t))*(diff(rpsi(t, x), x))+2*b1(t, x)*x*a1(t, x)^3*alpha(t, x)*beta(t, x)*(diff(ipsi(t, x), t))*(diff(ipsi(t, x), x)))/(b1(t, x)*x*alpha(t, x)^3*a1(t, x)^3);


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

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

(* type: gga_exc *)

lag_a1 :=   0.041106:
lag_a2 :=   2.626712:
lag_a3 :=   0.092070:
lag_a4 :=   0.657946:

lag_f0 := s-> lag_a1 * s^lag_a2/(1 + lag_a3 * s^lag_a2)^lag_a4:
lag_f  := x-> lag_f0(X2S*x):

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


# A striped preorder is one for which comparability is an equivalence relation

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

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

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

 E := R union `op/autorel`(A)(R);

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

 return true;
end;

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

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

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

######################################################################
# A075729

`count_elements/striped_preord` := proc(A::set)
 local n,x,egf;
 n := nops(A);
 egf := convert(series(exp(1/(2-exp(x))-1),x=0,n+1),polynom,x):
 return n! * coeff(egf,x,n);
end:

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

`list_elements/striped_preord` := proc(A::set)
 local RR,PI,pi,LL,QQ,B,Q,L;

 RR := [];

 PI := `list_elements/partitions`(A);
 for pi in PI do
  LL := [{}];
  for B in pi do
   QQ := `list_elements/total_preord`(B);
   LL := [seq(seq(L union Q,Q in QQ),L in LL)];
  od;
  RR := [op(RR),op(LL)];
 od:

 return RR;
end:

######################################################################
# Note that the function below is not actually a rank function, but
# it is an ingredient in certain rank functions to be defined
# elsewhere.

`rank/preord` := (A::set) -> proc(R)
 nops(`block_partition/preord`(A)(R));
end:

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

`random_element/striped_preord` := (A::set) -> proc()
 local pi,Q,B;

 pi := `random_element/partitions`(A)();
 Q := {};
 for B in pi do
  Q := Q union `random_element/total_preord`(B)();
 od;
 return Q;
end:

######################################################################
# Returns a striped preorder R0 > R with
# (or FAIL if R is already maximal).

`bump/striped_preord` := (A::set) -> proc(R)
 local pi,B,a,b,B0,R0;

 pi := `block_partition/preord`(A)(R);

 for B in pi do
  if nops(B) > 1 then
   a := B[1];
   B0 := B minus {a};
   R0 := R minus {seq([b,a],b in B0)};
   return R0;
  fi;
 od;

 return FAIL;
end:

######################################################################
# Returns a striped preorder R1 with R < R0 <= S
# (or FAIL if this is impossible)

`relative_bump/striped_preord` := (A::set) -> proc(R,S)
 local pi,B,BB,SB,C,a,b,c,B0,R0;

 pi := `block_partition/preord`(A)(R);

 for B in pi do
  BB := `top/autorel`(B);
  SB := S intersect BB;
  if BB minus S <> {} then
   for a in B do
    C := select(b -> member([b,a],SB) and not(member([a,b],SB)),B);
    if C = {} then
     B0 := B minus {a};
     R0 := R minus {seq([b,a],b in B0)};
     return R0;
    fi;
   od;
   return FAIL; # should not happen
  fi;
 od;

 return FAIL;
end:

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

`describe/striped_preord` := (A::set) -> proc(R)
 local s0,s1,s2,pi,B,C,r,m,j,k,c;

 s0 := "";
 pi := `block_partition/preord`(A)(R union `op/autorel`(A)(R));
 for B in pi do
  r := `rank_table/preord`(B)(R intersect `top/autorel`(B));
  m := max(map(b -> r[b],B));
  s1 := "";
  for j from 0 to m do
   C := select(b -> r[b]=j,B);
   s2 := "";
   for k from 1 to nops(C) do
    s2 := cat(s2,`if`(k>1,"=",""),sprintf("%A",C[k]));
   od:
   s1 := cat(s1,`if`(j>0,"<",""),s2);
  od;
  s0 := cat(s0,`if`(s0="","",","),s1);
 od:

 return s0;
end:


with(DifferentialAlgebra):
ring_diff := DifferentialRing(blocks = [[EGF_EGFR, EGFR, pEGFR, pAkt_S6, pEGFR_Akt, pAkt, S6, pS6, Akt], [y1, y2, y3] , [pro_EGFR]], derivations = [t]):
sys := [
diff(EGF_EGFR(t), t) - (reaction_1_k1*EGF_EGFR(t) - reaction_9_k1*EGF_EGFR(t) - reaction_1_k2*EGF_EGFR(t)),
diff(EGFR(t), t) - (-reaction_1_k1*EGF_EGFR(t) + reaction_1_k2*EGF_EGFR(t) - EGFR(t)*EGFR_turnover + EGFR_turnover*pro_EGFR(t)),
diff(pEGFR(t), t) - (-reaction_4_k1*pEGFR(t) + reaction_9_k1*EGF_EGFR(t) - pEGFR(t)*Akt(t)*reaction_2_k1 + reaction_3_k1*pEGFR_Akt(t) + pEGFR_Akt(t)*reaction_2_k2),
diff(pAkt_S6(t), t) - (pAkt(t)*reaction_5_k1*S6(t) - reaction_6_k1*pAkt_S6(t) - pAkt_S6(t)*reaction_5_k2),
diff(pEGFR_Akt(t), t) - (pEGFR(t)*Akt(t)*reaction_2_k1 - reaction_3_k1*pEGFR_Akt(t) - pEGFR_Akt(t)*reaction_2_k2),
diff(pAkt(t), t) - (-pAkt(t)*reaction_7_k1 - pAkt(t)*reaction_5_k1*S6(t) + reaction_6_k1*pAkt_S6(t) + reaction_3_k1*pEGFR_Akt(t) + pAkt_S6(t)*reaction_5_k2),
diff(S6(t), t) - (pS6(t)*reaction_8_k1 - pAkt(t)*reaction_5_k1*S6(t) + pAkt_S6(t)*reaction_5_k2),
diff(pS6(t), t) - (-pS6(t)*reaction_8_k1 + reaction_6_k1*pAkt_S6(t)),
diff(Akt(t), t) - (pAkt(t)*reaction_7_k1 - pEGFR(t)*Akt(t)*reaction_2_k1 + pEGFR_Akt(t)*reaction_2_k2),
y1(t) - (pEGFR(t)*a1 + a1*pEGFR_Akt(t)),
y2(t) - (a2*pAkt(t) + a2*pAkt_S6(t)),
y3(t) - (pS6(t)*a3)
];
res := CodeTools[CPUTime](RosenfeldGroebner(sys, ring_diff, singsol=none));


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

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

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

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

ol2_f := x ->
  + params_a_aa
  + params_a_bb*x^2/72.0
  + params_a_cc*x/(2^(1/3) + 4*x):

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


# Number of subspaces of dimension d in F^n, if |F|=q

grassmann_count := (q::posint) -> proc(n,d)
 local i;
 return mul(q^(n-i)-1,i=0..d-1)/mul(q^(d-i)-1,i=0..d-1);
end:

# Number of splittings of F^(n+m) as a sum of subspaces of
# dimensions n and m, if |F| = q.

splitting_count := (q::posint) -> (n,m) ->
 grassman_count(q)(n+m,n) * q^(n*m);

# tanabe_N(p,n,r)(k) is the number of irreducible F-linear representations
# of Z_p^n that have dimension p^k over F.

tanabe_N := (p,n,r) -> (k) -> `if`(k = 0,p^(n*r),(p^n-1) * p^((n-1)*k + n*(r-1)));

# The socle of K^0(BGL_{p^k}(F)) is generated by
# euler(V)^{N-1}, where N = tanabe_N_bar(n,v,k)

tanabe_N_bar := (p,n,r) -> proc(k)
 local j;
 p^(n*r) + (p^n-1)*p^(n*(r-1))*sum(p^((n-1)*j),j=1..k);
end:

tanabe_N_star := (p,n,r) -> proc(k)
 local j;
 p^(n*r-1) * (p-1) * sum(p^((n-1)*j),j=0..k-1);
end:

tanabe_N_lim := (p,n,r) -> (k) -> p^(n*r+n*k-k) * (1-p^(-n))/(1-p^(1-n));

# The natural numbers can be partitioned as the disjoint union of
# the sets tanabe_NN(p,n,r)(k), of size tanabe_N(p,n,r)(k).

tanabe_NN := (p,n,r) -> proc(k::nonnegint)
 local i;
 if k = 0 then
  return [seq(i,i=0..tanabe_N_bar(p,n,r)(0)-1)];
 else
  return [seq(i,i=tanabe_N_bar(p,n,r)(k-1)..tanabe_N_bar(p,n,r)(k)-1)];
 fi;
end:

# tanabe_s(p,n,r)(m) is the unique k such that m lies in tanabe_NN(p,n,r)(k).
tanabe_s := (p,n,r) -> proc(m)
 local k;
 k := 0;
 while m >= tanabe_N_bar(p,n,r)(k) do
  k := k+1;
 od;
 return k;
end:

# tanabe_X(p,n,r)(k) is the set of generators for E^0(BGL_*(F)) in
# degree p^k.

tanabe_X := (p,n,r) -> proc(k)
 local j;
 return [seq(c[p^k] ^ j, j = 0..tanabe_N(p,n,r)(k)-1)];
end:

# tanabe_prim_gen(p,n,r)(k) is a generator for the primitives
# in K^0(BGL_*(F)) in degree p^k
tanabe_prim_gen := (p,n,r) -> (k) -> c[p^k] ^ tanabe_N_bar(p,n,r)(k-1);

# tanabe_soc_gen(p,n,r)(k) is a generator for the socle of
# K^0(BGL_{p^k}(F))
tanabe_soc_gen  := (p,n,r) -> (k) -> c[p^k] ^ (tanabe_N_bar(p,n,r)(k) - 1);

# tanabe_m(p)(k) has p-adic valuation k and divides
# tanabe_m(p)(k+1).  Moreover, any positive integer n divides
# tanabe_m(p)(k) when k is sufficiently large.

tanabe_m := (p) -> proc(k)
  local m,i;
  m := 1;
  i := 1;
  while ithprime(i) <= p + k do
    m := m * ithprime(i) ^ k;
    i := i + 1;
  od:
  return m;
end:

check_tanabe_m := proc(p,k)
  _ASSERT(padic_val(tanabe_m(p)(k),p) = k,
          "v_p(m[k])");

  _ASSERT(type(tanabe_m(p)(k+1)/tanabe_m(p)(k),posint),
          "m[k] divides m[k+1]");
end:

# Given a polynomial f over the integers and a prime q, return
# the first irreducible factor of f mod q, in the standard
# Maple order.

first_factor := proc(f,q)
 local F;
 F := :-Factor(f) mod q;
 if type(F,`*`) then F := [op(F)] else F := [F]; fi:
 F := sort(map(g -> `if`(type(g,`^`),op(1,g),g),F));
 return F[1];
end:

# Return an irreducible polynomial f[k](x) of degree v0 * p^k over
# Z/q0.  This gives a field F(k) of degree p^k over F = F(0),
# where F(0) has order q = q0 ^ v0.  The polynomials are arranged
# so that the canonical primitive element x[k] in F(k) generates
# the group of units, and there is an inclusion F(k) -> F(k+1)
# sending x[k] to x[k+1] ^ m, where m = |F(k+1)^x|/|F(k)^x|.
tanabe_FF_poly := (q0,v0,p) -> proc(k::nonnegint)
 option remember;
 local q,m,f;

 q := q0 ^ v0;
 if k = 0 then
  f := NumberTheory[CyclotomicPolynomial](q0 ^ v0 - 1,x);
 else
  m := (q ^ (p ^ k) - 1)/(q ^ (p ^ (k - 1)) - 1);
  f := subs(x = x ^ m, tanabe_FF_poly(q0,v0,p)(k - 1));
 end:

 return first_factor(f,q0);
end:

# tanabe_F(q0,v0)(m) is the field denoted by F[m] in the paper,
# where q = q0 ^ v0 with q0 prime and v0 > 0.
# tanabe_FF(q0,v0)(p,k) is F(k) = F[p^k].

tanabe_F := (q0,v0) -> (m) -> GF(q0,v0 * m);
tanabe_FF := (q0,v0) -> (p,k) -> GF(q0,v0 * p ^ k,tanabe_FF_poly);

# Orders of various groups: G is the general linear group,
# N is the subgroup of monomial matrices, H is the block
# diagonal subgroup of p' index as in prop-non-p-power.

tanabe_G_order := (q) -> proc(d)
 local k;
 return mul(q ^ d - q ^ k,k = 0..d-1);
end:

tanabe_N_order := (q) -> (d) -> d! * (q - 1)^d;

tanabe_H_order := (q,p) -> proc(d)
 local dd,m,i;
 dd := digit_list(d,p);
 m := nops(dd);
 mul(tanabe_G_order(q)(p ^ i) ^ dd[i+1], i = 0..m-1);
end:

# The E^2 page of the AHSS converging to K_*(BV) has a trigrading
# with E^2_{ijk} = H_i(BV_k;K_j).  It has even generators
# b[i] and u, and odd generators e[i] with
#   |b[i]| = tanabe_b_trideg(p,n,r)(i) = [2i,0,1]
#   |e[i]| = tanabe_e_trideg(p,n,r)(i) = [2i+1,0,1]
#   |u|    = tanabe_u_trideg(p,n,r)    = [0,2,0].

tanabe_b_trideg  := (p,n,r) -> (i) -> [2*i,0,1];
tanabe_e_trideg  := (p,n,r) -> (i) -> [2*i+1,0,1];
tanabe_u_trideg  := (p,n,r) -> [0,2,0];

# The only nontrivial differentials have the form d_r, where
# r = tanabe_AHSS_page(p,n,r)(k) for some k >= 0
# [From now on we refer to this as the k'th differential,
#  and the page on which it occurs as the k'th page.]

tanabe_AHSS_page := (p,n,r) -> (k) -> 2*p^(n*(r+k)) - 1;

# Tridegree of the k'th differential
tanabe_AHSS_d_trideg := (p,n,r) -> (k) ->
 [1-2*p^(n*(r+k)),2*p^(n*(r+k))-2,0];

# The k'th page can be described in terms of generators
# bb[m,i] and ee[m,i]

tanabe_bb_defined := (p,n,r) -> (k) -> (m,i) ->
  m >= min(k,tanabe_s(p,n,r)(i));

tanabe_bb_indec := (p,n,r) -> (k) -> (m,i) ->
  m = min(k,tanabe_s(p,n,r)(i));

tanabe_ee_defined := (p,n,r) -> (k) -> (m,i) ->
  m = k and i >= tanabe_N_star(p,n,r)(k);

tanabe_bb_trideg := (p,n,r) -> (m,i) -> [2*p^m*i,0,p^m];
tanabe_ee_trideg := (p,n,r) -> (m,i) -> [2*p^m*i + 1,0,p^m];

tanabe_dbb0 := (p,n,r) -> (k) -> (m,i) ->
  ee[k,i - tanabe_N_bar(p,n,r)(k) + tanabe_N_star(p,n,r)(k)] *
    u ^ (p^(n * (k + r)) - 1);

tanabe_dbb := (p,n,r) -> (k) -> (m,i) ->
  `if`(m < k, 0, `if`(i < tanabe_N_bar(p,n,r)(k), 0, tanabe_dbb0(p,n,r)(k)(m,i)));

# This is the part of the inverse Poincare series contributed by
# irreducible representations of dimension at most p^k.

tanabe_inverse_poincare_series := (p,n,r) -> proc(k)
 local j;
 (1-t)^(p^(n*r)) * mul((1 - t^(p^j))^(p^(n*(r+j))*(1-1/p^n)),j=1..k);
end:

tanabe_poincare_series := (p,n,r) -> (k) ->
 convert(series(1/tanabe_inverse_poincare_series(p,n,r)(k),t=0,p^k+1),
         polynom,t);

tanabe_trideg := (p,n,r) -> proc(x)
 local d,d0,y;

 if type(x,indexed) then
  if op(0,x) = b then
   return tanabe_b_trideg(p,n,r)(op(x));
  elif op(0,x) = e then
   return tanabe_e_trideg(p,n,r)(op(x));
  elif op(0,x) = bb then
   return tanabe_bb_trideg(p,n,r)(op(x));
  elif op(0,x) = ee then
   return tanabe_ee_trideg(p,n,r)(op(x));
  else
   return [0,0,0];
  fi;
 elif x = u then
  return tanabe_u_trideg(p,n,r);
 elif type(x,`+`) then
  d := map(tanabe_trideg(p,n,r),{op(x)});
  if nops(d) = 1 then
   return op(d);
  else
   return FAIL;
  fi;
 elif type(x,`*`) then
  d := [0,0,0];
  for y in [op(x)] do
   d0 := tanabe_trideg(p,n,r)(y);
   if d0 = FAIL then return FAIL; fi;
   d := d +~ d0;
  od;
  return d;
 elif type(x,`^`) then
  return tanabe_trideg(p,n,r)(op(1,x)) *~ op(2,x);
 else
  return [0,0,0];
 fi;
end:

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

# Check v_p(q ^ j - 1) = r + v_p(j)
check_lem_vp := (p) -> proc(q::posint,j::posint)
 local r;
 r := padic_val(q - 1,p);
 _ASSERT(r > 0, "r > 0");

 _ASSERT(padic_val(q ^ j - 1,p) = r + padic_val(j,p),
         sprintf("v_{%d}(%d ^ %d - 1)",p,q,j));
end;

check_tanabe_numbers := proc()
 local n,r,k,p,L,N,N_bar,N_star,N_lim,P,err;

 assume(n::posint);
 assume(r::posint);
 assume(k::posint);
 assume(p::posint);

 N      := tanabe_N(p,n,r);
 N_bar  := tanabe_N_bar(p,n,r);
 N_star := tanabe_N_star(p,n,r);
 N_lim  := tanabe_N_lim(p,n,r);

 _ASSERT(
  simplify(N_bar(k) - N_bar(k-1) - N(k)) = 0,
  "N_bar(k) - N_bar(k-1) = N(k)"
 );

 _ASSERT(
  simplify(N_star(k) - (N_bar(k) - p^(n*k + n*r - k))) = 0,
  "N_star(k) = N_bar(k) - p^(n*k + n*r - k)"
 );

 _ASSERT(
  simplify(p^k * (N_bar(k) - N_star(k)) - p^(n * (k + r))) = 0,
  "p^k * (N_bar(k) - N_star(k)) = p^(n * (k + r))"
 );

 _ASSERT(
  simplify(p^(k + 1) * (N_bar(k) - N_star(k + 1)) - p^(n * (k + r))) = 0,
  "p^(k + 1) * (N_bar(k) - N_star(k + 1)) = p^(n * (k + r))"
 );

 _ASSERT(
  simplify(N(0) + sum(p^j * N(j),j=1..k) - p^(n*(r+k))) = 0,
  "sum(p^j * N(j),j=0..k) = p^(n*(r+k))"
 );

 _ASSERT(
  simplify((1 - p^(-k)) * N(0) +
           sum(expand((1 - p^(j - k)) * N(j)),j=1..k) - N_star(k)) = 0,
  "sum((1 - p^(j-k)) * N(j),j=0..k) = N_star(k)"
 );

 _ASSERT(
  simplify(p^(k + 1) * N_star(k + 1) - p^k * N_star(k) - (p - 1) * p^k * N_bar(k)) = 0,
  "p^(k + 1) * N_star(k + 1) = p^k * N_star(k) + (p - 1) * p^k * N_bar(k)"
 );

 _ASSERT(
  simplify(factor(N_bar(k) - (N_star(k)*(p^n-1)/(p-1) + p^(n*r)))) = 0,
  "N_bar(k) = N_star(k)*(p^n-1)/(p-1) + p^(n*r)"
 );

 _ASSERT(
  simplify(sum(p^j*(p-1)*N_bar(j),j=0..k-1) - p^k*N_bar(k) + p^(n*(r+k))) = 0,
  "sum(p^j*(p-1)*N_bar(j),j=0..k-1)"
 );

 _ASSERT(
  limit(simplify(N_bar(k)/N_lim(k)-1),k=infinity) = 0,
  "N_bar(k) is asymptotic to N_lim(k)"
 );
end:

check_factorial_congruences := proc()
 local p,i;
 p := ithprime(20);

 _ASSERT(
  {seq(modp((-1)^i * (i - 1)! * (p - i)!,p),i=1..p-1)} = {1},
  "(-1)^i * (i - 1)! * (p - i)! = 1 mod p"
 );

 _ASSERT(
  {seq(mods((-1)^i * binomial(p-1,i-1),p),i=1..p-1)} = {-1},
  "(-1)^i * binomial(p-1,i-1) = -1 mod p"
 );
end:

check_valuations := proc()
 local q0,v0,q,p,r,d,m;
 q0 := 19;
 v0 := 1;
 q  := q0 ^ v0;
 p  := 3;
 r  := padic_val(q - 1, p);
 d  := 20;

 _ASSERT(
  padic_val(tanabe_G_order(q)(d),p) - (d * r + (d - digit_sum(d,p))/(p - 1)) = 0,
  "valuation of |G(d)|"
 );

 m := tanabe_G_order(q)(d) / tanabe_N_order(q)(d):
 _ASSERT(type(m,posint) and padic_val(m,p) = 0,
  "N(d) has p' index in G(d)"
 );

 m := tanabe_G_order(q)(d) / tanabe_H_order(q,p)(d):
 _ASSERT(type(m,posint) and padic_val(m,p) = 0,
  "H(d) has p' index in G(d)"
 );

end:

check_diff_trideg := proc()
 local p,n,r,k,m,i,err,d0,d1,d2;

 d0 := tanabe_bb_trideg(p,n,r)(k,i);
 d1 := tanabe_AHSS_d_trideg(p,n,r)(k);
 d2 := tanabe_trideg(p,n,r)(tanabe_dbb0(p,n,r)(k)(m,i));

 err := simplify(d0 + d1 - d2, symbolic);

 _ASSERT(err = [0,0,0], "differential respects tridegrees");
end:


with(Groebner):
with(PolynomialIdeals):

J := PolynomialIdeal({2*f1*f2*f3*f4*f5 - 9823275,
5*f1*f2*f3*f4 + 24/5*f1*f2*f3*f5 + 21/5*f1*f2*f4*f5 + 16/5*f1*f3*f4*f5 + 9/5*f2*f3*f4*f5 - 4465125,
4*f1*f2*f3 + 6*f1*f2*f4 + 18/5*f1*f2*f5 + 6*f1*f3*f4 + 24/5*f1*f3*f5 + 14/5*f1*f4*f5 + 4*f2*f3*f4 + 18/5*f2*f3*f5 + 14/5*f2*f4*f5 + 8/5*f3*f4*f5 - 441486,
3*f1*f2 + 4*f1*f3 + 4*f1*f4 + 12/5*f1*f5 + 3*f2*f3 + 4*f2*f4 + 12/5*f2*f5 + 3*f3*f4 + 12/5*f3*f5 + 7/5*f4*f5 - 15498,
2*f1 + 2*f2 + 2*f3 + 2*f4 + 6/5*f5 - 215,
f1 + 2*f2 + 3*f3 + 4*f4 + 5*f5 + 6*t}):
st := time[real]():
Basis(J, tdeg(f1,f2,f3,f4,f5,t), characteristic=2^31-1):
time[real]() - st;

J := PolynomialIdeal({2*f1*f2*f3*f4*f5*f6 - 1404728325,
6*f1*f2*f3*f4*f5 + 35/6*f1*f2*f3*f4*f6 + 16/3*f1*f2*f3*f5*f6 + 9/2*f1*f2*f4*f5*f6 + 10/3*f1*f3*f4*f5*f6 + 11/6*f2*f3*f4*f5*f6 - 648336150,
5*f1*f2*f3*f4 + 8*f1*f2*f3*f5 + 14/3*f1*f2*f3*f6 + 9*f1*f2*f4*f5 + 7*f1*f2*f4*f6 + 4*f1*f2*f5*f6 + 8*f1*f3*f4*f5 + 7*f1*f3*f4*f6 + 16/3*f1*f3*f5*f6 + 3*f1*f4*f5*f6 + 5*f2*f3*f4*f5 + 14/3*f2*f3*f4*f6 + 4*f2*f3*f5*f6 + 3*f2*f4*f5*f6 +
5/3*f3*f4*f5*f6 - 67597623,
4*f1*f2*f3 + 6*f1*f2*f4 + 6*f1*f2*f5 + 7/2*f1*f2*f6 + 6*f1*f3*f4 + 8*f1*f3*f5 + 14/3*f1*f3*f6 + 6*f1*f4*f5 + 14/3*f1*f4*f6 + 8/3*f1*f5*f6 + 4*f2*f3*f4 + 6*f2*f3*f5 + 7/2*f2*f3*f6 + 6*f2*f4*f5 + 14/3*f2*f4*f6 + 8/3*f2*f5*f6 + 4*f3*f4*f5 + 7/2*f3*f4*f6 + 8/3*f3*f5*f6 +
3/2*f4*f5*f6 - 2657700,
3*f1*f2 + 4*f1*f3 + 4*f1*f4 + 4*f1*f5 + 7/3*f1*f6 + 3*f2*f3 + 4*f2*f4 + 4*f2*f5 + 7/3*f2*f6 + 3*f3*f4 + 4*f3*f5 + 7/3*f3*f6 + 3*f4*f5 + 7/3*f4*f6 + 4/3*f5*f6 - 46243,
2*f1 + 2*f2 + 2*f3 + 2*f4 + 2*f5 + 7/6*f6 - 358}):
st := time[real]():
Basis(J, tdeg(f1,f2,f3,f4,f5,f6), characteristic=2^31-1):
time[real]() - st;

J := PolynomialIdeal({2*f1*f2*f3*f4*f5*f6*f7 - 273922023375, 7*f1*f2*f3*f4*f5*f6 + 48/7*f1*f2*f3*f4*f5*f7 + 45/7*f1*f2*f3*f4*f6*f7 + 40/7*f1*f2*f3*f5*f6*f7 + 33/7*f1*f2*f4*f5*f6*f7 + 24/7*f1*f3*f4*f5*f6*f7 + 13/7*f2*f3*f4*f5*f6*f7 - 127830277575,
6*f1*f2*f3*f4*f5 + 10*f1*f2*f3*f4*f6 + 40/7*f1*f2*f3*f4*f7 + 12*f1*f2*f3*f5*f6 + 64/7*f1*f2*f3*f5*f7 + 36/7*f1*f2*f3*f6*f7 + 12*f1*f2*f4*f5*f6 + 72/7*f1*f2*f4*f5*f7 + 54/7*f1*f2*f4*f6*f7 + 30/7*f1*f2*f5*f6*f7 + 10*f1*f3*f4*f5*f6 + 64/7*f1*f3*f4*f5*f7 + 54/7*f1*f3*f4*f6*f7 + 40/7*f1*f3*f5*f6*f7 + 22/7f1*f4*f5*f6*f7 + 6*f2*f3*f4*f5*f6 + 40/7*f2*f3*f4*f5*f7 + 36/7*f2*f3*f4*f6*f7 + 30/7*f2*f3*f5*f6*f7 + 22/7*f2*f4*f5*f6*f7 + 12/7*f3*f4*f5*f6*f7 - 13829872635,
5*f1*f2*f3*f4 + 8*f1*f2*f3*f5 + 8*f1*f2*f3*f6 + 32/7*f1*f2*f3*f7 + 9*f1*f2*f4*f5 + 12*f1*f2*f4*f6 + 48/7*f1*f2*f4*f7 + 9*f1*f2*f5*f6 + 48/7*f1*f2*f5*f7 + 27/7*f1*f2*f6*f7 + 8*f1*f3*f4*f5 + 12*f1*f3*f4*f6 +
48/7*f1*f3*f4*f7 + 12*f1*f3*f5*f6 + 64/7*f1*f3*f5*f7 + 36/7*f1*f3*f6*f7 + 8*f1*f4*f5*f6 + 48/7*f1*f4*f5*f7 + 36/7*f1*f4*f6*f7 + 20/7*f1*f5*f6*f7 + 5*f2*f3*f4*f5 + 8*f2*f3*f4*f6 + 32/7*f2*f3*f4*f7 + 9*f2*f3*f5*f6 + 48/7*f2*f3*f5*f7 + 27/7*f2*f3*f6*f7 + 8*f2*f4*f5*f6 + 48/7*f2*f4*f5*f7 + 36/7*f2*f4*f6*f7 + 20/7*f2*f5*f6*f7 + 5*f3*f4*f5*f6 + 32/7*f3*f4*f5*f7 + 27/7*f3*f4*f6*f7 + 20/7*f3*f5*f6*f7 + 11/7*f4*f5*f6*f7 - 585849123,
4*f1*f2*f3 + 6*f1*f2*f4 + 6*f1*f2*f5 + 6*f1*f2*f6 + 24/7*f1*f2*f7 + 6*f1*f3*f4 + 8*f1*f3*f5 + 8*f1*f3*f6 + 32/7*f1*f3*f7 + 6*f1*f4*f5 + 8*f1*f4*f6 + 32/7*f1*f4*f7 + 6*f1*f5*f6 + 32/7*f1*f5*f7 + 18/7*f1*f6*f7 + 4*f2*f3*f4 + 6*f2*f3*f5 + 6*f2*f3*f6 + 24/7*f2*f3*f7 + 6*f2*f4*f5 + 8*f2*f4*f6 + 32/7*f2*f4*f7 + 6*f2*f5*f6 + 32/7*f2*f5*f7 + 18/7*f2*f6*f7 + 4*f3*f4*f5 + 6*f3*f4*f6 + 24/7*f3*f4*f7 + 6*f3*f5*f6 + 32/7*f3*f5*f7 + 18/7*f3*f6*f7 + 4*f4*f5*f6 + 24/7*f4*f5*f7 + 18/7*f4*f6*f7 + 10/7*f5*f6*f7 - 11675085,
3*f1*f2 + 4*f1*f3 + 4*f1*f4 + 4*f1*f5 + 4*f1*f6 + 16/7*f1*f7 + 3*f2*f3 + 4*f2*f4 + 4*f2*f5 + 4*f2*f6 + 16/7*f2*f7 + 3*f3*f4 + 4*f3*f5 + 4*f3*f6 + 16/7*f3*f7 + 3*f4*f5 + 4*f4*f6 + 16/7*f4*f7 + 3*f5*f6 + 16/7*f5*f7 + 9/7*f6*f7 - 116053,
2*f1 + 2*f2 + 2*f3 + 2*f4 + 2*f5 + 2*f6 + 8/7*f7 - 553}):
st := time[real]():
Basis(J, tdeg(f1,f2,f3,f4,f5,f6,f7), characteristic=2^31-1):
time[real]() - st;


(*
 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: "mbrxc_x\(" -> "xc_mgga_x_mbrxc_get_x(" *)

mbrxc_a1 := 0.074746:
mbrxc_a2 := 0.147:
mbrxc_a3 := 0.0032:

(* This is the derivative of f = (1+x)^(5/3)*exp(-2/3*x)/(x - 3) = (32*Pi)^(2/3)/(6*Q) *)
mbrxc_aux_dfdx := x -> -2/3 * (1 + x)^(2/3) * exp(-2*x/3) * (x^2 - 3*x + 6) / (x - 3)^2:

`diff/mbrxc_x` := proc(Q, g)
  - (32*Pi)^(2/3)/6 * diff(Q, g)/(Q^2 * mbrxc_aux_dfdx(mbrxc_x(Q)))
end proc:

mbrxc_Q := (x, t) ->
        mbrxc_a1*(2*t) - K_FACTOR_C + mbrxc_a2*x^2 + mbrxc_a3*x^4:

mbrxc_min_Q := 5.0e-13:
mbrxc_cQ := Q -> my_piecewise3(abs(Q) < mbrxc_min_Q,
  my_piecewise3(Q > 0, mbrxc_min_Q, -mbrxc_min_Q), Q):

mbrxc_v := x ->
  - (32*Pi)^(1/3)/(8*X_FACTOR_C) * exp(x/3)*(8 - exp(-x)*(x^2 + 5*x + 8))/(x*(1 + x)^(1/3)):

mbrxc_f := (x, u, t) ->
  - mbrxc_v(mbrxc_x(mbrxc_cQ(mbrxc_Q(x, t))))/2:

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