ENG  RUSTimus Online Judge
Online Judge
Задачи
Авторы
Соревнования
О системе
Часто задаваемые вопросы
Новости сайта
Форум
Ссылки
Архив задач
Отправить на проверку
Состояние проверки
Руководство
Регистрация
Исправить данные
Рейтинг авторов
Текущее соревнование
Расписание
Прошедшие соревнования
Правила
вернуться в форум

Обсуждение задачи 1076. Trash

I've implemented Hungarian algo, but for some test cases, my program cycles to the infinite
Послано vladu adrian 15 июл 2003 15:39
 I've used an Hungarian algo 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.
no subject
Послано starrich 19 июл 2006 01:22
no message