1:
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:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:

unit main;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;

type
  StrFeld = array of String;
  TForm1 = class(TForm)
    Memo1: TMemo;
    Button1: TButton;
    Button2: TButton;
    Label1: TLabel;
    ListBox1: TListBox;
    procedure Button2Click(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    function IstElement(zahl: integer):integer;
    function Permutationen(zk: String):StrFeld;
    function Fakultaet(zahl: integer):integer;
  private
    { Private-Deklarationen }
    procedure Loeschen(zahl: integer); overload;
    procedure Loeschen(feld: StrFeld); overload;
  public
    { Public-Deklarationen }
  end;

var
  Form1: TForm1;
  cprimes: array of integer;   // Feld für die circular Primes, [0] = Anzahl

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
 var
  max: integer;                     // Obergrenze
  i,j: integer;                     // Iteratoren
  eratosthenes: array of boolean;   // Feld für Primzahlsieb
  testzahlen: StrFeld;              // Feld für die Testzahlen
  als_zk: String;                   // Zwischenspeicher für als ZK gespeicherte Zahlen
begin
  max := 100;           // zu Testzwecken erstmal max = 100 (Ziel: 13 Stück)

  SetLength(eratosthenes,0);
  SetLength(testzahlen,0);
  SetLength(cprimes,0);

  // Schritt 1: alle Primzahlen im Bereich bis max ermitteln
  SetLength(eratosthenes, max+1);
  for i := 2 to max do eratosthenes[i] := true;

  // Primzahlsieb
  i := 2;
  repeat
    j := i;
    repeat
      j := j + i;
      eratosthenes[j] := false;
    until j>max;
    repeat
      i := i + 1;    // nächste Zahl wählen
    until eratosthenes[i] = true;
  until i*i>max;

  // gefundene Primzahlen in Feld cprimes übertragen
  SetLength(cprimes,101);            // erstmal 100 Plätze reservieren
  cprimes[0] := 0;

  for i := 2 to max do
   if eratosthenes[i] then
    begin // i ist eine Primzahl
      cprimes[0] := cprimes[0] + 1;
      if cprimes[0] >= length(cprimes) then SetLength(cprimes,Length(cprimes)+100);
      cprimes[cprimes[0]] := i;
    end;

   // jedes Element von cprimes durchgehen
   i := 1;
   repeat
     // alle mehrstelligen Zahlen löschen, die 2, 4, 5, 6, 8, 0 enthalten
     if cprimes[i]>9 then begin
       als_zk := IntToStr(cprimes[i]);
       if (pos('2',als_zk)>0) or
          (pos('4',als_zk)>0) or
          (pos('5',als_zk)>0) or
          (pos('6',als_zk)>0) or
          (pos('8',als_zk)>0) or
          (pos('0',als_zk)>0)
        then begin loeschen(cprimes[i]); i:= i-1; end;
     end;
     i := i + 1;
   until i = cprimes[0];

   // Speicherplatz von cprimes anpassen an reale Größe
   SetLength(cprimes,cprimes[0]+3);

   // jedes Element von cprimes durchgehen
   i := 1;
   repeat
     // alle Permutationen des Elementes ermitteln
     testzahlen := Permutationen(IntToStr(cprimes[i]));

     // führende Nullen entfernen
     for j := 0 to Length(testzahlen)-1 do
       testzahlen[j] := IntToStr(StrToInt(testzahlen[j]));

     // falls eine Permutation nicht im Feld enthalten, alle ggf. enthaltenen löschen
     for j := 0 to Length(testzahlen)-1 do
       if IstElement(StrToInt(testzahlen[j]))=-1 then
         begin
            Loeschen(testzahlen);
            Application.ProcessMessages;
            i := i - 1;
            break;
         end;

     i := i + 1;
   until i > cprimes[0];

   ListBox1.Items.Clear;
   for i := 1 to cprimes[0] do
     ListBox1.Items.Add(IntToStr(cprimes[i]));

   Label1.Caption := 'Im Bereich bis '+IntToStr(max)+' existieren '+IntToStr(cprimes[0])+' circular primes.';
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  close
end;

function TForm1.IstElement(zahl: integer):integer;
 var
  tmp: integer;   // Zwischenspeicher für Rückgabewert
  i: integer;     // Iterator
begin
  // Testet, ob zahl im Feld cprimes enthalten ist
  //  ja -> Rückgabewert entspricht Feldindex (des letzten Auftretens von zahl im Feld)
  //  nein --> Rückgabewert -1

  tmp := -1;

  for i := 1 to Length(cprimes)-1 do
    if cprimes[i]=zahl then tmp := i;

  IstElement := tmp;
end;

procedure TForm1.Loeschen(zahl: integer);
 var
  tmp: integer;     // Zwischenspeicher für Index
begin
  // zahl aus Feld cprimes löschen falls vorhanden
  tmp := IstElement(zahl);
  if tmp > -1 then
   begin
     // Zahl ist enthalten
     while tmp < Length(cprimes)-2 do
     begin
       cprimes[tmp] := cprimes[tmp+1];    // Element durch Nachfolger ersetzen
       tmp := tmp + 1;                    // tmp erhöhen
     end;
     cprimes[0] := cprimes[0]-1;     // Anzahl der cprimes um 1 verringern
   end;

end;

function TForm1.Permutationen(zk: String):StrFeld;
 var
  rueckgabe, tmp: StrFeld;
  i,j,anz: integer;
  wort: String;
begin
  // ermittelt rekursiv alle Zeichenpermutationen von zk (Mindestlänge 1)
  if length(zk)=1 then
   begin   // genau ein Zeichen
     SetLength(rueckgabe,1);
     rueckgabe[0] := zk;
   end else begin  // mehr als 1 Zeichen
     tmp := Permutationen(copy(zk,2,Length(zk)-1));  // Permutation ohne 1. Zeichen
     SetLength(rueckgabe,Fakultaet(Length(zk)));
     anz := 0;
     for i := 0 to Length(tmp)-1 do       // i als Iterator für Wörter in tmp
       for j := 1 to Length(zk) do        // j als Iterator für Zeichennummer
        begin
          wort := copy(tmp[i],1,j-1);     // Zeichen vor j-tem Zeichen kopieren
          wort := wort + zk[1];           // 1. Zeichen von zk als j-tes Zeichen
          wort := wort + copy(tmp[i],j,Length(tmp[i])); // Zeichen ab j-tem Zeichen kopieren
          rueckgabe[anz] := wort;
          anz := anz + 1;
        end;
   end;

  Permutationen := rueckgabe;
end;

function TForm1.Fakultaet(zahl: integer):integer;
 var
  rueckgabe,i: integer;
begin
  // berechnet Fakultät von zahl >= 0
  rueckgabe := 1;
  for i := 1 to zahl do rueckgabe := rueckgabe*i;

  Fakultaet := rueckgabe;
end;

procedure TForm1.Loeschen(feld: StrFeld);
 var
  i: integer;
begin
  for i := 0 to Length(feld)-1 do
     Loeschen(StrToInt(feld[i]));

end;

end.					

1:
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:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:

procedure TForm1.Button3Click(Sender: TObject);
var permutationen : tstringlist;
    zahl : array of boolean;
    maxx,i,j,s,m,anzahl : integer;
    unmoeglich:boolean;
    k:string;
begin
    maxx:=10000000;
    listbox1.Clear;

    //Primzahlsieb , Primzahlen im Feld zahl mit true
    setlength(zahl,maxx+1);
    for i:=1 to maxx do zahl[i]:=true;
    i:=2;
    repeat
      s:=i+i;
      while s<=maxx do begin
        zahl[s]:=false;
        s:=s+i;
      end;
      inc(i);
      while not zahl[i] do inc(i);
    until i>sqrt(maxx);

    //Hilfsliste für Permutationen, die Primzahl sind
    permutationen:=tstringlist.create;
    permutationen.sorted:=true;

    //Test ab zweistellig
    for i:=11 to maxx do begin
      //nur testen, wenn Zahl selbst Primzahl ist
      if zahl[i] then begin
        k:=inttostr(i);
        //alle Zahlen mit Ziffern o,2,4,5,6,8 ausschließen
        unmoeglich:=(pos('0',k)>0) or (pos('2',k)>0) or (pos('4',k)>0) or
                    (pos('5',k)>0) or (pos('6',k)>0) or (pos('8',k)>0);
        if not unmoeglich then begin
          permutationen.clear;
          anzahl:=0;
          //Test aller Permutationen
          for j:=1 to length(k) do begin
            k:=k[length(k)]+copy(k,1,length(k)-1);
            if zahl[strtoint(k)] then begin
              permutationen.Add(k);
              inc(anzahl);
            end;
          end;
          //nur wenn alle Permutationen Primzahlen sind
          if anzahl=length(k) then begin
            for j:=0 to permutationen.count-1 do begin
              k:=permutationen[j];
              //nur eintragen, wenn noch nicht in der Liste
              if listbox1.items.indexof(k)<0 then listbox1.Items.add(k);
            end;
          end;
        end;
      end;
    end;
    setlength(zahl,0);
    permutationen.free;
end;					

1:
2:
3:
4:
5:
6:
7:
8:
9:

          anzahl:=0;
          //Test aller Permutationen
          for j:=1 to length(k) do begin
            k:=k[length(k)]+copy(k,1,length(k)-1);
            if zahl[strtoint(k)] then begin
              permutationen.Add(k);
              inc(anzahl);
            end;
          end;					

1:
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:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:

{$IFDEF FPC}{$MODE Delphi}{$ELSE}{$APPTYPE CONSOLE}{$ENDIF}
uses
  sysutils;

const
  base = 4;
  maxDigits = base-1;
  cDigits : array[0..base-1] of NativeInt = (1,3,7,9);
  cMaxPr  = 1000*1000*1000;
type
  tDigits =array [0..2+3+3] of longInt;
  tprimes = array of boolean;
var
  Digits :tDigits;

//*********
//Sieb des Eratosthenes mal mit minimaler Anzahl an Streichungen aus 
//http://rosettacode.org/wiki/Sieve_of_Eratosthenes#alternative_using_wheel

function BuildWheel(var primes:tprimes;elemAnz:LongInt): longInt;
var
  //wheelprimes = 2,3,5,7,11... ;
  //wheelsize = product [i= 0..wpno-1]wheelprimes[i] > Uint64 i> 13
  wheelprimes :array[0..13] of byte;
  wheelSize,wpno,
  pr,pw,i, k: LongWord;
begin
  pr := 1;
  primes[1]:= true;
  WheelSize := 1;

  wpno := 0;
  repeat
    inc(pr);
    pw := pr;
    if pw > wheelsize then
      dec(pw,wheelsize);
    If Primes[pw] then
    begin
      k := WheelSize+1;
      for i := 1 to pr-1 do
      begin
        inc(k,WheelSize);
        if k<elemAnz then
          move(primes[1],primes[k-WheelSize],WheelSize)
        else
        begin
          move(primes[1],primes[k-WheelSize],elemAnz-WheelSize*i);
          break;
        end;
      end;
      dec(k);
      IF k > elemAnz then
        k := elemAnz;
      wheelPrimes[wpno] := pr;
      primes[pr] := false;

      inc(wpno);
      WheelSize := k;

      i:= pr;
      i := i*i;
      while i <= k do
      begin
        primes[i] := false;
        inc(i,pr);
      end;
    end;
  until WheelSize >= elemAnz;

  while wpno > 0 do
  begin
    dec(wpno);
    primes[wheelPrimes[wpno]] := true;
  end;
  BuildWheel  := pr+1;
end;

procedure InitPrimes(var primes:tprimes;elemAnz:LongInt);
var
  sieveprime,
  fakt : LongWord;
begin
  setlength(primes,elemAnz);
  sieveprime := BuildWheel(primes,elemAnz);
  repeat
    if primes[sieveprime] then
    begin
      fakt := elemAnz DIV sieveprime;
      IF fakt < sieveprime then
        BREAK;
      repeat
        primes[sieveprime*fakt] := false;
        repeat
          dec(fakt);
        until primes[fakt];
      until fakt < sieveprime;
    end;
    inc(sieveprime);
  until false;
  primes[1] := false;
end;
//*********

function circPrime(var pr:tprimes;nr:NativeInt;MaxIdx:NativeInt):boolean;
const
  PowerOf10 :array[0..9] of NativeInt =
              (1,10,100,
               1000,10*1000,100*1000,
               1000*1000,10*1000*1000,100*1000*1000,
               1000*1000*1000);
var
  i,r : NativeInt;

Begin
  dec(MaxIdx);
  i := MaxIdx;
  result := pr[nr];
  while result AND (i > 0) do
  Begin
     r := nr MOD 10;
     nr := nr div 10+r*PowerOf10[MaxIdx];
     dec(i);
     result := result AND pr[nr];
  end;
  //Falls es eine zirkulaere Primzahl ist, dann deren Varianten loeschen
  if result then
  begin
    i := MaxIdx;
    repeat
       pr[nr] := false;
       r := nr MOD 10;
       nr := nr div 10+r*PowerOf10[MaxIdx];
       write(nr:10);
       dec(i);
    until i <0;
    writeln;
  end;
end;

function NextNum(var Dgts:tDigits):boolean;
var
  i,d:NativeInt;
Begin
  i := 0;
  repeat
    d := Dgts[i];
    inc(d);
    iF d< base then
    Begin
      Dgts[i] := d;
      break;
    end;
    Dgts[i] := 0;
    inc(i);
  until i > High(Dgts);
  result := i <= High(Dgts);
end;

var
  i,nr,idx,maxIdx : LongInt;
  primes : array of boolean;
BEGIN
  InitPrimes(primes,cMaxPr);
  For i := Low(Digits) to High(Digits) do
    Digits[i] := -1;

  i := 0;
  maxIdx := 0;
  while NextNum(Digits) do
  Begin
    while (maxIdx <= High(Digits)) AND (Digits[maxIdx]>=0) do
      inc(maxIdx);
    idx := maxIdx-1;
    nr := 0;
    repeat
      nr := nr*10+cDigits[Digits[idx]];
      dec(idx)
    until idx < 0;
    CircPrime(primes,nr,MaxIdx);
  end;
  writeln(i);
END.					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:

sh-4.3# time ./CircPrime
         3
         7
        11        11
        13        31
        17        71
        37        73
        79        97
       113       311       131
       197       719       971
       199       919       991
       337       733       373
      1193      3119      9311      1931
      3779      9377      7937      7793
     11939     91193     39119     93911     19391
     19937     71993     37199     93719     99371
    193939    919393    391939    939193    393919    939391
    199933    319993    331999    933199    993319    999331
17

real  0m1.947s
user  0m1.893s
sys 0m0.050s