		(**S Mathematica Interface**)

(*The Functions are 	SForm, ToNumeric,   *)

BeginPackage["SInterface.m`"]

SForm::usage = "SForm[ st ] gives an S expression which corresponds to
    the value of the Mathematica expression st. This function calls
    the following  functions: ToNumeric,NumberListQ"
ToNumeric::usage = "ToNumeric[ st ] Coverts a Mathematica list which is
    an array of numbers into an S array"
AddQuote::usage = "ToNumeric[ st ] Coverts a Mathematica list which is
    an array of numbers into an S array"
NumberListQ::usage ="NumberListQ[st] Returns True if st is an array
    of numbers"

(************************************************************************)
        Begin["`private`"]
(************************************************************************)

SForm[ Plus[ x_, y_] ] :=  StringJoin[ SForm[x],"+",SForm[y] ]
SForm[ Times[ x_, y_] ] :=  StringJoin[ 
		If[Length[x]<2,SForm[x],StringJoin["(",SForm[x],")"]],"*",
		If[Length[y]<2,SForm[y],StringJoin["(",SForm[y],")"]] ]
SForm[ x_Rational] := StringJoin["(",ToString[InputForm[x]],")"]
SForm[ x_Real] := If[Precision[x] <17,
		ToString[InputForm[x]],
		StringJoin["as.bigfloat(\"",ToString[InputForm[x]],"\")"]]
SForm[ 0 ] := 0
SForm[ x_Integer] := If[ Ceiling[N[Log[Abs[x]]/Log[10.]]] <17,
		ToString[InputForm[x]],
		StringJoin["as.bigfloat(\\\"",ToString[InputForm[x]],"\\\")"]]
SForm[ x_Complex] := 
	StringJoin[If[Re[x]!=0,SForm[Re[x]],""],"+",SForm[Im[x]],"i"]
SForm[Exp[x_] ] := StringJoin["exp(",SForm[ x],")"]
SForm[Log[x_] ] := StringJoin["log(",SForm[ x],")"]
SForm[Power[x_,y_] ] :=  StringJoin[ 
		If[Length[x]<2,SForm[x],StringJoin["(",SForm[x],")"]],"^",
		If[Length[y]<2,SForm[y],StringJoin["(",SForm[y],")"]] ]
SForm[Dot[x_,y_] ] :=  StringJoin[
                If[Length[x]<2,SForm[x],StringJoin["(",SForm[x],")"]],"%*%",
                If[Length[y]<2,SForm[y],StringJoin["(",SForm[y],")"]] ] 
SForm[x_] := StringJoin["t(",SForm[x[[1]]],")"] /; Head[ x]==Transpose
SForm[ x_Symbol ] :=  Switch[ x,E,"exp(1)",Pi,"pi",_,ToString[x] ]
SForm[Sin[ x_]] := StringJoin["sin(",SForm[x],")"]
SForm[Cos[ x_]] := StringJoin["cos(",SForm[x],")"]
SForm[Tan[ x_]] := StringJoin["tan(",SForm[x],")"]
SForm[Sinh[ x_]] := StringJoin["sinh(",SForm[x],")"]
SForm[Cosh[ x_]] := StringJoin["cosh(",SForm[x],")"]
SForm[Tanh[ x_]] := StringJoin["tanh(",SForm[x],")"]
SForm[ArcSin[ x_]] := StringJoin["asin(",SForm[x],")"]
SForm[ArcCos[ x_]] := StringJoin["acos(",SForm[x],")"]
SForm[ArcTan[ x_]] := StringJoin["atan(",SForm[x],")"]
SForm[ArcSinh[ x_]] := StringJoin["asinh(",SForm[x],")"]
SForm[ArcCosh[ x_]] := StringJoin["acosh(",SForm[x],")"]
SForm[ArcTanh[ x_]] := StringJoin["atanh(",SForm[x],")"]
SForm[Rule[x_,y_] ] :=  StringJoin["list(",SForm[x],",",SForm[y],")"]
SForm[RuleTable[x_,y_,z_,t_] ] :=  StringJoin["list(",SForm[x],",",SForm[y],
	",",SForm[z],",",SForm[t]")"]

SForm[x_List]:=If[ NumberListQ[ x ],ToNumeric[x],
           StringJoin["list(",
           Apply[StringJoin,
		Drop[Drop[Characters[Map[SForm,x]],-1],1] ],")"] ]

SForm[ sp_ ] := If[ AtomQ[sp],ToString[sp],
 		SForm[Apply[ List,sp]]]

ToNumeric[ st_List ] :=
        Block[{dim,stflat,isint,stfloat,stint,prec},
         dim = Apply[StringJoin,Drop[Drop[ Characters[Dimensions[st] ],-1],1]];
         stflat=Flatten[If[Depth[st]>2,Transpose[st],st]];
         isint = Map[IntegerQ, stflat ];
         stint = Part[stflat,Flatten[ Position[isint,True]]];
         stfloat = Part[stflat,Flatten[ Position[isint,False]]];
         prec=Max[Map[Precision,stfloat],Ceiling[N[Log[Abs[stint]]/Log[10.]]]];
         If[ prec < 17,
           StringJoin["array(c(",
           Apply[StringJoin,Drop[Drop[Characters[InputForm[stflat]],-1],1]],
                      "),c(",dim,"))"],
           StringJoin["as.bigfloat(array(c(",AddQuote[stflat],"),c(",dim,")))"]
        ]
 ]

AddQuote[ st_ ] :=
        If[ Length[ st ] == 1, 
	StringJoin[ "\"",ToString[InputForm[st[[1]]]],"\""],
        StringJoin[ "\"",ToString[InputForm[st[[1]]]],"\",",AddQuote[Drop[st,1] ] ] ] 

NumberListQ[st_List]:=  NumberQ[ Apply[Plus,Flatten[st] ]]&&
                                        TensorRank[st]== Depth[st]-1
MakeList[ st_List, dim_] :=If[Length[dim] <= 1, st,
                     MakeList[Partition[st,dim[[-1]]],Drop[dim,-1]]]

(************************************************************************)
        End[]           (* end `private` Context                        *)
(************************************************************************)

(************************************************************************)
        EndPackage[]    (* end package Context                          *)
(************************************************************************)
