Re: Pi day
- To: mathgroup at smc.vnet.net
- Subject: [mg108376] Re: Pi day
- From: Ray Koopman <koopman at sfu.ca>
- Date: Mon, 15 Mar 2010 05:02:24 -0500 (EST)
- References: <201003131255.HAA28381@smc.vnet.net> <hnkf78$pkr$1@smc.vnet.net>
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}}
- References:
- Pi day
- From: Tom <tidetabletom@gmail.com>
- Pi day