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?
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-&gt; 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 $\sqrt{\text{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 -&gt; {1, Length@qq}], 
ListLinePlot[
Table[2 - 2/Prime[x] - 2/range (-E + Prime[x]), {x, 1, Length@qq + 0}],
PlotStyle -&gt; Red], PlotRange -&gt; All]




The plot above (there are $2$ plots here) show the values of "winchance" for primes against a plot of $$2+\frac{2 (e-p_n)}{\text{range}}-\frac{2}{p_n}$$

where $p_n$ is the $n$th prime, and "winchance" is  the number of possible wins for $n$ divided by total number of possible wins in range ie $$\dfrac{\text{range}}{2}\left(\text{range}-1\right)$$ 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 -&gt; {Thick, Red, PointSize[Medium]}, 
DataRange -&gt; {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 &amp;&amp; y[[m]] &lt; choice \[Or] 
Count[z, choice] &gt; 0 &amp;&amp; y[[m]] &lt; choice, "lose", "win"], 
{m, 1, games}], "win"]


&amp; 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 &amp;&amp; y[[m]] &lt; choice \[Or] 
  Count[z, choice] &gt; 0 &amp;&amp; y[[m]] &lt; choice, "lose", "win"], {m, 1, 
 games}], "win"], {range,2, highestRange}], Filling -&gt; Axis, PlotRange-&gt; All]


Added 2

Plot of mean "best $n$" up to range$=1000$ with tentative conjectured error bound of $\pm\dfrac{\sqrt{\text{range}}}{\log(\text{range})}$ for range$&gt;30$.



I could well be wrong here though. - In fact, on reflection, I think I am (related).
The mathematician should choose 990.  It has the most prime factors of 2, 3 ,5, 11 at the high end of numbers to 1000.
Since the computer is going to pick a random number, there is a high probability (large set)
1.  That the number picked will be less than 990
2.  That it will get an easily factored number containing 2,3,5 or 11 (there are many).

The mathematician does not want to be in this large set, and should win most games.