Prime numbers are prime no matter what base they are represented in.

A prime number in a base other than 10 may not look prime at first glance.

For instance: 19 base 10 is 25 in base 7.



Several different prime numbers may be expressed as the "same" string when converted to a different base.

 107 base 10 converted to base 6 == 255
 173 base 10 converted to base 8 == 255
 353 base 10 converted to base 12 == 255
 467 base 10 converted to base 14 == 255
 743 base 10 converted to base 18 == 255
 1277 base 10 converted to base 24 == 255
 1487 base 10 converted to base 26 == 255
 2213 base 10 converted to base 32 == 255


Task
Restricted to bases 2 through 36; find the strings that have the most different bases that evaluate to that string when converting prime numbers to a base.

Find the conversion string, the amount of bases that evaluate a prime to that string and the enumeration of bases that evaluate a prime to that string.

Display here, on this page, the string, the count and the list for all of the: 1 character, 2 character, 3 character, and 4 character strings that have the maximum base count that evaluate to that string.

Should be no surprise, the string '2' has the largest base count for single character strings.



Stretch goal
Do the same for the maximum 5 character string.



program MAXBaseStringIsPrimeInBase;
{$IFDEF FPC}
  {$MODE DELPHI}
  {$OPTIMIZATION ON,ALL}
{$ELSE}
  {$APPTYPE CONSOLE}
{$ENDIF}
uses
  sysutils;
const
  CharOfBase= '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz';
  MINBASE = 2;
  MAXBASE = 62;//36;//62;
  MAXDIGITCOUNT = 5;//6;
type
  tdigits    = packed record
                 dgtDgts : array [0..13] of byte;
                 dgtMaxIdx,
                 dgtMaxDgtVal :byte;
                 dgtNum  : Uint64; 
               end;                  
  tSol       = array of Uint64;
var
  BoolPrimes: array  of boolean;
 
function BuildWheel(primeLimit:Int64):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;
end;
 
procedure Sieve(PrimeLimit:Uint64);
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;
 
procedure CnvtoBASE(var dgt:tDigits;n:Uint64;base:NativeUint);
var
  q,r: Uint64;
  i : Int32;
Begin
  i := 0;
  with dgt do
  Begin
    fillchar(dgtDgts,SizeOf(dgtDgts),#0);  
    dgtNum:= n;
    repeat
      r := n;
      q := n div base;
      r  -= q*base;
      n := q;
      dgtDgts[i] := r;    
      inc(i);
    until (q = 0);
    dec(i);
    dgtMaxIdx := i;
 
    r := 1;
    repeat
      q := dgtDgts[i];
      if r < q then
        r := q;
      dec(i);
    until i <0 ;     
    dgtMaxDgtVal := r;
  end;  
end;
 
function CnvDgtAsInBase(const dgt:tDigits;base:NativeUint):Uint64;
var
  tmpDgt,i: NativeInt;
Begin
  result := 0;
  with dgt do
  Begin
    i:= dgtMaxIdx;
    repeat
      tmpDgt := dgtDgts[i];
      result *= base;
      dec(i);
      result +=tmpDgt;
    until (i< 0);
  end;  
end;
 
procedure IncInBaseDigits(var dgt:tDigits;base:NativeInt);
var
  i,q,tmp :NativeInt;
Begin
  with dgt do
  Begin
    tmp := dgtMaxIdx;          
    i := 0;    
    repeat
      q := dgtDgts[i]+1;
      q -= (-ORD(q >=base) AND base);
      dgtDgts[i] := q;
      inc(i);        
    until q <> 0;
    dec(i);  
    if tmp < i then
    begin
      tmp := i;  
      dgtMaxIdx := i;
    end;  
    i := tmp;  
    repeat
      tmp := dgtDgts[i];
      if q< tmp then
        q := tmp;
      dec(i);
    until i <0;     
    inc(dgtNum);
    dgtMaxDgtVal := q;
  end;  
end;  
 
function CntPrimeInBases(var Digits :tdigits;max:Int32):Uint32;
var
  pr : Uint64;
  base: Uint32;
begin
  result := 0;
  IncInBaseDigits(Digits,MAXBASE); 
  base := Digits.dgtMaxDgtVal+1;
  //divisible by every base
  IF Digits.dgtDgts[0] = 0 then
    EXIT;  
  IF base < MINBASE then  base := MINBASE;    
// if (MAXBASE - Base) <= (max-result)  then  BREAK;
  max := (max+Base-MAXBASE);
  if (max>=0) then
    EXIT;
  for base := base TO MAXBASE do
  begin
    pr := CnvDgtAsInBase(Digits,base);
    inc(result,Ord(boolprimes[pr]));
    //no chance to reach max then exit
    if result<max then 
      break;
    inc(max);  
  end;       
end;
 
function GetMaxBaseCnt(var dgt:tDigits;MinLmt,MaxLmt:Uint32):tSol;
var
  i : Uint32;
  baseCnt,max,Idx: Int32;
Begin
  setlength(result,0);
  max :=-1;
  Idx:= 0;
  For i := MinLmt to MaxLmt do
  Begin
    baseCnt := CntPrimeInBases(dgt,max);
    if baseCnt = 0 then
      continue;
    if max<=baseCnt then
    begin
      if max = baseCnt then
      begin
        inc(Idx);
        if Idx > High(result) then
          setlength(result,Idx);
        result[idx-1] := i;
      end
      else
      begin
        Idx:= 1;
        setlength(result,1);
        result[0] := i;
        max := baseCnt;
      end;
    end;
  end;
end;
 
function Out_String(n:Uint64;var s: AnsiString):Uint32;
//out-sourced for debugging purpose
var
  dgt:tDigits;
  sl : string[15];
  base,i: Int32;
Begin
  result := 0;
  CnvtoBASE(dgt,n,MaxBase);  
  sl := '';
  with dgt do
  begin
    base:= dgtMaxDgtVal+1;
    IF base < MINBASE then
      base := MINBASE;    
    i := dgtMaxIdx;  
    while (i>=0)do
    Begin
      sl += CharOfBase[dgtDgts[i]+1];
      dec(i);
    end;
    s := sl+' -> [';
  end;
  For base := base to MAXBASE do
    if boolprimes[CnvDgtAsInBase(dgt,base)] then
    begin
      inc(result);
      str(base,sl);
      s := s+sl+',';
    end;
  s[length(s)] := ']';
end;
 
procedure Out_Sol(sol:tSol);
var
  s : AnsiString;
  i,cnt : Int32;
begin
  if length(Sol) = 0 then
    EXIT;
  for i := 0 to High(Sol) do
  begin
    cnt := Out_String(sol[i],s);
    if i = 0 then
      writeln(cnt);
    writeln(s);
  end;
  writeln;
  setlength(Sol,0);
end;
 
var
  dgt:tDigits;
  T0 : Int64;
  i : NativeInt;  
  lmt,minLmt : UInt64;
begin
  T0 := GetTickCount64;
  lmt := 0;
  //maxvalue in Maxbase
  for i := 1 to MAXDIGITCOUNT do
    lmt :=lmt*MAXBASE+MAXBASE-1;
  writeln('max prime limit ',lmt); 
  Sieve(lmt);
  writeln('Prime sieving ',(GetTickCount64-T0)/1000:6:3,' s');
 
  T0 := GetTickCount64;
  CnvtoBASE(dgt,0,MAXBASE);
  i := 1;
  minLmt := 1;
  repeat
    write(i:2,' character strings which are prime in count bases = ');
    Out_Sol(GetMaxBaseCnt(dgt,minLmt,MAXBASE*minLmt-1));
    minLmt *= MAXBASE;
    inc(i);
  until i>MAXDIGITCOUNT;
  writeln('   Converting ',(GetTickCount64-T0)/1000:6:3,' s');
  {$IFDEF WINDOWS} readln; {$ENDIF}
end.