# A Prime Pencil

Posted 1 month ago
2083 Views
|
18 Replies
|
56 Total Likes
|
 I just got a set of these pencils, from Mathsgear. The number printed on it is prime, and will remain so as you sharpen the pencil from the left, all the way down to the last digit, 7. Here is a recursive construction of all such truncatable primes. TruncatablePrimes[p_Integer?PrimeQ] := With[{digits = IntegerDigits[p]}, {p, TruncatablePrimes /@ (FromDigits /@ (Prepend[digits, #] & /@ Range[9]))} ]; TruncatablePrimes[p_Integer] := {} The one on the pencil is the largest one, In[7]:= Take[Sort[Flatten[TruncatablePrimes /@ Range[9]]], -5] Out[7]= { 9918918997653319693967, 57686312646216567629137, 95918918997653319693967, 96686312646216567629137, 357686312646216567629137} 
18 Replies
Sort By:
Posted 1 month ago
 - Congratulations! This post is now a Staff Pick as distinguished by a badge on your profile! Thank you, please keep it coming!
Posted 1 month ago
 Very Good - I particularly like the recursive routine you came up with.
Posted 1 month ago
 Dear Roman,thank you very much for that fantastic post. I'll definitely have to get one of those pencils from somewhere. There is of course the following on question which is: What happens if we use different bases for our number system, i.e. binary numbers etc. There is an obvious extension to all bases up to 10: TruncatablePrimesbasis[p_Integer, basis_Integer] := With[{digits = IntegerDigits[p]}, h = FromDigits[ToString[p], basis]; If[PrimeQ[h], {p, TruncatablePrimesbasis[#, basis] & /@ (FromDigits /@ (Prepend[digits, #] & /@ Range[basis - 1]))}, {}]]; We can then generate all such strings for any base (up to 10): generateAllStrings[basis_Integer] := DeleteDuplicates[SortBy[Flatten[TruncatablePrimesbasis[#, basis] & /@ (FromDigits /@ (List /@ Select[Range[basis - 1], PrimeQ]))], Length[IntegerDigits[#]] &]] The following generates the table for the first few bases. Transpose[Table[{k, generateAllStrings[k]}, {k, 2, 5}]] // Grid[#, Frame -> All] & Note that for the binary system there is no such pencil/sequence. That is basically because the first prime is already two digits long, i.e. 10, and if I delete the first of the two digits I am left with 0 which is not prime. It turns out that base 6 leads to a long list of strings (of course this contains all substrings of the same that are contained in longer strings), but basis 7 is surprisingly short: generateAllStrings[7] (*{2, 3, 5, 23, 25, 32, 43, 52, 65, 443, 452, 623, 625, 632, 652, 2452, \ 2623, 6625, 6652, 42623, 642623, 6642623}*) So, why did we stop at base 10. The issue is that for larger bases we need letters as digits. And we will probably need the function FromDigits that can transform an appropriate string into a number to any base up to 35 (which probably is because we then run out of letters in the alphabet). If we want to go to larger basis we have to work with strings rather than numbers. The updated program looks like this: digitrange = Join[CharacterRange["1", "9"], CharacterRange["a", "z"]]; TruncatablePrimes[p_String, basis_Integer] := With[{digits = Characters[p]}, h = FromDigits[p, basis]; If[PrimeQ[h], {p, TruncatablePrimes[ToString[#], basis] & /@ (StringJoin[#] & /@ (Flatten[Prepend[digits, #]] & /@ (List /@ digitrange[[1 ;; basis - 1]])))}, {}]]; generateAllStrings[basis_Integer] := DeleteDuplicates[SortBy[Flatten[TruncatablePrimes[#, basis] & /@ Flatten[(List /@ Select[digitrange[[1 ;; basis - 1]], PrimeQ[FromDigits[#, basis]] &])]], StringLength[#] &]] We can try this out like this: Here is the longest string for base 11: generateAllStrings[11][[-1]] which gives a68822827. FromDigits["a68822827", 11] shows that this is 2276005673 which is prime. (Try PrimeQ). We can now slice off one digit by one: Table[FromDigits[StringTake[#, -k], 11] & @"a68822827", {k, 9, 1, -1}] and get {2276005673, 132416863, 15493837, 1321349, 32941, 3659, 997, 29, 7} all of which are prime. It turns out that for some bases the strings are much longer than for others ( I haven't finished calculating for basis 18 for example!). Here is what we can do: Monitor[data = Table[{k, Length[#], StringLength[#[[-1]]], #[[-1]]} &@generateAllStrings[k], {k, 3, 17}], k] So we save the base, the total number of sequences, the longest string length (not necessarily a unique string), and the longest string. Here is the table:This shows the length of the longest sequence vs base:I will try to calculate the sequences for some larger bases. As I said 18 has not finished yet. 19 is fast and short. 20 seems to take long, too. In fact, I think that it might be possible to speed this program up quite a bit, which I might want to do first....Thanks a lot for this very nice post.Cheers,Marco
Posted 1 month ago
 I have now slightly updated the program and am running it on a multi core machine - I haven't actually tried to speed up the code in any intelligent way. On one multi-core machine I am defining as before: digitrange = Join[CharacterRange["1", "9"], CharacterRange["a", "z"]]; TruncatablePrimes[p_String, basis_Integer] := With[{digits = Characters[p]}, h = FromDigits[p, basis]; If[PrimeQ[h], {p, TruncatablePrimes[ToString[#], basis] & /@ (StringJoin[#] & /@ (Flatten[ Prepend[digits, #]] & /@ (List /@ digitrange[[1 ;; basis - 1]])))}, {}]]; generateAllStrings[basis_Integer] := DeleteDuplicates[ SortBy[ Flatten[ TruncatablePrimes[#, basis] & /@ Flatten[(List /@ Select[digitrange[[1 ;; basis - 1]], PrimeQ[FromDigits[#, basis]] &])]], StringLength[#] &]] I then create a data bin: CreateDatabin[] bin = Databin["zR0oyN8c"] I also set the permissions public so you should be able to access the databin. I then launch my kernels: LaunchKernels[] and execute results = {}; ParallelDo[ AppendTo[ results, {k, Length[#], StringLength[#[[-1]]], #[[-1]]} &@ generateAllStrings[k]]; DatabinAdd[bin, results];, {k, 3, 35}] From a second computer I can now check the progress: bin = Databin["zR0oyN8c"] results = SortBy[DeleteDuplicates[Flatten["Data" /. Normal[Get@bin], 1]], First]; Grid[results, Frame -> All] which givesI can now plot the length of the string vs the base: ListLinePlot[results[[All, {1, 3}]], PlotTheme -> "Marketing", FrameLabel -> {"base", "max length"}, LabelStyle -> Directive[Bold, 16], ImageSize -> Large] I will try to update this once I have some of the outstanding bases.Cheers,Marco
Posted 1 month ago
 Very nice to consider other bases.I haven't seen a discussion of primes that are truncatable from the right. There aren't too many of these shrinkable primes: Clear[ShrinkablePrimes]; ShrinkablePrimes[] := Sort[ShrinkablePrimes[Range[9]]]; ShrinkablePrimes[ps_List] := Join @@ (ShrinkablePrimes /@ ps); With[{appendDigits = Append /@ Range[9]}, ShrinkablePrimes[p_Integer?PrimeQ] := Prepend[ShrinkablePrimes[FromDigits /@ Through[appendDigits[IntegerDigits[p]]]], p] ]; ShrinkablePrimes[p_Integer] := {} What's nice is that now all single-digit primes get a chance to contribute: In[13]:= ShrinkablePrimes[] Out[13]= {2, 3, 5, 7, 23, 29, 31, 37, 53, 59, 71, 73, 79, 233, 239, 293, 311, 313, 317, 373, 379, 593, 599, 719, 733, 739, 797, 2333, 2339, 2393, 2399, 2939, 3119, 3137, 3733, 3739, 3793, 3797, 5939, 7193, 7331, 7333, 7393, 23333, 23339, 23399, 23993, 29399, 31193, 31379, 37337, 37339, 37397, 59393, 59399, 71933, 73331, 73939, 233993, 239933, 293999, 373379, 373393, 593933, 593993, 719333, 739391, 739393, 739397, 739399, 2339933, 2399333, 2939999, 3733799, 5939333, 7393913, 7393931, 7393933, 23399339, 29399999, 37337999, 59393339, 73939133} So the largest one is 73939133, which makes for a rather short pencil. Given the upcoming holiday season, one could consider printing it on the side of a prime candle.
Posted 1 month ago
 ...and here is the intersection of the two sets, so you can sharpen your pencil from either end: {2, 3, 5, 7, 23, 37, 53, 73, 313, 317, 373, 797, 3137, 3797, 739397} but you have to make up your mind: you cannot change directions once you start chipping away digits.
Posted 1 month ago
 Dear Roman,after programming this I came across this video. They discuss truncation from the left and the right, both sides, and numbers where you can delete digits in some order and always make it a prime. My computations are making some progress. Here is the current table: bin = Databin["zR0oyN8c"]; results = SortBy[DeleteDuplicates[Flatten["Data" /. Normal[Get@bin], 1]], First]; Grid[Join[{{"base", "# sequences", "max length", "string"}}, results],Frame -> All] So it has already cracked base 18, for which the sequence has length 43. Here is the graph: ListLinePlot[results[[All, {1, 3}]], PlotTheme -> "Marketing", FrameLabel -> {"basis", "max length"}, LabelStyle -> Directive[Bold, 16], ImageSize -> Large] This behaves basically like the logarithm of the total number of sequences: ListLogPlot[results[[All, {1, 2}]], PlotTheme -> "Marketing", FrameLabel -> {"basis", "number strings"}, LabelStyle -> Directive[Bold, 16], ImageSize -> Large, PlotRange -> All, Joined -> True] I am not sure if/when the full table will be done. The bases that are currently missing are: 24, 28, 30, 32 and 34. I am not very positive about the CPU times needed for the larger ones of those. Cheers,Marco
Posted 1 month ago
 Hi everyone,here is another update. My computer has been calculating for a couple of days now and here is what I've got: bin = Databin["zR0oyN8c"] results = SortBy[DeleteDuplicates[Flatten["Data" /. Normal[Get@bin], 1]], First] Grid[Join[{{"base", "# sequences", "max length", "string"}}, results],Frame -> All] As you can see only the bases 24 and 30 are missing. Here is a graph of the behaviour - with these two bases missing: ListLinePlot[results[[All, {1, 3}]], PlotTheme -> "Marketing", FrameLabel -> {"base", "max length"}, LabelStyle -> Directive[Bold, 16], ImageSize -> Large] and ListLogPlot[results[[All, {1, 2}]], PlotTheme -> "Marketing", FrameLabel -> {"base", "number strings"}, LabelStyle -> Directive[Bold, 16], ImageSize -> Large, PlotRange -> All, Joined -> True] There are several observations here. Here is a little diagram with highlights: ListLinePlot[results[[All, {1, 3}]], PlotTheme -> "Marketing", FrameLabel -> {"base", "max length"}, LabelStyle -> Directive[Bold, 16], ImageSize -> Large, PlotRange -> {All, {0, 75}}, Epilog -> {Red, Thickness[0.01], Line[{{0, 6}, {30, 73}}], Green, Line[{{0, 0}, {35, 21}}], White, Opacity[0.4], Rectangle[{12.5, 8}, {17.5, 28}], Rectangle[{18.5, 10}, {23.5, 40}], Rectangle[{24.5, 18}, {29.5, 48}], Rectangle[{30.5, 19}, {35.5, 53}]}] The green and red lines are to guide the eye and show estimates for lowest and highest values expected. The grey boxes indicate an M like structure. Left and right of which we expect particularly long sequences. The two values that are missing at 24 and 30 are exactly between two if these M like structures. So particularly high values occur at bases that are multiples of 6. If this type of linear interpolation was correct we might expect string lengths of 58-60 for base 24 and something close to length 70 for base 30. It appears that the CPU time needed increases roughly exponentially with the length of the sequence, so we might have to wait for quite a bit for results on these bases. Members of this Community have contacted me and have started to use more sophisticated methods to tackle these bases. I am convinced that they will beat me to it. I would love to see their results. Also, I think that we all use PrimeQ. This uses heuristics for large prime numbers. It might be necessary to check whether these results are actually correct. I have not found a list of left truncatable primes that has bases as large as the ones discussed here, so it is difficult to compare.Also, we might want to start implementing something to be able to compute this for bases larger than 35 and perhaps think about mathematical arguments for the multiples of 6 observation. One thought is that this behaves a bit like the number of divisors of the respective base.Cheers,Marco
Posted 1 month ago
 Ok. Now I found it - using Wolfram Alpha. I take the first couple of values (up to 23, because 24 is still missing. results[[1 ;; 21, {1, 3}]][[All, 2]] That list I plug into Wolfram Alpha: WolframAlpha["3, 6, 6, 17, 7, 15, 10, 24, 9, 32, 8, 26, 22, 25, 11, 43, 14, 37, 27, 37, 17"] In the last pod WolframAlpha["3, 6, 6, 17, 7, 15, 10, 24, 9, 32, 8, 26, 22, 25, 11, 43, 14, 37, 27, 37, 17", IncludePods -> "PossibleContinuationFromOEIS", AppearanceElements -> {"Pods"}] It identifies this sequence as OEIS A103463. Here is the respective website. The full list they give is: 0, 3, 6, 6, 17, 7, 15, 10, 24, 9, 32, 8, 26, 22, 25, 11, 43, 14, 37, 27, 37, 17, 53, 20, 39, 28, 46, 19 So apart from 24 which will only be 53 (so less than I anticipated), we were doing quite well. It also states: The next term (base 30) will be difficult to calculate because there are over a trillion left-truncatable primes in that base for each of digit-lengths 29-34. Nevertheless, the largest left-truncatable prime in this base can be estimated by theory to have a length of about 82. [Hans Havermann, Aug 16 2011] Here is the paper with some of the early theory.So, the real challenge is not (!) base 24, but rather base 30. Cheers,Marco
Posted 1 month ago
 Very interesting discussion, is there some limit for base 10? can you have -say- a 200 digit truncatable prime? @Marco Thiel I guess it is time to set up some distributed computing :)
Posted 1 month ago
 Hi Sander,no you cannot. In base 10 that is really the largest number. The scheme is such that it builds the primes up one step at a time; sometimes there are several digits that can be prepended and still give primes The algorithm follows all branches and interactively adds first digits. It turns out that after a finite number of steps all branches "die out", i.e. no other digit can be prepended. That has of course something to do with the fact that prime numbers get sparse as we go to larger integers. The range that can be "searched" increases in higher bases, but the prime number density decreases. It turns out that the latter always wins. In the range that we are discussing there are only two bases missing, base 24 and 30. It appears that we might be able to manage 24. Base 30 appears to more of a challenge. I have access to HPC facilities, but this algorithm needs huge speed improvements before it would make sense to attempt base 30. It would be kind of cool if one could crowd source CPU time for such a thing. I think that this could be done similarly to the SETI project. Imagine Wolfram would be offering a scheme to donate CPU time that can be used by other people. That has all sorts of technical and legal issues, but would be cool. Cheers,Marco
Posted 1 month ago
 Thanks for clarifying. Looks quite a nice project! not sure if this can be sped up a lot? Primality testing is—i guess—been highly optimized in Mathematica, so going to C or so would probably not help…What about right-truncatable primes? if you would print is 'upside down' and you 'eat' digits from the right?Quite a cute problem!
Posted 1 month ago
 The number of right-truncatable primes for bases up to 42 is given in A076586 in OEIS. Their number is quite a bit smaller than the right-truncatable ones.
Posted 1 month ago
 If we allow for leading zeros ( meaning e.g. 013 is essentially 13 ) TruncatablePrimes[p_Integer?PrimeQ] := With[{digits = IntegerDigits[p]}, {p, TruncatablePrimes /@ (FromDigits /@ (Prepend[digits, #] & /@ {1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 20, 30, 40, 50, 60, 70, 80, 90}))}]; TruncatablePrimes[p_Integer] := {} gives more interesting results. See TruncatablePrimes[3] // Flatten // Sort 
Posted 1 month ago
 Usually, leading zeros are not considered. As they say in the paper referenced above: It will be noted that we have excluded 0 as a leading digit. If we do not do this, the length of the longest left-truncatable prime becomes indeterminate since, for example, there are, with probability one, infinitely many primes of the form $10^k+3$. So leading zeros can lead to trivial cases dominating the picture.Best wishes,Marco
Posted 1 month ago
 I've parallelized my search code and reduced it to just searching for the largest truncatable prime, and count of all such primes. Actually generating all primes and storing them on the master kernel doesn't work for the larger cases. If the primes are desired, they could be written to disk as they are found (on the parallel subkernels) with little extra effort.I keep track of the total number of all truncatable primes, but more interesting is the number of maximal primes, those than cannot be extended any further. All the others are just truncations of these.For base 10, for example, there are a total of 4260 truncatable primes, but only 1442 of these are maximal.As the branching factor is rather low, the parallel search runs quite nicely, there is never a large pool of untested primes.Computing for base 24 on a 20 core machine took 7.6 hours. There are 379,588,962 maximal primes, and 1,052,029,701 in total; the largest one has 53 digits and is hmjejfa3a71did9mfmnfe3d3kjha61kh92ifca3lb8gf444fbb7ah. These numbers are confirmed by the published results.Here is a snapshot of the ongoing computation: The display updates dynamically every few seconds and shows the largest prime found so far, its number of digits, the running counts of maximal primes, total number of primes, number of kernels running, and the sizes of the global and local pools of untested primes. Synchronization between master and subkernels happens only every few seconds, where they exchange progress information and als send pool entries back and forth as needed. The last line shows the current rates of maximal and total primes produced, and the number of synchronizations per second.I caught the program just seconds before completion. The pools are running low and some workers are paused, waiting for more work to do. I am now tackling base 30. So far the largest prime found is "lfm6l77krkjmn6t9tt7j71h2iakp2ihh2csf179q5h91t3ohb4o1n2r4rflbndccjjbnsj" with 70 digits. The running total is around 2.4G primes.