Cod sursa(job #4854)

Utilizator FreeYourMindAndrei FreeYourMind Data 8 ianuarie 2007 14:07:09
Problema Trapez Scor 100
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.61 kb
Program Trapez;

const fin = 'trapez.in';
     fout = 'trapez.out';
  infinit = 2000000001;

type tpoint = record
               x,y: longint;
              end;

var n: word;
    p: array[1..1000] of tpoint;
  nsl: longint;
   sl: array[1..1000000] of real;
  ntr: longint;

procedure load;
 var f: text; i: word;
begin
 assign(f, fin); reset(f);
  readln(f, n);
  for i:=1 to n do
   begin
    readln(f, p[i].x, p[i].y);
   end;
 close(f);
end;

procedure getslopes;
 var i,j: word;
begin
 nsl:=0;
 for i:=1 to n-1 do
  for j:=i+1 to n do
   begin
    inc(nsl);
    if p[i].x=p[j].x then sl[nsl]:=infinit
                     else sl[nsl]:=(p[j].y-p[i].y)/(p[j].x-p[i].x);
   end;
end;

var i: longint;
 temp: real;

procedure sortslopes;

   procedure sort(l,r: longint);
    var k: longint;
   begin
    if l>=r then exit;
    k:=l;
    for i:=l+1 to r do
        if sl[i]>sl[l] then
           begin
            inc(k);
            temp:=sl[k];
            sl[k]:=sl[i];
            sl[i]:=temp;
           end;
    temp:=sl[k];
    sl[k]:=sl[l];
    sl[l]:=temp;
    sort(l, k-1);
    sort(k+1, r);
   end;

begin
 sort(1,nsl);
end;

procedure save;
 var f: text; i,j: longint; current:longint;
begin
 ntr:=0;
 assign(f, fout); rewrite(f);
 i:=1;
 while (i<=nsl) do
  begin
    j:=i;
    current:=0;
    while sl[j] = sl[i] do
      begin
        inc(current); inc(j);
      end;
    if current>1 then
    ntr:=ntr+round( current*(current-1)/2);
    i:=j;
  end;
 writeln(f, ntr);
 close(f);
end;

begin
 load;
 getslopes;
 sortslopes;
 save;
end.