(* Steiner's "Quartic" Surface (c) 1990 Stewart Dickson *)

(* This is a one-liner.  *)

MakePolygons[vl_List] :=
    Block[{l = vl,
           l1 = Map[RotateLeft, vl],
           mesh},
        mesh = {l, RotateLeft[l], RotateLeft[l1], l1};
        mesh = Map[Drop[#, -1]&, mesh, {1}];
        mesh = Map[Drop[#, -1]&, mesh, {2}];
        Polygon /@ Transpose[ Map[Flatten[#, 1]&, mesh] ]
    ]

quarticpolys = MakePolygons[Table[{-(Cos[v]*Sin[u]*Sin[v]),
    -(Cos[u]*Cos[v]^2*Sin[u]),
    -(Cos[u]*Cos[v]*Sin[v])}, {u, 0, Pi, Pi / 24}, {v, 0, 2 Pi, Pi / 24}]];


centerview = {1.3, -2.4, 2.};

VecLen[{x_, y_, z_}] := Sqrt[N[x ^2 + y ^2 + z ^2]];
Cross[u_List, v_List] := Det[{{{1, 0, 0}, {0, 1, 0}, {0, 0, 1}}, u, v}];
 
centerline = {0.0, 0.0, -1.0};
eyeline = Cross[centerline, centerview];
ueyeline = eyeline / VecLen[eyeline];
viewdist = VecLen[centerview];
eyedist = viewdist / 24;
leftview = centerview + eyedist * ueyeline;
rightview = centerview - eyedist * ueyeline;
leftplot = Graphics3D[quarticpolys, ViewPoint -> leftview, Boxed->False,
	AspectRatio->.47,
        Background->RGBColor[0, 0, 0], RenderAll->False, LightSources -> 
        {{{0.7071, 0, 0.7071}, RGBColor[0.9481, 0, 0]}, 
        {{0.5773, 0.5773, 0.5773}, RGBColor[0, 0.8888, 0]}, 
        {{0, 0.7071, 0.7071}, RGBColor[0, 0, 1]}}
        ]
Display["quartic_left.ps", leftplot];
Clear[leftplot];

rightplot = Graphics3D[quarticpolys, ViewPoint -> rightview, Boxed->False,
	AspectRatio->.47,
        Background->RGBColor[0, 0, 0], RenderAll->False, LightSources -> 
        {{{0.7071, 0, 0.7071}, RGBColor[0.9481, 0, 0]}, 
        {{0.5773, 0.5773, 0.5773}, RGBColor[0, 0.8888, 0]}, 
        {{0, 0.7071, 0.7071}, RGBColor[0, 0, 1]}}
        ]
Display["quartic_right.ps", rightplot]
