Cod sursa(job #12516)

Utilizator andrei_infoMirestean Andrei andrei_info Data 4 februarie 2007 11:43:05
Problema Patrate 3 Scor 80
Compilator fpc Status done
Runda Arhiva de probleme Marime 4.33 kb
//patrate 3

const a = (sqrt(5)-1)/2;
      hashmax = 1000;
type pc= record
         x,y:real;
         end;
     pnody = ^tnody;
     tnody = record
                val:real;
                next : pnody;
                end;
     listay = record
                heady,lasty:pnody;
                end;
     pnodx = ^tnodx;
     tnodx = record
                val:real;
                yy : array[-hashmax..hashmax] of listay;
                next:pnodx;
                end;
     listax = record
                headx,lastx:pnodx;
                end;
var n,rez:longint;
    pcc:array[-hashmax..hashmax] of listax;
    puncte : array[0..1000] of pc;

function hash(x:real):integer;
begin
hash:= trunc(hashmax * ( frac(x*a) ));
end;

function egal(x,y:real):boolean;
begin
if abs(x-y) < 0.0001 then egal:=true
else egal:=false;
end;

procedure inserthash(z:pc);
var fx,fy,i:integer;
    p,pp:pnodx;
    q,qq:pnody;
begin
fx:=hash(z.x);
p:=pcc[fx].headx;
while p<> nil do
        begin
        if egal(p^.val,z.x) then
                begin
                fy:=hash(z.y);
                new(q);
                q^.val:=z.y; q^.next:=nil;
                if p^.yy[fy].heady = nil then
                        p^.yy[fy].heady:=q
                else p^.yy[fy].lasty^.next:=q;
                p^.yy[fy].lasty:=q;
                break;
                end;
        p:=p^.next;
        end;
if p = nil then
        begin
        new(pp); pp^.val:=z.x; pp^.next:=nil;
        fy:=hash(z.y);
        for i:=0 to hashmax do
                begin
                pp^.yy[i].heady:=nil; pp^.yy[i].lasty:=nil
                end;
        new(qq);
        qq^.val:=z.y; qq^.next:=nil;
        pp^.yy[fy].heady:=qq;
        pp^.yy[fy].lasty:=qq;
        if pcc[fx].headx = nil then pcc[fx].headx:=pp
        else pcc[fx].lastx^.next:=pp;
        pcc[fx].lastx:=pp;
        end;
end;

function cautahash(z:pc):boolean;
var p:pnodx;
    q:pnody;
    fx,fy:integer;
begin
cautahash:=false;
fx:=hash(z.x);
p:=pcc[fx].headx;
while p<> nil do
        begin
        if  egal(p^.val,z.x) then
                begin
                fy:=hash(z.y);
                q:=p^.yy[fy].heady;
                while q<> nil do
                        begin
                        if egal(q^.val,z.y) then
                                begin
                                cautahash:=true;
                                exit;
                                end;
                        q:=q^.next;
                        end;
                end;
        p:=p^.next;
        end;
end;

procedure citire;
var i:integer;
    z:pc;
begin
assign(input,'patrate3.in'); reset(input);
readln(n);
for i:=1 to n do
        begin
        readln(z.x,z.y);
        puncte[i]:=z;
        inserthash(z);
        end;
close(input);
end;


procedure mutapuncte( p0,p1:pc; var p2,p3:pc);
begin
if p0.x < p1.x then begin p2:=p0; p3:=p1; end
else    begin p2:=p1; p3:=p0; end;
end;

procedure calc;
var i,j:integer;
    d,mij,p1,p2,p01,p02:pc;
begin
for i:=1 to n do
        for j:=1 to n do
                if (i<>j) then
                        begin
                        mutapuncte(puncte[i],puncte[j],p01,p02);
                        mij.x:=(p01.x+p02.x)/2;
                        mij.y:=(p01.y+p02.y)/2;
                        d.x:=abs(mij.x-p01.x);
                        d.y:=abs(mij.y-p01.y);
                        if p01.y < p02.y then
                                begin
                                p1.x:=mij.x+d.y;
                                p1.y:=mij.y-d.x;
                                p2.x:=mij.x-d.y;
                                p2.y:=mij.y+d.x;
                                end
                        else
                                begin
                                p1.x:=mij.x-d.y;
                                p1.y:=mij.y-d.x;
                                p2.x:=mij.x+d.y;
                                p2.y:=mij.y+d.x;
                                end;
                        if cautahash(p1) and
                                cautahash(p2) then
                                        inc(rez);
                        end;
end;

begin
citire;
calc;
assign(output,'patrate3.out'); rewrite(output);
writeln(rez div 4);
close(output);
end.