Cod sursa(job #579926)

Utilizator gicu_01porcescu gicu gicu_01 Data 12 aprilie 2011 16:30:26
Problema Cutii Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.31 kb
var a:array[1..100,1..3500,1..3]of integer;
    b:array[1..100,1..3500]of longint;
    n,t:integer;

procedure init;
var i,j:integer; f:text;
begin
 assign(f,'cutii.in');
 reset(f);
 readln(f,n,t);
 for i:=1 to t do
  begin
   for j:=1 to n do
    begin
     readln(f,a[i,j,1],a[i,j,2],a[i,j,3]);
     b[i,j]:=a[i,j,1]*a[i,j,2]*a[i,j,3];
    end
  end;
 close(f);
end;

procedure sw(var a,b:integer);
var t:integer;
begin
 t:=a;a:=b;b:=t;
end;

procedure sw2(var a,b:longint);
var t:longint;
begin
 t:=a;a:=b;b:=t;
end;

procedure qs(k,left,right:integer);
var i,j:integer;p:longint;
begin
 i:=left; j:=right; p:=b[k,(i+j)div 2];
 while i<j do
  begin
   while b[k,i]>p do inc(i);
   while b[k,j]<p do dec(j);
   if i<=j then
    begin
     sw2(b[k,i],b[k,j]);
     sw(a[k,i,1],a[k,j,1]);
     sw(a[k,i,2],a[k,j,2]);
     sw(a[k,i,3],a[k,j,3]);
     inc(i);dec(j);
    end;
  end;
 if i<right then qs(k,i,right);
 if j>left then qs(k,left,j);
end;

procedure bool;
var i,j,k:integer; p:longint; f:text;
begin
 assign(f,'cutii.out');
 rewrite(f);
 for i:=1 to t do qs(i,1,n);
 for i:=1 to t do
  begin
   p:=b[i,1]; k:=1;
   for j:=2 to n do
    if b[i,j]<(p/2) then begin inc(k); p:=b[i,j]; end;
   writeln(f,k);
  end;
 close(f);
end;


begin
 init;
 bool;
end.