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

(* Equation 28 squared with Equation 25 built in *)
tpss_xi2 := (z, xt, xs0, xs1) ->
  (1 - z^2)*(t_total(z, xs0^2, xs1^2) - xt^2)/(2*(3*Pi^2)^(1/3))^2:

(* Equation 33 *)
tpss_C00 := (cc, z) ->
  + add(cc[i]*z^(2*(i-1)), i=1..4):

(* Equation 34 *)
(* The series expansion of C0 for z -> +- 1 goes as C + D*(1+-z)^(2/3) + O(1+-z)
   whose first derivative seems to diverge for ferromagnetic densities, leading
   to severe numerical instabilities. I can not correct for the bad design of
   the functional, and this is the possible solution that I found *)
tpss_C0_den := (z, xt, xs0, xs1) ->
  1 + tpss_xi2(z, xt, xs0, xs1)*((1 + z)^(-4/3) + (1 - z)^(-4/3))/2:
tpss_C0 := (cc, z, xt, xs0, xs1) -> my_piecewise3(1 - m_abs(z) <= 1e-12,
  add(cc[i], i=1..4),
  tpss_C00(cc, z) / tpss_C0_den(z_thr(z), xt, xs0, xs1)^4):

(* Equation 11, with tau_W from Equation 12 *)
tpss_aux := (z, xt, ts0, ts1) ->
  m_min(xt^2/(8*t_total(z, ts0, ts1)), 1):

(* n_sigma/n \epsilon^sigma in Equation 25 *)
tpss_par_s0 := (f_gga, rs, z, xt, xs0, xs1) ->
  m_max(f_gga(rs*(2/(1 + z))^(1/3),  1, xs0, xs0, 0), f_gga(rs, z, xt, xs0, xs1))*(1 + z)/2:
tpss_par_s1 := (f_gga, rs, z, xt, xs0, xs1) ->
  m_max(f_gga(rs*(2/(1 - z))^(1/3), -1, xs1, 0, xs1), f_gga(rs, z, xt, xs0, xs1))*(1 - z)/2:

(* Second line of Equation 25 *)
(* The screening of the density is important in order to stabilize this functional
   for ferromagnetic densities *)
tpss_par  := (f_gga, rs, z, xt, xs0, xs1, ts0, ts1) ->
  - (1 + tpss_C0(params_a_C0_c, z, xt, xs0, xs1))*tpss_aux(z, xt, ts0, ts1)^2*(
    + my_piecewise3(screen_dens_zeta(rs,  z),
        f_gga(rs, z_thr(z), xt, xs0, xs1)*(1 + z)/2,
        tpss_par_s0(f_gga, rs, z_thr(z), xt, xs0, xs1)
      )
    + my_piecewise3(screen_dens_zeta(rs, -z),
        f_gga(rs, z_thr(z), xt, xs0, xs1)*(1 - z)/2,
        tpss_par_s1(f_gga, rs, z_thr(z), xt, xs0, xs1)
      )
  ):

(* First line of Equation 25 *)
tpss_perp := (f_gga, rs, z, xt, xs0, xs1, ts0, ts1) ->
  (1 + tpss_C0(params_a_C0_c, z, xt, xs0, xs1)*tpss_aux(z, xt, ts0, ts1)^2)
  * f_gga(rs, z, xt, xs0, xs1):

(* Equation in full 25 *)
tpss_f0 := (f_gga, rs, z, xt, xs0, xs1, ts0, ts1) ->
  + tpss_par (f_gga, rs, z, xt, xs0, xs1, ts0, ts1)
  + tpss_perp(f_gga, rs, z, xt, xs0, xs1, ts0, ts1):

(* Equation 24 *)
tpss_f := (f_gga, rs, z, xt, xs0, xs1, ts0, ts1) ->
  + tpss_f0(f_gga, rs, z, xt, xs0, xs1, ts0, ts1)
  * (1 + params_a_d*tpss_f0(f_gga, rs, z, xt, xs0, xs1, ts0, ts1)*tpss_aux(z, xt, ts0, ts1)^3):


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

`is_element/linord` := (A::set) -> proc(L)
 global reason;

 if not type(L,list) then
  reason := ["is_element/linord","L is not a list",L];
  return false;
 fi;

 if nops(L) <> nops(A) then
  reason := ["is_element/linord","L does not the same length as A",L,A];
  return false;
 fi;

 if {op(L)} <> A then
  reason := ["is_element/linord","L is not an enumeration of A",L,A];
  return false;
 fi;

 return true;
end;

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

`is_equal/linord` := (A::set) -> proc(L0,L1)
 return evalb(L0 = L1);
end;

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

`op/linord` := (A::set) -> proc(L)
 local n,i;
 n := nops(A);
 return [seq(L[n-i],i=0..n-1)];
end;

`res/linord` := (A::set,B::set) -> proc(L)
 return select(a -> member(a,B),L);
end:

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

`flip/linord` := (A::set) -> (L) -> proc(a)
 local n,i;
 n := nops(L);
 if n <= 1 then return L; fi;
 i := 1;
 while i <= n and L[i] <> a do i := i+1; od;
 if i > n then error("a is not in L"); fi;
 return [op(i..n,L),op(1..i-1,L)];
end:

`loop/linord` := (A::set) -> (L) -> L;

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

`random_element/linord` := (A::set) -> proc()
 return combinat[randperm](A);
end:

`list_elements/linord` := proc(A::set)
 return combinat[permute](A);
end:

`count_elements/linord` := proc(A::set)
 return nops(A) !;
end:

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

`linord_is_leq` := (A::set) -> (L) -> proc(a,b)
 local x;
 for x in L do
  if x = a then return true; fi;
  if x = b then return false; fi;
 od;
 error("Neither a nor b is in L");
end:

`linord_is_less` := (A::set) -> (L) -> proc(a,b)
 return evalb((a <> b) and `linord_is_leq`(A)(L)(a,b));
end:


# Berechne kinematische Zwangsbedingungen für aufgestellte Viergelenkkette
# Einleitung

# Die kinematischen Zwangsbedingungen werden als Ersetzungsausdruck für die abhängigen Winkel aufgestellt.
#
# fourbar1turnTE -> Viergelenkkette, Modellierung der Zwangsbedingungen mit Ausdrücken für trigonometrische Elimination. Drehbar aufgestellt mit zusätzlichem Gelenk
# kinematic_constraint -> Kinematische Zwangsbedingungen
#
# TODO: Fertige Ergebnisse von Viergelenkkette laden und nicht hier neu berechnen.
# Quelle
# SA Bejaoui: Bejaoui2018_S749; "Modellierung kinematischer Zwangsbedingungen für hybride serielle Roboter mit planaren Parallelmechanismen"
# SA Shan: Shan2019_S828, "Reduktion der Modellkomplexität von seriell-hybriden Palettierrobotern"
# Autor
# Weipu Shan (Studienarbeit), Abderahman Bejaoui (Vorlage fourbar1), Moritz Schappler (Korrekturen)
# Studienarbeit bei: Moritz Schappler, moritz.schappler@imes.uni-hannover.de, 2018-08
# (C) Institut fuer Mechatronische Systeme, Leibniz Universitaet Hannover
#
# Initialisierung
interface(warnlevel=0): # Unterdrücke die folgende Warnung.
restart: # Gibt eine Warnung, wenn über Terminal-Maple mit read gestartet wird.
interface(warnlevel=3):
kin_constraints_exist := true: # Für Speicherung
;
with(StringTools): # Für Zeitausgabe
with(LinearAlgebra):
with(codegen):
with(CodeGeneration):
#with(ListTools):
codegen_act := true:
codegen_opt := 1: # Geringerer Optimierungsgrad. Sonst zu lange.
codegen_debug := 0: # Zur Code-Generierung auch für Nicht-Inert-Ausdrücke
;
read "../helper/proc_MatlabExport":
read "../transformation/proc_rotx":
read "../transformation/proc_roty":
read "../transformation/proc_rotz":
read "../helper/proc_convert_s_t":
read "../helper/proc_convert_t_s":
read "../robot_codegen_constraints/proc_subs_kintmp_exp":
read "../helper/proc_intersect_circle":
with(RealDomain): # Schränkt alle Funktionen auf den reellen Bereich ein. Muss nach Definition von MatlabExport kommen. Sonst geht dieses nicht.
;
read "../robot_codegen_definitions/robot_env":
read sprintf("../codeexport/%s/tmp/tree_floatb_definitions", robot_name):

# Variable mit Winkeln der Nebenstruktur nur in Abhängigkeit der verallgemeinerten Koordinaten
kintmp_qs := Matrix(RowDimension(kintmp_s),1):
kintmpD_t:=diff~(kintmp_t,t):
kintmpD_s:=Matrix(< etaD_s, xiD_s, rhoD_s>):
# Konstante Winkel bereits hineinschreiben ( Keine für Viergelenkkette)
for i from 1 to RowDimension(kintmp_s) do
  if diff(kintmp_s(i,1), t) = 0 then
    kintmp_qs(i,1) := kintmp_s(i,1):
  end if:
end do:
# Variablen definieren für die Hilfswinkel
#
# Ersetzungsausdrücke definieren.
# Speichere Sinus und Cosinus der Winkel direkt ab, da diese in den Rotationsmatrizen direkt auftreten.
# Spalte 1: Zu suchender Ausdruck (sin oder cos eines Winkels)
# Spalte 2: Einzusetzender Ausdruck.
# Dadurch werden arctan-Ausdrücke in der direkten Kinematik reduziert.
# Ähnliches Vorgehen wie in [1].
kintmp_subsexp := Matrix(2*RowDimension(kintmp_s),2):
for i from 1 to RowDimension(kintmp_s) do
  kintmp_subsexp(2*i-1, 1) := sin(kintmp_s(i,1)):
  kintmp_subsexp(2*i,   1) := cos(kintmp_s(i,1)):
  # Initialisierung der rechten Spalte mit gleichen Werten. Später nur Ersetzung, wenn Vorteilhaft.
  kintmp_subsexp(2*i-1, 2) := kintmp_subsexp(2*i-1, 1):
  kintmp_subsexp(2*i,   2) := kintmp_subsexp(2*i,   1):
end do:
printf("Beginn der Berechnungen. %s\n", FormatTime("%Y-%m-%d %H:%M:%S")):
st := time():
# Reihenfolge, in der die Winkel der Parallelstruktur berechnet werden. Hilft beim exportieren von Code, wenn beim Debuggen in der gleichen Reihenfolge ausgegeben wird.
Reihenfolge_kintmp := <1;3;2>:
# Zwangsbedingung mit Kreisschnittpunkt C zur Bestimmung von rho
r_p1:= < l1 , 0 >: # Punkt B
;
r_p2:= < l2*cos(qJ2s) , l2*sin(qJ2s)> : # Punkt D
;
r1:=l4:
r2:=l3:
A:=intersect_circle(r_p1, r_p2, r1, r2):
r_s1x:=simplify(A(1,1),trig):
r_s1y:=simplify(A(2,1),trig):
r_acx:=l2*cos(qJ2s) + l3*(-cos(rho_s)*cos(qJ2s)+sin(rho_s)*sin(qJ2s)): # aus Homogener Trafo
;
r_acy:=l2*sin(qJ2s)- l3*(cos(rho_s)*sin(qJ2s)+sin(rho_s)*cos(qJ2s)):  # aus Homogener Trafo
;
f1:=r_s1x-r_acx=0: # GL1
;
f2:=r_s1y-r_acy=0: # GL2
;
# Zwangsbedingungen für eta , zweiter Weg zum Kreisschnittpunkt C
r_acx2:=l1-l4*cos(eta_s):
r_acy2:=l4*sin(eta_s):
f11:=r_s1x-r_acx2=0: # GL3
;
f12:=r_s1y-r_acy2=0: # GL4
;
# Zwangsbedingungen für xi , zwei Wege zum Punkt D
r_adx1:=l2*cos(qJ2s):
r_ady1:=l2*sin(qJ2s):
r_adx2:=l1-l4*cos(eta_s)+l3*(cos(eta_s)*cos(xi_s)-sin(eta_s)*sin(xi_s)):
r_ady2:=l4*sin(eta_s)-l3*(cos(eta_s)*sin(xi_s)+sin(eta_s)*cos(xi_s)): # hier schon einen Fehler erkannt
;
f21:=r_adx1-r_adx2=0: # GL5
;
f22:=r_ady1-r_ady2=0: # GL6
;
# Bestimme Winkel
sol:=simplify(solve({f1,f2},[cos(rho_s),sin(rho_s)]),trig):
sol:=op(sol):
cos(rho_s):=simplify(rhs(sol[1]),trig):
sin(rho_s):=simplify(rhs(sol[2]),trig):
# eta bestimmen
sol1:=solve({f11,f12},{cos(eta_s),sin(eta_s)}):
assign(sol1):
cos(eta1_s):=simplify(rhs(sol1[1]),trig):
sin(eta1_s):=simplify(rhs(sol1[2]),trig):
# xi bestimmen
sol2:=solve({f21,f22},{cos(xi_s),sin(xi_s)}):
sol2:=op(sol2):
cos(xi_s):=simplify(rhs(sol2[1]),trig):
convert_s_t(cos(xi_s)):
sin(xi_s):=simplify(rhs(sol2[2]),trig):
cos(eta_s):=-cos(eta1_s):
sin(eta_s):=sin(eta1_s):
# kintmp_subsexp
kintmp_subsexp(1,2):=sin(rho_s):
kintmp_subsexp(2,2):=cos(rho_s):
kintmp_subsexp(3,2):=sin(eta_s):
kintmp_subsexp(4,2):=cos(eta_s):
kintmp_subsexp(5,2):=sin(xi_s):
kintmp_subsexp(6,2):=cos(xi_s):
# Kintmp_qs
kintmp_qs(1,1):=arctan(sin(rho_s),cos(rho_s)):
kintmp_qs(2,1):=arctan(sin(eta_s),cos(eta_s)):
kintmp_qs(3,1):=arctan(sin(xi_s),cos(xi_s)):
# Exportiere Code für folgende Skripte
kintmp_qt := convert_s_t(kintmp_qs):
# Speichere Maple-Ausdruck (Eingabe-Format und internes Format)
save kintmp_subsexp, sprintf("../codeexport/%s/tmp/kinematic_constraints_kintmp_subsexp_maple", robot_name):
save kintmp_subsexp, sprintf("../codeexport/%s/tmp/kinematic_constraints_kintmp_subsexp_maple.m", robot_name):
printf("Ausdrücke für kintmp_subsexp gespeichert (Maple). %s. CPU-Zeit bis hier: %1.2fs.\n", FormatTime("%Y-%m-%d %H:%M:%S"), time()-st):
for i from 1 to RowDimension(kintmp_s) do
  tmp := kintmp_qs(i):
  save tmp, sprintf("../codeexport/%s/tmp/kinematic_constraints_maple_inert_kintmpq_%d", robot_name, i):
  save tmp, sprintf("../codeexport/%s/tmp/kinematic_constraints_maple_inert_kintmpq_%d.m", robot_name, i):
end do:
save kin_constraints_exist, kintmp_qs, kintmp_qt,kintmp_subsexp, sprintf("../codeexport/%s/tmp/kinematic_constraints_maple_inert", robot_name):
save kin_constraints_exist, kintmp_qs, kintmp_qt, kintmp_subsexp, sprintf("../codeexport/%s/tmp/kinematic_constraints_maple_inert.m", robot_name):
save kintmp_qs, sprintf("../codeexport/%s/tmp/kinematic_constraints_kintmp_qs_maple_inert", robot_name):
printf("Ausdrücke mit Inert-Arctan exportiert (Matlab). %s. CPU-Zeit bis hier: %1.2fs.\n", FormatTime("%Y-%m-%d %H:%M:%S"), time()-st):
# Liste mit abhängigen konstanten Kinematikparametern erstellen (wichtig für Matlab-Funktionsgenerierung)
read "../helper/proc_list_constant_expressions";
kc_symbols := Matrix(list_constant_expressions( kintmp_subsexp ));
save kc_symbols, sprintf("../codeexport/%s/tmp/kinematic_constraints_symbols_list_maple", robot_name):
MatlabExport(kc_symbols, sprintf("../codeexport/%s/tmp/kinematic_constraints_symbols_list_matlab.m",robot_name),2);
printf("Fertig. %s. CPU-Zeit bis hier: %1.2fs.\n", FormatTime("%Y-%m-%d %H:%M:%S"), time()-st):


# # Computation for the equivariant cohomology of G/B
# # by Shizuo Kaji

# it requires coxeter and weyl package by J.Stembridge
# http://www.math.lsa.umich.edu/~jrs/maple.html

# symbols
# e(i), a[i]: elements in H^*(BT) in abstract coordinate and root coordinate
# x[i], z[i]: elements in H^*(G/T) in abstract coordinate and root coordinate

# look at the demo worksheet "BGGT_example.mw" for the details.

with(coxeter); with(weyl);with(WeylOps);

# decompose a word into products of smaller words
# used in "double"
decomp := proc(weyl::list) local L, i, temp;
 if nops(weyl)=1 then return {[weyl]}; end if;
 temp:={};
 for i in descent(weyl) do
   for L in procname(weyl.[i]) do
     if nops(L)=1 then
	   temp:={op(temp), [op(L),[i]], [L[1].[i]]};
     else
       temp:={op(temp), [op(L),[i]], [op(1..-2,L),L[-1].[i]]};
     end if;
   end do;
 end do;
 return temp;
end proc:

# Enumerate subwords of "longweyl" which is equal to "weyl"
subwords := proc(weyl::list, longweyl::list) local i,L,W; global R;
  W := {};
  for L in combinat[choose]([seq(i,i=1..nops(longweyl))],nops(weyl)) do
    if reduce([seq(longweyl[i],i=L)], R)=weyl then
	   W:=W union {L};
    end if;
  end do;
  return W;
end proc;

## Utility Functions
# convert between e-poly and z-poly
e2x := proc(f::polynom);
	return eval(f,[seq(e(j)=x[j], j = 1 .. dimr(R))]);
end proc:
x2e := proc(f::polynom);
	return eval(f,[seq(x[j]=e(j) , j = 1 .. dimr(R))]);
end proc:
e2u := proc(f::polynom);
	return eval(f,[seq(e(j)=u[j], j = 1 .. dimr(R))]);
end proc:

# convert between a-poly and z-poly
a2z := proc(f::polynom);
	return eval(f,[seq(a[j]=z[j], j = 1 .. rank(R))]);
end proc:

# BGG operator on GKM poly
BGG_GKM := proc(rt::integer, f::list(polynom), LR::symbol := 'R') local j,k,ff,v,u; global reduw, R, B, optype; option remember;
  ff := [seq(0,j=1..nops(reduw))];
  if LR='R' then
	for j from 1 to nops(reduw) do
		u := reflect(seq(B[reduw[j][k]],k=1..nops(reduw[j])),B[rt]);
		member(reduw[j].[rt],reduw,'v');
        if optype = 'e' then
            ff[j] := -simplify((f[j] - f[v])/u);
        else
            ff[j] := -simplify((f[j] - f[v])/e2a(u));
        end if;
	end do;
  elif LR='L' then
	for j from 1 to nops(reduw) do
		member([rt].reduw[j], reduw,'v');
        if optype = 'e' then
            ff[j]:=simplify((f[j]-subs({seq(e(i)=reflect(B[rt],e(i))
                                            ,i=1..dimr(R))},f[v]))/B[rt]);
        else
            ff[j]:=simplify((f[j]-subs({seq(a[i]=e2a(reflect(B[rt],B[i]))
                                            ,i=1..nops(B))},f[v]))/a[rt]);
        end if;
	end do;
  end if;
  return ff;
end proc:

# BGG on double polynomials
BGGT_e := proc(rt::integer, f::polynom, LR::symbol := 'R')
  if LR='R' then
    return -simplify((f - act([rt], f))/e2x(B[rt]));
  else
    return simplify((f - act([rt], f, 'L'))/B[rt]);
  end if;
  return -infinity;
end proc;
#
BGGT_a := proc(rt::integer, f::polynom, LR::symbol := 'R')
  if LR='R' then
      return -simplify((f - act([rt], f))/z[rt]);
  else
      return simplify((f - act([rt], f, 'L'))/a[rt]);
  end if;
  return -infinity;
end proc;

# BGG operator for poly in "X[weyl]"
BGGT_X := proc(rt::integer, f::polynom, LR::symbol := 'R') local ff,w,term;
    if degree(f) < 1 then
        return 0;
    elif LR = 'L' then
        if optype = 'e' then
            return (f-act([rt],f,'L'))/B[rt];
        else
            return (f-act([rt],f,'L'))/a[rt];
        end if;
    elif LR ='R' then
        if type(f, 'indexed') and op(0,f)=`X` then
            w:=op(1,f).[rt];
            if nops(w)=0 then return 1;
            elif nops(w) < nops(op(1,f)) then return(X[w]);
            else return 0;
            end if;
        elif op(0, f) = `+` then
            return expand(map2(procname, rt, f));
        elif op(0, f) = `*` then
            if type(op(1,f), 'rational') then
                return op(1,f)*procname(rt, f/op(1,f));
            end if;
            term[1] := op(1, f);
            term[2] := mul(op(i, f), i = 2 .. nops(f));
            return expand(procname(rt, term[1])*term[2]
                          +ref_rt(rt, term[1])*procname(rt, term[2]));
        elif op(0, f) = `^` then
            term[1] := op(1, f);
            return expand(procname(rt, term[1])*add(term[1]^(i-1)*act([rt], term[1])^(op(2,f)-i),i=1..op(2,f)));
        end if;
        print("error in BGGT_X:",f);
    end if;
end proc;

# BGG operator for weyl words
BGGweylT := proc(weyl::list, f::{list(polynom),polynom}, LR::symbol := 'R')
                 global optype; local i,temp,func;
	temp := f;
	if type(f, list(polynom)) then
	   func := 'BGG_GKM';
    elif has(f,`X`) then
        func := 'BGGT_X';
    elif type(f, polynom) then
	   func := cat('BGGT_',optype);
    else
        print("error in BGGWeylT:",f);
        return -infinity;
    end if;
	for i from nops(weyl) to 1 by -1 do
		temp := func(weyl[i], temp, LR);
	end do;
	return temp;
end proc:

# Weyl group action on polynomials
act := proc(weyl::list, f::ratpoly, LR::symbol := 'R') local ff,t,rt; global R,optype;
    if nops(weyl)=0 then
        return f;
    elif nops(weyl)>1 then
        return procname(weyl[1..-2],procname([weyl[-1]],f,LR),LR);
    elif nops(weyl)=1 then
        rt := weyl[-1];
        if LR='R' then
            ff:=eval(f, [seq(x[i] = subs([seq(e(j) = x[j], j = 1 .. dimr(R))],
                               reflect(B[rt], e(i))), i = 1 .. dimr(R))]);
            ff:=eval(ff, [seq(z[i] = add(root_coords(reflect(B[rt],B[i]),R)[j]*z[j],
                                               j = 1 .. rank(R)), i = 1 .. rank(R))]);
            return eval(ff,[seq(t=ref_weyl(rt,op(1,t),'R'), t=indetsX(ff))]);
       elif LR='L' then
            ff:= eval(f, [seq(e(i)=reflect(B[rt], e(i)),
                              i = 1 .. dimr(R))]);
            ff := eval(ff, [seq(a[i] = add(root_coords(reflect(B[rt], B[i]),R)[j]*a[j],
                                            j = 1 .. rank(R)), i = 1 .. rank(R))]);
            return eval(ff,[seq(t=ref_weyl(rt,op(1,t),'L'), t=indetsX(ff))]);
        end if;
    end if;
    print("error in act:",weyl,f);
    return -infinity;
end proc;

# enumerate X in a polynomial
indetsX := proc(f) local t,V;
    V:=[];
    for t in indets(f) do
        if type(t,'indexed') and op(0,t)=`X` then
            V:=[op(V),t];
        end if;
    end do;
    return V;
end proc:

# Weyl group action on X
ref_weyl := proc(rt::integer,weyl::list, LR::symbol := 'R') local b,j,v,u,w,temp; global B;
    if LR = 'R' then
        w := weyl.[rt];
        if nops(w) > nops(weyl) then
            return X[weyl];
        end if;
        temp := X[weyl]+act(w,B[rt],'L')*X[w];
        for b in pos_roots(B) do
            v := reflect(b,interior_pt(B));
            v := reflect(seq(B[j],j=w),v);
            vec2fc(v,R,'u');    # u = w.s_b
            if nops(u)=nops(weyl) then
                temp := temp - iprod(2/iprod(b,b)*b,B[rt])*X[u];
            end if;
        end do;
        return temp;
    elif LR = 'L' then
        w := [rt].weyl;
        if nops(w) > nops(weyl) then
            return X[weyl]
        else
            return -B[rt]*X[w]+X[weyl];
        end if;
    end if;
    print("error in ref_weyl:",rt,weyl);
    return -infinity;
end proc:

# evaluate poly at "w" by putting x[i]=w^{-1}e[i]
ev := proc(weyl::list, f::polynom) local ff; global R,optype;
      ff := eval(act(weyl,f), [seq(x[i] = e(i), i = 1 .. dimr(R))]);
      return eval(ff, [seq(z[i] = a[i], i = 1 .. rank(R))]);
end proc:

# orbit sum
orbit_sum := proc(f::polynom) global reduw,R;
  return expand(add(ev(weyl,f), weyl=reduw)/size(R));
end proc:

# push-forward in cohomology
push := proc(f::polynom) local d,weyl; global reduw,R,P;
    d := mul(e2x(i), i = P);
    return expand(ev([],(-1)^(nops(P))*simplify(add(act(weyl,f/d), weyl=reduw)))):
end proc:

# convert double polynomials to Schubert basis
P2X := proc(f::polynom) local weyl, temp, i; global R, redu;
    temp := ev([],f);
    for i to min(degree(f),nops(redu)) do
      temp := temp+add(
    	  ev([],BGGweylT(weyl, f))*X[weyl], weyl=redu[i]);
    end do;
	return col(temp);
end proc:

# Convert GKM polynomials to Schubert basis using upper triangularity
GKM2X := proc (f::list(polynom)) local i, j, it, lc, ff; global reduw;
   for it to nops(f) do
     if f[it] <> 0 then break; end if;
   end do;
   if nops(f) < it then return 0; end if;
   lc := normal(f[it]/GKM(reduw[it])[it]);
   ff := normal(zip(`-`, f, zip(`*`, lc, GKM(reduw[it]))));
   return col(lc*X[reduw[it]]+procname(ff));
end proc;

# Convert GKM polynomials to Schubert basis using right BGG operators
GKM2X2 := proc (f::list(polynom)) local i, deg, temp, weyl; global reduw;
    temp := f[1];
    deg := max(map(degree,f));
    for i to min(deg,nops(redu)) do
        temp := temp+add(BGGweylT(weyl, f)[1]*X[weyl], weyl=redu[i]);
    end do;
    return col(temp);
end proc;

# convert poly in "X" to Schubert basis
X2X := proc(f::polynom);
	return GKM2X(X2GKM(f));
end proc:

# Convert poly in "X" into GKM-poly
X2GKM := proc (f::polynom) local i, weyl; global reduw;
    return [seq(eval(f, [seq(X[weyl] = GKM(weyl)[i], weyl = reduw)]),i=1..nops(reduw))] ;
end proc;

# convert double poly into GKM-poly
P2GKM := proc(f::polynom);
    return ([seq(simplify(ev(w, f)), w = reduw)])
end proc:

# GKM polys (Billey's formula)
GKM :=proc(weyl::list, upto:=-1) option remember; global reduw;
 return [seq(GKM_internal(weyl,v),v=reduw[1..upto])];
end proc:

GKM_internal := proc(weyl::list, longweyl::list) local i,j,k,u,L,K,M; global R,B,optype;
  K := 0;
  for L in subwords(weyl, longweyl) do
    M := 1;
    for i from 1 to nops(weyl) do
      u := reflect(seq(B[longweyl[j]],j=1..L[i]-1), B[longweyl[L[i]]]);
	  if optype = 'e' then
	  	  M := M * u;
	  else
		  M := M * e2a(u);
	  end if;
	end do;
    K := K + M;
  end do;
  return simplify(K);
end proc:

# initialize for Lie type
setupT := proc (lie_type, roots::set :={}, upto::integer := 0) local i;
     global R, B, P, S, ST, redu, udim, reduw, optype, optypeK, w0;
  forget(GKM);
  forget(BGG_GKM);
  forget(refK); forget(strong_bruhat);
  unassign('S','ST');

  R := lie_type;
  B := base(R);
  P := pos_roots(R);
    optype := 'e';
    if R = cat('A',rank(R)) then
        optypeK := 'x'
    else
        optypeK := 'u'
    end if;
  udim := `if`(upto>0,upto,nops(P));
  redu := PReducedWd(R, roots, udim);
  reduw := [[],seq(op(i),i=redu)];
  w0 := longest_elt(R);
  return R;
end proc;

# TopSchubert poly
top := proc () local k, j, i, temp; global R,P;
   temp := 1;
   if optype='e' then
	if R = G2 then
	    return (-3*e2x(w[1])^6+2*e2x(w[1])^5*e2x(w[2]))/6;
    elif R = cat('A',rank(R)) then
	     return mul(x[i]^(rank(R)-i+1), i = 1 .. rank(R));
	elif R = cat('B',rank(R)) then
    	return mul(x[i]^(rank(R)-i), i = 1 .. rank(R))*mul(c(i,`x`)/2, i = 1 .. rank(R));
    elif lie_type = cat('C',rank(R)) then
		 return mul(x[i]^(2*rank(R)-2*i+1), i = 1 .. rank(R));
    elif R = E7 then
		temp := mul(x[i]-c(1,`x`), i = 1 .. 7);
		for i to 6 do temp := temp*mul(x[i]-x[j], j = i+1 .. 7) end do;
	    for i to 5 do
		 for j from i+1 to 6 do
			temp := temp*mul(x[i]+x[j]+x[k]-c(1,`x`), k = j+1 .. 7);
	     end do;
		end do;
		return temp;
    elif R = E8 then
		temp := mul(t[i], i = 1 .. 8);
		for i to 7 do temp := temp*mul(t[i]-t[j], j = i+1 .. 8) end do;
		for i to 7 do temp := temp*mul(t[i]+t[j]-t[0], j = i+1 .. 8) end do;
		for i to 6 do
			for j from i+1 to 7 do
				temp := temp*mul(t[i]+t[j]+t[k]-t[0], k = j+1 .. 8)
			end do;
		end do;
		return temp;
    else
		return mul(e2x(i), i = P)/mul(i, i=degrees(R));
    end if;
   else
	if R = G2 then
   		return z[1]^5*z[2]/2;
	else
		return mul(a2z(-e2a(i)), i = P)/mul(i, i=degrees(R));
    end if;
   end if;
end proc;

# Top double poly
topT := proc() global R,optype,S,w0;  local u, i, j, k, D, temp;
  if optype='e' then
     if R = cat('A',rank(R)) then
	     return mul(mul(x[i]-e(j), j = 1 .. rank(R)-i+1), i = 1 .. rank(R)+1);
	 elif R = cat('B',rank(R)) then
	    #  D:=Matrix(rank(R));
		#  for i from 1 to rank(R) do
		#     for j from 1 to rank(R) do
		#          k:=rank(R)+1+j-2*i;
		# 		 if k<=rank(R) and k>=0 then
		# 		   D[i,j]:=(c(k,`x`)+eval(c(k,`t`),[seq(t[h]=e(h),h=1..rank(R))]))/2;
		# 		 end if;
		# 	end do;
		# end do;
		# return act(longest_elt(R),mul(mul(x[i]-e(j), j = 1 .. i-1), i = 2 .. rank(R))
		#   *LinearAlgebra[Determinant](D));
   return  mul(mul(x[i]-e(j), j = 1 .. i), i = 1 .. rank(R))
                  *mul(mul(x[i]+e(j), j = 1 .. i-1), i = 1 .. rank(R))/(-2)^rank(R);

	 elif R = cat('C',rank(R)) then
	    #  D:=Matrix(rank(R));
		#  for i from 1 to rank(R) do
		#     for j from 1 to rank(R) do
		#          k:=rank(R)+1+j-2*i;
		# 		 if k<=rank(R) and k>=0 then
		# 		   D[i,j]:=(c(k,`x`)+eval(c(k,`t`),[seq(t[h]=e(h),h=1..rank(R))]));
		# 		 end if;
		# 	end do;
		# end do;
		# return act(longest_elt(R),mul(mul(x[i]-e(j), j = 1 .. i-1), i = 2 .. rank(R))
		#   *LinearAlgebra[Determinant](D));
        return   mul(mul(x[i]-e(j), j = 1 .. i), i = 1 .. rank(R))
                  *mul(mul(x[i]+e(j), j = 1 .. i-1), i = 1 .. rank(R));
	 elif R = cat('D',rank(R)) then
	     D:=Matrix(rank(R));
		 for i from 1 to rank(R) do
		    for j from 1 to rank(R) do
		         k:=rank(R)+j-2*i;
				 if k<=rank(R) and k>=0 then
				     D[i,j]:=(c(k,`x`)+eval(c(k,`t`),[seq(t[h]=e(h),h=1..rank(R))]))/2;
				 end if;
			end do;
		end do;
		return act(w0,mul(mul(x[i]-e(j), j = 1 .. i-1), i = 2 .. rank(R))
                   *LinearAlgebra[Determinant](D));
     elif R = G2 then
         return ((x[1]-x[2]+e2-e1)/2)*(x[2]-x[1]-e2+e3)*(x[2]-x[1]-e1+e3)
         *(x[1]-x[2]-e2+e3)*(x[1]-x[2]-e1+e3)*(-x[1]+2*x[2]-x[3]+e2-2*e1+e3);
#	     return -(x[3]-(2/3)*e3+(1/3)*e1-(2/3)*e2)*((3/2)*x[1]-(3/2)*e1)*(3*x[1]-3*e2)
#         *(3*x[1]-3*e3)*(x[2]-(2/3)*e1-(2/3)*e2+(1/3)*e3)*(x[2]-(2/3)*e3+(1/3)*e1-(2/3)*e2);
	 elif type(name_of(R),'indexed') then       # type I2
	      D:=[]; temp:=x[2]-e2;
	      for i from 1 to trunc(op(1,name_of(R))/2-1) do
		     D:=[1,2,op(D)];
		     temp:=temp*(x[2]-act(D,e2,'L'));
		  end do;
		  D:=[];
		  for i from 1 to trunc((op(1,name_of(R))-1)/2) do
		     D:=[2,1,op(D)];
		     temp:=temp*(x[2]-act(D,e2,'L'));
		  end do;
	      return temp*(x[1]+act(w0,e1,'L'));
	 else
	    return double(w0);
	 end if;
  elif optype='a' then
     if R = G2 then
         return ((-z[1]+a[1])/2)*(z[1]+a[1]+a[2])*(z[1]+2*a[1]+a[2])
         *(-z[1]+a[1]+a[2])*(-z[1]+2*a[1]+a[2])*(-z[2]+3*a[1]+a[2]);
     elif R = cat('A',rank(R)) then
        for i from 1 to rank(R)+1 do
	       u[i] := e2a(-add(e(j), j = 1 .. rank(R)+1)/(rank(R)+1) + e(i));
	    end do;
        return mul(mul(eval(u[i],[seq(a[k]=z[k],k=1..rank(R))])-u[j], j = 1 .. rank(R)-i+1),
	        i = 1 .. rank(R)+1);
     else
	    return double(w0);
	 end if;
  end if:
end proc:

# enumerate Schubert polynomials
schubertpolys := proc () global S,reduw,w0; local w,f;
  f:=top();
  for w in reduw do
	 S[w] := simplify(BGGweylT(inv(w).w0,f));
  end do;
  print("The top schubert poly is",f);
end proc:

# enumerate Double Schubert polynomials
schubertpolysT := proc () global optype,ST,reduw,w0; local w,f;
  f:=topT();
  for w in reduw do
	 ST[w] := simplify(BGGweylT(inv(w).w0,f));
  end do;
  print("The top double schubert poly is",f);
end proc:

# single to double formula
# compute double Schubert poly "ST[weyl]" from single Schubert polys "S[]"
double:=proc(weyl::list) global S; local temp,L;
  if optype = 'e' then
      return add((-1)^(nops(L))*mul(x2e(S[L[i]]),i=1..nops(L)-1)
                 *(x2e(S[L[-1]])-S[L[-1]]),L=decomp(weyl));
  else
      return add((-1)^(nops(L))*mul(z2a(S[L[i]]),i=1..nops(L)-1)
                 *(z2a(S[L[-1]])-S[L[-1]]),L=decomp(weyl));
  end if;
end proc:

# double to single
single:=proc(f::polynom) local ff; global R;
    ff := eval(f,[seq(e(j) = 0, j = 1 .. dimr(R))]);
    return eval(ff, [seq(a[j] = 0, j = 1 .. rank(R))]);
end proc:

# Cauchy formula for type A
Cauchy:=proc() global reduw,w0 ;local weyl;
 return add((-1)^(nops(weyl))*x2e(S[weyl])*S[weyl.w0],weyl=reduw);
end proc:

# Chevalley formula computes "X[weyl]X[rt]"
Chev := proc(weyl::list,rt::integer) local j,v,u,temp; global w,P;
	 temp := 0;
     for v in P do
       	 vec2fc(reflect(seq(B[j], j = weyl),v,interior_pt(R)),R,'u');
         if nops(u)=nops(weyl)+1 then
		   temp := temp + iprod(2/iprod(v,v)*v,w[rt])*X[u];
         end if;
     end do;
     return (w[rt]-reflect(seq(B[j], j = weyl),w[rt]))*X[weyl]+temp;
end proc:

# collect terms in Schubert presentation
col := proc(f::algebraic) local g; global reduw;
    g := collect(simplify(f),[seq(X[weyl],weyl=reduw)]);
    return collect(g,[seq(XK[weyl],weyl=reduw)]);
end proc:


read ("metaMPFR_straightforwardAlgo.mpl"):

f := AiryAi(x):
deq := holexprtodiffeq(f, y(x)):
rec := diffeqtorec(deq, y(x), a(n)):
name_of_function := op(0,f):
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), FUNCTION_SERIES, name_of_function, name_of_file, f):

f := erf(x):
deq := holexprtodiffeq(f, y(x)):
rec := diffeqtorec(deq, y(x), a(n)):
name_of_function := op(0,f):
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), FUNCTION_SERIES, name_of_function, name_of_file, f):

rec := { a(n+1) = -(6*n+1)*(6*n+2)*(6*n+3)*(6*n+4)*(6*n+5)*(6*n+6)*a(n)/( (n+1)^3*(3*n+1)*(3*n+2)*(3*n+3)*12288000 ), a(0)=1 }:
name_of_function := alpha:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), CONSTANT_SERIES, name_of_function, name_of_file, f):

rec := { a(n+1) = -(6*n+1)*a(n)/( (n+1)^3 ), a(0)=1 }:
name_of_function := test0a:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), CONSTANT_SERIES, name_of_function, name_of_file, f):

rec := { a(n+1) = -(6*n+1)*a(n)/( (n+1)^3 ), a(0)=Pi }:
name_of_function := test1a:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), CONSTANT_SERIES, name_of_function, name_of_file, f):

rec := { a(n+1) = (1/Pi)*(3*n+1)*a(n)/( (n+2) ), a(0)=1 }:
name_of_function := test2a:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), CONSTANT_SERIES, name_of_function, name_of_file, f):

rec := { a(n+1) = (1/Pi)*(3*n+1)*a(n)/( (n+2) ), a(0)=Pi }:
name_of_function := test3a:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), CONSTANT_SERIES, name_of_function, name_of_file, f):

rec := { a(n+2) = -(6*n+1)*a(n)/( (n+1)^3 ), a(0)=1, a(1)=2 }:
name_of_function := test4a:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), CONSTANT_SERIES, name_of_function, name_of_file, f):

rec := { a(n+2) = -(6*n+1)*a(n)/( (n+1)^3 ), a(0)=Pi, a(1)=0}:
name_of_function := test5a:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), CONSTANT_SERIES, name_of_function, name_of_file, f):

rec := { a(n+2) = (1/Pi)*(3*n+1)*a(n)/( (n+2) ), a(0)=1, a(1)=Pi }:
name_of_function := test6a:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), CONSTANT_SERIES, name_of_function, name_of_file, f):

rec := { a(n+2) = (1/Pi)*(3*n+1)*a(n)/( (n+2) ), a(0)=Pi, a(1)=0}:
name_of_function := test7a:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), CONSTANT_SERIES, name_of_function, name_of_file, f):

rec := { a(n+3) = -(6*n+1)*a(n)/( (n+1)^3 ), a(0)=1, a(1)=0, a(2)=0 }:
name_of_function := test8a:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), CONSTANT_SERIES, name_of_function, name_of_file, f):

rec := { a(n+3) = -(6*n+1)*a(n)/( (n+1)^3 ), a(0)=0, a(1)=Pi, a(2)=2 }:
name_of_function := test9a:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), CONSTANT_SERIES, name_of_function, name_of_file, f):

rec := { a(n+3) = (1/Pi)*(3*n+1)*a(n)/( (n+2) ), a(0)=0, a(1)=0, a(2)=1 }:
name_of_function := test10a:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), CONSTANT_SERIES, name_of_function, name_of_file, f):

rec := { a(n+7) = (1/Pi)*(3*n+1)*a(n)/( (n+2) ), a(0)=Pi, a(4)=1, a(6)=2  }:
name_of_function := test11a:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), CONSTANT_SERIES, name_of_function, name_of_file, f):

rec := { a(n+1) = -(6*n+1)*a(n)/( (n+1)^3 ), a(0)=1 }:
name_of_function := test0b:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), FUNCTION_SERIES, name_of_function, name_of_file, f):

rec := { a(n+1) = -(6*n+1)*a(n)/( (n+1)^3 ), a(0)=Pi }:
name_of_function := test1b:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), FUNCTION_SERIES, name_of_function, name_of_file, f):

rec := { a(n+1) = (1/Pi)*(3*n+1)*a(n)/( (n+2) ), a(0)=1 }:
name_of_function := test2b:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), FUNCTION_SERIES, name_of_function, name_of_file, f):

rec := { a(n+1) = (1/Pi)*(3*n+1)*a(n)/( (n+2) ), a(0)=Pi }:
name_of_function := test3b:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), FUNCTION_SERIES, name_of_function, name_of_file, f):

rec := { a(n+2) = -(6*n+1)*a(n)/( (n+1)^3 ), a(0)=1, a(1)=2 }:
name_of_function := test4b:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), FUNCTION_SERIES, name_of_function, name_of_file, f):

rec := { a(n+2) = -(6*n+1)*a(n)/( (n+1)^3 ), a(0)=Pi, a(1)=0}:
name_of_function := test5b:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), FUNCTION_SERIES, name_of_function, name_of_file, f):

rec := { a(n+2) = (1/Pi)*(3*n+1)*a(n)/( (n+2) ), a(0)=1, a(1)=Pi }:
name_of_function := test6b:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), FUNCTION_SERIES, name_of_function, name_of_file, f):

rec := { a(n+2) = (1/Pi)*(3*n+1)*a(n)/( (n+2) ), a(0)=Pi, a(1)=0}:
name_of_function := test7b:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), FUNCTION_SERIES, name_of_function, name_of_file, f):

rec := { a(n+3) = -(6*n+1)*a(n)/( (n+1)^3 ), a(0)=1, a(1)=0, a(2)=0 }:
name_of_function := test8b:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), FUNCTION_SERIES, name_of_function, name_of_file, f):

rec := { a(n+3) = -(6*n+1)*a(n)/( (n+1)^3 ), a(0)=0, a(1)=Pi, a(2)=2 }:
name_of_function := test9b:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), FUNCTION_SERIES, name_of_function, name_of_file, f):

rec := { a(n+3) = (1/Pi)*(3*n+1)*a(n)/( (n+2) ), a(0)=0, a(1)=0, a(2)=1 }:
name_of_function := test10b:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), FUNCTION_SERIES, name_of_function, name_of_file, f):

rec := { a(n+7) = (1/Pi)*(3*n+1)*a(n)/( (n+2) ), a(0)=Pi, a(4)=1, a(6)=2  }:
name_of_function := test11b:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), FUNCTION_SERIES, name_of_function, name_of_file, f):

rec := { a(n+1) = -(6*n+1)*a(n)/( (n+1)^3 ), a(0)=1 }:
name_of_function := test0c:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), FUNCTION_SERIES_RATIONAL, name_of_function, name_of_file, f):

rec := { a(n+1) = -(6*n+1)*a(n)/( (n+1)^3 ), a(0)=Pi }:
name_of_function := test1c:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), FUNCTION_SERIES_RATIONAL, name_of_function, name_of_file, f):

rec := { a(n+1) = (1/Pi)*(3*n+1)*a(n)/( (n+2) ), a(0)=1 }:
name_of_function := test2c:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), FUNCTION_SERIES_RATIONAL, name_of_function, name_of_file, f):

rec := { a(n+1) = (1/Pi)*(3*n+1)*a(n)/( (n+2) ), a(0)=Pi }:
name_of_function := test3c:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), FUNCTION_SERIES_RATIONAL, name_of_function, name_of_file, f):

rec := { a(n+2) = -(6*n+1)*a(n)/( (n+1)^3 ), a(0)=1, a(1)=2 }:
name_of_function := test4c:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), FUNCTION_SERIES_RATIONAL, name_of_function, name_of_file, f):

rec := { a(n+2) = -(6*n+1)*a(n)/( (n+1)^3 ), a(0)=Pi, a(1)=0}:
name_of_function := test5c:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), FUNCTION_SERIES_RATIONAL, name_of_function, name_of_file, f):

rec := { a(n+2) = (1/Pi)*(3*n+1)*a(n)/( (n+2) ), a(0)=1, a(1)=Pi }:
name_of_function := test6c:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), FUNCTION_SERIES_RATIONAL, name_of_function, name_of_file, f):

rec := { a(n+2) = (1/Pi)*(3*n+1)*a(n)/( (n+2) ), a(0)=Pi, a(1)=0}:
name_of_function := test7c:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), FUNCTION_SERIES_RATIONAL, name_of_function, name_of_file, f):

rec := { a(n+3) = -(6*n+1)*a(n)/( (n+1)^3 ), a(0)=1, a(1)=0, a(2)=0 }:
name_of_function := test8c:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), FUNCTION_SERIES_RATIONAL, name_of_function, name_of_file, f):

rec := { a(n+3) = -(6*n+1)*a(n)/( (n+1)^3 ), a(0)=0, a(1)=Pi, a(2)=2 }:
name_of_function := test9c:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), FUNCTION_SERIES_RATIONAL, name_of_function, name_of_file, f):

rec := { a(n+3) = (1/Pi)*(3*n+1)*a(n)/( (n+2) ), a(0)=0, a(1)=0, a(2)=1 }:
name_of_function := test10c:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), FUNCTION_SERIES_RATIONAL, name_of_function, name_of_file, f):

rec := { a(n+7) = (1/Pi)*(3*n+1)*a(n)/( (n+2) ), a(0)=Pi, a(4)=1, a(6)=2  }:
name_of_function := test11c:
name_of_file := sprintf("%a.c", name_of_function):
printf("\n\n\n/************************** Implémentation de %s ******************************/\n", name_of_file):
generateStraightforwardAlgo(rec, a(n), FUNCTION_SERIES_RATIONAL, name_of_function, name_of_file, f):


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

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

(* type: work_mgga_c *)

$include "gga_c_gapc.mpl"

(* override definition of gap_C *)
gap_G := (rs, z, xt, par) -> RS_FACTOR^2/8 * xt^2/rs^2:

f_kcis := (rs, z, xt, xs0, xs1, ts0, ts1) ->
  + f_gap(rs, z, xt)
  - xs0^2/(8*ts0) * (1 + z)/2 * f_gap(rs,  1, xs0)
  - xs1^2/(8*ts1) * (1 - z)/2 * f_gap(rs, -1, xs1):

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


with(LinearAlgebra):
with(Groebner):

# Exterior powers of matrices (implicitly using lexicographic ordering
# of the standard bases of exterior powers of R^n).

exterior_power := proc(k::nonnegint,A)
 local m,n,S,T,s,t;
 m,n := Dimension(A);
 S := combinat[choose](m,k);
 T := combinat[choose](n,k);
 Matrix([seq([seq(Determinant(SubMatrix(A,s,t)),t in T)],s in S)]);
end:

# If S is a subset of {1,..,n} then we have an associated shuffle
# permutation of {1,..,n}.  The next function computes the signature.

shuffle_sgn := proc(n,S)
 local k,T,ST;
 k := nops(S);
 T := sort([op({seq(i,i=1..n)} minus S)]);
 ST := [op(S),op(T)];
 return signum(mul(mul(ST[j]-ST[i],j=i+1..n),i=1..n));
end:

# Given a matrix A we get an induced map of Koszul algebras.  Each
# Koszul algebra has a natural Frobenius form, with using which we
# get a kind of dual map in the opposite direction, which is computed
# by the function below.  For a square matrix A, the composite of the
# k'th exterior power and the k'th koszul adjoint (in either order)
# is multiplication by det(A).

koszul_adjoint := proc(k::nonnegint,A)
 local m,n,M,N,S,T,Sc,Tc,Se,Te,s,t,i,j;
 m,n := Dimension(A);
 M := {seq(i,i=1..m)};
 N := {seq(j,j=1..n)};
 S := combinat[choose](m,k);
 T := combinat[choose](n,k);
 Sc := map(s -> sort([op(M minus {op(s)})]),S);
 Tc := map(t -> sort([op(N minus {op(t)})]),T);
 Se := [seq([op(S[i]),op(Sc[i])],i=1..nops(S))];
 Se := map(u -> signum(mul(mul(u[j]-u[i],j=i+1..m),i=1..m)),Se);
 Te := [seq([op(T[i]),op(Tc[i])],i=1..nops(T))];
 Te := map(u -> signum(mul(mul(u[j]-u[i],j=i+1..n),i=1..n)),Te);

 M := Matrix(nops(T),nops(S));
 for i from 1 to nops(S) do
  for j from 1 to nops(T) do
   M[j,i] := Determinant(SubMatrix(A,Sc[i],Tc[j])) * Se[i] * Te[j];
  od:
 od:

 return M;
end:

# A list u of length n in a ring R gives a differential on the
# Koszul algebra of R^n.  The function below gives the matrix of
# this differential with respect to the standard bases of the
# k'th and (k-1)'th exterior powers of R^n.

koszul_d := proc(k::posint,u)
 local n,S,T,s,t,i,j,MT,M;
 n := nops(convert(u,list));
 S := combinat[choose](n,k);
 T := combinat[choose](n,k-1);
 MT := table():
 for s in S do
  for t in T do
   MT[t,s] := 0;
  od:
  for i from 1 to k do
   t := [seq(s[j],j=1..i-1),seq(s[j],j=i+1..k)];
   MT[t,s] := (-1)^(i-1) * u[s[i]];
  od;
 od:
 M := Matrix([seq([seq(MT[T[i],S[j]],j=1..nops(S))],i=1..nops(T))]);
 return M;
end:

# koszul_p can be set equal to a prime number if we want to work in that
# characteristic.

koszul_p := infinity;

koszul_pmod := (x) -> `if`(koszul_p=infinity,x,mods(x,koszul_p)):

# The function below sets up a number of global variables.  The
# original v can be supplied as a list.  Then v_vec will be the corresponding
# row vector.  Also u_vec will be the vector of variables x[i], and w_vec
# will be the vector of powers x[i]^h, where h is minimal such that x[i]^h
# lies in I = (v[1],...,v[n])  for all i.  Next, A and B will be matrices with
# u_vec = v_vec.A and v_vec = w_vec.B, which witnesses the inclusions
# (x[1]^(h),...,x[n]^(h)) <= I <= (x[1],...,x[n]).  These matrices induce
# morphisms of Koszul complexes alpha : K(u) ->K(v) and beta: K(v)->K(w).  It
# is easy to understand K(u) and K(w) in particular,  they only have  homology
# in degree zero.  All three complexes can be regarded as commutative
# Frobenius algebras in the category of chain complexes, so there are adjoint
# morphisms alpha^! : K(v) -> K(u)  and beta^! : K(w) -> K(v).  The idea is
# to use these to show that K(v) also has homology concentrated in degree zero.

koszul_setup := proc(v)
 global n,u_vec,v_vec,w_vec,x_vec,x_vars,Iv,Mv,Nv,
        soc_u,soc_v,soc_w,A,B,p;
 local a,b,c,i,h,v0,v1,x0,x1,char;
 n := nops(v);
 v_vec := Transpose(Vector(v));
 x_vec := Transpose(<seq(x[i],i=1..n)>);
 w_vec := x_vec;
 soc_w := 1;
 x_vars := tdeg(seq(x[i],i=1..n));

 a := table();
 v0 := v_vec;
 v1 := v_vec;
 for i from n to 1 by -1 do
  v0 := v1;
  v1 := subs(x[i]=0,v1);
  a[i] := koszul_pmod((v0 - v1)/x[i]);
 od;

 B := Matrix([seq(convert(a[i],list),i=1..n)]);
 soc_v := koszul_pmod(Determinant(B));
 char := `if`(koszul_p=infinity,NULL,characteristic = koszul_p);

 Iv,Mv := Basis(convert(v,list),x_vars,output=extended,char);
 Mv := Transpose(Matrix(Mv));
 Nv := (z) -> koszul_pmod(NormalForm(z,Iv,x_vars,char));

 h := 1;
 x0 := map(Nv,convert(x_vec,list));
 x1 := x0;
 while h < 100 and x1 <> [0$n] do
  h := h+1;
  x1 := map(Nv,x0 *~ x1);
 od;

 if h >= 100 then
  error("Variables are not nilpotent mod given ideal");
 fi;

 u_vec := Transpose(Vector([seq(x[i]^h,i=1..n)]));
 soc_u := mul(x[i]^(h-1),i=1..n);

 a := NULL;
 b := NULL;
 for i from 1 to n do
  unassign('b');
  c := NormalForm(x[i]^h,Iv,x_vars,b,char);
  a := a,b;
 od;

 A := map(expand,Mv . Transpose(Matrix([a])));
 NULL;
end:


func $foo (var %i i32) i32 {
  dowhile {
    dassign %i (
      mul i32 (dread i32 %i, dread i32 %i))
    dassign %i (
      add i32 (dread i32 %i, constval i32 1) )} (
        lt i32 i32 ( dread i32 %i, constval i32 10) )
  return ( constval i32 0 )
}
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


# # Draw weak and strong Bruhat diagram
# # by Shizuo Kaji

# it requires "coxeter and weyl" and "poset" packages by J.Stembridge

# http://www.math.lsa.umich.edu/~jrs/maple.html

with(posets);
with(coxeter); with(weyl);
with(WeylOps):

# Draw weak (left or right) bruhat diagram
#
# Example:
# H,L := wbruhat(F4, {}, 'L')
# plot_poset(H, labels = L, stretch = 1)

wbruhat:=proc(R,roots::set:={}, lr::symbol:='L', upto::integer :=0)
             local H,i,j,w,newweyl,oldweyl,p,pos,wlabel,udim;
  udim := `if`(upto>0,upto,nops(pos_roots(R)));
  wlabel:=[[]]; oldweyl:=[[]];
  H:=NULL;
  while nops(wlabel[-1])<udim and nops(oldweyl)>0 do
    newweyl:=[];
  	for i  from 1 to nops(oldweyl) do
	    for j in {$1..rank(R)} minus roots do
	    	w:=`if`(lr='L',reduce([j,op(oldweyl[i])],R),reduce([op(oldweyl[i]),j],R));
			if nops(w)=nops(oldweyl[i])+1 then
				if not member(w, newweyl, 'pos') then
					H:=H, [nops(wlabel)-nops(oldweyl)+i, nops(wlabel)+nops(newweyl)+1];
					newweyl:=[op(newweyl), w];
				else
					H:=H, [nops(wlabel)-nops(oldweyl)+i, nops(wlabel)+pos];
				end if;
			end if;
	    end do;
	end do;
    wlabel:=[op(wlabel), op(newweyl)]; oldweyl:=newweyl;
  end do;
  return {H},table([seq(i = convert(wlabel[i], 'string'), i = 1 .. nops(wlabel))]):
end proc:

# Draw strong bruhat diagram
#
# Example:
# H,L,E := wbruhat(F4, {}, 3)
# plot_poset(H, labels = L, stretch = 1)
# E contains edge labeling

sbruhat := proc (R, roots::set:={}, upto::integer:=0)
local H, w, r, v, i, j, beta, pos, newvects, newreps, vects,
    len, reps, oldvects, oldreps, edge, udim,B,P;

    B := base(R); r := nops(B); P:=pos_roots(R);
    udim := `if`(upto>0,upto,nops(P));
	newvects := [add(weights(R)[i], i={$1..r} minus roots)];
    newreps := []; reps := [[]]; vects := newvects;

    for len from 1 to udim do;
		oldvects := newvects; oldreps := [newreps];
		newvects := []; newreps := NULL;
		for j to nops(oldvects) do
			for i to r do
				if 0 < iprod(B[i], oldvects[j]) then
					v := reflect(B[i], oldvects[j]);
					if not member(v, newvects) then
						newvects := [op(newvects), v];
						newreps := newreps, reduce([i, op(oldreps[j])], R)
					end if
				end if
			end do
		end do;
		if newreps=NULL then break; end if;
        reps := [op(reps), newreps];
        vects := [op(vects), op(newvects)];
    end do;

    H:= NULL;
    for j from 1 to nops(vects) do
        for beta in P do
            if iprod(beta,vects[j])>0 then
                v:=reflect(beta,vects[j]);
                if member(v,vects,'pos') then
                    edge[j,pos]:=root_coords(beta,R);
                    H:= H, [j,pos];
                end if;
            end if;
        end do;
    end do;
    return {H},table([seq(i=[i,reps[i]],i=1..nops(reps))]),edge;
end proc;

# check if v is minimal w.r.t. a reflection subgroup;
has_descent:=proc(w::list,refsub_gen::set,R) local ref;
  for ref in refsub_gen do
    if nops(reduce([op(w),op(ref)],R))<nops(w) then return true; end if;
 end do;
 return false;
end proc:

# reduced word w.r.t. a reflection subgroup
ref_reduce:=proc(w::list,refsub_gen::set,R) local u,v,neww,is_min;
    neww:=reduce(w,R);
    is_min:=false;
    while is_min=false do;
        is_min:=true;
        for u in refsub_gen do
            v:=reduce([op(neww),op(u)],R);
            if nops(v)<nops(neww) then
                neww:=v;
                is_min:=false;
            end if;
        end do;
    end do;
    return neww;
end proc:

# strong bruhat graph w.r.t. a reflection subgroup geenrated by
# (non-simple) roots
refbruhat:=proc(R,refsub::set:={},upto::integer:=0) local H,i,j,r,u,v,w,len,
    reps,newreps,oldreps,vects,newvects,oldvects,refsub_gen,udim,pos,ref,P,B,edge;
    B:=base(R); r:=rank(R);
    P:=pos_roots(R);
    udim := `if`(upto>0,upto,nops(P));

    refsub_gen:={};
    for ref in refsub do;
        vec2fc(reflect(ref,interior_pt(R)),B,'w');
        refsub_gen:={op(refsub_gen),w};
    end do;

    # enumerate reduced words
	newvects := {interior_pt(R)};
    reps := [[]]; newreps := reps; vects := newvects;

    for len from 1 to udim do;
		oldvects := newvects; oldreps := newreps;
		newvects := []; newreps := [];
		for j to nops(oldvects) do
			for i to r do
				if 0 < iprod(B[i], oldvects[j]) then
                    v := reflect(B[i], oldvects[j]);
                    w := reduce([i, op(oldreps[j])], R);
					if not member(v, newvects) then
                        if not has_descent(w,refsub_gen,R) then
                            newreps := [op(newreps), w];
                            newvects := [op(newvects), v];
                        end if;
					end if
				end if
			end do
		end do;
		if newreps={} then break; end if;
        reps := [op(reps), op(newreps)];
        vects := [op(vects), op(newvects)];
    end do;

    # edges
    H:=NULL;
    for j from 1 to nops(vects) do;
        for ref in P do
            if iprod(ref,vects[j])<0 then next; end if;
            vec2fc(reflect(ref,vects[j]),R,'w');
            w:=ref_reduce(w,refsub_gen,R):
            member(w,reps,'pos');
            if j<pos then
                if assigned(edge[j,pos]) then
                    edge[j,pos]:=[op(edge[j,pos]),root_coords(ref,R)];
                else
                    edge[j,pos]:=[root_coords(ref,R)];
                    H:=H, [j,pos];
                end if
            end if;
        end do;
    end do;
    return {H},table([seq(i = [i,reps[i]], i = 1 .. nops(reps))]),edge:
end proc:


isSectorValid:= proc(n, mbar, mubar, mbarbar)
	local result, debug;
	#Tells you wether the sector is empty or not
	if n < mbar*(mbar-1)/2 + mubar*(mubar-1)/2 then
		result:= false;
		debug:= "not enough boxes";
	end if:
	return result;
end proc:

genN1spart:= proc(n,m)
	local sparts;
	sparts:= genN2spart(n,0, m,0);
	if sparts = [[],[],[],[]] then return [[],[]]; end if;
	sparts:= map(x-> x[3..4], sparts);
	return sparts;
end proc:

isSpartValid:= proc(spart, debug:=0) local spartphi, spartthe, spartzed, spartpt;
	#tells you wether a spart is valid or not.
	if type(spart, list) <> true then
		return false;
	end if;
	if nops(spart) <> 4 then
			return false;
		end if;
		#Some local vars
		spartpt :=  spart[1];
		spartphi:=  spart[2];
		spartthe:=  spart[3];
		spartzed:=  spart[4];
		#Conditions on constituting partitions
		if MakeUnique(sort(spartphi)) <> sort(spartphi) then return false; end if;
		if MakeUnique(sort(spartthe)) <> sort(spartthe) then return false; end if;
		if min(FlattenOnce(spart)) < 0 then return false; end if;
		return true;
end proc:

giveSpartSector:= proc(spart::pN2spart)
		local n, mbar, mubar, mbarbar;
	#Takes a spart and returns the sector
		n := add(k, k in Flatten(spart));
		mbarbar:= nops(spart[1]);
		mbar:= nops(spart[2]);
		mubar:= nops(spart[3]);
		return [n, mbar, mubar, mbarbar];
end proc:

genN2spart:= proc(n, mbar, mubar, mbarbar, mode:=[1,2,3])
	local degreePT, ptSparts, spartPhi, spartThe, spartZed, degreePhi, degreeThe, degreeZed, sparts, newsparts, T, phiSparts, thetaSparts, zedSparts, part_of_n, ones_list;
	#Returns all the spart in a given sector
	#Initializing the number of boxes in each subpart
	sparts:= [];
	degreePT := n -mubar*(mubar-1)/2 - mbar*(mbar-1)/2;
	degreePhi:= n - degreePT;
	degreeThe:= n-degreePhi;
	degreeZed:= 0;
	if degreePT < 0 then return [[],[],[],[]]; end if;
	while degreePT >=0 do
		ptSparts:= partition(degreePT+mbarbar);
		ptSparts:= map(x-> if nops(x) <> mbarbar then NULL; else x; end if, ptSparts);
		ones_list:= map(x-> [seq(1, j=1..nops(x))], ptSparts);
		ptSparts:= ptSparts - ones_list;
		ptSparts:= map(x-> Reverse(x), ptSparts);

		degreePhi:= n - degreePT;
		while degreePhi >= mbar*(mbar-1)/2 do
			#All the dispart with degreePhi starting High
			phiSparts:=genSpartDist(degreePhi,mbar);

			degreeThe:=n-degreePhi-degreePT;
			while degreeThe >= mubar*(mubar-1)/2 do
				degreeZed:= n - degreePhi - degreeThe -degreePT;

				thetaSparts:= genSpartDist(degreeThe,mubar);
				#zedSparts:= Reverse(partition(degreeZed));
				part_of_n:= partition(degreeZed);
				zedSparts:= map(x-> Reverse(x), part_of_n);
				#Update the list of sparts
				T:=cartprod([ptSparts, phiSparts, thetaSparts, zedSparts]);
				newsparts:= [];
				while not T[finished] do newsparts:= [op(newsparts),T[nextvalue]()] end do;
				sparts:= [op(sparts), op(newsparts)];

				degreeThe:= degreeThe-1;
			end do:
			degreePhi:= degreePhi-1;
		end do:
	degreePT:= degreePT-1;
	end do:
return(spart_sort(sparts, mode));
end proc:

spart_sort:= proc(sparts, mode:=[1,2,3])
	local scores, k, j, out, perms, dom_score;
	scores:=[];
	for k in sparts do
		dom_score:=add(j, j in map(x->if `<` = sCompareDominance(k, x, mode) then 1; else 0; end if, sparts));
		scores:=[op(scores), dom_score];
	end do:
	perms:=sort(scores, output=permutation);
	out:= map(x->sparts[x], perms);
	return out;
end proc:

super_pol_sort:= proc(expr, the_symbol, sector, mode:=[1,2,3])
	local sort_vec;
	sort_vec:= map(x-> the_symbol[op(x)], genN2spart(op(sector), mode));
	return sort(expr, sort_vec);
end proc:

list_sort:= proc(in1, in2)
	if sCompareDominance([op(in1)], [op(in2)]) = `>` then return true; else return false; end if;
end proc:

genSpartDist:=proc(n,ell, debug:=0)
		local part_list, one_list;
	#Generates all the sparts with distinct parts including the zeros
	part_list:= Reverse(partition(n+ell));
	if debug <> 0 then print(part_list); end if;
		part_list:= map(x-> if nops(x) <> ell then NULL; else x; end if, part_list);
	if debug <> 0 then print(part_list); end if;
		part_list:= map(x-> if FindRepetitions(x) <> [] then NULL; else Reverse(x); end if, part_list);
	if debug <> 0 then print(part_list); end if;
	one_list:= map(x-> [seq(1, i=1..(nops(x)))], part_list);
		#part_list:= map(x-> Reverse(x - [seq(1, i=1..nops(x))]), part_list);
	part_list:= part_list - one_list;
		return part_list;
end proc:

switch_notation:= proc(spart, numbering:=a, uniquenum:=0, mode:=[1,2,3])
	local phis, thetas, phithetas, zeds, Lambda, pts, newLambda, counter,k;
	# exchange a spart for the other notation ( [] [] [] ) --> ( 4T, 3C, ...)
	pts := spart[1];
	if nops(spart[1])<>0 then pts := map(x-> [x, "TC", numbering^(x+1)], pts); end if;
	phis:= spart[2];
	if nops(spart[2])<>0 then phis:= map( x-> [x,"T",numbering^(x)], phis); end if;
	thetas:= spart[3];
	if nops(spart[3])<>0 then thetas:= map(x-> [x,"C", numbering^(x)], thetas); end if;
	zeds:= spart[4];
	if nops(spart[4])<>0 then zeds:= map(x-> [x,"", numbering^(x)], zeds); end if;
	Lambda:= Reverse(sort([op(pts),op(phis), op(thetas), op(zeds)]));
	if uniquenum=0 then
		newLambda:=[];
		counter:=1;
		for k from 1 to nops(Lambda) do
			if (op(2,Lambda[k]) = "T") or (op(2,Lambda[k]) = "C") then
				newLambda:=[op(newLambda), [op(Lambda[k]), numbering[counter]]];
				counter:= counter + 1;
			else
				newLambda:= [op(newLambda), [op(Lambda[k]), numbering]];
			end if;
		end do:
		Lambda:=newLambda;
		#Lambda:= map(x->
		#if (op(2,Lambda[x]) = "T") or (op(2,Lambda[x]) = "C")  then
		#[op(Lambda[x]), numbering[x]];
		#else
		#[op(Lambda[x]), numbering]; end if, [seq(k, k=1..nops(Lambda))]);
	else
		Lambda:= map(x->
		[op(Lambda[x]), numbering[x]]
		, [seq(k, k=1..nops(Lambda))]);
	end if;
	if mode <> [1,2,3] then
		Lambda:= sort_switch(Lambda, mode);
	end if;
	return Lambda;
end proc:

sort_switch:= proc(sw_spart, mode:=[1,2,3])
	local orig, perm, sublist, switched;
	orig:= ["TC", "T", "C"];
	perm:= subs({1="TC", 2="T", 3="C"}, mode);
	sublist:= {perm[1]="C0", perm[2]="B0", perm[3]="A0"};
	switched:= subs(sublist, sw_spart);
	switched:= Reverse(sort(switched));
	sublist:= {"C0"=perm[1], "B0"=perm[2], "A0"=perm[3]};
	switched:= subs(sublist, switched);
	return switched;
end proc:

reverse_notation:= proc(spart)
	local phis, thetas, phithetas, zeds, Lambda;
	phis:= 		Reverse(sort(map(x-> if x[2] = "T" then x[1]; else NULL; end if, spart)));
	thetas:= 	Reverse(sort(map(x-> if x[2] = "C" then x[1]; else NULL; end if, spart)));
	phithetas:= 	Reverse(sort(map(x-> if x[2] = "TC" then x[1]; else NULL; end if, spart)));
	zeds:= 		Reverse(sort(map(x-> if x[2] = "" then x[1]; else NULL; end if, spart)));
	Lambda:=	[phithetas,phis,thetas,zeds];
	return Lambda;
end proc:

#n-tupple aka compositions
#compositions
compare_bruhat:= proc(composition1, composition2)
	local compart, cumul_part1, cumul_part2, max_length, is1greater2, is1smaller2;
	# compare the weight of two composition, not really the bruhat order, it's the order defined in Baker, T. H., & Forrester, P. J. (1996). Non-Symmetric Jack Polynomials and Integral Kernels, 33. Quantum Algebra. Retrieved from http://arxiv.org/abs/q-alg/9612003
	compart:= compare_dominance(Reverse(sort(composition1)), Reverse(sort(composition2)));
	if composition1 = composition2 then return `=`; end if;
	if compart = `>` then
		return compart;
	elif compart = `<` then
		return compart;
	elif compart = `Non-comparable` then
		return compart;
	elif compart= `=` then
		cumul_part1:= PartialSums(composition1);
		cumul_part2:= PartialSums(composition2);
		max_length:= min(nops(cumul_part1), nops(cumul_part2));
		is1greater2 := map(x-> if op(x, cumul_part1) >= op(x, cumul_part2) then true; else false; end if, [seq(i, i=1..max_length)]);
		is1smaller2 := map(x-> if op(x, cumul_part1) <= op(x, cumul_part2) then true; else false; end if, [seq(i, i=1..max_length)]);

		if false in is1greater2 then
			if false in is1smaller2 then
						return `Non-comparable`;
				else
						return `<`;
			end if;
		else
				return `>`;
			end if;
	end if;
return `ErrorInBruhat`;
end proc:

genCompositions:=proc(weight, complength)
	local allcomp;
	allcomp:= [seq(op(composition(weight,k)),k=1..complength)];
	allcomp:= map(x-> if nops(x) < complength then [op(x),seq(0, k=1..(complength-nops(x)))]; else x; end if, allcomp);
	allcomp:= map(x-> permute(x), allcomp);
	allcomp:= FlattenOnce(allcomp);
	allcomp:= MakeUnique(allcomp);
	return allcomp;
end proc:

give_smallerComps:= proc(composition)
	local weight, allcomp, smallercomp;
	weight:= add(k, k in composition);
	allcomp:= genCompositions(weight, nops(composition));
	smallercomp:= map(x-> if compare_bruhat(composition, x) = `>` then x; else NULL; end if, allcomp);
	return smallercomp;
end proc:

compare_dominance:= proc(part1, part2, TEST:=NULL)
	local cumul_part1, cumul_part2, max_length, is1greater2, is1smaller2;
	#Normal dominance ordering comparision
	if part1=part2 then return `=`; end if;
	if add(i,i in part1) <> add(i,i in part2) then return `Non-comparable`; end if;
	cumul_part1:= PartialSums(part1);
	cumul_part2:= PartialSums(part2);
	if TEST <> NULL then
		if nops(part1) > nops(part2) then
			return `>`;
		else
			return `<`;
		end if;
	end if;
	max_length:= min(nops(cumul_part1), nops(cumul_part2));
	is1greater2 := map(x-> if op(x, cumul_part1) >= op(x, cumul_part2) then true; else false; end if, [seq(i, i=1..max_length)]);
	is1smaller2 := map(x-> if op(x, cumul_part1) <= op(x, cumul_part2) then true; else false; end if, [seq(i, i=1..max_length)]);
#debug

	if false in is1greater2 then
		if false in is1smaller2 then
			return `Non-comparable`;
		else
			return `<`;
		end if;
	else
		return `>`;
	end if;
end proc:

ell:= proc(spart)
	local ell_out;
	#Returns the length of a spart
	ell_out:= nops(Flatten(spart));
	return ell_out;
end proc:

lambda_box:= proc(spart)
	#removes circles from diagram
	return eliminate_zeros(sort(Flatten(spart), `>`));
end proc:

lambda_phitheta:= proc(spart)
	local phis, thetas, zeds, pts, ones;
	#removes h-circle, convert v-circle into boxes
	pts:= spart[1];
	ones:= [seq(1, k=1..nops(pts))];
	pts:= pts+ones;
	phis:= eliminate_zeros(spart[2]);
	thetas:= eliminate_zeros(spart[3]);
	zeds:= spart[4];
	return sort(Flatten([pts, phis, thetas, zeds]), `>`);
end proc:

lambda_phitheta_phi:= proc(spart)
	local pts, phis, thetas, zeds, ones;
	#removes h-circle, convert v-circle into boxes
	pts:= spart[1];
	ones:= [seq(1, k=1..nops(pts))];
	pts:= pts+ones;
	phis:= spart[2];
	ones:= [seq(1, k=1..nops(phis))];
	phis:= phis+ones;
	thetas:= eliminate_zeros(spart[3]);
	zeds:= spart[4];
	return sort(Flatten([pts, phis, thetas, zeds]), `>`);
end proc:

lambda_phitheta_phi_theta:= proc(spart)
	local pts, phis, thetas, zeds, ones;
	#removes h-circle, convert v-circle into boxes
	pts:= spart[1];
	ones:= [seq(1, k=1..nops(pts))];
	pts:= pts+ones;
	phis:= spart[2];
	ones:= [seq(1, k=1..nops(phis))];
	phis:= phis+ones;
	thetas:= spart[3];
	ones:= [seq(1, k=1..nops(thetas))];
	thetas:= thetas+ones;
	zeds:= spart[4];
	return sort(Flatten([pts, phis, thetas, zeds]), `>`);
end proc:

lambda_circle:= proc(spart, circs)
	local sector, pts, phis, thetas, zeds, partition, theseq;
	sector:= giveSpartSector(spart);
	pts:= spart[1];
	phis:= spart[2];
	thetas:= spart[3];
	zeds := spart[4];
	if 1 in circs then
		theseq:= [seq(1, k=1..sector[-1])];
		pts:= pts+theseq;
	end if:
	if 2 in circs then
		theseq:= [seq(1, k=1..sector[2])];
		phis:= phis+theseq;
	end if:
	if 3 in circs then
		theseq:= [seq(1, k=1..sector[3])];
		thetas:= thetas+theseq;
	end if:
	partition:= Flatten([pts, phis, thetas, zeds]);
	partition:= Reverse(sort(partition));
	return eliminate_zeros(partition);
end proc:

star_quatuor:= proc(spart, mode:=[1,2,3])
	local gradation, quatuor;
	#Self explanatory
	#Allowed modes:
	# [TC, T, C]=[1,2,3](Normal), [TC, C, T]=[1,3,2], [T, C, TC]=2,3,1, [T, TC, C]=[2,1,3]...
	gradation:= [ seq(mode[1..k], k=0..3) ];
	quatuor:= map(x-> lambda_circle(spart,x), gradation);
	return quatuor;
	#return [ lambda_box(spart), lambda_phitheta(spart), lambda_phitheta_phi(spart), lambda_phitheta_phi_theta(spart)];
end proc:

eliminate_zeros:= proc(a_list)
	#Removes 0's from a list
	return map(x-> if x = 0 then NULL; else x; end if, a_list);
end proc:

conjugate_part:= proc(part)
	local eat_part, new_part, len, ones;
	eat_part:= part;
	new_part:= [];
	len := nops(part);
	while len <> 0 do
		len := nops(eat_part);
		ones := [seq(1,j=1..len)];
		eat_part := eliminate_zeros(eat_part - ones);
		if len <> 0 then new_part := [op(new_part), len]; end if;
	end do:
	return new_part;
end proc:

sCompareDominance:= proc(spart1, spart2, mode:=[1,2,3])
	local quatuor1, quatuor2, quatuor_dom; option remember;
	#Compares the dominance of two sparts
	if spart1 = spart2 then return `=`; end if;
	quatuor1:= star_quatuor(spart1, mode);
	quatuor2:= star_quatuor(spart2, mode);
	quatuor_dom:=map(x-> compare_dominance(quatuor1[x], quatuor2[x]), [1,2,3,4]);
	if 	`Non-comparable` in quatuor_dom then return `Non-comparable`;
	elif 	`>` in quatuor_dom and `<` in quatuor_dom then return `Non-comparable`;
	elif	`>` in quatuor_dom then return `>`;
	elif	`<` in quatuor_dom then return `<`;
	else	return "This should not happen, error in sCompareDominance";
	end if;
end proc:

sKeep_smaller_sparts:= proc(spart, sparts, mode:=[1,2,3]) local compared_dominance, list_indices, smaller_sparts;
	#Given a spart and a list of sparts, returns all the sparts within the set that are smaller than then one given
	compared_dominance:= map(x-> sCompareDominance(spart, x, mode), sparts);
	list_indices:= [seq(k, k=1..nops(sparts))];
	smaller_sparts:= map(x-> if compared_dominance[x] = `>` then sparts[x]; else NULL; end if, list_indices);
	return smaller_sparts;
end proc:

give_greatest_spart:= proc(sparts, mode:=[1,2,3]) local k, dominance_of_spart;
	#Given a set of sparts, returns the highest one in the dominance ordering
	for k in sparts do
		dominance_of_spart:=map(x-> if x <> k then sCompareDominance(k, x, mode); else NULL; end if, sparts);
		if MakeUnique(dominance_of_spart) = [`>`] then return k; end if;
	end do:
end proc:

give_smallest_spart:= proc(sparts, mode:=[1,2,3]) local k, dominance_of_spart;
	#Given a set of sparts, returns the lowest one in the dominance ordering
	for k in sparts do
		dominance_of_spart:=map(x-> if x <> k then sCompareDominance(k, x, mode); else NULL; end if, sparts);
		if MakeUnique(dominance_of_spart) = [`<`] then return k; end if;
	end do:
end proc:

arm_part:= proc(i,j,part)
	#i is the row
	#j is the column
	return part[i]-j;
end proc:
co_arm_part:= proc(i,j,part)
	return j-1;
end proc:
co_leg_part:= proc(i,j,part)
	return i-1;
end proc:
leg_part:= proc(i,j,part)
	#i is the row
	#j is the column
	return conjugate_part(part)[j] - i;
end proc:
Jack_norm:= proc(spart, mode:=[1,2,3])
	local quatuor, spart0, spart1, spart2, spart3, spart_sector, M3, switched, nb_parts, B0, Btc, Bt, Bc, B1,B2,B3, ncoeff0, ncoeff1, ncoeff2, ncoeff3, the_coeff, pt_part, pt_distPart, zeta1;
	spart_sector:= giveSpartSector(spart);
	quatuor := star_quatuor(spart, mode);
	M3:= spart_sector[2] + spart_sector[3] + spart_sector[4];
	spart0:= quatuor[1];
	spart1:= quatuor[2];
	spart2:= quatuor[3];
	spart3:= quatuor[4];
	switched := switch_notation(spart, a, 0, mode);
	nb_parts := nops(switched);
	B0 := map(x-> if switched[x][2] = "" then seq([x,j], j=1..switched[x][1]); else NULL; end if, [seq(k, k=1..nb_parts)]);
	Btc := map(x-> if switched[x][2] = "TC" then seq([x,j], j=1..switched[x][1]); else NULL; end if, [seq(k, k=1..nb_parts)]);
	Bt := map(x-> if switched[x][2] = "T" then seq([x,j], j=1..switched[x][1]); else NULL; end if, [seq(k, k=1..nb_parts)]);
	Bt := map(x-> if x[2]-1 in spart[2] then NULL; else x; end if, Bt);
	Bc := map(x-> if switched[x][2] = "C" then seq([x,j], j=1..switched[x][1]); else NULL; end if, [seq(k, k=1..nb_parts)]);
	Bc := map(x-> if x[2]-1 in spart[3] then NULL; else x; end if, Bc);
	if mode[1] = 1 then
		B1:= Btc;
	elif mode[1] = 2 then
		B1:= Bt;
	elif mode[1] = 3 then
		B1:= Bc;
	end if;
	if mode[2] = 1 then
		B2:= Btc;
	elif mode[2] = 2 then
		B2:= Bt;
	elif mode[2] = 3 then
		B2:= Bc;
	end if;
	if mode[3] = 1 then
		B3:= Btc;
	elif mode[3] = 2 then
		B3:= Bt;
	elif mode[3] = 3 then
		B3:= Bc;
	end if;
	ncoeff0:= map(x->(leg_part(op(x),spart3) + alpha*(arm_part(op(x), spart0) + 1))/(leg_part(op(x),spart0) + 1 + alpha*arm_part(op(x), spart3)), B0);
	ncoeff1:= map(x->(leg_part(op(x),spart0) + alpha*(arm_part(op(x), spart0) + 1))/(leg_part(op(x),spart1) + 1 + alpha*arm_part(op(x), spart3)), B1);
	ncoeff2:= map(x->(leg_part(op(x),spart1) + alpha*(arm_part(op(x), spart0) + 1))/(leg_part(op(x),spart2) + 1 + alpha*arm_part(op(x), spart3)), B2);
	ncoeff3:= map(x->(leg_part(op(x),spart2) + alpha*(arm_part(op(x), spart0) + 1))/(leg_part(op(x),spart3) + 1 + alpha*arm_part(op(x), spart3)), B3);
	the_coeff:= mul(x, x in ncoeff0);
	the_coeff:= the_coeff*mul(x, x in ncoeff1);
	the_coeff:= the_coeff*mul(x, x in ncoeff2);
	the_coeff:= the_coeff*mul(x, x in ncoeff3);
	pt_part:= spart[1];
	pt_distPart:= {op(pt_part)};
	zeta1:= mul(factorial(Occurrences(i,pt_part)), i in pt_distPart);
	return factor(1/zeta1*alpha^(M3)*the_coeff);
end proc:

down_hook:= proc(spart, mode:=[1,2,3])
	local quatuor, spart0, spart1, spart2, spart3, spart_sector, M3, switched, nb_parts, B0, Btc, Bt, Bc, B1,B2,B3, ncoeff0, ncoeff1, ncoeff2, ncoeff3, the_coeff, pt_part, pt_distPart, zeta1;
	spart_sector:= giveSpartSector(spart);
	quatuor := star_quatuor(spart, mode);
	M3:= spart_sector[2] + spart_sector[3] + spart_sector[4];
	spart0:= quatuor[1];
	spart1:= quatuor[2];
	spart2:= quatuor[3];
	spart3:= quatuor[4];
	switched := switch_notation(spart, a, 0, mode);
	nb_parts := nops(switched);
	B0 := map(x-> if switched[x][2] = "" then seq([x,j], j=1..switched[x][1]); else NULL; end if, [seq(k, k=1..nb_parts)]);
	Btc := map(x-> if switched[x][2] = "TC" then seq([x,j], j=1..switched[x][1]); else NULL; end if, [seq(k, k=1..nb_parts)]);
	Bt := map(x-> if switched[x][2] = "T" then seq([x,j], j=1..switched[x][1]); else NULL; end if, [seq(k, k=1..nb_parts)]);
	Bt := map(x-> if x[2]-1 in spart[2] then NULL; else x; end if, Bt);
	Bc := map(x-> if switched[x][2] = "C" then seq([x,j], j=1..switched[x][1]); else NULL; end if, [seq(k, k=1..nb_parts)]);
	Bc := map(x-> if x[2]-1 in spart[3] then NULL; else x; end if, Bc);
	if mode[1] = 1 then
		B1:= Btc;
	elif mode[1] = 2 then
		B1:= Bt;
	elif mode[1] = 3 then
		B1:= Bc;
	end if;
	if mode[2] = 1 then
		B2:= Btc;
	elif mode[2] = 2 then
		B2:= Bt;
	elif mode[2] = 3 then
		B2:= Bc;
	end if;
	if mode[3] = 1 then
		B3:= Btc;
	elif mode[3] = 2 then
		B3:= Bt;
	elif mode[3] = 3 then
		B3:= Bc;
	end if;
	ncoeff0:= map(x->(leg_part(op(x),spart0) + 1 + alpha*arm_part(op(x), spart3)), B0);
	ncoeff1:= map(x->(leg_part(op(x),spart1) + 1 + alpha*arm_part(op(x), spart3)), B1);
	ncoeff2:= map(x->(leg_part(op(x),spart2) + 1 + alpha*arm_part(op(x), spart3)), B2);
	ncoeff3:= map(x->(leg_part(op(x),spart3) + 1 + alpha*arm_part(op(x), spart3)), B3);
	the_coeff:= mul(x, x in ncoeff0);
	the_coeff:= the_coeff*mul(x, x in ncoeff1);
	the_coeff:= the_coeff*mul(x, x in ncoeff2);
	the_coeff:= the_coeff*mul(x, x in ncoeff3);
	pt_part:= spart[1];
	pt_distPart:= {op(pt_part)};
	zeta1:= mul(factorial(Occurrences(i,pt_part)), i in pt_distPart);
	return factor(zeta1*the_coeff);
	#return the_coeff;
end proc:


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

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

(* type: work_mgga_c *)

par_n := 5:

gamma_x := 0.004:
par_x := [
    [  1.000, 0, 0],
    [  1.308, 0, 1],
    [  1.901, 0, 2],
    [  0.416, 1, 0],
    [  3.070, 1, 1]
]:

gamma_ss := 0.2:
par_ss := [
    [  1.000, 0, 0],
    [ -1.855, 0, 2],
    [ -5.668, 1, 0],
    [-20.497, 3, 2],
    [-20.364, 4, 2]
]:

gamma_os := 0.006:
par_os := [
    [  1.000, 0, 0],
    [  1.573, 0, 1],
    [ -6.298, 0, 3],
    [  2.535, 1, 0],
    [ -6.427, 3, 2]
]:

$define lda_x_params
$include "lda_x.mpl"
$include "b97mv.mpl"

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


inputfile := "AOC4-input.txt":
input := StringTools:-Split(FileTools:-Text:-ReadFile(inputfile), "\n"):
numbers := [parse(input[1])]:
input := map(StringTools:-Trim@StringTools:-Squeeze,input[3..-1]):
numboards := ceil( nops(input) / 6 );
theboards := [seq(1..numboards)]:

# create board and mark arrays for each bingo board
for i to numboards do
    tmp := map(s->map(parse, StringTools:-Split(s)),input[1..5]);
    boards[i] := Array(tmp,datatype=integer);
    marks[i] := Array(1..5, 1..5, 0, datatype=integer[1]);
    if i <> numboards then
        input := input[7..-1];
    else
        input := [];
    end if;
end do:

# find the location of n on each board and mark it
drawnumber := proc(n)
global boards, marks, theboards;
local i, loc;
    for i in theboards do
        if member(n, boards[i], 'loc') then
            marks[i][loc] := 1;
        end if;
    end do;
    return NULL;
end proc:

# check if board i has a bingo marked
checkbingo :=proc(i)
global marks;
    if max(ArrayTools:-AddAlongDimension(marks[i], 1)) = 5 then
        return true;
    elif max(ArrayTools:-AddAlongDimension(marks[i], 2)) = 5 then
        return true;
    else
        return false;
    end if;
end proc:

# first problem - find the board that will win FIRST
answer1 := FAIL:
for j to nops(numbers) while answer1 = FAIL do
    n := numbers[j];
    drawnumber(n);
    for i to numboards do
        if checkbingo(i) then
            answer1 := add(boards[i]-boards[i]*marks[i])*n;
            break;
        end if;
    end do;
end do:
answer1;

# second problem - find the board that will win LAST
answer2 := FAIL:
numbingos := 0:
for j to nops(numbers) while answer2 = FAIL do
    n := numbers[j];
    drawnumber(n);
    for i in theboards do
        if checkbingo(i) then
            if nops(theboards) = 1 then
                answer2 := add(boards[i]-boards[i]*marks[i])*n;
            end if;
            theboards := subs(i=NULL, theboards);
        end if;
    end do;
end do:
answer2;


myseries := series(sin(x), x = 0, 10);
poly := convert(myseries, polynom);

plotsetup(gif,plotoutput="plot.gif"):
plot(poly, x = -2*Pi .. 2*Pi, y = -3 .. 3);


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

`is_element/SEM` := (N::posint) -> (A::set) -> proc(eta)
 local AA,a,b,c,ok;
 global reason;

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

 AA := [seq(seq([a,b],b in A),a in A)];
 if {indices(eta)} <> {op(AA)} then
  reason := [convert(procname,string),"eta is not indexed by A^2",eta,AA];
  return false;
 fi;

 for a in A do
  for b in A do
   if eta[a,b] = 0 and a <> b then
    reason := [convert(procname,string),"eta does not separate a and b",a,b,eta];
    return false;
   fi;

   if eta[a,b] + eta[b,a] <> 0 then
    reason := [convert(procname,string),"eta is not antisymmetric at [a,b]",a,b,eta];
    return false;
   fi;

   for c in A do
    ok := `is_leq/E`(N)(0,eta[a,c]) or
          `is_leq/E`(N)(eta[a,b],eta[a,c]) or
          `is_leq/E`(N)(eta[b,c],eta[a,c]);
    if not(ok) then
     reason := [convert(procname,string),"min(0,eta[a,b],eta[a,c]) > eta[a,c]",a,b,c,eta];
     return false;
    fi;

    ok := `is_leq/E`(N)(eta[a,c],0) or
          `is_leq/E`(N)(eta[a,c],eta[a,b]) or
          `is_leq/E`(N)(eta[a,c],eta[b,c]);
    if not(ok) then
     reason := [convert(procname,string),"eta[a,c] > max(0,eta[a,b],eta[a,c])",a,b,c,eta];
     return false;
    fi;
   od;
  od;
 od;

 return true;
end;

`is_equal/SEM` := (N::posint) -> (A::set) -> proc(eta,zeta)
 local a,b;
 global reason;

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

 return true;
end:

`is_leq/SEM` := (N::posint) -> (A::set) -> proc(eta,zeta)
 local a,b;

 for a in A do
  for b in A do
   if not(`preceq/E`(N)(A)(eta[a,b],zeta[a,b])) then
    return false;
   fi;
  od;
 od;

 return true;
end:

`build/SEM` := (N::posint) -> (A::set) -> proc(s::list,u::list)
 local n,L,i,j,k,m,eta,a,b;

 n := nops(A);
 if nops(s) <> n or nops(u) <> n-1 then return FAIL; fi;
 if {op(s)} <> A then return FAIL; fi;

 L := table();
 for i from 1 to n do
  L[s[i]] := i;
 od:

 eta := table;

 for a in A do
  eta[a,a] := 0;
  for b in A do
   i := L[a];
   j := L[b];
   if i < j then
    m := min(seq(u[k],k=i..j-1));
    eta[a,b] :=  epsilon^m;
    eta[b,a] := -epsilon^m;
   fi;
  od;
 od;

 return eval(eta);
end:

`random_element/SEM` := (N::posint) -> (A::set) -> proc()
 local s,m,u,i;

 s := `random_element/ord`(A)();
 m := nops(A);
 u := [seq(rand(0..N-1)(),i=1..m-1)];
 return `build/SEM`(N)(A)(s,u);
end:

`list_elements/SEM` := (N::posint) -> proc(A::set)
 option remember;
 local S,U,s,u,m,i,j;

 S := `list_elements/ord`(A);
 U := [[]];
 m := nops(A);
 for i from 1 to m-1 do
  U := map(u -> seq([op(u),j],j=0..N-1),U);
 od:

 return [seq(seq(`build/SEM`(N)(A)(s,u),u in U),s in S)];
end:

`count_elements/SEM` := (N::posint) -> (A::set) ->
  nops(A)! * N^(nops(A) - 1);

`mu/F/SEM` := (N::posint) -> (A::set) -> proc(x)
 local eta,a,b,u,v,i;

 eta := table();
 for a in A do
  for b in A do
   u := x[b] -~ x[a];
   v := add(u[i] * epsilon^(i-1),i = 1..N);
   eta[a,b] := `lambda/P/E`(N)(v);
  od;
 od;

 return eval(eta);
end:

`sigma/SEM/F` := (N::posint) -> (A::set) -> proc(eta)
 local n,m,a,b,A1,x,u,i;

 n := table():

 for a in A do
  for b in A do
   n[a,b] := `is_leq/E`(N)(0,eta[a,b]);
  od;
 od;

 A1 := sort([op(A)],(a,b) -> n[a,b]);

 x := table():
 u := 0;
 m := nops(A1);
 x[A1[1]] := [0$N];

 for i from 2 to m do
  u := u + eta[A1[i-1],A1[i]];
  x[A1[i]] := [seq(coeff(u,epsilon,i),i=0..N-1)];
 od;

 return(eval(x));
end:


# Machine Learning

##
## Copyright (C) 2018 Maplesoft
## Authors:    Behzad Samadi <bsamadi@maplesoft.com>
## Created:    January 2018
## Version:    0.1
## Keywords:   Machine Learning, Maple, Code Generation, Reinforcement Learning, Gaussian Process Regression, Bayesian Optimizaiton
##
## Procedures:
##    Simulate
##

MachineLearning := module()
description "Machine learning";
option package;

export CostFunction,
       CovarianceMatrix,
       DotProduct,
       KernelFunction,
       Mean,
       Mean1D,
       Norm2,
       PDMatrixInverse,
       StandardDeviation,
       StandardDeviation1D,
       SquaredDistance,
       Simulate,
       SolveLT,
       SolveUT;

$include "Simulation/Simulate.mm"
$include "LinearAlgebra/DotProduct.mm"
$include "LinearAlgebra/Norm2.mm"
$include "LinearAlgebra/PDMatrixInverse.mm"
$include "LinearAlgebra/SolveLT.mm"
$include "LinearAlgebra/SolveUT.mm"
$include "GaussianProcess/CostFunction.mm"
$include "GaussianProcess/CovarianceMatrix.mm"
$include "GaussianProcess/KernelFunction.mm"
$include "GaussianProcess/Mean.mm"
$include "GaussianProcess/SquaredDistance.mm"
$include "GaussianProcess/StandardDeviation.mm"

end module; # MachineLearning


# Definitions for Robot Dynamics Code Generation
# Init
# Erstelle Definitionen für die Maple-Skripte zur Berechnung von Kinematik und Dynamik des Roboters
# Nutze Euler-Winkel (RPY-Konvention) zur Darstellung der Basisorientierung
#
# Quellen:
# [1] Sousa, C. D. and Cortesao, R.: Physical feasibility of robot base inertial parameter identification: A linear matrix inequality approach (2014)
# [2] Ayusawa, K. and Venture, G. and Nakamura, Y.: Identifiability and identification of inertial parameters using the underactuated base-link dynamics for legged multibody systems (2013)
# [3] Fujimoto, Y. and Obata, S. and Kawamura, A.: Robust biped walking with active interaction control between foot and ground (1998)
# [4] Khalil, W. and Kleinfinger, J.-F.: Minimum operations and minimum parameters of the dynamic models of tree structure robots (1987)
# [5] Ortmaier: Robotik I Vorlesungsskript
#
# Moritz Schappler, schappler@irt.uni-hannover.de, 2016-04
# (C) Institut fuer Regelungstechnik, Leibniz Universitaet Hannover
interface(warnlevel=0): # Unterdrücke die folgende Warnung.
restart: # Gibt eine Warnung, wenn über Terminal-Maple mit read gestartet wird.
interface(warnlevel=3):
# Funktion für Euler-Transformation aus Robotik-Repo laden (Pfad muss bekannt sein)
read("../robotics_repo_path"):
read(sprintf("%s/transformation/maple/proc_eulxyzjac", robotics_repo_path)):
# Lese Umgebungsvariable für Codegenerierung.
read "../robot_codegen_definitions/robot_env":
printf("Generiere Parameter für %s\n",robot_name):
# Lese allgemeine Definitionen für Floating-Base
read sprintf("../codeexport/%s/tmp/tree_floatb_twist_definitions", robot_name):
# Robotics Definitions
# Position und Orientierung der Basis (pelvis). Die Orientierung ist mit XYZ-Euler-Winkeln definiert.
# Eine Invertierung der Orientierungsdarstellung sollte nicht notwendig werden, von daher kein Problem mit Orientierungsrepräsentationssingularität.
# gem. [2], S. 4 X_base_t SE(3): Position und Orientierung.
NQB := 6:
X_base_t:=Matrix(6, 1, [rx_base(t),ry_base(t),rz_base(t),alphax_base(t), betay_base(t), gammaz_base(t)]):
X_base_s:=Matrix(6, 1, [rxs_base,rys_base,rzs_base,alphaxs_base, betays_base, gammazs_base]):
# Geschwindigkeit der Basis
# Twist: Verallgemeinerte Geschwindigkeit
V_base_t:=diff~(X_base_t, t):
V_base_s:=Matrix(6, 1, [vxs_base,vys_base,vzs_base,alphaDx_base, betaDy_base, gammaDz_base]):
# Zeitableitung davon
VD_base_t:=diff~(V_base_t, t):
VD_base_s:=Matrix(6, 1, [vDxs_base,vDys_base,vDzs_base,alphaDDx_base, betaDDy_base, gammaDDz_base]):
# Name der Methode für die Orientierungsdarstellung der Basis
base_method_name := "eulxyz":
# Umrechnung von der Ableitung der Basis-Orientierung zu Winkelgeschwindigkeiten:
# Nutze die Euler-XYZ-Konvention ("RPY").
# Siehe [5], Gl. (4.23)
T_basevel := eulxyzjac(X_base_t(4..6,1)):
# Verallgemeinerte Koordinaten, gem [2], S. 4, [3], S.1
NQ:=NQJ+NQB:
q_t := Matrix(NQ,1, <X_base_t, qJ_t>):
q_s := Matrix(NQ,1, <X_base_s, qJ_s>):
qD_t:= Matrix(NQ,1, <V_base_t, qJD_t>):
qD_s:= Matrix(NQ,1, <V_base_s, qJD_s>):
qDD_t:= Matrix(NQ,1, <VD_base_t, qJDD_t>):
qDD_s:= Matrix(NQ,1, <VD_base_s, qJDD_s>):
# MDH-Gelenkwinkel neu speichern (Definition der verallg. Koordinaten war dort noch nicht bekannt
theta := value(theta):
# Export
save q_t, q_s, qD_t, qD_s, qDD_t, qDD_s, qJ_t, qJ_s, qJD_t, qJD_s, qJDD_t, qJDD_s, g_world, X_base_t, X_base_s, V_base_t, V_base_s, VD_base_t, VD_base_s, qoffset, theta, alpha, d, a,v,b,beta, sigma,mu, M, r_i_i_Si, mr_i_i_Si, I_i_i, I_i_Si, PV2_vec, PV2_mat, robot_name, NQ,NQB,NQJ,NJ,NL, base_method_name, T_basevel, kintmp_t, kintmp_s, sprintf("../codeexport/%s/tmp/tree_floatb_eulxyz_definitions", robot_name):
save q_t, q_s, qD_t, qD_s, qDD_t, qDD_s, qJ_t, qJ_s, qJD_t, qJD_s, qJDD_t, qJDD_s, g_world, X_base_t, X_base_s, V_base_t, V_base_s, VD_base_t, VD_base_s, qoffset, theta, alpha, d, a,v,b,beta, sigma,mu, M, r_i_i_Si, mr_i_i_Si, I_i_i, I_i_Si, PV2_vec, PV2_mat, robot_name, NQ,NQB,NQJ,NJ,NL, base_method_name, T_basevel, kintmp_t, kintmp_s, sprintf("../codeexport/%s/tmp/tree_floatb_definitions", robot_name):


# This code sets up a toy model of the nonstandard product structure
# on the HKR character ring for V x V, where V is the groupoid of
# finite-dimensional F-vector spaces.

# We fix a number d > 0 (which should really be infinity).
# We consider the set A1 of tables indexed by natural numbers u < d,
# and the set A2 indexed by pairs (u,v) with u+v < d.  These sets
# have products called `star/A1` and `star/A2`.  The first is given by
# the following rule: `star/A1`(f,g)[u] is the sum of all terms
# c1[u0,u1] * f[u0] * g[u1], where u0+u1 = u, and c1[u0,u1] is the
# number of splittings of F^u as a direct sum of subspaces of
# dimensions u0 and u1.
#
# Similarly, `star/A2`(f,g)[u,v] is a sum of terms
# c2[u0,v0,u1,v1] * f[u0,v0] * g[u1,v1] where
# (u0,v0) + (u1,v1) = (u,v) and
# c2[u0,v0,u1,v1] is c1[u0,u1] times c1[v0,v1] times
# q^(u0*v1+2*u1*v0).  This final factor is inserted to ensure that
# the coproduct map psi : A1 -> A2 (given by psi(f)[u,v]=f[u+v])
# is a ring map.

d := 10;

grassmann_count := (q) -> (n,d) ->
 mul(q^(n-i)-1,i=0..d-1)/mul(q^(d-i)-1,i=0..d-1);

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

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

`is_element/A1` := proc(f)
 local u,L;

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

 L := [seq([u],u=0..d-1)];

 if [indices(f)] <> L then
  return false;
 fi;

 return true;
end:

`is_equal/A1` := proc(f,g)
 local u;

 for u from 0 to d-1 do
  if simplify(f[u]-g[u]) <> 0 then
   return false;
  fi;
 od;
 return true;
end:

`to_list/A1` := (f) -> [seq(f[u],u=0..d-1)]:
`from_symbol/A1` := (f) -> table([seq(u=f[u],u=0..d-1)]);

`zero/A1`  := table([seq(u=0,u=0..d-1)]):
`one/A1`   := table([seq(u=1,u=0..d-1)]):
`delta/A1` := table([seq(u=`if`(u=0,1,0),u=0..d-1)]):

`plus/A1` := proc(f,g)
 table([seq(u = f[u]+g[u],u=0..d-1)]);
end:

`minus/A1` := proc(f,g)
 table([seq(u = f[u]-g[u],u=0..d-1)]);
end:

`dot/A1` := proc(f,g)
 table([seq(u = f[u]*g[u],u=0..d-1)]);
end:

`scalar_times/A1` := proc(c,f)
 table([seq(u = c*f[u],u=0..d-1)]);
end:

`star/A1` := proc(f,g)
 local h,u,u0,u1;
 h := table();
 for u from 0 to d-1 do
  h[u] := 0;
 od;

 for u0 from 0 to d-1 do
  for u1 from 0 to d-1-u0 do
   h[u0+u1] := h[u0+u1] + splitting_count(q)(u0,u1)*f[u0]*g[u1];
  od;
 od:

 return eval(h);
end:

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

`is_element/A2` := proc(f)
 local u,L;

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

 L := [seq(seq([u,v],v=0..d-1-u),u=0..d-1)];

 if [indices(f)] <> L then
  return false;
 fi;

 return true;
end:

`is_equal/A2` := proc(f,g)
 local u,v;

 for u from 0 to d-1 do
  for v from 0 to d-1-u do
   if simplify(f[u,v]-g[u,v]) <> 0 then
    return false;
   fi;
  od;
 od;
 return true;
end:

`to_list/A2` := (f) -> [seq(seq(f[u,v],v=0..d-1-u),u=0..d-1)]:
`from_symbol/A2` := (f) -> table([seq(seq((u,v)=f[u,v],v=0..d-1-u),u=0..d-1)]);

`zero/A2`  := table([seq(seq((u,v)=0,v=0..d-1-u),u=0..d-1)]):
`one/A2`   := table([seq(seq((u,v)=1,v=0..d-1-u),u=0..d-1)]):
`delta/A2` := table([seq(seq((u,v)=`if`(u=0 and v = 0,1,0),v=0..d-1-u),u=0..d-1)]):

`plus/A2` := proc(f,g)
 table([seq(seq((u,v) = f[u,v]+g[u,v],v=0..d-1-u),u=0..d-1)]);
end:

`minus/A2` := proc(f,g)
 table([seq(seq((u,v) = f[u,v]-g[u,v],v=0..d-1-u),u=0..d-1)]);
end:

`dot/A2` := proc(f,g)
 table([seq(seq((u,v) = f[u,v]*g[u,v],v=0..d-1-u),u=0..d-1)]);
end:

`scalar_times/A2` := proc(c,f)
 table([seq(seq((u,v) = c*f[u,v],v=0..d-1-u),u=0..d-1)]);
end:

`mu/A2` := (u0,v0,u1,v1) -> q^(u0*v1+2*u1*v0);

`star/A2` := proc(f,g)
 local h,u,v,u0,u1,v0,v1;
 h := table();

 for u from 0 to d-1 do
  for v from 0 to d-1-u do
   h[u,v] := 0;
  od;
 od:

 for u0 from 0 to d-1 do
  for u1 from 0 to d-1-u0 do
   for v0 from 0 to d-1-u0-u1 do
    for v1 from 0 to d-1-u0-u1-v0 do
     h[u0+u1,v0+v1] :=
      h[u0+u1,v0+v1] +
       splitting_count(q)(u0,u1) *
       splitting_count(q)(v0,v1) *
       `mu/A2`(u0,v0,u1,v1) *
       f[u0,v0] * g[u1,v1];
    od;
   od;
  od;
 od;

 return eval(h);
end:

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

`is_element/A3` := proc(f)
 local u,L;

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

 L := [seq(seq(seq([u,v,w],w=0..d-1-u-v),v=0..d-1-u),u=0..d-1)];

 if [indices(f)] <> L then
  return false;
 fi;

 return true;
end:

`is_equal/A3` := proc(f,g)
 local u,v,w;

 for u from 0 to d-1 do
  for v from 0 to d-1-u do
   for w from 0 to d-1-u-v do
    if simplify(f[u,v,w]-g[u,v,w]) <> 0 then
     return false;
    fi;
   od;
  od;
 od;
 return true;
end:

`to_list/A3` := (f) -> [seq(seq(seq(f[u,v,w],w=0..d-1-u-v),v=0..d-1-u),u=0..d-1)]:
`from_symbol/A3` := (f) -> table([seq(seq(seq((u,v,w)=f[u,v,w],w=0..d-1-u-v),v=0..d-1-u),u=0..d-1)]);

`zero/A3`  := table([seq(seq(seq((u,v,w)=0,w=0..d-1-u-v),v=0..d-1-u),u=0..d-1)]):
`one/A3`   := table([seq(seq(seq((u,v,w)=1,w=0..d-1-u-v),v=0..d-1-u),u=0..d-1)]):
`delta/A3` := table([seq(seq(seq((u,v,w)=`if`([u,v,w]=[0,0,0],1,0),w=0..d-1-u-v),v=0..d-1-u),u=0..d-1)]):

`plus/A3` := proc(f,g)
 table([seq(seq(seq((u,v,w) = f[u,v,w]+g[u,v,w],w=0..d-1-u-v),v=0..d-1-u),u=0..d-1)]);
end:

`minus/A3` := proc(f,g)
 table([seq(seq(seq((u,v,w) = f[u,v,w]-g[u,v,w],w=0..d-1-u-v),v=0..d-1-u),u=0..d-1)]);
end:

`dot/A3` := proc(f,g)
 table([seq(seq(seq((u,v,w) = f[u,v,w]*g[u,v,w],w=0..d-1-u-v),v=0..d-1-u),u=0..d-1)]);
end:

`scalar_times/A3` := proc(c,f)
 table([seq(seq(seq((u,v,w) = c*f[u,v,w],w=0..d-1-u-v),v=0..d-1-u),u=0..d-1)]);
end:

`mu/A3` := (u0,v0,w0,u1,v1,w1) -> q^(u0*v1+u0*w1+v0*w1+2*u1*v0+2*u1*w0+2*v1*w0);

`star/A3` := proc(f,g)
 local h,u,v,w,u0,u1,v0,v1,w0,w1;
 h := table();

 for u from 0 to d-1 do
  for v from 0 to d-1-u do
   for w from 0 to d-1-u-v do
    h[u,v,w] := 0;
   od;
  od;
 od:

 for u0 from 0 to d-1 do
  for u1 from 0 to d-1-u0 do
   for v0 from 0 to d-1-u0-u1 do
    for v1 from 0 to d-1-u0-u1-v0 do
     for w0 from 0 to d-1-u0-u1-v0-v1 do
      for w1 from 0 to d-1-u0-u1-v0-v1-w0 do
       h[u0+u1,v0+v1,w0+w1] :=
	h[u0+u1,v0+v1,w0+w1] +
	 splitting_count(q)(u0,u1) *
	 splitting_count(q)(v0,v1) *
	 splitting_count(q)(w0,w1) *
	 `mu/A3`(u0,v0,w0,u1,v1,w1) *
	 f[u0,v0,w0] * g[u1,v1,w1];
      od;
     od;
    od;
   od;
  od;
 od;

 return eval(h);
end:

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

psi := proc(f)
 local h,u,v;

 h := table();

 for u from 0 to d-1 do
  for v from 0 to d-1-u do
   h[u,v] := f[u+v];
  od;
 od:

 return eval(h);
end:

psi_L := proc(f)
 local h,u,v,w;

 h := table();

 for u from 0 to d-1 do
  for v from 0 to d-1-u do
   for w from 0 to d-1-u-v do
    h[u,v,w] := f[u+v,w];
   od;
  od;
 od:

 return eval(h);
end:

psi_R := proc(f)
 local h,u,v,w;

 h := table();

 for u from 0 to d-1 do
  for v from 0 to d-1-u do
   for w from 0 to d-1-u-v do
    h[u,v,w] := f[u,v+w];
   od;
  od;
 od:

 return eval(h);
end:

tensor11 := proc(f,g)
 table([seq(seq((u,v)=f[u]*g[v],v=0..d-1-u),u=0..d-1)]);
end:

twisted_tensor11 := proc(f,g)
 table([seq(seq((u,v)=q^(u*v)*f[u]*g[v],v=0..d-1-u),u=0..d-1)]);
end:

eta_L := (f) -> tensor11(`delta/A1`,f):

eta_R := (f) -> tensor11(f,`delta/A1`):

epsilon_L := proc(f)
 local h,u;

 h := table;

 for u from 0 to d-1 do
  h[u] := f[0,u];
 od;

 return eval(h):
end:

epsilon_R := proc(f)
 local h,u;

 h := table;

 for u from 0 to d-1 do
  h[u] := f[u,0];
 od;

 return eval(h):
end:

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

check_A1 := proc()
 local f,g,h,ff,gg,hh;

 ff := `from_symbol/A1`(f);
 gg := `from_symbol/A1`(g);
 hh := `from_symbol/A1`(h);

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

 _ASSERT(
  `is_equal/A1`(`star/A1`(`delta/A1`,ff),ff),"Left unit law"
 );

 _ASSERT(
  `is_equal/A1`(`star/A1`(ff,`delta/A1`),ff),"Right unit law"
 );

 _ASSERT(
  `is_equal/A1`(`star/A1`(ff,`star/A1`(gg,hh)),
                `star/A1`(`star/A1`(ff,gg),hh)),
  "Associativity law"
 );
end:

check_A2 := proc()
 local f,g,h,ff,gg,hh;

 ff := `from_symbol/A2`(f);
 gg := `from_symbol/A2`(g);
 hh := `from_symbol/A2`(h);

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

 _ASSERT(
  `is_equal/A2`(`star/A2`(`delta/A2`,ff),ff),"Left unit law"
 );

 _ASSERT(
  `is_equal/A2`(`star/A2`(ff,`delta/A2`),ff),"Right unit law"
 );

 _ASSERT(
  `is_equal/A2`(`star/A2`(ff,`star/A2`(gg,hh)),
                `star/A2`(`star/A2`(ff,gg),hh)),
  "Associativity law"
 );
end:

check_A3 := proc()
 local f,g,h,ff,gg,hh;

 ff := `from_symbol/A3`(f);
 gg := `from_symbol/A3`(g);
 hh := `from_symbol/A3`(h);

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

 _ASSERT(
  `is_equal/A3`(`star/A3`(`delta/A3`,ff),ff),"Left unit law"
 );

 _ASSERT(
  `is_equal/A3`(`star/A3`(ff,`delta/A3`),ff),"Right unit law"
 );

 _ASSERT(
  `is_equal/A3`(`star/A3`(ff,`star/A3`(gg,hh)),
                `star/A3`(`star/A3`(ff,gg),hh)),
  "Associativity law"
 );
end:

check_A_maps := proc()
 local f1,g1,h1,ff1,gg1,hh1,f2,g2,h2,ff2,gg2,hh2;

 ff1 := `from_symbol/A1`(f1);
 gg1 := `from_symbol/A1`(g1);
 hh1 := `from_symbol/A1`(h1);

 ff2 := `from_symbol/A2`(f2);
 gg2 := `from_symbol/A2`(g2);
 hh2 := `from_symbol/A2`(h2);

 _ASSERT(
  `is_equal/A2`(eta_L(`delta/A1`),`delta/A2`) and
  `is_equal/A2`(eta_L(`star/A1`(ff1,gg1)),`star/A2`(eta_L(ff1),eta_L(gg1))),
  "eta_L is a ring map"
 );

 _ASSERT(
  `is_equal/A2`(eta_R(`delta/A1`),`delta/A2`) and
  `is_equal/A2`(eta_R(`star/A1`(ff1,gg1)),`star/A2`(eta_R(ff1),eta_R(gg1))),
  "eta_R is a ring map"
 );

 _ASSERT(
  `is_equal/A2`(psi(`delta/A1`),`delta/A2`) and
  `is_equal/A2`(psi(`star/A1`(ff1,gg1)),`star/A2`(psi(ff1),psi(gg1))),
  "psi is a ring map"
 );

 _ASSERT(
  `is_equal/A1`(epsilon_L(`delta/A2`),`delta/A1`) and
  `is_equal/A1`(epsilon_L(`star/A2`(ff2,gg2)),`star/A1`(epsilon_L(ff2),epsilon_L(gg2))),
  "epsilon_L is a ring map"
 );

 _ASSERT(
  `is_equal/A1`(epsilon_R(`delta/A2`),`delta/A1`) and
  `is_equal/A1`(epsilon_R(`star/A2`(ff2,gg2)),`star/A1`(epsilon_R(ff2),epsilon_R(gg2))),
  "epsilon_R is a ring map"
 );

 _ASSERT(
  `is_equal/A1`(epsilon_L(psi(ff1)),ff1),
  "epsilon_L o psi = 1"
 );

 _ASSERT(
  `is_equal/A1`(epsilon_R(psi(ff1)),ff1),
  "epsilon_R o psi = 1"
 );

 _ASSERT(
  `is_equal/A2`(`star/A2`(eta_R(ff1),eta_L(gg1)),twisted_tensor11(ff1,gg1)),
  "eta_R * eta_L"
 );
end;