Composite numbers k with no single digit factors whose factors are all substrings of k

Composite numbers k with no single digit factors whose factors are all substrings of k is a draft programming task. It is not yet considered ready to be promoted as a complete task, for reasons that should be found in its talk page.

Find the composite numbers k in base 10, that have no single digit prime factors and whose prime factors are all a substring of k.

Task

• Find and show here, on this page, the first ten elements of the sequence.

Stretch

• Find and show the next ten elements.

ALGOL 68

<lang algol68>BEGIN # find composite k with no single digit factors whose factors are all substrings of k #

   # returns TRUE if the string representation of f is a substring of k str, FALSE otherwise #
   PROC is substring = ( STRING k str, INT f )BOOL:
        BEGIN
           STRING f str   = whole( f, 0 );
           INT    f len   = ( UPB f str - LWB f str ) + 1;
           BOOL   result := FALSE;
           INT f end    := ( LWB k str + f len ) - 2;
           FOR f pos FROM LWB k str TO ( UPB k str + 1 ) - f len WHILE NOT result DO
               f end +:= 1;
               result := k str[ f pos : f end ] = f str
           OD;
           result
        END # is substring # ;
   # task #
   INT required numbers = 20;
   INT k count         := 0;
   # k must be odd and > 9 #
   FOR k FROM 11 BY 2 WHILE k count < required numbers DO
       IF k MOD 3 /= 0 AND k MOD 5 /= 0 AND k MOD 7 /= 0 THEN
           # no single digit odd prime factors #
           BOOL   is candidate := TRUE;
           STRING k str         = whole( k, 0 );
           INT    v            := k;
           INT    f count      := 0;
           FOR f FROM 11 BY 2 TO ENTIER sqrt( k ) + 1 WHILE v > 1 AND is candidate DO
               IF v MOD f = 0 THEN
                   # have a factor #
                   is candidate := is substring( k str, f );
                   IF is candidate THEN
                       # the digits of f ae a substring of v #
                       WHILE v OVERAB f;
                             f count +:= 1;
                             v MOD f = 0
                       DO SKIP OD
                   FI
               FI
           OD;
           IF is candidate AND ( f count > 1 OR ( v /= k AND v > 1 ) ) THEN
               # have a composite whose factors are up to the root are substrings #
               IF v > 1 THEN
                   # there was a factor > the root #
                   is candidate := is substring( k str, v )
               FI;
               IF is candidate THEN
                   print( ( " ", whole( k, -8 ) ) );
                   k count +:= 1;
                   IF k count MOD 10 = 0 THEN print( ( newline ) ) FI
               FI
           FI
       FI
   OD

END</lang>

Output:

    15317    59177    83731   119911   183347   192413  1819231  2111317  2237411  3129361
  5526173 11610313 13436683 13731373 13737841 13831103 15813251 17692313 19173071 28118827

Julia

<lang julia>using Lazy using Primes

function containsitsonlytwodigfactors(n)

   s = string(n)
   return !isprime(n) && all(t -> length(t) > 1 && contains(s, t), map(string, collect(keys(factor(n)))))

end

seq = @>> Lazy.range(2) filter(containsitsonlytwodigfactors)

foreach(p -> print(lpad(last(p), 9), first(p) == 10 ? "\n" : ""), enumerate(take(20, seq)))

</lang>

Output:

    15317    59177    83731   119911   183347   192413  1819231  2111317  2237411  3129361
  5526173 11610313 13436683 13731373 13737841 13831103 15813251 17692313 19173071 28118827

Pascal

Free Pascal

modified Factors_of_an_integer#using_Prime_decomposition <lang pascal>program FacOfInt; // gets factors of consecutive integers fast // limited to 1.2e11 {$IFDEF FPC}

 {$MODE DELPHI}  {$OPTIMIZATION ON,ALL}  {$COPERATORS ON}

{$ELSE}

 {$APPTYPE CONSOLE}

{$ENDIF} uses

 sysutils

{$IFDEF WINDOWS},Windows{$ENDIF}

 ;

//###################################################################### //prime decomposition const //HCN(86) > 1.2E11 = 128,501,493,120 count of divs = 4096 7 3 1 1 1 1 1 1 1

 HCN_DivCnt  = 4096;

type

 tItem     = Uint64;
 tDivisors = array [0..HCN_DivCnt] of tItem;
 tpDivisor = pUint64;

const

 //used odd size for test only
 SizePrDeFe = 32768;//*72 <= 64kb level I or 2 Mb ~ level 2 cache

type

 tdigits = array [0..31] of Uint32;
 //the first number with 11 different prime factors =
 //2*3*5*7*11*13*17*19*23*29*31 = 2E11
 //56 byte
 tprimeFac = packed record
                pfSumOfDivs,
                pfRemain  : Uint64;
                pfDivCnt  : Uint32;
                pfMaxIdx  : Uint32;
                pfpotPrimIdx : array[0..9] of word;
                pfpotMax  : array[0..11] of byte;
              end;
 tpPrimeFac = ^tprimeFac;

 tPrimeDecompField = array[0..SizePrDeFe-1] of tprimeFac;
 tPrimes = array[0..65535] of Uint32;

var

 {$ALIGN 8}
 SmallPrimes: tPrimes;
 {$ALIGN 32}
 PrimeDecompField :tPrimeDecompField;
 pdfIDX,pdfOfs: NativeInt;

procedure InitSmallPrimes; //get primes. #0..65535.Sieving only odd numbers const

 MAXLIMIT = (821641-1) shr 1;

var

 pr : array[0..MAXLIMIT] of byte;
 p,j,d,flipflop :NativeUInt;

Begin

 SmallPrimes[0] := 2;
 fillchar(pr[0],SizeOf(pr),#0);
 p := 0;
 repeat
   repeat
     p +=1
   until pr[p]= 0;
   j := (p+1)*p*2;
   if j>MAXLIMIT then
     BREAK;
   d := 2*p+1;
   repeat
     pr[j] := 1;
     j += d;
   until j>MAXLIMIT;
 until false;

 SmallPrimes[1] := 3;
 SmallPrimes[2] := 5;
 j := 3;
 d := 7;
 flipflop := (2+1)-1;//7+2*2,11+2*1,13,17,19,23
 p := 3;
 repeat
   if pr[p] = 0 then
   begin
     SmallPrimes[j] := d;
     inc(j);
   end;
   d += 2*flipflop;
   p+=flipflop;
   flipflop := 3-flipflop;
 until (p > MAXLIMIT) OR (j>High(SmallPrimes));

end;

function OutPots(pD:tpPrimeFac;n:NativeInt):Ansistring; var

 s: String[31];
 chk,p,i: NativeInt;

Begin

 str(n,s);
 result := s+': ';
 with pd^ do
 begin
   chk := 1;
   For n := 0 to pfMaxIdx-1 do
   Begin
     if n>0 then
       result += '*';
     p := SmallPrimes[pfpotPrimIdx[n]];
     chk *= p;
     str(p,s);
     result += s;
     i := pfpotMax[n];
     if i >1 then
     Begin
       str(pfpotMax[n],s);
       result += '^'+s;
       repeat
         chk *= p;
         dec(i);
       until i <= 1;
     end;

   end;
   p := pfRemain;
   If p >1 then
   Begin
     str(p,s);
     chk *= p;
     result += '*'+s;
   end;
 end;

end;

function CnvtoBASE(var dgt:tDigits;n:Uint64;base:NativeUint):NativeInt; //n must be multiple of base aka n mod base must be 0 var

 q,r: Uint64;
 i : NativeInt;

Begin

 fillchar(dgt,SizeOf(dgt),#0);
 i := 0;
 n := n div base;
 result := 0;
 repeat
   r := n;
   q := n div base;
   r  -= q*base;
   n := q;
   dgt[i] := r;
   inc(i);
 until (q = 0);
 //searching lowest pot in base
 result := 0;
 while (result<i) AND (dgt[result] = 0) do
   inc(result);
 inc(result);

end;

function IncByBaseInBase(var dgt:tDigits;base:NativeInt):NativeInt; var

 q :NativeInt;

Begin

 result := 0;
 q := dgt[result]+1;
 if q = base then
   repeat
     dgt[result] := 0;
     inc(result);
     q := dgt[result]+1;
   until q <> base;
 dgt[result] := q;
 result +=1;

end;

function SieveOneSieve(var pdf:tPrimeDecompField):boolean; var

 dgt:tDigits;
 i,j,k,pr,fac,n,MaxP : Uint64;

begin

 n := pdfOfs;
 if n+SizePrDeFe >= sqr(SmallPrimes[High(SmallPrimes)]) then
   EXIT(FALSE);
 //init
 for i := 0 to SizePrDeFe-1 do
 begin
   with pdf[i] do
   Begin
     pfDivCnt := 1;
     pfSumOfDivs := 1;
     pfRemain := n+i;
     pfMaxIdx := 0;
     pfpotPrimIdx[0] := 0;
     pfpotMax[0] := 0;
   end;
 end;
 //first factor 2. Make n+i even
 i := (pdfIdx+n) AND 1;
 IF (n = 0) AND (pdfIdx<2)  then
   i := 2;

 repeat
   with pdf[i] do
   begin
     j := BsfQWord(n+i);
     pfMaxIdx := 1;
     pfpotPrimIdx[0] := 0;
     pfpotMax[0] := j;
     pfRemain := (n+i) shr j;
     pfSumOfDivs := (Uint64(1) shl (j+1))-1;
     pfDivCnt := j+1;
   end;
   i += 2;
 until i >=SizePrDeFe;
 //i now index in SmallPrimes
 i := 0;
 maxP := trunc(sqrt(n+SizePrDeFe))+1;
 repeat
   //search next prime that is in bounds of sieve
   if n = 0 then
   begin
     repeat
       inc(i);
       pr := SmallPrimes[i];
       k := pr-n MOD pr;
       if k < SizePrDeFe then
         break;
     until pr > MaxP;
   end
   else
   begin
     repeat
       inc(i);
       pr := SmallPrimes[i];
       k := pr-n MOD pr;
       if (k = pr) AND (n>0) then
         k:= 0;
       if k < SizePrDeFe then
         break;
     until pr > MaxP;
   end;

   //no need to use higher primes
   if pr*pr > n+SizePrDeFe then
     BREAK;

   //j is power of prime
   j := CnvtoBASE(dgt,n+k,pr);
   repeat
     with pdf[k] do
     Begin
       pfpotPrimIdx[pfMaxIdx] := i;
       pfpotMax[pfMaxIdx] := j;
       pfDivCnt *= j+1;
       fac := pr;
       repeat
         pfRemain := pfRemain DIV pr;
         dec(j);
         fac *= pr;
       until j<= 0;
       pfSumOfDivs *= (fac-1)DIV(pr-1);
       inc(pfMaxIdx);
       k += pr;
       j := IncByBaseInBase(dgt,pr);
     end;
   until k >= SizePrDeFe;
 until false;

 //correct sum of & count of divisors
 for i := 0 to High(pdf) do
 Begin
   with pdf[i] do
   begin
     j := pfRemain;
     if j <> 1 then
     begin
       pfSumOFDivs *= (j+1);
       pfDivCnt *=2;
     end;
   end;
 end;
 result := true;

end;

function NextSieve:boolean; begin

 dec(pdfIDX,SizePrDeFe);
 inc(pdfOfs,SizePrDeFe);
 result := SieveOneSieve(PrimeDecompField);

end;

function GetNextPrimeDecomp:tpPrimeFac; begin

 if pdfIDX >= SizePrDeFe then
   if Not(NextSieve) then
     EXIT(NIL);
 result := @PrimeDecompField[pdfIDX];
 inc(pdfIDX);

end;

function Init_Sieve(n:NativeUint):boolean; //Init Sieve pdfIdx,pdfOfs are Global begin

 pdfIdx := n MOD SizePrDeFe;
 pdfOfs := n-pdfIdx;
 result := SieveOneSieve(PrimeDecompField);

end;

var

 s,pr : string[31];
 pPrimeDecomp :tpPrimeFac;

 T0:Int64;
 n,i : NativeUInt;
 checked : boolean;

Begin

 InitSmallPrimes;

 T0 := GetTickCount64;
 n := 0;
 Init_Sieve(0);
 repeat
   pPrimeDecomp:= GetNextPrimeDecomp;
   with pPrimeDecomp^ do
   begin
     //composite with smallest factor 11
     if (pfDivCnt>2) AND (pfpotPrimIdx[0]>3) then
     begin
       str(n,s);
       for i := 0 to pfMaxIdx-1 do
       begin
         str(smallprimes[pfpotPrimIdx[i]],pr);
         checked := (pos(pr,s)>0);
         if Not(checked) then
           Break;
       end;  
       if checked then
       begin
         if pfRemain >1 then
         begin
           str(pfRemain,pr);        
           checked := (pos(pr,s)>0);
         end;            
         if checked then
           writeln(OutPots(pPrimeDecomp,n));
       end;    
     end;     
   end;     
   inc(n);
 until n > 28118827;//1000*1000*1000+1;//
 T0 := GetTickCount64-T0;
 writeln('runtime ',T0/1000:0:3,' s');

end. </lang>

@TIO.RUN:

Real time: 2.166 s CPU share: 99.20 %//500*1000*1000 Real time: 38.895 s CPU share: 99.28 %

15317 :  6 : 17^2*53
59177 :  6 : 17*59^2
83731 :  8 : 31*37*73
119911 :  6 : 11^2*991
183347 :  6 : 47^2*83
192413 : 12 : 13*19^2*41
1819231 : 12 : 19*23^2*181
2111317 : 12 : 13^3*31^2
2237411 : 12 : 11^3*41^2
3129361 :  9 : 29^2*61^2
5526173 : 12 : 17*61*73^2
11610313 : 20 : 11^4*13*61
13436683 : 12 : 13^2*43^3
13731373 :  8 : 73*137*1373
13737841 : 12 : 13^5*37
13831103 : 12 : 11*13*311^2
15813251 :  4 : 251^3
17692313 :  4 : 23*769231
19173071 : 12 : 19^2*173*307
28118827 : 12 : 11^2*281*827
runtime 2.011 s
..@home limit 1E9 53^2*89xprime appears often
847253389   847253389 : 12 : 53^2*89*3389
889253557   889253557 : 12 : 53^2*89*3557
889753559   889753559 : 12 : 53^2*89*3559
892753571   892753571 : 12 : 53^2*89*3571
892961737   892961737 : 24 : 17^2*37^3*61
895253581   895253581 : 12 : 53^2*89*3581
895753583   895753583 : 12 : 53^2*89*3583
898253593   898253593 : 12 : 53^2*89*3593
972253889   972253889 : 12 : 53^2*89*3889
997253989   997253989 : 12 : 53^2*89*3989
runtime 45.922 s

Perl

Translation of: Raku

Library: ntheory

<lang perl> use strict; use warnings; use ntheory qw<is_prime factor gcd>;

my($values,$cnt); LOOP: for (my $k = 11; $k < 1E10; $k += 2) {

   next if 1 < gcd($k,2*3*5*7) or is_prime $k;
   map { next if index($k, $_) < 0 } factor $k;
   $values .= sprintf "%10d", $k;
   last LOOP if ++$cnt == 20;

} print $values =~ s/.{1,100}\K/\n/gr;</lang>

Output:

     15317     59177     83731    119911    183347    192413   1819231   2111317   2237411   3129361
   5526173  11610313  13436683  13731373  13737841  13831103  15813251  17692313  19173071  28118827

Phix

Translation of: Wren

with javascript_semantics
integer count = 0, n = 11*11,
        limit = iff(platform()=JS?10:20)
atom t0 = time(), t1 = time()
while count<limit do
    if gcd(n,3*5*7)=1 then
        sequence f = prime_factors(n,true,-1)
        if length(f)>1 then
            string s = sprintf("%d",n)
            bool valid = true
            for i=1 to length(f) do
                if (i=1 or f[i]!=f[i-1])
                and not match(sprintf("%d",f[i]),s) then
                    valid = false
                    exit
                end if
            end for
            if valid then
                count += 1
                string t = join(apply(f,sprint),"x"),
                       e = elapsed(time()-t1)
                printf(1,"%2d: %,10d = %-17s (%s)\n",{count,n,t,e})
                t1 = time()
            end if
        end if
    end if
    n += 2
end while
printf(1,"Total time:%s\n",{elapsed(time()-t0)})

Output:

(As usual, limiting to the first 10 under pwa/p2js keeps the time staring at a blank screen under 10s)

 1:     15,317 = 17x17x53          (0s)
 2:     59,177 = 17x59x59          (0.1s)
 3:     83,731 = 31x37x73          (0.0s)
 4:    119,911 = 11x11x991         (0.0s)
 5:    183,347 = 47x47x83          (0.1s)
 6:    192,413 = 13x19x19x41       (0.0s)
 7:  1,819,231 = 19x23x23x181      (3.5s)
 8:  2,111,317 = 13x13x13x31x31    (0.7s)
 9:  2,237,411 = 11x11x11x41x41    (0.4s)
10:  3,129,361 = 29x29x61x61       (2.6s)
11:  5,526,173 = 17x61x73x73       (7.5s)
12: 11,610,313 = 11x11x11x11x13x61 (23.2s)
13: 13,436,683 = 13x13x43x43x43    (7.9s)
14: 13,731,373 = 73x137x1373       (1.3s)
15: 13,737,841 = 13x13x13x13x13x37 (0.0s)
16: 13,831,103 = 11x13x311x311     (0.4s)
17: 15,813,251 = 251x251x251       (8.9s)
18: 17,692,313 = 23x769231         (9.0s)
19: 19,173,071 = 19x19x173x307     (7.1s)
20: 28,118,827 = 11x11x281x827     (46.2s)
Total time:1 minute and 59s

Raku

<lang perl6>use Prime::Factor; use Lingua::EN::Numbers;

put (2..∞).hyper(:5000batch).map( {

   next if (1 < $_ gcd 210) || .is-prime || any .&prime-factors.map: -> $n { !.contains: $n };
   $_

} )[^20].batch(10)».&comma».fmt("%10s").join: "\n";</lang>

Output:

    15,317     59,177     83,731    119,911    183,347    192,413  1,819,231  2,111,317  2,237,411  3,129,361
 5,526,173 11,610,313 13,436,683 13,731,373 13,737,841 13,831,103 15,813,251 17,692,313 19,173,071 28,118,827

Wren

Library: Wren-math

Library: Wren-seq

Library: Wren-fmt

<lang ecmascript>import "/math" for Int import "/seq" for Lst import "/fmt" for Fmt

var count = 0 var k = 11 * 11 var res = [] while (count < 20) {

   if (k % 3 == 0 || k % 5 == 0 || k % 7 == 0) {
       k = k + 2
       continue
   }
   var factors = Int.primeFactors(k)
   if (factors.count > 1) {
       Lst.prune(factors)
       var s = k.toString
       var includesAll = true
       for (f in factors) {
           if (s.indexOf(f.toString) == -1) {
               includesAll = false
               break
           }
       }
       if (includesAll) {
           res.add(k)
           count = count + 1
       }
   }
   k = k + 2

} Fmt.print("$,10d", res[0..9]) Fmt.print("$,10d", res[10..19])</lang>

Output:

    15,317     59,177     83,731    119,911    183,347    192,413  1,819,231  2,111,317  2,237,411  3,129,361
 5,526,173 11,610,313 13,436,683 13,731,373 13,737,841 13,831,103 15,813,251 17,692,313 19,173,071 28,118,827