I'm going to call a prime that only consists of moslty 0's and few 1's a sparse prime. Here's some code to find even larger sparse primes. It runs surprisingly quickly.
(*Searches for a prime that matches the first digits of n and remaining digits 0 or 1.*)
sparsePrimeWithSeed[n_Integer] :=
Block[{k = 1, p, remainder},
p = NextPrime[10 n];
Monitor[
While[Quotient[p, 10^k] != n || !MatchQ[IntegerDigits[Mod[p, 10^(k + 1)]], {(0 | 1) ..}],
remainder = Mod[p, 10^(k + 1)];
p = NextPrime[10^(++k)*n]
],
remainder];
p
]
We can now look for primes whose first digits match Todd's prime and remaining digits are all 0 or 1.
In[2]:= sparsePrimeWithSeed[1 + 10^4 + 10^18 + 10^201]
Out[2]= 1000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001000000000000010001000000000001
Or we can nest this function to get even larger sparse primes.
In[3]:= Nest[sparsePrimeWithSeed, 1 + 10^4 + 10^18 + 10^201, 5]
Out[3]= 1000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001000000000000010001000000000001000000000011100000000000000110100000000000000010100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001111
It turns out all primes seeded by Todd's prime aren't as sparse as the original. Here's a plot of the sparsity of succesive primes generated with the above code.
(* sparsity is number of 1's divided by integer length *)
ListLinePlot[
N[Total[IntegerDigits[#]]/IntegerLength[#]] & /@ NestList[sparsePrimeWithSeed, 1 + 10^4 + 10^18 + 10^201, 6],
PlotRange -> {0, .05}]
