Cod sursa(job #36736)

Utilizator andradaqAndrada Georgescu andradaq Data 23 martie 2007 23:31:37
Problema Critice Scor 20
Compilator fpc Status done
Runda Arhiva de probleme Marime 2.31 kb
var c,f,idx:array[1..1000,1..1000] of integer;
    viz,q,a:array[1..1000] of integer;
    b:array[1..10000] of integer;
    max,n,nsol,m,i,j,k,x,y,cost:integer;
    fi:text;


function parcurge(x:integer):boolean;
var i,j,k,vf:integer;
begin
parcurge:=true;
fillchar(viz,sizeof(viz),0);
viz[x]:=-1;
i:=1; j:=1;
q[1]:=x;
while i<=j do
 begin
 vf:=q[i];
 for k:=1 to n do
  if (c[vf,k]-f[vf,k]>0) and (viz[k]=0) then
   begin
   inc(j);
   q[j]:=k;
   viz[k]:=vf;
   if k=n then exit;
   end;
 inc(i);
 end;
parcurge:=false;
end;

function detmax(x:integer):integer;
var m,ma:integer;
begin
ma:=c[viz[x],x]-f[viz[x],x];
if viz[x]=1 then detmax:=ma
 else
  begin
  m:=detmax(viz[x]);
  if m<ma then detmax:=m else detmax:=ma;
  end;
end;

procedure cresteflux(x,max:integer);
begin
if x<>1 then
 begin
 f[viz[x],x]:=f[viz[x],x]+max;
 f[x,viz[x]]:=-f[viz[x],x];
 cresteflux(viz[x],max);
 end;
end;

procedure p1;
var i,j,k,vf:integer;
begin
a[1]:=1;
fillchar(viz,sizeof(viz),0);
viz[1]:=-1;
i:=1; j:=1;
q[1]:=1;
while i<=j do
 begin
 vf:=q[i];
 for k:=1 to n do
  if (c[vf,k]-f[vf,k]>0) and (viz[k]=0) then
   begin
   inc(j);
   q[j]:=k;
   viz[k]:=vf;
   a[k]:=1;
   end;
 inc(i);
 end;
end;

procedure pn;
var i,j,k,vf:integer;
begin
b[n]:=1;
fillchar(viz,sizeof(viz),0);
viz[n]:=-1;
i:=1; j:=1;
q[1]:=n;
while i<=j do
 begin
 vf:=q[i];
 for k:=1 to n do
  if (c[k,vf]-f[k,vf]>0) and (viz[k]=0) then
   begin
   inc(j);
   q[j]:=k;
   viz[k]:=vf;
   a[k]:=2;
   end;
 inc(i);
 end;
end;

begin
assign(fi,'critice.in'); reset(fi);
readln(fi,n,m);
fillchar(c,sizeof(c),0);
fillchar(f,sizeof(f),0);
for i:=1 to m do
 begin
 readln(fi,x,y,cost);
 c[x,y]:=cost;
 c[y,x]:=cost;
 idx[x,y]:=i;
 idx[y,x]:=i;
 end;
close(fi);

repeat
 if parcurge(1) then
   begin
   max:=detmax(n);
   cresteflux(n,max);
   end
 else break;
until 1=0;

p1;
pn;

assign(fi,'critice.out'); rewrite(fi);
for i:=1 to n do
 for j:=1 to n do
  if (c[i,j]>0) and (c[i,j]=f[i,j]) and (a[i]+a[j]=3) then
   begin
   inc(nsol);
   b[nsol]:=idx[i,j];
   end;
for i:=1 to nsol-1 do
 for j:=i+1 to nsol do
  if b[i]>b[j] then
   begin
   max:=b[i];
   b[i]:=b[j];
   b[j]:=max;
   end;
writeln(fi,nsol);
for i:=1 to nsol do writeln(fi,b[i]);
close(fi);
end.