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

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)

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

• maybe if we add myNextList[0]={2,3,5,7}; and start the nesting from 0 (that is, g = NestGraph[myNextList,0,10^3]), then leaves // Length gives 1442. (+1 of course)
– kglr
Sep 14, 2019 at 8:51
• @kglr Yup, that did it. Thank you! Sep 14, 2019 at 15:08
• Related post on the Wolfram Community site. Sep 14, 2019 at 17:19
• @RohitNamjoshi Thanks. Sep 15, 2019 at 0:09

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

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

• Seemed like my initial code myNextList isn't good after all as it can not get the whole list of 1442 numbers. I thought about using FixedPointList but then got a bit confused. Thanks. Sep 14, 2019 at 15:44