Реализуемо ли это в Делфи??
1 Провести минимальное количество прямых через столбцы и строки матрицы таким образом, чтобы они проходили через все нули, содержащиеся в таблице
2 Найти наименьший из элементов, через которые не проходит ни одна прямая
3 Вычесть его из всех элементов, через которые не проходят прямые
4 Прибавить его ко всем элементам, лежащим на пересечении прямых
5 Элементы, через которые проходит только одна прямая, оставить неизменными
Реализуемо.
Скажи, у тебя есть идеи, каким алгоритмом надо пользоваться, чтобы минимизировать количество прямых? (Вне связи с языком реализации - как бы ты действовала, если бы тебе дали таблицу с числами и попросили провести такие прямые?)
эмм.. нужно вычеркивать сначала те столбцы или строки, в которых сод. наибольшее кол-во нулей. написать это труднее, чем сказать. у меня получается что-то вроде этого:
max:=0;
counter:=0;
for i:=1 to m do
begin
for ii:=1 to m do
if matr[i,ii]=0 then
inc(counter);
if counter>max then
begin
max:=counter;
b:=ii; {запоминаем строку}
counter:=0;
end;
end;
это для строк. то же самое для столбцов с сохранением макс., но тут непонятно, как запоминать теперь уже столбец, чтобы не було путаницы, когда придется "вычеркивать"..
в принципе, думала примерно так же.
единственное уточнение - надо будет параллельно анализировать строки и столбцы.
то есть как-то так: нашли самую "нулевую" строку, потом - самый "нулевый" столбец, и только после этого решаем, что вычеркивать.
и на следующем этапе уже вычеркнутые нули не принимать во внимание.
Очень много лишних проходов.
Может быть, имеет смысл потратить некоторое количество памяти и, посчитав количество нулей в каждой строке и столбце, записать их отдельно? а потом по мере вычеркивания корректировать?
Цикл заканчивается, когда не осталось невычеркнутых нулей. То есть, если идем вторым путем, массив обнулился. Если первым - можно хранить кол-во оставшихся нулей в отдельной переменной.
следующий вопрос: как проверять, вычеркнуто ли то или иное число?
у меня есть 2 идеи:
1) создаем дополнительный массив, в который записываем номера вычеркнутых строк и столбцов.
2) исходный массив объявляем не так:
matr: array[1..m,1..m] of integer;
type
element=record
info,checked: integer;
end;
var matr: array[1..m,1..m] of element;
о, пришла бредовая мысля!
а что, если "зачеркнутые значения" в процессе зачеркивания умножить, напр, на те же 100. у меня ограничение по вводу меньше трех цифр, так что тогда будет сразу видно, что мы "зачеркивали", + довольно легко найдутся пересечения. и поиску мин. значений это не будет мешать.
потом:
if a[i,ii]<100 then a[i,ii]:=a[i,ii]-min;
затем ищем пересечения:
if a[i,ii]>=10000 then a[i,ii]:=a[i,ii]/10000+min
а остальные: двойной вложенный цикл
if a[i,ii]>=100 then a[i,ii]:=a[i,ii]/100.
будет оно правильно работать? а вот с этим поиском строк/столбцов с макс. кол-вом нулей я все равно туплю..
Вот мое решение:
Пойдём от обратного: какое максимальное число n линий нужно провести, чтобы вычеркнуть все нули с квадратной матрицы (потом легко можно перейти к общему случаю)? Ответ прост - число линий будет отвечать размерности матрицы (количеству столбцов или строк). Тогда когда же мы сможем получить выигрыш (число вычеркиваний будет меньшим чем n)? Ответ тоже прост - только в том случае, когда на каком-нибудь столбце или строке вообще не будет нулей.
Алгоритм таковой: находим все "безнулевые" строки и столбцы, одновременно считая их количество(NColumn, NLine). Сравниваем NColumn и NLine, если NLine больше проводим горизонтальные линии через все строки, не помечены как "безнулевые", если же NColumn - тоже самое, только вертикальные линии. В случае равенства - запускаем random з 2.. - направление не имеет значения.
а если безнулевых строк/столбцов не окажется?
1 1 1 0
1 0 1 1
0 0 1 1
1 1 0 1
хорошо, пусть в этом случае будет равенство. 0=0, => рандом. но рандом на то и рандом, что никак не угадать, что он начеркает. может оказаться, что вычеркнуться все элементы матрицы, как в таком, например, случае. а можно (нужно!) вычеркнуть минимальным кол-вом линий, чтобы эл-ты остались.
напрмер так;
1 - 1 -
1 - 1 -
- - - -
- - - -
пс. матрица и так квадратная. забыла уточнить в теме.
Ты не поняла шутки с random-ом - если безнулевых строк/столбцов не будет, то все-равно, проведём ли мы 4 вертикальных или 4 горизонтальных линий. Его мы используем чтобы узнать проводить горизонтальные или вертикальные линии. Ты можешь вообще не использовать random, тогда в случае равенства всегда проводить, например, только горизонтальные линии, хотя с тем же успехом можешь использовать только вертикальные.
ну да. если в моем примере проводить только горизонтальные линии, то все эл-ты зачеркнуться.
или ты предлагаешь делать это рекурсивно (по одному зачеркиванию за раз) и по ходу дела уже анализировать ситуацию?
не хватит! потому что при некоторых примерах оно не выполняется. как в том, что я привела. или в матрице, трансп. из этой:
1 0 1 1
1 0 0 1
0 1 1 1
1 1 1 0
хоть вычеркивай только вертикальные, хоть только горизонтальные, будет совсем не то, что требуется. таких примеров можно привести кучу (таких - когда нет ненулевых строк/столбцов=> алгоритм не работает).
алгоритм должен подходить по все возможные варианты, за исключением парочки, что можно описать в else. вот
если есть безнулевые строки или столбцы, все работает, но если нету.. вот тут-то и прокол.
дело в том, в этой задаче предыдущие два этапа как раз такие, что безнулевых строк/столбцов как раз не окажется.. (до этого находятся максы и мины в каждых строках/столбцах и вычитаются из всех эл-тов строки/столбца).
имхо, проще было бы каждый раз искать строку/столбец с наиб. кол-вом нулей и вычеркивать его..
Но зачеркивать-то с умом нужно) Чтобы остались элементы, над которыми производить потом разные действия.
0 1 1 1
0 1 1 1
1 1 0 1
1 0 0 0
м?) можно зачеркнуть тремя линиями. а по твоему алгоритму он 4 сделает.
.helga, покажи как ты с умом зачеркнёшь все нули в твоем примере.
насчет тех примеров:
зачеркну. сначала вычеркиваем столбец/строку с максимальным кол-вом нулей, а потом, когда появляются ненулевые строки/столбцы, можно рассуждать по твоему алгоритму.
проблема в том, что его можно применять только при наличии этих самых безнулевых столбцов.
Нет мой алгоритм и для такого не годится:
1111
1101
1101
1000
он даст 3, хотя можно обойтись и двумя линиями.
хм. тогда кроме вычеркивания строк/столбцов с максимальным кол-вом нулей, я решений не вижу..
вот так?
max_a, max_b, counter, i, ii, m: integer;
begin
max_b:=0;
counter:=0;
for i:=1 to m do
begin
for ii:=1 to m do
if matr[i,ii]=0 then
inc(counter);
if counter>max_b then
begin
max_b:=counter;
b:=ii; {запоминаем строку}
counter:=0;
end;
end;
max_a:=0;
for ii:=1 to m do
begin
for i:=1 to m do
if matr[i,ii]=0 then
inc(counter);
if counter>max_a then
begin
max_a:=counter;
a:=i; {запоминаем столбец}
counter:=0;
end;
end;
if max_a<max_b then
begin
for i:=1 to m do
if matr[i,b]=0 then matr[i,b]:=matr[i,b]*100;
end
else
begin
for ii:=1 to m do
if matr[a,ii]=0 then matr[a,ii]:=matr[a,ii]*100;
end;
end;
А полный код можешь привести?
отредактировала чуток предыдущее. спать все-таки иногда надо, прокалываюсь на мелочах)
полный код - это код всех 5 шагов? или только "вычеркивания"?
на недо-паскале:
program z;
uses crt;
var
mart: array [1..100, 1.. 100] of integer;
i,ii,m:integer;
procedure lines;
var
max_a, max_b, counter: integer;
begin
for i:=1 to m do
for ii:=1 to m do
if matr[i,ii]=0 then
inc(counter);
if counter=0 then break
else
max_b:=0;
counter:=0;
{максимальное кол-во нулей по строкам}
for i:=1 to m do
begin
for ii:=1 to m do
if matr[i,ii]=0 then
inc(counter);
if counter>max_b then
begin
max_b:=counter;
b:=ii; {запоминаем строку}
counter:=0;
end;
end;
max_a:=0;
{максимальное кол-во нулей по столбцам}
for ii:=1 to m do
begin
for i:=1 to m do
if matr[i,ii]=0 then
inc(counter);
if counter>max_a then
begin
max_a:=counter;
a:=i; {запоминаем столбец}
counter:=0;
end;
end;
{
если максимально кол-во нулей по строкам больше максимального
кол-ва нулей по столбцам, "вычеркиваем" строку и наоборот
}
if max_a<max_b then
begin
for i:=1 to m do
if matr[i,b]=0 then matr[i,b]:=matr[i,b]*100;
end
else
begin
for ii:=1 to m do
if matr[a,ii]=0 then matr[a,ii]:=matr[a,ii]*100;
end;
lines;
end;
procedure steps;
var
min: integer;
begin
{поиск минимального элемента}
min:=100;
for i:=1 to m do
for ii:=1 to m do
if matr[i,ii]<min then
min:=matr[i,ii];
{вычитаем минимальный элемент из незачеркнутых элементов матрицы}
for i:=1 to m do
for ii:=1 to m do
if a[i,ii]<100 then a[i,ii]:=a[i,ii]-min;
{прибавляем минимальный элемент к элементам, находящимся на пересечении прямых}
for i:=1 to m do
for ii:=1 to m do
if a[i,ii]>=10000 then a[i,ii]:=a[i,ii]/10000+min
{возвращаем "зачеркнутым" посредством умножения на 100 элементам их исходное значение}
for i:=1 to m do
for ii:=1 to m do
if a[i,ii]>=100 then a[i,ii]:=a[i,ii]/100.
end;
begin
lines;
steps;
end.
Конечно у тебя рекурсия вечная (до переполнения стека точно не остановится).
а вот этот кусок
for i:=1 to m do
for ii:=1 to m do
if matr[i,ii]=0 then
inc(counter);
if counter=0 then break
Ты тестила свой код? Правильные результаты дает?
Вот моя реализация алгоритма мисс_граффити:
uses crt;
const
n=4;
ar:array[1..n,1..n] of byte=((0,1,1,0),
(2,1,0,1),
(3,1,0,1),
(4,0,0,0));
Type
TElement=record
info:byte;
checked:boolean;
end;
TRes=record
ind,n:byte;
end;
Var mas:array[1..n,1..n] of TElement;
procedure init;
var i,j:byte;
begin
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 GetMaxColumn:TRes;//находим столбик с максимальным количеством нулей
var i,j,max:byte;
res:TRes;
begin
max:=0;
res.n:=0;
res.ind:=0;
for i:=1 to n do
begin
for j:=1 to n do
if (mas[j,i].info=0) and (mas[j,i].checked=false) then
inc(max);
if max>res.n then
begin
res.n:=max;
res.ind:=i;
end;
max:=0;
end;
GetMaxColumn:=res;
end;
function GetMaxLine:TRes;//находим строку с максимальным количеством нулей
var i,j,max:byte;
res:TRes;
begin
max:=0;
res.n:=0;
res.ind:=0;
for i:=1 to n do
begin
for j:=1 to n do
if (mas[i,j].info=0) and (mas[i,j].checked=false) then
inc(max);
if max>res.n then
begin
res.n:=max;
res.ind:=i;
end;
max:=0;
end;
GetMaxLine:=res;
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;
var NColumn,NLine:TRes;
begin
clrscr;
init;
repeat//повторяем
NColumn:=GetMaxColumn;
NLine:=GetMaxLine;
if (NColumn.n<>0) and (NLine.n<>0) then
if NColumn.n>NLine.n then //если количество нулей больше в столбце
begin
writeln('Column ',NColumn.ind);
CrossColumn(NColumn.ind);//то зачеркиваем его
end
else// в противоположном случае
begin
writeln('Line ',NLine.ind);
CrossLine(NLine.ind);// зачеркиваем линию
end;
until (NColumn.n=0) and (NLine.n=0);//пока не зачеркнем все нули
readln;
end.
2 Bokul: Copy+Paste - не наш метод... Убираем 2 функции (GetMaxLine/GetMaxColumn), заменяем их на одну:
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;
...
repeat
NColumn:=GetMax(false);
NLine:=GetMax(true);
...
for j:=1 to n do
for i:=1 to n do
if not(i in CrossedLines) then...
if (value.info=0) and (value.checked=false) then
n=5;
ar:array[1..n,1..n] of byte=((0,1,1,1,0),
(1,0,0,1,1),
(1,0,1,1,0),
(0,1,0,1,1),
(1,0,1,1,0));
Column 2
Column 5
Line 4
Line 1
Line 2
ой...
в смысле, вот так:
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,1,1,1),
(1,0,0,1,0));
я вот про этот вариант:
n=5;
ar:array[1..n,1..n] of byte=((0,1,1,1,0),
(1,0,0,1,1),
(1,0,1,1,0),
(0,1,0,1,1),
(1,0,1,1,0));
2 мисс_граффити
основы алгоритмизации и программирования. курсовой пишу.
с этим вот этапом вышла проблемка.
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,1,1,1),
(1,0,0,1,0));
Type
TElement=record
info:byte;
checked:boolean;
end;
TRes=record
ind,n:byte;
end;
Var mas:array[1..n,1..n] of TElement;
procedure init;
var i,j:byte;
begin
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; res:byte; b:boolean; value:TElement;
begin
res:=0;
for i:=1 to n do
begin
b:=false;
for j:=1 to n do
begin
if IsColumn then value:=mas[j,i] else value:=mas[i,j];
if (value.info=0) and (value.checked=false) then
b:=true
end;
if not(b) then
inc(res);
end;
GetWithoutZero:=res;
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;
var NColumn,NLine:TRes; WriteColumn:boolean;
begin
clrscr;
init;
NColumn:=GetMax(false);
NLine:=GetMax(true);
while (NColumn.n<>0) and (NLine.n<>0) do
begin
if NColumn.n>NLine.n then
WriteColumn:=true;
if NColumn.n<NLine.n then
WriteColumn:=false;
if NColumn.n=NLine.n then
if GetWithoutZero(true)>GetWithoutZero(false) then
WriteColumn:=true
else
WriteColumn:=true;
if WriteColumn then begin
writeln('Column ',NColumn.ind);
CrossColumn(NColumn.ind);
end
else begin
writeln('Line ',NLine.ind);
CrossLine(NLine.ind);
end;
NColumn:=GetMax(false);
NLine:=GetMax(true);
end;
readln;
end.
к сожалению, внесенные изменения не в полной мере решают проблему:
const
n=5;
ar:array[1..n,1..n] of byte=((0,1,0,1,0),
(1,1,1,1,1),
(1,0,0,1,0),
(1,1,1,1,1),
(1,0,0,1,0));
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,1,1,1),
(0,0,0,1,0));
Идея такая: если безнулевых столбцов/строк больше, накладываем запрет на вычеркивание строк/столбцов соответственно. Если поровну (частный случай - ни одного) - идем по старому алгоритму.
Что скажешь?
if NColumn.n=NLine.n then
if GetWithoutZero(true)>GetWithoutZero(false) then
WriteColumn:=true
else
WriteColumn:=true;//<---!надо заменить на false!
if WriteColumn then begin
вроде как непринципиально...
Я про немножко другой алгоритм... у тебя идет проверка на кол-во ненулевых только при NColumn.n=NLine.n.
А я предлагаю делать так:
1) Смотрим на ненулевые строки и столбцы.
2) Если строк больше, вычеркиваем только строки с нулями.
3) Если столбцов больше, вычеркиваем только столбцы с нулями.
4) Если поровну (как вариант - полное отсутствие) - идем по старому алгоритму... то есть ищем, где у нас больше нулей и т.д.
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
Переделать старый алгоритм("то есть ищем, где у нас больше нулей и т.д") на роботу не только с квадратными матрицами. Но изменения будут касаться не только сменой границ счетчиков (з двух 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));
(0,1,0,0),
(1,0,1,1),
(1,0,0,0),
(0,1,1,1),
(0,0,0,0));
Блин, написал код и для этого алгоритма, но он тоже не правильный - задыхается на таком примере:
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
почему? чем этот пример такой особенный???
покажешь код?
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.
рассматиривать отдельно?...
поскольку "развилок" может получиться много (особенно на больших массивах), это проблематично.
helga, а тебе непременно венгерский метод нужен?
уже нет, мне изменили постановку задачи, теперь немного другая тема.
но все равно интересно, как это сделать можно )
Проще всего сделать перебором, вот так, например:
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.
Malice, можешь сделать небольшое пояснение алгоритма?
P.S. может кому надо - отформатированное чудо Malice-а (извиняюсь перед Malice-ом, просто так легче разобраться , имхо)
10.pas ( 1.51 килобайт )
Кол-во скачиваний: 451