Cod sursa(job #299192)

Utilizator cristinabCristina Brinza cristinab Data 6 aprilie 2009 17:01:29
Problema Triang Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 3.77 kb
{triang}
{$N+}

type punct=record
           x,y:double;
           end;

var v:array[1..1500] of punct;
    n:integer;
    nr:longint;
    punct1,punct2:punct;
    da:boolean;

procedure citire;
var f:text;
    i:integer;
    xu,yu:double;
begin
assign(f,'triang.in'); reset(f);
readln(f,n);
for i:=1 to n do readln(f,v[i].x,v[i].y);
close(f);
end;

function part(l,r:longint):longint;
var p,pp:double;
    j,i:longint;
    aux:punct;
begin
p:=v[r].x;
pp:=v[r].y;
j:=l-1;
for i:=l to r do
    if (v[i].x<p) or ((v[i].x=p) and (v[i].y<=pp)) then
       begin
       inc(j);
       aux:=v[j];
       v[j]:=v[i];
       v[i]:=aux;
       end;
part:=j;
end;

procedure qsort(l,r:longint);
var poz:longint;
begin
poz:=part(l,r);
if l<poz-1 then qsort(l,poz-1);
if r>poz+1 then qsort(poz+1,r);
end;


procedure gaseste_punct(a1,b1,a2,b2:double);
var AB,abscisa,ordonata,difo,difa,suma,a,b,c,delta,x1,x2,y1,y2:double;
begin

punct1.x:=0;
punct1.y:=0;
punct2.x:=0;
punct2.y:=0;

AB:=sqr(a1-a2)+sqr(b1-b2);
abscisa:=sqr(a1)-sqr(a2);
ordonata:=sqr(b1)-sqr(b2);
difo:=b1-b2;
difa:=a1-a2;
da:=true;

if (difo<>0) and (difa<>0) then
   begin
   suma:=abscisa+ordonata;
   a:=4*sqr(difo)+4*sqr(difo);
   b:=-4*difo*suma+8*a1*difa*difo-2*b1*sqr(difa);
   c:=sqr(suma)+4*sqr(difa)*sqr(a1)-4*a1*difa*suma+4*sqr(difa)*sqr(b1)-AB*4*sqr(difa);
   delta:=sqr(b)-4*a*c;
   if delta>=0 then
   begin
   y1:=(-b+sqrt(delta))/(2*a);
   y2:=(-b-sqrt(delta))/(2*a);
   x1:=(abscisa+ordonata-2*y1*difo)/(2*difa);
   x2:=(abscisa+ordonata-2*y2*difo)/(2*difa);
   punct1.x:=round(x1*1000)/1000;
   punct1.y:=round(y1*1000)/1000;
   punct2.x:=round(x2*1000)/1000;
   punct2.y:=round(y2*1000)/1000;
   end
   else da:=false;
   end
else if difa=0 then
        begin
        y1:=ordonata/(2*difo);
        punct1.y:=round(y1*1000)/1000;
        punct2.y:=round(y1*1000)/1000;
        a:=1;
        b:=(-2)*a1;
        c:=sqr(a1)+sqr(y1)+sqr(b1)-2*y1*b1-AB;
        delta:=sqr(b)-4*a*c;
        if delta>=0 then
        begin
        x1:=(-b+sqrt(delta))/(2*a);
        x2:=(-b-sqrt(delta))/(2*a);
        punct1.x:=round(x1*1000)/1000;
        punct2.x:=round(x2*1000)/1000;
        end
        else da:=false
        end
     else if difo=0 then
             begin
             x1:=abscisa/(2*difa);
             punct1.x:=round(x1*1000)/1000;
             punct2.x:=round(x1*1000)/1000;
             a:=1;
             b:=(-2)*b1;
             c:=sqr(a1)+sqr(x1)+sqr(b1)-2*x1*a1-AB;
             delta:=sqr(b)-4*a*c;
             if delta>=0 then
             begin
             y1:=(-b+sqrt(delta))/(2*a);
             y2:=(-b-sqrt(delta))/(2*a);
             punct1.y:=round(y1*1000)/1000;
             punct2.y:=round(y2*1000)/1000;
             end
             else da:=false;
             end

end;


function caut_binar(punct_p:punct):boolean;
var ok:boolean;
    p,u,mij:longint;
begin
ok:=false;
p:=1;
u:=n;

while (p<=u) and not ok do
      begin
      mij:=(p+u) div 2;
      if (v[mij].x<punct_p.x) or (v[mij].x=punct_p.x) and (v[mij].y<punct_p.y) then p:=mij+1
      else if (v[mij].x>punct_p.x) or (v[mij].x=punct_p.x) and (v[mij].y>punct_p.y) then u:=mij-1
      else if (v[mij].x=punct_p.x) and (v[mij].y=punct_p.y) then ok:=true
      end;

caut_binar:=ok;
end;


procedure rezolvare;
var i,j:integer;
begin

nr:=0;

for i:=1 to n-1 do
    for j:=i+1 to n do
        begin
        gaseste_punct(v[i].x,v[i].y,v[j].x,v[j].y);
        if da and caut_binar(punct1) then inc(nr);
        if da and caut_binar(punct2) then inc(nr);
        end;
end;

procedure afisare;
var g:text;
begin
assign(g,'triang.out'); rewrite(g);
writeln(g,nr);
close(g);
end;

begin
citire;
qsort(1,n);
rezolvare;
afisare;
end.