Cod sursa(job #47944)

Utilizator andrewgPestele cel Mare andrewg Data 4 aprilie 2007 11:19:57
Problema Rubarba Scor 60
Compilator fpc Status done
Runda Arhiva de probleme Marime 3.94 kb
const maxn = 100001;
      inf = 2000000000;

type punct = record
        x,y:longint;
     end;
     punct0 = record
        x,y:real;
     end;

var f:text;
    n,i,j,k,x,y,z,di,q:longint;
    sol,d,dmax,m,max,min,xx,yy,zz:real;
    aux:punct0;
    a:array[1..maxn]of punct;
    st:array[1..maxn]of longint;

procedure readdata;
begin
   assign(f,'rubarba.in');
   reset(f);
   readln(f,n);
   aux.x:=0;
   aux.y:=0;
   for i:=1 to n do
   begin
      readln(f,a[i].x,a[i].y);
   end;
   close(f);
end;

procedure sort(l,r:longint);
var i,j,x:longint;
    y:punct;
begin
   i:=l;
   j:=r;
   x:=a[(l+r) div 2].x;
   repeat
      while a[i].x<x do i:=i+1;
      while x<a[j].x do j:=j-1;
      if i<=j then
      begin
         y:=a[i];
         a[i]:=a[j];
         a[j]:=y;
         i:=i+1;
         j:=j-1;
      end;
   until i>j;
   if l<j then sort(l,j);
   if i<r then sort(i,r);
end;

procedure sortd(l,r:longint);
var i,j,x:longint;
    y:punct;
begin
   i:=l;
   j:=r;
   x:=a[(l+r) div 2].y;
   repeat
      while a[i].y<x do i:=i+1;
      while x<a[j].y do j:=j-1;
      if i<=j then
      begin
         y:=a[i];
         a[i]:=a[j];
         a[j]:=y;
         i:=i+1;
         j:=j-1;
      end;
   until i>j;
   if l<j then sortd(l,j);
   if i<r then sortd(i,r);
end;

procedure coefficients(a,b:punct;var aa,bb,cc:longint);
begin
   aa:=a.y-b.y;
   bb:=b.x-a.x;
   cc:=a.x*b.y-b.x*a.y;
end;

procedure hull;
var v:array[1..100]of boolean;
    i,pas:longint;

function semn(a,b,c:punct):longint;
var aa,bb,cc:longint;
begin
   coefficients(a,b,aa,bb,cc);
   if aa*c.x+bb*c.y+cc<=0 then
   begin
      semn:=-1
   end
      else
   begin
      semn:=1;
   end;
end;

procedure modifica;
begin
   if pas=1 then
   begin
      inc(i);
      if i=n then pas:=-1;
   end
      else dec(i);
end;

begin
   fillchar(v,sizeof(v),false);
   sort(1,n);
   pas:=1;
   i:=1;
   while i<n do
   begin
      j:=1;
      while a[i].x=a[i+j].x do
      begin
         inc(j);
      end;
      sortd(i,i+j-1);
      i:=i+j;
   end;
   st[1]:=1;
   st[2]:=2;
   v[2]:=true;
   k:=2;
   i:=2;
   while i>1 do
   begin
      while v[i] do modifica;
      if i=0 then break;
      while (k>1) and (semn(a[st[k-1]],a[st[k]],a[i])=-1) do
      begin
         v[st[k]]:=false;
         st[k]:=0;
         dec(k);
      end;
      inc(k);
      st[k]:=i;
      v[i]:=true;
   end;
end;

function semn(c:punct;aa,bb,cc:real):longint;
begin
   if aa*c.x+bb*c.y+cc<=0 then
   begin
      semn:=-1
   end
      else
   begin
      semn:=1;
   end;
end;

function dista(p:punct;x,y,z:real):real;
begin
   if (x<>0) or (y<>0) then dista:=abs(x*p.x+y*p.y+z)/sqrt(x*x+y*y);
end;

function dist(p:punct;x,y,z:longint):real;
begin
   if (x<>0) or (y<>0) then dist:=abs(x*p.x+y*p.y+z)/sqrt(x*x+y*y);
end;

procedure solve;
begin
   hull;
   sol:=inf;
   for i:=1 to k-2 do
   begin
      coefficients(a[st[i]],a[st[i+1]],x,y,z);
      aux.x:=a[st[i]].x;
      aux.y:=a[st[i]].y;
      dmax:=0;
      for j:=1 to k-1 do
      begin
         d:=dist(a[st[j]],x,y,z);
         if d>dmax then
         begin
            dmax:=d;
            di:=st[i];
         end;
      end;
      if x<>0 then
      begin
         m:=-y/x;
         xx:=m;
         yy:=1;
         zz:=-aux.y-m*aux.x;
      end
         else
      begin
         xx:=1;
         yy:=0;
         zz:=-aux.x;
      end;
      max:=0;
      min:=0;
      for j:=1 to k-1 do
      begin
         q:=semn(a[st[j]],xx,yy,zz);
         d:=q*dista(a[st[j]],xx,yy,zz);
         if d>max then max:=d;
         if d<min then min:=d;
      end;
      if dmax*(max-min)<sol then sol:=dmax*(max-min);
   end;
end;

procedure writedata;
begin
   assign(f,'rubarba.out');
   rewrite(f);
   writeln(f,sol:0:2);
   close(f);
end;

begin
   readdata;
   solve;
   writedata;
end.