Anonymous user
Factorions: Difference between revisions
added pascal
No edit summary |
(added pascal) |
||
Line 773:
print_string "\n\n";
done</lang>
=={{header|Pascal}}==
modified [[munchhausen numbers#Pascal]].
output in base and 0! == 1!, so in Base 10 40585 has the same digits as 14558.
<lang pascal>
program munchhausennumber;
{$IFDEF FPC}{$MODE objFPC}{$ELSE}{$APPTYPE CONSOLE}{$ENDIF}
uses
sysutils;
type
tdigit = byte;
const
MAXBASE = 14;
var
DgtPotDgt : array[0..MAXBASE-1] of NativeUint;
dgtCnt : array[0..MAXBASE-1] of NativeInt;
cnt: NativeUint;
function convertToString(n:NativeUint;base:byte):AnsiString;
const
cBASEDIGITS = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvxyz';
var
r,dgt: NativeUint;
begin
IF base > length(cBASEDIGITS) then
EXIT('Base to big');
result := '';
repeat
r := n div base;
dgt := n-r*base;
result := cBASEDIGITS[dgt+1]+result;
n := r;
until n =0;
end;
function CheckSameDigits(n1,n2,base:NativeUInt):boolean;
var
i : NativeUInt;
Begin
fillchar(dgtCnt,SizeOf(dgtCnt),#0);
repeat
//increment digit of n1
i := n1;n1 := n1 div base;i := i-n1*base;inc(dgtCnt[i]);
//decrement digit of n2
i := n2;n2 := n2 div base;i := i-n2*base;dec(dgtCnt[i]);
until (n1=0) AND (n2= 0);
result := true;
For i := 2 to Base-1 do
result := result AND (dgtCnt[i]=0);
end;
procedure Munch(number,DgtPowSum,minDigit:NativeUInt;digits,base:NativeInt);
var
i: NativeUint;
s1,s2: AnsiString;
begin
inc(cnt);
number := number*base;
IF digits > 1 then
Begin
For i := minDigit to base-1 do
Munch(number+i,DgtPowSum+DgtPotDgt[i],i,digits-1,base);
end
else
For i := minDigit to base-1 do
//number is always the arrangement of the digits leading to smallest number
IF (number+i)<= (DgtPowSum+DgtPotDgt[i]) then
IF CheckSameDigits(number+i,DgtPowSum+DgtPotDgt[i],base) then
iF number+i>0 then
begin
s1 := convertToString(DgtPowSum+DgtPotDgt[i],base);
s2 := convertToString(number+i,base);
If length(s1)= length(s2) then
writeln(Format('%*s %*s',[Base-1,s1,Base-1,s2]));
end;
end;
//factorions
procedure InitDgtPotDgt(base:byte);
var
i: NativeUint;
Begin
DgtPotDgt[0]:= 1;
For i := 1 to Base-1 do
DgtPotDgt[i] := DgtPotDgt[i-1]*i;
DgtPotDgt[0]:= 0;
end;
{
//Munchhausen numbers
procedure InitDgtPotDgt;
var
i,k,dgtpow: NativeUint;
Begin
// digit ^ digit ,special case 0^0 here 0
DgtPotDgt[0]:= 0;
For i := 1 to Base-1 do
Begin
dgtpow := i;
For k := 2 to i do
dgtpow := dgtpow*i;
DgtPotDgt[i] := dgtpow;
end;
end;
}
var
base : byte;
begin
cnt := 0;
For base := 2 to 14 do
begin
writeln('Base = ',base);
InitDgtPotDgt(base);
Munch(0,0,0,base-1,base);
end;
writeln('Check Count ',cnt);
end.</lang>
{{out}}
<pre>
Base = 2
1 1
Base = 3
1 1
2 2
Base = 4
1 1
2 2
13 13
Base = 5
1 1
2 2
144 144
Base = 6
1 1
2 2
41 14
42 24
Base = 7
1 1
2 2
Base = 8
1 1
2 2
Base = 9
1 1
2 2
62558 25568
Base = 10
1 1
2 2
145 145
40585 14558
Base = 11
1 1
2 2
24 24
44 44
28453 23458
Base = 12
1 1
2 2
Base = 13
1 1
2 2
83790C5B 135789BC
Base = 14
1 1
2 2
8B0DD409C 11489BCDD
Check Count 13027729
</pre>
=={{header|Perl}}==
{{trans|Raku}}
| |||