Jordan-Pólya numbers: Difference between revisions
→{{header|Nim}}: append ==={{header|Free pascal}}===
(Added an option to the 'bonus' task.) |
(→{{header|Nim}}: append ==={{header|Free pascal}}===) |
||
Line 387:
The 3800th Jordan-Pólya number is:
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>
| |||