Cod sursa(job #1024899)

Utilizator hungntnktpHungntnktp hungntnktp Data 9 noiembrie 2013 12:14:36
Problema Struti Scor 20
Compilator fpc Status done
Runda Arhiva de probleme Marime 2.75 kb
program REC;
const
        inp='struti.in';
        oup='struti.out';
        max=1000;
var
        f:text;
        A:array[1..max,1..max] of longint;
        Tx,Ty,Cres,Res:array[1..10] of longint;
        N,M,K:longint;
(*              *)
procedure nhap;
var     i,j:longint;
begin
        assign(f,inp);  reset(f);
        readln(f,m,n,k);
        for i:=1 to m do
                begin
                        for j:=1 to n do read(f,A[i,j]);
                        readln(f);
                end;
        for i:=1 to k do
                begin
                        readln(f,Tx[i],Ty[i]);
                end;
        close(f);
end;
(*              *)
procedure tinh;
var     i,j,x,y,cas,minv,maxv:longint;
begin
        for i:=1 to k do Res[i]:=maxlongint;
        for cas:=1 to k do
           begin
                for x:=1 to m-Tx[cas]+1 do
                   for y:=1 to n-Ty[cas]+1 do
                   begin
                      minv:=8010;
                      maxv:=-1;
                      for i:=x to x+Tx[cas]-1 do
                         for j:=y to y+Ty[cas]-1 do
                                begin
                                        if A[i,j]<minv then minv:=A[i,j];
                                        if A[i,j]>maxv then maxv:=A[i,j];
                                end;
                      if (maxv-minv)<Res[cas] then
                        begin
                                res[cas]:=maxv-minv;
                                cres[cas]:=1;
                        end
                      else if maxv-minv=Res[cas] then inc(cres[cas]);
                   end;
                if Ty[cas]<>Tx[cas] then
                for x:=1 to m-Ty[cas]+1 do
                   for y:=1 to n-Tx[cas]+1 do
                   begin
                      minv:=8010;
                      maxv:=-1;
                      for i:=x to x+Ty[cas]-1 do
                         for j:=y to y+Tx[cas]-1 do
                                begin
                                        if A[i,j]<minv then minv:=A[i,j];
                                        if A[i,j]>maxv then maxv:=A[i,j];
                                end;
                      if (maxv-minv)<Res[cas] then
                        begin
                                res[cas]:=maxv-minv;
                                cres[cas]:=1;
                        end
                      else if maxv-minv=Res[cas] then inc(cres[cas]);
                   end;
           end;
end;
(*              *)
procedure xuat;
var     i:longint;
begin
        assign(f,oup);  rewrite(f);
        for i:=1 to k do writeln(f,Res[i],' ',Cres[i]);
        close(f);
end;
(*              *)
BEGIN
        nhap;
        tinh;
        xuat;
END.