# Triacontahedron

Nov 4th, 2018
135
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
1. (* Syntax: Wolfram, Code: Simon Tyran, Vienna, yukterez.net *)
2.
3. ecken={
4. {0,0,1/2 (-1-Sqrt[5])},
5. {0,0,1/2 (1+Sqrt[5])},
6. {1/10 (5-Sqrt[5]),Root[1-5 #1^2+5 #1^4&,1],1/10 (5+3 Sqrt[5])},
7. {1/10 (5-Sqrt[5]),Sqrt[1/10 (5+Sqrt[5])],1/10 (5+3 Sqrt[5])},
8. {2/Sqrt[5],0,1/10 (5+3 Sqrt[5])},
9. {1/10 (5+3 Sqrt[5]),Root[1-5 #1^2+5 #1^4&,1],1/10 (5+Sqrt[5])},
10. {1/10 (5+3 Sqrt[5]),Root[1-5 #1^2+5 #1^4&,1],1/10 (-5+Sqrt[5])},
11. {1/10 (5+3 Sqrt[5]),Sqrt[1/10 (5+Sqrt[5])],1/10 (5+Sqrt[5])},
12. {1/10 (5+3 Sqrt[5]),Sqrt[1/10 (5+Sqrt[5])],1/10 (-5+Sqrt[5])},
13. {-(2/Sqrt[5]),0,1/10 (-5-3 Sqrt[5])},
14. {-(1/Sqrt[5]),-Sqrt[1+2/Sqrt[5]],1/10 (5+Sqrt[5])},
15. {-(1/Sqrt[5]),-Sqrt[1+2/Sqrt[5]],1/10 (-5+Sqrt[5])},
16. {-(1/Sqrt[5]),Sqrt[1+2/Sqrt[5]],1/10 (5+Sqrt[5])},
17. {-(1/Sqrt[5]),Sqrt[1+2/Sqrt[5]],1/10 (-5+Sqrt[5])},
18. {1/Sqrt[5],-Sqrt[1+2/Sqrt[5]],1/10 (5-Sqrt[5])},
19. {1/Sqrt[5],-Sqrt[1+2/Sqrt[5]],1/10 (-5-Sqrt[5])},
20. {1/Sqrt[5],Sqrt[1+2/Sqrt[5]],1/10 (5-Sqrt[5])},
21. {1/Sqrt[5],Sqrt[1+2/Sqrt[5]],1/10 (-5-Sqrt[5])},
22. {-1-1/Sqrt[5],0,1/10 (5+Sqrt[5])},
23. {-1-1/Sqrt[5],0,1/10 (-5+Sqrt[5])},
24. {1/10 (-5-Sqrt[5]),Root[1-5 #1^2+5 #1^4&,2],1/10 (5+3 Sqrt[5])},
25. {1/10 (-5-Sqrt[5]),Sqrt[2/(5+Sqrt[5])],1/10 (5+3 Sqrt[5])},
26. {1/10 (5+Sqrt[5]),Root[1-5 #1^2+5 #1^4&,2],1/10 (-5-3 Sqrt[5])},
27. {1/10 (5+Sqrt[5]),Sqrt[2/(5+Sqrt[5])],1/10 (-5-3 Sqrt[5])},
28. {1+1/Sqrt[5],0,1/10 (5-Sqrt[5])},
29. {1+1/Sqrt[5],0,1/10 (-5-Sqrt[5])},
30. {1/10 (-5-3 Sqrt[5]),Root[1-5 #1^2+5 #1^4&,1],1/10 (5-Sqrt[5])},
31. {1/10 (-5-3 Sqrt[5]),Root[1-5 #1^2+5 #1^4&,1],1/10 (-5-Sqrt[5])},
32. {1/10 (-5-3 Sqrt[5]),Sqrt[1/10 (5+Sqrt[5])],1/10 (5-Sqrt[5])},
33. {1/10 (-5-3 Sqrt[5]),Sqrt[1/10 (5+Sqrt[5])],1/10 (-5-Sqrt[5])},
34. {1/10 (-5+Sqrt[5]),Root[1-5 #1^2+5 #1^4&,1],1/10 (-5-3 Sqrt[5])},
35. {1/10 (-5+Sqrt[5]),Sqrt[1/10 (5+Sqrt[5])],1/10 (-5-3 Sqrt[5])}};
36.
37. polygon={
38. {16,15,11,12},
39. {14,13,17,18},
40. {10,28,20,30},
41. {8,5,6,25},
42. {12,28,31,16},
43. {32,30,14,18},
44. {6,3,11,15},
45. {8,17,13,4},
46. {11,21,19,27},
47. {13,29,19,22},
48. {7,16,23,26},
49. {24,18,9,26},
50. {12,11,27,28},
51. {30,29,13,14},
52. {7,6,15,16},
53. {18,17,8,9},
54. {2,22,19,21},
55. {23,1,24,26},
56. {3,2,21,11},
57. {4,13,22,2},
58. {16,31,1,23},
59. {1,32,18,24},
60. {31,28,10,1},
61. {10,30,32,1},
62. {6,5,2,3},
63. {8,4,2,5},
64. {28,27,19,20},
65. {20,19,29,30},
66. {26,25,6,7},
67. {9,8,25,26}};
68.
69. x1=Max[ecken[[All, 1]]];
70. x2=Max[ecken[[All, 2]]];
71. x3=Max[ecken[[All, 3]]];
72.
73. f[α_,β_,δ_]:=RotationMatrix[α π/180,{0,1,0}].(RotationMatrix[β π/180,{0,0,1}].(RotationMatrix[δ π/180,{1,0,0}]));
74. solve[p_]:=Quiet[N[Reduce[x==pts[1, p, 1]]]];
75.
76. plane[p_,c_]:=InfinitePlane[Evaluate[Table[c ecken[[polygon[[p,k]]]],{k,2,4}]]];
77. cube[b_]:=Cuboid[b{-x1,-x2,-x3},b{+x1,+x2,+x3}];
78. pts[b_, p_,c_]:=Normal[Evaluate[Solve[{q,y,z}\[Element]plane[p,c]&&{q,y,z}\[Element]cube[b],{q,y,z},Reals]]][[1,1,2]];
79. opar=1; isize=400;
80.
81. plot[vp_,n_,ζ_,ς_,p_,s_,b_,r_,c_,ξ_,h_,α_,β_,δ_]:=Show[
82.
83. Graphics3D[{
84. Opacity[n],EdgeForm[Thickness[0.003]],Rotate[Rotate[Rotate[
85. GraphicsComplex[ecken,
86. Polygon[polygon]],
87. α π/180,{0,1,0}],β π/180,{0,0,1}],δ π/180,{1,0,0}]},SphericalRegion->True],
88.
89. Graphics3D[
90. {Opacity[ς],EdgeForm[Thickness[0.001]],FaceForm[Darker[Blue]],
91. Rotate[Rotate[Rotate[
92. InfinitePlane[Evaluate[Table[c ecken[[polygon[[p,k]]]],{k,2,4}]]],
93. α π/180,{0,1,0}],β π/180,{0,0,1}],δ π/180,{1,0,0}]},SphericalRegion->True],
94.
95. Graphics3D[
96. {Opacity[1],EdgeForm[Thickness[0.003]],FaceForm[Darker[Red]],Rotate[Rotate[Rotate[
97. GraphicsComplex[s ecken,
98. Polygon[polygon[[p]]]],
99. α π/180,{0,1,0}],β π/180,{0,0,1}],δ π/180,{1,0,0}]},SphericalRegion->True],
100.
101. Graphics3D[
102. {Opacity[1],EdgeForm[Thickness[0.003]],FaceForm[Darker[Red]],Rotate[Rotate[Rotate[
103. GraphicsComplex[s ecken,
104. Polygon[polygon[[p]]]],
105. α π/180,{0,1,0}],β π/180,{0,0,1}],δ π/180,{1,0,0}]},SphericalRegion->True],
106.
107. Graphics3D[
108. {Opacity[ζ],EdgeForm[Thickness[0.003]],
109. Rotate[Rotate[Rotate[
110. cube[b],
111. α π/180,{0,1,0}],β π/180,{0,0,1}],δ π/180,{1,0,0}]},SphericalRegion->True],
112.
113. If[1.0 α==0.,If[1.0 β==0.,If[1.0 δ==0.,If[h>0,If[p>2,
114. Quiet[ContourPlot3D[Evaluate[q==pts[1,p,1]],{q,-x1,+x1},{y,-x2,+x2},{z,-x3,+x3},
115. ContourStyle->Directive[Orange,Opacity[h],Specularity[White,30]]]],
116. {}],{}],{}],{}],{}],
117.
118. If[ξ>0,
119. Graphics3D[
120. Rotate[Rotate[Rotate[
121. {Opacity[opar],EdgeForm[Thickness[0.003]],Blue,Arrow[{{0,0,0},{2.1,0,0}}]},
122. α π/180,{0,1,0}],β π/180,{0,0,1}],δ π/180,{1,0,0}],SphericalRegion->True],
123. {}],
124.
125. If[ξ>0,
126. Graphics3D[
127. Rotate[Rotate[Rotate[
128. {Opacity[opar],EdgeForm[Thickness[0.003]],Red,Arrow[{{0,0,0},{0,2.1,0}}]},
129. α π/180,{0,1,0}],β π/180,{0,0,1}],δ π/180,{1,0,0}],SphericalRegion->True],
130. {}],
131.
132. If[ξ>0,
133. Graphics3D[
134. Rotate[Rotate[Rotate[
135. {Opacity[opar],EdgeForm[Thickness[0.003]],Darker[Green],Arrow[{{0,0,0},{0,0,2.1}}]},
136. α π/180,{0,1,0}],β π/180,{0,0,1}],δ π/180,{1,0,0}],SphericalRegion->True],
137. {}],
138.
139. If[ξ>0,
140. Graphics3D[
141. Rotate[Rotate[Rotate[
142. {Opacity[opar],EdgeForm[Thickness[0.003]],Blue,Line[{{0,0,0},{-2,0,0}}]},
143. α π/180,{0,1,0}],β π/180,{0,0,1}],δ π/180,{1,0,0}],SphericalRegion->True],
144. {}],
145.
146. If[ξ>0,
147. Graphics3D[
148. Rotate[Rotate[Rotate[
149. {Opacity[opar],EdgeForm[Thickness[0.003]],Red,Line[{{0,0,0},{0,-2,0}}]},
150. α π/180,{0,1,0}],β π/180,{0,0,1}],δ π/180,{1,0,0}],SphericalRegion->True],
151. {}],
152.
153. If[ξ>0,
154. Graphics3D[
155. Rotate[Rotate[Rotate[
156. {Opacity[opar],EdgeForm[Thickness[0.003]],Darker[Green],Line[{{0,0,0},{0,0,-2}}]},
157. α π/180,{0,1,0}],β π/180,{0,0,1}],δ π/180,{1,0,0}],SphericalRegion->True],
158. {}],
159.
160. If[ξ>0,
161. Graphics3D[
162. Rotate[Rotate[Rotate[
163. {Opacity[opar],PointSize[0.02],Blue,Point[{-2,0,0}]},
164. α π/180,{0,1,0}],β π/180,{0,0,1}],δ π/180,{1,0,0}],SphericalRegion->True],
165. {}],
166.
167. If[ξ>0,
168. Graphics3D[
169. Rotate[Rotate[Rotate[
170. {Opacity[opar],PointSize[0.02],Red,Point[{0,-2,0}]},
171. α π/180,{0,1,0}],β π/180,{0,0,1}],δ π/180,{1,0,0}],SphericalRegion->True],
172. {}],
173.
174. If[ξ>0,
175. Graphics3D[
176. Rotate[Rotate[Rotate[
177. {Opacity[opar],PointSize[0.02],Darker[Green],Point[{0,0,-2}]},
178. α π/180,{0,1,0}],β π/180,{0,0,1}],δ π/180,{1,0,0}],SphericalRegion->True],
179. {}],
180.
181. PlotRange->r,ViewPoint->vp,SphericalRegion->True,ImageSize->isize,Boxed->False];
182.
183. VP={{0,0,Infinity},{0,Infinity,0},{Infinity,0,0},{0,0,-Infinity},{0,-Infinity,0},{-Infinity,0,0}};
184. X0=x1; Y0=x2; Z0=x3;
185. T[text_, color_] := Style[text, FontSize->11, color];
186.
187. construct=Manipulate[
188. Grid[{
189. {Rasterize[plot[w VP[[1]],n,ζ,ς,p,s,b,r,c,ξ,h,α,β,δ], ImageSize->isize],
190. Rasterize[plot[w VP[[2]],n,ζ,ς,p,s,b,r,c,ξ,h,α,β,δ], ImageSize->isize]},
191. {Rasterize[plot[w VP[[3]],n,ζ,ς,p,s,b,r,c,ξ,h,α,β,δ], ImageSize->isize],
192. plot[1 VP[[6]],n,ζ,ς,p,s,b,r,c,ξ,h,0,0,0]},
193. {
194. Grid[{{T["x"==x/.Solve[solve[p],x],Black]},{T["y"==y/.Solve[solve[p],y],Black]},{T["z"==z/.Solve[solve[p],z],Black]}
195. }],
196. Grid[{{{T["α"->α,Black]},{T["β"->β,Black]},{T["δ"->δ,Black]}},
197. {{T["±X"->x1 1., Blue]}, {T["±Y"->x2 1., Red]}, {T["±Z"->x3 1., Darker[Green]]}}
198. }]}}],
199. {{n,1},0,1},
200. {{ζ,0.1},0,1},
201. {{ς,0.1},0,1/2},
202. {{r,2.7},1/3,10},
203. {{p,4},1,Length[polygon],1},
204. {{s,1.01},1,2},
205. {{b,1},0,1,1},
206. {{ξ,1},0,1,1},
207. {{c,-10},-10,1,11},
208. {{h,0.4},0,1,0.2},
209. {{w,1},-1,1,2},
210. {α,0,360,1},
211. {β,0,360,1},
212. {δ,0,360,1}
213. ];
214.
215. construct
RAW Paste Data