Jordan-Pólya numbers: Difference between revisions
Content added Content deleted
(Added an option to the 'bonus' task.) |
(→{{header|Nim}}: append ==={{header|Free pascal}}===) |
||
Line 387: | Line 387: | ||
The 3800th Jordan-Pólya number is: |
The 3800th Jordan-Pólya number is: |
||
7_213_895_789_838_336 = (4!)⁸(2!)¹⁶ |
7_213_895_789_838_336 = (4!)⁸(2!)¹⁶ |
||
</pre> |
|||
=={{header|Pascal}}== |
|||
==={{header|Free Pascal}}=== |
|||
succesive add of next factorial in its power.keep sorted and without doublettes.<br> |
|||
I dont't know, how "far" extended gets correct results.Maybe using logs would be more precise. |
|||
<syntaxhighlight lang="pascal"> |
|||
program Jordan_Polya_Num; |
|||
{$IFDEF FPC}{$MODE DELPHI}{$OPTIMIZATION ON,ALL}{$ENDIF} |
|||
{$IFDEF Windows}{$APPTYPE CONSOLE}{$ENDIF} |
|||
uses |
|||
sysutils; |
|||
const |
|||
dblLimit = 1E19;//7213895789838336+3e14;//1e53; |
|||
maxFac = 43; |
|||
type |
|||
tnum = extended; |
|||
tpow= array[0..maxFac-2] of byte; |
|||
tFac_mul = packed record |
|||
fm_num : tnum; |
|||
fm_pow : tpow; |
|||
fm_idx : byte; |
|||
end; |
|||
tpFac_mul = ^tFac_mul; |
|||
tFacMulPow = array of tFac_mul; |
|||
var |
|||
Factorial: array[0..maxFac-2] of tnum; |
|||
FacMulPowGes : tFacMulPow; |
|||
procedure QuickSort(var AI: tFacMulPow; ALo, AHi: Int32); |
|||
var |
|||
Tmp :tFac_mul; |
|||
Pivot : tnum; |
|||
Lo, Hi : Int32; |
|||
begin |
|||
Lo := ALo; |
|||
Hi := AHi; |
|||
Pivot := AI[(Lo + Hi) div 2].fm_num; |
|||
repeat |
|||
while AI[Lo].fm_num < Pivot do |
|||
Inc(Lo); |
|||
while AI[Hi].fm_num > Pivot do |
|||
Dec(Hi); |
|||
if Lo <= Hi then |
|||
begin |
|||
Tmp := AI[Lo]; |
|||
AI[Lo] := AI[Hi]; |
|||
AI[Hi] := Tmp; |
|||
Inc(Lo); |
|||
Dec(Hi); |
|||
end; |
|||
until Lo > Hi; |
|||
if Hi > ALo then |
|||
QuickSort(AI, ALo, Hi) ; |
|||
if Lo < AHi then |
|||
QuickSort(AI, Lo, AHi) ; |
|||
end; |
|||
procedure Out_MulFac(const fm:tFac_mul); |
|||
var |
|||
i,j,pow : integer; |
|||
begin |
|||
if fm.fm_num < 1E20 then |
|||
write(fm.fm_num:20:0) |
|||
else |
|||
writeln(fm.fm_num); |
|||
i := High(tpow); |
|||
while (i>=0 ) AND (fm.fm_pow[i]= 0) do |
|||
dec(i); |
|||
For j := 0 to i do |
|||
Begin |
|||
pow := fm.fm_pow[j]; |
|||
if pow > 1 then |
|||
write(' (',j+2,'!)^',pow) |
|||
else |
|||
if pow= 1 then |
|||
write(' ',j+2,'!'); |
|||
end; |
|||
writeln; |
|||
end; |
|||
procedure Init; |
|||
var |
|||
fac: tnum; |
|||
i,j,idx: integer; |
|||
Begin |
|||
fac:= 1.0; |
|||
j := 1; |
|||
idx := 0; |
|||
For i := 2 to 43 do |
|||
Begin |
|||
repeat |
|||
inc(j); |
|||
fac *= j; |
|||
until j = i; |
|||
Factorial[idx] := fac; |
|||
inc(idx); |
|||
end; |
|||
end; |
|||
procedure GenerateFirst(idx:NativeInt;var res:tFacMulPow); |
|||
//generating the first entry with (2!)^n |
|||
var |
|||
Fac_mul :tFac_mul; |
|||
fac : tnum; |
|||
i,MaxIdx : integer; |
|||
begin |
|||
fac := Factorial[idx]; |
|||
MaxIDx := trunc(ln(dblLimit)/ln(Fac))+1; |
|||
setlength(res,MaxIdx); |
|||
fillchar(Fac_Mul,SizeOf(Fac_Mul),#0); |
|||
with Fac_Mul do |
|||
begin |
|||
fm_num := 1; |
|||
fm_pow[idx] := 0; |
|||
fm_idx := 0; |
|||
end; |
|||
res[0] := Fac_Mul; |
|||
fac := 1; |
|||
For i := 1 to MaxIdx-1 do |
|||
begin |
|||
fac *= Factorial[idx]; |
|||
with Fac_Mul do |
|||
begin |
|||
fm_num := fac; |
|||
fm_pow[idx] := i; |
|||
end; |
|||
res[i] := Fac_Mul; |
|||
end; |
|||
end; |
|||
procedure DelDoulettes(var FMP:tFacMulPow); |
|||
//throw out doublettes, |
|||
//the one with highest power in the highest n! survives |
|||
var |
|||
pI,pJ : tpFac_mul; |
|||
i, j,idx : integer; |
|||
begin |
|||
j := 0; |
|||
pJ := @FMP[0]; |
|||
pI := pJ; |
|||
For i := 0 to High(FMP)-1 do |
|||
begin |
|||
inc(pI); |
|||
if pJ^.fm_num = pI^.fm_num then |
|||
Begin |
|||
idx := pJ^.fm_idx; |
|||
if idx < pI^.fm_idx then |
|||
pJ^ := pI^ |
|||
else |
|||
if idx = pI^.fm_idx then |
|||
if pJ^.fm_pow[idx]<pI^.fm_pow[idx] then |
|||
pJ^ := pI^; |
|||
end |
|||
else |
|||
begin |
|||
inc(j); |
|||
inc(pJ); |
|||
pJ^ := pI^; |
|||
end; |
|||
end; |
|||
setlength(FMP,j); |
|||
end; |
|||
procedure InsertFacMulPow(var res:tFacMulPow;Facidx:integer); |
|||
var |
|||
Fac,newFac,limit : tnum; |
|||
l_res,l_NewMaxPow,idx,i,j : Integer; |
|||
begin |
|||
if length(res)= 0 then |
|||
Begin |
|||
GenerateFirst(Facidx,res); |
|||
EXIT; |
|||
end; |
|||
fac := Factorial[Facidx]; |
|||
if fac>dblLimit then |
|||
EXIT; |
|||
l_NewMaxPow := trunc(ln(dblLimit)/ln(Fac))+1; |
|||
l_res := length(res); |
|||
//calc new length, reduces allocation of big memory chunks |
|||
j := 0; |
|||
idx := High(res); |
|||
For i := 1 to l_NewMaxPow do |
|||
Begin |
|||
limit := dblLimit/fac; |
|||
if limit < 1 then |
|||
BREAK; |
|||
repeat |
|||
dec(idx); |
|||
until res[idx].fm_num<=limit; |
|||
inc(j,idx); |
|||
fac *=Factorial[Facidx]; |
|||
end; |
|||
j += l_res+l_NewMaxPow+2; |
|||
setlength(res,j); |
|||
fac := Factorial[Facidx]; |
|||
idx := l_res; |
|||
For j := 0 to l_NewMaxPow-1 do |
|||
begin |
|||
For i := 0 to l_res-1 do |
|||
begin |
|||
res[idx]:= res[i]; |
|||
NewFac := res[i].fm_num*Fac; |
|||
if NewFac>dblLimit then |
|||
Break; |
|||
res[idx].fm_num := NewFac; |
|||
res[idx].fm_pow[Facidx] := j+1; |
|||
res[idx].fm_idx := Facidx; |
|||
inc(idx); |
|||
end; |
|||
fac *= Factorial[Facidx]; |
|||
end; |
|||
setlength(res,idx); |
|||
QuickSort(res,Low(res),High(res)); |
|||
DelDoulettes(res); |
|||
end; |
|||
var |
|||
i : integer; |
|||
BEGIn |
|||
init; |
|||
For i := Low(Factorial) to High(Factorial) do |
|||
InsertFacMulPow(FacMulPowGes,i); |
|||
write('Found ',length( FacMulPowGes),' Jordan-Polia numbers '); |
|||
writeln('up to ',dblLimit); |
|||
writeln; |
|||
writeln('The first 50 Jordan-Polia numbers'); |
|||
For i := 1 to 50 do |
|||
Begin |
|||
write(FacMulPowGes[i-1].fm_num:5:0); |
|||
if i mod 10 = 0 then |
|||
writeln; |
|||
end; |
|||
writeln; |
|||
writeln('The last < 1E8 '); |
|||
for i := 0 to High(FacMulPowGes) do |
|||
if FacMulPowGes[i].fm_num >= 1E8 then |
|||
begin |
|||
write('Index: ',i,' = '); |
|||
Out_MulFac(FacMulPowGes[i-1]); |
|||
BREAK; |
|||
end; |
|||
writeln; |
|||
writeln(' Index '); |
|||
i := 100;write(i:8,': ');Out_MulFac(FacMulPowGes[i-1]); |
|||
i := 800;write(i:8,': ');Out_MulFac(FacMulPowGes[i-1]); |
|||
i := 1050;write(i:8,': ');Out_MulFac(FacMulPowGes[i-1]); |
|||
i := 1800;write(i:8,': ');Out_MulFac(FacMulPowGes[i-1]); |
|||
i := 2800;write(i:8,': ');Out_MulFac(FacMulPowGes[i-1]); |
|||
i := 3800;write(i:8,': ');Out_MulFac(FacMulPowGes[i-1]); |
|||
END. |
|||
</syntaxhighlight> |
|||
{{out|@TIO.RUN}} |
|||
<pre> |
|||
Found 7832 Jordan-Polia numbers up to 1.00000000000000000000E+0019 |
|||
The first 50 Jordan-Polia numbers |
|||
1 2 4 6 8 12 16 24 32 36 |
|||
48 64 72 96 120 128 144 192 216 240 |
|||
256 288 384 432 480 512 576 720 768 864 |
|||
960 1024 1152 1296 1440 1536 1728 1920 2048 2304 |
|||
2592 2880 3072 3456 3840 4096 4320 4608 5040 5184 |
|||
The last < 1E8 |
|||
Index: 367 = 99532800 (2!)^3 4! (6!)^2 |
|||
Index |
|||
100: 92160 (2!)^7 6! |
|||
800: 18345885696 (2!)^2 (4!)^7 |
|||
1050: 139345920000 2! (5!)^3 8! |
|||
1800: 9784472371200 (2!)^15 (4!)^2 (6!)^2 |
|||
2800: 439378587648000 7! 14! |
|||
3800: 7222041363087360 2! (3!)^11 (4!)^3 6! |
|||
Real time: 0.148 s User time: 0.122 s Sys. time: 0.024 s CPU share: 99.01 % |
|||
Found 1660536 Jordan-Polia numbers up to 9.99999999999999999971E+0052 |
|||
--using double Found 1933972 Jordan-Polia numbers up to 9.99999999999999999971E+0052 |
|||
Real time: 13.738 s User time: 12.925 s Sys. time: 0.715 s CPU share: 99.28 % |
|||
</pre> |
</pre> |
||