A mathematician and a computer are playing a game: First, the mathematician chooses an integer from the range 2,...,1000. Then, the computer chooses an integer

uniformly at randomfrom the same range. If the numbers chosen share a prime factor, the larger number wins. If they do not, the smaller number wins. (If the two numbers are the same, the game is a draw.)Which number should the mathematician choose in order to maximize his chances of winning?

**Answer**

For fixed range:

```
range = 16;
a = Table[Table[FactorInteger[y][[n, 1]], {n, 1, PrimeNu[y]}], {y, 1, range}];
b = Table[Sort@DeleteDuplicates@ Flatten@Table[
Table[Position[a, a[[y, m]]][[n, 1]],
{n, 1, Length@Position[a, a[[y, m]]]}], {m, 1, PrimeNu[y]}], {y, 1, range}];
c = Table[Complement[Range[range], b[[n]]], {n, 1, range}];
d = Table[Range[n, range], {n, 1, range}];
e = Table[Range[1, n], {n, 1, range}];
w = Table[DeleteCases[DeleteCases[Join[Intersection[c[[n]], e[[n]]],
Intersection[b[[n]], d[[n]]]], 1], n], {n, 1, range}];
l = Table[DeleteCases[DeleteCases[Complement[Range[range], w[[n]]], 1],
n], {n, 1, range}];
results = Table[Length@l[[n]], {n, 1, range}];
cf = Grid[{{Join[{"n"}, Rest@(r = Range[range])] // ColumnForm,
Join[{"win against n"}, Rest@w] // ColumnForm,
Join[{"lose against n"}, Rest@l] // ColumnForm,
Join[{"probability win for n"}, (p = Drop[Table[
results[[n]]/Total@Drop[results, 1] // N,{n, 1, range}], 1])] // ColumnForm}}]
Flatten[Position[p, Max@p] + 1]
```

isn’t great code, but fun to play with for small ranges, gives

and perhaps more illuminating

```
rr = 20; Grid[{{Join[{"range"}, Rest@(r = Range[rr])] // ColumnForm,
Join[{"best n"}, (t = Rest@Table[
a = Table[Table[FactorInteger[y][[n, 1]], {n, 1, PrimeNu[y]}], {y, 1, range}];
b = Table[Sort@DeleteDuplicates@Flatten@Table[Table[
Position[a, a[[y, m]]][[n, 1]], {n, 1,Length@Position[a, a[[y, m]]]}],
{m, 1,PrimeNu[y]}], {y, 1, range}];
c = Table[Complement[Range[range], b[[n]]], {n, 1, range}];
d = Table[Range[n, range], {n, 1, range}];
e = Table[Range[1, n], {n, 1, range}];
w = Table[DeleteCases[DeleteCases[Join[Intersection[c[[n]], e[[n]]],
Intersection[b[[n]], d[[n]]]], 1], n], {n, 1, range}];
l = Table[DeleteCases[DeleteCases[Complement[Range[range], w[[n]]], 1], n],
{n,1, range}];
results = Table[Length@l[[n]], {n, 1, range}];
p = Drop[Table[results[[n]]/Total@Drop[results, 1] // N,
{n, 1, range}], 1];
{Flatten[Position[p, Max@p] + 1], Max@p}, {range, 1, rr}]/.Indeterminate-> draw);
Table[t[[n, 1]], {n, 1, rr - 1}]] // ColumnForm,
Join[{"probability for win"}, Table[t[[n, 2]], {n, 1, rr - 1}]] // ColumnForm}}]
```

compares ranges:

Plotting mean “best n” against √range gives

For range=1000, “best n” are 29 and 31, which can be seen as maxima in this plot:

# Update

In light of DanielV’s comment that a “primes vs winchance” graph would probably be enlightening, I did a little bit of digging, and it turns out that it is. Looking at the “winchance” (just a weighting for n) of the primes in the range only, it is possible to give a fairly accurate prediction using

```
range = 1000;
a = Table[Table[FactorInteger[y][[n, 1]], {n, 1, PrimeNu[y]}], {y, 1, range}];
b = Table[Sort@DeleteDuplicates@Flatten@Table[
Table[Position[a, a[[y, m]]][[n, 1]], {n, 1,
Length@Position[a, a[[y, m]]]}], {m, 1, PrimeNu[y]}], {y, 1, range}];
c = Table[Complement[Range[range], b[[n]]], {n, 1, range}];
d = Table[Range[n, range], {n, 1, range}];
e = Table[Range[1, n], {n, 1, range}];
w = Table[ DeleteCases[ DeleteCases[
Join[Intersection[c[[n]], e[[n]]], Intersection[b[[n]], d[[n]]]],
1], n], {n, 1, range}];
l = Table[
DeleteCases[DeleteCases[Complement[Range[range], w[[n]]], 1],
n], {n, 1, range}];
results = Table[Length@l[[n]], {n, 1, range}];
p = Drop[Table[
results[[n]]/Total@Drop[results, 1] // N, {n, 1, range}], 1];
{Flatten[Position[p, Max@p] + 1], Max@p};
qq = Prime[Range[PrimePi[2], PrimePi[range]]] - 1;
Show[ListLinePlot[Table[p[[t]] range, {t, qq}],
DataRange -> {1, Length@qq}],
ListLinePlot[
Table[2 - 2/Prime[x] - 2/range (-E + Prime[x]), {x, 1, Length@qq + 0}],
PlotStyle -> Red], PlotRange -> All]
```

The plot above (there are 2 plots here) show the values of “winchance” for primes against a plot of 2+2(e−pn)range−2pn

where pn is the nth prime, and “winchance” is the number of possible wins for n divided by total number of possible wins in range ie range2(range−1) eg 499500 for range 1000.

```
Show[p // ListLinePlot, ListPlot[N[
Transpose@{Prime[Range[PrimePi[2] PrimePi[range]]],
Table[(2 + (2*(E - Prime[x]))/range - 2/Prime[x])/range, {x, 1,
Length@qq}]}], PlotStyle -> {Thick, Red, PointSize[Medium]},
DataRange -> {1, range}]]
```

# Added

Bit of fun with game simulation:

```
games = 100; range = 30;
table = Prime[Range[PrimePi[range]]];
choice = Nearest[table, Round[Sqrt[range]]][[1]];
y = RandomChoice[Range[2, range], games]; z = Table[
Table[FactorInteger[y[[m]]][[n, 1]], {n, 1, PrimeNu[y[[m]]]}], {m, 1, games}];
Count[Table[If[Count[z, choice] == 0 && y[[m]] < choice \[Or]
Count[z, choice] > 0 && y[[m]] < choice, "lose", "win"],
{m, 1, games}], "win"]
```

& simulated wins against computer over variety of ranges

with

```
Clear[range]
highestRange = 1000;
ListLinePlot[Table[games = 100;
table = Prime[Range[PrimePi[range]]];
choice = Nearest[table, Round[Sqrt[range]]][[1]];
y = RandomChoice[Range[2, range], games];
z = Table[Table[FactorInteger[y[[m]]][[n, 1]], {n, 1, PrimeNu[y[[m]]]}], {m,
1, games}];
Count[Table[ If[Count[z, choice] == 0 && y[[m]] < choice \[Or]
Count[z, choice] > 0 && y[[m]] < choice, "lose", "win"], {m, 1,
games}], "win"], {range,2, highestRange}], Filling -> Axis, PlotRange-> All]
```

# Added 2

Plot of mean “best n” up to range=1000 with tentative conjectured error bound of ±√rangelog(range) for range>30.

I could well be wrong here though. – In fact, on reflection, I think I am (related).

**Attribution***Source : Link , Question Author : Community , Answer Author : Community*