Message Boards Message Boards

[GIF] Visualizing Interstellar's Wormhole: from article to programming

GROUPS:

Click on image to zoom. Press browser back button to return to the post.


enter image description here

Let me start off by saying that I know almost nothing about general relativity, but I thought it was really fun translating the equations presented in this paper by Oliver James, Eugenie von Tunzelmann, Paul Franklin, and Kip Thorne into notebook expressions.

Embedding Diagrams

The paper gives some really cool figures to show the curvature of 4-dimensional spacetime in the region around a wormhole. The physics of the wormhole is essentially described by three parameters:

  1. $\rho$ - the radius of the wormhole
  2. $a$ - the length of the wormhole
  3. $\mathcal{M}$ - a parameter describing the curvature, described in the paper as the "gentleness of the transition from the wormhole's cylindrical interior to its asymptotically flat exterior"

To look at the curvature for a given set of parameters, we only really care about the ratios $a/\rho$ and $\mathcal{M}/\rho$.

Taking equations (5) and (6) from the paper, we can plot the curvature for any pair of these parameters using cylindrical coordinates. Since the $z$ coordinate is described found via numerical integration, I chose to speed up the ParametricPlot3D by first forming an interpolating function.

embeddingDiagram[a_, M_, lmax_: 4] := Module[{ρ = 1, z, zz, x, r},
  x[l_] := (2 (Abs[l] - a))/(π*M);
  r[l_] := ρ + 
    UnitStep[
      Abs[l] - a] (M (x[l]*ArcTan[x[l]] - 1/2 Log[1 + (x[l])^2]));
  z[l_] := 
   NIntegrate[Sqrt[
    1 - (UnitStep[
        Abs[ll] - 
         a] (2 ArcTan[(2 (-a + Abs[ll]))/(M π)] Sign[
           l])/π)^2], {ll, 0, l}];
  zz = Interpolation@({#, z[#]} & /@ Subdivide[lmax, 20]);
  ParametricPlot3D[{{r[l] Cos[t], r[l] Sin[t], zz[l]}, {r[l] Cos[t], 
     r[l] Sin[t], -zz[l]}}, {l, 0, lmax}, {t, 0, 2 π},
   PlotStyle -> Directive[Orange, Specularity[White, 50]],
   Boxed -> False,
   Axes -> False,
   ImageSize -> 500,
   PlotPoints -> {40, 15}]
  ]

and here are three examples shown in the paper,

embeddingDiagram[0.005, 0.05/1.43]
embeddingDiagram[0.5, 0.014]
embeddingDiagram[0.5, 0.43, 10]

enter image description here

Tracing rays through the wormhole

The appendix to the paper describes a procedure for creating an image taken from a camera on one side of the wormhole. The procedure involves generating a map from one set of spherical polar coordinates (the "camera sky") to the "celestial spheres" describing the two ends of the wormhole.

First a location is chosen for the camera, then light rays are traced backwards in time from the camera to one of the two celestial spheres. This ray tracing involves solving 5 coupled differential equations back from $t=0$ to minus infinity (or a large negative time).

For this I use ParametricNDSolve. The functions being solved for are the spherical coordinates of the light rays and their momenta.

The parameters for ParametricNDSolve are the wormhole parameters listed above, the camera's position {lcamera, θcamera, ϕcamera} and the "camera sky" coordinates, used to build the map. Rather than walk through their derivation (again, not a cosmologist), I cite the paper for the equations given below:

rayTrace = Module[{
    (* auxilliary variables *)
    nl, nϕ, nθ, pϕ, 
    bsquared, M, x, r, rprime,
    (* parameters for ParametricNDSolve *)
    θcamsky, \
ϕcamsky, ρ, lcamera, θcamera, ϕcamera, W, a,
    (* time dependent parameters to be solved for *)

    l, θ, ϕ, pl, pθ,
    (* the time variable *)
    t
    },

   (* Eq. (7) *)
   M = W/1.42953;

   (*Eq. 5 *)
   x[l_] := (2 (Abs[l] - a))/(π*M);
   r[l_] := ρ + 
     UnitStep[
       Abs[l] - a] (M (x[l]*ArcTan[x[l]] - 1/2 Log[1 + (x[l])^2]));
   rprime[l_] := 
    UnitStep[
      Abs[l] - 
       a] (2 ArcTan[(2 (-a + Abs[l]))/(M π)] Sign[l])/π;

   (* Eq. A.9b *)
   nl = -Sin[θcamsky] Cos[ϕcamsky];
   nϕ = -Sin[θcamsky] Sin[ϕcamsky];
   nθ = Cos[θcamsky];

   (*Eq. A.9d*)
   pϕ = r[lcamera] Sin[θcamera] nϕ;
   bsquared = (r[lcamera])^2*(nθ^2 + nϕ^2);

   ParametricNDSolveValue[{
     (* Eq. A.7 *)
     l'[t] == pl[t],
     θ'[t] == pθ[t]/(r[l[t]])^2,
     ϕ'[t] == pϕ/((r[l[t]])^2 (Sin[θ[t]])^2),
     pl'[t] == bsquared*rprime[l[t]]/(r[l[t]])^3,
     pθ'[t] == 
      pϕ^2/(r[l[t]])^2 Cos[θ[t]]/(Sin[θ[t]])^3,

     (* Eq. A.9c *)
     pl[0] == nl,
     pθ[0] == r[lcamera] nθ,

     (* Initial conditions, paragraph following Eq. A.9d *)

     l[0] == lcamera,
     θ[0] == θcamera,
     ϕ[0] == ϕcamera
     },
    {l, θ, ϕ, pl, pθ},
    {t, 0, -10^6},
    {θcamsky, ϕcamsky, 
     lcamera, θcamera, ϕcamera, ρ, W, a}]];

Now to use the rayTrace function - we want to build up an array of values for which we can use a ListInterpolation function to map any direction in the camera's local sky to coordinates in one of the celestial spheres. Exactly which celestial sphere is determined by the sign of the lenght coordinate, l. The size of the array is very important. I find that it is important to use an odd number of array elements, or you'll end up with an ugly vertical line in the center of your image.

generateMap[nn_, lc_, θc_, ϕc_, ρ_, W_, a_] := 
 ParallelTable[{Mod[#2/π, 1], Mod[#3/(2 π), 1], #1} & @@ 
   Through[rayTrace[θ, ϕ, lc, θc, ϕc, ρ, 
       W, a][-10^6]][[;; 3]], {θ, 
   Subdivide[π, nn]}, {ϕ, Subdivide[2 π, nn]}]

Finally you need a function to transform the two input images using the map generated by the above function. I would be very happy if someone could suggest a method to do this better - perhaps using ImageTransformation? I was able to make something work with ImageTransformation but it was much less efficient than this. Essentially, ImageTransformation can map pixels from one part of an image to another, but they won't grab pixels from another image. You could create a composite image, with the two stacked on top of each other, or you could use the transformation function on each one separately and then combine them.

blackHoleImage[foreground_, background_, map_] := 
 Module[{raytracefunc, img1func, img2func, nrows, ncols, mapfunc},
  {nrows, ncols} = Reverse@ImageDimensions@foreground;
  raytracefunc = 
   ListInterpolation[#, {{1, nrows}, {1, ncols}}, 
      InterpolationOrder -> 1] & /@ Transpose[(map), {2, 3, 1}];
  img1func = 
   ListInterpolation[#, {{0, 1}, {0, 1}}] & /@ 
    Transpose[(foreground // ImageData), {2, 3, 1}];
  img2func = 
   ListInterpolation[#, {{0, 1}, {0, 1}}] & /@ 
    Transpose[(background // ImageData), {2, 3, 1}];
  mapfunc[a_, b_, x_ /; x <= 0] := Through[img2func[a, b]];
  mapfunc[a_, b_, x_ /; x > 0] := Through[img1func[a, b]];
  Image@Array[
    mapfunc @@ Through[raytracefunc[#1, #2]] &, {nrows, ncols}]
  ]

Low-resolution test

To generate a map using nn=501 takes about 15 to 20 minutes on my PC, so it's no good for testing the effects of various parameters. So we'll make a much smaller map, and the quality of the image will be lower. We can grab a couple of images from the cite listed in the paper,

foreground=Import["http://www.dneg.com/wp-content/uploads/2015/02/InterstellarWormhole_Fig6b.jpg"];
background=Import["http://www.dneg.com/wp-content/uploads/2015/02/InterstellarWormhole_Fig6a.jpg"];

and make a 101 by 101 map in under a minute:

map1 = 
   generateMap[101, 6.0, π/2, 0, 5.0, 0.07, 2.4]; // AbsoluteTiming
(* {36.2135, Null} *)

Here I've taken some some paramters I think make a cool picture ( $ \rho = 5.0$, $a = 2.4$, $W = \mathcal{M}/1.43 = 0.07$) and put the camera at $\{l, \theta, \phi\} = \{ 6, \pi/2, 0 \}$. Since the map is low resolution, I can reduce the resolution of the images to get a quick result,

blackHoleImage[ImageResize[foreground, 500], 
 ImageResize[background, 500], map1]

enter image description here

But if you set nn=501 and don't resize the images you get

enter image description here

Alien invasion

Have you ever read the Commonwealth Saga by Peter F. Hamilton, wherein an alien invades human-held territories via wormhole with the intent of exterminating our species?

Mathematica graphics

here is a better quality, lower filesize mp4 of the above animation. To make this one, I varied the wormhole width from 0 up to 5, then used ImageCompose to add in this stock image flying saucer, then shrunk the wormhole back to zero width.

Unfinished tasks -- I think it would be very interesting to take the result of rayTrace and plot it on top of the embedding diagram, but I haven't quite figured this out. I also think it would be pretty neat to take a terrestrial picture (say of the White House), and have a wormhole open up in the background. Finally, I would be very pleased to figure out how to put the wormhole at any position in an image I want, rather than just the center.

POSTED BY: Jason Biggs
Answer
2 years ago

enter image description here - you earned "Featured Contributor" badge, congratulations !

Dear @Jason Biggs, this is a great post and it has been selected for the curated Staff Picks group. Your profile is now distinguished by a "Featured Contributor" badge and displayed on the "Featured Contributor" board.

POSTED BY: Moderation Team
Answer
2 years ago

Thanks Jason, this is great. I started playing around with different images and I noticed something, though: if you use a square image for the foreground, the wormhole becomes elliptical. If you change the aspect ratio to 2:1, it goes back to a circle. When I use a square image for the background, the image inside the wormhole wraps and I get a vertical line in the middle of the interior. I don't know how to fix that issue...just wondering if you have any thoughts.

POSTED BY: Andrew Watters
Answer
4 months ago

This is really amazing work! I really enjoyed reading this, thank you!

POSTED BY: Sam Carrettie
Answer
4 months ago

Group Abstract Group Abstract