Pi day

[Tom]

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

[DC]

Not elegant and probably slow :

digits = Permutations[{1, 2, 3, 4, 5, 6, 7, 8, 9}, {9}];

factors = 10^# & /@ Range[8, 0, -1];

possibilities = (#.factors) & /@ digits;

output = Flatten[
Outer[{#1, #2, Abs[#1/#2 - \[Pi]]} &, possibilities, possibilities,
1, 1], 1];

SortBy[output, #[[3]] &] // First // N
SortBy[output, #[[3]] &] // Last // N

-Francesco

[DrMajorBob]

Very interesting problem! (But probably not one for high school students.)

Here are timings for the first part of Francesco's method:

Timing[digits = Permutations[{1, 2, 3, 4, 5, 6, 7, 8, 9}, {9}];]
Timing[factors = 10^# & /@ Range[8, 0, -1];
p1 = (#.factors) & /@ digits;]

{0.021722, Null}

{0.119972, Null}

I was surprised to find this was slower:

Timing[p2 = FromDigits /@ digits;]
p1 == p2

{0.777502, Null}

True

But this was faster than both, which did NOT surprise me:

Timing[
candidates = digits.(10^Range[8, 0, -1]);]
candidates == p1

{0.039861, Null}

True

The next step of Francesco's method was too slow for my patience level, so
I
tried something else. (And so, in the end, I spent MUCH more time than
simply using his method!)

(1) I sanity-checked the ordering of candidates:

pi = p2 = digits =.;
OrderedQ@candidates

True

(2) I determined the largest denominator (plus a little) that I'd need to
deal with:

Reduce[Pi b <= 987654321, Integers]

b \[Element] Integers && b <= 314380134

If a/b is close to Pi, and a <= 987654321, then optimal b is not much more
than the bound above.

But I need a bit of slack, so I find the smallest candidate larger than
the bound:

bUpper = Last@Select[candidates, Pi # < 987654321 &]
bNdxUpper = Position[candidates, bUpper][[1, 1]]

314298765

81480

I need to end on an element of the candidate list, even though it's too
large (I think) to be optimal.

(3) Similarly, I determined the smallest candidate numerator that I'd ever
need:

aLower = Last@Select[candidates, # < 123456789 Pi &]
aNdxLower = Position[candidates, aLower][[1, 1]]
n = Length@candidates

387695421

115080

362880

(4) I computed an InterpolationFunction that maps from candidate values of
(Pi * denominator) to their index in the candidate list:

Block[{c = Drop[candidates, aNdxLower - 1], r},
Print@First@c;
Print@Round[1/Pi First@c];
r = Range[aNdxLower, n];
cf = Interpolation[Thread[{c, r}], InterpolationOrder -> 1];
Print[cf /@ c == r]
]

387695421

123407285

True

The reason I needed aLower and aNdxLower was to make "cf" smaller than
using the entire candidate list in place of "c".

InterpolationOrder -> 1 is essential, since otherwise, cf isn't monotone.

(5) I formed a "numerator" function that tries the two nearest candidate
numerators (near to Pi b) and returns the best one, along with the
absolute error:

Clear[numerator]
numerator[b_] /; b <= bUpper :=
Module[{ndx = cf[Pi b], indices, a},
indices = Through[{Floor, Ceiling}@ndx];
a = First@
candidates[[indices[[Ordering[Abs[Pi - candidates[[indices]]/b],
1]]]]];
{Pi - a/b // N // Abs, a, b}
]

(6) Here it is, evaluated at the smallest and largest denominators I've
allowed:

numerator /@ {123456789, bUpper}

{{0.000498269, 387912456, 123456789}, {0.0000434772, 987412356,
314298765}}

(7) Compute all the relevant trials:

Timing[nums = Sort[numerator /@ Take[candidates, bNdxUpper]];]

{16.617, Null}

(8) Check out the best and worst approximations found:

Through[{First, Last}@nums]

{{1.01855*10^-10, 429751836, 136794258}, {0.106985, 412356789,
126934578}}

(9) I looked at about 22.5% of the legal denominators, and two numerators
for each.

bNdxUpper/n // N

0.224537

(10) It turned out that Ceiling was chosen every time.

I'm not sure why that is, or if it indicates I'm missing something.

Indeed, I could have missed something... but 429751836 / 136794258 is
closer than Patrick's 10-digit result.

Bobby

On Sun, 14 Mar 2010 05:14:44 -0500, DC <b.gate...@gmail.com> wrote:

> Not elegant and probably slow :
>
> digits = Permutations[{1, 2, 3, 4, 5, 6, 7, 8, 9}, {9}];
>
> factors = 10^# & /@ Range[8, 0, -1];
>
> possibilities = (#.factors) & /@ digits;
>
> output = Flatten[
> Outer[{#1, #2, Abs[#1/#2 - \[Pi]]} &, possibilities, possibilities,
> 1, 1], 1];
>
> SortBy[output, #[[3]] &] // First // N
> SortBy[output, #[[3]] &] // Last // N
>
>
> -Francesco
>
> On 03/13/2010 12:55 PM, Tom wrote:

--
DrMaj...@yahoo.com