Inconsummate numbers in base 10: Difference between revisions

Content added Content deleted
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: Line 220:
=={{header|Pascal}}==
=={{header|Pascal}}==
==={{header|Free 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>
<syntaxhighlight lang=pascal>
program Inconsummate;
program Inconsummate;

{$IFDEF FPC}
{$IFDEF FPC}
{$MODE DELPHI}{$OPTIMIZATION ON,ALL}{$CODEALIGN proc=8,loop=1}
{$MODE DELPHI}{$OPTIMIZATION ON,ALL}{$CODEALIGN proc=8,loop=1}
{$ENDIF}
{$ENDIF}

uses
uses
SysUtils;
sysutils;

const
const
base = 10;
base = 10;
DgtSumLmt = base*base*base*base*base;

type
type
// tNum = 0..250 * 1000;// 6996
tDgtSum = array[0..DgtSumLmt-1] of byte;
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
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 InitSumDigit(n: tNum): tSumDigit;
function OneTest(n:Nativeint):Boolean;
var
var
sd: tSumDigit;
i,d : NativeInt;
begin
qt: tNum;
i: integer;
result := true;
d := n;
For i := 1 TO 121 DO
begin
begin
IF GetSumOfDecDigits(n)= i then
with sd do
begin
Begin
sdNumber := n;
if i > 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;
end;
n +=d;
end;
end;
end;


var
var
d,
MySumDig: tSumDigit;
lnn: tNum;
cnt,lmt: Uint64;
Limit, cnt: integer;

begin
begin
Init(DgtSUm);
{$IFNDEF FPC}
cntbasedigits := trunc(ln(High(tNum)) / ln(base)) + 1;
{$ENDIF}
MySumDig := InitSumDigit(0);
cnt := 0;
cnt := 0;
For d := 1 to 527 do//5375540350 do
with MySumDig do
begin
repeat
IncSumDigit(MySumDig);
if OneTest(d) 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
begin
Inc(cnt);
inc(cnt);
Write(lnn: 5);
write(d:5);
if (cnt = limit) then
if cnt mod 10 = 0 then writeln;
begin
writeln;
Inc(limit, 10);
end;
if cnt >= 50 then
BREAK;
end;
end;
end;
writeln;
writeln;
writeln('Count Number(count) Maxfactor needed');

limit := 100;
cnt := 0;
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
begin
Inc(cnt);
inc(cnt);
if cnt = limit then
if cnt = lmt then
begin
begin
Writeln(limit: 10, lnn: 10);
writeln(cnt:10,d:12,max:5);
limit *= 10;
lmt *=10;
if limit > 1000 * 1000 then
EXIT;
end;
end;
end;
end;
writeln;
end;
writeln(cnt);
writeln(cnt);
end.
end.
</syntaxhighlight>
</syntaxhighlight>
{{out|@TIO.RUN}}
{{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
261 266 272 276 326 371 372 377 381 383
386 387 395 411 416 422 426 431 432 438
386 387 395 411 416 422 426 431 432 438
Line 379: Line 328:
491 492 493 494 497 498 516 521 522 527
491 492 493 494 497 498 516 521 522 527


Count Number(count) Maxfactor needed
100 936
1000 6996
10 216 27
10000 59853
100 936 36
100000 536081
1000 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>
</pre>


Retrieved from "https://rosettacode.org/wiki/Inconsummate_numbers_in_base_10"