CRECT - Đếm các hình chữ nhật

Tác giả: RR

Ngôn ngữ: Pascal

//Wishing myself a happy lunar new year with a lot of accept solutions
//Written by Nguyen Thanh Trung
{$R+,Q+}
uses math;
const
  FINP='';
  FOUT='';
  MAXN=411;
var
  f1,f2:text;
  a:array[0..MAXN,1..MAXN] of char;
  h,stack,l,r:array[0..MAXN] of longint;
  count:array['A'..'E','A'..'E','A'..'E'] of int64;
  ok:array[0..MAXN] of boolean;
  d:array['A'..'E'] of longint;
  m,n,kq:longint;
procedure openF; inline;
begin
  assign(f1,FINP); reset(f1);
  assign(f2,FOUT); rewrite(f2);
end;
procedure closeF; inline;
begin
  close(f1); close(f2);
end;
procedure inp; inline;
var
  i,j:longint;
begin
  readln(f1,m,n);
  for i:=1 to m do
    begin
      for j:=1 to n do read(f1,a[i,j]);
      readln(f1);
    end;
end;
procedure left; inline;
var
  i,top:longint;
begin
  top:=0; stack[0]:=0;
  for i:=1 to n do
    begin
      while (top>0) and (h[i]<=h[stack[top]]) do dec(top);
      l[i]:=stack[top]+1;
      inc(top); stack[top]:=i;
    end;
end;
procedure right; inline;
var
  i,top:longint;
begin
  top:=0; stack[0]:=n+1;
  for i:=n downto 1 do
    begin
      while (top>0) and (h[i]<=h[stack[top]]) do dec(top);
      r[i]:=stack[top]-1;
      inc(top); stack[top]:=i;
    end;
end;
procedure refine; inline;
var
  i,top:longint;
begin
  top:=0; stack[0]:=0;
  for i:=1 to n do
    begin
      while (top>0) and (h[i]<h[stack[top]]) do dec(top);
      if h[i]=h[stack[top]] then ok[i]:=false;
      inc(top); stack[top]:=i;
    end;
end;
procedure done(var kq:int64); inline;
var
  i,j,k,u,v:longint;
begin
  kq:=0;
  fillchar(h,sizeof(h),0);
  for i:=1 to m do
    begin
      for j:=1 to n do
        if d[a[i,j]]=1 then inc(h[j]) else h[j]:=0;
      fillchar(ok,sizeof(ok),true);
      left;
      right;
      refine;
      for j:=1 to n do
        begin
          if not ok[j] then continue;
          u:=l[j]; v:=r[j];
          k:=max(h[u-1],h[v+1]);
          inc(kq,(v-u+1)*(v-u+2)*(h[j]-k) div 2);
        end;
    end;
end;
function cal(c1,c2,c3:char):int64; inline;
var
  kq:int64;
begin
  fillchar(d,sizeof(d),0);
  d[c1]:=1; d[c2]:=1; d[c3]:=1;
  done(kq);
  cal:=kq;
end;
procedure solve;
var
  kq:int64;
  ch1,ch2,ch3:char;
begin
  kq:=0;
  for ch1:='A' to 'E' do
  for ch2:='A' to 'E' do
  if ch2>=ch1 then
    for ch3:='A' to 'E' do
    if ((ch1=ch2) and (ch3>=ch2)) or ((ch2>ch1) and (ch3>ch2)) then
      count[ch1,ch2,ch3]:=cal(ch1,ch2,ch3);
  for ch1:='A' to 'E' do
    for ch2:='A' to 'E' do
    if ch2>ch1 then
      for ch3:='A' to 'E' do
      if ch3>ch2 then
        kq:=kq+count[ch1,ch2,ch3]
              -count[ch1,ch1,ch2]-count[ch1,ch1,ch3]-count[ch2,ch2,ch3]
              +count[ch1,ch1,ch1]+count[ch2,ch2,ch2]+count[ch3,ch3,ch3];
  writeln(f2,kq);
end;
begin
  openF;
  inp;
  solve;
  closeF;
end.

Download