
(* Copyright 1989, 1990 Wolfram Research Inc. *)

(*:Version: Mathematica 2.0 *)

(*:Title: Shapes of Common 3D Solids *)

(*:Author: Roman Maeder *)

(*:Keywords:
	Shapes, cylinder, cone, torus, sphere, MoebiusStrip,
	helix, DoubleHelix, wireframe
*)

(*:Requirements: none. *)

(*:Warnings: none. *)

(*:Sources:
	Roman E. Maeder: Programming in Mathematica, 2nd Ed.,
	Addison-Wesley, 1991.
*)

(*:Summary:
*)


BeginPackage["Graphics`Shapes`", "Geometry`Rotations`"]


Shapes::usage = "<<Graphics/Shapes.m defines functions for creating and
	manipulating graphic representations of various geometric objects."

Cylinder::usage = "Cylinder[(r:1, h:1, (n:20r))] is a list of n polygons
	approximating an open cylinder centered around the z-axis with
	radius r and half height h."

Cone::usage = "Cone[(r:1, h:1, (n:20r))] is a list of n polygons
	approximating a cone centered around the z-axis with
	radius r and extending from -h to h."

Torus::usage = "Torus[(r1:1, r2:0.5, (n:20r1, m:20r2))] is a list of n*m
	polygons approximating a torus centered around the z-axis with
	radii r1 and r2."

Sphere::usage = "Sphere[(r:1, (n:20r, m:15r))] is a list of n*(m-2)+2
	polygons approximating a sphere with radius r."

MoebiusStrip::usage = "MoebiusStrip[(r1:1, r2:0.5, (n:20r1))] is a list
	of 2n polygons approximating a moebius strip centered around
	the z-axis with radii r1 and r2."

Helix::usage = "Helix[(r:1, h:0.5, (m:2, n:20r))] is a list of n*m polygons
	approximating a helix with half height h and m turns."

DoubleHelix::usage = "DoubleHelix[(r:1, h:0.5, (m:2, n:20r))] is a list
	of n*m polygons approximating a double helix with half height h
	and m turns."

RotateShape::usage = "RotateShape[-Graphics3D-, phi, theta, psi] rotates
	the graphics object by the specified Euler angles."

TranslateShape::usage = "TranslateShape[-Graphics3D-, {x, y, z}] translates
	the graphics object by the specified vector."

AffineShape::usage = "AffineShape[-Graphics3D-, {x, y, z}] multiplies
	all coordinates by x, y, and z respectively."

WireFrame::usage = "WireFrame[-Graphics3D-] replaces all
	polygons in -Graphics3D- by outlines."

Begin["`Private`"]

MakeShape[vl_List, c1_Integer, c2_Integer] :=
    Block[{l = vl,
    	   l1 = RotateLeft /@ vl,
    	   mesh},
	mesh = {l, l1, RotateLeft[l1], RotateLeft[l]};
	If[c1 == 1, mesh = Map[Drop[#, -1]&, mesh, {1}] ];
	If[c2 == 1, mesh = Map[Drop[#, -1]&, mesh, {2}] ];
	(*Graphics3D[*) Polygon /@ Transpose[ Map[Flatten[#, 1]&, mesh] ] (*]*)
    ]					/; TensorRank[vl] >= 2
(* c1 = 0 closes the surface in the first dimension, c1 = 1 leaves it open
   and analogous for the second dimension *)

Cylinder[r_, h_, n_Integer] :=
    MakeShape[
	Block[{rcphi, rsphi},
	    Table[rcphi = N[r Cos[2Pi i/n]]; rsphi = N[r Sin[2Pi i/n]];
		  {{rcphi, rsphi, h}, {rcphi, rsphi, -h}}, {i,n}] ],
	0, 1]						/; n>2
Cylinder[r_:1, h_:1] := Cylinder[r, h, Round[20r]]

Cone[r_, h_, n_Integer] :=
	(*Graphics3D[*)N[Table[Polygon[{{r Cos[2Pi i/n], r Sin[2Pi i/n], -h},
			 {r Cos[2Pi (i+1)/n], r Sin[2Pi (i+1)/n], -h},
			 {0, 0, h}}], {i, 0, n-1}]](*]*)/; n > 2
Cone[r_:1, h_:1] := Cone[r, h, Round[20r]]

Torus[r1_, r2_, n_Integer, m_Integer] :=
    MakeShape[
	Block[{cphi, sphi, s},
	    Table[cphi = N[Cos[2Pi i/n]]; sphi = N[Sin[2Pi i/n]];
		  Table[s = N[r1 + r2 Cos[2Pi j/m]];
			{cphi s, sphi s, N[r2 Sin[2Pi j/m]]},
		       {j, m}],
	         {i, n}]],
	0, 0]						/; n>2 && m>2
Torus[r1_:1.0, r2_:0.5] := Torus[r1, r2, Round[20r1], Round[20r2]]

Sphere[r_, n_Integer, m_Integer] :=
    (*Graphics3D[Join[#[[1]], #[[2]]]]& [*)
    MakeShape[
	Block[{cphi, sphi, s},
	  Table[cphi = N[Cos[2Pi i/n]]; sphi = N[Sin[2Pi i/n]];
		Table[s = N[r Cos[-Pi/2+ Pi j/m]];
		      {cphi s, sphi s, N[r Sin[-Pi/2 + Pi j/m]]},
		     {j, 1, m-1}],
	       {i, 0, n-1}]],
	0, 1] ~Join~	(* pole patches *)
    Block[{s = N[r Cos[-Pi/2 + Pi/m]], z = N[r Sin[-Pi/2 + Pi/m]]},
	(*Graphics3D[*){Polygon[Table[{N[s Cos[2Pi i/n]],
			N[s Sin[2Pi i/n]],
			z},
		      {i, 0, n-1}]],
	 	    z=-z;
		    Polygon[Table[{N[s Cos[2Pi i/n]],
	 		N[s Sin[2Pi i/n]],
	 		z},
	 	      {i, n-1, 0, -1}]]
	}(*]*)
    ](*]*)				/; n>2 && m>2
Sphere[r_:1.0] := Sphere[r, Round[20r], Round[15r]]

MoebiusStrip::notes = "We go around it twice, so that shading comes out right."
MoebiusStrip[r1_, r2_, n_Integer] :=
    MakeShape[
	Block[{cphi, sphi, h, rs},
	  Table[rs = N[r2 Cos[Pi i/n]]; h = N[r2 Sin[Pi i/n]];
	        cphi = N[Cos[2Pi i/n]]; sphi = N[Sin[2Pi i/n]];
		{{(r1 + rs) cphi, (r1 + rs) sphi,  h},
		 {(r1 - rs) cphi, (r1 - rs) sphi, -h}},
	       {i,0,2n-1}]],
	0, 1]							/; n>2
MoebiusStrip[r1_:1.0, r2_:0.5] := MoebiusStrip[r1, r2, Round[20r1]]

Helix[r_, h_, m_, n_] :=
    MakeShape[
    	Block[{in, pin, hh = N[2h/m]},
	  Table[in = N[i/n]; pin = N[2Pi in];
	        {{0, 0, hh in}, {r Cos[pin], r Sin[pin], hh in}},
	       {i, -n m / 2, n m / 2}]],
	1, 1]
Helix[r_:1.0, h_:1.0, m_:2] := Helix[r, h, m, Round[20r]]

DoubleHelix[r_, h_, m_, n_] :=
    MakeShape[
    	Block[{rc, rs, ih, hh = N[2h/m]},
	  Table[rc = N[r Cos[2Pi i/n]]; rs = N[r Sin[2Pi i/n]]; ih = hh i/n;
		{{-rc, -rs, ih}, {0, 0, ih}, {rc, rs, ih}},
	       {i, -n m / 2, n m / 2}]],
	1, 1]
DoubleHelix[r_:1.0, h_:1.0, m_:2] := DoubleHelix[r, h, m, Round[20r]]

RotateShape[ shape_, phi_, theta_, psi_ ] :=
    Block[{rotmat = RotationMatrix3D[N[phi], N[theta], N[psi]]},
	shape /. { poly:Polygon[_] :> Map[(rotmat . #)&, poly, {2}],
		   line:Line[_]    :> Map[(rotmat . #)&, line, {2}],
		   point:Point[_]  :> Map[(rotmat . #)&, point,{1}] }
    ]

TranslateShape[shape_, vec_List] :=
    Block[{tvec = N[vec]},
	shape /. { poly:Polygon[_] :> Map[(tvec + #)&, poly, {2}],
		   line:Line[_]    :> Map[(tvec + #)&, line, {2}],
		   point:Point[_]  :> Map[(tvec + #)&, point,{1}] }
    ] /; Length[vec] == 3


AffineShape[ shape_, vec_List ] :=
    Block[{tvec = N[vec]},
	shape /. { poly:Polygon[_] :> Map[(tvec * #)&, poly, {2}],
		   line:Line[_]    :> Map[(tvec * #)&, line, {2}],
		   point:Point[_]  :> Map[(tvec * #)&, point,{1}] }
    ] /; Length[vec] == 3


WireFrame[shape_] := shape /. Polygon[x_] :> Line[ Append[x, First[x]] ]


End[]   (* Graphics`Shapes`Private` *)

Protect[Cylinder, Cone, Torus, Sphere, MoebiusStrip, Helix, DoubleHelix,
	RotateShape, TranslateShape, AffineShape, WireFrame]

EndPackage[]   (* Graphics`Shapes` *)

(*:Limitations:
*)

(*:Tests:
*)

(*:Examples:

Show[ Graphics3D[ Cylinder[ 0.5,0.5]]]

Show[ Graphics3D[ Cone[]]]

Show[ Graphics3D[ Torus[2,0.7,15,14]]]

Show[ Graphics3D[Sphere[]]]

Show[ Graphics3D[ MoebiusStrip[ 2,1,80]]]

Show[ Graphics3D[ Helix[] ] ]

Show[ Graphics3D[ DoubleHelix[] ] ]

Show[ RotateShape[ Graphics3D[ MoebiusStrip[] ], Pi/4, Pi/3, Pi/2 ] ]

Show[ TranslateShape[ RotateShape[ Graphics3D[ MoebiusStrip[] ], Pi/4, Pi/3,
   Pi/2 ], {2,3,4}] ]

Show[ AffineShape[ Graphics3D[ Cone[] ],{1,2,3} ] ]

Show[ WireFrame[ Graphics3D[ Cone[] ] ] ]

*)
