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

Автор: 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), а во-вторых, однообразные циклы вполне можно сократить

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

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. По поводу сократить щас подумаю


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

Автор: Voivod 18.11.2006 4:00

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