# Inverse Dynamics for Robot with IC
# Einleitung
# Berechnung der inversen Dynamik für Roboter mit impliziten Zwangsbedingungen
#
# Dateiname:
# robot -> Berechnung für allgemeinen Roboter
# implicit_constraints -> Berechnung für Roboter mit impliziten Zwangsbedingungen
# rotmat -> Kinematik wird mit Rotationsmatrizen berechnet
# dynamics -> Berechnung der Dynamik
# worldframe -> Berechnung basierend auf Energien aus Welt-KS (KS W)
# par1 -> Parametersatz 1 (Schwerpunkt als Parameter: SX,SY,SZ)
# reg2 -> Regressorform
# Autor
# Tim Job (HiWi-Job bei Moritz Schappler), 2019-05
# Moritz Schappler, moritz.schappler@imes.uni-hannover.de
# (C) Institut für Mechatronische Systeme, Universität Hannover
# Sources
# [ParkChoPlo1999] Park, FC and Choi, Jihyeon and Ploen, SR: Symbolic formulation of closed chain dynamics in independent coordinates
# [Docquier2013] Docquier, Nicolas and Poncelet, Antoine and Fisette, Paul: ROBOTRAN: a powerful symbolic gnerator of multibody models (2013)
# [DoThanhKotHeiOrt2009b] Do Thanh et al.: On the inverse dynamics problem of general parallel robots (2009)
# Initialization
interface(warnlevel=0): # Unterdrücke die folgende Warnung.
restart: # Gibt eine Warnung, wenn über Terminal-Maple mit read gestartet wird.
interface(warnlevel=3):
with(LinearAlgebra):
with(ArrayTools):
with(codegen):
with(CodeGeneration):
with(StringTools):
# Einstellungen für Code-Export: Optimierungsgrad (2=höchster) und Aktivierung jedes Terms.
#codegen_act := true: # noch nicht implementiert
codegen_debug := false:
codegen_opt := 2:
read "../helper/proc_MatlabExport":
read "../robot_codegen_definitions/robot_env_IC":
read sprintf("../codeexport/%s/tmp/tree_floatb_definitions", robot_name_OL):
read "../robot_codegen_definitions/robot_env_IC":
if base_method_name="twist" then # Basis-Methode "twist" wird (hier) nur für fixed Base benutzt
  expstring:="fixb":
elif base_method_name="eulxyz" then
  expstring:="floatb_eulxyz":
else
  printf("Nicht behandelte Basis-Methode: %s\n", base_method_name):
fi:
# Kennung des Parametersatzes, für den die Dynamikfunktionen erstellt werden sollen. Muss im Repo und in der mpl-Datei auf 1 gelassen werden, da die folgende Zeile mit einem Skript verarbeitet wird.
codegen_dynpar := 1:
regressor_modus := "regressor":
herleitungsverfahren := "lagrange":
codeexport_invdyn := false:
codeexport_grav_inertia := false:
codeexport_coriolisvec := false:
codeexport_regressor := false:
if herleitungsverfahren = "lagrange" then #Dynamik aus Lagrange
# Ergebnisse der inversen Dynamik für par1/2 laden
  if codeexport_invdyn then
    read sprintf("../codeexport/%s/tmp/invdyn_fixb_par%d_maple.m", robot_name_OL, codegen_dynpar):
    tau := Matrix(taus_fixb(7..NQ,1)):
    printf("%s. Generiere inverse Dynamik (%s) für %s basierend auf IC-Jacobi und OL-Dynamik mit Parametersatz %d  und %s\n", \
      FormatTime("%Y-%m-%d %H:%M:%S"), herleitungsverfahren, robot_name, codegen_dynpar, base_method_name):
  fi:
# Ergebnisse der inversen Dynamik in Regressorform laden
  if codeexport_regressor then
    read sprintf("../codeexport/%s/tmp/invdyn_%s_%s_maple.m", robot_name_OL, expstring, regressor_modus):
    tau_regressor_s := tau_regressor_s(7..NQ,..):
    printf("%s. Generiere Dynamik in Regressorform (%s) für %s basierend auf IC-Jacobi und OL-Dynamik\n", \
      FormatTime("%Y-%m-%d %H:%M:%S"), herleitungsverfahren, robot_name):
  fi:
# Ergebnisse der Massenmatrix und des Gravitationsvektors laden
  if codeexport_grav_inertia then
    read sprintf("../codeexport/%s/tmp/gravload_par%d_maple.m", robot_name_OL, codegen_dynpar):
    taug := Matrix(taug_s(7..NQ,..)):
    read sprintf("../codeexport/%s/tmp/inertia_par%d_maple.m", robot_name_OL, codegen_dynpar):
    MM := Matrix(MM_s(7..NQ,7..NQ)):
    read sprintf("../codeexport/%s/tmp/coriolisvec_par%d_maple.m", robot_name_OL, codegen_dynpar):
    tauCC := Matrix(tauCC_s(7..NQ,..)):
    printf("%s. Generiere Gravitationsvektor und Massenmatrix (%s) für %s basierend auf IC-Jacobi und OL-Dynamik mit Parametersatz %d und %s\n",\
      FormatTime("%Y-%m-%d %H:%M:%S"), herleitungsverfahren, robot_name, codegen_dynpar, base_method_name):
  fi:

# Ergebnisse des Coriolisvektors laden. Noch nicht implementiert.
  if codeexport_coriolisvec then
    read sprintf("../codeexport/%s/tmp/coriolisvec_par%d_maple.m", robot_name_OL, codegen_dynpar):
    tauCC := Matrix(tauCC_s(7..NQ,..)):
    read sprintf("../codeexport/%s/tmp/inertia_par%d_maple.m", robot_name_OL, codegen_dynpar):
    MM := Matrix(MM_s(7..NQ,7..NQ)):
    printf("%s. Generiere Coriolisvektor (%s) für %s basierend auf IC-Jacobi und OL-Dynamik mit Parametersatz %d und %s\n", \
      FormatTime("%Y-%m-%d %H:%M:%S"), herleitungsverfahren, robot_name, codegen_dynpar, base_method_name):
  fi:
else #Dynamik aus Newton-Euler
# Ergebnisse der inversen Dynamik für par1/2 laden
  invdynfile:=sprintf("../codeexport/%s/tmp/invdyn_twist_NewtonEuler_linkframe_par%d_maple.m", robot_name_OL, codegen_dynpar):
  if FileTools[Exists](invdynfile) then
    read invdynfile:
  else
    printf("%s. Inversdynamik der offenen Kette wurde nicht berechnet. Abbruch der Newton-Euler-Berechnung (Regressorform).\n", \
      FormatTime("%Y-%m-%d %H:%M:%S")):
    quit: # Funktioniert in GUI nicht richtig...
    robot_name := "": # ...Daher auch Löschung des Roboternamens.
  end if:
  tau := Matrix(tau_J(1..NQJ,..)):
  taug := copy(tau):
  for i from 1 to NQ do
    taug := subs({qD_s[i,1]=0},taug):
    taug := subs({qDD_s[i,1]=0},taug):
  end do:
  printf("%s. Generiere Gravitationsvektor und gesamte inverse Dynamik (%s) für %s basierend auf IC-Jacobi und OL-Dynamik mit Parametersatz %d\n", \
    FormatTime("%Y-%m-%d %H:%M:%S"), herleitungsverfahren, robot_name, codegen_dynpar):
fi:
# Ergebnisse der impliziten Zwangsbedingungen laden
read sprintf("../codeexport/%s/tmp/kinconstr_impl_projection_jacobian_maple", robot_name):
B21 := B21:
read sprintf("../codeexport/%s/tmp/kinconstr_impl_projection_jacobian_derivative_maple", robot_name):
B21D := B21D:
# Ergebnisse des Positionsvektors und der aktiven und passiven Gelenke laden
read sprintf("../codeexport/%s/tmp/positionVector_NQJ_maple.m", robot_name):
posNQJ := posNQJ:
# Pertubationsmatrizen berechnen
# Entferne aktive/passive Koordinaten zur Umrechnung
# Berechne die Anzahl aller aktiven und passiven Gelenke (inkl virtueller Schnittgelenke)
NAJ := add(mu(k), k=1..NJ):
NPJ := NJ-NAJ:
# Bestimme Indizes der aktiven und passiven Gelenke
# Entspricht Partitionierung der Gelenkwinkel in q1 und q2 in [Docquier2013]. Hier kann die Reihenfolge von aktiven und passiven Winkeln auch durchmischt sein.
IndAct := Matrix(NAJ, 1):
IndPass:= Matrix(NPJ, 1):
ka := 1: kp := 1:
for i from 1 to NJ do
  if mu(i) = 1 then
    IndAct(ka) := i:
    ka := ka + 1:
  else
    IndPass(kp) := i:
    kp := kp + 1:
  end if:
end do:
# Entfernt die Einträge aus IndPass/IndAct, die virtuelle Schnittglenke sind
for i from 1 to NJ do
  if posNQJ(i) = 0 then
    posAct := ListTools[Search](i, convert(IndAct, list)):
    if posAct <> 0 then
      IndAct := DeleteRow(IndAct,posAct):
    end if:
    #posPass := ListTools[Search](i, convert(IndPass, list)):
    #if posPass <> 0 then
    #  IndPass := DeleteRow(IndPass,posPass):
    #end if:
  end if:
end do:
NQJA := RowDimension(IndAct):
NQJP := NQJ-NQJA: #RowDimension(IndPass):
IndPass:= Matrix(NQJP, 1):
kp := 1: ka := 1:
for i from 1 to NQJ do
  if ListTools[Search](i, convert(IndAct, list)) = 0 then
    IndPass(kp) := i:
    kp := kp + 1:
  end if:
end do:
# Permutationsmatrizen berechnen zur Umrechnung von aufgeteilten Koordinaten
# (aktiv/passiv nacheinander) in Koordinaten der Baumstruktur (aktiv/passiv gemischt)
P1 := Matrix(NQJA,NQJ):
P2 := Matrix(NQJP,NQJ):
for i from 1 to NQJA do
  P1(i,IndAct(i)) := 1:
end do:
for i from 1 to NQJP do
  P2(i,IndPass(i)) := 1:
end do:
# Inverse Dynamik
# explizit [Docquier2013], Gl. 12
W := Transpose(P1 + Transpose(B21).P2):
WD := Transpose(Transpose(B21D).P2):
#q1D_s := Transpose(W).qJD_s:
tauIC := Transpose(W).tau:
taugIC := Transpose(W).taug:
# [DoThanhKotHeiOrt2009b], Gl. (23); [ParkChoPlo1999] Gl. (56)
#tauCCIC := Transpose(W).tauCC + Transpose(W).MM.WD.q1D_s: # noch nicht implementiert
;
tauIC_regressor := P1.tau_regressor_s + Transpose(B21).P2.tau_regressor_s:
if herleitungsverfahren = "newton" then
  tau_MM := copy(tau):
  for i to NQ do
    tau_MM := subs(qD_s[i, 1] = 0,tau_MM);
  end do:

  MM := Matrix(NQJ, NQJ):
  for i to NQJ do
    for j to NQJ do
      MM[i, j] := diff(tau_MM[i, 1], qDD_s[6+j, 1]):
    end do:
  end do:
end if:
# [ParkChoPlo1999], Gl. 55; [DoThanhKotHeiOrt2009b], Gl. (23)
MMIC := Transpose(W).MM.W:
# Export
# Export der Belastung der Gelenke
# Floating Base
if codeexport_invdyn and not(base_method_name="twist") then
  MatlabExport(tauIC, sprintf("../codeexport/%s/tmp/invdyn_floatb_%s_par%d_ic_matlab.m", robot_name, base_method_name, codegen_dynpar), codegen_opt):
end if:
if codeexport_regressor and not(base_method_name="twist") then
  MatlabExport(tauIC_regressor, sprintf("../codeexport/%s/tmp/invdyn_floatb_%s_%s_ic_matlab.m", robot_name, base_method_name, regressor_modus), codegen_opt):
end if:
# Fixed Base
if codeexport_invdyn then
  tauIC_fixb:=tauIC:
  for i from 1 to NQB do
    tauIC_fixb := subs({X_base_s[i,1]=0},tauIC_fixb):
  end do:
  for i from 1 to 6 do
    tauIC_fixb := subs({V_base_s[i,1]=0},tauIC_fixb):
    tauIC_fixb := subs({VD_base_s[i,1]=0},tauIC_fixb):
  end do:
  MatlabExport(tauIC_fixb, sprintf("../codeexport/%s/tmp/invdyn_fixb_par%d_ic_matlab.m", robot_name, codegen_dynpar), codegen_opt):
end if:
if codeexport_grav_inertia then
  taugIC_fixb:=taugIC:
  MMIC_fixb:=MMIC:
  for i from 1 to NQB do
    MMIC_fixb := subs({X_base_s[i,1]=0},MMIC_fixb):
  end do:
  for i from 1 to 6 do
    MMIC_fixb := subs({V_base_s[i,1]=0},MMIC_fixb):
    MMIC_fixb := subs({VD_base_s[i,1]=0},MMIC_fixb):
  end do:
  MatlabExport(taugIC_fixb, sprintf("../codeexport/%s/tmp/gravload_joint_floatb_twist_par%d_ic_matlab.m", robot_name, codegen_dynpar), codegen_opt):
  MatlabExport(MMIC_fixb, sprintf("../codeexport/%s/tmp/inertia_joint_joint_floatb_%s_par%d_ic_matlab.m", robot_name, base_method_name, codegen_dynpar), codegen_opt):
end if:
# Noch nicht implementiert
if codeexport_coriolisvec then
  tauCCIC_fixb:=tauCCIC:
  for i from 1 to NQB do
    tauCCIC_fixb := subs({X_base_s[i,1]=0},tauCCIC_fixb):
  end do:
  for i from 1 to 6 do
    tauCCIC_fixb := subs({V_base_s[i,1]=0},tauCCIC_fixb):
    tauCCIC_fixb := subs({VD_base_s[i,1]=0},tauCCIC_fixb):
  end do:
  MatlabExport(tauCCIC_fixb, sprintf("../codeexport/%s/tmp/coriolisvec_joint_fixb_twist_par%d_ic_matlab.m", robot_name, codegen_dynpar), codegen_opt):
end if:
if codeexport_regressor then
  tauIC_regressor_fixb:=tauIC_regressor:
  for i from 1 to NQB do
    tauIC_regressor_fixb := subs({X_base_s[i,1]=0},tauIC_regressor_fixb):
  end do:
  for i from 1 to 6 do
    tauIC_regressor_fixb := subs({V_base_s[i,1]=0},tauIC_regressor_fixb):
    tauIC_regressor_fixb := subs({VD_base_s[i,1]=0},tauIC_regressor_fixb):
  end do:
  MatlabExport(tauIC_regressor_fixb, sprintf("../codeexport/%s/tmp/invdyn_fixb_%s_ic_matlab.m", robot_name, regressor_modus), codegen_opt):
end if:
if herleitungsverfahren = "newton" then
  tauIC_fixb:=tauIC:
  taugIC_fixb:=taugIC:
  MMIC_fixb:=MMIC:
  for i from 1 to NQB do
    tauIC_fixb := subs({X_base_s[i,1]=0},tauIC_fixb):
    MMIC_fixb := subs({X_base_s[i,1]=0},MMIC_fixb):
  end do:
  for i from 1 to 6 do
    tauIC_fixb := subs({V_base_s[i,1]=0},tauIC_fixb):
    tauIC_fixb := subs({VD_base_s[i,1]=0},tauIC_fixb):
    MMIC_fixb := subs({V_base_s[i,1]=0},MMIC_fixb):
    MMIC_fixb := subs({VD_base_s[i,1]=0},MMIC_fixb):
  end do:
  MatlabExport(tauIC_fixb, sprintf("../codeexport/%s/tmp/invdyn_fixb_snew_par%d_ic_matlab.m", robot_name, codegen_dynpar), codegen_opt):
  MatlabExport(taugIC_fixb, sprintf("../codeexport/%s/tmp/gravload_joint_floatb_twist_snew_par%d_ic_matlab.m", robot_name, codegen_dynpar), codegen_opt):
  MatlabExport(MMIC_fixb, sprintf("../codeexport/%s/tmp/inertia_joint_joint_floatb_%s_snew_par%d_ic_matlab.m", robot_name, base_method_name, codegen_dynpar), codegen_opt):
end if:
# Export Anzahl der aktiven Koordinaten NAJ
MatlabExport(NAJ, sprintf("../codeexport/%s/tmp/NAJ_ic_matlab.m", robot_name), codegen_opt):


# This file sets up the theory of the simplicial category, with simplicial
# maps encoded as lists of values.  This is an alternative to simplicial.mpl,
# where simplicial maps are encoded as tables.  This version is more efficient,
# but suffers from the fact that Maple uses 1-based indexing, so we need a
# lot of extra +1's.

`is_element/simplicial_maps_alt` := (n::nonnegint,m::nonnegint) -> proc(f)
 evalb(type(f,list(nonnegint)) and nops(f) = n+1 and max(op(f)) <= m)
end:

`is_leq/simplicial_maps_alt` := (n::nonnegint,m::nonnegint) -> proc(f,g)
 evalb( min(op(g -~ f)) >= 0 );
end:

# This assumes that
# *  p is a subset of {1,...,n} of size k
# *  q is a subset of {0,...,m} of size k+1
# It returns the nondecreasing map f : {0,...,n} -> {0,...,m} such that
# *  The image of f is q
# * { i > 0 : f(i) > f(i-1) } = p.

`build/simplicial_maps_alt` :=  (n::nonnegint,m::nonnegint) -> proc(k,p,q)
 local pp,i,j,f;
 pp := [0,op(p),n+1];
 f := NULL;
 i := 0;
 for i from 0 to k do
  for j from pp[i+1] to pp[i+2]-1 do
   f := f,q[i+1];
  od;
 od;

 return [f];
end:

`random_element/simplicial_maps_alt` := (n::nonnegint,m::nonnegint) -> proc()
 local p,q,i,j,k,l,f;

 k := rand(0..min(n,m))();
 p := combinat[randcomb](n,k);
 q := combinat[randcomb](m+1,k+1) -~ 1;
 return `build/simplicial_maps_alt`(n,m)(k,p,q);
end:

`list_elements/simplicial_maps_alt` := proc(n::nonnegint,m::nonnegint)
 option remember;
 local i;

 if n = 0 then
  return [seq(`C/simplicial_maps_alt`(0,i),i=0..m)];
 else
  if m = 0 then
   return [`C/simplicial_maps_alt`(n,0)];
  else
   return [op(map(`I/simplicial_maps_alt`(n,m-1),
                   `list_elements/simplicial_maps_alt`(n,m-1))),
           op(map(`T/simplicial_maps_alt`(n-1,m),
	           `list_elements/simplicial_maps_alt`(n-1,m)))];
  fi;
 fi;
end:

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

# Constant maps
`C/simplicial_maps_alt` := proc(n::nonnegint,k::nonnegint)
 [k$(n+1)]
end:

# Inclusion Delta(n,m) -> Delta(n,m+1)
`I/simplicial_maps_alt` := (n::nonnegint,m::nonnegint) -> proc(f)
 f;
end:

# Map Delta(n,m) -> Delta(n+1,m): extend by sending n+1 to m
`T/simplicial_maps_alt` := (n::nonnegint,m::nonnegint) -> proc(f)
 [op(f),m];
end:

# `delta/simplicial_maps_alt`(n)(i) : [n] >-> [n+1]; image omits i
`delta/simplicial_maps_alt` := proc(n::nonnegint,i::nonnegint)
 local j;
 if i > n+1 then return FAIL; fi;
 return [seq(j,j=0..i-1),seq(j+1,j=i..n)];
end:

# `sigma/simplicial_maps_alt`(n)(i) : [n] ->> [n-1]; takes the value i twice
`sigma/simplicial_maps_alt` := proc(n::nonnegint,i::nonnegint)
 local j;
 if i > n-1 then return FAIL; fi;
 return [seq(j,j=0..i),seq(j-1,j=i+1..n)];
end:

`id/simplicial_maps_alt` := proc(n::nonnegint)
 local i;
 return [seq(i=i,i=0..n)];
end:

`eval/simplicial_maps_alt` := (n::nonnegint,m::nonnegint) -> (f) -> (i) -> f[i+1];

# `compose/simplicial_maps`(n,m,p)(f,g) assumes that f:[n] -> [m] and g:[m] -> [p],
# and it returns the composite g o f : [n] -> [p].

`compose/simplicial_maps_alt` := (n::nonnegint,m::nonnegint,p::nonnegint) -> proc(f,g)
 local i;
 [seq(g[f[i+1]+1],i=0..n)];
end:

`is_wide/simplicial_maps_alt` := (n::nonnegint,m::nonnegint) -> proc(f)
 return evalb(f[1] = 0 and f[n+1] = m);
end:

`is_mono/simplicial_maps_alt` := (n::nonnegint,m::nonnegint) -> proc(f)
 evalb(nops({op(f)}) = n+1);
end:

`is_epi/simplicial_maps_alt` := (n::nonnegint,m::nonnegint) -> proc(f)
 local j;
 evalb({op(f)} = {seq(j,j=0..m)});
end:

# This assumes that f : [n] -> [m], and it returns [k,g,h] such that
# g : [n] ->> [k] and h : [k] >-> [m] and f = h o g

`factor/simplicial_maps_alt` := (n::nonnegint,m::nonnegint) -> proc(f)
 local K,k,g,h,hi,i;

 h := sort([op({op(f)})]);
 k := nops(h) - 1;
 hi := table();
 for i from 0 to k do hi[h[i+1]] := i; od;
 g := [seq(hi[f[i+1]],i=0..n)];
 return [k,g,h];
end:

`describe/simplicial_maps_alt` := (n::nonnegint) -> proc(f)
 local i;
 cat(seq(nat_code[f[i]],i=1..n+1));
end:

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

`is_element/simplicial_epi_alt` := (n::nonnegint,m::nonnegint) -> proc(f)
 global reason;

 if not(`is_element/simplicial_maps_alt`(n,m)(f)) then
  reason := [convert(procname,string),"not a simplicial map from [n] to [m]",reason];
  return false;
 fi;

 return `is_epi/simplicial_maps_alt`(n,m)(f);
end:

`is_leq/simplicial_epi_alt` :=  (n::nonnegint,m::nonnegint) -> proc(f,g)
 `is_leq/simplicial_maps_alt`(n,m)(f,g);
end:

`random_element/simplicial_epi_alt` := (n::nonnegint,m::nonnegint) -> proc()
 local p,q,k,f,i;

 if n < m then return FAIL; fi;

 k := m;
 p := combinat[randcomb](n,k);
 q := [seq(i,i=0..m)];
 return `build/simplicial_maps_alt`(n,m)(k,p,q);
end:

`list_elements/simplicial_epi_alt` := proc(n::nonnegint,m::nonnegint)
 local P,L,S,i,j;

 P := combinat[choose]([seq(i,i=1..n)],m);
 L := map(S -> [0$S[1],seq(j$(S[j+1]-S[j]),j=1..m-1),m$(n+1-S[m])],P);

 return L;
end:

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

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

`is_element/simplicial_mono_alt` := (n::nonnegint,m::nonnegint) -> proc(f)
 global reason;

 if not(`is_element/simplicial_maps_alt`(n,m)(f)) then
  reason := [convert(procname,string),"not a simplicial map from [n] to [m]",reason];
  return false;
 fi;

 return `is_mono/simplicial_maps_alt`(n,m)(f);
end:

`is_leq/simplicial_mono_alt` :=  (n::nonnegint,m::nonnegint) -> proc(f,g)
 `is_leq/simplicial_maps_alt`(n,m)(f,g);
end:

`random_element/simplicial_mono_alt` := (n::nonnegint,m::nonnegint) -> proc()
 local p,q,i,j,k,l,f;

 if n > m then return FAIL; fi;

 q := combinat[randcomb](m+1,n+1) -~ 1;
 q := sort([op(q)]);
 return q;
end:

`list_elements/simplicial_mono_alt` := proc(n::nonnegint,m::nonnegint)
 map(q -> q -~ 1,combinat[choose](m+1,n+1));
end:

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


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

# General framework for operads freely generated by a strongly
# reduced Sigma-module.

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

 pn := cat("is_element/Phi/",gen_name);

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

 TT,m := op(TTm);

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

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

 if map(nops,{indices(m)}) <> {1} then
  reason := [pn,"m is not a unidimensional table"];
  return false;
 fi;

 TT1 := map(op,[indices(m)]);

 if {op(TT1)} <> select(T -> nops(T) > 1,TT) then
  reason := [pn,"m is not indexed by the big sets in TT",TT1,TT];
  return false;
 fi;

 C := children_map(A)(TT);

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

 return true;
end;

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

`is_equal/Phi/generic` :=  (gen_name,eq_test) -> (A::set) ->
proc(TTm,UUn)
 local pn,TT,m,UU,n,C,TT1,T;
 global reason;

 pn := cat("is_element/realisation/",poset_name);

 TT,m := op(TTm);
 UU,n := op(UUn);

 if not(`is_equal/full_trees`(A)(TT,UU)) then
  reason := [pn,"TT <> UU",TT,UU];
  return false;
 fi;

 C := children_map(A)(TT);
 TT1 := select(T -> nops(T) > 1,TT);

 for T in TT1 do
  if not(eq_test(C[T])(m[T],n[T])) then
   reason := [pn,"m[T] <> n[T]",T,C[T],m[T],n[T]];
   return false;
  fi;
 od;

 return true;
end;

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

`eta/Phi/generic` := (gen_name) -> (A::set) -> `if`(nops(A) = 1,[{A},table()],FAIL);

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

`gamma/Phi/generic` := (gen_name,action) -> (A::set,B::set) -> (p) -> proc(UUn,TTm)
 local F,FF,UU,UU1,CU,CV,CT,U,U0,Ui,CU0,CU1,TT,T,VV,f,b,m,n,o;

 F := fibres(A,B)(p);
 UU,n := op(UUn);
 CU := children_map(B)(UU);
 FF := table();
 for U in UU do
  FF[U] := `union`(seq(F[b],b in U));
 od;

 TT := table();
 CT := table();
 m := table();

 for b in B do
  TT[b],m[b] := op(TTm[b]);
  CT[b] := children_map(F[b])(TT[b]);
 od;

 VV := `gamma/trees`(A,B)(p)(UU,TT);
 CV := children_map(A)(VV);

 o := table();
 UU1 := select(U -> nops(U) > 1,UU);
 for U in UU do
  Ui := FF[U];
  CU0 := CU[U];
  CU1 := CV[Ui];
  f := table();
  for U0 in CU0 do f[U0] := FF[U0]; od;
  o[Ui] := action(CU0,CU1)(f)(n[U]);
 od;

 for b in B do
  for T in TT[b] do
   if nops(T) > 1 then
    o[T] := m[b](T);
   fi;
  od;
 od;

 return(eval([VV,o]));
end:

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

`zeta/Phi/generic` := (gen_name,action) -> (A::set) -> proc(m)
 local TT,n,f,A1,a;

 if nops(A) = 1 then return(`eta/Phi/generic`(gen_name)(A)); fi;

 TT := corolla(A);
 n := table();
 f := table();
 A1 := {seq({a},a in A)};
 for a in A do f[a] := {a}; od;
 n[A] := action(A,A1)(f)(m);
 return eval([TT,n]);
end:

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

`epsilon/Phi/generic` := (gen_name,eta,gamma) -> (A::set) -> proc(TTm)
 local TT,m;

 TT,m := op(TTm);
 return `theta/Xi/generic`(gen_name,eta,gamma)(A)(TT,corolla(A))(m);
end;


cdir := "/home/scott/Documents/research/software/hqca/hqca/maple/test_cases/":
with(LinearAlgebra): with(ArrayTools): with(QuantumChemistry):
loaddata := readdata(cat(cdir,"tmp7bh4a4ao.rdm"), 8):
Flatten := proc(x) local n, a, i, j, k, l; `local`(a, n, i, j, k, l); `description`("convert chemists to numpy and flatten an array to form a matrix"); n := Size(x); a := Matrix(1 .. n[1]*n[2], 1 .. n[3]*n[4], datatype = float[8]); for i to round(n[1]) do for j to round(n[2]) do for k to round(n[3]) do for l to round(n[4]) do a[(i - 1)*n[1] + j, (k - 1)*n[3] + l] := x[i, j, k, l]; end do; end do; end do; end do; return a; end proc:
New := Array(1 .. 4, 1 .. 4, 1 .. 4, 1 .. 4, datatype = float[8]):
for i in loaddata[3 .. ()] do
    New[round(i[1]), round(i[2]), round(i[3]), round(i[4])] := i[5]:
end do:
Transpose(Re(Eigenvalues(Flatten(New))));
pure := Purify2RDM(New, spin_free = false, electron_number=4, conv_tol = 0.00000000001):
ExportMatrix(cat(cdir, "_temp_purified.csv"), Flatten(pure[rdm2])):


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

`is_element/stasheff_star` := (A::set) -> proc(Rt)
 local R,t,n,JJ,TT,J,u,i,j,k;
 global reason;

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

 R,t := op(Rt);

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

 n := nops(A);
 JJ := {seq(seq({seq(R[k],k=i..j)},j=i..n),i=1..n)};

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

 if map(op,{indices(t)}) <> JJ then
  reason := [convert(procname,string),"t is not indexed by the set of R-intervals",t,R,JJ];
  return false;
 fi;

 TT := NULL;

 for J in JJ do
  u := t[J];

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

  if (nops(J) = 1 and u <> 1) then
   reason := [convert(procname,string),"t[{a}] <> 1",op(J),t[J]];
   return false;
  fi;

  if (nops(J) = 1 or nops(J) = n) and u <> 1 then
   reason := [convert(procname,string),"t[A] <> 1",A,t[J]];
   return false;
  fi;

  if u > 0 then TT := TT,J; fi;
 od;

 TT := {TT};

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

 return true;
end;

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

`is_equal/stasheff_star` := (A::set) -> proc(Rt1,Rt2)
 local R1,R2,t1,t2,n,JJ,J,i,j,k;

 R1,t1 := op(Rt1);
 R2,t2 := op(Rt2);

 if not(`is_equal/ord`(A)(R1,R2)) then
  return false;
 fi;

 n := nops(A);
 JJ := {seq(seq({seq(R1[k],k=i..j)},j=i..n),i=1..n)};

 for J in JJ do
  if t1[J] <> t2[J] then return false; fi;
 od;

 return true;
end:

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

`is_leq/stasheff_star` := NULL;

######################################################################
# Covariant functoriality for bijections p : A -> B.

`act/stasheff_star` := (A::set,B::set) -> (p) -> proc(Rt)
 local R,t,S,u,JJ,J,J1;

 R,t := op(Rt);
 S := map(a -> p[a],R);
 u := table();
 JJ := map(op,[indices(t)]);
 for J in JJ do
  J1 := map(a -> p[a],J);
  u[J1] := t[J];
 od:
 return [S,eval(u)];
end:

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

`random_element/stasheff_star` := (A::set) -> proc()
 local R,t0,JJ0,J0,t,J;

 R := `random_element/ord`(A)();
 t0 := `random_element/standard_stasheff_star`(nops(A))();

 JJ0 := map(op,[indices(t0)]);
 t := table();
 for J0 in JJ0 do
  J := map(i -> R[i],J0);
  t[J] := t0[J0];
 od:

 return [R,eval(t)];
end:

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

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

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

`phi/stasheff_trees/stasheff_star` := (A::set) -> proc(RTT)
 local R,TT,n,JJ,J,t,i,j,k;

 R,TT := op(RTT);

 n := nops(R);
 JJ := {seq(seq({seq(R[k],k=i..j)},j=i..n),i=1..n)};
 t := table();

 for J in JJ do t[J] := 0; od;
 for J in TT do t[J] := 1; od;

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

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

`phi/realisation/stasheff_trees/stasheff_star` := (A::set) -> proc(x)
 local y,C,R,n,JJ,J,RTT,t,TT,z,i,j,k;

 y := table();
 C := map(op,[indices(x)]);
 R := C[1][1];
 n := nops(A);
 JJ := {seq(seq({seq(R[k],k=i..j)},j=i..n),i=1..n)};

 for J in JJ do y[J] := 0; od;

 for RTT in C do
  t := x[RTT];
  TT := RTT[2];
  z := `phi/stasheff_trees/stasheff_star`(A)(TT);
  for J in JJ do y[J] := y[J] + t * z[J]; od;
 od;

 return eval(y);
end:

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

`phi/stasheff_star/ord_simplex_interior` := (A::set) -> proc(Rt)
 local R,t,JJ,JS,Ja,J,K,lambda,mu,a,children;

 R,t := op(Rt);
 JJ := select(J -> t[J] > 0, map(op,{indices(t)}));
 children := `children_map`(A)(JJ);
 JS := sort([op(JJ),(U,V) -> nops(U) < nops(V)]);

 lambda := table();
 for J in JS do
  if nops(J) = 1 then
   lambda[J] := 1;
  else
   lambda[J] := add(lambda[K]^(1-t[K]),K in children[J]);
  fi;
 od;

 mu := table();
 for a in A do
  Ja := select(J -> member(a,J),JJ);
  mu[a] := mul(lambda[J]^(-t[J]),J in Ja);
 od;

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

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

`phi/stasheff_star/one_cubes_prime` := (A::set) -> proc(Rt)
 `phi/ord_simplex_interior/one_cubes_prime`(A)(
  `phi/stasheff_star/ord_simplex_interior`(A)(Rt));
end;

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

`proj/stasheff_star/ord` := (A::set) -> (Rt) -> Rt[1];

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

`describe/stasheff_star` := (A::set) -> proc(Rt)
 local R,t,n,r,i,TT;
 R,t := op(Rt);
 n := nops(A);
 r := table();
 for i from 1 to n do r[R[i]] := i; od:

 TT := map(op,[indices(t)]);
 TT := select(J -> (t[J] > 0 and nops(J) > 1),TT);
 TT := map(J -> [op(J)],TT);
 TT := map(sort,TT,(a,b) -> (r[a] < r[b]));
 TT := sort(TT,(J0,J1) -> (
        (nops(J0) < nops(J1)) or
        ((nops(J0) = nops(J1)) and (r[J0[1]] < r[J1[1]]))));
 return sprintf("%A",map(J -> (J=t[{op(J)}]),TT));
end;


da2 :=
[
    [#(1) filter9 ((1)-(34) are from http://homepages.math.uic.edu/~jan/demo.html)
        [m2*m4*m6 - 1/100,
 a*m4*b - 7/500,
 a**2 + m1**2 - 2/25,
 b**2 + m7**2 - 37/50,
 m3**2 + m5**2 + m4**2 + m2**2 + m6**2 - 9401/10000,
 m4**2*m6**2 + m2**2*m4**2 + m3**2*m6**2 + m2**2*m5**2
 + m3**2*m5**2 + m2**2*m6**2 - 38589/1000000,
 m1*m3*m5*m7 - m6*m1*m3*b + m2*m6*a*b - m2*a*m5*m7 + 81/10000,
 -m1*m2*m3*m4*b - a*m4*m5*m6*m7 + a*m4*b*m6**2 + a*m2**2*m4*b + 39/25000,
 -m4**2*m7**2 - m3**2*m7**2 + 2*m5*m6*b*m7 - m2**2*m7**2 - m5**2*m7**2
- m3**2*b**2 - b**2*m6**2 - m2**2*b**2 + 27173/40000
        ],
        [m1,m2,m3,m4,m5,m6,m7,a,b]
    ],
    [#(2) katsura6
        [ 1*x1+2*x2+2*x3+2*x4+2*x5+2*x6+2*x7-1,
 2*x4*x3+2*x5*x2+2*x6*x1+2*x7*x2-1*x6,
 1*x3^2+2*x4*x2+2*x5*x1+2*x6*x2+2*x7*x3-1*x5,
 2*x3*x2+2*x4*x1+2*x5*x2+2*x6*x3+2*x7*x4-1*x4,
 1*x2^2+2*x3*x1+2*x4*x2+2*x5*x3+2*x6*x4+2*x7*x5-1*x3,
 2*x2*x1+2*x3*x2+2*x4*x3+2*x5*x4+2*x6*x5+2*x7*x6-1*x2,
 1*x1^2+2*x2^2+2*x3^2+2*x4^2+2*x5^2+2*x6^2+2*x7^2-1*x1
        ],
        [x1,x2,x3,x4,x5,x6,x7]
    ],
    [#(3) katsura7
        [-x1+2*x8^2+2*x7^2+2*x6^2+2*x5^2+2*x4^2+2*x3^2+2*x2^2+x1^2,
 -x2+2*x8*x7+2*x7*x6+2*x6*x5+2*x5*x4+2*x4*x3+2*x3*x2+2*x2*x1,
 -x3+2*x8*x6+2*x7*x5+2*x6*x4+2*x5*x3+2*x4*x2+2*x3*x1+x2^2,
 -x4+2*x8*x5+2*x7*x4+2*x6*x3+2*x5*x2+2*x4*x1+2*x3*x2,
 -x5+2*x8*x4+2*x7*x3+2*x6*x2+2*x5*x1+2*x4*x2+x3^2,
 -x6+2*x8*x3+2*x7*x2+2*x6*x1+2*x5*x2+2*x4*x3,
 -x7+2*x8*x2+2*x7*x1+2*x6*x2+2*x5*x3+x4^2,
 -1+2*x8+2*x7+2*x6+2*x5+2*x4+2*x3+2*x2+x1
        ],
        [x1,x2,x3,x4,x5,x6,x7,x8]
    ],
    [#(4) katsura8
        [ -x1+2*x9^2+2*x8^2+2*x7^2+2*x6^2+2*x5^2+2*x4^2+2*x3^2+2*x2^2+x1^2,
 -x2+2*x9*x8+2*x8*x7+2*x7*x6+2*x6*x5+2*x5*x4+2*x4*x3+2*x3*x2+2*x2*x1,
 -x3+2*x9*x7+2*x8*x6+2*x7*x5+2*x6*x4+2*x5*x3+2*x4*x2+2*x3*x1+x2^2,
 -x4+2*x9*x6+2*x8*x5+2*x7*x4+2*x6*x3+2*x5*x2+2*x4*x1+2*x3*x2,
 -x5+2*x9*x5+2*x8*x4+2*x7*x3+2*x6*x2+2*x5*x1+2*x4*x2+x3^2,
 -x6+2*x9*x4+2*x8*x3+2*x7*x2+2*x6*x1+2*x5*x2+2*x4*x3,
 -x7+2*x9*x3+2*x8*x2+2*x7*x1+2*x6*x2+2*x5*x3+x4^2,
 -x8+2*x9*x2+2*x8*x1+2*x7*x2+2*x6*x3+2*x5*x4,
 -1+2*x9+2*x8+2*x7+2*x6+2*x5+2*x4+2*x3+2*x2+x1
        ],
        [x1,x2,x3,x4,x5,x6,x7,x8,x9]
    ],
    [#(5) katsura9
        [ -x1+2*x10^2+2*x9^2+2*x8^2+2*x7^2+2*x6^2+2*x5^2+2*x4^2+2*x3^2+2*x2^2+x1^2,
 -x2+2*x10*x9+2*x9*x8+2*x8*x7+2*x7*x6+2*x6*x5+2*x5*x4+2*x4*x3+2*x3*x2+2*x2*x1,
 -x3+2*x10*x8+2*x9*x7+2*x8*x6+2*x7*x5+2*x6*x4+2*x5*x3+2*x4*x2+2*x3*x1+x2^2,
 -x4+2*x10*x7+2*x9*x6+2*x8*x5+2*x7*x4+2*x6*x3+2*x5*x2+2*x4*x1+2*x3*x2,
 -x5+2*x10*x6+2*x9*x5+2*x8*x4+2*x7*x3+2*x6*x2+2*x5*x1+2*x4*x2+x3^2,
 -x6+2*x10*x5+2*x9*x4+2*x8*x3+2*x7*x2+2*x6*x1+2*x5*x2+2*x4*x3,
 -x7+2*x10*x4+2*x9*x3+2*x8*x2+2*x7*x1+2*x6*x2+2*x5*x3+x4^2,
 -x8+2*x10*x3+2*x9*x2+2*x8*x1+2*x7*x2+2*x6*x3+2*x5*x4,
 -x9+2*x10*x2+2*x9*x1+2*x8*x2+2*x7*x3+2*x6*x4+x5^2,
 -1+2*x10+2*x9+2*x8+2*x7+2*x6+2*x5+2*x4+2*x3+2*x2+x1
        ],
        [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10]
    ],
    [#(6) katsura10
        [ -x1+2*x11^2+2*x10^2+2*x9^2+2*x8^2+2*x7^2+2*x6^2+2*x5^2+2*x4^2+2*x3^2+2*x2^2+x1^2,
 -x2+2*x11*x10+2*x10*x9+2*x9*x8+2*x8*x7+2*x7*x6+2*x6*x5+2*x5*x4+2*x4*x3+2*x3*x2+2*x2*x1,
 -x3+2*x11*x9+2*x10*x8+2*x9*x7+2*x8*x6+2*x7*x5+2*x6*x4+2*x5*x3+2*x4*x2+2*x3*x1+x2^2,
 -x4+2*x11*x8+2*x10*x7+2*x9*x6+2*x8*x5+2*x7*x4+2*x6*x3+2*x5*x2+2*x4*x1+2*x3*x2,
 -x5+2*x11*x7+2*x10*x6+2*x9*x5+2*x8*x4+2*x7*x3+2*x6*x2+2*x5*x1+2*x4*x2+x3^2,
 -x6+2*x11*x6+2*x10*x5+2*x9*x4+2*x8*x3+2*x7*x2+2*x6*x1+2*x5*x2+2*x4*x3,
 -x7+2*x11*x5+2*x10*x4+2*x9*x3+2*x8*x2+2*x7*x1+2*x6*x2+2*x5*x3+x4^2,
 -x8+2*x11*x4+2*x10*x3+2*x9*x2+2*x8*x1+2*x7*x2+2*x6*x3+2*x5*x4,
 -x9+2*x11*x3+2*x10*x2+2*x9*x1+2*x8*x2+2*x7*x3+2*x6*x4+x5^2,
 -x10+2*x11*x2+2*x10*x1+2*x9*x2+2*x8*x3+2*x7*x4+2*x6*x5,
 -1+2*x11+2*x10+2*x9+2*x8+2*x7+2*x6+2*x5+2*x4+2*x3+2*x2+x1
        ],
        [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11]
    ],
    [#(7) utbikker
        [ x^2+x*y+y^2-2*x*z-4*y*z+3*z^2-3*x*t+2*y*t+t^2-3*x-2*y+3*z-2*t-2,
 2*x^2-x*y+y^2-x*z-y*z-6*z^2-x*t+y*t-5*z*t-3*t^2-5*x+y+5*z+2*t+5,
 -3-3*x*y+2*x*z+x*t^2-5*x*z^2-5*z^2*t-3*x*t-2*z*t+x*y*z+x*y*t-x^2*z+x^2
 -y^2+2*z^2+11*z-2*t-x+y+x^3+y^3-3*z^3+2*t^3-3*t^2-5*y^2*z+7*y*z^2,
 -15+2*x*y+11*x*t^2+5*x*z^2-z*t-4*x*y*z+6*x*y*t-x^2*z+3*x^2+2*y^2-z^2+4*z
 -10*t-35*x-14*y-x^3+6*y^3+15*z^3+4*t^3+5*t^2+6*y^2*z+4*y*z^2-x*z*t+6*x^2*y
 -12*x*y^2-7*y^2*t+2*y*t
        ],
        [x,y,z,t]
    ],
    [#(8) kotsireas
        [ (b-d1)*(a-c) - 2*f + 2,
 (b-d1)*(a+c-2*f) + 2*(a-c),
 (b-d1)*(b-d1) - 2*(b+d1) + t + 1,
 a**2*b**3 - 1,
 c**2*d1**3 - 1,
 f**2*t**3 - 1
        ],
        [a,b,c,d1,f,t]
    ],
    [#(9) chandra4
        [ 8*H1 - 051234/100000*H1*(1+(1/2)*H1+(1/3)*H2+(1/4)*H3) - 8,
 8*H2 - 051234/100000*H2*(1+(2/3)*H1+(2/4)*H2+(2/5)*H3) - 8,
 8*H3 - 051234/100000*H3*(1+(3/4)*H1+(3/5)*H2+(3/6)*H3) - 8,
 8*H4 - 051234/100000*H4*(1+(4/5)*H1+(4/6)*H2+(4/7)*H3) - 8
        ],
        [H1,H2,H3,H4]
    ],
    [#(10) chandra5
        [ 10*H1 - 051234/100000*H1*(1+(1/2)*H1+(1/3)*H2+(1/4)*H3+(1/5)*H4) - 10,
 10*H2 - 051234/100000*H2*(1+(2/3)*H1+(2/4)*H2+(2/5)*H3+(2/6)*H4) - 10,
 10*H3 - 051234/100000*H3*(1+(3/4)*H1+(3/5)*H2+(3/6)*H3+(3/7)*H4) - 10,
 10*H4 - 051234/100000*H4*(1+(4/5)*H1+(4/6)*H2+(4/7)*H3+(4/8)*H4) - 10,
 10*H5 - 051234/100000*H5*(1+(5/6)*H1+(5/7)*H2+(5/8)*H3+(5/9)*H4) - 10
        ],
        [H1,H2,H3,H4,H5]
    ],
    [#(11) chandra6
        [ 12*H1 - 051234/100000*H1*(1+(1/2)*H1+(1/3)*H2+(1/4)*H3+(1/5)*H4+(1/6)*H5) - 12,
 12*H2 - 051234/100000*H2*(1+(2/3)*H1+(2/4)*H2+(2/5)*H3+(2/6)*H4+(2/7)*H5) - 12,
 12*H3 - 051234/100000*H3*(1+(3/4)*H1+(3/5)*H2+(3/6)*H3+(3/7)*H4+(3/8)*H5) - 12,
 12*H4 - 051234/100000*H4*(1+(4/5)*H1+(4/6)*H2+(4/7)*H3+(4/8)*H4+(4/9)*H5) - 12,
 12*H5 - 051234/100000*H5*(1+(5/6)*H1+(5/7)*H2+(5/8)*H3+(5/9)*H4+(5/10)*H5) - 12,
 12*H6 - 051234/100000*H6*(1+(6/7)*H1+(6/8)*H2+(6/9)*H3+(6/10)*H4+(6/11)*H5) - 12
        ],
        [H1,H2,H3,H4,H5,H6]
    ],
    [#(12) tangents0
        [x0**2+x1**2+x2**2-1,
x0*x3+x1*x4+x2*x5,
 50*x0**2-2*x0*x4+ 14*x0*x5+x1**2-14*x1*x2+ 2*x1*x3+ 49*x2**2-14*x2*x3+x3**2
+x4**2+x5**2-1,
 29*x0**2-10*x0*x1-4*x0*x2-4*x0*x4+ 10*x0*x5+ 5*x1**2-20*x1*x2+ 4*x1*x3-2*x1
*x5+ 26*x2**2-10*x2*x3+ 2*x2*x4+x3**2+x4**2+x5**2-1,
 9*x0**2-6*x0*x5+ 9*x2**2+ 6*x2*x3+x3**2+x4**2+x5**2-1,
 9*x0**2+ 6*x0*x5+ 9*x2**2-6*x2*x3+x3**2+x4**2+x5**2-1
        ],
        [x0,x1,x2,x3,x4,x5]
    ],
    [#(13) assur44
        [ ca^2+sa^2-1,
 cb^2+sb^2-1,
 cc^2+sc^2-1,
 cd^2+sd^2-1,
 8*cc*cb*ca+8*cc*cb*sa-8*cc*sb*ca+8*cc*sb*sa-8*sc*cb*ca+8*sc*cb*sa-8*sc*
 sb*ca-8*sc*sb*sa+24*cc*cb-24*cc*sb-24*sc*cb-24*sc*sb-16*cb*ca+12*cb*sa-12*sb*ca
-16*sb*sa-4*cc+28*sc-48*cb-36*sb+24*ca+48,
 -8*cd*cb*ca+16*cd*cb*sa-16*cd*sb*ca-8*cd*sb*sa+16*sd*cb*ca+8*sd*cb*sa-8*
sd*sb*ca+16*sd*sb*sa-32*cd*cb+86*cd*sb-86*sd*cb-32*sd*sb+8*cb*ca+12*cb*sa-12*sb
*ca+8*sb*sa+16*cd+28*sd-73*cb+12*sb-28*ca-30*sa+112,
 -980*cd*cb*ca-1960*cd*cb*sa+1960*cd*sb*ca-980*cd*sb*sa-1960*sd*cb*ca+980
*sd*cb*sa-980*sd*sb*ca-1960*sd*sb*sa+280*cc*cb*ca-1400*cc*cb*sa+1400*cc*sb*ca+
280*cc*sb*sa+1400*sc*cb*ca+280*sc*cb*sa-280*sc*sb*ca+1400*sc*sb*sa+6300*cd*cc-
4900*cd*sc+6860*cd*cb+8330*cd*sb-4900*sd*cc-6300*sd*sc-8330*sd*cb+6860*sd*sb+
6860*cc*cb+1540*cc*sb+1540*sc*cb-6860*sc*sb+56*cb*ca+2268*cb*sa-2268*sb*ca+56*
sb*sa-11480*cd+5390*sd-8060*cc+1820*sc-10094*cb-4788*sb+784*ca-1764*sa+19798,
 280*cd*cc-280*sd*sc-336*cd-240*cc+391
        ],
        [ca,cb,cc,cd,sa,sb,sc,sd]
    ],
    [#(14) cyclic9
        [ z0 + z1 + z2 + z3 + z4 + z5 + z6 + z7 + z8,
  z0*z1 + z1*z2 + z2*z3 + z3*z4 + z4*z5 + z5*z6 + z6*z7 + z7*z8 + z8*z0,
  z0*z1*z2 + z1*z2*z3 + z2*z3*z4 + z3*z4*z5 + z4*z5*z6 + z5*z6*z7
+ z6*z7*z8 + z7*z8*z0 + z8*z0*z1,
  z0*z1*z2*z3 + z1*z2*z3*z4 + z2*z3*z4*z5 + z3*z4*z5*z6 + z4*z5*z6*z7
+ z5*z6*z7*z8 + z6*z7*z8*z0 + z7*z8*z0*z1 + z8*z0*z1*z2,
  z0*z1*z2*z3*z4 + z1*z2*z3*z4*z5 + z2*z3*z4*z5*z6 + z3*z4*z5*z6*z7
+ z4*z5*z6*z7*z8 + z5*z6*z7*z8*z0 + z6*z7*z8*z0*z1 + z7*z8*z0*z1*z2
+ z8*z0*z1*z2*z3,
  z0*z1*z2*z3*z4*z5 + z1*z2*z3*z4*z5*z6 + z2*z3*z4*z5*z6*z7 + z3*z4*z5*z6*z7*z8
+ z4*z5*z6*z7*z8*z0 + z5*z6*z7*z8*z0*z1 + z6*z7*z8*z0*z1*z2 + z7*z8*z0*z1*z2*z3
+ z8*z0*z1*z2*z3*z4,
  z0*z1*z2*z3*z4*z5*z6 + z1*z2*z3*z4*z5*z6*z7 + z2*z3*z4*z5*z6*z7*z8
+ z3*z4*z5*z6*z7*z8*z0 + z4*z5*z6*z7*z8*z0*z1 + z5*z6*z7*z8*z0*z1*z2
+ z6*z7*z8*z0*z1*z2*z3 + z7*z8*z0*z1*z2*z3*z4 + z8*z0*z1*z2*z3*z4*z5,
  z0*z1*z2*z3*z4*z5*z6*z7 + z1*z2*z3*z4*z5*z6*z7*z8 + z2*z3*z4*z5*z6*z7*z8*z0
+ z3*z4*z5*z6*z7*z8*z0*z1 + z4*z5*z6*z7*z8*z0*z1*z2 + z5*z6*z7*z8*z0*z1*z2*z3
+ z6*z7*z8*z0*z1*z2*z3*z4 + z7*z8*z0*z1*z2*z3*z4*z5 + z8*z0*z1*z2*z3*z4*z5*z6,
  z0*z1*z2*z3*z4*z5*z6*z7*z8 - 1
        ],
        [z0,z1,z2,z3,z4,z5,z6,z7,z8]
    ],
    [#(15) cyclic10
        [  z0 + z1 + z2 + z3 + z4 + z5 + z6 + z7 + z8 + z9,
  z0*z1 + z1*z2 + z2*z3 + z3*z4 + z4*z5 + z5*z6 + z6*z7 + z7*z8 + z8*z9 + z9*z0,
  z0*z1*z2 + z1*z2*z3 + z2*z3*z4 + z3*z4*z5 + z4*z5*z6 + z5*z6*z7
+ z6*z7*z8 + z7*z8*z9 + z8*z9*z0 + z9*z0*z1,
  z0*z1*z2*z3 + z1*z2*z3*z4 + z2*z3*z4*z5 + z3*z4*z5*z6 + z4*z5*z6*z7
+ z5*z6*z7*z8 + z6*z7*z8*z9 + z7*z8*z9*z0 + z8*z9*z0*z1 + z9*z0*z1*z2,
  z0*z1*z2*z3*z4 + z1*z2*z3*z4*z5 + z2*z3*z4*z5*z6 + z3*z4*z5*z6*z7
+ z4*z5*z6*z7*z8 + z5*z6*z7*z8*z9 + z6*z7*z8*z9*z0 + z7*z8*z9*z0*z1
+ z8*z9*z0*z1*z2 + z9*z0*z1*z2*z3,
  z0*z1*z2*z3*z4*z5 + z1*z2*z3*z4*z5*z6 + z2*z3*z4*z5*z6*z7 + z3*z4*z5*z6*z7*z8
+ z4*z5*z6*z7*z8*z9 + z5*z6*z7*z8*z9*z0 + z6*z7*z8*z9*z0*z1 + z7*z8*z9*z0*z1*z2
+ z8*z9*z0*z1*z2*z3 + z9*z0*z1*z2*z3*z4,
  z0*z1*z2*z3*z4*z5*z6 + z1*z2*z3*z4*z5*z6*z7 + z2*z3*z4*z5*z6*z7*z8
+ z3*z4*z5*z6*z7*z8*z9 + z4*z5*z6*z7*z8*z9*z0 + z5*z6*z7*z8*z9*z0*z1
+ z6*z7*z8*z9*z0*z1*z2 + z7*z8*z9*z0*z1*z2*z3 + z8*z9*z0*z1*z2*z3*z4
+ z9*z0*z1*z2*z3*z4*z5,
  z0*z1*z2*z3*z4*z5*z6*z7 + z1*z2*z3*z4*z5*z6*z7*z8 + z2*z3*z4*z5*z6*z7*z8*z9
+ z3*z4*z5*z6*z7*z8*z9*z0 + z4*z5*z6*z7*z8*z9*z0*z1 + z5*z6*z7*z8*z9*z0*z1*z2
+ z6*z7*z8*z9*z0*z1*z2*z3 + z7*z8*z9*z0*z1*z2*z3*z4 + z8*z9*z0*z1*z2*z3*z4*z5
+ z9*z0*z1*z2*z3*z4*z5*z6,
  z0*z1*z2*z3*z4*z5*z6*z7*z8 + z1*z2*z3*z4*z5*z6*z7*z8*z9
+ z2*z3*z4*z5*z6*z7*z8*z9*z0 + z3*z4*z5*z6*z7*z8*z9*z0*z1
+ z4*z5*z6*z7*z8*z9*z0*z1*z2 + z5*z6*z7*z8*z9*z0*z1*z2*z3
+ z6*z7*z8*z9*z0*z1*z2*z3*z4 + z7*z8*z9*z0*z1*z2*z3*z4*z5
+ z8*z9*z0*z1*z2*z3*z4*z5*z6 + z9*z0*z1*z2*z3*z4*z5*z6*z7,
  z0*z1*z2*z3*z4*z5*z6*z7*z8*z9 - 1
        ],
        [z0,z1,z2,z3,z4,z5,z6,z7,z8,z9]
    ],
    [#(16) cyclic11
        [z0*z1*z2*z3*z4*z5*z6*z7*z8*z9*z10 - 1,
z0 + z1 + z2 + z3 + z4 + z5 + z6 + z7 + z8 + z9 + z10,
z0*z1 + z1*z2 + z2*z3 + z3*z4 + z4*z5 + z5*z6 + z6*z7
+ z7*z8 + z8*z9 + z9*z10 + z10*z0,
z0*z1*z2 + z1*z2*z3 + z2*z3*z4 + z3*z4*z5 + z4*z5*z6 + z5*z6*z7
 + z6*z7*z8 + z7*z8*z9 + z8*z9*z10 + z9*z10*z0 + z10*z0*z1,
z0*z1*z2*z3 + z1*z2*z3*z4 + z2*z3*z4*z5 + z3*z4*z5*z6 + z4*z5*z6*z7
 + z5*z6*z7*z8 + z6*z7*z8*z9 + z7*z8*z9*z10 + z8*z9*z10*z0 + z9*z10*z0*z1
 + z10*z0*z1*z2,
z0*z1*z2*z3*z4 + z1*z2*z3*z4*z5 + z2*z3*z4*z5*z6 + z3*z4*z5*z6*z7
 + z4*z5*z6*z7*z8 + z5*z6*z7*z8*z9 + z6*z7*z8*z9*z10 + z7*z8*z9*z10*z0
 + z8*z9*z10*z0*z1 + z9*z10*z0*z1*z2 + z10*z0*z1*z2*z3,
z0*z1*z2*z3*z4*z5 + z1*z2*z3*z4*z5*z6 + z2*z3*z4*z5*z6*z7
 + z3*z4*z5*z6*z7*z8 + z4*z5*z6*z7*z8*z9 + z5*z6*z7*z8*z9*z10
 + z6*z7*z8*z9*z10*z0 + z7*z8*z9*z10*z0*z1 + z8*z9*z10*z0*z1*z2
 + z9*z10*z0*z1*z2*z3 + z10*z0*z1*z2*z3*z4,
z0*z1*z2*z3*z4*z5*z6 + z1*z2*z3*z4*z5*z6*z7 + z2*z3*z4*z5*z6*z7*z8
 + z3*z4*z5*z6*z7*z8*z9 + z4*z5*z6*z7*z8*z9*z10 + z5*z6*z7*z8*z9*z10*z0
 + z6*z7*z8*z9*z10*z0*z1 + z7*z8*z9*z10*z0*z1*z2 + z8*z9*z10*z0*z1*z2*z3
 + z9*z10*z0*z1*z2*z3*z4 + z10*z0*z1*z2*z3*z4*z5,
z0*z1*z2*z3*z4*z5*z6*z7 + z1*z2*z3*z4*z5*z6*z7*z8 + z2*z3*z4*z5*z6*z7*z8*z9
 + z3*z4*z5*z6*z7*z8*z9*z10 + z4*z5*z6*z7*z8*z9*z10*z0
 + z5*z6*z7*z8*z9*z10*z0*z1 + z6*z7*z8*z9*z10*z0*z1*z2
 + z7*z8*z9*z10*z0*z1*z2*z3 + z8*z9*z10*z0*z1*z2*z3*z4
 + z9*z10*z0*z1*z2*z3*z4*z5 + z10*z0*z1*z2*z3*z4*z5*z6,
z0*z1*z2*z3*z4*z5*z6*z7*z8 + z1*z2*z3*z4*z5*z6*z7*z8*z9
 + z2*z3*z4*z5*z6*z7*z8*z9*z10 + z3*z4*z5*z6*z7*z8*z9*z10*z0
 + z4*z5*z6*z7*z8*z9*z10*z0*z1 + z5*z6*z7*z8*z9*z10*z0*z1*z2
 + z6*z7*z8*z9*z10*z0*z1*z2*z3 + z7*z8*z9*z10*z0*z1*z2*z3*z4
 + z8*z9*z10*z0*z1*z2*z3*z4*z5 + z9*z10*z0*z1*z2*z3*z4*z5*z6
 + z10*z0*z1*z2*z3*z4*z5*z6*z7,
z0*z1*z2*z3*z4*z5*z6*z7*z8*z9 + z1*z2*z3*z4*z5*z6*z7*z8*z9*z10
 + z2*z3*z4*z5*z6*z7*z8*z9*z10*z0 + z3*z4*z5*z6*z7*z8*z9*z10*z0*z1
 + z4*z5*z6*z7*z8*z9*z10*z0*z1*z2 + z5*z6*z7*z8*z9*z10*z0*z1*z2*z3
 + z6*z7*z8*z9*z10*z0*z1*z2*z3*z4 + z7*z8*z9*z10*z0*z1*z2*z3*z4*z5
 + z8*z9*z10*z0*z1*z2*z3*z4*z5*z6 + z9*z10*z0*z1*z2*z3*z4*z5*z6*z7
 + z10*z0*z1*z2*z3*z4*z5*z6*z7*z8
        ],
        [z0,z1,z2,z3,z4,z5,z6,z7,z8,z9,z10]
    ],
    [#(17) simple
        [ x^2,
 x*y,
 y^2
        ],
        [x,y]
    ],
    [#(18) eg1
        [ x**2,
 y**2
        ],
        [x,y]
    ],
    [#(19) eg2
        [ x**2+y**2,
 x-y
        ],
        [x,y]
    ],
    [#(20) eg3
        [ x**2,
 x-y
        ],
        [x,y]
    ],
    [#(21) eg4
        [ x**3,
 x-y
        ],
        [x,y]
    ],
    [#(22) eg5
        [ x**4,
 x-y
        ],
        [x,y]
    ],
    [#(23) baker1
        [ x1**2-x2,
 x1**2+x2
        ],
        [x1,x2]
    ],
    [#(24) cbms1
        [x1**3-x2*x3,
x2**3-x1*x3,
x3**3-x1*x2
        ],
        [x1,x2,x3]
    ],
    [#(25) cbms2
        [ x1**3  - 3*x1**2*x2 + 3*x1*x2**2  - x2**3  - x3**2,
 x3**3  - 3*x3**2*x1 + 3*x3*x1**2  - x1**3  - x2**2,
 x2**3  - 3*x2**2*x3 + 3*x2*x3**2  - x3**3  - x1**2
        ],
        [x1,x2,x3]
    ],
    [#(26) mth191
        [ x^3+y^2+z^2-1,
 x^2+y^3+z^2-1,
 x^2+y^2+z^3-1
        ],
        [x,y,z]
    ],
    [#(27) decker1
        [ x1**3+x1*x2,
 x2**2+x2
        ],
        [x1,x2]
    ],
    [#(28) decker2
        [ x1+x2**3,
 x1**2*x2-x2**4
        ],
        [x1,x2]
    ],
    [#(29) decker3
        [ x1+x2**2,
 15/10*x1*x2+x2**2+x2**3
        ],
        [x1,x2]
    ],
    [#(30) kss3
        [ x1^2 + x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 - 2*x1 - 9,
 x2^2 + x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 - 2*x2 - 9,
 x3^2 + x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 - 2*x3 - 9,
 x4^2 + x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 - 2*x4 - 9,
 x5^2 + x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 - 2*x5 - 9,
 x6^2 + x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 - 2*x6 - 9,
 x7^2 + x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 - 2*x7 - 9,
 x8^2 + x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 - 2*x8 - 9,
 x9^2 + x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 - 2*x9 - 9,
 x10^2 + x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 - 2*x10 - 9
        ],
        [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10]
    ],
    [#(31) ojika1
        [ x**2+y-3,
 x+0125/1000*y**2-15/10
        ],
        [x,y]
    ],
    [#(32) ojika2
        [ x1**2+x2+x3-1,
 x1+x2**2+x3-1,
 x1+x2+x3**2-1
        ],
        [x1,x2,x3]
    ],
    [#(33) ojika3
        [ x1+x2+x3-1,
 02/10*x1**3+05/10*x2**2-x3+05/10*x3**2+05/10,
 x1+x2+05/10*x3**2-05/10
        ],
        [x1,x2,x3]
    ],
    [#(34) ojika4
        [ x1+x3*x1**3+x1*x3*x2**2-x1*x3,
 10*x2-2*x2*x3*x1**2-x3*x2**3-x2*x3,
 -6*x3**2*x1**4-3*x1**2*x2**2*x3**2-x3**2*x1**2+28*x3*x1**2
 -3*x3**2*x2**4+2*x3**2*x2**2+7*x3*x2**2+x3**2-11*x3+10
        ],
        [x1,x2,x3]
    ]
]:


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

op_a1 := 1.5214:
op_a2 := 0.5764:
op_b1 := 1.1284:
op_b2 := 0.3183:

(* This wrapper is to avoid overflows in the OP functionals. The
   energy is not affected, since the value is only changed for
   densities that are screened away.  *)
op_b88_zab := (f_x, rs, z, xs0, xs1) ->
  my_piecewise3(
    b88_zab(1, op_enhancement, rs, z, xs0, xs1) = 0,
    DBL_EPSILON,
    b88_zab(1, op_enhancement, rs, z, xs0, xs1)
  ):

op_beta := (rs, z, xs0, xs1) ->
  op_qab/op_b88_zab(op_enhancement, rs, z, xs0, xs1):

op_f_s := (rs, z, xt, xs0, xs1) ->
  - (1 - z^2)*n_total(rs)/4.0
  * (op_a1*op_beta(rs, z, xs0, xs1) + op_a2)
  / (op_beta(rs, z, xs0, xs1)^4 + op_b1*op_beta(rs, z, xs0, xs1)^3 + op_b2*op_beta(rs, z, xs0, xs1)^2)
:

op_f := (rs, z, xt, xs0, xs1) ->
   my_piecewise3(1 - abs(z) <= p_a_zeta_threshold or (screen_dens(rs,z) and screen_dens(rs,-z)), 0,
                 op_f_s(rs, z_thr(z), xt, xs0, xs1)):

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


`gamma/permutations` := (J) -> proc(s,t)
 local k,i,m,tt;
 k := nops(J);
 i := `+`(op(J));
 tt := [];
 m := 0;
 for i from 1 to k do
  tt := [op(tt),t[i] +~ m];
  m := m + J[i];
 od:
 return [seq(op(tt[s[i]]),i=1..k)];
end:

`eta/permutations` := [1];

`circ/permutations` := (i,m,n) -> proc(s,t)
 local u,p;
 u := NULL;
 for p from 1 to m do
  if s[p] < i then
   u := u,s[p]
  elif s[p] = i then
   u := u , op(t +~ (i - 1));
  else
   u := u,s[p]+n-1;
  fi;
 od;
 return [u];
end:


Digits := 100:
interface(quiet=true):
read "common-procedures.mpl":
with(orthopoly):

mkdir("TEMPTRIG"):

# - Evaluation scheme :
# case 1 : return x
# case 2 (or Fast) : compute a simple polynomial
# case 3 : do an argument reduction...

########################################################
#  Case 1 : Small arguments
# return x for sine and tan, return 1 for cos
########################################################

xmax_return_x_for_sin := 2^(-26):
xmax_return_1_for_cos_RN := sqrt(2^(-53)):
xmax_return_1_for_cos_RDIR:=2^(-26):
one_rounded_down := evalf(1-ulp(1/2)):

xmax_return_x_for_tan := 2^(-27):

########################################################
# Case 2 : simple polynomial approximation
########################################################

# We want to use the same polynomial in case 2 and 3.
# So see after arg red

#################################################
#   Case 3 : Argument reduction
#################################################

#################################################
# CODY and WAITE  Argument reduction

C := Pi/256:
invC:= nearest(1/C):
reminvC := evalf(1/C - invC):
expC:=ieeedouble(C)[2]:
epsinvC := abs(reminvC*C):

# There are three sets of constants :
#  - split redC into two constants, for small values when we are concerned with absolute error
#  - split redC into three constants, for larger values
#  - split redC into three doubles, for the cases when we need
#     good relative precision on the result and fear cancellation

# Fastest reduction using two-part Cody and Waite (up to |k|=2^22)

bitsCh_0:=34:

# 1/2 <= C/2^(expC+1) <1
Ch:= round(evalf(  C * 2^(bitsCh_0-expC-1))) / (2^(bitsCh_0-expC-1)):
# recompute bitsCh in case we are lucky (and we are for bitsCh_0=32)
bitsCh:=1+log2(op(2,ieeedouble(Ch)[3])) :  # this means the log of the denominator

Cl:=nearest(C - Ch):
# Cody and Waite argument reduction will work for |k|<kmax_cw2
kmax_cw2:=2^(53-bitsCh):

# The constants to move to the .h file
RR_CW2_CH := Ch:
RR_CW2_MCL := -Cl:
XMAX_CODY_WAITE_2 := nearest(kmax_cw2*C):

# The error in this case (we need absolute error)
delta_repr_C_cw2   := abs(C-Ch-Cl):
delta_round_cw2    := kmax_cw2* 1/2 * ulp(Cl) :
delta_cody_waite_2 := kmax_cw2 * delta_repr_C_cw2 + delta_round_cw2:
# This is the delta on y, the reduced argument

#log2(%);

# Slower reduction using three-part Cody and Waite, up to |k|=2^31

bitsCh_0:=23: # 22 or 23
Ch:= round(evalf(  C * 2^(bitsCh_0-expC-1))) / (2^(bitsCh_0-expC-1)):
# recompute bitsCh in case we are lucky
bitsCh:=1+log2(op(2,ieeedouble(Ch)[3])) :  # this means the log of the denominator

r := C-Ch:
Cmed := round(evalf(  r * 2^(2*bitsCh-expC-1))) / (2^(2*bitsCh-expC-1)):
bitsCmed:=1+log2(op(2,ieeedouble(Cmed)[3])) :

Cl:=nearest(C - Ch - Cmed):

kmax_cw3 := 2^min(53-bitsCh, 53-bitsCmed, 31):# Otherwise we have integer overflow

# The constants to move to the .h file
RR_CW3_CH  := Ch:
RR_CW3_CM  := Cmed:
RR_CW3_MCL := -Cl:
XMAX_CODY_WAITE_3 := nearest(kmax_cw3*C):

# The error in this case (we need absolute error)
delta_repr_C_cw3   := abs(C - Ch - Cmed - Cl):
delta_round_cw3    := kmax_cw3 * 1/2 * ulp(Cl) :
delta_cody_waite_3 := kmax_cw3 * delta_repr_C_cw3 + delta_round_cw3:
# This is the delta on y, the reduced argument

#log2(%);

# Third range reduction, using double-double arithmetic, for |k| up to 2^51-1

# This max int value can be produced by DOUBLE2LONGINT
kmax:=2^46-1:
XMAX_DDRR:=nearest(kmax*C):

#in this case we have C stored as 3 doubles
Ch   := nearest(C):
Cmed := nearest(C-Ch):
Cl   := nearest(C-Ch-Cmed):

RR_DD_MCH := -Ch:
RR_DD_MCM := -Cmed:
RR_DD_CL  := Cl:

delta_repr_C := abs(C - Ch - Cmed - Cl):

# and we have only exact Add12 and Mul12  operations. The only place
# with possible rounding errors is:
#       Add22 (pyh, pyl,    (x + kch_h) , (kcm_l - kd*RR_DD_CL),   th, tl) ;
# where (x + kch_h) is exact (Sterbenz) with up to kmax bits of cancellation
# and the error is simply the error in  (kcm_l - kd*RR_DD_CL)
# At the very worst :
delta_round :=
              kmax * 1/2 * ulp(Cl) # for   kd*RR_DD_CL
              + kmax*ulp(Cl)         # for the subtraction
              + 2^(-100) * Pi/512 :    # for the Add22
delta_RR_DD :=  kmax * delta_repr_C + delta_round:

#  the last case, Payne and Hanek reduction, gives a very small delta:
#  red arg is on 9*30 bits, then rounded to a double-double (106 bits)
# This should, of course, be optimized some day
delta_PayneHanek := 2^(-100):

# Finally the max delta on the reduced argument is
delta_ArgRed := max(delta_cody_waite_2, delta_cody_waite_3,
                    delta_RR_DD, delta_PayneHanek):

#print("delta_ArgRed to move to the .gappa file = ",  evalf(delta_ArgRed)):
#log2(delta_ArgRed);

# Now we use the above absolute error when k mod 256 <> 0
# otherwise we need to worry about relative accuracy of the result.

# First, what is the worst case for cancellation ?

emax := ieeedouble(XMAX_DDRR)[2] +1 :
# above emax, we will use Payne and Hanek so we do not worry

(wcn, wce, wceps) := WorstCaseForAdditiveRangeReduction(2,53,-8, emax, C):
wcx := wcn * 2^wce:
wck := round(wcx/C):
wcy := wcx - wck*C:

#log2(wcy);   # y > 2^(-67);

# In these cases we use the double-double range reduction, for |k|<kmax_cw3
# and the relative precision in the worst case is for wcy

delta_round := kmax_cw3 * 1/2 * ulp(Cl)      # for   kd*RR_DD_CL
              + kmax_cw3 * ulp(Cl) :         # for the subtraction

delta_RR_DD :=  kmax_cw3 * delta_repr_C + delta_round:

eps_ArgRed := (1+delta_RR_DD/wcy)*(1+2^(-100)) -1:

#log2(eps_ArgRed);

# In all the other cases we use Payne and Hanek, and eps_ArgRed is
# much smaller, so this is the max.

###########
# Polynomials for do_sine and do_cos, and for the case 2
degreeSin := 8:
degreeCos := 7:

maxepsk := (1+epsinvC)*(1+2^(-53))-1:

ymaxCase3  := evalf(Pi/512 + XMAX_DDRR*maxepsk):
#print("ymaxCase3 to move to the .gappa file = ",  ymaxCase3):

y2maxCase3 := ymaxCase3^2:
# These are the parameters that can be varied to fine-tune performance
#   (they should always be larger than Pi/512
xmaxCosCase2   := Pi/256:
xmaxSinCase2   := Pi/256:

x2maxSinCase2:= xmaxSinCase2^2:
x2maxCosCase2:= xmaxCosCase2^2:

# We had the difficulty here to find minimax polynomials which are good for case 2
# as well as for case 3. A simple solution was to set xmaxCosCase2 =ymaxCase3...
# However we found another answer: in the future we intend to use these polynomials for second
# step, too. Therefore, no minimax, only Taylor.

polySin:=  poly_exact(convert( series(sin(x), x=0, degreeSin+1), polynom)):
polyTs := expand(polySin/x-1):
polyTs2 := subs(x=sqrt(y), polyTs):

polyCos  := poly_exact (convert( series(cos(x), x=0, degreeCos+1), polynom)):
polyTc2 := subs(x=sqrt(y), polyCos - 1):

epsApproxSinCase2 := numapprox[infnorm]((x*polyTs+x -sin(x))/sin(x), x=0..xmaxSinCase2):
epsApproxSinCase3 := numapprox[infnorm]((x*polyTs +x -sin(x))/sin(x), x=0..ymaxCase3):

deltaApproxSinCase2 := numapprox[infnorm]((x*polyTs+x -sin(x)), x=0..xmaxSinCase2):
deltaApproxSinCase3 := numapprox[infnorm]((x*polyTs +x -sin(x)), x=0..ymaxCase3):

deltaApproxCosCase2:= numapprox[infnorm](polyCos -  cos(x), x=0..xmaxCosCase2):
deltaApproxCosCase3:= numapprox[infnorm](polyCos -  cos(x), x=0..ymaxCase3):

#print("deltaApproxSinCase3 to move to the .gappa file = ",  deltaApproxSinCase3):
#print("deltaApproxCosCase3 to move to the .gappa file = ",  deltaApproxCosCase3):

########################## Case 2 for sine  ###########################

# evaluate this polynomial in double. The error on x*x is at most half an ulp
errlist:=errlist_quickphase_horner(degree(polyTs2),0,0,2^(-53), 0):
(eps_rounding_Ts, delta_rounding_Ts, minTs, maxTs):=
	compute_horner_rounding_error(polyTs2,y,x2maxSinCase2, errlist, true):

eps_poly_TsCase2 := numapprox[infnorm]((x*polyTs)/(sin(x)-x) -1, x=0..xmaxSinCase2):
maxeps2 := (1+eps_poly_TsCase2)*(1+eps_rounding_Ts)*(1+2^(-53))-1:

maxepstotalSinCase2 := maxeps2 * numapprox[infnorm](1-x/sin(x), x=0..xmaxSinCase2):
rnconstantSinCase2 := evalf(compute_rn_constant(maxepstotalSinCase2)):

##################################### Case2 cos ###########################

# evaluate this polynomial in double. The error on x*x is at most half an ulp
errlist        := errlist_quickphase_horner(degree(polyTc2),0,0,2**(-53), 0):
(eps_rounding_Tc, delta_rounding_Tc, minTc, maxTc):=
              compute_horner_rounding_error(polyTc2,y,x2maxCosCase2, errlist, true):

# Then we have an Add12 which is exact. The result is greater then cos(xmaxCosCase2):
miny := cos(xmaxCosCase2):
maxepstotalCosCase2 :=  (delta_rounding_Tc + deltaApproxCosCase2) / miny :
#log2(%);
rnconstantCosCase2 := evalf(compute_rn_constant(maxepstotalCosCase2)):

######################## Case2 Tangent #########################
#
# Compute the Taylor series
degreeTanCase2 := 12:
xmaxTanCase2   := 2**(-4):
xminTanCase2   := 2**(-30):

Poly_P := convert(series(tan(sqrt(x))/(x^(3/2))-1/x, x=0, degreeTanCase2*4),polynom):
Poly_cheb := numapprox[chebpade](Poly_P, x=xminTanCase2..xmaxTanCase2^2, [degreeTanCase2/2-2,0]):
polyTanCase2 :=  poly_exact2(expand(x + x^3 * subs(x=x^2, Poly_cheb)), 4):

#polyTanCase2 :=  poly_exact2(convert(series(tan(x), x=0, degreeTanCase2), polynom), 4):

maxepsApproxTanCase2:=numapprox[infnorm](1 - polyTanCase2 / tan(x), x=xminTanCase2..xmaxTanCase2):

maxepsOverXTanCase2 :=numapprox[infnorm]((1 - polyTanCase2 / tan(x))/x, x=xminTanCase2..xmaxTanCase2):
# Now we pass these values to Gappa

filename:="TEMPTRIG/TanCase2.sed":
fd:=fopen(filename, WRITE, TEXT):
  t3h, t3l := hi_lo(coeff(polyTanCase2,x,3)):
  fprintf(fd, " s/_t3h/%1.40e/g\n", t3h):
  fprintf(fd, " s/_t3l/%1.40e/g\n", t3l):
  fprintf(fd, " s/_t5/%1.40e/g\n",  coeff(polyTanCase2,x,5)):
  fprintf(fd, " s/_t7/%1.40e/g\n",  coeff(polyTanCase2,x,7)):
  fprintf(fd, " s/_t9/%1.40e/g\n",  coeff(polyTanCase2,x,9)):
  fprintf(fd, " s/_t11/%1.40e/g\n", coeff(polyTanCase2,x,11)):
  fprintf(fd, " s/_xmax/%1.40e/g\n", xmaxTanCase2):
  fprintf(fd, " s/_maxEpsApproxOverX/%1.40e/g\n", maxepsOverXTanCase2*1.00001):
  fprintf(fd, " s/_maxEpsApprox/%1.40e/g\n", maxepsApproxTanCase2*1.00001):
fclose(fd):

printf("\n\n************ DONE TEMPTRIG/TanCase2.sed ************\n");
printf("Now you should use  \n    sed -f TEMPTRIG/TanCase2.sed trigoTanCase2.gappa | gappa  > /dev/null \n");

maxepstotalTanCase2:=4.59602e-19:  # Cut from Gappa output

log2(maxepstotalTanCase2): # almost 61 bits

###############################################################################
#   Computing errors for Case3 : now we have an error due to arg red

# First DoSinZero. The notations are those of the paper proof

# Approximation error already computed above as epsApproxSinCase3;

#  polynomial evaluation in double, with an error on  y*y of epsilonArgRed
errlist:=errlist_quickphase_horner(degree(polyTs2),0,0,eps_ArgRed, 0):
(epsRoundingTsSinZero, deltaRoundingTsSinZero, minTs, maxTs):=
	compute_horner_rounding_error(polyTs2,y,y2maxCase3, errlist, true):

# just as in the paper proof
maxepsSinZero1 := (1+epsApproxSinCase3)*(1+epsRoundingTsSinZero)*(1+2^(-53))*(1+2^(-53))  - 1:

# just as in the paper proof. For x>0 the absolute values are as given

epstotalSinZero :=  ( (x-sin(x))*maxepsSinZero1 + x*eps_ArgRed + 2^(-53)*x^3/3 )  / sin(x):
maxepstotalSinZero := numapprox[infnorm]( epstotalSinZero , x=2^(-30)..ymaxCase3):

printf("\nMax rel error for DoSinZero is %1.5e, if it's smaller than 2^(-66) (%1.5e) then the proof is OK\n\n", maxepstotalSinZero, 2^(-66)):

##############################SinCosCase3############################
  SinCosSize:= 128: # size f the table

# The Gappa files in TEMPTRIG
for i from 1 to SinCosSize/2 do
    filename:=cat("TEMPTRIG/SinACosA_",i,".sed"):
    fd:=fopen(filename, WRITE, TEXT):

    # The table values
    s:=hi_lo(sin(i*Pi/(2*SinCosSize))):
    c:=hi_lo(cos(i*Pi/(2*SinCosSize))):
    fprintf(fd, " s/_cah/%1.40e/g\n", c[1]):
    fprintf(fd, " s/_cal/%1.40e/g\n", c[2]):
    fprintf(fd, " s/_sah/%1.40e/g\n", s[1]):
    fprintf(fd, " s/_sal/%1.40e/g\n", s[2]):

    # The polynomial coefficients
    fprintf(fd, " s/_s3/%1.40e/g\n", coeff(polySin,x,3)):
    fprintf(fd, " s/_s5/%1.40e/g\n", coeff(polySin,x,5)):
    fprintf(fd, " s/_s7/%1.40e/g\n", coeff(polySin,x,7)):
    fprintf(fd, " s/_s9/%1.40e/g\n", coeff(polySin,x,9)):
    fprintf(fd, " s/_c2/%1.40e/g\n", coeff(polyCos,x,2)):
    fprintf(fd, " s/_c4/%1.40e/g\n", coeff(polyCos,x,4)):
    fprintf(fd, " s/_c6/%1.40e/g\n", coeff(polyCos,x,6)):
    fprintf(fd, " s/_c8/%1.40e/g\n", coeff(polyCos,x,8)):

    # The approximation errors
    fprintf(fd, " s/_ymaxCase3/%1.40e/g\n", ymaxCase3*1.00001):
    fprintf(fd, " s/_delta_ArgRed/%1.40e/g\n", delta_ArgRed*1.00001):
    fprintf(fd, " s/_delta_approx_Sin_Case3/%1.40e/g\n", deltaApproxSinCase3*1.00001):
    fprintf(fd, " s/_delta_approx_Cos_Case3/%1.40e/g\n", deltaApproxCosCase3*1.00001):

    fclose(fd):
od:

printf("************ DONE TEMPTRIG/*.sed ************\n"):

# A shell script to use them
filename:="../gappa/run-trigo-proof.sh":
fd:=fopen(filename, WRITE, TEXT):
fprintf(fd, "#!/bin/sh\n"):
fprintf(fd, "# You probably need to edit the path to the gappa executable\n"):
fprintf(fd, "for file in ../maple/TEMPTRIG/SinACosA*.sed  \n"):
fprintf(fd, "do\n"):
fprintf(fd, "  echo $file:\n"):
fprintf(fd, "  sed -f  $file  trigoSinCosCase3.gappa | ~/gappa/src/gappa\n"):
fprintf(fd, "  echo\n"):
fprintf(fd, "done\n"):
fclose(fd):

printf("************ DONE trigo_test.sh ************\n"):
printf("To run the Gappa proof, you should go to the gappa directory and run\n"):
printf(" sh run-trigo-proof.sh 2> ../maple/TEMPTRIG/Gappa.out\n"):

printf("Then look at maple/TEMPTRIG/Gappa.out. It shouldn't contain 'No proof'.\n This means that everything is OK and the rounding constants in TEMPTRIG/trigo_fast.h are proven upper bounds.\n\n"):

#  This value has been validated by Gappa (using all the previous)
maxepstotalSinCosCase3:=3*2^(-66):
rnconstantSinCosCase3 := evalf(compute_rn_constant(maxepstotalSinCosCase3)):

# The error of sin, the error of cos, then the error of Div22
maxepstotalTanCase3:= 2.1*maxepstotalSinCosCase3:
rnconstantTanCase3 := evalf(compute_rn_constant(maxepstotalTanCase3)):

##############################################
## Compute constants for SCS arg red
oldDigits:=Digits:
Digits:=1000:
# for 2/Pi:
n:=round(2^(30*48)*evalf(2/Pi)):
digitlist:=[]:
for i from 1 to 48 do
  r:=n mod (2^30):
  n:=floor(n/(2^30)):
  hexstring:= convert(convert(r,hex),string):
  digitlist:=[hexstring, op(digitlist)]:
end:
digitlist:

# for 256/Pi:
n:=round(2^(30*47)*evalf(256/Pi)):
digitlist:=[]:
for i from 1 to 48 do
  r:=n mod (2^30):
  n:=floor(n/(2^30)):
  hexstring:= convert(convert(r,hex),string):
  digitlist:=[hexstring, op(digitlist)]:
end:
digitlist:
Digits:=oldDigits:

# an auxiliary output function:
# Outputs the high part of a double, and the double in comment.
# As all these high parts are used in code as
# if(absxhi < XMAX_COS_CASE2)
# we have to remove one LSB to the high part, or, divide var by
# (1+2^(-20))
# Now we have absxhi<highpart(var/(1+2^(-20))
# => absxhi*(1+2^(-20))<var
# => x<var
outputHighPart:=proc(cvarname, var)
  local varMinusLSB:
  Digits:=8:
  varMinusLSB:=var/(1+2^(-20)):
  ("#define " || cvarname || " 0x" || (ieeehexa(varMinusLSB)[1])
    ||  "        /* " || (convert(evalf(varMinusLSB),string)) ||  " */" )
end proc:

# Output:

filename:="TEMPTRIG/trigo_fast.h":
fd:=fopen(filename, WRITE, TEXT):

fprintf(fd, "#include \"crlibm.h\"\n#include \"crlibm_private.h\"\n"):

fprintf(fd, "\n/*File generated by maple/trigo.pl*/\n"):
fprintf(fd, "\n"):

fprintf(fd,  "%s\n",  outputHighPart("XMAX_RETURN_X_FOR_SIN", xmax_return_x_for_sin) ):
fprintf(fd,  "%s\n",  outputHighPart("XMAX_SIN_CASE2        ", xmaxSinCase2) ):

fprintf(fd,  "%s\n",  outputHighPart("XMAX_RETURN_1_FOR_COS_RN", xmax_return_1_for_cos_RN) ):
fprintf(fd,  "%s\n",  outputHighPart("XMAX_RETURN_1_FOR_COS_RDIR", xmax_return_1_for_cos_RDIR) ):
fprintf(fd,  "%s\n",  outputHighPart("XMAX_COS_CASE2        ", xmaxCosCase2) ):

fprintf(fd,  "%s\n",  outputHighPart("XMAX_RETURN_X_FOR_TAN", xmax_return_x_for_tan) ):
fprintf(fd,  "%s\n",  outputHighPart("XMAX_TAN_CASE2        ", xmaxTanCase2) ):

fprintf(fd, "\n"):
fprintf(fd, "#define ONE_ROUNDED_DOWN  %1.25e \n", one_rounded_down):
fprintf(fd, "\n"):

fprintf(fd, "#define EPS_SIN_CASE2     %1.25e \n", maxepstotalSinCase2):
fprintf(fd, "#define RN_CST_SIN_CASE2  %1.25f \n", rnconstantSinCase2):
fprintf(fd, "\n"):
fprintf(fd, "#define EPS_COS_CASE2     %1.25e \n", maxepstotalCosCase2):
fprintf(fd, "#define RN_CST_COS_CASE2  %1.25f \n", rnconstantCosCase2):
fprintf(fd, "\n"):
fprintf(fd, "#define EPS_SINCOS_CASE3     %1.25e \n", maxepstotalSinCosCase3):
fprintf(fd, "#define RN_CST_SINCOS_CASE3  %1.25f \n", rnconstantSinCosCase3):
fprintf(fd, "\n"):
fprintf(fd, "#define EPS_TAN_CASE2     %1.25e \n", maxepstotalTanCase2):
fprintf(fd, "#define EPS_TAN_CASE3     %1.25e \n", maxepstotalTanCase3):
fprintf(fd, "#define RN_CST_TAN_CASE3  %1.25f \n", rnconstantTanCase3):

fprintf(fd, "\n"):

fprintf(fd, "#define INV_PIO256        %1.25f \n", 1/C):
fprintf(fd, "\n"):

fprintf(fd,  "%s\n",  outputHighPart("XMAX_CODY_WAITE_2", XMAX_CODY_WAITE_2) ):
fprintf(fd,  "%s\n",  outputHighPart("XMAX_CODY_WAITE_3", XMAX_CODY_WAITE_3) ):
fprintf(fd,  "%s\n",  outputHighPart("XMAX_DDRR        ", XMAX_DDRR) ):
#fprintf(fd,  "%s\n",  outputHighPart("", ) ):
fprintf(fd, "\n"):

fprintf(fd, "#define RR_CW2_CH  %1.25e\n", RR_CW2_CH):
fprintf(fd, "#define RR_CW2_MCL %1.25e\n", RR_CW2_MCL):
fprintf(fd, "\n"):

fprintf(fd, "#define RR_CW3_CH  %1.25e\n", RR_CW3_CH):
fprintf(fd, "#define RR_CW3_CM  %1.25e\n", RR_CW3_CM):
fprintf(fd, "#define RR_CW3_MCL %1.25e\n", RR_CW3_MCL):
fprintf(fd, "\n"):

fprintf(fd, "#define RR_DD_MCH  %1.25e\n", RR_DD_MCH):
fprintf(fd, "#define RR_DD_MCM  %1.25e\n", RR_DD_MCM):
fprintf(fd, "#define RR_DD_CL   %1.25e\n", RR_DD_CL):
fprintf(fd, "\n"):

fprintf(fd, "\n"):

  fprintf(fd, "\n\n"):

  # The 256/Pi SCS array
  fprintf(fd, "static const int digits_256_over_pi[] = \n{"):
  for i from 0 to 11 do
    for j from 1 to 4 do
      fprintf(fd, " 0x%s,  \t",digitlist[4*i+j]):
    end:
    fprintf(fd, "\n "):
  end:
  fprintf(fd, "};\n\n"):

  # The Pi/256 SCS constant
  fprintf(fd, "static const scs Pio256=\n"):
  WriteSCS(fd, evalf(C)):
  fprintf(fd, ";\n#define Pio256_ptr  (scs_ptr)(& Pio256)\n\n"):

fprintf(fd,"#ifdef WORDS_BIGENDIAN\n"):
for isbig from 1 to 0 by -1 do

  if(isbig=0) then
    fprintf(fd,"#else\n"):
  fi:

  # The sine polynomial

  fprintf(fd, "static db_number const s3 = "):
  printendian(fd, coeff(polySin,x,3), isbig):
  fprintf(fd, ";\n"):
  fprintf(fd, "static db_number const s5 = "):
  printendian(fd, coeff(polySin,x,5), isbig):
  fprintf(fd, ";\n"):
  fprintf(fd, "static db_number const s7 = "):
  printendian(fd, coeff(polySin,x,7), isbig):
  fprintf(fd, ";\n\n"):

  # the cos polynomial

  fprintf(fd, "static db_number const c2 = "):
  printendian(fd, coeff(polyCos,x,2), isbig):
  fprintf(fd, ";\n"):
  fprintf(fd, "static db_number const c4 = "):
  printendian(fd, coeff(polyCos,x,4), isbig):
  fprintf(fd, ";\n"):
  fprintf(fd, "static db_number const c6 = "):
  printendian(fd, coeff(polyCos,x,6), isbig):
  fprintf(fd, ";\n\n"):

  # the tan polynomial

  t3h, t3l := hi_lo(coeff(polyTanCase2,x,3)):
  fprintf(fd, "static db_number const t3h = "):
  printendian(fd, t3h, isbig):
  fprintf(fd, ";\n"):
  fprintf(fd, "static db_number const t3l = "):
  printendian(fd, t3l, isbig):
  fprintf(fd, ";\n"):
  fprintf(fd, "static db_number const t5 = "):
  printendian(fd, coeff(polyTanCase2,x,5), isbig):
  fprintf(fd, ";\n"):
  fprintf(fd, "static db_number const t7 = "):
  printendian(fd, coeff(polyTanCase2,x,7), isbig):
  fprintf(fd, ";\n"):
  fprintf(fd, "static db_number const t9 = "):
  printendian(fd, coeff(polyTanCase2,x,9), isbig):
  fprintf(fd, ";\n"):
  fprintf(fd, "static db_number const t11 = "):
  printendian(fd, coeff(polyTanCase2,x,11), isbig):
  fprintf(fd, ";\n\n"):

  # The sincos table

  fprintf(fd, "\n/*  sine and cos of kPi/256 in double-double */\n"):
  fprintf(fd, "static db_number const sincosTable[%d] =\n{\n",  4*(SinCosSize/2+1)):
  for i from 0 to SinCosSize/2 do
      s:=hi_lo(sin(i*Pi/(2*SinCosSize))):
      c:=hi_lo(cos(i*Pi/(2*SinCosSize))):
      printendian(fd,s[1],isbig):
      fprintf(fd," ,\n"):
      printendian(fd,s[2],isbig):
      fprintf(fd," ,\n"):
      printendian(fd,c[1],isbig):
      fprintf(fd," ,\n"):
      printendian(fd,c[2],isbig):
    if i<SinCosSize-1 then fprintf(fd," ,\n"): fi:
  od:
  fprintf(fd, "\n};\n\n"):

od:
fprintf(fd,"#endif /* WORDS_BIGENDIAN */\n\n\n"):

fclose(fd):

printf("\n\n************ DONE TEMPTRIG/trigo_fast.h ************\n Copy it to the crlibm source directory.\n\n");

#################################################
# Stuff for the accurate phase,
#
# Should very bad cases be found in the future, only the degrees below
# should  be increased, then this script rerun. Everything should
# compile OK with the newly generated trigo_accurate.h

printf("\n-------------------------------------------------------\n"):
printf("--------------------Accurate phase---------------------\n"):
printf("-------------------------------------------------------\n"):

xminSCS   := 0:
xmaxSCS   := Pi/4:

#-----------------Sine-----------------------
degreeSinSCS := 26:
Poly_P := convert(series(sin(sqrt(x))/(x^(3/2))-1/x, x=0, degreeSinSCS*4),polynom):
Poly_cheb := numapprox[chebpade](Poly_P, x=xminSCS..xmaxSCS^2, [degreeSinSCS/2-2,0]):
polySinSCS :=  poly_exact_SCS(expand(x + x^3 * subs(x=x^2, Poly_cheb))):

DEGREE_SIN_SCS := degree(polySinSCS):
maxepsApproxSinSCS:=numapprox[infnorm](1 - polySinSCS/sin(x), x=xminSCS..xmaxSCS):
printf("The sine polynomial for the second phase (degree %d) is accurate to %f bits on O..Pi/4\n", DEGREE_SIN_SCS, -log2(maxepsApproxSinSCS)):
# For the proof of the very bad cases, near zero
maxepsApproxSinSCSNearZero:=numapprox[infnorm](1 - polySinSCS/sin(x), x=0..2^(-17)):
printf("  ... and  accurate to %f bits on O..2^(-17)\n", -log2(maxepsApproxSinSCSNearZero)):

#-----------------Cos-----------------------
degreeCosSCS := 28:
Poly_P := convert(series((cos(sqrt(x)) -1)/x, x=0, degreeCosSCS*4),polynom):
Poly_cheb := numapprox[chebpade](Poly_P, x=xminSCS..xmaxSCS^2, [degreeCosSCS/2-2,0]):
polyCosSCS :=  poly_exact_SCS(expand(1 + x^2 * subs(x=x^2, Poly_cheb))):
DEGREE_COS_SCS := degree(polyCosSCS):

maxepsApproxCosSCS:=numapprox[infnorm](1 - polyCosSCS/cos(x), x=xminSCS..xmaxSCS):
printf("The cos polynomial for the second phase (degree %d) is accurate to %f bits on O..Pi/4\n", degree(polyCosSCS), -log2(maxepsApproxCosSCS)):
# For the proof of the very bad cases, near zero
maxepsApproxCosSCSNearZero:=numapprox[infnorm](1 - polyCosSCS/cos(x), x=0..2^(-18)):
printf("  ... and  accurate to %f bits on O..2^(-18)\n", -log2(maxepsApproxCosSCSNearZero)):

#-----------------Tan-----------------------
degreeTanSCS := 70:
Poly_P := convert(series(tan(sqrt(x))/(x^(3/2))-1/x, x=0, degreeTanSCS*4),polynom):
Poly_cheb := numapprox[chebpade](Poly_P, x=xminSCS..xmaxSCS^2, [degreeTanSCS/2-2,0]):
polyTanSCS :=  poly_exact_SCS(expand(x + x^3 * subs(x=x^2, Poly_cheb))):

DEGREE_TAN_SCS := degree(polyTanSCS):
maxepsApproxTanSCS:=numapprox[infnorm](1 - polyTanSCS/tan(x), x=xminSCS..xmaxSCS):
printf("The tan polynomial for the second phase (degree %d) is accurate to %f bits on O..Pi/4\n", DEGREE_TAN_SCS, -log2(maxepsApproxTanSCS)):
# For the proof of the very bad cases, near zero
maxepsApproxTanSCSNearZero:=numapprox[infnorm](1 - polyTanSCS/tan(x), x=0..2^(-17)):
printf("  ... and  accurate to %f bits on O..2^(-17)\n", -log2(maxepsApproxTanSCSNearZero)):

filename:="TEMPTRIG/trigo_accurate.h":
fd:=fopen(filename, WRITE, TEXT):
fprintf(fd, "/*File generated by maple/trigo.mpl*/\n\n"):
fprintf(fd, "#include \"crlibm.h\"\n#include \"crlibm_private.h\"\n\n"):
fprintf(fd, "#define DEGREE_SIN_SCS  %d \n", DEGREE_SIN_SCS):
fprintf(fd, "#define DEGREE_COS_SCS  %d \n", DEGREE_COS_SCS):
fprintf(fd, "#define DEGREE_TAN_SCS  %d \n", DEGREE_TAN_SCS):
fprintf(fd, "\n"):
fprintf(fd, "#define  sin_scs_poly_ptr (scs_ptr)&sin_scs_poly \n"):
fprintf(fd, "#define  cos_scs_poly_ptr (scs_ptr)&cos_scs_poly \n"):
fprintf(fd, "#define  tan_scs_poly_ptr (scs_ptr)&tan_scs_poly \n"):
fprintf(fd, "\n"):
Write_SCS_poly(fd, sin_scs_poly, polySinSCS):
fprintf(fd, "\n\n"):
Write_SCS_poly(fd, cos_scs_poly, polyCosSCS):
fprintf(fd, "\n\n"):
Write_SCS_poly(fd, tan_scs_poly, polyTanSCS):
fprintf(fd, "\n"):
fclose(fd):

printf("\n\n************ DONE TEMPTRIG/trigo_accurate.h ************\n Copy it to the crlibm source directory.\n\n");


sgn := proc(s) local i,j; signum(mul(mul(s[j] - s[i],j=i+1..nops(s)),i=1..nops(s))); end:

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

is_table_on := (A::set) -> proc(x)
 if not(type(x,table)) then return false; fi;
 if {indices(x)} <> map(a -> [a],A) then
  return false;
 fi;

 return true;
end:

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

# Return a randomly selected element of a finite set A

random_element_of := proc(A)
 local n,i;

 if not type(A,list) and not type(A,set) then
  error("A is not a list or set");
 fi;

 n := nops(A);

 if n = 0 then
  error("A is empty");
 fi;

 i := rand(1..n)();
 return A[i];
end:

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

# Return a randomly selected element of a finite set A

random_subset_of := proc(A,size_::nonnegint)
 local n,i,U,V,r,x;

 if not type(A,list) and not type(A,set) then
  error("A is not a list or set");
 fi;

 n := nops(A);

 if nargs = 1 then
  r := rand(2);
  V := select(a -> (r() = 1),{op(A)});
  return V;
 else
  if size_ > n then
   return FAIL;
  fi;
  U := {op(A)};
  V := {};
  for i from 0 to size_-1 do
   x := U[rand(1..(n-i))()];
   U := U minus {x};
   V := V union {x};
  od:
  return V;
 fi;
end:

random_nonempty_subset_of := proc(A)
 local n,k,B;

 if not type(A,list) and not type(A,set) then
  error("A is not a list or set");
 fi;

 n := nops(A);
 if n = 0 then error("A is empty"); fi;
 k := rand(1..n)();
 B := combinat[randcomb](A,k);
 return B;
end:

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

# This function converts small numbers to single-character strings,
# which is convenient in some circumstances when we need to display
# a large number of small numbers.
#
#  0 ..  9 become "0" to "9"
# 10 .. 35 become "A" to "Z"
# 36 .. 61 become "a" to "z"

nat_code := table([
 seq(i = convert([48+i],bytes),i=0..9),
 seq(i = convert([65+i-10],bytes),i=10..35),
 seq(i = convert([97+i-36],bytes),i=36..61)
]);

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

# Return a list of pairs [p[i],v[i]] such that the p[i] are distinct
# primes in increasing order, the v[i] are nonzero integers, and
# n is the product of the p[i]^v[i].  The real work is done by Maple's
# ifactor() function, we just convert the result to a more convenient
# form.

ifactor_list := proc(n::rational)
 local u;
 if n = 0 then
  error("Cannot factor zero");
 fi;
 u := ifactor(abs(n));
 if type(u,`*`) then
  u := [op(u)];
 else
  u := [u];
 fi;
 u := map(x -> `if`(type(x,`^`),[op(op(1,x)),op(2,x)],[op(x),1]),u);
 return u;
end:

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

# Return true iff n = p^k for some prime p and integer k >= 0.

is_prime_power := proc(n::posint)
 not(type(ifactor(n),`*`));
end:

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

# Return the p-adic valuation of m.

padic_val := proc(m::rational,p)
 local k,l;
 if m = 0 then return infinity; fi;
 if denom(m) <> 1 then
  return padic_val(numer(m),p) - padic_val(denom(m),p);
 fi;
 k := 0;
 l := m;
 while irem(l,p,'l') = 0 do k := k+1; od:
 return k;
end:

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

# Return the list of the base p digits of n, least significant first.

digit_list := proc(n::nonnegint,p::posint)
 local L,m;
 L := NULL;
 m := n;
 while m > 0 do
  L := L,irem(m,p);
  m := iquo(m,p);
 od:
 return [L];
end:

# Return the sum of the base p digits of n.

digit_sum := (n::nonnegint,p::posint) -> `+`(0,op(digit_list(n,p)));

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

# If u is an algebraic expression with an overall minus sign, then
# remove the mius sign.

strip_sign := proc(u)
 if type(u,list) or type(u,set) then
  return map(strip_sign,u);
 elif type(u,`*`) then
  return map(x -> `if`(type(x,numeric),abs(x),x),u);
 else
  return u;
 fi;
end:

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

# Given a Grobner basis such that the corresponding quotient ring is
# finite-dimensional, return the usual basis for that quotient.

cobasis := proc(basis,vars)
 local lm_basis,B,B0,V,b,i,v;

 lm_basis := map(u -> LeadingMonomial(u,vars), basis);
 B := [1];
 V := [op(vars)];
 for v in V do
  B0 := B;
  B := NULL;
  for b in B0 do
   i := 0;
   while NormalForm(b*v^i,lm_basis,vars) <> 0 do
    B := B,b*v^i;
    i := i+1;
   od:
  od:
  B := [B];
 od:
 return B;
end:

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

# Returns the set of monomials occuring in u

monomials := proc(u)
 if type(u,`+`) or type(u,list) or type(u,set) then
  return map(op,map(monomials,{op(u)}));
 elif type(u,`*`) then
  return {remove(type,u,constant)};
 elif type(u,constant) then
  return {1};
 else
  return {u};
 fi;
end:

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

# Returns the coefficient in u of the monomial m.
# If u involves variables that do not occur in m, then these will
# be included in the coefficient.

multi_coeff := proc(u,m)
 local c,x;
 c := u;
 for x in indets(m) do
  c := coeff(c,x,degree(m,x));
 od;
 return c;
end:

coeff_list := (u,mm) -> map2(multi_coeff,u,mm);

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

# This function returns a pair [d,q], where d is the gcd of the integers
# in u, and q is a list of integers such that the sum of the terms
# q[i] * u[i] is equal to d.  Moreover, q is the unique such list with
# 0 <= q[i] < d[i]/d[i-1] for i = 2,...,n, where d[i] is the gcd of
# u[1],...,u[i].  Note that there is no bound on q[1], which will
# typically be large and negative.

igcd_alt := proc(u::list(posint))
 local n,d,e,v,s,t,p,q,m,i;
 n := nops(u);
 d := table():
 e := table():
 v := table():
 d[1] := u[1];
 for i from 2 to nops(u) do
  d[i] := igcdex(d[i-1],u[i],s[i],t[i]);
  e[i-1] := d[i-1]/d[i];
  v[i] := u[i]/d[i];
 od:
 e[n] := d[n];

 p[n] := s[n];
 q[n] := t[n];
 m := iquo(q[n],e[n-1]);
 q[n] := q[n] - m*e[n-1];
 p[n] := p[n] + m*v[n];

 for i from n-1 to 2 by -1 do
  p[i] := s[i]*p[i+1];
  q[i] := t[i]*p[i+1];
  m := floor(q[i]/e[i-1]);
  q[i] := q[i] - m*e[i-1];
  p[i] := p[i] + m*v[i];
 od;

 q[1] := p[2];
 return [d[n],[seq(q[i],i=1..n)]];
end:

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

# Permutation matrix
# (duplicated in groups/general_linear.mpl)

perm_matrix := proc(s)
 local n,M,i;
 n := nops(s);
 M := Matrix(n,n);
 for i from 1 to n do
  M[s[i],i] := 1;
 od:
 return M;
end:

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

# Return u, but with all tiny numerical constants converted to 0.

trim := proc(u,epsilon := 10.^(-90))
 local c,v;
 if type(u,`+`) or type(u,list) or type(u,set) or type(u,Matrix) or type(u,Vector) then
  return map(trim,u,epsilon);
 elif type (u,`*`) then
  c,v := selectremove(type,u,complex(numeric));
  if abs(Re(c)) < epsilon then c := Im(c) * I; fi;
  if abs(Im(c)) < epsilon then c := Re(c); fi;
  return c * v;
 elif type(u,complex(numeric)) then
  c := u;
  if abs(Re(c)) < epsilon then c := Im(c) * I; fi;
  if abs(Im(c)) < epsilon then c := Re(c); fi;
  return c;
 else
  return u;
 fi;
end:

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

symmetric_difference := (A,B) ->
 {op(A),op(B)} minus ({op(A)} intersect {op(B)});

is_all_zero := proc(x)
 if type(x,{list,set}) then
  return `and`(op(map(is_all_zero,x)));
 elif type(x,Vector) then
  return is_all_zero(convert(x,list));
 elif type(x,Matrix) then
  return is_all_zero(convert(x,listlist));
 else
  return evalb(x = 0);
 fi;
end:

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

is_all_zero := proc(x)
 if type(x,{list,set}) then
  return `and`(op(map(is_all_zero,x)));
 elif type(x,Vector) then
  return is_all_zero(convert(x,list));
 elif type(x,Matrix) then
  return is_all_zero(convert(x,listlist));
 else
  return evalb(x = 0);
 fi;
end:

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

make_index := proc(L::{list,Vector})
 local L0,T,i;

 L0 := L;
 if type(L0,Vector) then L0 := convert(L0,list); fi;

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

 return eval(T);
end:

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

sum_terms := proc(x)
 if x = 0 then
  return [];
 elif type(x,`+`) then
  return [op(x)];
 else
  return [x];
 fi;
end;

coeff_split := proc(x,T := integer)
 if type(x,T) then
  return [x,1];
 elif type(x,`*`) then
  return [selectremove(type,x,T)];
 else
  return [1,x];
 fi;
end;


#
# Functions related to the CMS model or Cherednik operators
#
###################
#list of functions#
###################
#		Hpoly:=proc(poly)
#		Dunkl_i_n:= proc(i, n, poly, Nin:=0, parameter:= beta)
#		H_n:= proc(n, poly, giveinm:=1)
#		I_k_n:= proc(k, n, poly, giveinm:=1)
#		EigenCMSn:= proc(spart,n, hn:=0, IorNot:=NULL, minN:=NULL)
#		lambdabar_i:= proc(composition, i, N)
#		FermDunkl_i_n:= proc(i,n, poly)
#		Itilde_k_n:= proc(k, n, poly, giveinm:=1)

HcmsPolyM:= proc(expr_in_m)
	return z_to_m(sort(expand(Hpoly(old_LinBaseConvert(expr_in_m, `z`)))));
end proc:
part_Hpoly:= proc(poly, i, nbvars)
	local j, term2, term3, terms, term23;
	terms:= [seq(k, k=(i+1)..nbvars)];
	#for j from i+1 to nbvars do
	#if j > i  then
	term2:=0; term3:=0;
		term2:=map(j->(((z||i+z||j)/(z||i-z||j)*(z||i*diff(
			poly,z||i)-z||j*diff(poly,z||j)))), terms);
		term3:=map(j->(((z||i*z||j)/((z||i-z||j)^2)*(
				poly-subs({theta||i=theta||j,
				theta||j=theta||i,phi||i=phi||j,
				phi||j=phi||i},poly)))), terms) ;
	#end if;
	#end do:
	term23:= term2 -2*term3;
	return sort(expand(add(k, k in term23)));
end proc:
Hpoly:=proc(poly)
	local H_on_poly, term1, term23, term3, i,j, Vars, nbvars, varsindices;
	#Hamiltonian as a direct generalization of K_ij
	#The code is pretty much self-explainatory
    	Vars:=giveVars(poly);
    	nbvars:= max(nops(Vars[1]), nops(Vars[2]), nops(Vars[3]));

	term1:=0; term23:=0; term3:=0;
	varsindices:= [seq(k, k=1..nbvars)];
	#term1:=term1+sort(expand(z||i*(diff(z||i*diff(poly,z||i),z||i))));
	term1:= map(x-> z||x*(diff(z||x*diff(poly, z||x), z||x)), varsindices);
	term1:= sort(expand(add(k, k in term1)));
	term23:= map(x-> part_Hpoly(poly,x,nbvars), varsindices);
	term23:= sort(expand(beta*add(k, k in term23)));
	H_on_poly:= sort(expand(term1+term23));
	#H_on_poly:= z_to_m(H_on_poly);
	return factor(H_on_poly);
end proc:

mH_n:= proc(n, poly_in_m)
	return H_n(n,old_LinBaseConvert(poly_in_m, 'z'), 1);
end proc:

H_n:= proc(n, poly, giveinm:=1)
    local Hpoly, N, Vars;
	# The hamiltonian tower in terms of the sum of the dunkl on every variables
    Vars:= giveVars(poly);
	N:= max(nops(Vars[1]), nops(Vars[2]), nops(Vars[3]));
	if N = 1 then N:= 2; end if;
    Hpoly:= simplify(add(Dunkl_i_n(i, n, poly, N), i=1..N));
    if giveinm = 1 then Hpoly:= z_to_m(Hpoly); end if;
    return Hpoly;
end proc:
#J_n:= proc(n, poly, giveninm:=1)
    #local Hpoly, N, Vars;
	# The hamiltonian tower in terms of the sum of the dunkl on every variables
    #Vars:= giveVars(poly);
	#N:= max(nops(Vars[1]), nops(Vars[2]), nops(Vars[3]));
	#if N = 1 then N:= 2; end if;
    #Hpoly:= add(Dunkl_i_n(i, n, phi||i*theta||i*diff(diff(poly, phi||i), theta||i), N), i=1..N);
    #if giveinm = 1 then Hpoly:= z_to_m(Hpoly); end if;
    #return Hpoly;
#end proc:
#H_n:= proc(n, poly, giveinm:=1)
	#local Hpoly, N, Vars;
	#Vars:= giveVars(poly);
	#N:= max(nops(Vars[1]), nops(Vars[2]), nops(Vars[3]));
	#if N = 1 then N:= 2; end if;
    	#Hpoly:= add(FermDunkl_i_n(i, n, poly), i=1..N);
    	#if giveinm = 1 then Hpoly:= z_to_m(Hpoly); end if;
    	#return Hpoly;
#end proc:
project_var_sector:= proc(poly_z,var, sector)
	local mbarbar, mbar, Ppoly, k,j, mubar, ind, thevar;
	mbarbar:= sector[4];
	mubar:= sector[3];
	#print(mubar);
	mbar := sector[2];
	Ppoly:= poly_z;
	if var = "pt" then
		for k from 1 to mbarbar do
			Ppoly:= sort(expand(phi||k*theta||k*diff(diff(Ppoly, phi||k), theta||k)));
		end do:
	elif var = "p" then
		for j from 1 to mbar do
			k:= j+ mbarbar;
			Ppoly:= sort(expand(phi||k*diff(Ppoly, phi||k)));
		end do:
	elif var = "t" then
		for j from 1 to mubar do
			k:= j + mbarbar+mbar;
			Ppoly:= sort(expand(theta||k*diff(Ppoly, theta||k)));
		end do:
	else return NULL;
	end if;
	return Ppoly;
end proc:

expI_n:= proc(smalli,n, poly_in_m)
	local sector, mbarbar, mbar, nbVars, Ipoly, theIndex, mubar, bigM;
	print(poly_in_m);
	sector:= givePolySector(poly_in_m);
	mbarbar:= sector[4];
	mbar:= sector[2];
	mubar:= sector[3];
	bigM:= [0,sector[4], sector[4]+sector[2], sector[4]+sector[3]+sector[2]];
    nbVars:= max(map(x-> nops(Flatten(x)), genN2spart(op(sector))));
	Ipoly:= old_LinBaseConvert(poly_in_m, 'z');
	Ipoly:= project_var_sector(Ipoly, "pt", sector);
	Ipoly:= project_var_sector(Ipoly, "p", sector);
	Ipoly:= project_var_sector(Ipoly, "t", sector);
	Ipoly:= Dunkl_i_n(bigM[smalli]+1,n,Ipoly, nbVars);
	Ipoly:= factor(Kw(Ipoly, nbVars));
	Ipoly:= z_to_m(Ipoly);
	return Ipoly;
end proc:
Ibarbar_n:= proc(n,poly_in_m)
	local sector, mbarbar, nbVars, Ipoly;
	sector:= givePolySector(poly_in_m);
	mbarbar:= sector[4];
	nbVars:= max(map(x-> nops(Flatten(x)), genN2spart(op(sector))));
	Ipoly:= old_LinBaseConvert(poly_in_m, 'z');
	if mbarbar = 0 then return 0; end if;
	Ipoly:= phi1*theta1*diff(diff(Ipoly, phi1), theta1);
	Ipoly:= Dunkl_i_n(1,n,Ipoly, nbVars);
	Ipoly:= factor(Kw(Ipoly, nbVars));
	Ipoly:= z_to_m(Ipoly);
	return Ipoly;
end proc:

Ibar_n:= proc(n, poly_in_m)
	local sector, mbarbar, mbar, nbVars, Ipoly, theIndex;
	sector:= givePolySector(poly_in_m);
	mbarbar:= sector[4];
	mbar := sector[2];
        nbVars:= max(map(x-> nops(Flatten(x)), genN2spart(op(sector))));
	Ipoly:= old_LinBaseConvert(poly_in_m, 'z');
	Ipoly:= project_var_sector(Ipoly, "pt", sector);
	if mbar = 0 then return 0; end if;
	theIndex:= mbarbar+1;
	Ipoly:= phi||theIndex*diff(Ipoly, phi||theIndex);
	Ipoly:= Dunkl_i_n(theIndex,n,Ipoly, nbVars);
	Ipoly:= factor(Kw(Ipoly, nbVars));
	Ipoly:= z_to_m(Ipoly);
	return Ipoly;
end proc:

Iubar_n:= proc(n, poly_in_m)
	local sector, mbarbar, mbar,mubar, nbVars, Ipoly, theIndex;
	sector:= givePolySector(poly_in_m);
	mbarbar:= sector[4];
	mbar := sector[2];
	mubar:= sector[3];
	if mubar = 0 then return 0; end if;
        nbVars:= max(map(x-> nops(Flatten(x)), genN2spart(op(sector))));
	Ipoly:= old_LinBaseConvert(poly_in_m, 'z');
	Ipoly:= project_var_sector(Ipoly, "pt", sector);
	Ipoly:= project_var_sector(Ipoly, "p", sector);
	theIndex:= mbarbar+mbar+1;
	Ipoly:= theta||theIndex*diff(Ipoly, theta||theIndex);
	Ipoly:= Dunkl_i_n(theIndex,n,Ipoly, nbVars);
	Ipoly:= factor(Kw(Ipoly, nbVars));
	Ipoly:= z_to_m(Ipoly);
	return Ipoly;
end proc:
testJn:= proc(n, poly_in_m)
	local poly_z, nbVars, Jpoly;
	poly_z:= old_LinBaseConvert(poly_in_m, 'z');
	nbVars:= giveNbVars(poly_z);
	Jpoly:= map(x-> theta||x*diff(poly_z, theta||x), [seq(k, k=1..nbVars)]);
	Jpoly:= map(x-> factor(Dunkl_i_n(x, n, Jpoly[x])), [seq(k,k=1..nbVars)]);
	Jpoly:= factor(add(k, k in Jpoly));
	return (Jpoly);
end proc:

VAP_I:= proc(spart, i, N)
	local spart_sector, M_i, pts, phis, thetas, zeds, Rspart, ellComp, deltaNell, term1, term2, term3, j,m,thesign;
	spart_sector:= giveSpartSector(spart);
	spart_sector:= [spart_sector[4], spart_sector[2], spart_sector[3]];
	M_i:= [0,spart_sector[1],spart_sector[1] + spart_sector[2],spart_sector[1] + spart_sector[2]+ spart_sector[3]];
	pts:= spart[1];
	phis:= spart[2];
	thetas:= spart[3];
	zeds:= spart[4];
	Rspart:= [op(Reverse(pts)),op(Reverse(phis)), op(Reverse(thetas)), op(Reverse(zeds))];
	ellComp:= nops(Rspart);
	deltaNell:= N-ellComp;
	if deltaNell<>0 then Rspart:= [op(Rspart), seq(0, k=1..deltaNell)]; end if;
	print(Rspart, "rspart");
	ellComp:= N;
	term1:= factorial(N- (spart_sector[1] + spart_sector[2] + spart_sector[3]));
	print(term1, "globalpref");
	term2:= factorial( spart_sector[1]) * factorial(spart_sector[2]) * factorial(spart_sector[3]);
	term2:= term2/factorial(spart_sector[i]);
	print(term2, "specificpref");
	term3:=
		add( factorial(M_i[i+1]-j)*( (M_i[i+1]-j)*lambdabar_i(Rspart,j, ellComp) - beta), j=(M_i[i]+1)..(M_i[i+1]-1))
		+ lambdabar_i(Rspart, M_i[i+1], ellComp);
	for j from M_i[i]+1 to M_i[i+1] - 1 do
		print("itt",j,"pref", factorial(M_i[i+1]-j));
		print("lambdabar", lambdabar_i(Rspart, j, ellComp));
		print("addedterm",factorial(M_i[i+1]-j)*( (M_i[i+1]-j)*lambdabar_i(Rspart,j, ellComp) - beta)) ;
		print((M_i[i+1]-j), hey);
	end do;
	print(M_i);
	print(lambdabar_i(Rspart, M_i[i+1], ellComp));
	return term1*term2*term3;
end proc:

EigenCMSn:= proc(spart,n, hn:=0, IorNot:=NULL, minN:=NULL)
    local DomMonomial, OpDomMonomial, I_1_1EigVal, I_2_1EigVal, H_2EigVal, EigenValues;
    # The function that returns the Eigen value for a given monomial. The code is probably broken.
    if minN <> NULL then DomMonomial:= m2n(spart, minN); else DomMonomial:= m2n(spart)  end if;

    I_1_1EigVal:=0;
    I_2_1EigVal:=0:
    H_2EigVal:= 0;

    OpDomMonomial:= I_k_n(1,n, DomMonomial, 2);
    if OpDomMonomial <> 0 then
        I_1_1EigVal:=  coeff(OpDomMonomial, m[op(spart)]);
    end if;

    OpDomMonomial:= I_k_n(6,n, DomMonomial, 2);
    if OpDomMonomial <> 0 then
        I_2_1EigVal:= coeff(OpDomMonomial, m[op(spart)]);
    end if;

    OpDomMonomial:= H_n(n+hn, DomMonomial);
    if OpDomMonomial <> 0 then
        H_2EigVal:= coeff(OpDomMonomial, m[op(spart)]);
    end if;
    if IorNot=NULL then
        EigenValues:= [I_1_1EigVal, I_2_1EigVal, H_2EigVal];
    else
        #EigenValues:= [I_1_1EigVal+I_2_1EigVal,I_1_1EigVal-I_2_1EigVal, H_2EigVal];
        EigenValues:= [I_1_1EigVal,I_2_1EigVal, H_2EigVal];
    end if;
    return EigenValues;
end proc:


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

# Real numbers mod integers

`is_element/RZ` := (x) -> type(x,realcons):

`is_equal/RZ` := (x,y) -> type(simplify(y-x),integer):

`is_leq/RZ` := NULL:

`normalize/RZ` := (x) -> simplify(x - floor(x)):

`random_element/RZ` := proc() rand(0..719)()/(720); end:

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

`d/RZ` := (x,y) -> abs(x - y - round(x - y));

`eta/RZ` := (x) -> exp(2*Pi*I*x);

`is_cyclic/RZ` := proc(x::list)
 local n,y,z,i;
 n := nops(x);
 if n <= 2 then return true; fi;
 y := simplify(x -~ x[1]);
 y := simplify(y -~ map(floor,y));
 z := [seq(y[i+1] - y[i],i=1..n-1)];
 return evalb(simplify(min(op(z))) >= 0);
end:

`is_strictly_cyclic/RZ` := proc(x::list)
 local n,y,z,i;
 n := nops(x);
 if n <= 2 then return true; fi;
 y := simplify(x -~ x[1]);
 y := simplify(y -~ map(floor,y));
 z := [seq(y[i+1] - y[i],i=1..n-1)];
 return evalb(simplify(min(op(z))) >= 0);
end: