Cod sursa(job #682296)

Utilizator MihaiBunBunget Mihai MihaiBun Data 18 februarie 2012 20:31:04
Problema Infasuratoare convexa Scor 100
Compilator fpc Status done
Runda Arhiva educationala Marime 2.19 kb
program kk;
var f:text;
    i,n,p,q,nr:longint;
    x,y:array[1..120000] of extended;
    a:array[1..120000] of longint;
    min,t:extended;

procedure sort(l,r:longint);
var i1,j1,m:longint;
    xm,ym:extended;
begin
  i1:=l;j1:=r;xm:=x[(l+r)div 2];ym:=y[(l+r)div 2];
  repeat
    while (y[i1]-y[1])*(xm-x[1])<(ym-y[1])*(x[i1]-x[1]) do i1:=i1+1;
    while (ym-y[1])*(x[j1]-x[1])<(y[j1]-y[1])*(xm-x[1]) do j1:=j1-1;
    if i1<=j1 then begin
                    t:=x[i1];
                    x[i1]:=x[j1];
                    x[j1]:=t;
                    t:=y[i1];
                    y[i1]:=y[j1];
                    y[j1]:=t;
                    i1:=i1+1;
                    j1:=j1-1;
                   end;
  until i1>j1;
  if l<j1 then sort(l,j1);
  if i1<r then sort(i1,r);
end;

procedure stiva;
begin
  a[1]:=1;
  a[2]:=2;
  nr:=2;
  for i:=3 to n do
    begin
      while ((x[a[nr]]-x[a[nr-1]])*(y[i]-y[a[nr-1]])<(x[i]-x[a[nr-1]])*(y[a[nr]]-y[a[nr-1]]))
                    and(nr>2) do nr:=nr-1;
      nr:=nr+1;
      a[nr]:=i;
    end;
end;

procedure eliminpuncte;
var k,m,s:longint;
   z,max:extended;
begin
  k:=2;m:=2;
  repeat
    s:=k;
    x[m]:=x[k];
    y[m]:=y[k];
    max:=sqrt(sqr(x[k]-x[1])+sqr(y[k]-y[1]));
    while ((y[k]-y[1])*(x[s]-x[1])=(y[s]-y[1])*(x[k]-x[1])) and (k<=n) do
      begin
        z:=sqrt(sqr(x[k]-x[1])+sqr(y[k]-y[1]));
        if z>=max then begin
                        x[m]:=x[k];
                        y[m]:=y[k];
                        max:=z;
                      end;
        k:=k+1;
      end;
    m:=m+1;
  until k>n;
 n:=m;
end;

begin
  assign(f,'infasuratoare.in');
  reset(f);
  min:=2000000000;
  readln(f,n);
  for i:=1 to n do
    begin
      readln(f,x[i],y[i]);
      if x[i]<min then begin min:=x[i];p:=i;end
                  else if x[i]=min then
                           if y[i]<y[p] then p:=i;

    end;
  t:=x[1];
  x[1]:=x[p];
  x[p]:=t;
  t:=y[1];
  y[1]:=y[p];
  y[p]:=t;
  sort(2,n);
  eliminpuncte;
  stiva;
  close(f);
  assign(f,'infasuratoare.out');
  rewrite(f);
  writeln(f,nr-1);
  for i:=1 to nr-1 do writeln(f,x[a[i]],' ',y[a[i]]);
  close(f);
end.