Re: Just use Hungarian algo (-)
> I've used a Hungarian algo that I've found on the NET. I don't know
if it's correct because, for some tests it cycles to the infinite
because no modifications can be done. Please, could somebody give me
an algo that works?
Here's my source. Usually it works fine but, as I said, in some cases
it doesn't work.
program trash;
const nmax = 150;
var a, d : array [1..nmax, 1..nmax] of integer;
s : array [1..nmax] of integer;
nz : array [1..nmax] of byte;
m, b : array [1..nmax, 1..nmax] of boolean;
hasm, found : boolean;
mlin, mcol : array [1..nmax] of boolean;
ming1 : integer;
sum : longint;
N, i, j : byte;
procedure readdata;
begin
{ assign(input, 'trash.in'); reset(input);}
fillchar(s, sizeof(s), 0);
readln(N);
for i:=1 to N do
begin
for j:=1 to N do
begin
read(d[i,j]);
inc(s[i], d[i,j]);
end;
for j:=1 to N do
begin
a[i,j]:=s[i]-d[i,j];
d[i,j]:=a[i,j];
end;
readln;
end;
{ close(input);}
end;
procedure DoZero;
var i, j : byte;
min : integer;
begin
for i:=1 to N do
begin
min:=a[i,1];
for j:=2 to N do
if a[i,j]<min then
min:=a[i,j];
for j:=1 to N do
dec(a[i,j], min);
end;
for j:=1 to N do
begin
min:=a[1,j];
for i:=2 to N do
if a[i,j]<min then
min:=a[i,j];
for i:=1 to N do
dec(a[i,j],min);
end;
end;
function DoMark:boolean;
var i, j, k, min, r : byte;
begin
fillchar(nz, sizeof(nz), 0);
fillchar(m, sizeof(m), 0);
fillchar(b, sizeof(b), 0);
for i:=1 to N do
for j:=1 to N do
if a[i,j]=0 then
inc(nz[i]);
for k:=1 to N do
begin {choose a row with min 0's}
min:=255;
for i:=1 to N do
if (nz[i]>0)and(nz[i]<min) then
begin
min:=nz[i];
r:=i;
end;
if min=255 then
begin
DoMark:=false;
exit;
end;
j:=1;
nz[r]:=0;
while (a[r,j]<>0)or(b[r,j]) do inc(j);
m[r,j]:=true; {is marked}
for i:=j+1 to N do
if (a[r,i]=0) then
b[r,i]:=true;
for i:=1 to N do
if (i<>r)and(a[i,j]=0) then
begin
b[i,j]:=true;
dec(nz[i]);
end;
end;
DoMark:=true;
end;
begin
readdata;
DoZero;
while not DoMark do
begin
fillchar(mlin, sizeof(mlin), false);
fillchar(mcol, sizeof(mcol), false);
for i:=1 to N do
begin
hasm:=false;
for j:=1 to N do
if m[i,j] then
begin
hasm:=true;
break;
end;
if not hasm then mlin[i]:=true;
end;
repeat
found:=false;
for i:=1 to N do
if mlin[i] then
for j:=1 to N do
if (b[i,j])and(mcol[j]=false) then
begin
mcol[j]:=true;
found:=true;
end;
if found then
for j:=1 to N do
if mcol[j] then
for i:=1 to N do
if (m[i,j])and(not mlin[i]) then
begin
mlin[i]:=true;
found:=true;
end;
until not found;
{i've made the marking}
ming1:=maxint;
for i:=1 to N do
for j:=1 to N do
if (mlin[i])and(not mcol[j])and(a[i,j]<ming1) then
ming1:=a[i,j];
for i:=1 to N do
for j:=1 to N do
if (mlin[i])and(not mcol[j]) then
dec(a[i,j], ming1);
for i:=1 to N do
for j:=1 to N do
if (not mlin[i])and(mcol[j]) then
inc(a[i,j], ming1);
end;
sum:=0;
for i:=1 to N do
for j:=1 to N do
if m[i,j] then
inc(sum, d[i,j]);
writeln(sum);
end.