PBCWATER - Tính toán lượng nước
Tác giả: khuc_tuan
Ngôn ngữ: Pascal
program rain2;
(*****************************************************)
const
dx:array[1..4] of shortint=(-1,1,0,0);
dy:array[1..4] of shortint=(0,0,-1,1);
(*****************************************************)
type
byte = longint ;
integer = longint ;
ptype2=^_type2;
_type2=
record
i,j:byte;
next:ptype2;
end;
ptype1=^_type1;
_type1=
record
h:integer;
list:ptype2;
end;
arr1=array[1..100,1..100] of integer;
arr2=array[1..10000] of _type1;
arr3=array[0..101,0..101] of byte;
(*****************************************************)
var
m,n:integer;
a:arr1;
b:arr3;
queue:record
a:array[1..30000] of byte;
l,r:integer;
end;
list:^arr2;
nl:integer;
sum,count:longint;
{ _t:longint;
time:longint absolute 0:$46C;}
(*****************************************************)
procedure initqueue;
begin
queue.l:=0;
end;
(*****************************************************)
procedure addQ(i:byte);
begin
if queue.l=0 then
begin
queue.l:=1;
queue.r:=1;
end
else if queue.r=30000 then queue.r:=1 else inc(queue.r);
queue.a[queue.r]:=i;
end;
(*****************************************************)
function delete:byte;
begin
delete:=queue.a[queue.l];
if queue.l=queue.r then queue.l:=0
else if queue.l=30000 then queue.l:=1 else inc(queue.l);
end;
(*****************************************************)
function empty:boolean;
begin
empty:=queue.l=0;
end;
(*****************************************************)
procedure main(var list:arr2);
(*****************************************************)
procedure init;
begin
fillchar(a, sizeof(a), 0);
fillchar(b, sizeof(b), 0);
fillchar( queue, sizeof(queue), 0);
nl := 0;
sum := 0;
count := 0;
fillchar(list,sizeof(list),0);
end;
(*****************************************************)
procedure nhap;
var i,j:integer;
begin
readln(m,n);
for i:=1 to m do
begin
for j:=1 to n do read(a[i,j]);
readln;
end;
end;
(*****************************************************)
procedure add(var l:ptype2;i,j:byte);
var p:ptype2;
begin
new(p);
p^.i:=i;
p^.j:=j;
p^.next:=l;
l:=p;
end;
(*****************************************************)
procedure createlist;
var i,j:byte;
l,r,mid:integer;
begin
nl:=0;
for i:=1 to m do
for j:=1 to n do
begin
if (nl=0) or (list[nl].h<a[i,j]) then
begin
inc(nl);
list[nl].h:=a[i,j];
add(list[nl].list,i,j);
continue;
end;
l:=1;
r:=nl;
while l<>r do
begin
mid:=(l+r) div 2;
if list[mid].h=a[i,j] then
begin
l:=mid;
r:=mid;
break;
end;
if list[mid].h>a[i,j] then r:=mid else l:=mid+1;
end;
if list[l].h=a[i,j] then add(list[l].list,i,j)
else
begin
inc(nl);
move(list[l],list[l+1],(nl-l)*sizeof(_type1));
list[l].h:=a[i,j];
list[l].list:=nil;
add(list[l].list,i,j);
end;
end;
end;
(*****************************************************)
procedure loang(i,j:byte);
var k:byte;
begin
initqueue;
for k:=1 to 4 do if b[i+dx[k],j+dy[k]]=2 then
begin
addQ(i+dx[k]);
addQ(j+dy[k]);
dec(count);
b[i+dx[k],j+dy[k]]:=0;
end;
while not empty do
begin
i:=delete;
j:=delete;
for k:=1 to 4 do if b[i+dx[k],j+dy[k]]=2 then
begin
addQ(i+dx[k]);
addQ(j+dy[k]);
dec(count);
b[i+dx[k],j+dy[k]]:=0;
end;
end;
end;
(*****************************************************)
procedure cat(x:integer);
var p:ptype2;
i,j,k:byte;
begin
p:=list[x].list;
while p<>nil do
begin
i:=p^.i;
j:=p^.j;
for k:=1 to 4 do if b[i+dx[k],j+dy[k]]=0 then b[i,j]:=0;
if b[i,j]=0 then loang(i,j)
else
begin
b[i,j]:=2;
inc(count);
end;
p:=p^.next;
end;
sum:=sum+(list[x+1].h-list[x].h)*count;
end;
(*****************************************************)
procedure xuly;
var i,j:integer;
begin
createlist;
for i:=1 to m do
for j:=1 to n do b[i,j]:=1;
for i:=1 to nl-1 do
begin
cat(i);
end;
end;
(*****************************************************)
procedure ghi;
begin
writeln( sum);
end;
(*****************************************************)
begin
init;
nhap;
xuly;
ghi;
end;
(*****************************************************)
procedure mktest;
var i,j:integer;
k:integer;
begin
randomize;
m:=100;
n:=100;
k:=0;
writeln(m,' ',n);
for i:=1 to m do
begin
for j:=1 to n do
begin
inc(k);
write(k,' ');
end;
writeln;
end;
end;
(*****************************************************)
var
i,t : integer ;
begin
{ mktest;
_t:=time;}
//readln( t);
//for i:=1 to t do
// begin
new(list);
main(list^);
dispose(list);
// end;
{ writeln('Thoi gian:',(time-_t)/18.23 :0:4);}
end.