Rosetta Code

Inconsummate numbers in base 10: Difference between revisions

Page Discussion

Inconsummate numbers in base 10 (view source)

Revision as of 07:12, 30 September 2022

926 bytes removed ,  1 year ago
→‎{{header|Free Pascal}}: Faster version checking Digitalsum, testing for max used factor.
m (→‎{{header|Wren}}: Changes to preamble and made second version more compact.)
(→‎{{header|Free Pascal}}: Faster version checking Digitalsum, testing for max used factor.)
Line 220:
=={{header|Pascal}}==
==={{header|Free Pascal}}===
Inconsummate numbers are not a divisor of a niven number.<br>
Therefore I tried a solution [[Harshad_or_Niven_series | niven number]].<br>
There is only a small increase in the needed factor in count of Inconsummate numbers
<syntaxhighlight lang=pascal>
program Inconsummate;
 
{$IFDEF FPC}
{$MODE DELPHI}{$OPTIMIZATION ON,ALL}{$CODEALIGN proc=8,loop=1}
{$ENDIF}
 
uses
SysUtilssysutils;
 
const
base = 10;
DgtSumLmt = base*base*base*base*base;
 
type
// tNumtDgtSum = array[0..250DgtSumLmt-1] *of 1000byte;// 6996
var
// tNum = 0..260 * 10000;// 59837
DgtSUm : tDgtSum;
// tNum = 0..290 * 100000;//536081
max: Uint64;
tNum = 0..319 * 1000000;//5073249
procedure Init(var ds:tDgtSum);
var
i,l,k0,k1: NativeUint;
Begin
For i := 0 to base-1 do
ds[i] := i;
k0 := base;
repeat
k1 := k0-1;
For i := 1 to base-1 do
For l := 0 to k1 do
begin
ds[k0] := ds[l]+i;
inc(k0);
end;
until k0 >= High(ds);
end;
 
const
cntbasedigits = 16;//trunc(ln(High(tNum)) / ln(base)) + 1;
 
function GetSumOfDecDigits(n:Uint64):NativeUint;
type
tSumDigit = record
sdDigits: array[0..cntbasedigits - 1] of byte;
sdSumDig: uint32;
sdNumber: tNum;
sdDiv: tNum;
sdIsNiven: boolean;
end;
var
r,d: NativeUint;
isN: array[0..High(tNUm) div 1 + 1] of boolean;
begin
result := 0;
repeat
r := n DIv DgtSumLmt;
d := n-r* DgtSumLmt;
result +=DgtSUm[d];
n := r;
until r = 0;
end;
 
function InitSumDigitOneTest(n: tNumNativeint): tSumDigitBoolean;
var
i,d sd: tSumDigitNativeInt;
begin
qt: tNum;
result i:= integertrue;
d := n;
For i := 1 TO 121 DO
begin
IF GetSumOfDecDigits(n)= i then
with sd do
beginBegin
sdNumberif :=i n;> max then
max := i;
fillchar(sdDigits, SizeOf(sdDigits), #0);
Exit(false);
 
sdSumDig := 0;
sdIsNiven := False;
i := 0;
// calculate Digits und sum them up
while n > 0 do
begin
qt := n div base;
{n mod base}
sdDigits[i] := n - qt * base;
Inc(sdSumDig, sdDigits[i]);
n := qt;
Inc(i);
end;
if sdSumDig > 0 then
sdIsNiven := (sdNumber mod sdSumDig = 0);
end;
InitSumDigit := sd;
end;
 
procedure IncSumDigit(var sd: tSumDigit);
var
pD: pbyte;
i, d, s: uint32;
begin
i := 0;
pD := @sd.sdDigits[0];
with sd do
begin
s := sdSumDig;
Inc(sdNumber);
repeat
d := pD[i];
Inc(d);
Inc(s);
//base-1 times the repeat is left here
if d < base then
begin
pD[i] := d;
BREAK;
end
else
begin
pD[i] := 0;
Dec(s, base);
Inc(i);
end;
until i > high(sdDigits);
sdSumDig := s;
i := sdNumber div s;
sdDiv := i;
sdIsNiven := (sdNUmber - i * s) = 0;
end;
n +=d;
end;
end;
 
var
d,
MySumDig: tSumDigit;
lnncnt,lmt: tNumUint64;
Limit, cnt: integer;
 
begin
Init(DgtSUm);
{$IFNDEF FPC}
cntbasedigits := trunc(ln(High(tNum)) / ln(base)) + 1;
{$ENDIF}
MySumDig := InitSumDigit(0);
cnt := 0;
For d := 1 to 527 do//5375540350 do
with MySumDig do
begin
repeat
if IncSumDigitOneTest(MySumDigd); then
if sdIsNiven then
isN[sdDiv] := True;
until sdnumber > High(tNum) - 1;
 
limit := 10;
for lnn := 1 to High(isN) - 1 do
if not (isN[lnn]) then
begin
Incinc(cnt);
Writewrite(lnnd: 5);
if (cnt mod 10 = limit)0 then writeln;
begin
writeln;
Inc(limit, 10);
end;
if cnt >= 50 then
BREAK;
end;
end;
writeln;
writeln('Count Number(count) Maxfactor needed');
 
limitcnt := 1000;
max := 0;
for lnn := lnn + 1 to High(isN) - 1 do
lmt := 10;
if not (isN[lnn]) then
For d := 1 to 50332353 do // 5260629551 do
begin
if OneTest(d) then
begin
Incinc(cnt);
if cnt = limitlmt then
begin
Writelnwriteln(limitcnt: 10, lnnd: 1012,max:5);
limitlmt *= 10;
if limit > 1000 * 1000 then
EXIT;
end;
end;
writelnend;
writeln(cnt);
end.
</syntaxhighlight>
{{out|@TIO.RUN}}
<pre>
<pre> 62 63 65 75 84 95 161 173 195 216
62 63 65 75 84 95 161 173 195 216
261 266 272 276 326 371 372 377 381 383
386 387 395 411 416 422 426 431 432 438
Line 379 ⟶ 328:
491 492 493 494 497 498 516 521 522 527
 
Count Number(count) Maxfactor needed
100 936
1000 10 6996 216 27
10000 100 59853 936 36
100000 1000 536081 6996 36
10000 59853 54
1000000 5073249
100000 536081 63
1000000 5073249 69
10000000 50332353 81
10000000
Real time: 23.898 s
 
@Home AMD 5600G 4.4 Ghz:
Count Number(count) Maxfactor needed
10 216 27
100 936 36
1000 6996 36
10000 59853 54
100000 536081 63
1000000 5073249 69
10000000 50332353 81 //real 0m6,395s
100000000 517554035 87
1000000000 5260629551 96
1000000000
 
real 15m54,915s
Real time: 3.342 s CPU share: 99.16 %
</pre>
 
Horst H
4

edits

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