Colorful numbers: Difference between revisions

=={{header|Pascal}}==

==={{header|Free Pascal}}===

I've created a lexical permutation of [2,3,4,5,6,7,8,9] which results in 40320 arrangements.<br>

So 0,1 are missing. The test of 3 digits is simple a test of the first three digits of these arrangments every delta = (8-3)! = 120 (for one digit = (8-1)! = 5040 ).<BR>

At home, the [[#C|C]]-Version compiled with -Ofast is still faster with best 15.03 ms vs 17ms of my version<br>But such short timings differ extrem from run to run.

<syntaxhighlight lang="pascal">

{$IFDEF FPC}

{$mode Delphi}

{$Optimization ON,All}

{$Coperators ON}

{$CODEALIGN proc=1,loop=1}

{$ENDIF}

{$IFDEF WINDOWS}

{$APPTYPE CONSOLE}

{$ENDIF}

uses

sysutils;

const

EightFak = 1*2*3*4*5*6*7*8;

type

tDgt = Int8;

tpDgt = pInt8;

tDgtfield = array[0..7] of tdgt;

tPermfield = tDgtfield;

tAllPermDigits = array[0..EightFak-1] of tDgtfield;

tMarkNotColorful = array[0..EightFak-1] of byte;

tDat = Uint32;

tDatfield = array[0..0] of tdat;

tpDat =^tDatfield;

tusedMultiples = array[0..8*9 DIV 2] of tDat;

var

AllPermDigits :tAllPermDigits;

MarkNotColorful:tMarkNotColorful;

permcnt: NativeUint;

totalCntColorFul,CntColorFul : Int32;

procedure OutNum(const num:tPermfield;dgtCnt: Int32);

var

i : integer;

Begin

For i := 0 to dgtcnt-1 do

write(num[i]);

writeln;

end;

function Check(pDat :tpDat; maxIdx : Int32;dat :tDat):boolean;

var

I : Int32;

begin

i := maxIdx;

if i>= 0 then

repeat

if dat = pDat[i] then

EXIT(true);

Dec(i);

until i

<0;

pDat[maxIdx+1]:= dat;

result := false;

end;

function CheckColorful(dgtCnt: NativeInt;idx:Int32):boolean;

var

usedMultiples : tusedMultiples;

pDgtfield : ^tDgtfield;

TestDgtCnt,StartIdx,l,value,maxIdx : Int32;

begin

IF MarkNotColorful[idx] <> 0 then

EXIT(false);

pDgtfield := @AllPermDigits[idx];

maxIdx := -1;

// needn't to test product of all digits.It's a singular max value

dec(dgtCnt);

//multiples of TestDgtCnt digits next to one another

For TestDgtCnt := 0 to dgtCnt do

begin

For StartIdx := 0 to dgtCnt-TestDgtCnt do

begin

value := 1;

For l := 0 to TestDgtCnt do

value *=pDgtfield[StartIdx+l];

if Check(@usedMultiples[0],maxIdx,value) then

begin

MarkNotColorful[idx] := dgtcnt+1;

EXIT(false);

end;

inc(MaxIdx);

end;

end;

inc(totalCntColorFul);

inc(CntColorFul);

result := true;

end;

procedure PermLex(n: Int32;StartVal:Int8);

var

Perm : tPermField;

k,j : Int32;

temp: tDgt;

pDat :tpDgt;

begin

For j := 0 to n-1 do

Perm[j]:= j+StartVal;

permcnt := 0;

dec(n);

repeat

AllPermDigits[permcnt] := Perm;

inc(permcnt);

k := N-1;

pDat := @Perm[k];

while (pDat[0]> pDat[1]) And (k >=Low(Perm) ) do

begin

dec(pDat);

dec(k);

end;

if k >= Low(Perm) then

begin

j := N;

pDat := @Perm[j];

temp := Perm[k];

while (temp > pDat[0]) And (J >K) do

begin

dec(j);

dec(pDat);

end;

Perm[k] := pDat[0];

pDat[0] := temp;

j := N;

pDat := @Perm[j];

Inc(k);

while j>k do

begin

temp := pDat[0];

pDat[0] := Perm[k];

Perm[k] := temp;

dec(j);

dec(pDat);

inc(k);

end;

end

else

break;

until false;

end;

procedure CheckDgtCnt(dgtCnt,delta:Int32);

var

i : int32;

begin

i := 0;

CntColorFul := 0;

if dgtCnt = 1 then

CntColorFul := 2;//0,1

while i <= High(AllPermDigits) do

begin

CheckColorful(dgtCnt,i);

inc(i,delta);

end;

end;

var

T0 : Int64;

i,j,delta: INteger;

Begin

T0 := GetTickCount64;

PermLex(8,2);

delta := EightFak-1;

//takes ~1 ms til here

Writeln(' digits count');

totalCntColorFul := 2;//0,1,

delta := (delta+1) DIV 8;

j := 7;

repeat

CheckDgtCnt(8-j,delta);

writeln(8-j:10,CntColorFul:10);

if j = 0 then

BREAK;

delta := delta DIV j;

dec(j);

until false;

Writeln('Total number of colorful numbers: ',totalCntColorFul);

Write('Highest Value :');

For i := High(AllPermDigits) downto low(AllPermDigits) do

if MarkNotColorful[i] = 0 then

Begin

OutNum(AllPermDigits[i],8);

BREAK;

end;

Writeln('Runtime in ms ',GetTickCount64-T0);

end.

</syntaxhighlight>

{{out|@TIO.RUN}}

<pre>

digits count

1 10

2 56

3 328

4 1540

5 5514

6 13956

7 21596

8 14256

Total number of colorful numbers: 57256

Highest Value :98746253

Runtime in ms 27</pre>