Services & ResourcesWolfram ForumsMathGroup Archive

[Date Index] [Thread Index] [Author Index]

Re: A problem in Pi digits as Lattice space filling

• To: mathgroup at smc.vnet.net
• Subject: [mg93847] Re: [mg93793] A problem in Pi digits as Lattice space filling
• From: Daniel Lichtblau <danl at wolfram.com>
• Date: Thu, 27 Nov 2008 05:29:01 -0500 (EST)
• References: <200811261011.FAA19540@smc.vnet.net>

Roger Bagula wrote:
> I need help with programs for  4th, 5th and 6th, etc.
> levels of lattice filling:
> 
> The idea that the Pi digits are normal
> implies that they will fill space on different levels
> in a lattice type way ( Hilbert/ Peano  space fill).
> 
> Question of space filling:
> Digit(n)-> how fast till all ten
> {Digit[n],Digit[n+1]} -> how fast to fill the square lattice 
> {0,0},{0,9},{9,0},{9,9}
> {Digit[n],Digit[n+1],Digit[n+2]} -> how fast to fill the cubic lattice 
> {0,0,0} to {9,9,9}
> I've answers for the first three with some really clunky programs.
> 33,606,8554,...
> my estimates for the 4th is: 60372 to 71947
> ((8554)2/(606*2)and half the log[]line result of 140000.)
> but it appears to  outside what my old Mac can do.
> I'd also like to graph the first occurrence to see how random the path 
> between
> the lattice / space fill points is.
> 
> The square:
> a = Table[Floor[Mod[N[Pi*10^n, 1000], 10]], {n, 0, 1000}];
> 
> Flatten[Table[
>         If[Length[Delete[Union[Flatten[Table[Table[If[a[[n]] == k && 
> a[[n + \
> 1]] - l ==
>     0, {l, k}, {}], {k, 0, 9}, {
>           l, 0, 9}], {n, 1, m}], 2]], 1]] == 100, m, {}], {m, 600, 610}]]
> {606, 607, 608, 609, 610}
> Table[Length[Delete[Union[Flatten[Table[Table[If[a[[n]] == k && a[[
>                   n + 1]] - l == 0, {l, k}, {}], {k, 0, 9}, {l,
>                 0, 9}], {n, 1, m}], 2]], 1]], {m, 600, 650}]
> {99, 99, 99,
>     99, 99, 99, 100,
>    100, 100, 100,
>     100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100,
> 100, 100,
> 100, 100, 100,
>    100, 100, 100, 100, 100,
>       100, 100, 100,
>         100, 100, 100, 100, 100,
>             100, 100, 100, 100, 100, 100, 100, 100, 100}
> 
> Mathematica
> Clear[a, b, n]
> a = Table[Floor[Mod[N[Pi*10^n, 10000], 10]], {n, 0, 10000}];
> b = Table[{a[[n]], a[[n + 1]], a[[n + 2]]}, {n, 1, Length[a] - 2}];
> Flatten[Table[
>   If[Length[Union[Table[b[[n]], {
>       n, 1, m}]]] == 1000, m, {}], {m, 8550, 8600}]]
> {8554, 8555, 8556,
>        8557, 8558, 8559, 8560, 8561, 8562, 8563, 8564, 8565, 8566,
>   8567, 8568, 8569, 8570, 8571, 8572, 8573, 8574, 8575, 8576,
>             8577, 8578, 8579, 8580, 8581, 8582, 8583, 8584, 8585, 8586,
>   8587, 8588, 8589,
>     8590, 8591, 8592, 8593, 8594, 8595, 8596, 8597, 8598, 8599, 8600}
> The proof of the 33 is:
> Clear[a,b,n]
> a=Table[Floor[Mod[N[Pi*10^n,10000],10]],{n,0,10000}];
> Flatten[Table[If[Length[Union[Table[a[[n]],{n,1,
>         m}]]]==10,m,{}],{m,1,50}]]
> {33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50}
> 
> My own 4th level program that won't run on my older machine /older 
> version of Mathematica:
> Clear[a, b, n]
> a = Table[Floor[Mod[N[Pi*10^n, 100000], 10]], {n, 0, 100000}];
> b = Table[{a[[n]], a[[n + 1]], a[[n + 2]], a[[n + 3]]}, {n, 1, Length[a] 
> - 3}];
> Flatten[Table[If[ Length[Union[Table[b[[n]], {n, 1, m}]]] == 10000, m, 
> {}], {m, 1, 50}]]
> 
> Respectfully, Roger L. Bagula
> 11759Waterhill Road, Lakeside,Ca 92040-2905,tel: 619-5610814 
> :http://www.geocities.com/rlbagulatftn/Index.html
> alternative email: rlbagula at sbcglobal.net

Much faster to compute all the digits in one go. Then loop over them, 
check which give new values, and once you've filled the lattice, return 
the number that were needed to get there.

Also bear in mind that it might take more than ten times as many sets in 
order to fill such a lattice.

Here is code to do all this.

latticeFillMark[n_?NumericQ, d_Integer] /;d>0 :=
   Catch[Module[
   {digits, vals, len=10^d, hitlist, count=0, elem},
     digits = First[RealDigits[n,10,10*Ceiling[d/2]*len]];
	vals = Map[FromDigits,Partition[digits,d,1]];
	hitlist = ConstantArray[0,len];
	Do[
	  elem = vals[[j]] + 1;
	  If [hitlist[[elem]]==1, Continue[]];
	  hitlist[[elem]] = 1;
	  count++;
	  If [count==len, Throw[j]];
	  ,{j,Length[vals]}];
	$Failed
   ]]

In[52]:= Timing[latticeFillMark[Pi,3]]
Out[52]= {0.088987, 8554}

In[53]:= Timing[latticeFillMark[Pi,4]]
Out[53]= {1.03484, 99847}

(So your guess was a bit low.)

In[51]:= Timing[latticeFillMark[Pi,5]]
Out[51]= {28.0557, 1369561}

That needed more than 10^6 digits computed, which is why I coded to use 
more. An alternative would be to take 10^d at a time, adding another 
layer of loop. Would run faster, but it's more code than I want to write 
at the moment.

More examples:

In[59]:= Timing[latticeFillMark[E,4]]
Out[59]= {1.03684, 102125}

In[60]:= Timing[latticeFillMark[GoldenRatio,4]]
Out[60]= {1.11583, 93907}

Daniel Lichtblau
Wolfram Research

• References:
  • A problem in Pi digits as Lattice space filling
    • From: Roger Bagula <rlbagula@sbcglobal.net>