Data commit

Task/Arithmetic-numbers/Free-Pascal/arithmetic-numbers-1.pas

@@ -0,0 +1,144 @@
+program ArithmeticNumbers;
+{$OPTIMIZATION ON,ALL}
+type
+  tPrimeFact = packed record
+                 pfSumOfDivs,
+                 pfRemain  : Uint64;
+                 pfDivCnt  : Uint32;
+                 pfMaxIdx  : Uint32;
+                 pfpotPrimIdx : array[0..9] of word;
+                 pfpotMax  : array[0..11] of byte;//11 instead of 9 for alignment
+               end;
+var
+  SmallPrimes : array[0..6541] of word;
+
+procedure InitSmallPrimes;
+var
+  testPrime,j,p,idx:Uint32;
+begin
+  SmallPrimes[0] := 2;
+  SmallPrimes[1] := 3;
+  idx := 1;
+  testPrime := 5;
+  repeat
+    For j := 1 to idx do
+    begin
+      p := SmallPrimes[j];
+      if p*p>testPrime then
+        BREAK;
+      if testPrime mod p = 0 then
+      Begin
+        p := 0;
+        BREAK;
+      end;
+    end;
+    if p <> 0 then
+    begin
+      inc(idx);
+      SmallPrimes[idx]:= testPrime;
+    end;
+    inc(testPrime,2);
+  until testPrime >= 65535;
+end;
+
+procedure smplPrimeDecomp(var PrimeFact:tPrimeFact;n:Uint32);
+var
+  pr,i,pot,fac,q :NativeUInt;
+Begin
+  with PrimeFact do
+  Begin
+    pfDivCnt := 1;
+    pfSumOfDivs := 1;
+    pfRemain := n;
+    pfMaxIdx := 0;
+    pfpotPrimIdx[0] := 1;
+    pfpotMax[0] := 0;
+
+    i := 0;
+    while i < High(SmallPrimes) do
+    begin
+      pr := SmallPrimes[i];
+      q := n DIV pr;
+      //if n < pr*pr
+      if pr > q then
+         BREAK;
+      if n = pr*q then
+      Begin
+        pfpotPrimIdx[pfMaxIdx] := i;
+        pot := 0;
+        fac := pr;
+        repeat
+          n := q;
+          q := n div pr;
+          pot+=1;
+          fac *= pr;
+        until n <> pr*q;
+        pfpotMax[pfMaxIdx] := pot;
+        pfDivCnt *= pot+1;
+        pfSumOfDivs *= (fac-1)DIV(pr-1);
+        inc(pfMaxIdx);
+      end;
+      inc(i);
+    end;
+    pfRemain := n;
+    if n > 1 then
+    Begin
+      pfDivCnt *= 2;
+      pfSumOfDivs *= n+1
+    end;
+  end;
+end;
+
+function IsArithmetic(const PrimeFact:tPrimeFact):boolean;inline;
+begin
+  with PrimeFact do
+    IsArithmetic := pfSumOfDivs mod pfDivCnt = 0;
+end;
+
+var
+  pF :TPrimeFact;
+  i,cnt,primeCnt,lmt : Uint32;
+begin
+  InitSmallPrimes;
+
+  writeln('First 100 arithemetic numbers');
+  cnt := 0;
+  i := 1;
+  repeat
+    smplPrimeDecomp(pF,i);
+    if IsArithmetic(pF) then
+    begin
+      write(i:4);
+      inc(cnt);
+      if cnt MOD 20 =0 then
+        writeln;
+    end;
+    inc(i);
+  until cnt = 100;
+  writeln;
+
+  writeln('   Arithemetic numbers');
+  writeln('   Index   number composite');
+  cnt := 0;
+  primeCnt := 0;
+  lmt := 10;
+  i := 1;
+  repeat
+    smplPrimeDecomp(pF,i);
+    if IsArithmetic(pF) then
+    begin
+      inc(cnt);
+      if pF.pfRemain = i then
+        inc(primeCnt);
+    end;
+    if cnt = lmt then
+    begin
+      writeln(lmt:8,i:9,lmt-primeCnt:10);
+      lmt := lmt*10;
+    end;
+    inc(i);
+  until lmt>1000000;
+  {$IFdef WINDOWS}
+  WriteLn('Hit <ENTER>');ReadLn;
+  {$ENDIF}
+end.

Task/Arithmetic-numbers/Free-Pascal/arithmetic-numbers-2.pas

@@ -0,0 +1,41 @@
+const
+  //make size of sieve using 11 MB of 16MB Level III cache
+  SizePrDeFe = 192*1024;
+.....
+function IsArithmetic(const PrimeFact:tPrimeFac):boolean;inline;
+begin
+  with PrimeFact do
+    IsArithmetic := pfSumOfDivs mod pfDivCnt = 0;
+end;
+
+var
+  pPrimeDecomp :tpPrimeFac;
+  T0:Int64;
+  n,lmt,cnt,primeCnt : NativeUInt;
+Begin
+  InitSmallPrimes;
+
+  T0 := GetTickCount64;
+  cnt := 1;
+  primeCnt := 1;
+  lmt := 10;
+  n := 2;
+  Init_Sieve(n);
+  repeat
+    pPrimeDecomp:= GetNextPrimeDecomp;
+    if IsArithmetic(pPrimeDecomp^) then
+    begin
+      inc(cnt);
+      if pPrimeDecomp^.pfDivCnt = 2 then
+        inc(primeCnt);
+    end;
+    if cnt = lmt then
+    begin
+      writeln(lmt:14,n:14,lmt-primeCnt:14);
+      lmt := lmt*10;
+    end;
+    inc(n);
+  until lmt>1000*1000*1000;
+  T0 := GetTickCount64-T0;
+  writeln;
+end.