Cod sursa(job #142907)

Utilizator antoanelaAntoanela Siminiuc antoanela Data 25 februarie 2008 16:15:33
Problema Patrate2 Scor 70
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.9 kb
program patrate2;
var f,g:text;
    n,i,j,cy,l,k,m,t,y,r,h,ok:longint;
    s,v,p:array[1..1000]of 0..10000;
begin
assign(f,'patrate2.in');
assign(g,'patrate2.out');
reset(f);
rewrite(g);
read(f,n);
if (n=1)then write(g,'2') else
begin
  l:=1;
  k:=1;
  v[1]:=1;
  p[1]:=1;
  for y:=2 to n do
    begin
      cy:=y;
      t:=1;
      h:=0;
      ok:=0;
      while (t=1)do
        begin
          inc(h);
          inc(v[h]);
          t:=v[h] div 10;
          v[h]:=v[h] mod 10;
          if (h=k)then
            begin
              ok:=1;
              break;
            end;
        end;
      if (t>0)and(ok=1)then
        begin
          inc(k);
          v[k]:=t;
        end;
      {k:=0;
      while (cy<>0)do
        begin
          inc(k);
          v[k]:=cy mod 10;
          cy:=cy div 10;
        end; }
      {for i:=1 to k do write(g,v[i],' ');
      writeln(g);}
      for i:=1 to l do
        begin
          t:=0;
          m:=i-1;
          for j:=1 to k do
            begin
              r:=p[i]*v[j]+t;
              t:=r div 10;
              r:=r mod 10;
              inc(m);
              s[m]:=s[m]+r;
            end;
          if (t>0)then
            begin
              inc(m);
              s[m]:=t;
            end;
        end;
      t:=0;
      for i:=1 to m do
        begin
          s[i]:=s[i]+t;
          t:=s[i] div 10;
          p[i]:=s[i] mod 10;
        end;
      if (t>0)then
        begin
          inc(m);
          p[m]:=t;
        end;
      l:=m;
      for i:=1 to l do s[i]:=0;
    end;
for y:=1 to n*n do
  begin
    t:=0;
    for i:=1 to l  do
      begin
        p[i]:=p[i]*2+t;
        t:=p[i] div 10;
        p[i]:=p[i] mod 10;
      end;
    if (t>0)then
      begin
        inc(l);
        p[l]:=t;
      end;
  end;
end;


for i:=l downto 1 do write(g,p[i]);
close(f);
close(g);
end.