25
$\begingroup$

A 3D Bloch (Poincaré) sphere is nicely shown in this wolfram demonstration. However, in that example, it is not possible to mouse select a point on the sphere and directly get the corresponding qubit representation.

How can we do something like this with Mathematica?

Improve this question
$\endgroup$

1 Answer 1

Reset to default
38
$\begingroup$

Here is an attempt to draw a 3D Bloch sphere, on which we can select a point simply clicking on it with the mouse and obtain the corresponding qubit representation. In the code I made use of Szabolcs' MaTeX package to draw the labels in LaTeX (not necessary, but better looking) and Sjoerd C. de Vries' splineCircle to draw the 3D arcs (the above functions are therefore necessary to run the following code).

Result

enter image description here

Code sections

Pretty printing qubit states:

We start by defining a function that takes as input the amplitudes of the state, and prints in output the state in a nice-looking form:

ClearAll@qubitPrettyPrint;
Options[qubitPrettyPrint] = {normalized -> False, magnification -> 2, 
   prefix -> ""};
qubitPrettyPrint[c1_, c2_, OptionsPattern[]] := 
 If[! TrueQ@OptionValue@normalized,
  MaTeX[
   StringTemplate[
     "`3`\\left(`1`\\right)\\left|0\\right\\rangle + \
\\left(`2`\\right)\\left|1\\right\\rangle"][
    ToString@TeXForm[c1], ToString@TeXForm[c2], 
    ToString@OptionValue@prefix
    ],
   Magnification -> OptionValue@magnification
   ],
  With[{nCoefficients = Normalize[{c1, c2}]},
   MaTeX[
    StringTemplate[
      "`3`\\left(`1`\\right)\\left|0\\right\\rangle + \
\\left(`2`\\right)\\left|1\\right\\rangle"][
     Sequence @@ (ToString@*TeXForm /@ nCoefficients), 
     ToString@OptionValue@prefix
     ],
    Magnification -> OptionValue@magnification
    ]
   ]
  ]

printStateFromPoint[pt_, useMatex_: True] := If[TrueQ@useMatex,
  Panel@qubitPrettyPrint[
    With[{θ = ArcCos[pt[[3]]], ϕ = 
       ArcTan[If[pt[[1]] == 0, 0, pt[[2]]/pt[[1]]]]},
     Sequence @@ {Cos[θ/2], Exp[I ϕ] Sin[θ/2]}
     ],
    prefix -> "\\left| \\psi \\right\\rangle = ",
    magnification -> 1.6
    ],
  Panel@With[
    {θ = ArcCos[pt[[3]]], ϕ = 
      ArcTan[If[pt[[1]] == 0, 0, pt[[2]]/pt[[1]]]]},
    Style[
     "\!\(\*TemplateBox[{\"ψ\"},\n\"Ket\"]\) = " ~~ 
      ToString@Cos[θ/2] ~~ 
      "\!\(\*TemplateBox[{\"0\"},\n\"Ket\"]\) + (" ~~ 
      ToString[Exp[I ϕ] Sin[θ/2]] ~~ 
      ") \!\(\*TemplateBox[{\"1\"},\n\"Ket\"]\)",
     texStyle
     ]
    ]
  ]

giving for example

enter image description here

Print static Bloch sphere

The following prints the 3D Bloch sphere, with parallel and meridian lines, drawn with surroundingCircles, which makes use of splineCircle, and the labels, which are printed in LaTeX through MaTeX.

pointsAndConnection[points_] := 
 Sequence @@ {Sequence @@ Point /@ #, Line@#} &@points
surroundingCircles = GeometricTransformation[
   splineCircle[{0, 0, 0}, 1],
   {
    {RotationMatrix[0, {1, 0, 0}], {0, 0, 0}},
    {RotationMatrix[Pi/2, {1, 0, 0}], {0, 0, 0}},
    {RotationMatrix[Pi/2, {0, 1, 0}], {0, 0, 0}}
    }
   ];

ClearAll@texKet;
texKet[n_, magnification_: 2, useMatex_: True] := If[TrueQ@useMatex,
  MaTeX["\\left|" ~~ ToString@n ~~ "\\right\\rangle", 
   Magnification -> magnification],
  Text@Style[
    StringTemplate["\!\(\*TemplateBox[{\"`1`\"},\n\"Ket\"]\)"][
     ToString@n],
    texStyle
    ]
  ]

blochSphere = Graphics3D[
   {
    White, [email protected], Sphere[{0, 0, 0}, 1],
    Opacity@1, [email protected], [email protected],
    Red, pointsAndConnection@{{0, 0, 1}, {0, 0, -1}},
    Blue, pointsAndConnection@{{1, 0, 0}, {-1, 0, 0}},
    Darker@Green, pointsAndConnection@{{0, 1, 0}, {0, -1, 0}},
    Black, Point[{0, 0, 0}],
    Text[texKet[0], {0, 0, 1.2}],
    Text[texKet[1], {0, 0, -1.2}],
    Text[texKet["+"], {1.2, 0, 0}],
    Text[texKet["-"], {-1.2, 0, 0}],
    Text[texKet["L"], {0, 1.2, 0}],
    Text[texKet["R"], {0, -1.2, 0}],
    Gray, Thin, surroundingCircles
    },
   Boxed -> False,
   PlotRange -> ConstantArray[{-1, 1}, 3],
   ImageSize -> 500,
   RotationAction -> "Clip"
   ];

This produces the main output graphics, upon which we will build the dynamic part later:

enter image description here

Find intersections with the sphere from mouse clicks

When clicking on the Graphics3D with the mouse we get the information on the clicked position through MousePosition["Graphics3DBoxIntercepts"], which we need to process to derive the corresponding point on the sphere.

To do this, we notice that, denoting with $p_1$ and $p_2$ the points on the boundary box (given by MousePosition), the points between them are given by $p(\lambda) = (1-\lambda) p_1 + \lambda p_2$ for $0 \le \lambda \le 1$. The points on the sphere will therefore be given by $p(\lambda)$ for $\lambda$ such that $\| p(\lambda) \|^2 = 1$. This is easily made into the equation: $$ (p^2 + q^2 -2 p q c) \lambda^2 + 2 \lambda (p q c - p^2) + (p^2 -1) =0, $$ where $p \equiv \|p_1\|$, $q \equiv \|p_2 \|$, and $c \equiv \frac{p_1 \cdot p_2}{\|p_1 \cdot p_2 \|}$. We solve this with Mathematica obtaining:

In[37]:= Solve[
 (p^2 + q^2 - 2 p q c) λ^2 + 
   2 λ (p q c - p^2) + (p^2 - 1) == 0,
 λ
 ]

Out[37]= {{λ -> (-p^2 + c p q - Sqrt[
    p^2 - 2 c p q + q^2 - p^2 q^2 + c^2 p^2 q^2])/(-p^2 + 2 c p q - 
    q^2)}, {λ -> (-p^2 + c p q + Sqrt[
    p^2 - 2 c p q + q^2 - p^2 q^2 + c^2 p^2 q^2])/(-p^2 + 2 c p q - 
    q^2)}}

and we can now take this solution and plug it in our function to get the intersections with the sphere given the intercept points with the box:

ClearAll@intersectionsWithSphere
intersectionsWithSphere[pt1_, pt2_] := With[{
   p = Norm[pt1], q = Norm[pt2], c = Cos@VectorAngle[pt1, pt2]
   },
  {(-p^2 + c p q - Sqrt[
    p^2 - 2 c p q + q^2 - p^2 q^2 + c^2 p^2 q^2])/(-p^2 + 2 c p q - 
    q^2), (-p^2 + c p q + Sqrt[
    p^2 - 2 c p q + q^2 - p^2 q^2 + c^2 p^2 q^2])/(-p^2 + 2 c p q - 
    q^2)}
  ]
intersectionsWithSphere[{pt1_, pt2_}] := 
 intersectionsWithSphere[pt1, pt2]

Draw angles

As a nice additional touch, we also want to draw the circular arcs representing the angles $\theta$ and $\phi$ of the currently selected point on the sphere. We do this using the functions drawThetaAngle and drawPhiAngle:

drawThetaAngle[pt_] := With[{
   θ = VectorAngle[{0, 0, 1}, pt],
   θ2 = VectorAngle[{pt[[1]], pt[[2]], 0}, pt],
   ϕ = VectorAngle[{1, 0, 0}, {pt[[1]], pt[[2]], 0}]
   },
  Function[plot,
    GeometricTransformation[
     plot,
     RotationMatrix[#, {0, 0, 1}] &@If[pt[[2]] > 0, ϕ, -ϕ].
        RotationMatrix[Pi/2, {1, 0, 0}].
        RotationMatrix[#, {0, 0, 1}] &@
      If[pt[[3]] < 0, -θ2, θ2, 0]
     ]
    ] /@ {
    splineCircle[{0, 0, 0}, .2, {0, θ}],
    RevolutionPlot3D[0, {t, 0, .2}, {theta, 0, θ}, 
      Mesh -> None, PlotStyle -> Directive[Yellow]][[1]]
    }
  ]
drawPhiAngle[pt_] := With[{
   ϕ = VectorAngle[{1, 0, 0}, {pt[[1]], pt[[2]], 0}]
   },
  {
     splineCircle[{0, 0, 0}, .2, {0, #}],
     RevolutionPlot3D[0, {t, 0, .2}, {θ, 0, #}, Mesh -> None, 
       PlotStyle -> Directive[Cyan]][[1]]
     } &@If[pt[[2]] > 0, ϕ, 2 Pi - ϕ]
  ]

Finally, put everything together:

All that is left is to put the above pieces together, and add the Point representing where the used has clicked. To handle the case where we click outside the sphere we put a single conditional, which verifies the the derived point on the sphere has unit norm (and thus is really on the sphere).

DynamicModule[{pt = {0, 1/Sqrt[2] // N, 1/Sqrt[2] // N}},
 Row[{
   EventHandler[
    Show[
     blochSphere,
     Graphics3D[Dynamic@{
        Opacity@1, [email protected], Point@pt,
        Dashed, Thin, Purple, 
        Line@{{0, 0, 0}, pt, {pt[[1]], pt[[2]], 0}, {0, 0, 0}},
        Dashing[{}], [email protected], Red, drawThetaAngle[pt],
        Dashing[{}], [email protected], Blue, 
        Sequence @@ drawPhiAngle[pt]
        }](*,
     RotationAction\[Rule]"Clip"*)
     ],
    {
     "MouseClicked" :> (
       Module[{p1, p2},
        {p1, p2} = MousePosition["Graphics3DBoxIntercepts"];
        With[{newPt = (1 - λ) p1 + λ p2 /. λ \
-> intersectionsWithSphere[p1, p2][[2]]},
         If[Norm[newPt] == 1, pt = newPt]
         ]
        ]
       )
     },
    PassEventsDown -> True
    ],
   Dynamic@printStateFromPoint[pt]
   }]
 ]

This finally produces the dynamic plot showed at the beginning of the plot.

Full code (except for splineCircle and MaTeX):

ClearAll@qubitPrettyPrint;
Options[qubitPrettyPrint] = {normalized -> False, magnification -> 2, 
   prefix -> ""};
qubitPrettyPrint[c1_, c2_, OptionsPattern[]] := 
 If[! TrueQ@OptionValue@normalized,
  MaTeX[
   StringTemplate[
     "`3`\\left(`1`\\right)\\left|0\\right\\rangle + \
\\left(`2`\\right)\\left|1\\right\\rangle"][
    ToString@TeXForm[c1], ToString@TeXForm[c2], 
    ToString@OptionValue@prefix
    ],
   Magnification -> OptionValue@magnification
   ],
  With[{nCoefficients = Normalize[{c1, c2}]},
   MaTeX[
    StringTemplate[
      "`3`\\left(`1`\\right)\\left|0\\right\\rangle + \
\\left(`2`\\right)\\left|1\\right\\rangle"][
     Sequence @@ (ToString@*TeXForm /@ nCoefficients), 
     ToString@OptionValue@prefix
     ],
    Magnification -> OptionValue@magnification
    ]
   ]
  ]
printStateFromPoint[pt_, useMatex_: True] := If[TrueQ@useMatex,
  Panel@qubitPrettyPrint[
    With[{θ = ArcCos[pt[[3]]], ϕ = 
       ArcTan[If[pt[[1]] == 0, 0, pt[[2]]/pt[[1]]]]},
     Sequence @@ {Cos[θ/2], Exp[I ϕ] Sin[θ/2]}
     ],
    prefix -> "\\left| \\psi \\right\\rangle = ",
    magnification -> 1.6
    ],
  Panel@With[
    {θ = ArcCos[pt[[3]]], ϕ = 
      ArcTan[If[pt[[1]] == 0, 0, pt[[2]]/pt[[1]]]]},
    Style[
     "\!\(\*TemplateBox[{\"ψ\"},\n\"Ket\"]\) = " ~~ 
      ToString@Cos[θ/2] ~~ 
      "\!\(\*TemplateBox[{\"0\"},\n\"Ket\"]\) + (" ~~ 
      ToString[Exp[I ϕ] Sin[θ/2]] ~~ 
      ") \!\(\*TemplateBox[{\"1\"},\n\"Ket\"]\)",
     texStyle
     ]
    ]
  ]
pointsAndConnection[points_] := 
 Sequence @@ {Sequence @@ Point /@ #, Line@#} &@points
surroundingCircles = GeometricTransformation[
   splineCircle[{0, 0, 0}, 1],
   {
    {RotationMatrix[0, {1, 0, 0}], {0, 0, 0}},
    {RotationMatrix[Pi/2, {1, 0, 0}], {0, 0, 0}},
    {RotationMatrix[Pi/2, {0, 1, 0}], {0, 0, 0}}
    }
   ];

ClearAll@texKet;
texKet[n_, magnification_: 2, useMatex_: True] := If[TrueQ@useMatex,
  MaTeX["\\left|" ~~ ToString@n ~~ "\\right\\rangle", 
   Magnification -> magnification],
  Text@Style[
    StringTemplate["\!\(\*TemplateBox[{\"`1`\"},\n\"Ket\"]\)"][
     ToString@n],
    texStyle
    ]
  ]

blochSphere = Graphics3D[
   {
    White, [email protected], Sphere[{0, 0, 0}, 1],
    Opacity@1, [email protected], [email protected],
    Red, pointsAndConnection@{{0, 0, 1}, {0, 0, -1}},
    Blue, pointsAndConnection@{{1, 0, 0}, {-1, 0, 0}},
    Darker@Green, pointsAndConnection@{{0, 1, 0}, {0, -1, 0}},
    Black, Point[{0, 0, 0}],
    Text[texKet[0], {0, 0, 1.2}],
    Text[texKet[1], {0, 0, -1.2}],
    Text[texKet["+"], {1.2, 0, 0}],
    Text[texKet["-"], {-1.2, 0, 0}],
    Text[texKet["L"], {0, 1.2, 0}],
    Text[texKet["R"], {0, -1.2, 0}],
    Gray, Thin, surroundingCircles
    },
   Boxed -> False,
   PlotRange -> ConstantArray[{-1, 1}, 3],
   ImageSize -> 500,
   RotationAction -> "Clip"
   ];

ClearAll@intersectionsWithSphere
intersectionsWithSphere[pt1_, pt2_] := With[{
   p = Norm[pt1], q = Norm[pt2], c = Cos@VectorAngle[pt1, pt2]
   },
  {(-p^2 + c p q - Sqrt[
    p^2 - 2 c p q + q^2 - p^2 q^2 + c^2 p^2 q^2])/(-p^2 + 2 c p q - 
    q^2), (-p^2 + c p q + Sqrt[
    p^2 - 2 c p q + q^2 - p^2 q^2 + c^2 p^2 q^2])/(-p^2 + 2 c p q - 
    q^2)}
  ]
intersectionsWithSphere[{pt1_, pt2_}] := 
 intersectionsWithSphere[pt1, pt2]

drawThetaAngle[pt_] := With[{
   θ = VectorAngle[{0, 0, 1}, pt],
   θ2 = VectorAngle[{pt[[1]], pt[[2]], 0}, pt],
   ϕ = VectorAngle[{1, 0, 0}, {pt[[1]], pt[[2]], 0}]
   },
  Function[plot,
    GeometricTransformation[
     plot,
     RotationMatrix[#, {0, 0, 1}] &@If[pt[[2]] > 0, ϕ, -ϕ].
        RotationMatrix[Pi/2, {1, 0, 0}].
        RotationMatrix[#, {0, 0, 1}] &@
      If[pt[[3]] < 0, -θ2, θ2, 0]
     ]
    ] /@ {
    splineCircle[{0, 0, 0}, .2, {0, θ}],
    RevolutionPlot3D[0, {t, 0, .2}, {theta, 0, θ}, 
      Mesh -> None, PlotStyle -> Directive[Yellow]][[1]]
    }
  ]
drawPhiAngle[pt_] := With[{
   ϕ = VectorAngle[{1, 0, 0}, {pt[[1]], pt[[2]], 0}]
   },
  {
     splineCircle[{0, 0, 0}, .2, {0, #}],
     RevolutionPlot3D[0, {t, 0, .2}, {θ, 0, #}, Mesh -> None, 
       PlotStyle -> Directive[Cyan]][[1]]
     } &@If[pt[[2]] > 0, ϕ, 2 Pi - ϕ]
  ]

DynamicModule[{pt = {0, 1/Sqrt[2] // N, 1/Sqrt[2] // N}},
 Row[{
   EventHandler[
    Show[
     blochSphere,
     Graphics3D[Dynamic@{
        Opacity@1, [email protected], Point@pt,
        Dashed, Thin, Purple, 
        Line@{{0, 0, 0}, pt, {pt[[1]], pt[[2]], 0}, {0, 0, 0}},
        Dashing[{}], [email protected], Red, drawThetaAngle[pt],
        Dashing[{}], [email protected], Blue, 
        Sequence @@ drawPhiAngle[pt]
        }](*,
     RotationAction\[Rule]"Clip"*)
     ],
    {
     "MouseClicked" :> (
       Module[{p1, p2},
        {p1, p2} = MousePosition["Graphics3DBoxIntercepts"];
        With[{newPt = (1 - λ) p1 + λ p2 /. λ \
-> intersectionsWithSphere[p1, p2][[2]]},
         If[Norm[newPt] == 1, pt = newPt]
         ]
        ]
       )
     },
    PassEventsDown -> True
    ],
   Dynamic@printStateFromPoint[pt]
   }]
 ]
Improve this answer
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

Not the answer you're looking for? Browse other questions tagged or ask your own question.