Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Mathematica code for this animation of transitions in hydrogen wavefunctions: https://twitter.com/bencbartlett/status/1287802625602117632
<< MaTeX`
SetOptions[MaTeX, "Preamble" -> {"\\usepackage{color,txfonts}"}];
SetDirectory[NotebookDirectory[]];
Clear[drawLadder];
drawLadder[n_, l_, m_, imsize_: 500] := Module[{maxrungs = 5, mag = 4},
Graphics[{
White, Opacity[1], Thickness[.02], Dashing[None],
Table[Line[{{0, k}, {1, k}}], {k, maxrungs}], (*draw n lines*)
Gray, Dashed, Thickness[.005], Line[{{0, 0}, {1, 0}}],
Red, Opacity[.75],
Disk[{0.5, n}, .3],
White, Opacity[1], Thickness[.02], Dashing[None],
Table[
Line[{{2, k}, {3, k}}], {k, 0,
Floor[n + 0.01] - 1}], (*draw l lines*)
Gray, Dashed,
Thickness[.005],
Table[Line[{{2, k}, {3, k}}], {k, Floor[n + 0.01], maxrungs}],
Blue, Opacity[.75],
Disk[{2.5, l}, .3],
White, Opacity[1], Thickness[.02], Dashing[None],
Table[
Line[{{4, k}, {5, k}}], {k, 0,
Ceiling[l - 0.01]}], (*draw m lines*)
Gray, Dashed,
Thickness[.005],
Table[
Line[{{4, k}, {5, k}}], {k, Ceiling[l - 0.01] + 1, maxrungs}],
Green, Opacity[.75],
Disk[{4.5, m}, .3],
White, Opacity[1], Thick, Dashing[None],
Text[
MaTeX["\\color{white} n", Magnification -> mag], {.5,
maxrungs + 1}],
Text[
MaTeX["\\color{white} l", Magnification -> mag], {2.5,
maxrungs + 1}],
Text[
MaTeX["\\color{white} m", Magnification -> mag], {4.5,
maxrungs + 1}],
Table[
Text[MaTeX["\\color{white} " <> ToString[k],
Magnification -> .5*mag], {5.8, k}], {k, 0, maxrungs}]
},
(*Background\[Rule]Black,*)
Background -> Transparent,
ImageSize -> imsize
]
];
(*drawLadder[3,2,0]*)
Clear[drawFrame];
drawFrame[{n1_, l1_, m1_}, {n2_, l2_, m2_}, c1_, c2_] :=
Module[{c1norm, c2norm},
c1norm = c1/Sqrt[Abs[c1]^2 + Abs[c2]^2];
c2norm = c2/Sqrt[Abs[c1]^2 + Abs[c2]^2];
ListDensityPlot[
Table[
Module[{r = Norm[{x, 0, z}], eq1, eq2},
eq1 =
Sqrt[4 \[Pi]]
r (Exp[-(r/n1)] r^
l1 LaguerreL[n1 - 1 - l1, 2 l1 + 1, (2 r)/
n1]) SphericalHarmonicY[l1, m1, ArcCos[z/r], ArcTan[x, 0]];
eq2 =
Sqrt[4 \[Pi]]
r (Exp[-(r/n2)] r^
l2 LaguerreL[n2 - 1 - l2, 2 l2 + 1, (2 r)/
n2]) SphericalHarmonicY[l2, m2, ArcCos[z/r], ArcTan[x, 0]];
Abs[c1norm*eq1 + c2norm*eq2]^2
], {z, -40.1, 40, .5}, {x, -40.1, 80, .5}],
DataRange -> {{-40, 40}, {-40, 80}},
AspectRatio -> .8/1.2, ImageSize -> 1000*{1.2, .8},
Mesh -> False, Frame -> False,
(*InterpolationOrder\[Rule]1,
THIS CAUSES CRASHES*)
(*PlotPoints\[Rule]100,
MaxRecursion\[Rule]6,*)
ColorFunctionScaling -> True,
ColorFunction -> "SunsetColors",
Epilog -> Inset[
drawLadder[
(*n1*c1norm+n2*c2norm,m1*c1norm+m2*c2norm,l1*c1norm+l2*c2norm*)
n1*c1norm^2 + n2*c2norm^2, l1*c1norm^2 + l2*c2norm^2,
m1*c1norm^2 + m2*c2norm^2, 250],
(*{60,0},*)
{29, 20}
]
]
]
drawFrame[{4, 3, 3}, {5, 3, 3}, .5, .5]
(*drawFrame[{2,0,0},{2,1,0},1,.8]*)
Clear[renderFrame];
renderFrame[t_] := Module[{tt = t - Floor[t], c1, c2, ttt},
ttt = Piecewise[{{0,
tt < .1}, {(tt - .1)/(1 - .1 - .1), .1 <= tt < .9}, {1,
tt >= .9}}];
c1 = Cos[\[Pi]/2 * ttt];
c2 = Sin[\[Pi]/2 * ttt];
Switch[Floor[t],
0, drawFrame[{5, 0, 0}, {4, 0, 0}, c1, c2],
1, drawFrame[{4, 0, 0}, {3, 0, 0}, c1, c2],
2, drawFrame[{3, 0, 0}, {3, 1, 0}, c1, c2],
3, drawFrame[{3, 1, 0}, {3, 1, 1}, c1, c2],
4, drawFrame[{3, 1, 1}, {4, 0, 0}, c1, c2],
5, drawFrame[{4, 0, 0}, {4, 1, 1}, c1, c2],
6, drawFrame[{4, 1, 1}, {4, 2, 1}, c1, c2],
7, drawFrame[{4, 2, 1}, {4, 3, 1}, c1, c2],
8, drawFrame[{4, 3, 1}, {5, 0, 0}, c1, c2],
9, drawFrame[{5, 0, 0}, {5, 1, 1}, c1, c2],
10, drawFrame[{5, 1, 1}, {5, 2, 1}, c1, c2],
11, drawFrame[{5, 2, 1}, {5, 3, 1}, c1, c2],
12, drawFrame[{5, 3, 1}, {5, 4, 1}, c1, c2],
13, drawFrame[{5, 4, 1}, {5, 3, 1}, c1, c2],
14, drawFrame[{5, 3, 1}, {5, 2, 1}, c1, c2],
15, drawFrame[{5, 2, 1}, {5, 1, 1}, c1, c2],
16, drawFrame[{5, 1, 1}, {4, 1, 1}, c1, c2],
17, drawFrame[{4, 1, 1}, {3, 1, 1}, c1, c2],
18, drawFrame[{3, 1, 1}, {2, 1, 1}, c1, c2],
19, drawFrame[{2, 1, 1}, {1, 0, 0}, c1, c2],
_, drawFrame[{2, 1, 0}, {1, 0, 0}, 0, 1]
]
];
renderFrame[0.9]
Plot[
Module[{},
ttt = Piecewise[{{0,
x < .1}, {(x - .1)/(1 - .1 - .1), .1 <= x < .9}, {1, x > .9}}];
c1 = Cos[\[Pi]/2 * ttt];
c2 = Sin[\[Pi]/2 * ttt];
2*c1^2 + 3*c2^2
], {x, -1, 2}]
saveframe[tt_] := Module[{frame, title},
frame = renderFrame[tt];
title = IntegerString[Floor[tt*1000], 10, 8] <> ".png";
Export["frames/" <> title, frame];
];
Monitor[Table[saveframe[t], {t, 0, 20, 1/120}],
ProgressIndicator[t, {0, 20}]];
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment