Cod sursa(job #553466)

Utilizator david93Demeny David david93 Data 14 martie 2011 08:45:24
Problema Flux maxim Scor 60
Compilator fpc Status done
Runda Arhiva educationala Marime 1.9 kb
uses crt;
type
 op=record
 a,b:longint;
 end;
 kl=array[1..1000,1..1000]of op;
 lp=array[1..1000]of longint;
var
 a,b,c,i,l,m,n,h,k,min,s:longint;
 f,g:text;
 j,d,d2,e,v:lp;
 x:kl;
 csel:boolean;
function vissza:integer;
var a,b:integer;
begin
 a:=n;b:=1;v[1]:=n; min:=1001;
 while a<>1 do
  begin
     a:=abs(e[a]);
     inc(b);
     v[b]:=a;
     if e[v[b-1]]>0
      then
       begin
         if min>x[v[b],v[b-1]].a- x[v[b],v[b-1]].b
           then min:=x[v[b],v[b-1]].a- x[v[b],v[b-1]].b;
       end
      else
        if min>x[v[b-1],v[b]].b then min:=x[v[b-1],v[b]].b
  end;
  vissza:=b;
end;
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;
  end;
 csel:=true;
 while csel do
   begin
    csel:=false; e:=d2;
    d:=d2;k:=1;  j:=d2;
    d[1]:=1; h:=1; j[1]:=1;
    while not(csel)and(k<=h) do
     begin
      i:=1;
      while (i<=n)and(not(csel)) do
      begin
       if (x[d[k],i].a<>0)and(x[d[k],i].a<>x[d[k],i].b)and(j[i]=0)
        then
         begin
          inc(h);
          d[h]:=i; j[i]:=1;
          e[i]:=d[k];
          if i=n then csel:=true;
         end
        else
         if (x[i,d[k]].a<>0)and(x[i,d[k]].b<>0)and(j[i]=0)
           then
            begin
              inc(h);
              d[h]:=i;j[i]:=1;
              e[i]:=(-1)*d[k];
              if i=n then csel:=true;
            end;
       inc(i);
      end;
      inc(k);
     end;
        if csel then
        begin
          v:=d2;
          b:=vissza;
          for i:=b-1 downto 1 do
            if (x[v[i+1],v[i]].a<>0)
               then x[v[i+1],v[i]].b:= x[v[i+1],v[i]].b+min
               else x[v[i],v[i+1]].b:= x[v[i],v[i+1]].b-min
        end;
   end;
 s:=0;
 for i:=1 to n do
  s:=s+x[i,n].b;
 write(g,s);
 close(f);
 close(g);
end.