(* PostScriptForm[] *)
(*
    "http://mathematica.stackexchange.com/questions/101954/postscriptform-or-forthform"
    "http://mathematica.stackexchange.com/questions/102894/multi-case-function-many-single-case-delayed-assignments-or-one-which"
*)
(*
    Careful! The ‘ArcTan’ function in Mathematica returns things in radians; the ‘atan’ function in PostScript returns in degrees.
    If doing angle-type calculations, this still works. If doing area-type calculations, it won’t unless atan multiplied by a factor of Pi÷180.
*)
Remove[PostScriptForm,PostScriptFormInner];
PostScriptForm[thing_]:=StringTrim[StringReplace[StringJoin[" ",PostScriptFormInner[thing]],{
    " -1 mul "->" neg ",
    RegularExpression[" -1 ([A-Za-z][A-Za-z0-9]*) mul "]->" $1 neg ",
    " 1 exch div mul "->" div ",
    " div 1 atan "->" atan "
}]];
PostScriptFormInner[thing_Rational]:=If[Abs[Denominator[thing]/(2^IntegerExponent[Denominator[thing],2])/(5^IntegerExponent[Denominator[thing],5])]==1,ToString[N[thing,20],InputForm,NumberMarks->False],PostScriptFormInner[Numerator[thing]]<>" "<>PostScriptFormInner[Denominator[thing]]<>" div"];
PostScriptFormInner[thing_?AtomQ]:=ToString[thing];
PostScriptFormInner[thing_List]:=StringJoin@@Riffle[Map[PostScriptFormInner,thing],"\r\n"];
PostScriptFormInner[MatrixForm[thing_]]:=PostScriptFormInner[thing];
PostScriptFormInner[ArcTan[Times[Power[xThing_,n_],yThing_]]]:=StringJoin[PostScriptFormInner[yThing]," ",PostScriptFormInner[Power[xThing,-n]]," atan"]/;n<0;
PostScriptFormInner[ArcTan[Times[yThing_,Power[xThing_,n_]]]]:=StringJoin[PostScriptFormInner[yThing]," ",PostScriptFormInner[Power[xThing,-n]]," atan"]/;n<0;
PostScriptFormInner[ArcTan[Thing_]]:=StringJoin[PostScriptFormInner[Thing]," 1 atan "];
PostScriptFormInner[ArcCsc[Times[h_,Power[x_,n_]]]]:=PostScriptFormInner[ArcTan[((x^(-n))//FullSimplify)/(Sqrt[h^2-x^(-2n)]//FullSimplify)]]/;n<0;
PostScriptFormInner[ArcCsc[Times[Power[x_,n_],h_]]]:=PostScriptFormInner[ArcTan[((x^(-n))//FullSimplify)/(Sqrt[h^2-x^(-2n)]//FullSimplify)]]/;n<0;
PostScriptFormInner[ArcCsc[Rational[h_,x_]]]:=PostScriptFormInner[ArcTan[(x//FullSimplify)/(Sqrt[h*h-x*x]//FullSimplify)]];

PostScriptFormInner[thing_Power]:=(
    psExponent:=Which[
        #>5&&Divisible[#,3],psExponent[#/3]<>" dup dup mul mul",
        #>=5&&OddQ[#],"dup "<>psExponent[(#-1)/2]<>" dup mul mul" ,
        #>=4&&EvenQ[#],psExponent[#/2]<>" dup mul",
        #==3,"dup dup mul mul",
        #==2,"dup mul",
        #==1/2,"sqrt",
        #==3/2,"dup sqrt mul",
        #<0,psExponent[-#]<> " 1 exch div",
        (Rational===Head[#])&&(Log[2,#//Denominator]//IntegerQ),psExponent[Simplify[2#]]<>" sqrt",
        Not[IntegerQ[#]],PostScriptFormInner[#]<>" exp",
        #==1,"",
        True," !!!\[Bullet]\[Bullet]\[Bullet]Error with exponent = "<>ToString[#]<> "\[Bullet]\[Bullet]\[Bullet]!!! "
    ]&;
    Which[
        thing[[2]]>0||Not[IntegerQ[thing[[2]]]],PostScriptFormInner[thing[[1]]]<>" "<>psExponent[thing[[2]]],
        thing[[2]]==-1,"1 "<>PostScriptFormInner[thing[[1]]]<>" div",
        thing[[2]]==0,"1",
        True,"1 "<>PostScriptFormInner[thing[[1]]]<>" "<>psExponent[-thing[[2]]]<>" div"
    ]);

PostScriptFormInner[thing_Times]:=StringJoin[PostScriptFormInner[-thing]," neg"]/;MemberQ[thing,-1];
PostScriptFormInner[thing_Times]:=StringJoin@Riffle[Reap[If[MatchQ[thing[[1]],Power[_,n_Integer/;n<0]],(Sow["1 "<>PostScriptFormInner[thing[[1,1]]]<>" div"];),(Sow[PostScriptFormInner[thing[[1]]]];)];Map[(If[MatchQ[#,Power[_,n_Integer/;n<0]],(Sow[PostScriptFormInner[#[[1]]^(-#[[2]])]<>" div"];),(Sow[PostScriptFormInner[#]<>" mul"]; )])&,Drop[List@@thing,1]]][[2,1]]," "];

PostScriptFormInner[thing_Plus]:=
StringJoin@@If[FreeQ[thing,_^n_],
    (* Simple expression, no powers, to be summed one item at a time *)
    Module[{i},
        i=Position[thing,Except[Times[-1,_]|(_?Negative)],1,Heads->False];
        If[Length[i]>0,i=i[[1,1]],(i=Position[thing,Not[MatchQ[#,Times[-1,_]]]&,1,Heads->False];i=If[Length[i]>0,i[[1,1]],1])]; Prepend[Map[(" "<>Replace[#,{(n_Integer/;n<0:>ToString[-n]<>" sub"),(Times[-1,_]:>PostScriptFormInner[Times@@Drop[#,1]]<>" sub"),(Times[n_/;n<0,_]:>PostScriptFormInner[Times@@Drop[#,1]]<>" "<>ToString[-#[[1]]]<>" mul sub"),(Times[n_/;n>0,_]:>PostScriptFormInner[Times@@Drop[#,1]]<>" "<>ToString[#[[1]]]<>" mul add"),(_:>PostScriptFormInner[#]<>" add")}])&,Drop[List@@thing,{i}]],Replace[thing[[i]],{Times[-1,_]:>PostScriptFormInner[-thing[[i]]]<>" neg",_:>PostScriptFormInner[thing[[i]]]}]]  ],
    (* Polynomial *)
    Module[{vars,exps,v,rcl,i,firstMul},
        vars=Variables[thing];
        exps=Exponent[thing,vars];
        v=Select[Transpose[{vars,exps}],(#[[2]]==Max@@exps)&][[1,1]];
        rcl=Reverse[Map[Factor,CoefficientList[thing,v]]];
        Reap[
            i=1;firstMul=True;If[rcl[[1]]=!=1,Sow[PostScriptFormInner[rcl[[1]]]]];
Map[If[#===0,i++,(Sow[If[firstMul&&rcl[[1]]===1,PostScriptFormInner[v^i]<>" "," "<>PostScriptFormInner[v^i]<>" mul "]<>If[MatchQ[#,(Times[_?Negative,_]|(_?Negative))],PostScriptFormInner[-#]<>" sub",PostScriptFormInner[#]<>" add"]];i=1;firstMul=False)]&,Drop[rcl,1]];
            If[i>1,Sow[" "<>PostScriptFormInner[v^(i-1)]<>" mul "]];
        ][[2,1]]
]];

(* PostScriptForm[] *)
(* 


    "http://mathematica.stackexchange.com/questions/101954/postscriptform-or-forthform"
        "http://mathematica.stackexchange.com/questions/102894/multi-case-function-many-single-case-delayed-assignments-or-one-which"
    *)
    (*
        Careful! The ‘ArcTan’ function in Mathematica returns things in radians; the ‘atan’ function in PostScript returns in degrees.
        If doing angle-type calculations, this still works. If doing area-type calculations, it won’t unless atan multiplied by a factor of Pi÷180.
    *)
    Remove[PostScriptForm,PostScriptFormInner];
    PostScriptForm[thing_]:=StringTrim[StringReplace[StringJoin[" ",PostScriptFormInner[thing]],{
        " -1 mul "->" neg ",
        RegularExpression[" -1 ([A-Za-z][A-Za-z0-9]{4,}) mul "] -> " $1 neg ", (* mul div add sub neg atan exch dup sqrt: length ≤4. So ≥5 isn’t a relevant operator. *)
        " 1 exch div mul "->" div ",
        " div 1 atan "->" atan "
    }]];
    PostScriptFormInner[thing_Rational]:=If[Abs[Denominator[thing]/(2^IntegerExponent[Denominator[thing],2])/(5^IntegerExponent[Denominator[thing],5])]==1,ToString[N[thing,20],InputForm,NumberMarks->False],PostScriptFormInner[Numerator[thing]]<>" "<>PostScriptFormInner[Denominator[thing]]<>" div"];
    PostScriptFormInner[thing_?AtomQ]:=ToString[thing];
    PostScriptFormInner[thing_List]:=StringJoin@@Riffle[Map[PostScriptFormInner,thing],"\r\n"];
    PostScriptFormInner[MatrixForm[thing_]]:=PostScriptFormInner[thing];
    PostScriptFormInner[ArcTan[Times[Power[xThing_,n_],yThing_]]]:=StringJoin[PostScriptFormInner[yThing]," ",PostScriptFormInner[Power[xThing,-n]]," atan"]/;n<0;
    PostScriptFormInner[ArcTan[Times[yThing_,Power[xThing_,n_]]]]:=StringJoin[PostScriptFormInner[yThing]," ",PostScriptFormInner[Power[xThing,-n]]," atan"]/;n<0;
    PostScriptFormInner[ArcTan[Thing_]]:=StringJoin[PostScriptFormInner[Thing]," 1 atan "];
    PostScriptFormInner[ArcCsc[Times[h_,Power[x_,n_]]]]:=PostScriptFormInner[ArcTan[((x^(-n))//FullSimplify)/(Sqrt[h^2-x^(-2n)]//FullSimplify)]]/;n<0;
    PostScriptFormInner[ArcCsc[Times[Power[x_,n_],h_]]]:=PostScriptFormInner[ArcTan[((x^(-n))//FullSimplify)/(Sqrt[h^2-x^(-2n)]//FullSimplify)]]/;n<0;
    PostScriptFormInner[ArcCsc[Rational[h_,x_]]]:=PostScriptFormInner[ArcTan[(x//FullSimplify)/(Sqrt[h*h-x*x]//FullSimplify)]];
    
    PostScriptFormInner[thing_Power]:=(
        psExponent:=Which[
            #>5&&Divisible[#,3],psExponent[#/3]<>" dup dup mul mul",
            #>=5&&OddQ[#],"dup "<>psExponent[(#-1)/2]<>" dup mul mul" ,
            #>=4&&EvenQ[#],psExponent[#/2]<>" dup mul",
            #==3,"dup dup mul mul",
            #==2,"dup mul",
            #==1/2,"sqrt",
            #==3/2,"dup sqrt mul",
            #<0,psExponent[-#]<> " 1 exch div",
            (Rational===Head[#])&&(Log[2,#//Denominator]//IntegerQ),psExponent[Simplify[2#]]<>" sqrt",
            Not[IntegerQ[#]],PostScriptFormInner[#]<>" exp",
            #==1,"",
            True," !!!\[Bullet]\[Bullet]\[Bullet]Error with exponent = "<>ToString[#]<> "\[Bullet]\[Bullet]\[Bullet]!!! "
        ]&;
        Which[
            thing[[2]]>0||Not[IntegerQ[thing[[2]]]],PostScriptFormInner[thing[[1]]]<>" "<>psExponent[thing[[2]]],
            thing[[2]]==-1,"1 "<>PostScriptFormInner[thing[[1]]]<>" div",
            thing[[2]]==0,"1",
            True,"1 "<>PostScriptFormInner[thing[[1]]]<>" "<>psExponent[-thing[[2]]]<>" div"
        ]);
    
    PostScriptFormInner[thing_Times]:=StringJoin[PostScriptFormInner[-thing]," neg"]/;MemberQ[thing,-1];
    PostScriptFormInner[thing_Times]:=StringJoin@Riffle[Reap[If[MatchQ[thing[[1]],Power[_,n_Integer/;n<0]],(Sow["1 "<>PostScriptFormInner[thing[[1,1]]]<>" div"];),(Sow[PostScriptFormInner[thing[[1]]]];)];Map[(If[MatchQ[#,Power[_,n_Integer/;n<0]],(Sow[PostScriptFormInner[#[[1]]^(-#[[2]])]<>" div"];),(Sow[PostScriptFormInner[#]<>" mul"]; )])&,Drop[List@@thing,1]]][[2,1]]," "];
    
    PostScriptFormInner[thing_Plus]:=
    StringJoin@@If[FreeQ[thing,_^n_],
        (* Simple expression, no powers, to be summed one item at a time *)
        Module[{i},
            i=Position[thing,Except[Times[-1,_]|(_?Negative)],1,Heads->False];
            If[Length[i]>0,i=i[[1,1]],(i=Position[thing,Not[MatchQ[#,Times[-1,_]]]&,1,Heads->False];i=If[Length[i]>0,i[[1,1]],1])]; Prepend[Map[(" "<>Replace[#,{(n_Integer/;n<0:>ToString[-n]<>" sub"),(Times[-1,_]:>PostScriptFormInner[Times@@Drop[#,1]]<>" sub"),(Times[n_/;n<0,_]:>PostScriptFormInner[Times@@Drop[#,1]]<>" "<>ToString[-#[[1]]]<>" mul sub"),(Times[n_/;n>0,_]:>PostScriptFormInner[Times@@Drop[#,1]]<>" "<>ToString[#[[1]]]<>" mul add"),(_:>PostScriptFormInner[#]<>" add")}])&,Drop[List@@thing,{i}]],Replace[thing[[i]],{Times[-1,_]:>PostScriptFormInner[-thing[[i]]]<>" neg",_:>PostScriptFormInner[thing[[i]]]}]]  ],
        (* Polynomial *)
        Module[{vars,exps,v,rcl,i,firstMul},
            vars=Variables[thing];
            exps=Exponent[thing,vars];
            v=Select[Transpose[{vars,exps}],(#[[2]]==Max@@exps)&][[1,1]];
            rcl=Reverse[Map[Factor,CoefficientList[thing,v]]];
            Reap[
                i=1;firstMul=True;If[rcl[[1]]=!=1,Sow[PostScriptFormInner[rcl[[1]]]]];
    Map[If[#===0,i++,(Sow[If[firstMul&&rcl[[1]]===1,PostScriptFormInner[v^i]<>" "," "<>PostScriptFormInner[v^i]<>" mul "]<>If[MatchQ[#,(Times[_?Negative,_]|(_?Negative))],PostScriptFormInner[-#]<>" sub",PostScriptFormInner[#]<>" add"]];i=1;firstMul=False)]&,Drop[rcl,1]];
                If[i>1,Sow[" "<>PostScriptFormInner[v^(i-1)]<>" mul "]];
            ][[2,1]]
    ]];