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
With[{ComplicatedExpression = x^2}, Experimental`OptimizeExpression[{(ComplicatedExpression)*(1 + ComplicatedExpression)}]]– Michael E2 Dec 13 '15 at 02:33