Cod sursa(job #24589)

Utilizator vladcyb1Vlad Berteanu vladcyb1 Data 2 martie 2007 22:45:19
Problema Patrate 3 Scor 100
Compilator fpc Status done
Runda Arhiva de probleme Marime 3.41 kb

 const
      FIN = 'patrate3.in';
      FOUT = 'patrate3.out';
      NMAX = 1002;

 type int_real = array[ 1..NMAX ] of real;
      int = array[ 1..NMAX ] of longint;


 var
     X, Y : int_real;
     ind, P : int;
     N, pivot, pz, ans : longint;
     f, g : text;
     ok : boolean;
     Xm, Ym, x1, y1, x2, y2 : real;

 procedure read_data;
  var i : longint;
  begin
   assign( f, FIN ); reset( f ); readln( f, N );
   for i := 1 to N do
     begin
       readln( f, X[i], Y[i] );
       IND[i] := i;
     end;
  close( f );
  end;

  procedure poz( lo, hi : longint );
   var i, j, di, dj, aux : longint;
    begin
     i := lo; j := hi; di := 0; dj := -1;
      while i < j do
        begin
         if X[ind[i]] > X[ind[j]] then begin aux := di; di := - dj; dj := - aux;
                                             aux := ind[i]; ind[i] := ind[j]; ind[j] := aux;
                                       end
                                   else
         if X[ind[i]] = X[ind[j]] then
         if Y[ind[i]] > Y[ind[j]] then begin aux := di; di := - dj; dj := - aux;
                                             aux := ind[i]; ind[i] := ind[j]; ind[j] := aux;
                                        end;
         inc( i, di ); inc( j, dj );
         end;
        pivot := i;
    end;

  procedure quick( lo, hi : longint );
   begin
    if lo < hi then
      begin
       poz( lo, hi );
       quick( lo, pivot - 1 );
       quick( pivot + 1, hi );
      end;
   end;

  function equal( a, b : real ) : boolean;
   begin
    if abs( a - b ) <= 0.0001 then equal := true
                              else equal := false;
   end;


  procedure binary( var A : int_real; lo, hi : longint; value : real );
   var juma : longint;
    begin
     if lo = hi then
                     begin
                       if equal( A[ind[lo]], value ) then pz := lo
                                        else pz := 0;
                     end
                 else
     begin
       juma := ( lo + hi ) shr 1;
       if (value < A[ind[juma]]) or ( equal( value, A[ind[juma]] ) )
                      then binary( A, lo, juma, value )
                       else binary( A, juma + 1, hi, value );
     end;
   end;


  procedure solve;
   var i, j : longint;
   begin
   quick( 1, N );
   for i := N - 1 downto 1 do
     if equal( X[ind[i]], X[ind[i+1]] ) then P[i] := 1 + P[i+1]
                              else P[i] := 0;
   for i := 1 to N - 1 do
    for j := i + 1 to N do
        begin
          Xm := ( X[i] + X[j] ) / 2;
          Ym := ( Y[i] + Y[j] ) / 2;
          x1 := Xm + Ym - Y[i];  x2 := Y[i] - Ym + Xm;
          y1 := X[i] - Xm + Ym;  y2 := Xm + Ym - X[i];
          binary( X, 1, n, x1 );
          if pz <> 0 then
              begin
                 binary( Y, pz, pz + P[pz], y1 );
                 if pz <> 0 then
                    begin
                      binary( X, 1, N, x2 );
                      if pz <> 0 then
                           begin
                             binary( Y, pz, pz + P[pz], y2 );
                             if pz <> 0 then inc( ans );
                            end;
                      end;
               end;
        end;
  end;

 procedure save;
  begin
   assign( g, FOUT ); rewrite( g );
   writeln( g, ans div 2 ); close( g );
  end;

  begin
   read_data;
   solve;
   save;
  end.