MathGroup Archive 2010

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

Search the Archive

Re: Pi day

  • To: mathgroup at smc.vnet.net
  • Subject: [mg108388] Re: Pi day
  • From: DrMajorBob <btreat1 at austin.rr.com>
  • Date: Tue, 16 Mar 2010 04:44:49 -0500 (EST)

A couple of tweaks improved the timing from 6.4 seconds to 4.9, on my
computer:

Timing[s = (Permutations@Range@9).(10^Range[8, 0, -1]);
    j = 1; i = Position[s, x_ /; x > Pi s[[j]], 1, 1][[1, 1]];
    hi = s[[i]]/s[[j]]; ijhi = {i, j};
    lo = s[[i - 1]]/s[[j]]; ijlo = {i - 1, j};
    k = -1 + Position[s, x_ /; s[[-1]] < Pi x, 1, 1][[1, 1]];
    While[j < k, j++; While[s[[i]]/s[[j]] < Pi, i++];
     If[s[[i]]/s[[j]] < hi, hi = s[[i]]/s[[j]]; ijhi = {i, j}];
     If[s[[i - 1]]/s[[j]] > lo, lo = s[[i - 1]]/s[[j]];
      ijlo = {i - 1, j}]];
    {{N[hi - Pi], s[[ijhi]]}, {N[lo - Pi], s[[ijlo]]}}]

{4.90821, {{1.01855*10^-10, {429751836,
     136794258}}, {-8.49969*10^-11, {467895213, 148935672}}}}

Position replaced the first two While loops, and Dot replaced Map in the
first line.

Using Position in the main loop is too slow, because it doesn't start at
the current position in the list. Using Drop[s, i - 1] and adding i - 1
would do that, but it's also too slow, presumably due to the expense of
allocating the Drop result.

Here's the same thing in base 11:

Timing[s = (Permutations@Range@10).(11^Range[9, 0, -1]);
  j = 1; i = Position[s, x_ /; x > Pi s[[j]], 1, 1][[1, 1]];
  hi = s[[i]]/s[[j]]; ijhi = {i, j};
  lo = s[[i - 1]]/s[[j]]; ijlo = {i - 1, j};
  k = -1 + Position[s, x_ /; s[[-1]] < Pi x, 1, 1][[1, 1]];
  While[j < k, j++; While[s[[i]]/s[[j]] < Pi, i++];
   If[s[[i]]/s[[j]] < hi, hi = s[[i]]/s[[j]]; ijhi = {i, j}];
   If[s[[i - 1]]/s[[j]] > lo, lo = s[[i - 1]]/s[[j]];
    ijlo = {i - 1, j}]];
  {{N[hi - Pi], BaseForm[s[[ijhi]], 11]}, {N[lo - Pi],
    BaseForm[s[[ijlo]], 11]}}]

{55.9061,{{4.2637*10^-12,{Subscript[a139786245, 11],Subscript[32498a5761,  
11]}},{-8.34888*10^-13,{Subscript[a675231948, 11],Subscript[3415a68729,  
11]}}}}

Base 12 seemed to steal every byte of memory on my 4GB iMac with 64-bit  
Mathematic.

Permutations choked on base 13, immediately.

Bobby

On Mon, 15 Mar 2010 05:02:24 -0500, Ray Koopman <koopman at sfu.ca> wrote:

> On Mar 14, 10:05 pm, d... at wolfram.com wrote:
>>> Hello,  I am a high school math teacher and the following puzzle was
>>> posed by a few math teachers I am in contact with.
>>>
>>> Create a fraction whose numerator has the digits 1 - 9 (used once)
>>> and whose denominator has the digits 1 - 9  (used one) .
>>>
>>> Which fraction has a value closest to the value of pi?
>>>
>>> I've worked on some "brute force" checks and managed to check all
>>> possible fractions with 2,3,4,5 and 6 digits.   But after that, there
>>> are just too many possibilities.
>>>
>>> I don't have the programming ability to implement something elegant in
>>> Mathematica.
>>>
>>> Is there anyone who could suggest an approach to find the solution to
>>> this?
>>>
>>> Sincerely,
>>>
>>> Tom
>>
>> Here is a method that is reasonably effective. It is a "greedy" approach
>> and I cannot offhand guarantee that is gives the best result (though I
>> believe it does).
>>
>> The idea is to begin with all one digit (numerator,denominator) pairs.
>> Filter out the ones that cannot possibly be improved via further digits  
>> in
>> a way that will beat the best pairs. For the keepers, augment numerators
>> and denominators with all available single digits. Iterate this process
>> until we are out of digits. It is the pruning that keeps this from
>> becoming intractable as we progress over the digit pool. (Eventual
>> exhaustion of said pool also helps.)
>>
>> In brief, the routines do as follows.
>>
>> frac[] makes an integer pair into a rational.
>>
>> closest[] takes a list of pairs and a target value, and finds the one
>> whose corresponding fraction is closest to that target.
>>
>> intervalize[] takes a pair and creates the interval comprised of  
>> fractions
>> where first denominator, and then numerator, are increased by one. This
>> interval is a crude lower/upper bound on all values that can be attained
>> by adding allowable digits to the given numerator and denominator.
>>
>> siftPairs[] takes pairs and a target. it first finds the pair that best
>> approximates the target. It then removes all others that cannot possibly
>> get within range via allowable augmentation to numerator and  
>> denominator.
>>
>> successors[] takes a numerator/denominator pair and finds the set of  
>> allowed
>> pairs. These are defined as pairs with numerator and denominator one  
>> digit
>> longer, and neither one repeating digits.
>>
>> With that intro, here is the code.
>>
>> frac[{n_Integer, d_Integer}] := n/d
>>
>> closest[pairs_, target_] :=
>>  pairs[[Ordering[Abs[Map[frac, pairs, 1] - target], 1]]][[1]]
>>
>> intervalize[{num_Integer, den_Integer}] :=
>>  Interval[{num/(den + 1), (num + 1)/den}]
>>
>> siftPairs[pairs_, target_] := Module[
>>   {interval, num, den},
>>   {num, den} = closest[pairs, target];
>>   interval = intervalize[{num, den}];
>>   Select[pairs, (IntervalIntersection[intervalize[#], interval] =!=
>>       Interval[]) &]
>>   ]
>>
>> successors[{num_Integer, den_Integer}] := Module[
>>   {nd, dd, cnd, cdd, nums, dens},
>>   {nd, dd} = IntegerDigits[{num, den}];
>>   cnd = Complement[Range[9], nd];
>>   cdd = Complement[Range[9], dd];
>>   nums = Map[10*num + # &, cnd];
>>   dens = Map[10*den + # &, cdd];
>>   Flatten[Outer[List, nums, dens], 1]
>>   ]
>>
>> We now form our initial pairs of one digit numerators and denominators.  
>> We
>> then nest our successorship function eight times (thus exhausting
>> available digits). In each step we sift to remove pairs that are not
>> contenders.
>>
>> initpairs = Flatten[Outer[List, Range[9], Range[9]], 1];
>>
>> In[377]:= Timing[
>>  candidates =
>>    Nest[Flatten[Map[successors, siftPairs[#, Pi]], 1] &, initpairs,
>>     8];]
>> Out[377]= {16.864, Null}
>>
>> In[378]:= Length[candidates]
>> Out[378]= 2576
>>
>> In[380]:= best = closest[candidates, Pi]
>> Out[380]= {429751836, 136794258}
>>
>> In[382]:= bestfrac = frac[best]
>> Out[382]= 23875102/7599681
>>
>> In[386]:= N[bestfrac - Pi, 5]
>> Out[386]= 1.0186*10^-10
>>
>> So we get within around 10^(-10) of our quarry.
>>
>> It is instructive to print lengths of our pair lists at intermediate
>> steps. It goes over 70,000 before receding to the eventual 2600 or so.
>> Possibly a more aggressive sifter would so better (but would be more
>> trouble to code, or for that matter to figure out how to construct).
>>
>> Given that we work from most significant digits downward, it seems
>> plausible that our eventual result will be optimal. But it is not  
>> obvious
>> to me that it is forced to be so. I need to give this more thought.
>>
>> Daniel Lichtblau
>> Wolfram Research
>
> I get a little better fit by walking the list.
>
> s = FromDigits/@Permutations@Range@9;
> i = j = 1; While[s[[i]]/s[[j]] < Pi, i++];
> hi = s[[ i ]]/s[[j]]; ijhi = { i ,j};
> lo = s[[i-1]]/s[[j]]; ijlo = {i-1,j};
> k = Length@s; While[s[[-1]]/s[[k]] < Pi, k--];
> While[j < k,
>   j++; While[s[[i]]/s[[j]] < Pi, i++];
>   If[s[[ i ]]/s[[j]] < hi, hi = s[[ i ]]/s[[j]]; ijhi = { i ,j}];
>   If[s[[i-1]]/s[[j]] > lo, lo = s[[i-1]]/s[[j]]; ijlo = {i-1,j}]];
> {N[hi-Pi], s[[ijhi]]}
> {N[lo-Pi], s[[ijlo]]}
>
> {1.0185541299279066*^-10, {429751836, 136794258}}
> {-8.499689840846258*^-11, {467895213, 148935672}}
>


-- 
DrMajorBob at yahoo.com


  • Prev by Date: Re: Re: Pi day
  • Next by Date: Axeslabel containing capital n
  • Previous by thread: Re: Re: Pi day
  • Next by thread: Re: Pi day