Re: Pi day
- To: mathgroup at smc.vnet.net
- Subject: [mg108393] Re: Pi day
- From: brien colwell <xcolwell at gmail.com>
- Date: Tue, 16 Mar 2010 04:45:47 -0500 (EST)
... forgot to attach attempted code for this approach.
nums = Sort[FromDigits /@ Permutations[{1, 2, 3, 4, 5, 6, 7, 8, 9}]];
NIndex = 1;
DIndex = -1;
pv = 0;
v = 0;
ChooseNextIndexes[] := Module[{i = 1},
While[v < (nums[[NIndex - i]]/nums[[DIndex - 1]]),
i += 1];
If[nums[[NIndex + 1]]/nums[[DIndex]] <
nums[[NIndex - (i - 1)]]/nums[[DIndex - 1]],
{NIndex + 1, DIndex},
{NIndex - (i - 1), DIndex - 1}
]
];
(* This is a guess to speed up the search
*)
While[nums[[NIndex + 1]]/nums[[DIndex - 1]] < \[Pi],
NIndex += 1;
DIndex -= 1;
];
pv = 0;
pIndexes = {NIndex, DIndex};
While[(v = nums[[NIndex]]/nums[[DIndex]]) < \[Pi],
pv = v;
pIndexes = {NIndex, DIndex};
{NIndex, DIndex} = ChooseNextIndexes[];
];
If[N[\[Pi] - pv] < N[v - \[Pi]],
ToString[nums[[pIndexes[[1]]]]] <> " / " <>
ToString[nums[[pIndexes[[2]]]]],
ToString[nums[[NIndex]]] <> " / " <> ToString[nums[[DIndex]]]
]
N[If[N[\[Pi] - pv] < N[v - \[Pi]],
pv,
v
]]
On Tue, Mar 16, 2010 at 12:41 AM, brien colwell <xcolwell at gmail.com> wrote:
> 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}}
>>
>>
>