Aug 25, 2009

Visualize irrational number as random walk

Irrational numbers have decimal expansions that neither terminate nor become periodic. So we can get unlimited “random walk” steps from an irrational numbers.

With the following code, the first 10000 digits of Sqrt[2] is presented as a random walk by converting it in base 4. 0, 1, 2 and 3 digit in base 4 represent 4 directions. Starting point is the green dot, the red one is the ending point.

x = N[Sqrt[2], 10000];
walk = First@ RealDigits[x, 4];
rn = FoldList[Plus, {0, 0}, {{0, 1}, {1, 0}, {0, -1}, {-1, 0}}[[# + 1]] & /@ walk];
Graphics[{Line[rn], PointSize[Large], Green, Point[First@rn], Red, Point[Last@rn]}]

randomwalk1

We can also display it with ArrayPlot by constructing a sparse array.

(* shift the moves to {1,1} *)

minx = Min[rn[[All, 1]]];
miny = Min[rn[[All, 2]]];
m = # + {-minx + 1, -miny + 1} & /@ rn;

(* sparse array *)

tt = Tally[m];
cd = SparseArray[tt[[All, 1]] -> tt[[All, 2]]];
cd = Transpose[cd];
ArrayPlot[cd, ColorFunction -> "Rainbow", DataReversed -> True, ColorRules -> {0 -> White}]

randomwalk2

Let’s visualize Sqrt[2], e, Pi in their first 50000 digits. It seems there are some similarities among these images.

Sqrt[2]

2

Pi

Pi

e

e

Update:

DrMajorBob said... in comments:

Here's a 3D version:

x = N[Sqrt[2], 10000];
walk = First@RealDigits[x, 6];
rn = FoldList[ Plus, {0, 0, 0}, {{0, 1, 0}, {1, 0, 0}, {0, -1, 0}, {-1, 0, 0}, {0, 0, 1}, {0, 0, -1}}[[# + 1]] & /@ walk ];
Graphics3D[{Line[rn], PointSize[Large], Green, Point[First@rn], Red, Point[Last@rn]}]

 

3d

You can also try non-irrational number, e.g. 121/5^10

Thanks.

Update 2:

Visualize genome sequence. I know nothing about it, it probably totally meaningless.

GenePlot[g_] := Module[{cs, rn}, walk = Characters[GenomeData [g, "FullSequence"]] /. {"A" -> 1,  "T" -> 2, "G" -> 3, "C" -> 4};
  rn = FoldList[Plus, {0, 0}, {{0, 1}, {1, 0}, {0, -1}, {-1, 0}}[[#]] & /@ walk];
  Graphics[{Line[rn], PointSize[Large], Green, Point[First@rn], Red, Point[Last@rn]}, Frame -> True, FrameTicks -> None] ]

GenePlot["DDK4"]

geneplot

GenePlot["DKK3"]

geneplot2

8 comments:

xan273 (marco) said...

very cool program !

Tommy said...

That's pretty cool. If you could make it 3d (I would if I could), that would be very cool, and would be an interesting way to visualize the data.

DrMajorBob said...

Here's a 3D version:

x = N[Sqrt[2], 10000];
walk = First@RealDigits[x, 6];
rn = FoldList[
Plus, {0, 0,
0}, {{0, 1, 0}, {1, 0, 0}, {0, -1, 0}, {-1, 0, 0}, {0, 0, 1}, {0,
0, -1}}[[# + 1]] & /@ walk];
Graphics3D[{Line[rn], PointSize[Large], Green, Point[First@rn], Red,
Point[Last@rn]}]

DrMajorBob said...

Note, the numbers don't have to be irrational to make these look like random walks. For instance:

x = N[121/5^10, 100000];
walk = First@RealDigits[x, 6];
directions = {{0, 1, 0}, {1, 0, 0}, {0, -1, 0}, {-1, 0, 0}, {0, 0,
1}, {0, 0, -1}};
rn = FoldList[Plus, {0, 0, 0}, directions[[# + 1]] & /@ walk];
Graphics3D[{Line@rn, PointSize@Large, Green, Point@First@rn, Red,
Point@Last@rn}]

Anonymous said...

Very cool and compact code. Thanks. BTW, any idea if the resulting pattern (walks) say anything about the irrational number being used?

aileen said...

I recently came accross your blog and have been reading along. I thought I would leave my first comment. I dont know what to say except that I have enjoyed reading. Nice blog. I will keep visiting this blog very often.


Susan

http://dclottery.info

severoon said...

This is very cool...I think it is probably related to cellular automata (a la NKS). One neat thing to do is to create a table of these results for many multiples of the irrational number: Table[f[n*Pi],{n,32}] for instance.

Note each power of 4 is the same walk over again because it simply shifts the decimal in the base-4 representation (of course). If you run this to 10,000 places of precision for 10*Pi, you get a very interesting walk that creates a path and doesn't deviate from it very much. I wonder what that's about...

michael said...

The more visual type as I am may like to color the path to show the timeline:

m = Length[rn] - 1
g2r = Blend[{Green, Red}, #] & /@ Table[i/m, {i, 0, m - 1}];

coloredWalk =
Transpose[{g2r, Line /@ Partition[rn[[1 ;; m + 1]], 2, 1]}];

Graphics[{coloredWalk}]

Thanks for the lunchtime fun!