Cod sursa(job #578324)

Utilizator david93Demeny David david93 Data 11 aprilie 2011 10:48:47
Problema Flux maxim Scor 40
Compilator fpc Status done
Runda Arhiva educationala Marime 2.24 kb
uses crt;
type
 mut=^elem;
 elem=record
  a:longint;
  k:mut;
 end;
 let=record
  a,b:longint;
 end;
 kl=array[0..1000] of mut;
 op=array[0..1000,0..1000] of let;
 pl=array[0..1000] of longint;
var
 a,b,c,i,m,n,k,h,min,s:longint;
 d,j,j1,o,j2:pl;
 x:op;
 v:kl;
 f,g:text;
 veg,kesz:boolean;
 p:mut;
begin
 assign(f,'maxflow.in');
 reset(f);
 assign(g,'maxflow.out');
 rewrite(g);
 readln(f,n,m);
 for i:=1 to m do
  begin
   readln(f,a,b,c);
   x[a,b].a:=c;
   new(p);
   p^.a:=b;
   p^.k:=v[a];
   v[a]:=p;
   new(p);
   p^.a:=a*(-1);
   p^.k:=v[b];
   v[b]:=p;
  end;
 b:=1;   veg:=false;
 repeat
  d[1]:=1; h:=1;k:=1;
  j[1]:=b;
  kesz:=false;
  while (not(kesz))and(k<=h) do
   begin
    p:=v[d[k]];
    while (p<>nil)and(not(kesz)) do
     begin
       if p^.a >0
        then
         begin
          if (x[d[k],p^.a].b<x[d[k],p^.a].a)and(j[p^.a]<>b)
           then
            begin
              inc(h);
              j[p^.a]:=b;
              d[h]:=p^.a;
              o[p^.a]:=d[k];
              if p^.a=n then kesz:=true;
            end;
         end
        else
         begin
          a:=abs(p^.a);
          if (x[a,d[k]].b<>0)and(j[a]<>b)
           then
            begin
             inc(h);
             j[p^.a]:=b;
             d[h]:=a;
             o[a]:=(-1)*d[k];
             if a=n then kesz:=true;
            end;
         end;
       p:=p^.k;
     end;
    inc(k);
   end;
  if kesz
   then
    begin
      k:=n; i:=1;
      j1[1]:=n;
      if o[k]<0 then min:=x[k,o[k]].b
      else min:=x[o[k],k].a-x[o[k],k].b;
      while o[k]<>0 do
         begin
          inc(i);
          j1[i]:=o[abs(k)];
          if j1[i]<0
           then begin if min>x[j1[i],k].b then min:=x[j1[i],k].b;    end
           else if min>x[o[k],k].a-x[o[k],k].b then min:=x[o[k],k].a-x[o[k],k].b;

          k:=o[k];
         end;
     for a:=1 to i-1 do
       if j1[a]>0
        then x[j1[a+1],j1[a]].b:= x[j1[a+1],j1[a]].b+min
        else x[j1[a],j1[a+1]].b:=x[j1[a],j1[a+1]].b-min;
    end
   else veg:=true;
  inc(b);
  d:=j2;
 until veg;
 p:=v[n]; s:=0;
 while p<>nil do
  begin
   s:=s+x[abs(p^.a),n].b;
   p:=p^.k;
  end;
 writeln(g,s);
 close(f);
 close(g);
end.