NKNET - Mạng truyền tin

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
uses math;
const
  finp='';
  fout='';
  maxn=101;
  oo=1000000;
var
  s,t,m,n:longint;
  queue,trace:array[0..maxn] of longint;
  c,c2,f:array[0..maxn,0..maxn] of longint;
procedure readinp;
var
  i,u,v:longint;
begin
  assign(input,finp);  reset(input);
  read(n,m);
  for i:=1 to m do
  begin
    read(u,v,c[u,v]);
    c[v,u]:=c[u,v];
  end;
  read(s,t);
  close(input);
end;
function findpath:boolean;
var
  first,last,i,j:longint;
begin
  fillchar(trace,sizeof(trace),0);
  first:=0;
  last:=1;
  queue[1]:=s;
  trace[s]:=n+1;
  while first<last do
  begin
    inc(first);
    i:=queue[first];
    for j:=1 to n do
    if (trace[j]=0) and (f[i,j]<c[i,j]) then
      begin
        trace[j]:=i;
        inc(last);
        queue[last]:=j;
        if j=t then exit(true);
      end;
  end;
  exit(false);
end;
procedure incflow;
var
  i,j,delta:longint;
begin
  delta:=oo;
  j:=t;
  repeat
    i:=trace[j];
    if delta>c[i,j]-f[i,j] then delta:=c[i,j]-f[i,j];
    j:=i;
  until j=s;
  j:=t;
  repeat
    i:=trace[j];
    inc(f[i,j],delta);
    dec(f[j,i],delta);
    j:=i;
  until j=s;
end;
function check(val:longint):boolean;
var
  i,j,cost:longint;
  ok:boolean;
begin
  c2:=c;
  for i:=1 to n do
  for j:=1 to n do
    if (c[i,j]<>0) and (c[i,j]<=val) then c[i,j]:=1
    else if c[i,j]>val then c[i,j]:=oo;
  fillchar(f,sizeof(f),0);
  ok:=false;
  repeat
    if not findpath then break;
    incflow;
  until ok;
  cost:=0;
  for i:=1 to n do
    if f[s,i]>0 then inc(cost,f[s,i]);
  c:=c2;
  if cost>=oo then exit(false) else exit(true);
end;
procedure printresult(val:longint);
var
  i,j,cost:longint;
  ok:boolean;
  fo:text;
begin
  for i:=1 to n do
  for j:=1 to n do
    if (c[i,j]<>0) and (c[i,j]<=val) then c[i,j]:=1
    else if (c[i,j]<>0) then c[i,j]:=oo;
  fillchar(f,sizeof(f),0);
  ok:=false;
  repeat
    if not findpath then break;
    incflow;
  until ok;
  cost:=0;
  for i:=1 to n do
    if f[s,i]>0 then inc(cost,f[s,i]);
  assign(fo,fout); rewrite(fo);
  writeln(fo,cost);
  for i:=1 to n do
  for j:=1 to n do
    if (c[i,j]<>0) and (trace[i]<>0) and (trace[j]=0)
    then writeln(fo,i,' ',j);
  close(fo);
end;
procedure solve;
var
  left,right,mid:longint;
begin
  left:=0;  right:=101;
  repeat
    mid:=(left+right) div 2;
    if check(mid) then right:=mid else left:=mid;
  until left=right-1;
  if check(left) then printresult(left) else printresult(right);
end;
begin
  readinp;
  solve;
end.

Download