HAOI6000 - HAOI 6000

Tác giả: RR

Ngôn ngữ: Pascal

{$R+,Q+}
program HAOI6000;
const
  FINP='';
  FOUT='';
  MAXN=1001;
  oo=2000001;
var
  xet:array[1..MAXN,1..MAXN,1..2] of byte;
  a:array[1..MAXN,1..MAXN] of byte;
  min,sl,m,n:longint;
procedure inp;
var
  f:text;
  i,j:longint;
begin
  assign(f,FINP); reset(f);
  readln(f,m,n);
  for i:=1 to m do
    for j:=1 to n do
      read(f,a[i,j]);
  close(f);
end;
procedure ans;
var
  f:text;
begin
  assign(f,FOUT); rewrite(f);
  if sl=0 then
    begin
      writeln(f,'0 0');
      close(f); halt;
    end;
  writeln(f,min,' ',sl);
  close(f);
end;
procedure find(i:longint);
var
  l,u,v,k:longint;
begin
  u:=1; v:=i; k:=1; l:=1;
  repeat
    inc(l); xet[u,v,k]:=1;
    if l>min then exit;
    if (a[u,v]=0) and (k=1) then
      begin
        if (v<n) and (xet[u,v+1,2-a[u,v+1]]=0) then
          begin
            inc(v);
            k:=2-a[u,v];
          end
        else if (u>1) and (xet[u-1,v,2]=0) then
          begin
            dec(u);
            k:=2;
          end
        else exit;
      end
    else if (a[u,v]=0) and (k=2) then
      begin
        if (v>1) and (xet[u,v-1,1+a[u,v-1]]=0) then
          begin
            dec(v);
            k:=1+a[u,v];
          end
        else if (u<m) and (xet[u+1,v,1]=0) then
          begin
            inc(u);
            k:=1;
          end
        else exit;
      end
    else if (a[u,v]=1) and (k=1) then
      begin
        if (v>1) and (xet[u,v-1,1+a[u,v-1]]=0) then
          begin
            dec(v);
            k:=1+a[u,v];
          end
        else if (u>1) and (xet[u-1,v,2]=0) then
          begin
            dec(u);
            k:=2;
          end
        else exit;
      end
    else if (a[u,v]=1) and (k=2) then
      begin
        if (v<n) and (xet[u,v+1,2-a[u,v+1]]=0) then
          begin
            inc(v);
            k:=2-a[u,v];
          end
        else if (u<m) and (xet[u+1,v,1]=0) then
          begin
            inc(u);
            k:=1;
          end
        else exit;
      end;
  until (u=m) and (k=2);
  if l<min then begin min:=l; sl:=1; end
  else if l=min then inc(sl);
end;
procedure solve;
var
  i:longint;
begin
  min:=oo;
  for i:=1 to n do
    find(i);
end;
begin
  inp;
  solve;
  ans;
end.

Download