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-> 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 -> {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+\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 -> {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 $\pm\dfrac{\sqrt{\text{range}}}{\log(\text{range})}$ for range$>30$.

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

First consider choosing a prime $p$ in the range $[2,N]$. You lose only if the computer chooses a multiple of $p$ or a number smaller than $p$, which occurs with probability $$ \frac{(\lfloor{N/p}\rfloor-1)+(p-2)}{N-1}=\frac{\lfloor{p+N/p}\rfloor-3}{N-1}. $$ The term inside the floor function has derivative $$ 1-\frac{N}{p^2}, $$ so it increases for $p\le \sqrt{N}$ and decreases thereafter. The floor function does not change this behavior. So the best prime to choose is always one of the two closest primes to $\sqrt{N}$ (the one on its left and one its right, unless $N$ is the square of a prime). Your chance of losing with this strategy will be $\sim 2/\sqrt{N}$.

On the other hand, consider choosing a composite $q$ whose prime factors are $$p_1 \le p_2 \le \ldots \le p_k.$$ Then the computer certainly wins if it chooses a prime number less than $q$ (other than any of the $p$'s); there are about $q / \log q$ of these by the prime number theorem. It also wins if it chooses a multiple of $p_1$ larger than $q$; there are about $(N-q)/p_1$ of these. Since $p_1 \le \sqrt{q}$ (because $q$ is composite), the computer's chance of winning here is at least about $$ \frac{q}{N\log q}+\frac{N-q}{N\sqrt{q}}. $$ The first term increases with $q$, and the second term decreases. The second term is larger than $(1/3)/\sqrt{N}$ until $q \ge (19-\sqrt{37})N/18 \approx 0.72 N$, at which point the first is already $0.72 / \log{N}$, which is itself larger than $(5/3)/\sqrt{N}$ as long as $N > 124$. So the sum of these terms will always be larger than $2/\sqrt{N}$ for $N > 124$ or so, meaning that the computer has a better chance of winning than if you'd chosen the best prime.

This rough calculation shows that choosing the prime closest to $\sqrt{N}$ is the best strategy for sufficiently large $N$, where "sufficiently large" means larger than about $100$. (Other answers have listed the exceptions, the largest of which appears to be $N=30$, consistent with this calculation.)

Scheme:

(define (range a b) (if (> a b) '() (cons a (range (+ a 1) b))))

;; Probability of Winning if you Choose N out of NRange
(define (ProbOfWinning N NRange)
  ;; how many numbers k for which
  ;;   GCD(k, N)=1 and N < k
  ;; or
  ;;   GCD(k, N)>1 and N > k
    ;; N beats K
  (define (Wins k)
      (if (= (gcd k N) 1) (< N k) (> N k)))

  (/ (length (filter Wins NRange)) (length NRange)))

(define GameRange (range 2 1000))

(define WinChances (map (λ (N) (list N (ProbOfWinning N GameRange))) GameRange))

(sort WinChances (λ (a b) (< (second a) (second b))) )

The best chances of winning are $31$ and $29$, with probability $938/999$, and close third $37$ at $937/999$

I used Javascript and brute-forced the solution. It wasn't terribly fast, but it worked. 29 or 31 are the best numbers to pick.

function find_primes(max) {
  // returns all primes less than or equal to max
  for (var primes = [], i = 2; i <= max; ++ i) {
    for (var j = 0; j < primes.length; ++ j)
      if (i % primes[j] == 0) break;  // stop if it's divisible by a prime
    if (j >= primes.length) primes.push(i);
  }
  return primes;
}

function winner(a, b, primes) {
  // primes must contain all primes less than or equal to the largest a or b
  for (var j = 0; j < primes.length; ++ j)
    if (!(a % primes[j] + b % primes[j])) return Math.max(a, b);
  return Math.min(a, b);
}

var min = 2, max = 1000, primes = find_primes(max), plays = [];
for (var i = min; i <= max; ++ i) {
  plays[i] = {play: i, opponents: 0, wins: 0};
  for (var j = min; j <= max; ++ j) {
    ++ plays[i].opponents;
    if (i != j && winner(i, j, primes) == i) ++ plays[i].wins;
  }
}

// sort, highest number of wins first
plays.sort(function (a, b) { return a.wins < b.wins; });
// display the results
plays.map(function (e) {
  return e.play + ": " + e.wins + " wins (" + (e.wins / e.opponents * 100).toFixed(2) * 1 + "%)";
});

(edit) you also get an interesting pattern if you print the entire list with prime numbers highlighted, like this:

I feel like all of the other responses are somewhat more complicated and hard to follow, so I hope to provide something more straight-forward. I'm always impressed with the beautiful formatting on MSE, though.

First, any number $n$ you choose will have some set of prime factors $(p1, p2, ...)$. For each prime factor $p_i$, there are $x_i =\lfloor \frac{1000}{p_i} \rfloor$ numbers to consider which will have that common factor. If $n$ is chosen to be a prime itself, there are $\lfloor \frac{1000}{n} \rfloor - 1$ numbers greater than $n$ which will beat it, and it loses to any numbers less than itself, for a total of $$f(n)=n + \lfloor \frac{1000}{n} \rfloor - 2$$

Now if $n$ is composite, it loses to all of those numbers greater than it which share common factors

$$g(n)=\sum{\lfloor{\frac{1000}{p_i}}\rfloor} - \lfloor\frac{n}{p_i}\rfloor$$

as well as $\phi(n)$ numbers less than n which don't share common factors, with $\phi$ being Euler's totient function.

Clearly large primes fail, since $\phi(n) =n-1$ when n is prime. Likewise, small composite numbers fail, since $g(n)$ dominates there.

If we examine the formula for primes, we can see that it is minimized roughly when $n^2=1000$ by taking a derivative and solving. This curve monotonically decreases as it is dominated by $\lfloor\frac{1000}{n}\rfloor$ and monotonically increases as it is dominated by $n$. Thus only a few primes need to be tried to discover that $n=29$ and $n=31$ give the best prime solutions.

If any composite solution is going to out-perform a prime one, it must have a totient smaller than $f(31)=61$, at the very least, and as a result it cannot exceed $210$. Thus it must also have less than $61$ numbers between $210$ and $1000$ which it shares a factor with. $\lfloor(1000-210) / 61 \rfloor= 12$, so none of the factors can be less than $12$, but if there is more than one such factor, we would have a totient too large. Therefore there can be no composite solution better than the prime one.

Intuitively, you are just comparing the quadratic growth of the small prime choice to the $n/\log{n}$ growth of the large composite choice