Message Boards Message Boards

[Numberphile] - The Illumination Problem


enter image description here

The other day I was watching a video on the wonderful Numberphile channel about the illumation problem. Check it out here.

It's about light bouncing inside a closed room where all the walls are covered by mirrors. Roger Penrose came up with a room which can not be completely lit by a single light source. I was very curious what the paths would look like so here it is.

Let's first create the shape:


enter image description here

Note that I discretize the ellipses with a small measure, such that we have a very good approximation. What I'm left with is only small line pieces.

Here is some code that calculates the paths (not optimized, I'll leave that to someone else; I'm sure some operations can be vectorized):

ClearAll[LineLineIntersect, JumpAroundCreateGraphics]
LineLineIntersect[X1_, X2_, X3_, X4_] := 
 Module[{a, denom, \[CapitalDelta]x, x2, x4, \[CapitalDelta]y, y2, y4},
  {\[CapitalDelta]x, \[CapitalDelta]y} = X1 - X3;
  {x2, y2} = X2;
  {x4, y4} = X4 - X3;
  denom = x4 y2 - x2 y4;
  If[denom == 0, Return[False],
   a = (y4 \[CapitalDelta]x - x4 \[CapitalDelta]y)/denom;
   If[a > 10^-10 \[And] 
     0 <= (y2 \[CapitalDelta]x - x2 \[CapitalDelta]y)/denom <= 1, 
    Return[a], Return[False]]
JumpAroundCreateGraphics[lines_, n_, dirs_List, start_] := 
 Module[{points, k, cp, cv, dat, fdat, tmp, index, np, mirror},
  k = 0;
  PrintTemporary[ProgressIndicator[Dynamic[k/(Length[dirs] n)]]];
  points = Table[
    cp = start;
    cv = \[Theta];
       dat = LineLineIntersect[cp, cv, #1, #2] & @@@ lines;
       fdat = Min @@ DeleteCases[dat, False];
       tmp = Flatten[Position[dat, fdat]];
       If[Length[tmp] > 0,
        index = First[tmp];
        np = cp + dat[[index]] cv;
        mirror = (#[[2]] - #[[1]]) &[lines[[index]]];
        cv = -cv + 2 (cv.mirror/Norm[mirror]) (mirror/Norm[mirror]); 
        Sow[cp = np]
       {i, n}
      ][[2, 1]]
    {\[Theta], dirs}
  Graphics[{Line@lines, Line /@ points, Red, 
    Arrow /@ points[[All, ;; 2]], Blue, Disk[start, 0.25]}, 
   AspectRatio -> Automatic]

We can try it out by calling this new function:

JumpAroundCreateGraphics[lines, 15, {{1.2, -0.4}}, {0.5, 0.5}]

where lines is all the little line-pieces, 15 the number of bounces, followed by a list of directions, and lastly the starting position.

enter image description here

We can run it longer and indeed confirm that the four square corners will not be lit if we start somewhere in the middle:

JumpAroundCreateGraphics[lines, 150, {{1.2, -0.4}}, {0.5, 0.5}]

enter image description here

Indeed, the corners remain in the dark.

A more comprehensive search is by sending light out in more than one direction:

JumpAroundCreateGraphics[lines, 25, CirclePoints[12], {0.5, 0.5}]

enter image description here

We can see again that the corners stay in the dark.

If we start in one of the corners only part of the box is illuminated:

JumpAroundCreateGraphics[lines, 25, CirclePoints[12], {8.45, 1.15}]

enter image description here

And lastly, if we start in the top half-ellipse, it will reach only the top 2 corners:

JumpAroundCreateGraphics[lines, 25, CirclePoints@12, {-0.2632, 7.377}]

enter image description here

Final note: note that I used a discretized version of the ellipses, after many many bounces the effect of this will show up and accumulate errors slowly. So if one calculates many many bounces it will end up everywhere...

Hope you enjoyed this little exploration.

POSTED BY: Sander Huisman
27 days ago

enter image description here - Congratulations! This post is now a Staff Pick! Thank you for your wonderful contributions. Please, keep them coming!

POSTED BY: Moderation Team
27 days ago

Group Abstract Group Abstract