Rosetta Code

Practical numbers: Difference between revisions

Page Discussion

Practical numbers (view source)

Revision as of 14:18, 2 May 2021

166 bytes added ,  3 years ago
m
Fix pascal version to run in delphi
m (→‎{{header|alternative}}: only memorizing heigher divisors)
m (Fix pascal version to run in delphi)
Line 138:
{$ELSE}
{$APPTYPE CONSOLE}
 
{$ENDIF}
 
uses
sysutils;
{$IFNDEF FPC}
,Windows
{$ENDIF}
;
 
const
LOW_DIVS = 0;
HIGH_DIVS = 2048 - 1;
 
type
tdivs = record
DivsVal : array[0LOW_DIVS..2048-1HIGH_DIVS] of Uint32;
DivsMaxIdx, DivsNum, DivsSumProp: :NativeUInt;▼
DivsMaxIdx,
end;▼
DivsNum,
▲ DivsSumProp :NativeUInt;
▲ end;
 
var
Divs: tDivs;
HasSum : array of byte;
 
procedure GetDivisors(var Divs: tdivs; n: Uint32);
//calc all divisors,keep sorted
var
i, quot, ug,og og: UInt32;
sum: UInt64;
begin
Begin
with Divs do
Beginbegin
DivsNum := n;
sum := 0;
ug := Low(tdivs.DivsVal)0;
og := High(tdivs.DivsVal)HIGH_DIVS;
i := 1;
 
while i * i < n do
begin
quot := n div i;
IFif n - quot * i = 0 then
Beginbegin
DivsVal[og] := quot;
Divs.DivsVal[ug] := i;
inc(sum, quot + i);
dec(og);
inc(ug);
Line 178 ⟶ 189:
inc(i);
end;
Ifif i * i = n then
Beginbegin
DivsVal[og] := i;
inc(sum, i);
dec(og);
end;
//move higher divisors down
while og < High(tDivs.DivsVal)high_DIVS do
begin
inc(og);
Line 191 ⟶ 202:
inc(ug);
end;
DivsMaxIdx := ug - 2;
DivsSumProp := sum - n;
end; //with
end;
 
function SumAllSetsForPractical(Limit: Uint32): boolean;
//mark sum and than shift by next divisor == add
//for practical numbers every sum must be marked
var
hs0,hs1 hs1: pByte;
idx, j, loLimit, maxlimit,delta delta: NativeUint;
begin
Begin
Limit := trunc(Limit * (Limit / Divs.DivsSumProp));
LoLimitloLimit := 0;
maxlimit := 0;
hs0 := @HasSum[0];
hs0[0] := 1; //empty set
for idx := 0 to Divs.DivsMaxIdx do
Beginbegin
delta := Divs.DivsVal[idx];
hs1 := @hs0[delta];
Forfor j := maxlimit downto 0 do
hs1[j] := hs1[j] or hs0[j];
maxlimit +:= maxlimit + delta;
while hs0[LoLimitloLimit] <> 0 do
inc(LoLimitloLimit);
//IF there is a 0 < delta, it will never be set
//IF there are more than the Limit set,
//it will be copied by the following Delta's
if (LoLimitloLimit < delta) ORor (LoLimitloLimit > Limit) then
Break;
end;
result := (LoLimitloLimit > Limit);
end;
 
function isPractical(n: Uint32): boolean;
var
i: NativeInt;
sum: NativeUInt;
begin
Begin
if n = 1 then
EXIT(True);
if ODD(n) then
EXIT(false);
if (n > 2) ANDand not NOT((n MODmod 4 = 0) or (n Modmod 6 = 0)) then
EXIT(false);
 
GetDivisors(Divs, n);
i := n - 1;
sum := Divs.DivsSumProp;
if sum < i then
result := false
else
Beginbegin
IFif length(HasSum) > sum + 1 + 1 then
FillChar(HasSum[0], sum + 1, #0)
else
Beginbegin
setlength(HasSum, 0);
setlength(HasSum, sum + 8 + 1);
end;
result := SumAllSetsForPractical(i);
end;
end;
 
procedure OutIsPractical(n: nativeInt);
begin
Ifif isPractical(n) then
writeln(n, ' is practical')
else
writeln(n, ' is not practical');
end;
 
const
ColCnt = 10;
MAX = 333;
 
var
T0 : Int64;
n, col,count count: NativeInt;
 
Begin
begin
col := ColCnt;
count := 0;
Forfor n := 1 to MAX do
if isPractical(n) then
begin
write(n: 5);
inc(count);
dec(col);
if col = 0 then
Beginbegin
writeln;
col := ColCnt;
end;
end;
writeln;
writeln('There are ', count, ' pratical numbers from 1 to ', MAX);
writeln;
 
Line 297 ⟶ 310:
OutIsPractical(5384);
OutIsPractical(1441440);
writeln(Divs.DivsNum, ' has ', Divs.DivsMaxIdx + 1, ' proper divisors');
writeln((GetTickCount64 - T0) / 1000: 10: 3, ' s');
T0 := GetTickCount64;
OutIsPractical(99998640);
writeln(Divs.DivsNum, ' has ', Divs.DivsMaxIdx + 1, ' proper divisors ');
writeln((GetTickCount64 - T0) / 1000: 10: 3, ' s');
T0 := GetTickCount64;
OutIsPractical(99998640);
writeln(Divs.DivsNum, ' has ', Divs.DivsMaxIdx + 1, ' proper divisors ');
writeln((GetTickCount64 - T0) / 1000: 10: 3, ' s');
setlength(HasSum, 0);
{$IFNDEF UNIX} readln; {$ENDIF}
end.</lang>▼
end.
▲end.</lang>
{{out}}
<pre> TIO.RUN.
MaiconSoft
478

edits

Retrieved from "https://rosettacode.org/wiki/Special:MobileDiff/310367"