# Cod sursa(job #85179)

Utilizator Data 20 septembrie 2007 15:54:56 Traseu 100 fpc done Arhiva de probleme 4.28 kb
``````program renovare;
const
fin='traseu.in';
fout='traseu.out';
inf=maxlongint shr 2;
nmax=100;
mmax=10000;
var
start,target,prev,cost:array[0..mmax] of longint;
pred,last,pret:array[0..nmax] of longint;
d:array[0..nmax,0..nmax] of longint;
delta,capa,flow:array[0..mmax] of longint;
sink,srs:longint;
ok:boolean;
list:array[0..nmax] of longint;
este:array[0..nmax] of boolean;
pop,push:longint;
iin,iout:array[0..nmax] of longint;
m,n,xflow,crt,tcost,a,b,c,cst,i,j,k,x,y,nedge,tflow:longint;

function op(x:longint):longint;
begin
if x and 1=1 then
op:=x+1
else
op:=x-1;
end;

procedure insert(a,b,cap,cst:longint);
begin
inc(nedge);
start[nedge]:=a;target[nedge]:=b;
cost[nedge]:=cst;
capa[nedge]:=cap;
flow[nedge]:=0;
prev[nedge]:=last[a];
last[a]:=nedge;
inc(nedge);
start[nedge]:=b;target[nedge]:=a;
cost[nedge]:=-cst;
capa[nedge]:=0;
flow[nedge]:=0;
prev[nedge]:=last[b];
last[b]:=nedge;
end;

begin
assign(input,fin);
reset(input);
fillchar(last,sizeof(last),0);
nedge:=0;
tcost:=0;
for i:=1 to n do
for j:=1 to n do
d[i,j]:=inf;
for i:=1 to m do
begin
d[a,b]:=cst;
inc(iin[b]);inc(iout[a]);
inc(tcost,cst);
end;
sink:=nmax;
srs:=nmax-1;
for i:=1 to n do
d[i,i]:=0;
for k:=1 to n do
for i:=1 to n do
for j:=1 to n do
if d[i,j]>d[i,k]+d[k,j] then
d[i,j]:=d[i,k]+d[k,j];
for i:=1 to n do
if iin[i]>iout[i] then
begin
insert(srs,i,iin[i]-iout[i],0);
end
else if iout[i]>iin[i] then
begin
insert(i,sink,iout[i]-iin[i],0);
end;
for i:=1 to n do
if iin[i]>iout[i] then
for j:=1 to n do
if iout[j]>iin[j] then
insert(i,j,inf,d[i,j]);
ok:=false;
while not(ok) do
begin
for i:=1 to n+1 do
pret[i]:=inf;
pop:=1;push:=2;
fillchar(este,sizeof(este),false);
fillchar(delta,sizeof(delta),0);
fillchar(pred,sizeof(pred),0);
list[pop]:=srs;
pret[srs]:=0;
for i:=1 to n do
pret[i]:=inf;
pret[sink]:=inf;
delta[srs]:=inf;
este[srs]:=true;
pred[srs]:=0;
while pop<>push do
begin
crt:=last[list[pop]];
if start[crt]<>sink then
if pret[list[pop]]<pret[sink] then
while crt>0 do
begin
if capa[crt]-flow[crt]>0 then
begin
if delta[list[pop]]<capa[crt]-flow[crt] then
x:=delta[list[pop]]
else
x:=capa[crt]-flow[crt];
if pret[start[crt]]+cost[crt]<pret[target[crt]] then
begin
if este[target[crt]]=false then
begin
list[push]:=target[crt];
inc(push);
if push=nmax+1 then
push:=1;
este[target[crt]]:=true;
end;
pred[target[crt]]:=crt;
delta[target[crt]]:=x;
pret[target[crt]]:=pret[start[crt]]+cost[crt];
end;
end;
crt:=prev[crt];
end;
este[list[pop]]:=false;
inc(pop);
if pop=nmax+1 then
pop:=1;
end;
if delta[sink]<>0 then
begin
inc(tflow,delta[sink]);
x:=pred[sink];
while x>0 do
begin
inc(flow[x],delta[sink]);
flow[op(x)]:=-flow[x];
x:=pred[start[x]];
end;
end
else
ok:=true;
end;
close(input);
assign(output,fout);
rewrite(output);
for i:=1 to nedge do
if flow[i]>0 then
inc(tcost,flow[i]*cost[i]);
writeln(tcost);
close(output);
end.
``````