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.