Cod sursa(job #1405732)

Utilizator Stefan.Andras Stefan Stefan. Data 29 martie 2015 15:49:20
Problema Flux maxim Scor 70
Compilator fpc Status done
Runda Arhiva educationala Marime 2.7 kb
program fluxulmaxim;
const nmax = 1001;
var f,g:text;
    bufin,bufout:array[1..1 shl 17] of char;
    n,m,x,y,c,i,k,t,maxf,p,min,j:longint;
    fr:array[1..nmax] of byte;
    frz,niv,coada,pred:array[1..nmax] of integer;
    viz:array[1..nmax] of boolean;
    v:array[1..5000] of integer;
    a:array[1..nmax,1..nmax] of longint;
function bfs(nod:integer):boolean;
var     p,i,st,sf:longint;
begin
    fillchar(viz,sizeof(viz),false);
    st := 0; sf := 1; coada[1] := nod; pred[nod]:=0;
    viz[nod] := true; niv[nod] := 0;
    while st < sf do
        begin
          inc(st);
          for i := 1 to n do
              if (a[coada[st], i] > 0) and (not viz[i]) then
                  begin
                    inc(sf);
                    coada[sf] := i;
                    viz[coada[sf]] := true;
                    pred[coada[sf]] := coada[st];
                    niv[coada[st]] := niv[coada[st]] + 1;
                  end;
        end;
    if viz[n] = true then bfs := true
                     else bfs := false;
end;
begin
        assign(f,'maxflow.in'); reset(f);
        assign(g,'maxflow.out'); rewrite(g);
        settextbuf(f,bufin); settextbuf(f,bufout);
        readln(f,n,m);
        for i:=1 to m do
            begin
              readln(f, x, y, c);
              a[x, y] := c;
            end;
        while bfs(1) do
            begin
              fr[1] := 1; fr[n] := 1;
              for i := 2 to n - 1 do
                   fr[pred[i]] := 1;
              k := 0;
              for i := 2 to n - 1 do
                  if (fr[i] = 0) and (a[i, n] > 0) then
                      begin
                        inc(k); frz[k]:=i;
                      end;
              //pentru toate frunzele
              for t := 1 to k do
                  begin
                    p := frz[t];
                    v[1] := n;
                    i := 1;
                    min := maxlongint;
                    while p <> 0 do
                        begin
                          inc(i);
                          v[i] := p;
                          if a[v[i], v[i-1]] < min then min := a[v[i], v[i-1]];
                          p := pred[p];
                        end;
                 //   for j := i downto 2 do
                   //     if a[v[j], v[j-1]] < min then min := a[v[j], v[j-1]];
                    for j := i downto 2 do
                        begin
                          a[v[j],v[j-1]]:=a[v[j],v[j-1]]-min;
                          a[v[j-1],v[j]]:=a[v[j-1],v[j]]+min;
                        end;
                  maxf := maxf + min;
                  end;
            end;
        writeln(g,maxf);
        close(f); close(g);
end.