Building Truncatable Primes using Nest(List), While, Fold

Question

Here is a video on Truncatable Primes. I tried to build it myself. Here is what I have tried using the method in the video for left Truncatable Primes.

myNextList[n_] := Select[10^(Length[IntegerDigits[n]])*Range[9] + n, PrimeQ];
SetAttributes[myNextList, Listable];

So a bit of testing:

myNextList[91]

{191, 491, 691, 991}

myNextList[3947]

{}

and

myNextList[{13, 23, 43, 53, 73, 83}]

{{113, 313, 613}, {223, 523, 823}, {443, 643, 743}, {353, 653, 853, 953}, {173, 373, 673, 773}, {283, 383, 683, 883, 983}}

Now the goal is to repeate the proccess until we get none of them returns a prime. So I tried

NestWhileList[myNextList, 7, AllTrue[#, PrimeQ] &]
NestWhile[myNextList, 7, AllTrue[#, PrimeQ] &]

{{317, 617}, {137, 337, 937}, {347, 547, 647, 947}, {167, 367, 467, 967}, {197, 397, 797, 997}}

which should be continued ...

myNextList[%]

{{{6317, 8317}, {2617, 3617}}, {{2137, 3137, 9137}, {4337, 6337, 9337}, {4937, 7937}}, {{2347, 3347, 5347}, {3547, 4547, 6547, 7547, 9547}, ...

I think it's an easy fix, with the test part, which I have used AllTrue[#, PrimeQ] &. But I don't know how to fix it.

If I just use

Nest[myNextList, 1, 8]
Nest[myNextList, 7, 8]
Nest[myNextList, 7, 16]

for example, it all worked fine. But I want to repeat something from the video and find all 1422 end points (as stated in the video at 04:49)

Answer 1

NestGraph seems like a good choice:

ClearAll[myNextList]
myNextList[0] := {2, 3, 5, 7}
myNextList[n_] := Select[10^(Length[IntegerDigits[n]])*Range[9] + n, PrimeQ];


g = NestGraph[myNextList, 0, 10^3];
leaves = Pick[VertexList[g], VertexOutDegree[g], 0];
leaves // Length

1442

Max[leaves]

357686312646216567629137

Answer 2

Update 2: An alternative approach using FixedPoint

ClearAll[g0, g1, nextDigit]

nextDigit[a__] := Select[Range[9], PrimeQ[FromDigits[{#, a}]] &] /. {} -> {0};

g0[{0, a__}] := {{0, a}}

g0[{0}] := List /@ {2, 3, 5, 7}

g0[{a__}] := {#, a} & /@ nextDigit[a]

g1 = Join @@ g0 /@ # &;

ltprimes3 = FromDigits /@ 
   DeleteCases[SplitBy[Join @@ FixedPoint[g1, {{0}}], # == 0 &], {0}];

Length @ ltprimes3
1442

Max @ ltprimes3

357686312646216567629137

Sort @ ltprimes3 == Sort @ ltprimes2

True

Update: To get the list of 1442 primes

ClearAll[myNextList2, f0, f1]
myNextList2[n_] := Select[10^(Length[IntegerDigits[n]])*Range[9] + n, PrimeQ] /. {} -> {""};
myNextList2[0] = {2, 3, 5, 7};
myNextList2[""] = Sequence[];

f0[Except[_List]] := Sequence[]
f0[{a___, ""}] := {a, ""}
f0[{a___, b_}] := {a, b, #} & /@ myNextList2[b]

f1 = Join @@ f0 /@ # &;

ltprimes2 = Cases[Join @@ FixedPointList[f1, {{0}}],  {0, ___, x_, ""} :> x];

ltprimes2 // Sort // Short

{2, 5, 773, <<1436>>, 95918918997653319693967, 96686312646216567629137, 357686312646216567629137}

Max @ ltprimes2

357686312646216567629137

Length @ ltprimes2

1442

Original answer:

You can use FixedPointList:

ltprimes = Join @@ FixedPointList[Composition[Flatten, myNextList], {2, 3, 5, 7}];

Length @ ltprimes

4260

Last @ ltprimes

357686312646216567629137

IntegerLength @ Last @ ltprimes

24

Count[FixedPoint[myNextList, {2, 3, 5, 7}], {}, {0, Infinity}]

1442