
MATHEMATICA

f[n_] := Block[{p = 2, q = n/2}, While[ !PrimeQ[p]  !PrimeQ[n  p], p++ ]; While[ !PrimeQ[q]  !PrimeQ[n  q], q ]; q  p]; t = Table[0, {10000}]; Do[a = f[2n]; If[a < 10000 && t[[a + 1]] == 0, t[[a + 1]] = 2n], {n, 2, 10^6}]; g = Flatten[ Position[t, 0]];
