TAXID - VOI10 - Mã số thuế

Tác giả: flashmt

Ngôn ngữ: Pascal

const fi='';
      maxl=13;
type ar=array[1..maxl,-1..36] of int64;
var n,q:int64;
    m,p,x,y,num,dg:longint;
    f,g,h:ar;
    a,b,c,e:array[1..40] of longint;
    d:array[1..10000] of longint;

procedure calc(var f:ar;x:longint);
var i,j:longint;
begin
     for j:=0 to x-1 do f[1,j]:=1;
     for i:=2 to maxl do
          for j:=0 to x-1 do f[i,j]:=f[i-1,j]*x;
end;

procedure conv;
var i:longint; nn:int64;
begin
     nn:=n;
     while nn>0 do
     begin
          inc(dg);
          b[dg]:=nn mod 36;
          nn:=nn div 36;
     end;
end;

function check(i,x:longint):boolean;
begin
     while i>0 do
     begin
          if i mod 36>=x then exit(false);
          i:=i div 36;
     end;
     check:=true;
end;

procedure wr(x:longint);
var i,j:longint;
begin
     j:=0;
     while x>0 do
     begin
          inc(j);
          e[j]:=x mod 36;
          x:=x div 36;
     end;
     for i:=j downto 1 do
          if e[i]<10 then write(e[i])
          else write(chr(e[i]+87));
     writeln;
end;

procedure vet;
var i,j,sl:longint;
begin
     sl:=0;
     for i:=1 to n do
         if check(i,x) and not check(i,y) then
         begin
              inc(sl);
              d[sl]:=i;
         end;
     if odd(p) then wr(d[q])
     else wr(d[sl-q+1]); halt;
end;

procedure rf;
var i,k,r:longint;
begin
     read(n,m,p,q);
     k:=(m-1) shr 1;
     for i:=1 to k do read(c[i]);
     r:=(p+1) shr 1;
     if r>k then x:=36 else x:=c[r];
     if r>1 then y:=c[r-1] else y:=0;
     if not odd(p) then conv;
     if n<=10000 then vet;
end;

procedure minus;
var i,j:longint;  s,t:boolean;  oo:int64;
begin
     s:=true; t:=true; oo:=100000000; oo:=oo*oo;
     for i:=1 to maxl do
          for j:=0 to x-1 do
               h[i,j]:=f[i,j]-g[i,j];
     for i:=1 to maxl do
          for j:=0 to x-1 do
          begin
               if s then h[i,j]:=h[i,j-1]+h[i,j];
               if h[i,j]>oo then s:=false;
               if t then f[i,j]:=f[i,j-1]+f[i,j];
               if f[i,j]>oo then t:=false;
          end;
end;

procedure find;
var i,j:longint; kt:boolean; res:int64;
begin
     kt:=false; res:=0;
     for i:=dg downto 1 do
     begin
          if kt then
          begin
               if b[i]>=x then
               begin
                    res:=res+f[i,x-1]; break;
               end;
               if i>1 then res:=res+f[i,b[i]-1] else res:=res+f[1,b[i]];
          end
          else
          begin
               if b[i]>=x then
               begin
                    res:=res+h[i,x-1];
                    break;
               end;
               if i>1 then res:=res+h[i,b[i]-1] else res:=res+h[1,b[i]];
               if b[i]>=y then kt:=true;
          end;
     end;
     q:=res-q+1;
end;

procedure pr;
var i,j:longint; kt,z:boolean;
begin
     calc(f,x);
     if y>0 then calc(g,y);
     minus;
     if not odd(p) then find;
     if y=0 then
     begin
          inc(n); inc(q);
     end;
     for num:=1 to maxl do
          if h[num,x-1]>=n then break;
     kt:=false;
     for i:=num downto 1 do
     begin
          for j:=0 to x-1 do
              if kt then
              begin
                   if f[i,j]>=q then
                   begin
                        a[i]:=j;
                        q:=q-f[i,j-1];
                        break;
                   end;
              end
              else
              begin
                   if h[i,j]>=q then
                   begin
                        a[i]:=j;
                        q:=q-h[i,j-1];
                        break;
                   end;
              end;
              if j>=y then kt:=true;
     end;
     z:=false;
     for i:=num downto 1 do
     begin
          if not z and (a[i]=0) then continue;
          if a[i]>0 then z:=true;
          if a[i]<10 then write(a[i])
          else write(chr(a[i]+87));
     end;
end;

begin
     assign(input,fi); reset(input);
     rf;
     pr;
     close(input);
end.

Download