Re: Pi day
- To: mathgroup at smc.vnet.net
- Subject: [mg108392] Re: Pi day
- From: brien colwell <xcolwell at gmail.com>
- Date: Tue, 16 Mar 2010 04:45:35 -0500 (EST)
I would try to approach it iteratively. If you have a rational number
P/Q, then the smallest step forward (seems to be) either increasing P by
the smallest amount, or decreasing Q by the smallest amount and then
decreasing P to ensure strictly ascending.
The iteration would be start with the smallest number (123456789 /
987654321) and take the smallest steps forward until it crosses Pi.
I can't think of a clever way to iterate the numbers of interest in
ascending order, so I would probably just throw all 9! (400k) in a list and
sort it.
On Mon, Mar 15, 2010 at 6:02 AM, 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}}
>
>