6
$\begingroup$

Mathematica has very useful functions CForm and FortranForm. I want the same for a different language: PostScriptForm, which would convert Mathematica expressions to the stack-based, reverse-polish, single-precision 1980s page-description language called PostScript.

To solve a slight generalisation of a circle-packing problem, I have output from GroebnerBasis[] (which was suggested in an earlier request for help). It has output the nine coefficients of an octic equation, the coefficients being polynomials of order up to 8 in three parameters, with a total of 139 terms.

I could convert it to PostScript by hand, with multiple errors being found by numerical checks. Yuck. Is there better? Is there a ‘LanguageForm’ for any stack-based, reverse-polish language, even if not for PostScript?

Presumably I could attempt to write PostScriptForm myself. Mathematica code could trace the expression tree, doing the obvious steps. But that would produce rubbish PostScript. For example, consider (ComplicatedExpression)*(1+ComplicatedExpression). Recursing the tree would produce PostScript that twice executed ComplicatedExpression. It would be much more elegant to have PostScript resembling ComplicatedExpression dup 1 add mul, the dup duplicating the top item on the stack. Please, is there existing Mathematica code that comes near this // PostScriptForm task?

And for those interested, my 12k lines of PostScript can be found by following this link.

$\endgroup$
  • 1
    $\begingroup$ Maybe this helps: With[{ComplicatedExpression = x^2}, Experimental`OptimizeExpression[{(ComplicatedExpression)*(1 + ComplicatedExpression)}]] $\endgroup$ – Michael E2 Dec 13 '15 at 2:33
7
$\begingroup$

Progress, at least for my purposes. This is not a proper ‘PostScriptForm’, which should cope elegantly with all kinds of difficult cases. But it does satisfy my needs, mostly the PostScript’ification of polynomials of degree ≤8 in a few variables.

I expect that I have not structured the code in a natural Mathematica idiom. Please suggest improvements.

Mathematica: http://www.jdawiseman.com/2015/20151227_PostscriptForm.nb (superseding earlier versions at www.jdawiseman.com/2015/20151218_PostscriptForm.nb www.jdawiseman.com/2015/20151220_PostscriptForm.nb www.jdawiseman.com/2015/20151225_PostscriptForm.nb)

Test of example polynomial: http://www.jdawiseman.com/2015/20151218_PostscriptForm.ps

Edit (2015-12-18 12:30), adding problems and questions. • Can’t find any combination of new-line or carriage-return type chars that correctly copy into my code editor (AlphaX 8.2b13 under Mac OS X 10.11.2). • Output not as concise as possible: that which I hand-coded a few days ago is shorter. That’s going to be handling of lots of special cases. Sigh. • I’d like the output wrapped such that each line is at most, say, 250 characters (so leaving room for some indenting tabs). Currently doing that by hand. Is that easy in Mathematica string manipulation?

Edit (2015-12-28 00:50):

(* 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
*)
Remove[PostScriptForm];
PostScriptForm[thing_Rational] := 
  ToString[N[thing, 20], InputForm, NumberMarks -> False];
PostScriptForm[thing_?AtomQ] := ToString[thing];
PostScriptForm[thing_List] := 
  StringJoin @@ Riffle[Map[PostScriptForm, thing], "\r\n"];
PostScriptForm[MatrixForm[thing_]] := PostScriptForm[thing];
PostScriptForm[Times[-1, thing_]] := 
  StringJoin[PostScriptForm[thing], " neg"];

PostScriptForm[thing_Power] := (
    psExponent[n_Integer /; n >= 1] := Which[
            n == 1, "",
            n == 2, "dup mul",
            n == 3, "dup dup mul mul",
            EvenQ[n], psExponent[n/2] <> " dup mul",
            Divisible[n, 3], psExponent[n/3] <> " dup dup mul mul",
            True, "dup " <> psExponent[(n - 1)/2] <> " dup mul mul" (* 
     Must be odd *)
        ];
    Which[
            thing[[2]] == -1, "1 " <> PostScriptForm[thing[[1]]] <> " div",
            thing[[2]] == 0, "1",
            (Rational === Head[thing[[2]]]) && 
     IntegerQ[Log[2, Denominator[thing[[2]]]]], 
    PostScriptForm[thing[[1]]^Simplify[2*thing[[2]]]] <> " sqrt",
            Not[IntegerQ[thing[[2]]]], 
    PostScriptForm[thing[[1]]] <> " " <> PostScriptForm[thing[[2]]] <>
      " exp",
            thing[[2]] > 0, 
    PostScriptForm[thing[[1]]] <> " " <> psExponent[thing[[2]]],
            True, 
    "1 " <> PostScriptForm[thing[[1]]] <> " " <> 
     psExponent[-thing[[2]]] <> " div"
        ]);

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

PostScriptForm[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, _] :> 
              PostScriptForm[Times @@ Drop[#, 1]] <> " sub"), (Times[
               n_ /; n < 0, _] :> 
              PostScriptForm[Times @@ Drop[#, 1]] <> " " <> 
               ToString[-#[[1]]] <> " mul sub"), (Times[
               n_ /; n > 0, _] :> 
              PostScriptForm[Times @@ Drop[#, 1]] <> " " <> 
               ToString[#[[1]]] <> " mul add"), (_ :> 
              PostScriptForm[#] <> " add")}]) &, 
       Drop[List @@ thing, {i}]], 
      Replace[
       thing[[i]], {Times[-1, _] :> 
         PostScriptForm[-thing[[i]]] <> " neg", _ :> 
         PostScriptForm[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[PostScriptForm[rcl[[1]]]]];
       Map[
        If[# === 0, 
          i++, (Sow[
            If[firstMul && rcl[[1]] === 1, PostScriptForm[v^i] <> " ",
               " " <> PostScriptForm[v^i] <> " mul "] <> 
             If[MatchQ[#, (Times[_?Negative, _] | (_?Negative))], 
              PostScriptForm[-#] <> " sub", 
              PostScriptForm[#] <> " add"]]; i = 1; 
           firstMul = False)] &, Drop[rcl, 1]];

       If[i > 1, Sow[" " <> PostScriptForm[v^(i - 1)] <> " mul "]];
            ][[2, 1]]
     ]];

Test code:

Map[{#, PostScriptForm[#]} &,
  {9 + n, 9 - n, -9 + n, -9 - n, 1/n, 2 n^-1, n^-2, 
   3 n^-11, -(a b/c/d ) e, f g h, 
   a + 4 b - 2 c, -(a b/c/d ) e + f g h, b b + a b, 
   Sqrt[2], (a a + 2 a b + b b), (a a - 2 a b - b b)^3, 
   1 + 2 r + 3 r^2 + 4 r^3 + 5 r^4 + 6 r^5, 
   1 - 5 r^4 + 6 r^5, -1 - 5 r^4 + r^5, r^(91/32), r^(
   91/48)}] // MatrixForm
$\endgroup$
  • $\begingroup$ Seems quite reasonable, and gets my vote. You should put the code directly into your response though. Along with a modest size example. $\endgroup$ – Daniel Lichtblau Dec 19 '15 at 20:59
  • $\begingroup$ Very well, I will — but rather than doing that formatting effort twice, first allow me to finish a few rounds of improvements (which will also include MIT Software licensing and a pointer to this thread). $\endgroup$ – jdaw1 Dec 20 '15 at 12:51
  • $\begingroup$ @Daniel Lichtblau: done, following help received in mathematica.stackexchange.com/questions/102508/… $\endgroup$ – jdaw1 Dec 20 '15 at 21:19
  • $\begingroup$ Oops: bug. Fixed. Sorry. Also a separate improvement. $\endgroup$ – jdaw1 Dec 20 '15 at 22:58
  • $\begingroup$ Nice work, how to make it work with non symbolic computation ? E.G: PostScriptForm[1 + 3*5] = 16 and not "1 3 5 MUL ADD" $\endgroup$ – Crypto Dec 22 '15 at 13:07
4
$\begingroup$

Not sure if this is quite what you want, but it seems close. Code stolen from this older MSE post and modified for post-order of operands.

depthFirstPostorder[expr_] := 
 Module[{stack = {expr, {}}, el = expr},
  Reap[
    While[stack =!= {},
      {el, stack} = stack;
      If[AtomQ[el], Sow[el]];
      If[Not[AtomQ[el]],
       stack = {Head[el], stack};
       Do[stack = {el[[j]], stack}, {j, Length[el], 1, -1}]];];][[2, 
    1]]]

Here is a simple example.

expr = a + b*c - d^2*e;
depthFirstPostorder[expr]

(* Out[63]= {a, b, c, Times, -1, d, 2, Power, e, Times, Plus} *)
$\endgroup$
  • $\begingroup$ That points in the correct direction, thank you. It would need more work (PostScript operators such as add, sub, mul, div, idiv, exp and atan all take exactly two operators; the likes of sqrt, sin (trigonometry all in degrees not radians), cos, ln (natural), log (base 10), abs, neg, ceiling, floor, round, all take one parameter). The output might gain efficiency by checking for repeated expressions and expression parts, dup or copy, them, and use stack manipulations such as exch and roll. If not already written, too complicated for me. $\endgroup$ – jdaw1 Dec 13 '15 at 23:00
  • $\begingroup$ And I have done it by hand—which I tried to copy into this comment, but it was too long by 2049 characters. $\endgroup$ – jdaw1 Dec 13 '15 at 23:04
  • 1
    $\begingroup$ @jdaw1, why not write it as an answer? Then people can offer suggestions or tweaks. $\endgroup$ – J. M. will be back soon Dec 14 '15 at 3:26
  • $\begingroup$ @J.M. Because ‘by hand’ meant converting it to PostScript by hand, the laborious way. Except that I have just realised that I’ll need to do the same for an even bigger equation—yuck—so am now trying, I think rather badly, to construct something that will do it for me. $\endgroup$ – jdaw1 Dec 14 '15 at 16:55
  • 3
    $\begingroup$ This will get very untidy if done via comments. You can put them together in an answer (it's fine to post an answer to one's own question), and as you extend the code you simply edit the answer and put the extensions in there. $\endgroup$ – Daniel Lichtblau Dec 15 '15 at 0:08
0
$\begingroup$

Recently some functionality has been added, so updated code being posted.

To do: want to replace more of the ‘-1 … mul’ with ‘… neg’. Current code works in some situations, but fails with the likes of a-b^2. Suggestions welcomed.

(* 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]]
    ]];
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.