SkullBox Forum  |  Development  |  Delphi & Pascal  |  Topic: ordinea lexicografica a permutarilor

const
  n=4;
type
  tv=array[1..n] of 1..n;
const
  v:tv=(4,2,3,1);

function perm(n:byte):longint;
var i:byte;
    p:longint;
begin
  p:=1;
  for i:=1 to n do p:=p*i;
  perm:=p;
end;

function p2n:longint;
var i,j:byte;
    x:longint;
    w:tv;
begin
  w:=v;
  x:=1;
  for i:=1 to n do begin
    x:=x+perm(n-i)*(w[i]-1);
    for j:=i+1 to n do if w[j]>w[i] then dec(w[j]);
  end;
  p2n:=x;
end;

begin
  write(p2n);
  readln;
end.

const
  n=4;
var
  v:array[1..n] of 1..n;
  x:longint;
  i,j:byte;

function perm(n:byte):longint;
var i:byte;
    p:longint;
begin
  p:=1;
  for i:=1 to n do p:=p*i;
  perm:=p;
end;

procedure n2p;
var i,j,k,t:byte;
    p:longint;
begin
  for i:=1 to n do v[i]:=i;
  for i:=1 to n-1 do
  if x>perm(n-i) then begin
    p:=perm(n-i);
    k:=(x-1) div p;
    x:=1+(x-1) mod p;
    t:=v[i+k];
    for j:=i+k downto i+1 do v[j]:=v[j-1];
    v[i]:=t;
  end;
end;

begin
  write('x='); readln(x);{}
  n2p;
  for i:=1 to n do write(v[i]:3);
  readln;
  end;{}
end.

const
  n=4;
  k=3;
type
  vt=array[1..k] of 1..n;
const
  v:vt=(4,2,3);

function aranj(n,k:byte):longint;
var i:byte;
    x:longint;
begin
  x:=1;
  for i:=n-k+1 to n do x:=x*i;
  aranj:=x;
end;

function a2n:longint;
var i,j:byte;
    x:longint;
    w:vt;
begin
  w:=v; x:=1;
  for i:=1 to k do begin
    x:=x+aranj(n-i,k-i)*(w[i]-1);
    for j:=i+1 to k do if w[j]>w[i] then dec(w[j]);
  end;
  a2n:=x;
end;

begin
  write(a2n);
  readln;
end.

const
  n=4;
  k=3;
var
  v:array[1..k] of 1..n;
  x:longint;
  i:byte;

function aranj(n,k:byte):longint;
var i:byte;
    x:longint;
begin
  x:=1;
  for i:=n-k+1 to n do x:=x*i;
  aranj:=x;
end;

procedure n2a;
var i,j,c,p:byte;
    d:array[1..n] of 0..1;
    a:longint;
begin
  for i:=1 to n do d[i]:=1;
  for i:=1 to k do begin
    a:=aranj(n-i,k-i);
    p:=1+(x-1) div a;
    x:=1+(x-1) mod a;
    c:=0;
    for j:=1 to p do repeat inc(c) until d[c]=1;
    d[c]:=0;
    v[i]:=c;
  end;
end;

begin
  write('x='); readln(x);
  n2a;
  for i:=1 to k do write(v[i]:3);
  readln;
end.

const
  n=7;
  k=4;
  v:array[1..k] of byte=(3,4,5,7);

function cnk(n,k:byte):longint;
var i,a,b:byte;
    c:longint;
begin
  c:=1; a:=k; b:=a;
  if a>n-a then a:=n-a else b:=n-b;
  for i:=b+1 to n do c:=c*i;
  for i:=2 to a do c:=c div i;
  cnk:=c;
end;

function c2n:longint;
var x:longint;
    i,j:byte;
begin
  x:=1;
  for i:=v[1]-1 downto 1 do x:=x+cnk(n-i,k-1);
  for i:=2 to k do
  for j:=v[i]-1 downto v[i-1]+1 do x:=x+cnk(n-j,k-i);
  c2n:=x;
end;

begin
  write(c2n);
  readln;
end.

const
  n=7;
  k=4;
var
  v:array[1..k] of 1..n;
  x:longint;
  i:byte;

function cnk(n,k:byte):longint;
var i,a,b:byte;
    c:longint;
begin
  c:=1; a:=k; b:=a;
  if a>n-a then a:=n-a else b:=n-b;
  for i:=b+1 to n do c:=c*i;
  for i:=2 to a do c:=c div i;
  cnk:=c;
end;

procedure n2c;
var i,j:byte;
begin
  for i:=1 to k do v[i]:=i;
  dec(x);
  for i:=1 to k do
  while x>=cnk(n-v[i],k-i) do begin
    x:=x-cnk(n-v[i],k-i);
    inc(v[i]);
    for j:=i+1 to k do v[j]:=v[j-1]+1;
  end;
end;

begin
  write('x='); readln(x);
  n2c;
  for i:=1 to k do write(v[i]:3);
  readln;
end.