Cod sursa(job #461092)

Utilizator ionicaion ionica Data 5 iunie 2010 17:23:25
Problema Infasuratoare convexa Scor 20
Compilator fpc Status done
Runda Arhiva educationala Marime 2.77 kb
program p1;
type punct=record
           x,y,dt:double;
           end;

var f,g:text;
    a,s:array[1..120000] of punct;
    p0:punct;
    n:longint;

procedure citeste;
var i:longint;
begin
     read(f,n);
     for i:=1 to n do
         read(f,a[i].x,a[i].y);
end;

procedure sch(var q,w:punct);
var aux:punct;
begin
     aux:=q;q:=w;w:=aux;
end;

procedure caut_primul;
var i,im:longint;
begin
     im:=1;
     for i:=2 to n do
         if (a[i].y<a[im].y)
           or (a[i].y=a[im].y)and(a[i].x<a[im].x) then im:=i;

     sch(a[im],a[1]);
     p0:=a[1];
end;

procedure dist(i:longint);
var u,v:double;
begin
 u:=p0.x-a[i].x;
 v:=p0.y-a[i].y;
 a[i].dt:=sqrt(u*u+v*v);
end;

procedure distante;
var i:longint;
begin
     for i:=2 to n do
     dist(i);
end;

function prod(k,q,z:punct):double;
begin
     prod:=k.x*q.y+q.x*z.y+z.x*k.y-q.y*z.x-z.y*k.x-k.y*q.x;
end;

function test1(x,y:punct):boolean;
var pr:double;
begin
 pr:=prod(p0,x,y);
 if (pr<0)or(pr=0)and(y.dt>=x.dt) then test1:=true
 else test1:=false;
end;

{function test2(x,y:punct):boolean;
var pr:longint;
begin
 pr:=prod(p0,x,y);
 if (pr>0)or(pr=0)and(y.dt<x.dt) then test2:=true
 else test2:=false;
end;

}
procedure part(st,dr:longint;var m:longint);
var s,d:longint;
    aux,p:punct;
begin
     p:=a[st];
     s:=st;d:=dr;
     while s<d do
     begin
          while(s<=dr) and test1(p,a[s]) do
                            s:=s+1;
          while not test1(p,a[d]) do
                                d:=d-1;
          if s<d then sch(a[s],a[d]);
     end;
     a[st]:=a[d];a[d]:=p;
     m:=d;
end;

procedure quick(st,dr:longint);
var m:longint;
begin
     part(st,dr,m);
     if st<m-1 then quick(st,m-1);
     if dr>m+1 then quick(m+1,dr);
end;

procedure muta;
var i,j:longint;
begin
     i:=2;
     s[1]:=a[1];
     s[2]:=a[2];

     for j:=3 to n do
         if prod(p0,a[j-1],a[j])<>0 then
              begin
              i:=i+1;
              s[i]:=a[j];
              end;

     for j:=1 to i do a[j]:=s[j];
     n:=i;
end;

procedure final;
var i,ps:longint;
    pr:double;
begin
     ps:=3;
     for i:=4 to n do
     begin
          repeat
               pr:=prod(s[ps-1],s[ps],a[i]);
{                writeln('ps=',ps,' i=',i,'pr=',pr);}
                if pr<=0 then ps:=ps-1;
          until pr>0;
          ps:=ps+1;
          s[ps]:=a[i];
     end;
     a:=s;
     n:=ps;
     writeln(g,n);
     for i:=1 to n do writeln(g,a[i].x:0:12,' ',a[i].y:0:12);
     close(g);
end;

begin
     assign(f,'infasuratoare.in');reset(f);
     assign(g,'infasuratoare.out');rewrite(g);

     citeste;

     caut_primul;

     distante;

     quick(2,n);

     muta;

     final;

     close(f);
end.