z = a + bi, w = c + di に対して |z|^2 - |w|^2 , 2 Re(z(OverBar[w])),2 Im(z(OverBar[w])) を考える。

hopf[{a_,b_,c_,d_}]:={(a^2)+(b^2)-(c^2)-(d^2),2(a c + b d),2 (-a d+b c)}

単位球面にのっていることを確認しよう :

((a^2)+(b^2)-(c^2)-(d^2))^2+(2(a c +b d))^2+(2 (-a d+b c))^2//FullSimplify

一方で (z,w) に対して  (e^it)(z,w) は次のベクトルに対応する:

orbit[{a_,b_,c_,d_},t_]:={a Cos[t]-b Sin[t],b Cos[t]+a Sin[t],c Cos[t]-d Sin[t],d Cos[t]+c Sin[t]}

単位球面 (S^3)上の点 q は適当に z を選ぶと次の点にもっていける (0≤s≤π/2 , 0≤r≤2π):

q[s_,r_]:={Cos[s],0,Sin[s]Cos[r],Sin[s]Sin[r]}

これを z で回すと

orbit[q[s,r],t]//FullSimplify

orb[s_,r_,t_]:={Cos[s] Cos[t],Cos[s] Sin[t],Cos[r+t] Sin[s],Sin[s] Sin[r+t]}

この点の Hopf ファイブレーションでの行き先は確かに t によらない

hopf[orb[s,r,t]]//Simplify

あとで使うので名前を付けておこう:

proj[s_,r_]:={Cos[2 s],Cos[r] Sin[2 s],-Sin[r] Sin[2 s]}

{1,0,0,0} から投影すると次の点にゆく:

proj[{a_,b_,c_,d_}]:={b,c,d}/(1-a)

これらを図示しよう。ちょっと準備が必要である :

S3range={{-2.5,2.5},{-2.5,2.5},{-2.5,2.5}};

S2range={{-1.2,1.2},{-1.2,1.2},{-1.2,1.2}};

unitS2insert=Graphics3D[{Opacity[.2],Sphere[{0,0,0}]}];

diskinsert=ParametricPlot3D[{0,r Sin[t],r Cos[t]},{r,0,1},{t,0,2Pi},PlotRange-> S3range,
ImageSize-> Medium,PlotStyle->{Opacity[.1],Blue},Mesh->None];

CF[x_]:=Hue[x,.8,.8]

donut[s_,op_,pro_]:=Table[
ParametricPlot3D[
pro[orb[s,r,t]],{t,0,2Pi},
PlotStyle-> {CF[r/(2Pi)],Opacity[op]},
PlotRange-> S3range,
ImageSize-> Medium],
{r,0,2Pi,2Pi/20}]~Join~{ParametricPlot3D[
pro[orb[s,r,Pi]],{r,0,2Pi},
ColorFunction->( CF[#4/(2Pi)]&),ColorFunctionScaling->False,
PlotRange-> S3range,
ImageSize-> Medium]}

base[s_]:=ParametricPlot3D[
proj[s,r],{r,0,2Pi},
ColorFunctionScaling-> False,ColorFunction->( CF[#4/(2Pi)]&),
PlotRange->S2range,
ImageSize-> Small]

varyS[s_,op_]:={Show[donut[s,op,proj],diskinsert],
Show[base[s],
unitS2insert]}

すると以下のようになる: 右端の絵は与えられた s に対して r を 0 から 2π まで振ったときの (S^2) 上の軌跡で、左端の絵の各線は右の図の色の対応する点にうつる (S^3)上の点を (1,0,0,0) からの立体投影であらわしたもの。薄青色の面は (負,0,c,d) という半空間の立体投影。

Manipulate[varyS[s,If[op,.1,1]],{{s,.5},0.01,Pi/2},{{op,False,"切断を強調"},{True,False}},SaveDefinitions->True]