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

mkdir("TEMPTRIG"):

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

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

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

xmax_return_x_for_tan := 2^(-27):

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

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

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

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

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

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

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

bitsCh_0:=34:

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

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

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

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

#log2(%);

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

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

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

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

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

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

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

#log2(%);

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

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

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

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

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

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

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

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

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

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

# First, what is the worst case for cancellation ?

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

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

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

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

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

delta_RR_DD :=  kmax_cw3 * delta_repr_C + delta_round:

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

#log2(eps_ArgRed);

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

log2(maxepstotalTanCase2): # almost 61 bits

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

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

# Approximation error already computed above as epsApproxSinCase3;

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

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

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

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

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

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

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

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

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

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

    fclose(fd):
od:

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

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

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

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

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

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

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

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

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

# Output:

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

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

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

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

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

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

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

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

fprintf(fd, "\n"):

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

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

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

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

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

fprintf(fd, "\n"):

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

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

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

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

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

  # The sine polynomial

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

  # the cos polynomial

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

  # the tan polynomial

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

  # The sincos table

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

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

fclose(fd):

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

 return true;
end:

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

# Return a randomly selected element of a finite set A

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

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

 n := nops(A);

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

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

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

# Return a randomly selected element of a finite set A

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

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

 n := nops(A);

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

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

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

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

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

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

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

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

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

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

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

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

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

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

# Return the p-adic valuation of m.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

# Returns the set of monomials occuring in u

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

 return eval(T);
end:

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

# Real numbers mod integers

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

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

`is_leq/RZ` := NULL:

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

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

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

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

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

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

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


# A maple code for the dual Leipniz-Hopf(LH) algebra
# Description: This code includes functions to compute
# the orverlapping product and the conjugation in the dual
# Leipniz-Hopf algebra
# Author: S. Kaji (Yamaguchi University, Japan)
# Version history: initial version -- 2 Feb. 2014.
#                  current version -- 2 Jan. 2015.
# Global variables:
# T[]: basis for LH-algebra
# S[]: basis for dual LH-algebra
# P[]: Cartan-Serre basis for Steenrod algebra
# Q[]: Cartan-Serre basis for dual Steenrod algebra
# x[]: Milnor basis for dual Steenrod algebra

with(LinearAlgebra[Modular]);

## the dual Leibniz-Hopf algebra
# overlapping shuffle product
os := proc (f::polynom) local ff, L, t; global p;
    ff := expand(f) mod p;
    if degree(ff) < 2 then
        return ff
    elif op(0, ff) = `+` then
        return expand(map(os, ff)) mod p
    elif op(0, ff) = `*` then
        if type(op(1, ff), 'numeric') then
            return op(1, ff)*os(ff/op(1, ff)) mod p;
        elif nops(ff) = 2 and type(op(1, ff), 'indexed') and type(op(2, ff), 'indexed') then
            L := osw(op(1, op(1, ff)), op(1, op(2, ff)));
            return `mod`(add(S[l], l in L), p)
        else
            return `mod`(expand(os(os(op(1, ff))*os(mul(op(i, ff), i = 2 .. nops(ff))))), p)
        end if;
    elif op(0, ff) = `^` and type(op(1, ff), 'indexed') then
        t := floor(log[p](op(2, ff)));
        if 0 < t then
            return `mod`(os(S[p^t*op(1, op(1, ff))]*op(1, ff)^(op(2, ff)-p^t)), p)
        else L := osw(op(1, op(1, ff)), op(1, op(1, ff)));
            return os(add(S[l], l in L)*op(1, ff)^(op(2, ff)-2))
        end if;
    else
        print(ff, op(0, ff), "Error: no rule to compute the product")
    end if;
end proc;

#overlapping shuffle of two words
osw := proc (v::list, w::list) local L, i; option remember;
    if nops(w) = 0 then
        return [v]
    end if;
    if nops(v) = 0 then
        return [w]
    end if;
    L := [seq([w[1], op(x)], x in osw(v, w[2 .. -1]))];
    for i to nops(v) do
        L := [op(L), seq([op(v[1 .. i]), w[1], op(x)], x in osw(v[i+1 .. -1], w[2 .. -1]))];
        L := [op(L), seq([op(v[1 .. i-1]), v[i]+w[1], op(x)], x in osw(v[i+1 .. -1], w[2 .. -1]))]
    end do;
    return L;
end proc;

# pi image of milnor's dual basis
xi := proc (n) local i, x; global p;
    if type(n, 'integer') then
        if n = 0 then
            return 1
        else
            return S[[seq(p^(n-i), i = 1 .. n)]]
        end if
    elif type(n, 'list') then
        x := 1;
        for i to nops(n) do
            x := x*xi(i)^n[i]
        end do;
        return x
    else print("Error: xi")
    end if
end proc;

# convert a polynomial in x to one in S
x2xi := proc(f::polynom) local s,ind;
    ind := [];
    for s in indets(f) do
        if op(0,s)=`x` and type(s,'indexed') then
            ind := [op(ind),op(1,s)]
        end if;
    end do;
    return eval(f,[seq(x[i]=xi(i),i=ind)]);
end proc:

# conjugation for dual LH-algebra
chi := proc (f::polynom) global p;
    if degree(f) < 1 then
        return f
    elif type(f, 'indexed') then
        return add((-1)^nops(op(1, f))*S[x], x in coarsening(ListTools[Reverse](op(1, f))))
    elif op(0, f) = `+` then
        return `mod`(map(chi, f), p)
    elif op(0, f) = `*` then
        if type(op(1, f), 'numeric') then
            return `mod`(op(1, f)*chi(f/op(1, f)), p)
        else
            return `mod`(chi(op(1, f))*chi(mul(op(i, f), i = 2 .. nops(f))), p)
        end if
    elif op(0, f) = `^` then
        return `mod`(chi(op(1, f))^op(2, f), p)
    else
        print("cannot compute chi:", f, op(0, f))
    end if
end proc;

# conjugation for LH-algebra
chi2 := proc (f::polynom) global p;
    if degree(f) < 1 then
        return f
    elif type(f, 'indexed') then
        return add((-1)^nops(op(1, f))*T[x], x in refinement(ListTools[Reverse](op(1, f))))
    elif op(0, f) = `+` then
        return `mod`(map(chi2, f), p)
    elif op(0, f) = `*` then
        if type(op(1, f), 'numeric') then
            return `mod`(op(1, f)*chi2(f/op(1, f)), p)
        else
            return `mod`(chi2(op(1, f))*chi2(mul(op(i, f), i = 2 .. nops(f))), p)
        end if
    elif op(0, f) = `^` then
        return `mod`(chi2(op(1, f))^op(2, f), p)
    else
        print("cannot compute chi2:", f, op(0, f))
    end if
end proc;

# retraction onto the dual steenrod algebra (taking admissble terms)
retract := proc (f::polynom) local ff, i, w; global p;
    ff := expand(f);
    if 1 < degree(ff) then
        print(ff, "input must be linear")
    elif op(0, ff) = `+` then
        return map(retract, ff)
    elif type(ff, 'indexed') then
        if op(0,ff) != `S` then return ff; end if;
        w := op(1, ff);
        for i to nops(w)-1 do
            if w[i] < p*w[i+1] then
                return 0
            end if
        end do;
        return Q[w]
    elif op(0, ff) = `*` and type(op(1, ff), 'numeric') then
        return `mod`(op(1, ff)*retract(ff/op(1, ff)), p)
    else
        print("cannot compute retract:",ff, op(0, ff));
        return 0
    end if
end proc;

# projection onto the steenrod algebra (applying Adem relations)
projection := proc (f::polynom) local ff, i, w, t, j; global p;
    ff := expand(f) mod p;
    if 1 < degree(ff) then
        print(ff, "input must be linear")
    elif type(ff,'numeric') then
        return ff;
    elif op(0, ff) = `+` then
        return map(procname, ff) mod p
    elif type(ff, 'indexed') then
        if op(0,ff) != `T` and op(0,ff) != `P` then return ff; end if;
        w := op(1, ff);
        for i to nops(w)-1 do
            if w[i] < p*w[i+1] then
                t := ((-1)^(w[i]))*binomial((p-1)*w[i+1]-1,w[i])
                      *P[[op(w[1..i-1]),w[i]+w[i+1],op(w[i+2..-1])]];
                for j to floor(w[i]/p) do
                    t:=t + ((-1)^(w[i]+j))*binomial((p-1)*(w[i+1]-j)-1,w[i]-p*j)
                      *P[[op(w[1..i-1]),w[i]+w[i+1]-j,j,op(w[i+2..-1])]];
                end do;
                return procname(t mod p);
            end if
        end do;
        return P[w]
    elif op(0, ff) = `*` and type(op(1, ff), 'numeric') then
        return `mod`(op(1, ff)*procname(ff/op(1, ff)), p)
    else
        print("cannot compute projection:",ff, op(0, ff));
        return 0
    end if
end proc;

## Combinatorics on words
# ordered partition of an integer
ordpart := proc (n::integer) local L, V; option remember;
    if n = 0 then
        return []
    elif n = 1 then
        return [[1]]
    end if;
    L := ordpart(n-1);
    V[1] := [seq([1, op(v)], v in L)];
    V[2] := [seq([v[1]+1, op(v[2 .. -1])], v in L)];
    return [op(V[1]), op(V[2])]
end proc;
# ordered partition of a list
ordpartlist := proc (L::list) local V, u, i, w, pos;
    V := [];
    for u in ordpart(nops(L)) do
        w := [];
        pos := 1;
        for i in u do
            w := [op(w), L[pos .. pos+i-1]];
            pos := pos+i
        end do;
        V := [op(V), w]
    end do;
    return V
end proc;

# coarsening of a word
coarsening := proc (w::list) local L, p, i, l, v; option remember;
    L := [];
    for p in ordpart(nops(w)) do
        v := [];
        l := 1;
        for i to nops(p) do
            v := [op(v), add(w[j], j = l .. l+p[i]-1)];
            l := l+p[i]
        end do;
        L := [op(L), v]
    end do;
    return L
end proc;

# refinement of a word
refinement := proc (w::list) local L, l, v, U; option remember;
    if nops(w)=1 then
        return ordpart(w[1]);
    else
        U := [];
        L := refinement(w[2..-1]);
        for v in ordpart(w[1]) do
            for l in L do
                U := [op(U), [op(v),op(l)]];
            end do;
        end do;
        return U;
    end if;
end proc:

# list monomials of degree "totaldeg" consisting of "gens",
# whose degrees are specified by "degs"
list_monom := proc (gens::list, degs::(list(integer)), totaldeg::integer) local v, L, V;
    L := wpartition(degs, totaldeg);
    V := [];
    for v in L do
        V := [op(V), mul(gens[i]^v[i], i = 1 .. nops(v))]
    end do;
    return V
end proc;

# weighted partition; express "totaldeg" as linear combinations of "degs"
wpartition := proc (degs::(list(integer)), totaldeg::integer) local i, L, V;
    L := [];
    if totaldeg = 0 then
        return [[seq(0, i = 1 .. nops(degs))]]
    elif nops(degs) = 0 then
        return []
    elif nops(degs) = 1 then
        if `mod`(totaldeg, degs[1]) = 0 then
            return [[totaldeg/degs[1]]]
        else
            return []
        end if
    end if;
    for i from floor(totaldeg/degs[-1]) by -1 to 0 do
        V := wpartition(degs[1 .. -2], totaldeg-i*degs[-1]);
        L := [op(L), seq([op(v), i], v in V)]
    end do;
    return L
end proc;

## Enumerating basis and the conjugation invariants
# enumerate admissible sequences with lex order
admseq := proc (totaldeg::integer) local n, L; global p;
    n := floor(log[p]((p-1)*totaldeg+1));
    L := wpartition([seq((p^i-1)/(p-1), i = 1 .. n)], totaldeg);
    return map(ex2adm, L)
end proc;

# convert excess representation to admissible sequence
ex2adm := proc (ex::list) local n; global p;
    n := nops(ex);
    while ex[n] = 0 do
        n := n-1
    end do;
    return [seq(add(p^(i-j)*ex[i], i = j .. nops(ex)), j = 1 .. n)]
end proc;

# enumerate pi image of milnor monomials of degree "deg"
milnor_images := proc (deg::integer) local L, V, i, s, n; global p;
    V := [];
    n := floor(log[p]((p-1)*deg+1));
    L := list_monom([seq(x[i], i = 1 .. n)], [seq((p^i-1)/(p-1), i = 1 .. n)], deg);
    for s in L do
        V := [op(V), s = os(eval(s, [seq(x[i] = xi(i), i = 1 .. n)]))]
    end do;
    return V
end proc;

# polynomial associated to a list
pp := proc (L::list) local x, w;
    x := 0;
    for w in L do
        x := x+mul(S[u], u in w)
    end do;
    return x
end proc;

# linear equation solver
# Solves equations L in terms of indeterminants A
sol := proc (L::list, A::list) local X, V, i, j, v, n, Y,Z, rp, d, R, U, r; global p;
    n := nops(L);
    X := Matrix(n, n+nops(A));
    for i to n do
        X[i, nops(A)+i] := 1;
        for j to nops(A) do
            X[i, j] := coeff(op(2, L[i]), A[j])
        end do
    end do;
    X := Mod(p, X, integer[]);
    U := Mod(p, X, integer[]);
    Y, rp, d := RowEchelonTransform(p, U, true, true, false, false);
    r := nops(rp); U := U[1 .. n, 1 .. n];
    Z := LinearAlgebra[IdentityMatrix](n, compact = false);
    for i to LinearAlgebra[Dimension](Y) do
        LinearAlgebra[RowOperation](Z, [i, Y[i]], inplace = true)
    end do;
    Z := Mod(p, Z, integer[]);
    X := Multiply(p, Z, X);
    X := Multiply(p, U, X);
    V := [];
    for v in convert(X, listlist) do
        V := [op(V), add(v[i]*A[i], i = 1 .. nops(A)) = add(v[nops(A)+i]*op(1, L[i]), i = 1 .. nops(L))]
    end do;
    return V
end proc;

# compute conjugation invariants in degree "deg" in the dual Steenrod algebra
conjinvQ := proc (deg::integer) local L, V, U, v, w; global p;
    L := milnor_images(deg);
    V := [];
    for v in L do
        V := [op(V), op(1, v) = `mod`(chi(op(2, v))-op(2, v), p)]
    end do;
    U := [];
    for v in sol(V, [seq(S[w], w=admseq(deg))]) do
        if op(1,v)=0 then
            U:=[op(U), [op(2, v),retract(os(x2xi(op(2,v))))]];
        end if;
    end do:
    return U;
end proc;
# compute conjugation invariants in degree "deg" in the dual LH algebra
conjinvS := proc (deg::integer) local L, V, U, v, w; global p;
    L := ordpart(deg);
    V := [];
    for v in L do
        V := [op(V), S[v] = `mod`(chi(S[v])-S[v], p)]
    end do;
    U:=[];
    for v in sol(V, [seq(S[w], w=L)]) do
        if op(1, v) = 0 then
            U:=[op(U),srt(op(2, v))]
        end if;
    end do;
    return U
end proc;
# compute conjugation invariants in degree "deg" in the LH algebra
conjinvT := proc (deg::integer) local L, V, U, v, w; global p;
    L := ordpart(deg);
    V := [];
    for v in L do
        V := [op(V), T[v] = `mod`(chi2(T[v])-T[v], p)]
    end do;
    U:=[];
    for v in sol(V, [seq(T[w], w=L)]) do
        if op(1, v) = 0 then
            U:=[op(U),srt(op(2, v))]
        end if;
    end do;
    return U
end proc;
# compute conjugation invariants in degree "deg" in the Steenrod algebra
conjinvP := proc (deg::integer) local L, V, U, v; global p;
    L := admseq(deg);
    V := [];
    for v in L do
        V := [op(V), P[v] = projection(chi2(T[v]) - T[v]) mod p]
    end do;
    U:=[];
    for v in sol(V, [seq(P[w],w=L)]) do
        if op(1, v) = 0 then
            U:=[op(U),srt(op(2, v))]
        end if;
    end do;
    return U
end proc;

# sort terms in reverse lex order
srt := proc (f::polynom) local L;
    if degree(f) <> 1 then
        print("degree must be one", f);
        return f
    end if;
    L := sort([seq(ListTools[Reverse](op(1, s)), s in indets(f))]);
    L := [seq(S[ListTools[Reverse](l)], l in L)];
    return
    sort(f, L)
end proc;

# duality between S_I and T^J
# Note that S_J is conjugation invariant <=> So is T^K in non-dual LH-algebra
dual := proc (f::{polynom,list}) local J,K,k,Sym;
    if op(0, f) = `+` or type(f,'list') then
        return map(dual, f);
    elif op(0, f) = `*` then
        if type(op(1, f), 'numeric') then
            return op(1, f)*dual(f/op(1, f));
        else
            print("cannot compute dual :",f);
        end if;
    elif type(f, 'indexed') then
        if op(0,f)=`S` then
            Sym := T;
        else
            Sym := S;
        end if;
        k := 0;
        J := op(1,f);
        K := [];
        while nops(J)>0 do
            k := k+1;
            if J[1]=1 then
                J := J[2..-1];
                if nops(J)=0 then
                    K := [op(K),k];
                end if;
            else
                J[1] := J[1]-1;
                K := [op(K),k];
                k := 0;
            end if;
        end do;
        return Sym[K];
    else
            print("cannot compute dual:",f);
    end if;
end proc:


(*
 Copyright (C) 2020 Susi Lehtola

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

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

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

$include "mgga_k_csk.mpl"

(* Equation (21) *)
csk_z  := (p, q) -> 1 + params_a_csk_cp*p + params_a_csk_cq*q - (1 + 5*p/3):


# This file is about Singer systems of endomorphisms of the additive formal
# group.  Such a system has groups G(i,j) (for 0 <= i <= j <= n say),
# all of which are equal to the standard additive formal group.  There
# are morphisms G(j,k) -> G(i,l) whenever i <= j <= k <= l, with the
# evident functoriality condition.  The horizontal maps are linear
# and the vertical maps are short isogenies.  Every subdiagram
# G(i,i) -> G(i,j) <- G(j,j) is of the form G -> G/a <- G//a.

W0V := (k) -> mul(V[i],i=0..k-1):

WW := proc(k,l,m)
  local J,P;
  J := [seq(j,j=k..l-1)];
  P := combinat[choose](J,l-k-m);
  return add(mul(V[u[t]]^(2^(k+m+t-1-u[t])),t=1..l-k-m),u in P);
end:

WWW := (i,j,k,l,m) -> WW(k,l,m) * W0V(j)^(2^(k+m-j)) / W0V(i)^(2^(l-i)):

# G(j,k) to G(i,l)
f := proc(i,j,k,l)
 local x;
 return unapply(sort(collect(expand(add(WWW(i,j,k,l,m) * x^(2^m),m=0..l-k)),x)),x):
end:

vV_rule := {seq(v[i]=V[i]/W0V(i),i=0..20)}:

Vv_rule := {seq(
 V[i] = v[i] * mul(v[j]^(2^(i-j-1)),j=0..i-1),
 i=0..20)};

check_id := proc(i::nonnegint,k::nonnegint)
 local x;

 if not (i <= k) then return FAIL; fi;

 _ASSERT(f(i,i,k,k)(x) = x,"identity maps",[i,k]);

end:

check_compose := proc(h::nonnegint,i::nonnegint,j::nonnegint,
                      k::nonnegint,l::nonnegint,m::nonnegint)
 local x,err;

 if not(h <= i and i <= j and j <= k and k <= l and l <= m) then
  return FAIL;
 fi;

 err := modp(expand(f(h,i,l,m)(f(i,j,k,l)(x)) - f(h,j,k,m)(x)),2);

 _ASSERT(err = 0,"maps compose correctly",[h,i,j,k,l]);
end:

check_linear := proc(i::nonnegint,j::nonnegint,k::nonnegint)
 local x,y,err;

 if not(i <= j and j <= k) then
  return FAIL;
 fi;

 y := f(i,j,k,k)(x);
 err := expand(y - coeff(y,x,1) * x);

 _ASSERT(err = 0,"horizontal map is linear",[i,j,k]);
end:

check_short_isogeny := proc(i::nonnegint,k::nonnegint,l::nonnegint)
 local x,y,err;

 if not(i <= k and k <= l) then
  return FAIL;
 fi;

 y := f(i,i,k,l)(x);

 _ASSERT(degree(y,x) = 2^(l-k) and coeff(y,x,2^(l-k)) = 1,
         "vertical map is a short isogeny",[i,k,l]);
end:

check_dilation := proc(i::nonnegint,p::nonnegint)
 local x,y,z,err;

 y := f(i,i,i,i+p)(x);
 z := f(i,i+p,i+p,i+p)(x);
 _ASSERT(expand(coeff(y,x,1) - coeff(z,x,1)) = 0,"dilation condition",[i,j,k]);
end:

check_vV_rules := proc(n)
 _ASSERT(
  `and`(seq(evalb(subs(vV_rule,subs(Vv_rule,V[i])) = V[i]),i=0..n)) and
  `and`(seq(evalb(subs(Vv_rule,subs(vV_rule,v[i])) = v[i]),i=0..n)),
  "rules for converting v[i] to V[i] and vice versa"
 );

end: