ac1088.pas

这是在网络上搜集到的在东京大学的ACM上面解决的一些题目的源码

program tju1088;
const
  maxmap=200;
  maxstrips=sqr(maxmap) shr 1;
type
  strip=record p,s,e:word;end;
  striplist=array[0..maxstrips+1]of strip;
var
  map:array[1..maxmap,1..maxmap]of byte;
  x,y:striplist;
  from,till:array[1..maxmap]of word;
  my:array[1..maxstrips]of word;
  vy:array[1..maxstrips]of boolean;
  m,n,i,j,cx,cy,ans:word;
function max(a,b:byte):byte;
  begin
    if a>b then max:=a else max:=b;
  end;
procedure makestrips(var l:striplist;var c:word);
  var
    i,j:byte;
    open:boolean;
  begin
    c:=0;
    for i:=1 to m do begin
      open:=false;
      for j:=1 to n do
        case map[i,j] of
          0:if open then
              l[c].e:=j
            else begin
              open:=true;inc(c);with l[c] do begin p:=i;s:=j;e:=j;end;
            end;
          2:open:=false;
        end;
    end;
  end;
procedure flip;
  var
    l,i,j,t:word;
  begin
    l:=max(m,n);
    for i:=2 to l do
      for j:=1 to i-1 do begin
        t:=map[i,j];map[i,j]:=map[j,i];map[j,i]:=t;
      end;
    t:=m;m:=n;n:=t;
  end;
procedure calfromtill;
  var
    i,j,k:word;
  begin
    y[0].p:=0;y[cy+1].p:=maxint;

    k:=0;
    for i:=1 to cy do
      if y[i].p>y[i-1].p then
        repeat inc(k);from[k]:=i;until k=y[i].p;
    while k<n do begin inc(k);from[k]:=cy+1;end;

    k:=n+1;
    for i:=cy downto 1 do
      if y[i].p<y[i+1].p then
        repeat dec(k);till[k]:=i;until k=y[i].p;
    while k>1 do begin dec(k);till[k]:=0;end;
  end;
function cross(a,b:word):boolean;
  begin
    cross:=(map[x[a].p,y[b].p]=0) and
           (x[a].p>=y[b].s) and (x[a].p<=y[b].e) and
           (y[b].p>=x[a].s) and (y[b].p<=x[a].e);
  end;
function find(v:word):boolean;
  var
    i:word;
  begin
    for i:=from[x[v].s] to till[x[v].e] do
      if not vy[i] and (my[i]=0) and cross(v,i) then begin
        my[i]:=v;find:=true;exit;
      end;
    for i:=from[x[v].s] to till[x[v].e] do
      if not vy[i] and cross(v,i) then begin
        vy[i]:=true;
        if find(my[i]) then begin
          my[i]:=v;find:=true;exit;
        end;
      end;
    find:=false;
  end;
procedure match;
  var
    i:word;
    t:strip;
  begin
    fillchar(my,sizeof(my),0);
    ans:=0;
    for i:=1 to cx do begin
      fillchar(vy,sizeof(vy),0);
      if find(i) then inc(ans);
    end;
    writeln(ans);
  end;
begin
  repeat
    read(m,n);
    for i:=1 to m do
      for j:=1 to n do
        read(map[i,j]);
    makestrips(x,cx);flip;
    makestrips(y,cy);flip;
    calfromtill;
    match;
  until seekeof;
end.