home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / e / e032 / 3.ddi / FILES / GRAPHICS.PAK / POLYHEDR.M < prev    next >
Encoding:
Text File  |  1992-07-29  |  7.9 KB  |  271 lines
  1.  
  2. (* Copyright 1989, 1990 Wolfram Research Inc. *)
  3.  
  4. (*:Version: Mathematica 2.0 *)
  5.  
  6. (*:Name: Graphcs`Polyhedra` *)
  7.  
  8. (*:Title: Graphics with Platonic Polyhedra  *)
  9.  
  10. (*:Author: Roman Maeder *)
  11.  
  12. (*:Keywords:
  13.     Polyhedron, vertices, faces, Stellate,
  14.     Tetrahedron, Cube, Octahedron,
  15.     Dodecahedron, Icosahedron, Hexahedron,
  16.     GreatDodecahedron, SmallStellatedDodecahedron,
  17.     GreatStellatedDodecahedron, GreatIcosahedron
  18. *)
  19.  
  20. (*:Requirements: none. *)
  21.  
  22. (*:Warnings:
  23.     Faces[] and Vertices[] fail on
  24.     GreatDodecahedron, SmallStellatedDodecahedron, and
  25.     GreatStellatedDodecahedron.
  26. *)
  27.  
  28. (*:Source:
  29.     Roman E. Maeder: Programming in Mathematica, 2nd Ed.,
  30.     Addison-Wesley, 1991.
  31. *)
  32.  
  33. (*:Summary:
  34. This package plots various Platonic polyhedra.  One can also
  35. access the coordinates of the vertices and the vertex numbers
  36. of each face of the solids.
  37. *)
  38.  
  39.  
  40. BeginPackage["Graphics`Polyhedra`"]
  41.  
  42. Polyhedron::usage = "Polyhedron[name] gives a Graphics3D object
  43. representing the specified solid centered at the origin and with
  44. unit distance to the midpoints of the edges.  Polyhedron[name,
  45. center, size] uses the given center and size. The possible names
  46. are in the list Polyhedra."
  47.  
  48. Vertices::usage = "Vertices[name] gives a list of the vertex coordinates
  49.     for the named solid."
  50.  
  51. Faces::usage = "Faces[name] gives a list of the faces for the named
  52. solid.  Each face is a list of the numbers of the vertices that
  53. comprise that face."
  54.  
  55. Stellate::usage = "Stellate[expr, (ratio:2)] replaces each polygon
  56. in expr by a pyramid with the polygon as its base.  Stellation
  57. ratios less than 1 give concave figures."
  58.  
  59. Polyhedra::usage = "Polyhedra is a list of the known polyhedra."
  60.  
  61. Polyhedra = {Tetrahedron, Cube, Octahedron,
  62.     Dodecahedron, Icosahedron, Hexahedron,
  63.     GreatDodecahedron, SmallStellatedDodecahedron,
  64.     GreatStellatedDodecahedron, GreatIcosahedron}
  65.  
  66. Map[(Evaluate[#]::"usage" =
  67.     StringJoin[ToString[#],
  68.         " is a kind of polyhedron, for use with
  69.         the Polyhedron[] function.  See Polyhedron."])&,
  70.     Polyhedra]
  71.  
  72.  
  73. Begin["`Private`"]
  74.  
  75. Polyhedron[name_Symbol, opts___ ] := 
  76.     PolyGraphics3D[ Vertices[name], Faces[name], opts ] /;
  77.                 MemberQ[Polyhedra, name]
  78.  
  79. PolyGraphics3D[ vertices_, faces_, pos_:{0.0,0.0,0.0}, scale_:1.0 ] :=
  80.     Graphics3D[ Polygon /@
  81.         Map[scale # + pos &, (vertices[[#]]&) /@ faces, {2}] ]
  82.  
  83. Norm[ v_ ] := Sqrt[Plus @@ (v^2)]
  84. Apex[ v_ ] := Plus @@ v / Length[v]
  85.  
  86. DualFace[ vertex_, faces_ ] :=
  87.     Block[{incident, current, newfaces={}, newface},
  88.         incident = Select[ faces, MemberQ[#, vertex]& ];
  89.         incident = RotateLeft[#, Position[#, vertex][[1,1]]-2]& /@ incident;
  90.         incident = Take[#, 3]& /@ incident;
  91.         current = incident[[1]];
  92.         While[incident =!= {},
  93.             newface = Select[ incident,
  94.               Length[Intersection[#, current]] > 1& ] [[1]];
  95.             AppendTo[ newfaces,
  96.               Position[faces, _List?(Length[Intersection[#, newface]]==3 &)] [[1, 1]] ];
  97.             current = newface;
  98.             incident = Complement[ incident, {current} ];
  99.         ];
  100.         newfaces
  101.     ]
  102.  
  103. DualFaces[name_] :=
  104.     Block[{i, faces = Faces[name], vertices = Vertices[name]},
  105.         Table[ DualFace[i, faces], {i, Length[vertices]} ]
  106.     ]
  107.  
  108. DualVertices[name_] :=
  109.     Block[{faces = Faces[name], vertices = Vertices[name],
  110.            dvertices, length1, length2},
  111.         dvertices = Apex /@ (vertices[[#]]&) /@ faces;
  112.         length1 = Norm[ (vertices[[faces[[1,1]]]] +
  113.                         vertices[[faces[[1,2]]]])/2 ];
  114.         dvertices = dvertices / length1;
  115.         dvertices = 1/Norm[#]^2 # & /@ dvertices;
  116.         dvertices
  117.     ]
  118.  
  119. Tetrahedron /: Faces[Tetrahedron] =
  120.      {{1, 2, 3}, {1, 3, 4}, {1, 4, 2}, {2, 4, 3}}
  121.  
  122. Tetrahedron /: Vertices[Tetrahedron] = N[
  123.      {{0, 0, 3^(1/2)}, {0, (2*2^(1/2)*3^(1/2))/3, -3^(1/2)/3}, 
  124.       {-2^(1/2), -(2^(1/2)*3^(1/2))/3, -3^(1/2)/3}, 
  125.       {2^(1/2), -(2^(1/2)*3^(1/2))/3, -3^(1/2)/3}} ]
  126.  
  127. Hexahedron /: Faces[Hexahedron] =
  128.      {{1, 2, 3, 4}, {1, 4, 6, 7}, {1, 7, 8, 2},
  129.       {2, 8, 5, 3}, {5, 8, 7, 6}, {3, 5, 6, 4}}
  130.  
  131. Hexahedron /: Vertices[Hexahedron] = N[Sqrt[2]/2] *
  132.      {{1, 1, 1}, {-1, 1, 1}, {-1, -1, 1}, {1, -1, 1},
  133.       {-1, -1, -1}, {1, -1, -1}, {1, 1, -1}, {-1, 1, -1}}
  134.  
  135. Cube/: Faces[Cube] := Faces[Hexahedron]
  136. Cube/: Vertices[Cube] := Vertices[Hexahedron]
  137.  
  138. Octahedron /: Faces[Octahedron] =
  139.      {{1, 2, 3}, {1, 3, 5}, {1, 5, 6}, {1, 6, 2},
  140.       {2, 6, 4}, {2, 4, 3}, {4, 6, 5}, {3, 4, 5}}
  141.  
  142. Octahedron /: Vertices[Octahedron] = N[Sqrt[2]] *
  143.      {{0, 0, 1}, {1, 0, 0}, {0, 1, 0},
  144.       {0, 0, -1}, {-1, 0, 0}, {0, -1, 0}}
  145.  
  146. SphericalToCartesian[{theta_, phi_}] :=
  147.     {Sin[theta] Cos[phi], Sin[theta] Sin[phi], Cos[theta]}
  148.  
  149. Icosahedron /: Faces[Icosahedron] =
  150.   {{1, 3, 2}, {1, 4, 3}, {1, 5, 4}, {1, 6, 5}, {1, 2, 6},
  151.    {2, 3, 7}, {3, 4, 8}, {4, 5, 9}, {5, 6, 10}, {6, 2, 11},
  152.    {7, 3, 8}, {8, 4, 9}, {9, 5, 10}, {10, 6, 11}, {11, 2, 7},
  153.    {7, 8, 12}, {8, 9, 12}, {9, 10, 12}, {10, 11, 12}, {11, 7, 12}}
  154.  
  155. Icosahedron /: Vertices[Icosahedron] :=
  156.     Icosahedron /: Vertices[Icosahedron] =
  157.    N[ N[ (SphericalToCartesian /@
  158.     {{0,0},
  159.      {ArcTan[2], 0}, {ArcTan[2], 2Pi/5}, {ArcTan[2], 4Pi/5},
  160.        {ArcTan[2], 6Pi/5}, {ArcTan[2], 8Pi/5},
  161.      {Pi - ArcTan[2], Pi/5}, {Pi - ArcTan[2], 3Pi/5},
  162.        {Pi - ArcTan[2], 5Pi/5}, {Pi - ArcTan[2], 7Pi/5},
  163.        {Pi - ArcTan[2], 9Pi/5},
  164.      {Pi,0}
  165.     })/(1/2 + Cos[ArcTan[2]]/2)^(1/2),
  166.        2 Precision[1.0] ]
  167.     ]
  168.  
  169. Dodecahedron/: Vertices[Dodecahedron] :=
  170.     Dodecahedron/: Vertices[Dodecahedron] =
  171.         DualVertices[Icosahedron]
  172. Dodecahedron/: Faces[Dodecahedron] :=
  173.     Dodecahedron/: Faces[Dodecahedron] =
  174.         DualFaces[Icosahedron]
  175.  
  176. GreatDodecahedron/:
  177. Polyhedron[ GreatDodecahedron, opts___ ] :=
  178.     Stellate[ Polyhedron[Icosahedron, opts], 1/Sqrt[2] ]
  179.  
  180. SmallStellatedDodecahedron/:
  181. Polyhedron[ SmallStellatedDodecahedron, opts___ ] :=
  182.     Stellate[ Polyhedron[Dodecahedron, opts], Sqrt[5] ]
  183.  
  184. GreatStellatedDodecahedron/:
  185. Polyhedron[ GreatStellatedDodecahedron, opts___ ] :=
  186.     Stellate[ Polyhedron[Icosahedron, opts], 3 ]
  187.  
  188. AdjacentTo[face_, flist_] :=
  189.     Select[flist, Length[Intersection[face, #]] == 2&]
  190.  
  191. Opposite[face_, flist_] :=
  192.     Block[ {adjacent, next},
  193.         adjacent = AdjacentTo[ face, flist ];
  194.         next = AdjacentTo[#, flist]& /@ adjacent;
  195.         next = Complement[#, {face}]& /@ next;
  196.         Flatten[ Intersection @@ #& /@ next ]
  197.     ]
  198.  
  199. GreatIcosahedron/: Vertices[GreatIcosahedron] := Vertices[Icosahedron];
  200.  
  201. GreatIcosahedron/: Faces[GreatIcosahedron] :=
  202.     GreatIcosahedron/: Faces[GreatIcosahedron] =
  203.         Opposite[#, Faces[Icosahedron]]& /@ Faces[Icosahedron];
  204.  
  205.  
  206. StellateFace[face_List, k_] :=
  207.     Block[ { apex,  n = Length[face], i } ,
  208.         apex = N [ k Apply[Plus, face] / n ] ;
  209.         Table[ Polygon[ {apex, face[[i]], face[[ Mod[i, n] + 1 ]] }
  210.                   ],
  211.              {i, n} ]
  212.     ]
  213.     
  214. Stellate[poly_, k_:2] := 
  215.     Flatten[ poly /. Polygon[x_] :> StellateFace[x, k] ] /;
  216.         NumberQ[N[k]]
  217.  
  218.  
  219. (* Compatibility with V1.1 Polyhedra.m *)
  220.  
  221.  
  222. GreatStellatedDodecahedron[opts___] :=
  223.     Polyhedron[GreatStellatedDodecahedron, opts][[1]]
  224.  
  225. SmallStellatedDodecahedron[opts___] :=
  226.     Polyhedron[SmallStellatedDodecahedron, opts][[1]]
  227.  
  228. GreatDodecahedron[opts___] := Polyhedron[GreatDodecahedron, opts][[1]]
  229.  
  230. Dodecahedron[opts___] := Polyhedron[Dodecahedron, opts][[1]]
  231.  
  232. GreatIcosahedron[opts___] :=
  233.     Polyhedron[GreatIcosahedron, opts][[1]]
  234.  
  235. Icosahedron[opts___] := Polyhedron[Icosahedron, opts][[1]]
  236.  
  237. Octahedron[opts___] := Polyhedron[Octahedron, opts][[1]]
  238.  
  239. Cube[opts___] := Polyhedron[Cube, opts][[1]]
  240.  
  241. Hexahedron[opts___]:= Polyhedron[Hexahedron, opts][[1]] 
  242.  
  243. Tetrahedron[opts___] := Polyhedron[Tetrahedron, opts][[1]]
  244.  
  245. End[]   (* Graphics`Polyhedra`Private` *)
  246.  
  247. Protect[ Polyhedron, Stellate, Vertices, Faces ]
  248.  
  249. EndPackage[]   (* Graphics`Polyhedra` *)
  250.  
  251. (*:Limitations:
  252. *)
  253.  
  254. (*:Tests:
  255. *)
  256.  
  257. (*:Examples:
  258.  
  259. Show[ Polyhedron[Dodecahedron] ]
  260.  
  261. Show[ Polyhedron[ GreatStellatedDodecahedron]]
  262.  
  263. Vertices[Dodecahedron]
  264.  
  265. Faces[ Icosahedron ]
  266.  
  267. Show[ Stellate[ Polyhedron[ Octahedron ] ] ]
  268.  
  269. *)
  270.  
  271.