Автор: алекс ди 20.03.2003 1:32
Попалась тут мне недавно на глаза одна интересная задача, которую я не смог решить ;D(я только начал изучать паскаль), но думаю что другим она "понравится"
Задача: В матрице А(m,n), состоящей из одних нулей и единиц, найти квадрат наибольшего размера, состоящий из нулей.
PS: ответьте мне, плиз, у всех ли эта задача вызвала затруднения? я лично на ней просто завис :-[
Автор: GLuk 20.03.2003 2:59
{Алгоритм кривой ;) пока, если надо - оптимизирую}
Код
Uses
Crt;
Const
M = 140; {Лучше поставить значения поменьше, т.к. на моем 750 МГц он считал 1767 мс}
N = 160;
{a:array[1..M, 1..N] of Byte = ((0,0,0,1,0,0),
(0,0,0,1,0,0),
(0,0,0,1,0,0),
(0,0,0,0,0,0));}
Var
i,j:Word;
Max, SideL:Word;
Process:Boolean;
a:array[1..M, 1..N] of Byte;
T:LongInt;
Function FindSquare(SideL:Word):Boolean;
var
MaxD,MaxR,i,j,k,j1,i1:Word;
MaxS:Word;
Find:Boolean;
begin
MaxR:=N - SideL + 1;
MaxD:=M - SideL + 1;
k:=MaxR*MaxD;
FindSquare:=False; j1:=1; i1:=1;
For j1:=1 to MaxR do
For i1:=1 to MaxD do
begin
Find:=True;
For j:=j1 to j1+SideL-1 do
For i:=i1 to i1+SideL-1 do
begin
If a[i,j]=1 then Find:=False;
end;
If Find then FindSquare:=True;
end;
end;
Begin
ClrScr;
If M>N then Max:=N else Max:=M;
Randomize;
For i:=1 to M do
begin
For j:=1 to N do
begin
a[i,j]:=Random(2);
Write(a[i,j],#32);
end;
Write(#13#10);
end;
Process:=True;
SideL:=Max;
WriteLn(#13#10'Максимальная длина стороны квадрата = ', SideL);
T:=MemL[$40:$6c];
While Process do
begin
If SideL=1 then Process:=False
else
If FindSquare(SideL) then Process:=False;
Dec(SideL);
end;
WriteLn('Максимальная длина стороны квадрата = ',SideL+1);
WriteLn('Общее время счета = ',MemL[$40:$6c]-T,' мс');
End.
Автор: алекс ди 21.03.2003 17:58
2 GLuk :)
Принцип пока не очень понял, но вроде работает.
Но всё равно, спасибо за ответ. ;)