Cod sursa(job #288740)

Utilizator 7RaduRadu Antohi 7Radu Data 26 martie 2009 08:35:54
Problema Flux maxim Scor 60
Compilator fpc Status done
Runda Arhiva educationala Marime 1.83 kb
program Flux;
var
  a,f:array[1..1000,1..1000] of integer;
  viz:array[1..1000] of boolean;
  c,t:array[1..1000] of longint;
  n,i,j,k,l,p,z,x,y,m,s,d,min1,ftot:longint;
  fl:text;

function bf:boolean;
var
  p,u,k,i:longint;
begin
   for i := 1 to n do
      viz[i] := false;
   c[1] := s;
   p := 1;
   u := 1;
   while p<= u do
      begin
        k := c[p];
        for i := 1 to n do
          if not viz[i] and (a[k,i]-f[k,i] > 0) then
             begin
                inc(u);
                c[u] := i;
                t[i] := k;
                viz[i] := true;
             end;
          inc(p);
      end;
   if viz[d] then
      bf := true
   else
     bf := false;
end;
begin
   assign(fl,'maxflow.in');
   reset(fl);
   readln(fl,n,m);
   for i := 1 to n do
     for j := 1 to n do
       begin
         a[i,j] := 0;
         f[i,j] := 0;
       end;
   for i := 1 to m do
      begin
         readln(fl,x,y,z);
         a[x,y] := z;
      end;
   s := 1;
   d := n;
   close(fl);

   while bf do
      for i := 1 to n do
         if a[i,n]-f[i,n]>0 then
            begin
               min1 := a[i,n]-f[i,n];
               j := i;
               while j <> s do
                  begin
                     if a[t[j],j]-f[t[j],j]<min1 then
                     min1 := a[t[j],j]-f[t[j],j];
                     j := t[j];
                  end;
               j := i;
               while j <> 1 do
                 begin
                    f[t[j],j]:=f[t[j],j]+min1;
                    f[j,t[j]]:=f[j,t[j]]-min1;
                    j := t[j];
                end;
              f[i,n] := f[i,n]+min1;
              f[n,i] := f[n,i]-min1;
              ftot:=ftot+min1;
           end;

   assign(fl,'maxflow.out');
   rewrite(fl);
   writeln(fl,ftot);
   close(fl);
end.