Версия для печати темы

Нажмите сюда для просмотра этой темы в обычном формате

Форум «Всё о Паскале» _ Задачи _ Помогите решить задачу про двумерные массивы

Автор: Voivod 17.11.2006 20:18

Помогите решить задачу
Матрицу А(m,n) заполнить следующим образом. Для заданных k и l элементу аkl присвоить значение 1 ; элементам , окаймляющим его (соседним с ним по вертикали, горизонтали и диагоналям) – значение 2; элементам следующего окаймление – значение 3 и так далее до заполнения всей матрицы. Результат вывести на экран ,раскрасив слой разными цветами. Примечание : алгоритм не изменится ,если координаты элемента (несуществующего ) k и l находятся за пределами матрицы.

Автор: klem4 17.11.2006 22:06

Вот на вскидку ...

uses crt;

const

n = 5;

type
TMx = array [1..n, 1..n] of Integer;

function IsOk(const a, b: Integer): Boolean;
begin
isOk := (a >= 1) AND (a <= n) AND (b >= 1) AND (b <= n);
end;

function CreateMatrix(const k, l: Integer): TMx;
var
delta, i, count: LongInt;
mx: TMx;
begin

for i := 1 to n do
FillChar(mx[i], sizeof(mx[i]), 0);

count := 0;
delta := 0;

while (count < n * n) do begin

for i := l - delta to l + delta do begin

if IsOk(k - delta, i) then begin
if mx[k - delta, i] = 0 then inc(count);
mx[k - delta, i] := delta + 1;
end;

if IsOk(k + delta, i) then begin
if mx[k + delta, i] = 0 then inc(count);
mx[k + delta, i] := delta + 1;
end;

end;

for i := k - delta to k + delta do begin

if IsOk(i, l - delta) then begin
if mx[i, l - delta] = 0 then inc(count);
mx[i, l - delta] := delta + 1;
end;

if IsOk(i, l + delta) then begin
if mx[i, l + delta] = 0 then inc(count);
mx[i, l + delta] := delta + 1;
end;

end;

inc(delta);
end;

CreateMatrix := mx;
end;

procedure PrintMatrix(const mx: TMx);
var
i, j: Integer;
begin
for i := 1 to n do begin
writeln;
for j := 1 to n do begin
TextColor(mx[i, j] + 1);
write(mx[i, j]:3);
end;
end;
end;

begin
clrscr;
PrintMatrix(CreateMatrix(2, 2));
readln;
end.

Автор: volvo 17.11.2006 22:42

klem4: во-первых, твоя программа в TP не откомпилируется ... Это только для 32-бит (из-за возвращаемого значения CreateMatrix), а во-вторых, однообразные циклы вполне можно сократить blum.gif

Добавлено позже...
Вот так, например:

uses crt;

const
n = 10;

type
TMx = array [1..n, 1..n] of Integer;

function IsOk(const a, b: Integer): Boolean;
begin
isOk := (a >= 1) AND (a <= n) AND (b >= 1) AND (b <= n);
end;

function CreateMatrix(const k, l: Integer): TMx;
var
delta, count: LongInt;
mx: TMx;

procedure loop(i_first: boolean; X, Y: integer);
var
i, pm: integer;
first, second: integer;
begin
for i := X - delta to X + delta do

for pm := -1 to 1 do begin

first := byte(not i_first)*(Y + pm * delta) + byte(i_first)*i;
second := byte(not i_first)*i + byte(i_first)*(Y + pm * delta);

if (pm <> 0) and IsOk(first, second) then begin
if mx[first, second] = 0 then inc(count);
mx[first, second] := delta + 1;
end;

end;

end;

begin
FillChar(mx, sizeof(mx), 0);

count := 0;
delta := 0;

while (count < n * n) do begin

loop(false, L, K); loop(true, K, L);
inc(delta);

end;

CreateMatrix := mx;
end;

procedure PrintMatrix(const mx: TMx);
var
i, j: Integer;
begin
for i := 1 to n do begin
writeln;
for j := 1 to n do begin
TextColor(mx[i, j] + 1);
write(mx[i, j]:3);
end;
end;
end;

begin
clrscr;
PrintMatrix(CreateMatrix(2, 2));
readln;
end.

Автор: klem4 17.11.2006 22:54

Вот переделал под TP. По поводу сократить щас подумаю smile.gif


Прикрепленные файлы
Прикрепленный файл  FORUM.PAS ( 1.45 килобайт ) Кол-во скачиваний: 184

Автор: Voivod 18.11.2006 4:00

Спасибо большое за вложенный вариант задачи , а то какой день бьюсь над решением