program ex;
const
  maxn=20;
var
  i,n:longint;
  flag:boolean;
  z:integer;
  a:array[1..maxn]of byte;

function check(x:longint):boolean;
var
  i:longint;
begin
  check:=true;
  for i:=2 to trunc(sqrt(x)) do
    if x mod i=0 then
    begin
      if i>10 then begin writeln(-1); halt; end;
      check:=false;
      exit;
    end;
end;

procedure solve(x:longint);
var
  i:integer;
begin
  if check(x) then
    if x<10 then
    begin
      z:=z+1;
      a[z]:=x;
      exit;
    end
    else
    begin
      writeln(-1);
      halt;
    end;
  for i:=9 downto 2 do
    if x mod i=0 then
    begin
      flag:=false;
      z:=z+1;
      a[z]:=i;
      x:=x div i;
      solve(x);
      break;
    end;
end;

begin
  readln(n);
  flag:=true;
  fillchar(a,sizeof(a),0);
  z:=0;
  if n=0 then writeln(10) else
  if (n>=1) and (n<=9) then writeln(n) else
  begin
    solve(n);
    for i:=z downto 1 do write(a[i]);
  end;
  writeln;
end.

Here's my source code:

{$r+,n+,q+,b-}
const maxn=10000;
var x,y:array[1..maxn] of longint;
    a:array[1..maxn] of real;
    b:array[1..maxn] of integer;
    n:integer;
    min,a1,a2:longint;

procedure nhap;
var i:integer;
begin
   readln(n);
   min:=maxlongint;
   for i:=1 to n do
   begin
      readln(x[i],y[i]);
      if (y[i]<min) or ((y[i]=min) and (x[i]>x[a1])) then
      begin
         min:=y[i];
         a1:=i;
      end;
   end;
end;

procedure shellsort;
var i,j,h,tb:integer;
    ta:real;
begin
   h:=n shr 1;
   while h<>0 do
   begin
      for i:=h+1 to n do
      begin
         ta:=a[i]; tb:=b[i];
         j:=i-h;
         while (j>0) and (a[j]>ta) do
         begin
            a[j+h]:=a[j];
            b[j+h]:=b[j];
            j:=j-h;
         end;
         a[j+h]:=ta;
         b[j+h]:=tb;
      end;
      h:=h shr 1;
   end;
end;

function angle(i,j:integer):real;
var dx,dy,ax,ay:longint;
    t:real;
begin
   dx:=x[j]-x[i]; ax:=abs(dx);
   dy:=y[j]-y[i]; ay:=abs(dy);
   if (dx=0) and (dy=0) then t:=0 else t:=dy/(ax+ay);
   if dx<0 then t:=2-t else if dy<0 then t:=4+t;
   angle:=t*90;
end;

procedure init;
var i:integer;
begin
   for i:=1 to n do a[i]:=angle(a1,i);
   for i:=1 to n do b[i]:=i;
end;

begin
   nhap;
   init;
   shellsort;
   writeln(a1,' ',b[n div 2+1]);
end.

Try this test:
5
0110
The correct answer is
01010
The answer of your program is
010100

GL

Can you give me a test.
I can't find a test that my pro. run incorectly.
Thanks a lot.
Here's my pro.:

const maxn=101;
var a,d:array[1..maxn,1..maxn] of byte;
    doi:array['('..']'] of char;
    st:string;
    n:integer;

procedure in_data;
begin
   readln(st);
   n:=length(st);
   doi['(']:=')'; doi[')']:='(';
   doi['[']:=']'; doi[']']:='[';
end;

procedure solve;
var i,j,k:integer;
begin
   fillchar(a,sizeof(a),0);
   for i:=1 to n do a[i,i]:=1;

   for i:=1 to n-1 do
   for j:=i+1 to n do
   begin
      a[i,j]:=255;
      if (st[i]=doi[st[j]]) and (st[i] in ['(','[']) then
      if a[i+1,j-1]<a[i,j] then
      begin
         a[i,j]:=a[i+1,j-1];
         d[i,j]:=0;
      end;

      for k:=i to j-1 do
      if a[i,k]+a[k+1,j]<a[i,j] then
      begin
         a[i,j]:=a[i,k]+a[k+1,j];
         d[i,j]:=k;
      end;
   end;
end;

procedure out(i,j:integer);
begin
   if i>j then exit;
   if i=j then
   begin
      if st[i] in ['(','['] then write(st[i],doi[st[i]])
      else write(doi[st[i]],st[i]);
   end
   else if d[i,j]=0 then
   begin
      write(st[i]);
      if i+1<=j-1 then out(i+1,j-1);
      write(st[j]);
   end
   else
   begin
      out(i,d[i,j]);
      out(d[i,j]+1,j);
   end;
end;

begin
   in_data;
   solve;
   out(1,n);
   writeln;
end.

I use DFS, but get WA.
Give me a test please.

Andrey Popyk.
popyk@ief.tup.km.ua
ICQ# 88914410

CONST Dim = 7200;

VAR A:Array[1..Dim,0..3] of integer;
    Col:Array[1..Dim] of byte;
    N:integer;

PROCEDURE ReadData;
var i,j:integer;
begin
  readln(N);
  for i:=1 to N do
  begin
    read(A[i,0]);
    for j:=1 to A[i,0] do read(A[i,j]);
    readln;
  end;
end;

PROCEDURE DFS(v:integer; c:byte);
var i:integer;
begin
  Col[v]:=c;
  for i:=1 to A[v,0] do
    if Col[A[v,i]]=0 then DFS(A[v,i],3-c);
end;

PROCEDURE Solve;
var i:integer;
begin
  for i:=1 to N do
    if Col[i]=0 then DFS(i,1);
end;

PROCEDURE WriteData;
var S,C,i:integer;
begin
  S:=0;
  for i:=1 to N do
    if Col[i]=1 then inc(S);
  if S>N-S then begin S:=N-S; C:=2 end
           else C:=1;
  writeln(S);
  for i:=1 to N do
    if Col[i]=C then write(i,' ');
  writeln;
end;

BEGIN
  ReadData;
  Solve;
  WriteData;
END.

----------------------MY RROGRAM-----------------
type arr = record
             a:array[1..100]of byte;
             l:integer;
           end;
var N,a,b,i:longint;
    r,_a,_b:arr;
procedure mul_i(var a:arr;x:integer);
var c,k:longint;
    i:integer;
begin
  k:=0;
  for i:=1 to a.l do
  begin
    c:=a.a[i];
    a.a[i]:=(a.a[i]*x+k) mod 10;
    k:=(c*x+k) div 10;
  end;
  while k<>0 do
  begin
    inc(i);
    a.a[i]:=k mod 10;
    k:=k div 10;
  end;
  a.l:=i;
end;

procedure mul_i2(var a:arr;x:integer;var d:arr;p:integer);
var c,k:longint;
    i:integer;
begin
  k:=0;
  for i:=1 to a.l do
  begin
    c:=a.a[i];
    d.a[i+p]:=(a.a[i]*x+k) mod 10;
    k:=(c*x+k) div 10;
  end;
  while k<>0 do
  begin
    inc(i);
    d.a[i+p]:=k mod 10;
    k:=k div 10;
  end;
  d.l:=i+p;
end;

procedure add(var a,b:arr);
var m,i:integer;
    k,c:byte;
begin
  if a.l>b.l then m:=a.l else m:=b.l;
  k:=0;
  for i:=1 to m do
  begin
    c:=a.a[i];
    a.a[i]:=(a.a[i]+b.a[i]+k) mod 10;
    k:=(c+b.a[i]+k) div 10;
  end;
  if k = 1 then
  begin
    inc(i);
    a.a[i]:=1;
  end;
  a.l:=i;
end;

procedure mul(var a,b:arr);
var c,d:arr;
    i:integer;
begin
  d.l:=0;fillchar(d,sizeof(d),0);
  for i:=1 to a.l do
  begin
    c.l:=0;fillchar(c,sizeof(c),0);
    mul_i2(b,a.a[i],c,i-1);
    add(d,c);
  end;
  a:=d;
end;



procedure calc(a:longint;var s:arr);
var i:longint;
    x:arr;
begin
  fillchar(s,sizeof(s),0);
  fillchar(x,sizeof(x),0);
  s.l:=0;
  x.l:=1;
  x.a[1]:=1;
  for i:=0 to a do
  begin
    {s:=s+x;}add(s,x);
    {X:=X*N;}mul_i(x,N);
  end;
end;

begin
  readln(N,A,b);
  calc(a,_a);
  calc(B,_b);
  mul(_a,_b);
  for i:=_a.l downto 1 do write(_a.a[i]);
  writeln;
end.

-----------------------My program-------------------------------------
const q = 40;
var
counter,check,l,i,j,n:integer;
s:string;
a:array [1..q,1..q] of integer;
ch:string;
begin
  readln (n);
  for i:=1 to n do
  begin
  for l:=1 to N DO
  begin
    readln (ch);
    if ch='.' then
      begin
         a[i,l]:=1
      end
      else a[i,l]:=-1;
  end;
  end;
  a[1,1]:=2;
  a[n,n]:=2;
  check:=1;
  while (check=1) do
  begin
    check:=0;
    for i:=1 to n do
    begin
      for j:=1 to n do
      begin
        if a[i,j]=2 then
        begin
          a[i,j]:=3;
          if a[i-1,j]=1 then a[i-1,j]:=2;
          if a[i,j-1]=1 then a[i,j-1]:=2;
          if a[i+1,j]=1 then a[i+1,j]:=2;
          if a[i,j+1]=1 then a[i,j+1]:=2;
          check:=1;
        end;
      end;
    end;
  end;
  for i:=1 to n do
  begin
    for j:=1 to n do
    begin
      if a[i,j]=3 then
      begin
        if (a[i-1,j]<>3) then inc (counter);
        if (a[i+1,j]<>3) then inc (counter);
        if (a[i,j+1]<>3) then inc (counter);
        if (a[i,j-1]<>3) then inc (counter);
      end;
    end;
  end;
  counter:=counter-4;
  writeln (counter*9);
end.
{Where is my error? I have WA}

Try this test:
1
1 1
It doesn't run properly at my c++ compiler and at my turbo c
compiler, it causes a deadloc... Maybe you should try to rewrite your
algorythm in pascal and try again.

I am getting WA using BFS. Can anyone give me a hint?
My mail: a_haque@agni.com

Thanks.
71222119
mailto : trungduck@yahoo.com

 I tried some tests but I didn't find the test make me get that
mistake or something like that.
  Here is my program, could you tell me why or give me the test make
me wrong or mistake.

const    max    = 5100;
         han    = 1000000000;

var      a           :array[1..2*max] of longint;
         cl          :array[1..2*max] of byte;
         line        :array[0..max] of record x,y :longint;
                                              c   :byte;
                                       end;

         m,k,n       :longint;
         dau,kq      :longint;

procedure them(u,v,t :longint);
begin
  inc(m);
  with line[m] do
  begin x := u;
        y := v;
        c := t;
  end;
  inc(k); a[k] := u;
  inc(k); a[k] := v;
end;


procedure chuanbi;
begin
  m := 0; k := 2;
  line[0].x := 0; line[0].y := han; line[0].c := 1;
  a[1] := 0; a[2] := han;
end;


procedure input;
var   i         :integer;
      u,v       :longint;
      t         :byte;
      st        :string;
begin
  chuanbi;

  readln( n);
  for i := 1 to n do
  begin
    readln( u, v, st);
    if pos('b',st) > 0 then t := 2
                       else t := 1;
    if u < v then
     them(u,v,t);
  end;
end;


procedure sort(l,r :longint);
var     i,j,tam,x    :longint;
begin
  i := l; j := r; x := a[ l + random(r-l+1)];

  repeat
    while a[i] < x do inc(i);
    while a[j] > x do dec(j);

    if i <= j then
    begin
      tam := a[i]; a[i] := a[j]; a[j] := tam;
      inc(i); dec(j);
    end;
  until i > j;

  if l < j then sort(l,j);
  if i < r then sort(i,r);
end;


procedure xoa(j,i :longint);
var    u  :longint;
begin
  k := k -i +j +1;
  for u := j+1 to k do
    a[u] := a[u+i-j-1];
end;


procedure rut_gon;
var      i,j      :longint;
begin
  i := k;
  repeat
    j := i;
    repeat dec(j) until a[j] < a[i];
    if j < i-1 then xoa(j,i);
    i := j;
  until i = 1;
end;


function tt( x : longint) :longint;
var     dau,cuoi,giua     :longint;
begin
  dau := 1; cuoi := k;

  repeat
    giua := ( dau + cuoi ) div 2;
    if x = a[giua] then begin tt := giua; exit; end;
    if x < a[giua] then cuoi := giua -1 else
                        dau  := giua +1;
  until false;
end;



procedure to_mau;
var   i,u,v,t      :longint;
begin
  for i := 0 to m do
    with line[i] do
    begin
      u := tt( x ); v := tt( y );
      for t := u to v-1 do
         cl[t] := c;
    end;
end;



procedure tim;
var   i,kq,dau,length,x   :longint;

 procedure update;
 begin
   if length > kq then
   begin  kq  := length;
          dau := x;
   end;
 end;

begin
  kq := 0;  dau := 0;
  length := 0; x := -1;

  for i := 1 to k-1 do
   if cl[i] = 1 then
   begin
     if x = -1 then x := a[i];
     length := length + a[i+1] - a[i];
   end else
   if length > 0 then
   begin
     update;
     length := 0; x := -1;
   end;

   update;
   writeln( dau,' ',dau + kq);
end;


procedure solve;
begin
  sort(1,k);
  rut_gon;
  to_mau;
  tim;
end;



begin
  input;
  solve;
end.

I know the definition of a euler path, but i don't know how to
implement it efficently, could someone help?, and tell me how is
possible to do a the problem "Bus Routes" with only 49 k??.. (i see
it in the list, is from someone from IFMO i belive).
Mail: miguelangelhdz@hotmail.com
Thanks in advance :)

CONST
     INP                =               '1067.inp';
     OUT                =               '1067.out';
     maxtro             =               10000 ;

TYPE
     st1                =               string[9] ;

VAR
  last,tro,n     :       integer;
  s     :       string ;
  rec   :       array[0..maxtro] of ^st1;
  dad   :       array[0..maxtro] of integer;

PROCEDURE               ReadInput;
  begin
    assign (input,inp);
    reset(input);
    assign (output,out) ;
    rewrite (output) ;

    readln ( n) ;
  end;

PROCEDURE               readbuf ;
  begin
    readln (s) ;
    while  (s[length(s)] in [#10,#13] ) do delete(s,length(s),1) ;
  end ;

PROCEDURE               get (var dir : st1 ) ;
  begin
    dir:='';
    while s[1] = '\' do delete (s,1,1) ;
    while (s[1] <> '\') and (s <> '') do
      begin
        dir:=dir + s[1] ;
        delete(s,1,1) ;
      end ;
  end ;

FUNCTION                recognize ( i: integer ) : boolean ;
  begin
    recognize:=false ;
    if last <> 0 then
      begin
        if dad[i] = last then recognize:=true ;
      end
    else
      recognize:=true ;
  end ;

FUNCTION                getpos ( dir : st1 ) : integer ;
  var
    i,l,r,mid           :       integer ;
  begin
    getpos:=0 ;
    l:=1 ; r:=tro ; mid:=0 ;
    while l <= r do
      begin
        mid:= (l+r) div 2 ;
        if (rec[mid]^ = dir)  then break ;
        if dir > rec[mid]^ then l:=mid+1
        else r:=mid-1 ;
      end ;

    l:=mid ; if l = 0 then exit ;
    while (rec[l]^ = dir) do
    begin
      if recognize ( l ) then
        begin
          getpos:=l ; exit ;
        end ;
      dec (l) ;
    end ;

    l:=mid ;
    while rec[l]^ = dir do
    begin
      if recognize ( l ) then
        begin
          getpos:=l ; exit ;
        end ;
      inc(l) ;
    end ;
  end ;

FUNCTION                findcache ( dir : st1 ) : integer ;
  var
    l,r,mid             :       integer ;
  begin
    l:=1 ; r:=tro ;
    while l <= r do
      begin
        mid := (l+r) div 2 ;
        if dir > rec[mid]^ then l:=mid+1
        else r:=mid-1 ;
      end ;
    findcache:=(l+r) div 2 ;
  end ;

FUNCTION                newpos ( dir : st1 ) : integer ;
  var
    i,j           :       integer ;
  begin
    j:= findcache ( dir ) ;
    for i:=1 to tro do
      if dad[i] > j then inc(dad[i]) ;
    if last > j then inc (last) ;

    for i:=tro downto j+1 do
      begin
        rec[i+1]:=rec[i] ;
        dad[i+1]:=dad[i] ;
      end ;
    new (rec[j+1]) ;
    rec[j+1]^:=dir ;
    dad[j+1]:=0 ;
    newpos:=j+1 ;
    inc (tro) ;
  end ;

PROCEDURE               makelink ( j : integer ) ;
  begin
    if last <> 0 then
      begin
        dad[j]:=last ;
      end ;
    last:=j ;
  end ;

PROCEDURE               analys ;
  var
    dir         :       st1 ;
    j           :       integer ;
  begin
    last:=0 ;
    repeat
      get ( dir ) ;
      j:=getpos (dir) ;
      if j = 0 then j:= newpos ( dir ) ;
      makelink (j) ;
    until s = '';
  end ;

PROCEDURE               xuly ;
  var
    i           :       integer ;
  begin
    tro:=0 ;
    fillchar (dad,sizeof(dad),0) ;
    for i:=1 to n do
      begin
        readbuf ;
        analys ;
      end ;

  end;

PROCEDURE               spread ( i,ccc  : integer ) ;
  var
    j           :       integer ;
  begin
    for j:=1 to ccc do write(' ') ;
    writeln(rec[i]^) ;
    for j:=1 to tro do
      if dad[j] = i then
        begin
          spread ( j,ccc+1) ;
        end ;
  end ;

PROCEDURE               Writeoutput ;
  var
    i           :       integer ;
  begin
    for i:=1 to tro do
      if dad[i] = 0 then
        begin
          spread ( i,0 ) ;
        end ;

    close (output);
    close (input) ;

You said you can give me an idea? My troubles make me go use your
help. I get WA, but all my test runnings for this program were
successfull. This is the source:

// solution for superlong sums. version 3.0
#include <stdio.h>
typedef unsigned long T;
int main()
{
  T amo, nin=0, i, j=0;
  unsigned int las=0, a, b;
  unsigned char fpr; // output in first time

  fpr = 2;
  las = 0;

  scanf("%d", &amo);

  for (i=1; i<=amo; i++)
  {

  scanf("%d", &a);
  scanf("%d", &b);

  if (a+b < 9)
   {
      if ((fpr == 0) || (las != 0))
    {
    printf("%d", las);
    fpr = 0;
    }; // if not in first time or las<>0
      for (j=1; j<=nin; j++) printf("9");

      if (nin>0) fpr = 0;

      nin = 0;
      las = a+b;
   }; // if a+b<9

  if (a+b == 9)
   {

   nin++;

   }; // if a+b == 9

  if (a+b > 9)
   {

   printf("%d", las+1);
   fpr = 0;// !!!!!!

   for (j=1; j<=nin; j++) printf("0");
   nin = 0;
   las = a + b - 10;

   }; // if a+b > 9
  };

if ((fpr == 0) || (las != 0))  printf("%d", las);

for (j=1; j<=nin; j++) printf("9");


return 0;
} // main

As we know IOI2002 is coming, some countries had its own teams, but
we don't know much about members of their teams. Is there any one
doing here participant in IOI2002 ? Give us some names. The First,
from Vietnam is Nguyen Van Hieu (Athena Chu) - the boy stand for the
third place in ranklist.

#include<stdio.h>
int sum[32001];
int pre[32001];
int lnk[32001];
int end;
int tmp_sum[32001];
int tmp_pre[32001];
int tmp_end;
int n,m;
int count[15000];
int get(int i){
    while(i>=0){
        if(i==pre[i])return sum[i];
        i=pre[i];}
    return 0;}

int main(void){
    int i,j,x,y,curx,cury,left,k,prej,preend;
    scanf("%d",&n);
        m=n;
    /*init*/
    pre[0]=-1;
    for(i=1;i<=500;i++)
        pre[i]=0;
    for(i=500;i<32000;i+=500)
        for(j=i+1;j<=i+500;j++)
            pre[j]=i;
    end=-1;
    for(i=0;i<n;i++)
        count[i]=0;
    /*end of init*/
    scanf("%d %d",&x,&y);
        n--;
    while(1){
        curx=-1;
        left=0;
        cury=y;
        tmp_sum[x]=get(x)+left+1;
        count[tmp_sum[x]-1]++;
        left++;
        tmp_pre[x]=curx;
        curx=x;
        while(1){
            if(!n)goto end;
            scanf("%d %d",&x,&y);
                        n--;
                        if(y!=cury)break;
            tmp_sum[x]=get(x)+left+1;
                        count[tmp_sum[x]-1]++;
            left++;
            tmp_pre[x]=curx;
            curx=x;
            }
        tmp_end=curx;
        i=tmp_end;
        j=end;
                prej=end;
                preend=end;
              while(i>=0){
            while(j>i){
                                sum[j]=tmp_sum[i]-get(i)+get(j);
                                prej=j;
                j=lnk[j];}
            if(j==i){
                sum[i]=tmp_sum[i];
                pre[i]=i;
                                prej=j;
                j=lnk[j];}
            else{
                for(k=i+1;pre[k]==pre[i]
&&k<32001;k++)
                    pre[k]=i;
                pre[i]=i;
                                sum[i]=tmp_sum[i];
                                if(prej==preend){
                                        end=i;
                                        lnk[i]=prej;
                                        }
                                else{
                                        lnk[prej]=i;
                                        lnk[i]=j;}
                                prej=i;}
            i=tmp_pre[i];
            }
        }
    end:
    for(i=0;i<m;i++)
        printf("%d\n",count[i]);
    return 0;}

I can trade the solution for one of the most difficult problems on
TIMUS. I need any long arithmetic routines. Write an answer on this
webboard.