The Torus Tunnel Bridge Challenge

Jesse Bettencourt

(*Parameterize the two circles which determine the torus*)
x[r_,θ_]:=r Cos[θ] ;
y[r_,θ_]:=r Sin[θ] ;
w[R_,ρ_]:=R Cos[ρ] ;
z[R_,ρ_]:=R Sin[ρ] ;

(*Parametrization of the torus in 4D*)Torus[r_,R_,θ_,ρ_]:={x[r,θ],y[r ,θ],w[R,ρ],z[R,ρ]}

(*Project this torus into 3D*)
StereographicProjection[{x_,y_,z_,w_}]:={x,y,z}/(1-w)

(*Useful clean plotting function*)
PlotTorus[torus_]:=ParametricPlot3D[torus,{θ,0,2π},{ρ,0,2π},Axes->False,Boxed->False, Mesh->None]

(*Play with the radii defining the torus*)
Manipulate[PlotTorus[StereographicProjection@Torus[r,R,θ,ρ]],{{r,1/Sqrt[2]},0.1,1},{{R,1/Sqrt[2]},0.1,1}]

(*Define the Clifford torus,
with symetric properties which will make later pictures clearer*)
CliffordTorus[θ_,ρ_]:=Torus[1/Sqrt[2],1/Sqrt[2],θ,ρ]
PlotTorus[StereographicProjection@CliffordTorus[θ,ρ]]

(* Define a few rotations in 4D space *)Rotxw[txw_]:=RotationTransform[txw,{{1,0,0,0},{0,0,1,0}}]
Rotwz[twz_]:=RotationTransform[twz,{{0,0,1,0},{0,0,0,1}}]
Rotxz[txz_]:=RotationTransform[txz,{{1,0,0,0},{0,0,0,1}}]

(*Play around with these rotations*)
Manipulate[PlotTorus[StereographicProjection[Rotxz[Txz]@Rotxw[Txw]@Rotwz[Twz]@CliffordTorus[θ,ρ]]],{Twz,0,2Pi},{Txw,0,2Pi},{Txz,0,2Pi}]

(*If you rotate about the xz-axis by (π/4) we get the desired tunnel bridge image*)
PlotTorus[StereographicProjection[Rotxz[Pi/4]@N@CliffordTorus[θ,ρ]]]

(*We can visualize this from above the tunel, from the point {1,0,0} *)
tunnel=StereographicProjection[Rotxz[Pi/4]@N@CliffordTorus[θ,ρ]];
ParametricPlot3D[tunnel,{θ,0,2π},{ρ,0,2π},Axes->False,Boxed->False, Mesh->None,ViewPoint->{1, 0, 0}]

(*Here are some prettier colourings of this*)
Table[ParametricPlot3D[tunnel,{θ,0,2π},{ρ,0,2π},Axes->False,Boxed->False, Mesh->None,ViewPoint->{1, 0, 0},ColorFunction->Function[{x,y,z,θ,ρ},i],ImageSize->Large],{i,{Hue[x],Hue[θ],Hue[ρ]}}]