FLOW1 - Giao lưu

Tác giả: RR

Ngôn ngữ: Pascal

{$R+,Q+}
PROGRAM FLOW1;
CONST
  fi='';
  fo='';
  maxn=255;
  max=2;
TYPE
  stack=^ds;
  ds=record data:integer; next:stack; end;
VAR
  n,m:byte;
  c,d:array[0..maxn*4+1,0..maxn*4+1] of byte;
  xet:array[0..maxn*4+1] of boolean;
  dt:array[0..maxn*4+1] of shortint;
  pre:array[0..maxn*4+1] of integer;
  top:stack;
  timeold:longint;
Procedure ReadInput;
Var
  f:text;
  i,j:integer;
Begin
  Assign(f,fi); Reset(f);
  Readln(f,n,m);
  For i:=1 to n do
  begin
    While not Eoln(f) do
      begin
        Read(f,j);
        c[i,n+j]:=1;
      end;
    Readln(f);
  end;
  For i:=1 to n do
  begin
    While not Eoln(f) do
      begin
        Read(f,j);
        c[n+m+j,n+2*m+i]:=1;
      end;
    Readln(f);
  end;
  Close(f);
End;
Procedure Init;
Var
  i:integer;
Begin
  For i:=1 to n do c[0,i]:=1;
  For i:=1 to n do c[2*m+n+i,2*m+2*n+1]:=1;
  For i:=1 to m do c[n+i,n+m+i]:=1;
End;
Procedure WriteOutput;
Var
  f:text;
  i,j:integer;
  found:boolean;
Begin
  Assign(f,fo); Rewrite(f);
  For i:=1 to m do
    begin
      found:=false;
      For j:=1 to n do
        If d[j,n+i]=1 then
          begin Write(f,j,' '); found:=true; end;
      If not found then Writeln(f,'0 0');
      For j:=1 to n do
        If d[n+m+i,2*m+n+j]=1 then
          begin Write(f,j,' '); end;
      If found then Writeln(f);
    end;
  Close(f);
End;
Procedure Push(a:integer);
Var
  p:stack;
Begin
  New(p); p^.data:=a; p^.next:=top; top:=p;
End;
Procedure Pop(var a:integer);
Var
  p:stack;
Begin
  p:=top; a:=p^.data; top:=p^.next; Dispose(p);
End;
Procedure KhoiTri;
Var
  i:integer;
Begin
  For i:=1 to 2*m+2*n+1 do xet[i]:=false;
  For i:=1 to 2*m+2*n+1 do dt[i]:=max;
  For i:=1 to 2*m+2*n+1 do pre[i]:=0;
  xet[0]:=true;
  dt[0]:=max;
  top:=nil;
  Push(0);
End;
Function min(a,b:shortint):shortint;
Begin
  If a<b then min:=a else min:=b;
End;
Procedure GanNhan(u:integer);
Var
  i:integer;
Begin
  For i:=1 to 2*m+2*n+1 do
    If (not xet[i]) and (d[u,i]<c[u,i]) and (c[u,i]>0) then
      begin
        xet[i]:=true;
        Push(i);
        dt[i]:=min(dt[u],c[u,i]-d[u,i]);
        pre[i]:=u;
      end
  else
    If (not xet[i]) and (d[i,u]>0) and (c[i,u]>0) then
      begin
        xet[i]:=true;
        Push(i);
        dt[i]:=min(d[i,u],dt[u]);
        pre[i]:=-u;
      end;
End;
Procedure TangLuong;
Var
  x,truoc:integer;
Begin
  x:=2*m+2*n+1;
  repeat
    truoc:=pre[x];
    If truoc>=0 then d[truoc,x]:=d[truoc,x]+dt[2*m+2*n+1]
    else d[x,-truoc]:=d[x,-truoc]-dt[2*m+2*n+1];
    truoc:=abs(truoc);
    x:=truoc;
  until x=0;
End;
Procedure Solve;
Var
  u:integer;
Begin
  repeat
    KhoiTri;
    While (top<>nil) and (not xet[2*m+2*n+1]) do
      begin
        Pop(u);
        GanNhan(u);
      end;
    TangLuong;
  until not xet[2*m+2*n+1];
End;
BEGIN
  ReadInput;
  Init;
  Solve;
  WriteOutput;
END.

Download