SHTH - Số hiệu tổ hợp
Tác giả: RR
Ngôn ngữ: Pascal
{$R+,Q+}
uses math;
const
FINP='';
FOUT='';
MAXN=101;
MAXM=301;
oo=100000000;
type
bigNum=array[0..MAXN] of longint;
var
f1,f2:text;
procedure print(a:bigNum);
var
i:longint;
s:string;
begin
if a[0]=0 then begin writeln(f2,0); exit; end;
write(f2,a[MAXN-a[0]+1]);
for i:=MAXN-a[0]+2 to MAXN do
begin
str(a[i],s);
while length(s)<8 do s:='0'+s;
write(f2,s);
end;
writeln(f2);
end;
operator <(a,b:bigNum) c:boolean;
var
i:longint;
begin
if a[0]<b[0] then exit(true)
else if a[0]>b[0] then exit(false);
for i:=MAXN-a[0]+1 to MAXN do
if a[i]<b[i] then exit(true)
else if a[i]>b[i] then exit(false);
exit(false);
end;
operator +(a,b:bigNum) c:bigNum;
var
nho,i:longint;
begin
nho:=0;
fillchar(c,sizeof(c),0); c[0]:=max(a[0],b[0]);
for i:=MAXN downto MAXN-c[0]+1 do
begin
c[i]:=a[i]+b[i]+nho;
nho:=c[i] div oo;
c[i]:=c[i] mod oo;
end;
if nho>0 then
begin
inc(c[0]);
c[MAXN-c[0]+1]:=nho;
end;
end;
operator -(var a,b:bigNum) c:bigNum;
var
nho,i:longint;
begin
nho:=0;
fillchar(c,sizeof(c),0); c[0]:=a[0];
for i:=MAXN downto MAXN-c[0]+1 do
begin
c[i]:=a[i]-b[i]-nho;
if c[i]<0 then
begin
nho:=1;
c[i]:=c[i]+oo;
end
else nho:=0;
end;
while (c[0]>0) and (c[MAXN-c[0]+1]=0) do dec(c[0]);
end;
procedure trans(s:ansistring;var a:bigNum);
var
ss:ansistring;
code:integer;
begin
fillchar(a,sizeof(a),0);
while length(s)>7 do
begin
ss:=copy(s,length(s)-7,8);
delete(s,length(s)-7,8);
val(ss,a[MAXN-a[0]],code);
inc(a[0]);
end;
if length(s)>0 then
begin
val(s,a[MAXN-a[0]],code);
inc(a[0]);
end;
end;
var
xet,a:array[0..MAXM] of longint;
c:array[0..MAXM,0..MAXM] of bigNum;
tt:bigNum;
n,k:longint;
procedure openF;
begin
assign(f1,FINP); reset(f1);
assign(f2,FOUT); rewrite(f2);
end;
procedure closeF;
begin
close(f1); close(f2);
end;
procedure inp;
var
i,j:longint;
begin
readln(f1,n,k);
c[0,0][0]:=1; c[0,0][MAXN]:=1;
for i:=1 to MAXM do
begin
c[i,0][0]:=1; c[i,0][MAXN]:=1;
c[i,i][0]:=1; c[i,i][MAXN]:=1;
end;
for i:=1 to MAXM do
for j:=1 to i-1 do
c[i,j]:=c[i-1,j-1]+c[i-1,j];
end;
procedure solve1;
var
s:ansistring;
u,i:longint;
begin
readln(f1,s);
trans(s,tt);
for i:=1 to k do
begin
u:=a[i-1]+1; while xet[u]=1 do inc(u);
while (c[n-u,k-i]<tt) do
begin
tt:=tt-c[n-u,k-i];
inc(u); while xet[u]=1 do inc(u);
end;
xet[u]:=1; a[i]:=u;
end;
for i:=1 to k do
write(f2,a[i],' ');
writeln(f2);
end;
procedure solve2;
var
i,u,count:longint;
begin
fillchar(xet,sizeof(xet),0);
fillchar(tt,sizeof(tt),0);
for i:=1 to k do read(f1,a[i]);
xet[0]:=1;
for i:=1 to k do
begin
u:=a[i-1]; while xet[u]=1 do inc(u); count:=0;
while (u<a[i]) do
begin
if xet[u]=0 then tt:=tt+c[n-u,k-i];
inc(u);
end;
xet[a[i]]:=1;
end;
print(tt+c[0,0]);
end;
begin
openF;
inp;
solve1;
solve2;
closeF;
end.