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

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

stproj[s_,r_,t_]:= {Cos[s] Sin[t],Cos[r+t] Sin[s],Sin[s] Sin[r+t]}/(1-Cos[s]Cos[t])

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

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

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

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

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

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}]}];

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

varyS[s_]:={Show[Table[
ParametricPlot3D[
stproj[s,r,t],{t,0,2Pi},
PlotStyle-> {CF[r/(2Pi)]},
PlotRange-> S3range,
ImageSize-> Medium],
{r,0,2Pi,2Pi/15}]],
Show[{ParametricPlot3D[
proj[s,r],{r,0,2Pi},
ColorFunctionScaling-> False,ColorFunction->( CF[#4/(2Pi)]&),
PlotRange->S2range,
ImageSize-> Small],
unitS2insert}]}

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

Manipulate[varyS[s],{{s,.5},0.01,Pi/2},SaveDefinitions->True]

varyR[r_]:={Show[Table[
ParametricPlot3D[
stproj[s,r,t],{t,0,2Pi},
PlotStyle-> {CF[s/(Pi)]},
PlotRange-> S3range,
ImageSize->Medium],
{s,Pi/40,Pi,Pi/15}]],
Show[{
ParametricPlot3D[
proj[s,r],{s,0,Pi},
ColorFunctionScaling-> False,ColorFunction->( CF[#4/(Pi)]&),
PlotRange->S2range,
ImageSize-> Small],
unitS2insert}]
}

同様にして与えられた r に対して s を 0 から π まで振ったときの (S^2) 上の軌跡を右に、その各点に Hopf fibration のもとでうつる (S^3)上の線を立体投影であらわすようにするとこうなる:

Manipulate[varyR[r],{{r,2.5},0,2Pi},SaveDefinitions->True]