Pensieve Header: Making a Dodecahedral Link. See also http://www.math.toronto.edu/drorbn/Gallery/KnottedObjects/Knotted532.html.

SetDirectory["C:\\drorbn\\AcademicPensieve\\2011-12"];

g=N[GoldenRatio]

Graphics3D[{
Hue[0],
Polygon[{{1,1,1}, {1,-1,1},{1,-1,-1},{1,1,-1}}],
Polygon[{{1,1,1}, {1,-1,1}, {g, -1/g, 0}, {g, 1/g,0}}],
Polygon[{{1,1,-1}, {1,-1,-1}, {g, -1/g, 0}, {g, 1/g,0}}],
Polygon[{{1,1,1},{1,1,-1},{g,1/g,0}}],
Polygon[{{1,-1,1},{1,-1,-1},{g,-1/g,0}}]
}]

roof[s_, j_] := {
Polygon[{{1,1,1}, {1,-1,1},{1,-1,-1},{1,1,-1}}],
Polygon[{{1,1,1}, {1,-1,1}, {g, -1/g, 0}, {g, 1/g,0}}],
Polygon[{{1,1,-1}, {1,-1,-1}, {g, -1/g, 0}, {g, 1/g,0}}],
Polygon[{{1,1,1},{1,1,-1},{g,1/g,0}}],
Polygon[{{1,-1,1},{1,-1,-1},{g,-1/g,0}}]
} /. {x_?NumberQ, y_?NumberQ, z_?NumberQ} :> RotateLeft[{s x,y,z}, j]

Graphics3D[{
Opacity[0.7],
Hue[0/6], roof[1,0], Hue[1/6], roof[1,1], Hue[2/6], roof[1,2],
Hue[3/6], roof[-1,0], Hue[4/6], roof[-1,1], Hue[5/6], roof[-1,2]
}, Boxed -> False]

vs=Sort[Flatten[{
Outer[Vertex, {1,-1}, {1,-1}, {1,-1}],
Outer[Vertex, {0}, {1,-1}g, {1,-1}/g] /. v_Vertex :> {v, RotateLeft[v], RotateRight[v]}
}]] /. Vertex -> List

d[v1_, v2_] := Sqrt[(v1-v2).(v1-v2)];
es={};
Do[
If[d[vs[[i]], vs[[j]]] == Sqrt[1+(1-g)^2+(1-1/g)^2], AppendTo[es, Edge[i,j]]],
{i,1,19}, {j,i+1,20}
];
es

MakeImage["DodecahedralSkeleton", Graphics3D[{
Table[Text[i, vs[[i]]], {i,20}],
es /. Edge[i_, j_] :> Tube[{vs[[i]], vs[[j]]}, 0.1],
}, Boxed -> False, ViewPoint -> {-30,-6,-7}
]]

Wiggle[nvs_, rvs_] := Module[{n,r,b},
n=Total[vs[[nvs]]]/Length[nvs];
r=Total[vs[[rvs]]]/Length[rvs];
b = Cross[n,r]; b=Sqrt[r.r]*b/Sqrt[b.b];
Tube[
Line[Table[
(1+0.1Cos[5t])(Cos[t]r+Sin[t]b),
{t, 0, 2Pi+10^-6, 2Pi/720}
]],0.15
]
];
MakeImage["DodecahedralLink-1", Graphics3D[{
JoinForm["Round"],
Hue[0/6], Wiggle[{1,2,6,8,4}, {3,7}],
Hue[1/6], Wiggle[{1,3,9,10,4}, {5,7}],
Hue[2/6], Wiggle[{1,2,5,7,3}, {4,10}],
Hue[3/6], Wiggle[{2,6,12,11,5}, {7,13}],
Hue[4/6], Wiggle[{6,12,18,14,8}, {2,5}],
Hue[5/6], Wiggle[{4,8,14,16,10}, {1,2}]
}, Boxed -> False, ViewPoint -> -{30,6,7}, Background -> Black
]]

$Image["DodecahedralLink-1"];

Wiggle[nvs_, rvs_] := Module[{n,r,b},
n=Total[vs[[nvs]]]/Length[nvs];
r=Total[vs[[rvs]]]/Length[rvs];
b = Cross[n,r]; b=Sqrt[r.r]*b/Sqrt[b.b];
Tube[
Line[Table[
(1+0.1Cos[5t])(Cos[t]r+Sin[t]b),
{t, 0, 2Pi+Pi/120, 2Pi/720}
]],0.08
]
];
MakeImage["DodecahedralLink-2", Graphics3D[{
JoinForm["Round"], CapForm[None], Opacity[0.6],
Hue[0/6], Wiggle[{1,2,6,8,4}, {3,7}],
Hue[1/6], Wiggle[{1,3,9,10,4}, {5,7}],
Hue[2/6], Wiggle[{1,2,5,7,3}, {4,10}],
Hue[3/6], Wiggle[{2,6,12,11,5}, {7,13}],
Hue[4/6], Wiggle[{6,12,18,14,8}, {2,5}],
Hue[5/6], Wiggle[{4,8,14,16,10}, {1,2}],
Opacity[1], White, CapForm["Round"],
es /. Edge[i_, j_] :> Tube[{vs[[i]], vs[[j]]}, 0.05]
}, Boxed -> False, ViewPoint -> -{30,6,7}, Background -> Black
]]

$Image["DodecahedralLink-2"];

Wiggle[nvs_, rvs_] := Module[{n,r,b},
n=Total[vs[[nvs]]]/Length[nvs];
r=Total[vs[[rvs]]]/Length[rvs];
b = Cross[n,r]; b=Sqrt[r.r]*b/Sqrt[b.b];
Tube[
Line[Table[
(1+0.1Cos[5t])(Cos[t]r+Sin[t]b),
{t, 0, 2Pi+Pi/120, 2Pi/720}
]],0.1
]
];
MakeImage["DodecahedralLink-3", Graphics3D[{
JoinForm["Round"], CapForm[None], Opacity[1],
Hue[0/6], Wiggle[{1,2,6,8,4}, {3,7}],
Hue[1/6], Wiggle[{1,3,9,10,4}, {5,7}],
Hue[2/6], Wiggle[{1,2,5,7,3}, {4,10}],
Hue[3/6], Wiggle[{2,6,12,11,5}, {7,13}],
Hue[4/6], Wiggle[{6,12,18,14,8}, {2,5}],
Hue[5/6], Wiggle[{4,8,14,16,10}, {1,2}],
Opacity[1], Gray, CapForm["Round"],
es /. Edge[i_, j_] :> Tube[{vs[[i]], vs[[j]]}, 0.03]
}, Boxed -> False, ViewPoint -> -{30,6,7}, Background -> White
]]

Wiggle[nvs_, rvs_] := Module[{n,r,b},
n=Total[vs[[nvs]]]/Length[nvs];
r=Total[vs[[rvs]]]/Length[rvs];
b = Cross[n,r]; b=Sqrt[r.r]*b/Sqrt[b.b];
Tube[
Line[Table[
(1+0.1Cos[5t])(Cos[t]r+Sin[t]b),
{t, 0, 2Pi+Pi/240, 2Pi/720}
]],0.1
]
];
MakeImage["DodecahedralLink-4", Graphics3D[{
JoinForm["Round"], CapForm[None], Opacity[0.6],
Hue[0/6], Wiggle[{1,2,6,8,4}, {3,7}],
Hue[1/6], Wiggle[{1,3,9,10,4}, {5,7}],
Hue[2/6], Wiggle[{1,2,5,7,3}, {4,10}],
Hue[3/6], Wiggle[{2,6,12,11,5}, {7,13}],
Hue[4/6], Wiggle[{6,12,18,14,8}, {2,5}],
Hue[5/6], Wiggle[{4,8,14,16,10}, {1,2}]
}, Boxed -> False, ViewPoint -> -{30,6,7}, Background -> White
]]

Tetrahedron[i_,j_,k_,l_] := {
Tube[vs[[{i,j}]], w], Tube[vs[[{i,k}]], w], Tube[vs[[{i,l}]], w],
Tube[vs[[{j,k}]], w], Tube[vs[[{j,l}]], w], Tube[vs[[{k,l}]], w]
};
MakeImage["FiveTetrahedra-1", Graphics3D[{
w=0.1;
Hue[0/5], Tetrahedron[1,11,14,15],
Hue[1/5], Tetrahedron[2,18,10,13],
Hue[2/5], Tetrahedron[6,17,16,3],
Hue[3/5], Tetrahedron[8,5,20,9],
Hue[4/5], Tetrahedron[4,12,7,19],
White, es /. Edge[i_, j_] :> Tube[{vs[[i]], vs[[j]]}, 0.025]
}, Boxed -> False, ViewPoint -> -{30,6,7}, Background -> Black
]]

$Image["FiveTetrahedra-1"];

rectangle[i_,j_,k_,l_] := {
Tube[vs[[{i,j}]], w], Tube[vs[[{j,k}]], w], Tube[vs[[{k,l}]], w], Tube[vs[[{l,i}]], w],
Opacity[0.5],
Polygon[vs[[{i,j,k,l}]]],
Opacity[1]
};
MakeImage["EmbeddedBorromean", Graphics3D[{
w=0.1;
Hue[0/3], rectangle[4,8,17,13],
Hue[1/3], rectangle[2,5,19,16],
Hue[2/3], rectangle[3,9,18,12],
White, es /. Edge[i_, j_] :> Tube[{vs[[i]], vs[[j]]}, 0.025]
}, Boxed -> False, ViewPoint -> -{30,6,7}, Background ->White
]]

Tetra[i_,j_,k_,l_] := {
Tube[vs[[{i,j}]], w], Tube[vs[[{i,k}]], w], Tube[vs[[{i,l}]], w],
Tube[vs[[{j,k}]], w], Tube[vs[[{j,l}]], w], Tube[vs[[{k,l}]], w],
Opacity[0.75], EdgeForm[],
Polygon[vs[[{j,k,l}]]], Polygon[vs[[{i,k,l}]]],
Polygon[vs[[{i,j,l}]]], Polygon[vs[[{i,j,k}]]], 
Opacity[1]
};
MakeImage["FiveTetrahedra-2", Graphics3D[{
w=0.05;
Hue[0/5], Tetra[1,11,14,15],
Hue[1/5], Tetra[2,18,10,13],
Hue[2/5], Tetra[6,17,16,3],
Hue[3/5], Tetra[8,5,20,9],
Hue[4/5], Tetra[4,12,7,19],
(* White, es /. Edge[i_, j_] :> Tube[{vs[[i]], vs[[j]]}, 0.0125] *)
}, Boxed -> False, ViewPoint -> -{30,6,7}, Background -> Black
]]

Tetra[i_,j_,k_,l_] := {
Tube[vs[[{i,j}]], w], Tube[vs[[{i,k}]], w], Tube[vs[[{i,l}]], w],
Tube[vs[[{j,k}]], w], Tube[vs[[{j,l}]], w], Tube[vs[[{k,l}]], w],
Opacity[0.75], EdgeForm[],
Polygon[vs[[{j,k,l}]]], Polygon[vs[[{i,k,l}]]],
Polygon[vs[[{i,j,l}]]], Polygon[vs[[{i,j,k}]]], 
Opacity[1]
};
MakeImage["FiveTetrahedra-3", Graphics3D[{
w=0.05;
Hue[0/5], Tetra[1,11,14,15],
Hue[1/5], Tetra[2,18,10,13],
Hue[2/5], Tetra[6,17,16,3],
Hue[3/5], Tetra[8,5,20,9],
Hue[4/5], Tetra[4,12,7,19],
White, es /. Edge[i_, j_] :> Tube[{vs[[i]], vs[[j]]}, 0.0125]
}, Boxed -> False, ViewPoint -> -{30,6,7}, Background -> White
]]

The Cosmogram

From Conway’s Feb 24, 2016 lecture:



Also search “zometool kepler’s obsession”.

ws={Edge[2,10],Edge[2,13],Edge[10,13],Edge[2,18], Edge[10,18], Edge[13,18]} /. Edge[i_,j_] :> (vs[[i]]+vs[[j]])/2;
Graphics3D[{
Red,es /. Edge[i_, j_] :> Tube[{vs[[i]], vs[[j]]}, 0.05],
Yellow, {
Edge[2,3],Edge[3,10],Edge[10,8],Edge[8,2],Edge[2,11], Edge[11,13],Edge[13,3], Edge[13,19],Edge[19,10],Edge[19,18], Edge[18,8],Edge[18,11]
} /. Edge[i_, j_] :> Tube[{vs[[i]], vs[[j]]}, 0.05],
Green, {
Edge[2,10],Edge[2,13],Edge[10,13],Edge[2,18], Edge[10,18], Edge[13,18]
} /. Edge[i_, j_] :> Tube[{vs[[i]], vs[[j]]}, 0.05],
RGBColor[64,224,208], {
Edge[1,2],Edge[1,3],Edge[1,4],Edge[1,5],Edge[6,2],Edge[6,3],Edge[6,4],Edge[6,5],Edge[2,3], Edge[3,5],Edge[5,4],Edge[4,2]
} /. Edge[i_, j_] :> Tube[{ws[[i]], ws[[j]]}, 0.04],
}, Boxed -> False, ViewPoint -> {-30,-6,-7}
]

ws={Edge[2,10],Edge[2,13],Edge[10,13],Edge[2,18], Edge[10,18], Edge[13,18]} /. Edge[i_,j_] :> (vs[[i]]+vs[[j]])/2;
Graphics3D[{
RGBColor[64,224,208], {
Edge[1,2],Edge[1,3],Edge[1,4],Edge[1,5],Edge[6,2],Edge[6,3],Edge[6,4],Edge[6,5],Edge[2,3], Edge[3,5],Edge[5,4],Edge[4,2]
} /. Edge[i_, j_] :> Tube[{ws[[i]], ws[[j]]}, 0.04],
}, Boxed -> False, ViewPoint -> {-30,-6,-7}
]