Rosetta Code

Disarium numbers: Difference between revisions

Page Discussion

Disarium numbers (view source)

Revision as of 14:05, 4 January 2023

1,597 bytes added ,  1 year ago
m
→‎{{header|Free Pascal}}: correct by accident correct value for base 10.Now run correct in Base 11 too
(Added 11l)
m (→‎{{header|Free Pascal}}: correct by accident correct value for base 10.Now run correct in Base 11 too)
Line 1,933:
<syntaxhighlight lang="pascal">
program disarium;
//compile with fpc -O3 -Xs
{$IFDEF WINDOWS}
{$APPTYPE CONSOLE}
Line 1,938 ⟶ 1,939:
{$IFDEF FPC}
{$Mode Delphi}
// {$R+,O+}
{$Optimization ON,ALL}
uses
sysutils;
Line 1,948 ⟶ 1,947:
const
MAX_BASE = 16;
cDigits : array[0..MAX_BASE-1] of char =
MAX_DIGIT_CNT = 20;
('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F');
 
MAX_DIGIT_CNT = 31;
 
type
tDgt_cnt= 0..MAX_DIGIT_CNT-1;
tdgtPows = array[tDgt_cnt,0..MAX_BASE] of Uint64;
tdgtMaxSumPot = array[tDgt_cnt] of Uint64;
tmyDigits = record
digitdgtPot : array[0..31tDgt_cnt] of byteUint64;
dgtSumPot : array[tDgt_cnt] of Uint64;
dgtNumber : UInt64;
dgtMaxLendigit : Uint64array[0..31] of byte;
dgtMaxLen : tDgt_cnt;
end;
tdgtPows = array[0..MAX_BASE-1,tDgt_cnt] of Uint64;
 
const
ONE_BILLIONUPPER_LIMIT = 1000100*1000*10001002;
 
var
Line 1,966 ⟶ 1,971:
dgtPows :tdgtPows;
 
procedure InitMyPots(var mp :tdgtPows;base:int32);
var
jpot,dgt:Uint32;
p : Uint64;
begin
fillchar(mp,SizeOf(mp),#0);
For dgt := 0 to MAX_BASE-1 do
For dgt := 0 to BASE do
begin
p := dgt;
For jpot :=in 0 to 19tDgt_cnt do
begin
mp[dgtpot,jdgt] := p;
p := p*dgt;
end;
end;
p := 0;
end;
 
procedure Out_Digits(constvar md:tmyDigits);
var
i : Int32;
Line 1,988 ⟶ 1,995:
with md do
begin
write('dgtNumber ',dgtNumber,' = ',dgtSumPot[0],' in Base ');
For i := dgtMaxLen-1 downto 10 do write(digit[i]:2,'|');
writeln write(cDigits[digit[0i]]:2);
writeln;
end;
end;
 
procedure IncLoopIncByOne(var md:tmyDigits;Base: Int32);inline;
var
PotSum : Uint64;
potBase: nativeInt;
dg,idx,pot,idx : Int32;
 
Begin
with md do
begin
dg :=//first digit[0]+1; seperate
pot := dgtMaxLen-1;
dg := digit[0]+1;
if dg < BASE then
begin
inc(dgtNumber);
digit[0]:= dg;
dgtSumPotdgtPot[0] := dgtSumPot[1] + dgtPows[pot,dg,pot];
dgtSumPot[0] := dgtSumPot[1] + dgtPot[0];
EXIT;
end;
 
dec(dgtNumber,Base-1);
digit[0]:= 0;
dgtPot[0]:= 0;
dgtSumPot[0] := dgtSumPot[1];
potbase := Base;
 
potbase := Base;
idx := 1;
dec(pot);
Line 2,024 ⟶ 2,038:
inc(dgtNumber,potbase);
digit[idx]:= dg;
dgtSumPotdgtPot[idx] := dgtSumPot[idx+1] + dgtPows[pot,dg,pot];
PotSum := dgtSumPot[idx+1];
//update sum
while idx>=0 do
begin
inc(PotSum,dgtPot[idx]);
dgtSumPot[idx] := PotSum;
dec(idx);
end;
EXIT;
end;
dec(dgtNumber,(dg-1)*PotBase);//+ord(dg<>Base));
potbase *= Base;
digit[idx]:= 0;
dgtSumPotdgtPot[idx] := dgtSumPot[idx+1]0;
dec(pot);
inc(idx);
end;
 
For pot := idx-1 downto 0 do
Begin
dgtSumPot[pot] := 0;
dgtPot[idx] :=0;
dgtSumPot[pot] := 1;
end;
digit[idx] := 1;
dgtSumPotdgtPot[idx] := 1;
dgtMaxLen := idx+1;
dgtNumber := potbase;
end;
end;
 
procedure OneRun(var s: tmyDigits;base:UInt32);
procedure OneRun(var s: tmyDigits;base:UInt32;Limit:Int64);
var
cnt,i : int64;
cnt : Int32;
begin
Writeln('Base = ',base);
InitMyPots(dgtPows,base);
fillchar(s,SizeOf(s),#0);
s.dgtMaxLen := 1;
 
i := 0;
cnt := -(Base-1)0;
repeat
IncLoop(s,base);//IncIntStr(base,s);
inc(i);
if s.dgtSumPot[0] = s.dgtNumber then
Begin
Line 2,057 ⟶ 2,087:
inc(cnt);
end;
IncByOne(s,base);
until (i>ONE_BILLION) OR (cnt>=8);
inc(i);
writeln ( i,' increments and found ',cnt+Base-1);
until (i>=Limit);
writeln ( i,' increments and found ',cnt);
end;
 
Line 2,064 ⟶ 2,096:
{$Align 32}
s : tmyDigits;
base : nativeInt;
T0: TDateTime;
base: nativeInt;
Begin
InitMyPots(dgtPows);
fillchar(s,SizeOf(s),#0);
s.dgtMaxLen := 1;
T0 := time;
base := 10;
T0 := time;
OneRun(s,base);
OneRun(s,base,2646799);
T0 := (time-T0)*86400;
writeln(T0:8:3,' s');
writeln;
 
base := 11;
T0 := time;
OneRun(s,base,100173172);
T0 := (time-T0)*86400;
writeln(T0:8:3,' s');
Line 2,080 ⟶ 2,116:
{$ENDIF}
end.
 
</syntaxhighlight>
{{out|@TIO.RUN}}
<pre>
Base = 10
dgtNumber 1 = 1 1
dgtNumber 20 = 20 in 2Base 0
dgtNumber 31 = 31 in 3Base 1
dgtNumber 42 = 42 in 4Base 2
dgtNumber 53 = 53 in 5Base 3
dgtNumber 64 = 64 in 6Base 4
dgtNumber 75 = 75 in 7Base 5
dgtNumber 86 = 86 in 8Base 6
dgtNumber 97 = 97 in 9Base 7
dgtNumber 898 = 898 in 8|Base 98
dgtNumber 1359 = 1359 in 1|Base 3| 59
dgtNumber 17589 = 17589 in 1|Base 7| 589
dgtNumber 518135 = 518135 in 5|Base 1| 8135
dgtNumber 598175 = 598175 in 5|Base 9| 8175
dgtNumber 1676518 = 1676518 in 1|Base 6| 7| 6518
dgtNumber 2427598 = 2427598 in 2|Base 4| 2| 7598
dgtNumber 26467981306 = 26467981306 in 2|Base 6| 4| 6| 7| 9| 81306
dgtNumber 1676 = 1676 in Base 1676
2646798 increments and found 17
dgtNumber 2427 = 2427 in Base 2427
dgtNumber 2646798 = 2646798 in Base 2646798
2646799 increments and found 19
0.008 s
 
Base = 11
dgtNumber 0 = 0 in Base 0
dgtNumber 1 = 1 in Base 1
dgtNumber 2 = 2 in Base 2
dgtNumber 3 = 3 in Base 3
dgtNumber 4 = 4 in Base 4
dgtNumber 5 = 5 in Base 5
dgtNumber 6 = 6 in Base 6
dgtNumber 7 = 7 in Base 7
dgtNumber 8 = 8 in Base 8
dgtNumber 9 = 9 in Base 9
dgtNumber 10 = 10 in Base A
dgtNumber 27 = 27 in Base 25
dgtNumber 39 = 39 in Base 36
dgtNumber 109 = 109 in Base 9A
dgtNumber 126 = 126 in Base 105
dgtNumber 525 = 525 in Base 438
dgtNumber 580 = 580 in Base 488
dgtNumber 735 = 735 in Base 609
dgtNumber 1033 = 1033 in Base 85A
dgtNumber 1044 = 1044 in Base 86A
dgtNumber 2746 = 2746 in Base 2077
dgtNumber 59178 = 59178 in Base 40509
dgtNumber 63501 = 63501 in Base 43789
dgtNumber 100173171 = 100173171 in Base 515AA64A
100173172 increments and found 24
0.294 s
</pre>
 
=={{header|Perl}}==
<syntaxhighlight lang="perl">use strict;
Horst
132

edits

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