/*
 * Maxima code to compute the series expansion for the rhumb area.  This
 * generates the matrix Q from the paper
 *
 * - C. F. F. Karney,
 *   The area of rhumb polygons,
 *   Technical Report, SRI International, March 2023.
 *   https://arxiv.org/abs/2303.03219
 *
 * Copyright (c) Charles Karney (2023) <karney@alum.mit.edu> and licensed
 * under the MIT/X11 License.  For more information, see
 * https://geographiclib.sourceforge.io/
 *
 * Instructions:
 *
 *  * [optional] edit to set the desired value of Lmax (currently 6)
 *
 *  * start maxima and run
 *      batch("rhumbarea.mac")$
 *
 *  * now Q is an Lmax x Lmax matrix with the series coefficients.
 *
 *  * run writelsp(), writemaxima(), writetex(), writecpp(),
 *    writeoctave(floatp) to save Q lisp, Maxima code, LaTeX, C++ code, or
 *    Octave/MATLAB code.  For Lmax = 6, the files are called
 *    auxval6.{lsp,max,tex,cpp,m}.  The argument floatp governs whether the
 *    entries of matrices are written as floating-point numbers or as exact
 *    fractions.
 *
 * Area of rhumb quad
 *
 * A = c^2 * (lambda2-lamba1) * (S(chi2)-S(chi1))/(psi2-psi1)
 *
 * S(chi) = log(sec(chi)) + sum(P[l]*cos(2*l*beta),l,1,Lmax)
 * P = Q.n^[1,2,3,4,..,Lmax]
 *
 * Q =
 *   [   1  22    398  596  ]
 *   [ - -  --  - ---  ---- ]
 *   [   3  45    945  2025 ]
 *   [                      ]
 *   [      1     118  1543 ]
 *   [  0   -   - ---  ---- ]
 *   [      5     315  4725 ]
 *   [                      ]
 *   [            17   152  ]
 *   [  0   0   - ---  ---  ]
 *   [            315  945  ]
 *   [                      ]
 *   [                  5   ]
 *   [  0   0     0    ---  ]
 *   [                 252  ]
 *
 * Time for Lmax = 40 = 584 mins.
*/

/* Series for auxiliary latitudes available at
   https://doi.org/10.5281/zenodo.7382666
*/
load("auxvals40.mac")$

Lmax:6$

submat(M,rows,cols):=block([r0:length(M),c0:length(M[1]),l],
  l:append(makelist(r,r,rows+1,r0),[M]),
  M:apply('submatrix,l),
  l:append([M],makelist(c,c,cols+1,c0)),
  apply('submatrix,l))$

/* xi in terms of beta */
xibeta:block([M:submat(C[xi,beta],Lmax,Lmax)],
  beta+makelist(sin(2*l*beta),l,1,Lmax).M.
  transpose(makelist(n^j,j,1,Lmax)))$

/* chi in terms of beta */
chibeta:block([M:submat(C[chi,beta],Lmax,Lmax)],
  beta+makelist(sin(2*l*beta),l,1,Lmax).M.
  transpose(makelist(n^j,j,1,Lmax)))$

/* phi in terms of beta */
phibeta:block([M:submat(C[phi,beta],Lmax,Lmax)],
  beta+makelist(sin(2*l*beta),l,1,Lmax).M.
  transpose(makelist(n^j,j,1,Lmax)))$

kill(C,T)$

Q:block([xxn, s, sinxi, sinchi, cosbetasecphi],
  sinxi:expand(trigexpand(taylor(sin(xibeta),n,0,Lmax))),
  sinchi:expand(trigexpand(taylor(sin(chibeta),n,0,Lmax))),
  xxn:expand((sinxi-sinchi)/cos(beta)),
  cosbetasecphi:expand(trigexpand(taylor(cos(beta)/cos(phibeta),n,0,Lmax))),
  /* (1-f) = b/a = (1-n)/(1+n) */
  xxn:expand(trigexpand(taylor((1-n)/(1+n)*xxn*cosbetasecphi,n,0,Lmax))),
  s:expand(trigreduce(integrate(xxn,beta))),
  s:genmatrix(lambda([l,m],coeff(coeff(s,cos(2*l*beta)),n,m)),Lmax,Lmax))$

writelsp():=block([fname:concat("rhumbvals",Lmax,".lsp")],
  save(fname,Lmax,Q))$
writemaxima():=block([fname:concat("rhumbvals",Lmax,".mac")],
  writefile(fname),
  print(concat("Lmax:",string(Lmax),"$")),
  print(concat("Q:", string(submat(Q,Lmax,Lmax)),"$")),
  closefile(),'done)$

formatnum(x):=if integerp(x) then string(x) else
block([s:"",y:x],if x<0 then (s:"-",y:-x),
  concat(s,"\\frac{",num(y),"}{",denom(y),"}"))$
texout(M):=block([rows:length(M),cols:length(M[1]),s,linel:2000],
  print("\\begin{bmatrix}"),
  for i:1 thru rows do (s:"",
    for j:1 thru cols do
    s:concat(s,if j>=i then formatnum(M[i,j]) else "",
      if j<cols then "&" else if i<rows then "\\\\" else ""),
    print(s)),
  print("\\end{bmatrix}"),'done)$
writetex():=block([fname:concat("rhumbvals",Lmax,".tex")],
  writefile(fname),
  print(concat("\\begin{equation}\\label{Qeq}")),
  print("\\mathsf Q ="),
  texout(submat(Q,Lmax,Lmax)),
  print(".\\end{equation}"),
  closefile(),'done)$

indent:"      "$
printterm(x,line):=block([lx:slength(x)+2,lline:slength(line)],
  x:concat(" ",x,","),
  if lline=0 then line:concat(indent," ",x)
  else (if lx+lline<80 then line:concat(line,x)
    else (print(line),line:concat(indent," ",x))),
  line)$
flushline(line):=(if slength(line)>0 then (print(line),line:""),line)$
cppnum(x,realp):=block([s],s:if x<2^31 then string(x) else
  if x<2^63 then concat(string(x),"LL") else
  concat(string(x),"LLOVERFLOW"),
  if x<2^63 and (realp or x>=2^53) then concat("real(",s,")") else s)$
cppfrac(x):=block([s:""], if x<0 then (x:-x,s:"-"),
  if integerp(x) then s:concat(s,cppnum(x,false)) else
  concat(s,cppnum(num(x),false),"/",cppnum(denom(x),true)))$
cppout(name,M):=block([linel:2000,l:length(M),m:length(M[1]),
  count:0,line:""],
  print(concat(indent,"  // ", name)),
  for i:1 thru l do block([skip:1,
    start:l],
    for j:i+floor((start-i)/skip)*skip step -skip thru i do
    (line:printterm(cppfrac(M[i,j]), line),
      count:count+1),
    line:flushline(line)),
  count)$
writecpp():=block([fname:concat("rhumbvals",Lmax,".cpp"),linel:90,
  macro:"GEOGRAPHICLIB_EXP_RHUMBAREA_ORDER"],
  writefile(fname),
  for ord:2 thru Lmax do block([],
    print(concat(if ord = 2 then "#if " else "#elif ",
        macro, " == ", string(ord))),
    print(concat(indent,"static const real coeffs[] = {")),
    cppout("Coefficients in matrix Q", submat(Q,ord,ord)),
    print(concat(indent,"};"))),
  print("#else
#error", concat("\"Bad value for ", macro, "\""), "
#endif
"),
closefile(),'done)$

/* Do an exact rounding to 18 digits; 17 digits this may lead to a
   double-rounding error when the numbers are read as doubles */
doubleprint(x):=if integerp(x) then string(x) else block([fpprec:18,
  s:if x<0 then "-" else "",f,e],
  x:abs(x),
  e:floor(log(x)/log(10)),
  x:10^(-e+fpprec-1)*x,
  f:floor(x+1/2),
  if abs(f-x) = 1/2 and oddp(f) then f:2*x-f,
  x:split(string(bfloat(f/10^(-e+fpprec-1))),"b"),
  f:x[1],e:parse_string(x[2]),
  if e = 0 then x:f else
  block([y:split(f,"."),f1,f2,n],
    f1:y[1],f2:y[2],n:slength(f2),
    if e>0 and e<n then
    x:concat(f1,substring(f2,1,1+e),".",substring(f2,1+e)) else
    if e=n then x:concat(f1,f2,"e0") else
    if e<0 and e>=-3 then
    x:concat("0.",smake(-e-1,"0"),f1,
      if charat(f2, n) = "0" then substring(f2,1,n) else f2) else
    x:concat(f,"e",e)),
  concat(s,x))$
octout(name,M,floatp):=block([linel:2000],
  print(concat(name,"=[")),
  for i:1 thru length(M) do
  print(concat(if floatp then sremove("\"",string(map('doubleprint,M[i])))
      else string(M[i]),";")),
  print("];"))$
writeoctave(floatp):=block([fname:concat("rhumbvals",Lmax,".m")],
  writefile(fname),
  print(concat("Lmax=",Lmax,";")),
  octout("Q",submat(Q,Lmax,Lmax),floatp),
  closefile(),'done)$
trymult(fact):=block([tt:transpose(fact*Q.makelist(n^l,l,1,Lmax))[1]],
  tt:map(lambda([x],ratdisrep(taylor(x,n,0,Lmax))),tt),
  entier(100000*genmatrix(lambda([i,j],coeff(tt[i],n,j)),Lmax,Lmax)+1/2))$
