# FUNCTION: mathematica - produce output suitable for Mathematica
#################################################################

alias(math = `mathematica/math`):
alias(SubsPara = `mathematica/SubsPara`):
alias(Operator = `mathematica/operator`):
alias(OperatorMap = `mathematica/operator/map`):

math[sin] := Sin:
math[cos] := Cos:
math[tan] := Tan:
math[sec] := Sec:
math[csc] := Csc:
math[cot] := Cot:
math[sinh] := Sinh:
math[cosh] := Cosh:
math[tanh] := Tanh:
math[sech] := Sech:
math[csch] := Csch:
math[coth] := Coth:
math[arcsin] := ArcSin:
math[arccos] := ArcCos:
math[arctan] := ArcTan:
math[arccot] := ArcCot:
math[arcsec] := ArcSec:
math[arccsc] := ArcCsc:
math[arcsinh] := ArcSinh:
math[arccosh] := ArcCosh:
math[arctanh] := ArcTanh:
math[arccoth] := ArcCoth:
math[arcsech] := ArcSech:
math[arccsch] := ArcCsch:
math[exp] := Exp:
math[ln] := Log:
math[infinity] := Infinity:
math[GAMMA] := Gamma:
math[abs] := Abs:
math[binomial] := Binomial:
math[erf] := Erf:
math[erfc] := Erfc:
math[BesselI] := BesselI:
math[BesselJ] := BesselJ:
math[BesselK] := BesselK:
math[BesselY] := BesselY:
math[Beta] := Beta:
math[Ci] := CosIntegral:
math[Ei] := ExpIntegralEi:
math[euler] := EulerE:
math[gamma] := EulerGamma:
math[factorial] := Factorial:
math[Psi] := PolyGamma:
math[Si] := SinIntegral:
math[bernoulli] := BernoulliB:
math[Ai] := AiryAi:
math[Bi] := AiryBi:
math[FresnelC] := FresnelC:
math[FresnelS] := FresnelS:
math[true] := True:
math[false] := False:
math[int] := Integrate:
math[Int] := Integrate:
math[sum] := Sum:
math[Sum] := Sum:
math[product] := Product:
math[Product] := Product:
math[Catalan] := Catalan:
math[E] := E:
math[Pi] := Pi:
math[min] := Min:
math[max] := Max:
math[diff] := D:
math[Diff] := D:

mathematica := proc(e)
   local result;
   global infolevel, `mathematica/warnings`; 
   if not assigned(infolevel[mathematica]) then infolevel[mathematica] := 1 fi;
   result := `mathematica/mathematica`(e):
   `mathematica/warnings` := '`mathematica/warnings`':
   result
end:

`mathematica/mathematica` := proc(e) 
   local f, i, n, m, level, s, d, nmin, nmax, x, x0, C; 
   global `mathematica/warnings`;

   if nargs=2 then level := args[2] else level := 10 fi;

   if type(e,'name') and not type(e,'operator') then 
      if assigned(math[e]) then 
         math[e] 
      elif type(e,'indexed') then
         cat(procname(op(0,e)), `[[`, 
                seq( cat(procname(op(i,e)), `,`), i=1..nops(e)-1), 
                procname(op(nops(e),e)), 
             `]]`);
      else e 
      fi

   elif type(e,'numeric') then # => minus sign !!!
      if type(e,'fraction') then
        s := cat(numer(e),`/`,denom(e));
        if level = 0 then s := cat(`(`, s, `)`) else s fi;
      elif type(e,'float') then
         # s := cat(procname(op(1,e)),`.*10^(`,procname(op(2,e)),`)`);
         s := convert(e,'string');
         if e<0 and level = 0 then s := cat(`(`, s, `)`) else s fi;
      elif type(e,'negint') and level = 0 then
         cat(`(`, e, `)`)
      else 
         cat(e)
      fi
	
   elif type(e,`+`) then # level 3
      s := procname(op(1,e), 3): # leading negative sign?
      for i from 2 to nops(e) do f := op(i,e);
         if type(f,'numeric') and f<0
         or type(f,`*`) and type(op(1,f), 'numeric') and op(1,f) < 0 then
            s := cat(s, `-`, procname(-f,3))
         else 
            s := cat(s, `+`, procname( f,3))
         fi;
      od;
      if level < 3 then s := cat(`(`, s, `)`) else s fi;
	
   elif type(e,`*`) then # level 2
      d := 1/(select(
         t -> type(t,`^`) and type(op(2,t), 'numeric') and op(2,t)<0,
         e));
      if d <> 1 then
         s := cat(procname(d*e, 2), `/`, procname(d, 1))
      else
         if op(1,e) = -1 then 
            s := cat(`-`, procname(op(2,e), 2)); m := 3;
         else
            s := procname(op(1,e), 2); m := 2
         fi;
         for i from m to nops(e) do f := op(i,e);
            s := cat(s, `*`, procname(f, 2))
         od;
      fi;
      if level < 2 then s := cat(`(`, s, `)`) else s fi;

   elif type(e,`^`) then # level 1
      if op(2,e) = -1 then # 1/x
         s := cat(`1/`, procname(op(1,e), 0))
      else
         s := cat(procname(op(1,e), 0), `^`, procname(op(2,e), 0));
      fi;
      if level < 1 then s := cat(`(`, s, `)`) else s fi;

   elif type(e,'list') or type(e,'set') then
      cat(`{`, seq( cat(procname(op(i,e)), `, `), i=1..nops(e)-1), 
          procname(op(nops(e),e)),`}`)

   elif type(e,'function') then f := op(0,e);
     if f='limit' or f='Limit' then
       cat(`Limit[`, procname(op(1,e)), `, `, 
               procname(lhs(op(2,e))), ` -> `, procname(rhs(op(2,e))),
            `]`)
     elif f='log10' then
       cat(`Log[`, procname(op(1,e)), `, 10]`);
     elif f='lnGAMMA' then 
     # logGamma has a single branch cut along the negative real axis,
       cat(`Log[Gamma[`,procname(op(1,e)), `]]`);
     elif f='harmonic' then
       procname(Psi(op(1,e)+1)+gamma)
     elif f='dilog' then
       cat(`PolyLog[2, 1`, procname(-op(1,e)), `]`);
     elif f='Zeta' then n := nops(e);
       if n=1 then cat(`Zeta[`, procname(op(1,e)), `]`);
       elif n=2 then m := op(1,e);
          if type(m,'nonnegint') then
             cat('Zeta', `'`$m, `[`, procname(op(2,e)), `]`);
          else
             ERROR(`cannot translate this Zeta function: `,e)
          fi
       elif n=3 then m := op(1,e);
          if type(m,'nonnegint') then 
             cat('Zeta', `'`$m,`[`, procname(op(2,e)), procname(op(3,e)), `]`);
          else 
             ERROR(`cannot translate this Zeta function: `,e)
          fi
       else ERROR(`cannot translate this Zeta function: `,e)
       fi
        
     elif assigned(math[f]) then
       cat(math[f], `[`, 
              seq( cat(procname(op(i,e)), `,`), i=1..nops(e)-1),
              procname(op(nops(e),e)),
           `]`);
     else
       if not assigned(`mathematica/warnings`[f] ) then
          userinfo(1,mathematica,`translating unknown function `.f.` as is`);
          `mathematica/warnings`[f] := true
       fi;
       cat(procname(f), `[`,
              seq( cat(procname(op(i,e)), `,`), i=1..nops(e)-1),
              procname(op(nops(e),e)),
           `]`);
     fi

   elif type(e,'operator') then 
      Operator(e)

   elif type(e,'laurent') then
      f := op(0,e); 
      if type(f,name) then x := f; x0 := 0
      elif type(f,`+`) then x := op(1,f); x0 := -subs(x=0,f);
      else ERROR(`problem with this series`)
      fi;
      s := cat(`SeriesData[`,procname(x),`, `,procname(x0), `, {`);
      nmin := op(2,e); nmax := nmin; C := table('sparse'):
      for i by 2 to nops(e)-1 do f := op(i,e); n := op(i+1,e);
         if not type(f, 'O'('anything')) then C[n] := f fi;
         if n > nmax then nmax := n fi;
         if n < nmin then nmin := n fi;
      od;
      s := cat(s, procname(C[nmin]));
      for i from nmin+1 to nmax do
         s := cat(s, `,`, procname(C[i]))
      od;
      s := cat(s, `}, `, procname(nmin), `, `, procname(nmax), `, 1]`);
         
   elif type(e,'series') then
      ERROR(`general series cannot be translated`);

   elif type(e,'vector') then
      procname(convert(e,list))

   elif type(e,'matrix') then
      procname(convert(e,listlist))

   elif type(e,'relation') then # level 4
      if type(e,`=`) then
         if type(rhs(e),'range') then # occurs in int/sum/product etc.
           RETURN(
              cat(`{`, procname(lhs(e)), `, `, procname(lhs(rhs(e))), `, `, 
                       procname(rhs(rhs(e))), `}`)
           )
         else
           s := cat(procname(lhs(e), 3), `==`, procname(rhs(e), 3));
         fi
      elif type(e,`<>`) then
         s := cat(procname(lhs(e), 3), `!=`, procname(rhs(e), 3));
      elif type(e,`<`) then
         s := cat(procname(lhs(e), 3), `<`,  procname(rhs(e), 3));
      elif type(e,`<=`) then
         s := cat(procname(lhs(e), 3), `<=`, procname(rhs(e), 3));
      fi;
      if level < 4 then s := cat(`(`, s, `)`) else s fi;

   elif type(e,'logical') then
      if type(e,`or`) then # level 7
         s := cat(procname(op(1,e), 7), ` || `, procname(op(2,e), 7));
         m := 7;
      elif type(e,`and`) then # level 6
         s := cat(procname(op(1,e), 6), ` && `, procname(op(2,e), 6));
         m := 6;
      elif type(e,`not`) then # level 5
         s := cat(`!`,procname(op(1,e), 5));
         m := 5;
      fi;
      if level < m then s := cat(`(`, s, `)`) else s fi;

   elif `type/if`(e) then
      s := cat(`If[`, procname(op(1,e)), `,`, procname(op(2,e)) );
      if nops(e) > 2 then
         s := cat(s, `,`, procname(op(3,e)) )
      fi;
      s := cat(s, `]`);
      
   elif type(e,'procedure') then
   	ERROR(`procedures can not be translated`);
      
   else
     ERROR(`dont know how to translate`, e)
   fi;
end:

macro( IF = 31, PARAM = 24, FUNCTION = 12, A=addressof, P=pointto );

`type/param` := proc(x) evalb( disassemble( A(x) )[1] = PARAM ) end:
`type/if` := proc(x) evalb( disassemble( A(x) )[1] = IF ) end:
`convert/function` := proc(f,a)
        if not type(a,'list') then ERROR(`internal error: list expected`) fi;
        P( assemble( FUNCTION, A(f), disassemble(A(a))[2] ) ) end:

SubsPara := proc(s) local t, r, f;
   if `type/param`(s) then cat(`#`,disassemble( A(s) )[2])
   elif type(s, 'numeric') then s
   elif type(s, 'string') then s
   elif type(s,`+`) then
      convert( [seq( procname(t), t=[op(s)] )], `+` )
   elif type(s,`*`) then
      convert( [seq( procname(t), t=[op(s)] )], `*` )
   elif type(s,`^`) then
      procname(op(1,s))^procname(op(2,s))
   elif type(s,'function') then
      f := procname(op(0,s)); r := [seq( procname(t), t=s )];
     `convert/function`(f,r)
   elif type(s,'logical') then OperatorMap(procname, s)
   elif type(s,'relation') then OperatorMap(procname, s)
   elif `type/if`(s) then OperatorMap(procname, s)
   elif type(s,'range') then procname(op(1,s)) .. procname(op(2,s))
      
   else ERROR(cat(`cannot handle `,whattype(eval(s,1)),` in `), eval(s,1))
   fi
end: # SubsPara

OperatorMap := proc(f,x) local a,i,t;
    a := [seq( f(t), t=x )];
    i := disassemble(A(x))[1];
    t := P(assemble(i,seq(A(t),t=a)));
    i := disassemble(A(t))[1];
    t
end:

Operator := proc(p:operator) local f, body;
   if type(p,'name') then RETURN( procname(eval(p)) ) fi;
   if nops([op(2,p)]) <> 0 then
      ERROR(`local parameters in operators are not supported`)
   fi;
   # body := op(5,p);
   body := P( disassemble(A(p))[6] );

   f := SubsPara(body);
   cat(`( `, mathematica(f), ` )&`);
end: # operator   
    
macro(A = A, P = P);



`help/text/mathematica` := TEXT(
`FUNCTION: mathematica - produce output suitable for Mathematica`,
`   `,
`CALLING SEQUENCE:`,
`   mathematica(expr)`,
`   `,
`PARAMETERS:`,
`   expr     - any expression`,
`   `,
`SYNOPSIS:   `,
`- The mathematica function produces transforms an expression in a general valid`,
`  input to the Computer Algebra  System  Mathematica.  The result returned from`,
`  the function mathematica is a Maple string. `,
`   `,
`- The inert functions Sum, Int, Diff, Limit and Log can be used instead of sum,`,
`  int, diff, limit and log to prevent evaluation by Maple.`,
`   `,
`- The most important application is to find bugs in Mathematica ....`,
`   `,
`EXAMPLES:   `,
`> mathematica(linalg[matrix](2,3,[1,2,3,4,5/2,6]));`,
`   `,
`                            {{1, 2, 3}, {4, 5/2, 6}}`,
`   `,
`> mathematica(Int(1/(x^2-2*x+1), x=0..2));`,
`   `,
`                       Integrate[1/(x^2-2*x+1),{x, 0, 2}]`,
`   `,
`> mathematica(Limit(Ei(x-1/x)-Ei(x), x=infinity));`,
`   `,
`          Limit[ExpIntegralEi[x-1/x]-ExpIntegralEi[x], x -> Infinity]`,
`   `,
`> mathematica(series(GAMMA(x), x=0, 2 ));`,
`   `,
`    SeriesData[x, 0, {1,-EulerGamma,1/12*Pi^2+1/2*EulerGamma^2,0}, -1, 2, 1]`,
`   `,
`> mathematica((x,y) -> (x^2+y^2)/(x^2-y^2));`,
`   `,
`                          ( (#1^2+#2^2)/(#1^2-#2^2) )&`,
`   `,
`> mathematica(W(x) * exp(W(x)) = x);`,
`mathematica/mathematica:   translating unknown function W as is`,
`                               W[x]*Exp[W[x]]==x`,
`   `,
`SEE ALSO:  writeto, appendto`,
`   `
):

# save `math.m`;
# done
