Multi-base primes: Difference between revisions

First counting the bases that convert a decimal string of n into a prime number.<BR>

Afterwards only checking the maxcount for the used bases.<BR>

Most time consuming is sieving for the primes.

<lang pascal>program DecStringIsPrimeInBase;

//base 10 numeric string

{$IFDEF FPC}

{$MODE DELPHI}

{$OPTIMIZATION ON,ALL}

{$CodeAlign proc=32,loop=1}

{$ELSE}

{$APPTYPE CONSOLE}

{$ENDIF}

uses

sysutils;

const

MINBASE = 2;

MAXBASE = 36;

MAXFACPOT = 6;

MAXFAC = 10*10*10*10*10*10;

type

tChkLst = array of byte;

tSol = array of Uint32;

//sieve primes see http://rosettacode.org/wiki/Sieve_of_Eratosthenes#alternative_using_wheel

var

BoolPrimes: array of boolean;

ChkLst :tChkLst;

function popcnt64(n:Uint64):integer;

begin

result := 0;

repeat

result += ORD(n AND 1 <> 0);

n := n shr 1;

until n = 0;

end;

function BuildWheel(primeLimit:Int32):NativeUint;

var

myPrimes : pBoolean;

wheelprimes :array[0..31] of byte;

wheelSize,wpno,

pr,pw,i, k: NativeUint;

begin

myPrimes := @BoolPrimes[0];

pr := 1;

myPrimes[1]:= true;

WheelSize := 1;

wpno := 0;

repeat

inc(pr);

pw := pr;

if pw > wheelsize then

dec(pw,wheelsize);

If myPrimes[pw] then

begin

k := WheelSize+1;

for i := 1 to pr-1 do

begin

inc(k,WheelSize);

if k<primeLimit then

move(myPrimes[1],myPrimes[k-WheelSize],WheelSize)

else

begin

move(myPrimes[1],myPrimes[k-WheelSize],PrimeLimit-WheelSize*i);

break;

end;

end;

dec(k);

IF k > primeLimit then

k := primeLimit;

wheelPrimes[wpno] := pr;

myPrimes[pr] := false;

inc(wpno);

WheelSize := k;

i:= pr;

i := i*i;

while i <= k do

begin

myPrimes[i] := false;

inc(i,pr);

end;

end;

until WheelSize >= PrimeLimit;

while wpno > 0 do

begin

dec(wpno);

myPrimes[wheelPrimes[wpno]] := true;

end;

myPrimes[0] := false;

myPrimes[1] := false;

BuildWheel := pr+1;

writeln;

end;

procedure Sieve(PrimeLimit:Int32);

var

myPrimes : pBoolean;

sieveprime,

fakt : NativeUint;

begin

setlength(BoolPrimes,PrimeLimit+1);

myPrimes := @BoolPrimes[0];

sieveprime := BuildWheel(PrimeLimit);

repeat

if myPrimes[sieveprime] then

begin

fakt := PrimeLimit DIV sieveprime;

IF fakt < sieveprime then

BREAK;

repeat

myPrimes[sieveprime*fakt] := false;

repeat

dec(fakt);

until myPrimes[fakt];

until fakt < sieveprime;

end;

inc(sieveprime);

until false;

myPrimes[1] := false;

end;

function CnvtoBase(n,base:Uint32):Uint32;

//with test of digit >= base

var

q,r,fac: Uint32;

Begin

fac := 1;

result := 0;

repeat

q := n DIV 10;

r := (n-q*10);

if r >= base then

break;

result += fac*r;

fac *= base;

n := q;

until (n = 0);

if r >= base then

result := 0;

end;

function CnvtoBase11toMAXBASE(n,base:Uint32):Uint32;

var

q,r,fac: Uint32;

Begin

fac := 1;

result := 0;

repeat

q := n DIV 10;

r := (n-q*10);

result += fac*r;

fac *= Base;

n := q;

until n = 0;

end;

procedure ConvertToBases(n:Uint32);

var

base,r,Counter: Uint32;

begin

Counter := 0;

//base 10

if boolprimes[n] then

inc(Counter);

for base := MINBASE TO 9 do

Begin

r := CnvtoBase(n,base);

// if boolprimes[r] then inc(Counter);

inc(Counter,Ord(boolprimes[r]));

end;

for base := 11 TO MAXBASE do

Begin

r := CnvtoBase11toMAXBASE(n,base);

// if boolprimes[r] then inc(Counter);

inc(Counter,Ord(boolprimes[r]));

end;

chklst[n] := Counter;

end;

function GetMax(MinLmt,MaxLmt:Uint32):tSol;

var

i,pc,max,Idx: Int32;

Begin

setlength(result,10);

max :=-1;

Idx:= 0;

For i := MinLmt to MaxLmt do

Begin

pc := ChkLst[i];

if max<=pc then

begin

if max = pc then

begin

inc(Idx);

if Idx > High(result) then

setlength(result,Idx+10);

result[idx-1] := i;

end

else

begin

Idx:= 1;

result[Idx-1] := i;

max := pc;

end;

end;

end;

setlength(result,idx);

end;

procedure Out_Sol(sol:tSol);

var

sl : string[8];

s : AnsiString;

i,n,base,r,cnt: Uint32;

begin

if length(Sol) = 0 then

EXIT;

cnt := 0;

for i := 0 to High(Sol) do

begin

n := sol[i];

str(n:7,sl);

s := sl+' -> [';

For base := MINBASE to MAXBASE do

Begin

r := CnvtoBase(n,base);

if boolprimes[r] then

begin

inc(cnt);

str(base,sl);

s := s+sl+',';

end;

end;

s[length(s)] := ']';

if i = 0 then

writeln(cnt);

writeln(s);

end;

writeln;

setlength(Sol,0);

end;

var

T0 : Int64;

i,lmt,minLmt : Uint32;

begin

T0 := GetTickCount64;

lmt := 0;

//maxvalue of "99...99" in Maxbase

for i := 1 to MAXFACPOT do

lmt := (lmt*MAXBASE+9);

writeln('max prime limit ',lmt);

Sieve(lmt);

Setlength(ChkLst,MAXFAC);

writeln('Start ',(GetTickCount64-T0)/1000:6:3,' s');

For i := 2 to MAXFAC-1 do

ConvertToBases(i);

i := 1;

minLmt := 1;

repeat

write(i:2,' character strings which are prime in most bases: ');

Out_Sol(GetMax(minLmt,10*minLmt-1));

minLmt *= 10;

inc(i);

until minLmt >= MAXFAC;

{$IFDEF WINDOWS} readln; {$ENDIF}

end.</lang>

{{out}}

<pre>

TIO.RUN

max prime limit 559744029

Start 2.343 s

1 character strings which are prime in most bases: 34

2 -> [3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36]

2 character strings which are prime in most bases: 18

21 -> [3,5,6,8,9,11,14,15,18,20,21,23,26,29,30,33,35,36]

3 character strings which are prime in most bases: 18

131 -> [4,5,7,8,9,10,12,14,15,18,19,20,23,25,27,29,30,34]

551 -> [6,7,11,13,14,15,16,17,19,21,22,24,25,26,30,32,35,36]

737 -> [8,9,11,12,13,15,16,17,19,22,23,24,25,26,29,30,31,36]

4 character strings which are prime in most bases: 19

1727 -> [8,9,11,12,13,15,16,17,19,20,22,23,24,26,27,29,31,33,36]

5347 -> [8,9,10,11,12,13,16,18,19,22,24,25,26,30,31,32,33,34,36]

5 character strings which are prime in most bases: 18

30271 -> [8,10,12,13,16,17,18,20,21,23,24,25,31,32,33,34,35,36]

6 character strings which are prime in most bases: 18

441431 -> [5,8,9,11,12,14,16,17,19,21,22,23,26,28,30,31,32,33]

Real time: 3.047 s CPU share: 97.07 %

//Start 1.077 s real 0m1,364s at home</pre>