Sphenic numbers: Difference between revisions
→{{header|Phix}}: prepend Freepascal
m (→{{header|Phix}}: minor tidy) |
(→{{header|Phix}}: prepend Freepascal) |
||
Line 263:
</syntaxhighlight>
=={{header|Pascal}}==
==={{header|Free Pascal}}===
{{trans|Wren}} Output Format {{trans|AppleScript}}
Most of the time, ~ 75% in this case, is spent with sort.
<syntaxhighlight lang=pascal>
program sphenic;
const
Limit= 1000*1000;
LimitPrime = Limit div (2*3);
primeCount = 15224;
var
primes : array of Uint32;
sphenics : array of Uint32;
procedure GetPrimes;
//trial division
var
p,p2,i,maxIdx,maxSqrtPrimeIdx : Uint32;
begin
setlength(Primes,primeCount);
primes[0] := 2;
maxIdx := 0;
maxSqrtPrimeIdx := 0;
p2:= sqr(primes[maxSqrtPrimeIdx]);
For p := 3 to LimitPrime do
begin
if p2 <=p then
begin
inc(maxSqrtPrimeIdx);
p2 := sqr(primes[maxSqrtPrimeIdx]);
end;
i := 0;
repeat
if p mod primes[i] = 0 then
BREAK;
inc(i);
until i >= maxSqrtPrimeIdx;
if i >= maxSqrtPrimeIdx then
begin
inc(maxIdx);
primes[maxIdx] := p;
end;
end;
setlength(primes,maxidx+1);
end;
procedure QuickSort(var A: array of Uint32);
procedure QSort(L, R: Int32);
var
I, J: Int32;
Tmp, Pivot: Uint32;
begin
if R - L < 1 then exit;
I := L; J := R;
{$push}{$q-}{$r-}Pivot := A[(L + R) shr 1];{$pop}
repeat
while A[I] < Pivot do Inc(I);
while A[J] > Pivot do Dec(J);
if I <= J then begin
Tmp := A[I];
A[I] := A[J];
A[J] := Tmp;
Inc(I); Dec(J);
end;
until I > J;
QSort(L, J);
QSort(I, R);
end;
begin
QSort(0, High(A));
end;
function binary_search(value: Uint32): Int32;
var
p : Uint32;
l, m, h: UInt32;
begin
l := Low(primes);
h := High(primes);
while l <= h do
begin
m := (l + h) div 2;
p := primes[m];
if p > value then
begin
h := m - 1;
end
else
begin
if p < value then
begin
l := m + 1;
end
else
exit(m);
end;
end;
binary_search:=m;
end;
procedure CreateSphenics;
var
i1,i2,i3,
idx1,idx2,idx3,
p1,p2,p,i : Uint32;
begin
i := 0;
idx1 := trunc(exp(1/3*ln(Limit)));
idx1 := binary_search(idx1)-1;
idx3 := idx1+2;
For i1 := 0 to idx1 do
begin
p1 := primes[i1];
idx2 := trunc(sqrt(Limit DIV p1));
idx2:= binary_search(idx2)+1;
For i2 := i1+1 to idx2 do
begin
p2:= p1*primes[i2];
For i3 := i2+1 to High(primes) do
begin
p := p2*Primes[i3];
if p > Limit then
break;
sphenics[i] := p;
inc(i);
end;
end;
end;
setlength(sphenics,i);
QuickSort(sphenics);
end;
procedure OutTriplet(i:Uint32);
begin
write('{',sphenics[i],',',sphenics[i+1],',',sphenics[i+2],'}');
end;
function CheckTriplets(i:Uint32):boolean;
begin
CheckTriplets:= (sphenics[i]+1=sphenics[i+1]) AND
(sphenics[i+1]+1=sphenics[i+2]);
end;
var
i,j,t5000 : Uint32;
begin
GetPrimes;
setlength(sphenics,21*Limit div 100+100);//203,834,084 for Limit 1E9
CreateSphenics;
writeln('Sphenic numbers < 1,000:');
i := 1;
repeat
if sphenics[i] > 1000 then
break;
write(sphenics[i]:4);
if i Mod 15 = 0 then
writeln;
inc(i);
until i>= High(sphenics);
writeln;
writeln('Sphenic triplets < 10,000:');
i := 0;
j := 0;
repeat
if CheckTriplets(i) then
Begin
OutTriplet(i);
inc(j);
if j < 3 then
write(',')
else
begin
writeln;
j := 0;
end;
end;
inc(i);
until sphenics[i+2]>10000;
writeln;
i := 0;
j := 0;
writeln('There are ',length(sphenics),' sphenic numbers < ',limit);
repeat
if CheckTriplets(i) then
Begin
inc(j);
if j = 5000 then
t5000 := i;
end;
inc(i);
until i+2 >high(sphenics);
writeln('There are ',j,' sphenic triplets numbers < ',limit);
writeln('The 200,000th sphenic number is ',sphenics[200000]);
write('The 5,000th sphenic triplet is ');OutTriplet(T5000);
end.
</syntaxhighlight>
{{out}}
<pre>
Sphenic numbers < 1,000:
30 42 66 70 78 102 105 110 114 130 138 154 165 170 174
182 186 190 195 222 230 231 238 246 255 258 266 273 282 285
286 290 310 318 322 345 354 357 366 370 374 385 399 402 406
410 418 426 429 430 434 435 438 442 455 465 470 474 483 494
498 506 518 530 534 555 561 574 582 590 595 598 602 606 609
610 615 618 627 638 642 645 646 651 654 658 663 665 670 678
682 705 710 715 730 741 742 754 759 762 777 782 786 790 795
805 806 814 822 826 830 834 854 861 874 885 890 894 897 902
903 906 915 935 938 942 946 957 962 969 970 978 986 987 994
Sphenic triplets < 10,000:
{1309,1310,1311},{1885,1886,1887},{2013,2014,2015}
{2665,2666,2667},{3729,3730,3731},{5133,5134,5135}
{6061,6062,6063},{6213,6214,6215},{6305,6306,6307}
{6477,6478,6479},{6853,6854,6855},{6985,6986,6987}
{7257,7258,7259},{7953,7954,7955},{8393,8394,8395}
{8533,8534,8535},{8785,8786,8787},{9213,9214,9215}
{9453,9454,9455},{9821,9822,9823},{9877,9878,9879}
There are 206964 sphenic numbers < 1000000
There are 5457 sphenic triplets numbers < 1000000
The 200,000th sphenic number is 966467
The 5,000th sphenic triplet is {918005,918006,918007}
</pre>
=={{header|Phix}}==
{{trans|Wren}}
| |||