(* "RomBoy Deformation" (c) 1992 Stewart Dickson
        The metamorphosis (or homeotopy) of Steiner's
        "Quartic" or "Roman"  Surface
        into the Boy surface.

        From :    Francis, George ; "A Topological Picturebook",
                  New York : Springer - Verlag, 1987. "Figure Eight",
                  pp . 95 - 98.  *)





     Needs["Graphics`ThreeScript`"] ;  
     

     SetOptions[Graphics3D, Background -> RGBColor[0, 0, 0], Boxed -> False,           PlotRange -> All, RenderAll -> True] ;  
     


     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] ]
                 ] ;






     (* radii : *)
     r1 = r2 = 0.5 ;






     (* sliding parameter b : 0.0 -> Roman surface
        b = 1.0 / (3 ^ (1/2)) ;    -> all pinch points  cancelled
        b = 1.0 ; -> a good picture of the Boy surface *)






     Z1 = { r1 Cos[2 theta], r1 Sin[2 theta], 1 } ;
     Z2 = { r2 Cos[theta], -r2 Sin[theta], 0 } ;
     A = 1 / (1 + phi ^ 2) ;
     B = A (phi + 1.125 * phi ^ 2 + (phi ^ 3) / 128 ) ;






     (* For a more uniform parametric mesh, purturb phi : *)
     phi := N[Tan[tau]]






     b = 0 ;
     venusPolys1 = MakePolygons[Table[N[Z1 A + B Z2],
           {tau, 0, (Pi / 2) - 0.08, Pi / 20},
           {theta, 0, 2 Pi, Pi / 20}]] ;






     venusPolys2 = MakePolygons[Table[N[-Z1 A - B Z2],
           {tau, 0, (Pi / 2) - 0.08, Pi / 20},
           {theta, 0, 2 Pi, Pi / 20}]] ;






     venusOut = Graphics3D[ { venusPolys1, venusPolys2 } ] ;






     Show[venusOut]
[Graphics:Venus1gr1.gif] 
     - Graphics3D -


     ThreeScript["VenusGeom3.3s", venusOut] ;