The prime sequence starts:
s = { 11, 41, 61, 83, 113, 101, 151, 181, 233, 223, 263,
293, 353, 383, 419, 401, 479, 467, 541, 1009, 599, 631,
661, 691, 727, 751, 787, 797, 809, 877, 907, 919, 967,
991, 9001, 1031}.
The digit-decomposed list starts:
t = {1, 1, 4, 1, 6, 1, 8, 3, 1, 1, 3, 1, 0, 1, 1, 5, 1, 1, 8, 1, 2, 3,
3, 2, 2, 3, 2, 6, 3, 2, 9, 3, 3, 5, 3, 3, 8, 3, 4, 1, 9, 4, 0, 1,
4, 7, 9, 4, 6, 7, 5, 4, 1, 1, 0, 0, 9, 5, 9, 9, 6, 3, 1, 6, 6, 1,
6, 9, 1, 7, 2, 7, 7, 5, 1, 7, 8, 7, 7, 9, 7, 8, 0, 9, 8, 7, 7, 9,
0, 7, 9, 1, 9, 9, 6, 7, 9, 9, 1, 9, 0, 0, 1, 1, 0, 3, 1}.
The initial $11$ in $s$ is given. Thereafter, each new term must be the smallest possible prime not already used.
In other words, we want 11 to say: "In position 1 is a 1," 41 to say: "In position 4 is a 1," 61 to say: "In position 6 is a 1," 83 to say: "In position 8 is a 3," 113 to say: "In position 11 is a 3," 101 to say: "In position 10 is a 1," and so on. All of our statements must be truthful.
As per the $s$ and $t$ above, one may verify that the following yields all True
:
Table[
Floor[s[[i]] / 10] > Length[t] || t[[ Floor[s[[i]] / 10] ]] == Mod[s[[i]], 10],
{i, Length[s]}
]
Some of our primes (in the above example 9001) may refer to future positions which we have yet to calculate, which is why I had to Or
the Floor[s[[i]] / 10] > Length[t]
in the code. The existence of closely-spaced future digits leads to situations where, potentially, very large primes are required to comply with all of our demands.
For example, term #1446 is 190901, taking up positions 7006-7011. Positions 7012-7020 and 7022-7024 are already assigned with digits: 191737191?371. That would make term #1447 19173719153.
For the background origin of this challenge, see here. I've struggled with some very inefficient code to generate a few thousand terms over the course of many days. I'm hoping someone can do better.
I will add here my just revamped code to show that even I can kludge together a working program that is significantly faster than my original attempt. Unfortunately it introduces seemingly arbitrary parameters that — although they speed up the calculation — are grounded in poorly understood (by me) logical concepts underlying the sequence:
s = {11}; t = {1, 1}; u = {t}; v = {1}; p = 13; While[Length[s] < 101,
While[f = Floor[p/10]; m = Mod[p, 10]; w = Join[t, IntegerDigits[p]];
a = Length[t] - 32; b = Length[w]; c = Select[v, a < # <= b &];
If[c != {},
q = Table[
w[[v[[k]]]] == u[[k]][[-1]], {k, Position[v, c[[1]]][[1, 1]],
Position[v, c[[-1]]][[1, 1]]}]];
MemberQ[v, f] || (f <= Length[w] && w[[f]] != m) || Union[q] != {True},
p = NextPrime[p]]; AppendTo[s, p]; t = w; u = Union[u, {{f, m}}];
v = Union[v, {f}]; p = Max[13, NextPrime[9*a]]]; s
Additionally, the program will not intelligently handle the occurrence of the very large primes that appear at #1447 and #3868.