реализуемо ли Опции

[мисс_граффити]

Идея такая: если безнулевых столбцов/строк больше, накладываем запрет на вычеркивание строк/столбцов соответственно. Если поровну (частный случай - ни одного) - идем по старому алгоритму.
Что скажешь?

[Bokul]

можно обойтись вычеркиванием трех строк, а программка предлагает 4 столбца...

Я допустил ошибку:

             
             if NColumn.n=NLine.n then
                 if GetWithoutZero(true)>GetWithoutZero(false) then
                    WriteColumn:=true
                 else
                     WriteColumn:=true;//<---!надо заменить на false!
             if WriteColumn then begin

Хотя с моим вариантом он не справляется все-равно .

если безнулевых столбцов/строк больше, накладываем запрет на вычеркивание строк/столбцов соответственно

Почти тоже самое в моей последнем варианте - только вместо запрета разрешение..

Если поровну (частный случай - ни одного) - идем по старому алгоритму.

А если еще потом окажется, что максимальное количество нулей в строке и столбце одинаковое? Как линию проводить, горизонтально или вертикально?

Сообщение отредактировано: Bokul - 3.01.2007 5:07

[мисс_граффити]

вроде как непринципиально...

Я про немножко другой алгоритм... у тебя идет проверка на кол-во ненулевых только при NColumn.n=NLine.n.
А я предлагаю делать так:
1) Смотрим на ненулевые строки и столбцы.
2) Если строк больше, вычеркиваем только строки с нулями.
3) Если столбцов больше, вычеркиваем только столбцы с нулями.
4) Если поровну (как вариант - полное отсутствие) - идем по старому алгоритму... то есть ищем, где у нас больше нулей и т.д.

[Bokul]

0 0 1 1 1
1 1 0 1 1
1 1 0 1 1
1 1 0 1 1
1 1 1 1 1

У меня есть идейка, сейчас попробую додумать..

[Bokul]

Переделать старый алгоритм("то есть ищем, где у нас больше нулей и т.д") на роботу не только с квадратными матрицами. Но изменения будут касаться не только сменой границ счетчиков (з двух n-ов станет до m и до n), но и добавлением условия - если полученное число вычеркиваний меньше меньшей стороны матрицы - делаем их, в противном случае проводим линии перпендикулярно меньшей стороне.

Тогда в квадратной матрицы, в случае существования безнулевых строчек/столбцов, мы их удаляем и передаем полученную матрицу обновлённому "старому" алгоритму, описанному выше.

Например:

(0,1,0,1,0),
(1,0,1,1,1),
(1,0,0,1,0),
(0,1,1,1,1),
(0,0,0,1,0));

1-ый шаг

(0,1,0,0),
(1,0,1,1),
(1,0,0,0),
(0,1,1,1),
(0,0,0,0));

2-ой шаг

(Количество вычеркиваний согласно "старому" алгоритму=5) > (меньшей стороны 4), по тому проводим четыре вертикальных линии.

Ну как?

Сообщение отредактировано: Bokul - 3.01.2007 5:43

[Bokul]

Блин, написал код и для этого алгоритма, но он тоже не правильный - задыхается на таком примере:

1 0 0 0 1
1 1 1 1 0
0 1 1 1 0
0 1 1 1 1
1 0 0 0 1

[мисс_граффити]

почему? чем этот пример такой особенный???
покажешь код?

[Bokul]

uses crt;
const
     n=5;
     ar:array[1..n,1..n] of byte=((0,1,0,1,0),
                                  (1,0,1,1,1),
                                  (1,0,0,1,0),
                                  (0,1,0,1,1),
                                  (0,0,0,1,0));
Type
    TElement=record
        info:byte;
        checked:boolean;
    end;
    TRes=record
        ind,n:byte;
    end;
    TCrossing=record//хранит номер вычеркнутого столбца/строки и что было вычеркнуто - столбец/строка
        ind:byte;
        IsLine:boolean;
    end;

Var mas:array[1..n,1..n] of TElement;
    NCol,NLin:byte;//длинна столбца/строки псле удаления
    DeletedLines,DeletedColumns: set of byte;//удаленные строки/столцбы
    Crossed:array[1..n] of TCrossing;//массив вычеркиваний используя "старый" алгоритм.
procedure init;
var i,j:byte;
begin
  DeletedLines:=[];
  DeletedColumns:=[];
  for i:=1 to n do
      for j:=1 to n do
          begin
               mas[i,j].info:=ar[i,j];
               mas[i,j].checked:=false;
          end;
end;

function GetMax(isLine: boolean):TRes;
var i,j,max:byte;
    res:TRes;
    value: TElement;
begin
  max:=0;
  res.n:=0;
  res.ind:=0;
  for i:=1 to n do
      begin
           for j:=1 to n do begin
               if  isLine then value := mas[i, j] else value := mas[j, i];
               if  (value.info=0) and (value.checked=false) then inc(max);
           end;
           if max>res.n then
              begin
                   res.n:=max;
                   res.ind:=i;
              end;
           max:=0;
      end;
  GetMax:=res;
end;

function GetWithoutZero(IsColumn:boolean):byte;
var i,j:byte; b:boolean; value:TElement;
begin
  for i:=1 to n do
      begin
           b:=true;
           for j:=1 to n do
               begin
                    if IsColumn then value:=mas[j,i] else value:=mas[i,j];
                    if (value.info=0) then
                        b:=false
               end;
           if b then
              if ((IsColumn)       and ((i in(DeletedColumns))=false)) or
                 ((IsColumn=false) and ((i in(DeletedLines))=false)) then begin

                 GetWithoutZero:=i;
                 exit;
               end;
      end;
  GetWithoutZero:=0;
end;

procedure CrossColumn(num:byte);
var i:byte;
begin
  for i:=1 to n do
      mas[i,num].checked:=true;
end;

procedure CrossLine(num:byte);
var i:byte;
begin
  for i:=1 to n do
      mas[num,i].checked:=true;
end;

procedure Delete;{удаляем безнулевые строки/столбцы. На самом деле они не удаляются, а заносятся в множества DeletedLines и DeletedColumns}
var NL,NC:byte;
begin
  NCol:=n;//сколько сталось неудаленных столбцов
  NLin:=n;//сколько сталось неудаленных строк
  repeat
        NL:=GetWithoutZero(false);
        NC:=GetWithoutZero(true);
        if NL<>0 then begin
           DeletedLines:=DeletedLines+[NL];//так происходит "удаление" строки
           dec(NLin);
        end;
        if NC<>0 then begin
           DeletedColumns:=DeletedColumns+[NC];//а так- столбца
           dec(NCol);
        end;
  until (NL=0) and (NC=0);
end;


var i,NOldMethod:byte;
    NLinTog,NColTog:TRes;
    Min:TCrossing;
begin
  clrscr;
  init;
  delete;

//-----------------Step Two--------------------

  if NCol<NLin then begin //ищем меньшую сторону в "новой" матрице
     Min.ind:=NCol;
     Min.IsLine:=false;
  end
  else begin
       Min.ind:=NLin;
       Min.IsLine:=true;
  end;

//а вот и старый алгоритм
  NLinTog:=GetMax(true);//максимальное число нулей, идущих вподряд в строке
  NColTog:=GetMax(false);// в столбце
  NOldMethod:=0;
  while ((NLinTog.n<>0) and (NColTog.n<>0)) and (NOldMethod<Min.ind) do
        begin
             inc(NOldMethod);
             if NColTog.n>NLinTog.n then begin
                Crossed[NOldMethod].ind:=NColTog.ind;//вместо writeln записываем результат в массив
                Crossed[NOldMethod].IsLine:=false;
                CrossColumn(NColTog.ind);
             end
             else begin
                  Crossed[NOldMethod].ind:=NLinTog.ind;// тут тоже самое
                  Crossed[NOldMethod].IsLine:=true;
                  CrossLine(NLinTog.ind);
             end;
             NLinTog:=GetMax(true);
             NColTog:=GetMax(false);
       end;
  if Min.ind<=NOldMethod then begin//сравниваем, каким способом будет меньше вычеркиваний 
     for i:=1 to n do //выводим результат 
         if Min.IsLine then begin
            if not(i in DeletedLines) then  writeln('Line ',i);
         end
         else
            if not(i in DeletedColumns) then writeln('Column ',i);
  end
  else
      for i:=1 to NOldMethod do//выводим результат 
          if Crossed[i].IsLine then writeln('Line ',Crossed[i].ind)
          else writeln('Column ',Crossed[i].ind);
  readln;
end.

почему? чем этот пример такой особенный???

Можно пройтись по периметру, сделав только 4 вычеркивания, мой алгоритм делает 5. Проблема все в том же - как вычеркивать в случае равенства горизонтально ли вертикально?

[мисс_граффити]

рассматиривать отдельно?...
поскольку "развилок" может получиться много (особенно на больших массивах), это проблематично.

helga, а тебе непременно венгерский метод нужен?

[.helga]

уже нет, мне изменили постановку задачи, теперь немного другая тема.

но все равно интересно, как это сделать можно )

[Malice]

Проще всего сделать перебором, вот так, например:

uses crt;
const
 n=5;
 ar:array[1..n,1..n] of byte=
((1,0,0,0,1),
(1,1,1,1,0),
(0,1,1,1,0),
(0,1,1,1,1),
(1,0,0,0,1));
type TElement=record
      info:byte;
        checked:boolean;
    end;
mas_= array [1..n,1..n] of TElement;
Var y,mas:mas_;
mn,mnn,x,i,j:word;
b:boolean;
k:integer;
s1,s2,s11,s22:string;
 function IntToStr(I: Longint): String;
var
  S: string;
begin Str(I, S);  IntToStr := S;  end;
begin
mn:=n; mnn:=255; clrscr;
for i:=1 to n do for j:=1 to n do begin
mas[i,j].info:=ar[i,j]; mas[i,j].checked:=false;
end;
for x:=0 to $ffff do begin
i:=0; y:=mas;
s1:=''; s2:='';
while (i+1)<=n do begin
if (1 shl i) and (x and $Ff)>0 then begin
for j:=1 to n do y[j,i+1].checked:=true;
s1:=s1+inttostr(i+1)+' '; end;
if ((1 shl i) and ((x and $Ff00) shr 8))>0 then begin
s2:=s2+inttostr(i+1)+' ';
for j:=1 to n do y[i+1,j].checked:=true; end;
inc (i);
end;
b:=true;
for i:=1 to n do for j:=1 to n do
if (y[i,j].info=0) and (y[i,j].checked=false) then b:=false;

j:=x; i:=0;
while j>0 do begin inc (i,j and 1); j:=j div 2; end;
if b and (i<=mn) then begin mn:=i; mnn:=x; s11:=s1; s22:=s2; end;
end;
writeln ('Всего-',mn);
writeln ('Столбцы-', s11);
writeln ('Строки- ',s22);
end.

[Bokul]

Malice, можешь сделать небольшое пояснение алгоритма?

P.S. может кому надо - отформатированное чудо Malice-а (извиняюсь перед Malice-ом, просто так легче разобраться , имхо)
 10.pas ( 1.51 килобайт ) Кол-во скачиваний: 481


Сообщение отредактировано: Bokul - 4.01.2007 15:01

[Malice]

Malice, можешь сделать небольшое пояснение алгоритма?

Конечно Простой перебор, поясню немного:
1. x = 0..$FFFF - Вырианты зачеркиваний, в битовом представлении первые 8 бит - столбцы, вторые строки, 1-зачеркнут, 0 -нет
2. Зачеркиваем в соответствии с x
3. Проверяем все ли 0-ли зачеркнуты (там, где b)
4. считаем колво 1-ц в x
5. Сравниваем на минимум
Из типа x вытекает ограничение на размер матрицы (8 х 8), но перебор можно и иначе сделать, если что.
ps а что, хорошее форматирование, мне так, например, легче