projection of {-1,1}*{-1,1} to a ruled tetrahedral surface in rectangles

• To: mathgroup at smc.vnet.net
• Subject: [mg52709] projection of {-1,1}*{-1,1} to a ruled tetrahedral surface in rectangles
• From: Roger Bagula <tftn at earthlink.net>
• Date: Thu, 9 Dec 2004 20:24:02 -0500 (EST)
• Sender: owner-wri-mathgroup at wolfram.com

```Clear[x,y,a,g,p,k]
(* projection of {-1,1}*{-1,1} to a ruled tetrahedral surface in
rectangles*)
x[t_,p_]:=(1-p)*Cos[t]/Max[Abs[Cos[t]],Abs[Sin[t]]]
y[t_,p_]:=(1+p)*Sin[t]/Max[Abs[Cos[t]],Abs[Sin[t]]]
p=(k+1)/10
g=Table[ParametricPlot[{x[t,p],y[t,p]},{t,-Pi,Pi},
PlotRange->{{-1.25,1.25},{-1.25,1.25}}],{k,0,8}];
Show[g,PlotRange->All]
ga=ParametricPlot3D[{x[Pi*t,p],y[Pi*t,p],p},{t,-1,1},{p,-1,1},Axes->False,Boxed->False,PlotPoints->40]

Show[ga,ViewPoint->{1.517, 1.467, 2.645}]
selectgraphics3d[graphics3dobj_,bound_,opts___]:=
Show[Graphics3D[Select[graphics3dobj,
(Abs[#[[1,1,1]]] < bound &&  Abs[#[[1,1,2]]] < bound &&
Abs[#[[1,1,3]]] < bound &&  Abs[#[[1,2,1]]] < bound &&
Abs[#[[1,2,2]]] < bound &&  Abs[#[[1,2,3]]] < bound &&
Abs[#[[1,3,1]]] < bound &&  Abs[#[[1,3,2]]] < bound &&
Abs[#[[1,3,3]]] < bound &&  Abs[#[[1,4,1]]] < bound &&
Abs[#[[1,4,2]]] < bound &&  Abs[#[[1,4,2]]] < bound
)&]],opts]
dip[ins_][g_]:=\$DisplayFunction[Insert[g,ins,{1,1}]]
selectgraphics3d[ga[[1]],8,Boxed->False,PlotRange->All,DisplayFunction->dip[EdgeForm[]]]

Respectfully, Roger L. Bagula