Mathematician vs. Computer: A Game

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 random from 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

enter image description here
enter image description here

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:

enter image description here

Plotting mean “best n” against range gives

enter image description here

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

enter image description here

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]

enter image description here

The plot above (there are 2 plots here) show the values of “winchance” for primes against a plot of 2+2(epn)range2pn

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(range1) eg 499500 for range 1000.

enter image description here

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

enter image description here

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.

enter image description here

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

Leave a Comment