Jordan-Pólya numbers: Difference between revisions

Content added Content deleted
(Added Go)
(→‎{{header|Free Pascal}}: Convert using Uint64. misinterpretate 2^53 with 1E53 tse tse tse...)
Line 732: Line 732:
==={{header|Free Pascal}}===
==={{header|Free Pascal}}===
succesive add of next factorial in its power.keep sorted and without doublettes.<br>
succesive add of next factorial in its power.keep sorted and without doublettes.<br>
Now using Uint64 and only marking which factorial is used, which is unnecessary, but why not. It makes output easier<br>
I dont't know, how "far" extended gets correct results.Maybe using logs would be more precise.
Runtime for TIO.RUN 127 ms (too short to be significant ) @home 2 ms<br>
<syntaxhighlight lang="pascal">
Using alternative dblLimit := 1 shl 6 as starting Limit and increase it by a factor of 256<br>
program Jordan_Polya_Num;
This gets if MaxIdx = 3800 in 4ms.
{$IFDEF FPC}{$MODE DELPHI}{$OPTIMIZATION ON,ALL}{$ENDIF}
<syntaxhighlight lang="pascal">program Jordan_Polya_Num;
{$IFDEF FPC}{$MODE DELPHI}{$OPTIMIZATION ON,ALL}{$COPERATORS ON}{$ENDIF}
{$IFDEF Windows}{$APPTYPE CONSOLE}{$ENDIF}
{$IFDEF Windows}{$APPTYPE CONSOLE}{$ENDIF}
uses
uses
sysutils;
sysutils;
const
const
MaxIdx = 3800;//7279 < 2^62
dblLimit = 1E19;//7213895789838336+3e14;//1e53;
maxFac = 43;
maxFac = 21;//21!> 2^63
type
type
tnum = extended;
tnum = Uint64;
tpow= array[0..maxFac-2] of byte;
tpow= set of 0..31;// 1==2!^? ,2=3!^? 3=2!^?*3!^?
tFac_mul = packed record
tFac_mul = packed record
fm_num : tnum;
fm_num : tnum;
fm_pow : tpow;
fm_pow : tpow; //which Factorials where used for fm_num
fm_idx : byte;
fm_high_idx : word;//memorize highest Factorial Index
fm_high_pow : word;// and it's power
end;
end;
tpFac_mul = ^tFac_mul;
tpFac_mul = ^tFac_mul;
tFacMulPow = array of tFac_mul;
tFacMulPow = array of tFac_mul;
var
var
Factorial: array[0..maxFac-2] of tnum;
Factorial: array[0..maxFac-2] of tnum;
FacMulPowGes : tFacMulPow;
FacMulPowGes : tFacMulPow;
LastSearchFor :tFac_mul;
dblLimit : tnum;


procedure QuickSort(var AI: tFacMulPow; ALo, AHi: Int32);
procedure QuickSort(var AI: tFacMulPow; ALo, AHi: Int32);
Line 785: Line 791:
end;
end;


procedure Out_MulFac(const fm:tFac_mul);
procedure Out_MulFac(idx:Uint32;const fm:tFac_mul);
var
var
fac,
num : tNum;
i,j,pow : integer;
i,j,pow : integer;
begin
begin
if fm.fm_num < 1E20 then
num := fm.fm_num;
write(fm.fm_num:20:0)
write(num:20);
i := fm.fm_high_idx;
else
repeat
writeln(fm.fm_num);
j := 0;

i := High(tpow);
fac := Factorial[i];
while (i>=0 ) AND (fm.fm_pow[i]= 0) do
while (num>=fac) AND (num mod Fac = 0) do
dec(i);
Begin
num := num DIV Fac;

For j := 0 to i do
inc(j);
end;
Begin
pow := fm.fm_pow[j];
if j = 0 then
if pow > 1 then
write(' 1')
else
write(' (',j+2,'!)^',pow)
else
if j = 1 then
if pow= 1 then
write(' ',i+2,'!')
write(' ',j+2,'!');
else
write(' (',i+2,'!)^',j);
end;
if num = 1 then
BREAK;
dec(i);
while (i>=0 ) AND Not(i in fm.fm_pow) do
dec(i);
until i < 0;
writeln;
writeln;
end;
end;


procedure Init;
procedure Out_I_th(i: integer);
begin
write(i:8,': ');
if i <= High(FacMulPowGes) then
Out_MulFac(i,FacMulPowGes[i-1])
else
writeln('Too big');
end;

procedure Initfirst;
var
var
fac: tnum;
fac: tnum;
i,j,idx: integer;
i,j,idx: integer;
Begin
Begin
fac:= 1.0;
fac:= 1;
j := 1;
j := 1;
idx := 0;
idx := 0;
For i := 2 to 43 do
For i := 2 to maxFac do
Begin
Begin
repeat
repeat
Line 827: Line 850:
inc(idx);
inc(idx);
end;
end;
Fillchar(LastSearchFor,SizeOf(LastSearchFor),#0);
LastSearchFor.FM_NUM := 0;
dblLimit := 1 shl 53;// 1 shl 6;
end;

procedure ResetSearch;
Begin
setlength(FacMulPowGes,0);
end;
end;


Line 832: Line 863:
//generating the first entry with (2!)^n
//generating the first entry with (2!)^n
var
var
res_p : tpFac_mul;
Fac_mul :tFac_mul;
Fac_mul :tFac_mul;
fac : tnum;
facPow,Fac : tnum;
i,MaxIdx : integer;
i,MaxIdx : integer;
begin
begin
Line 843: Line 875:
begin
begin
fm_num := 1;
fm_num := 1;
fm_pow[idx] := 0;
fm_pow := [0];
fm_idx := 0;
fm_high_idx := 0;
end;
end;
res[0] := Fac_Mul;
res_p := @res[0];
fac := 1;
res_p^ := Fac_Mul;
facPow := 1;
For i := 1 to MaxIdx-1 do
For i := 1 to MaxIdx-1 do
begin
begin
fac *= Factorial[idx];
facPow *= Fac;
with Fac_Mul do
with Fac_Mul do
begin
begin
fm_num := fac;
fm_num := facPow;
fm_pow[idx] := i;
fm_high_pow := i;
end;
end;
res[i] := Fac_Mul;
inc(res_p);
res_p^ := Fac_Mul;
end;
end;
end;
end;


procedure DelDoulettes(var FMP:tFacMulPow);
procedure DelDoublettes(var FMP:tFacMulPow);
//throw out doublettes,
//throw out doublettes,
//the one with highest power in the highest n! survives
//the one with highest power in the highest n! survives
Line 875: Line 909:
if pJ^.fm_num = pI^.fm_num then
if pJ^.fm_num = pI^.fm_num then
Begin
Begin
idx := pJ^.fm_idx;
idx := pJ^.fm_high_idx;
if idx < pI^.fm_idx then
if idx < pI^.fm_high_idx then
pJ^ := pI^
pJ^ := pI^
else
else
if idx = pI^.fm_idx then
if idx = pI^.fm_high_idx then
if pJ^.fm_pow[idx]<pI^.fm_pow[idx] then
if pJ^.fm_high_pow < pI^.fm_high_pow then
pJ^ := pI^;
pJ^ := pI^;
end
end
Line 898: Line 932:
l_res,l_NewMaxPow,idx,i,j : Integer;
l_res,l_NewMaxPow,idx,i,j : Integer;
begin
begin
fac := Factorial[Facidx];

if length(res)= 0 then
if length(res)= 0 then
Begin
Begin
Line 903: Line 939:
EXIT;
EXIT;
end;
end;

fac := Factorial[Facidx];
if fac>dblLimit then
if fac>dblLimit then
EXIT;
EXIT;

l_NewMaxPow := trunc(ln(dblLimit)/ln(Fac))+1;
l_NewMaxPow := trunc(ln(dblLimit)/ln(Fac))+1;
l_res := length(res);
l_res := length(res);
Line 915: Line 951:
For i := 1 to l_NewMaxPow do
For i := 1 to l_NewMaxPow do
Begin
Begin
limit := dblLimit/fac;
limit := dblLimit DIV fac;
if limit < 1 then
if limit < 1 then
BREAK;
BREAK;
Line 933: Line 969:
For i := 0 to l_res-1 do
For i := 0 to l_res-1 do
begin
begin
res[idx]:= res[i];
NewFac := res[i].fm_num*Fac;
NewFac := res[i].fm_num*Fac;
if NewFac>dblLimit then
if NewFac>dblLimit then
Break;
Break;
res[idx].fm_num := NewFac;
res[idx]:= res[i];
res[idx].fm_pow[Facidx] := j+1;
with res[idx] do
res[idx].fm_idx := Facidx;
Begin
fm_num := NewFac;
include(fm_pow,Facidx);
fm_high_idx := Facidx;
fm_high_pow := j;
end;
inc(idx);
inc(idx);
end;
end;
Line 946: Line 986:
setlength(res,idx);
setlength(res,idx);
QuickSort(res,Low(res),High(res));
QuickSort(res,Low(res),High(res));
DelDoulettes(res);
DelDoublettes(res);
end;
end;


Line 952: Line 992:
i : integer;
i : integer;
BEGIn
BEGIn
init;
InitFirst;
repeat
For i := Low(Factorial) to High(Factorial) do
ResetSearch;
InsertFacMulPow(FacMulPowGes,i);
i := 0;
write('Found ',length( FacMulPowGes),' Jordan-Polia numbers ');
repeat
if Factorial[i] < dblLimit then
InsertFacMulPow(FacMulPowGes,i)
else
break;
inc(i);
until i > High(Factorial);
if (Length(FacMulPowGes) > MaxIdx) then
begin
if (LastSearchFor.fm_num<> FacMulPowGes[MaxIdx-1].fm_num) then
Begin
LastSearchFor := FacMulPowGes[MaxIdx-1];
if LastSearchFor.fm_num < Factorial[i] then
break;
end
else
Break;
end;
if dblLimit> HIGH(tNUm) DIV 256 then
BREAK;
dblLimit *= 256;
until false;
write('Found ',length(FacMulPowGes),' Jordan-Polia numbers ');
writeln('up to ',dblLimit);
writeln('up to ',dblLimit);
writeln;
writeln;
Line 962: Line 1,025:
For i := 1 to 50 do
For i := 1 to 50 do
Begin
Begin
write(FacMulPowGes[i-1].fm_num:5:0);
write(FacMulPowGes[i-1].fm_num:5);
if i mod 10 = 0 then
if i mod 10 = 0 then
writeln;
writeln;
Line 968: Line 1,031:
writeln;
writeln;


writeln('The last < 1E8 ');
write('The last < 1E8 ');
for i := 0 to High(FacMulPowGes) do
for i := 0 to High(FacMulPowGes) do
if FacMulPowGes[i].fm_num >= 1E8 then
if FacMulPowGes[i].fm_num > 1E8 then
begin
begin
write('Index: ',i,' = ');
Out_MulFac(i,FacMulPowGes[i-1]);
Out_MulFac(FacMulPowGes[i-1]);
BREAK;
BREAK;
end;
end;
writeln;
writeln;

writeln(' Index ');
Out_I_th(0);
i := 100;write(i:8,': ');Out_MulFac(FacMulPowGes[i-1]);
Out_I_th(100);
i := 800;write(i:8,': ');Out_MulFac(FacMulPowGes[i-1]);
Out_I_th(800);
i := 1050;write(i:8,': ');Out_MulFac(FacMulPowGes[i-1]);
Out_I_th(1050);
i := 1800;write(i:8,': ');Out_MulFac(FacMulPowGes[i-1]);
Out_I_th(1800);
i := 2800;write(i:8,': ');Out_MulFac(FacMulPowGes[i-1]);
Out_I_th(2800);
i := 3800;write(i:8,': ');Out_MulFac(FacMulPowGes[i-1]);
Out_I_th(3800);
END.
</syntaxhighlight>
END.</syntaxhighlight>
{{out|@TIO.RUN}}
{{out|@home}}
<pre>
<pre>
Found 7832 Jordan-Polia numbers up to 1.00000000000000000000E+0019
Found 3876 Jordan-Polia numbers up to 9007199254740992


The first 50 Jordan-Polia numbers
The first 50 Jordan-Polia numbers
Line 997: Line 1,059:
2592 2880 3072 3456 3840 4096 4320 4608 5040 5184
2592 2880 3072 3456 3840 4096 4320 4608 5040 5184


The last < 1E8
The last < 1E8 99532800 (6!)^2 4! (2!)^3
Index: 367 = 99532800 (2!)^3 4! (6!)^2


0: 1 1
Index
100: 92160 (2!)^7 6!
100: 92160 6! (2!)^7
800: 18345885696 (2!)^2 (4!)^7
800: 18345885696 (4!)^7 (2!)^2
1050: 139345920000 2! (5!)^3 8!
1050: 139345920000 8! (5!)^3 2!
1800: 9784472371200 (2!)^15 (4!)^2 (6!)^2
1800: 9784472371200 (6!)^2 (4!)^2 (2!)^15
2800: 439378587648000 7! 14!
2800: 439378587648000 14! 7!
3800: 7222041363087360 2! (3!)^11 (4!)^3 6!
3800: 7213895789838336 (4!)^8 (2!)^16
Real time: 0.148 s User time: 0.122 s Sys. time: 0.024 s CPU share: 99.01 %


real 0m0,002s user 0m0,002s sys 0m0,000s</pre>
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>


=={{header|Phix}}==
=={{header|Phix}}==
Retrieved from "https://rosettacode.org/wiki/Jordan-Pólya_numbers"