(* On a Power Mac, this Mathematica program takes about 40 minutes *)
nn = PrimePi[8191];
t1 = {2};
t5 = {31, 1801};
t7 = {127};
t13 = {8191}; found = Union[t1, t5, t7, t13]; t2 = {};
Do[ps = Position[(2^Range[k/2] + 1)/k, _?(IntegerQ[#] &), 1, 1];
If[ps != {}, AppendTo[found, k]; AppendTo[t2, {k, ps[[1, 1]]}]], {k,
Prime[Range[2, nn]]}]; Length[found]
t3 = {};
Do[Do[If[! MemberQ[found, k],
ps = Position[(2^j + 2^Range[j - 1] + 1)/k, _?(IntegerQ[#] &), 1, 1];
If[ps != {}, AppendTo[found, k];
AppendTo[t3, {k, j, ps[[1, 1]]}]; Break[]]], {j, 2, k/3}], {k,
Prime[Range[2, nn]]}]; Length[found]
t4 = {};
Do[Do[If[! MemberQ[found, k],
ps = Position[(2^j + 2^i + 2^Range[i - 1] + 1)/k, _?(IntegerQ[#] &), 1, 1];
If[ps != {}, AppendTo[found, k];
AppendTo[t4, {k, j, i, ps[[1, 1]]}]; Break[]]], {j, 3, k/10}, {i, 2, j}],
{k, Prime[Range[2, nn]]}]; Length[found]
x1 = {Append[t1, 1]};
x2 = Transpose[t2][[1]]; x2 = Transpose[{x2, Table[2, {Length[x2]}]}];
x3 = Transpose[t3][[1]]; x3 = Transpose[{x3, Table[3, {Length[x3]}]}];
x4 = Transpose[t4][[1]]; x4 = Transpose[{x4, Table[4, {Length[x4]}]}];
x5 = Transpose[{t5, Table[5, {Length[t5]}]}];
x7 = {Append[t7, 7]};
x13 = {Append[t13, 13]};
seq = Sort[Join[x1, x2, x3, x4, x5, x7, x13]];
t = Transpose[seq][[2]];