Cod sursa(job #610396)

Utilizator ctlin04UAIC.VlasCatalin ctlin04 Data 26 august 2011 23:01:23
Problema Cautare binara Scor 60
Compilator fpc Status done
Runda Arhiva educationala Marime 2.54 kb
Program cautbin;
 var a:array [0..100010] of longint;
    i,j,n,nr,x,m,pos,st,dr,k:longint;
    fi,fo:text;
procedure cauta(i,sf:longint);
 var mid,j:longint;
begin
st:=i; dr:=sf;
if i<=sf then begin
 mid:=(i+sf) div 2;
 if a[mid]>x then cauta(i,mid-1)
 else if a[mid]<x then cauta(mid+1,sf);
 if a[mid]=x then pos:=mid;
                end;
end;
begin
 assign(fi,'cautbin.in');
  assign(fo,'cautbin.out');
 reset(fi);
  rewrite(fo);
 readln(fi,n);
 for i:=1 to n do read(fi,a[i]);
 readln(fi);
 readln(fi,m);
 for i:=1 to m do begin
                   readln(fi,nr,x);
                   pos:=0;
                    cauta(1,n);
                   if nr=0 then
                    if pos=0 then writeln(fo,'-1')
                     else begin
                           while a[pos]=x do inc(pos);
                           writeln(fo,pos-1);
                           end;
                   if nr=1 then
                    if pos=0 then writeln(fo,dr){ begin
                                   k:=dr+1;
                                    if a[k]<x then begin
                                                     while a[k]<x do inc(k);
                                                     writeln(fo,k-1);
                                                     end
                                    else begin
                                         while a[k]>x do dec(k);
                                         writeln(fo,k);
                                         end;
                                    end           }
                     else begin
                           while a[pos]=x do inc(pos);
                           writeln(fo,pos-1);
                           end;
                   if nr=2 then
                   if pos=0 then writeln(fo,st){ begin
                                  k:=dr+1;
                                  if a[k]<x then begin
                                     while a[k]<x do inc(k);
                                      writeln(fo,k);
                                                  end
                                  else begin
                                         while a[k]>x do dec(k);
                                         writeln(fo,k+1);
                                         end;
                                  end           }
                    else  begin
                           while a[pos]=x do dec(pos);
                           writeln(fo,pos+1);
                           end;
                    end;
 close(fo);
end.