{This works}
program ex(input,output);
var first,i,j,k,kk,i1,n,count,k1,k2:integer;
    a,q,m,up,down,s,start,last,graft,mark,cc,bound:array[0..20] of integer;
    next:array[1..20,1..20] of integer;
procedure out;
var k:integer;
begin
  for k:=1 to n do write(q[k]:2);
  write(' c=',count:2);
  {readln;}
  writeln;
end;
procedure swap(i,j:integer);
var w:integer;
begin
  w:=q[i]; q[i]:=q[j]; q[j]:=w;
  count:=count+1;
  out;
end;
procedure perm;
begin
  repeat
    if (start[i-1]=1) and (up[i-1]=i-1) then begin
      cc[i-1]:=1; bound[i-1]:=1;
      start[i-1]:=0;
      if cc[i-1]=1 then if q[i]<>q[i-1] then begin
        bound[i-1]:=bound[i-1]+1;
        next[i-1,bound[i-1]]:=q[i];
      end;
    end;
    if cc[i]<bound[i] then begin
      start[i]:=0;
      swap(i,s[i]);
{      mark[i]:=0; }
      next[s[i],1]:=q[s[i]];
      cc[i]:=cc[i]+1;
      if cc[i-1]=1 then if q[i]<>q[i-1] then begin
        bound[i-1]:=bound[i-1]+1; next[i-1,bound[i-1]]:=q[i];
      end;
      s[i]:=0;
    end;
    graft[i]:=0;
    if cc[i]=bound[i] then begin
      up[i]:=up[i-1]; up[i-1]:=i-1;
      start[i]:=1; bound[i]:=1;
      {*** graft ***}
      if i<n then
      if (q[up[i]]=q[i]) and (up[i]<i)
        then graft[up[i]]:=graft[up[i]]+1 else graft[up[i]]:=0;
      if q[i]=next[up[i],cc[up[i]]+1] then
        begin
          if s[up[i]]=0 then begin
            {*** down ***}
            if (i=down[i]-1) and (q[up[i]]=q[n]) or (i=n)
               then begin
                 down[up[i]]:=i-graft[up[i]];
                 mark[up[i]]:=1
               end
               else down[up[i]]:=i+1;
            s[up[i]]:=i;
          end else begin
                     next[i,1]:=q[i];
                     if (mark[up[i]]=0) then down[up[i]]:=i;
                   end
        end
      else begin
        next[i,1]:=q[i];
        if mark[up[i]]=0 then down[up[i]]:=i
      end;
      if i<>down[i] then begin
        mark[i]:=0;
        i1:=i; i:=down[i]; down[i1]:=i1;
        cc[i]:=1;
        {bound[i]:=1;}
        next[i,1]:=q[i];
        {writeln(' going down', i:2);}
      end else
      begin
        last[i]:=0;
        i1:=i; i:=up[i]; up[i1]:=i1;
        if start[i]=1 then begin cc[i]:=1; end;
      end;
    end else
        begin
          {mark[i]:=0;}
          i:=down[i];
          cc[i]:=1; {bound[i]:=1;} next[i,1]:=q[i]
        end;
  until i=0
end;
begin
  write('input kk and ni ');
  readln(kk);
  for i:=1 to kk do read(m[i]);
  readln;
  first:=0;
  for i:=1 to kk do begin
    for j:=1 to m[i] do q[first+j]:=i;
    first:=first+m[i]
  end;
  n:=first;
  for i:=1 to n do s[i]:=0;
  count:=1;
  i:=n-m[kk];
  up[0]:=0;
  for k:=1 to i do begin
    next[k,1]:=q[k];
    up[k]:=k;
    s[k]:=0;
  end;
  for k:=i+1 to n do begin
    next[k,1]:=q[k]; up[k]:=k;
  end;
  for k:=1 to n do mark[k]:=0;
  for k:=1 to n do begin cc[k]:=1; bound[k]:=1; start[k]:=1; down[k]:=k end;
  i:=i+1; {up[i]:=i-1;}
  down[i]:=i;   down[n]:=n;
  out; perm;
  write('count ',count:3);
  readln
end.