Викиучебник

Книга программиста/Обработка матриц на PascalABC.Net

< Книга программиста
(перенаправлено с «Обработка матриц на PascalABC.Net»)

К оглавлению | Назад | Вперёд

Все программы, код которых выложен здесь, являются работоспособными. На момент написания программ использовалась среда PascalABC.Net 3.0 (и 3.3).

Простые задачи

править

Максимальные элементы столбцов матрицы

править 
const
  N = 3;
  M = 3;

var
  A: array [0..N - 1, 0..M - 1] of integer;
  Max: array [0..M - 1] of integer;

begin
  for var i := 0 to N - 1 do
    for var j := 0 to M - 1 do
      A[i, j] := Random(10);
  
  Writeln('Матрица:');
  for var i := 0 to N - 1 do
  begin
    for var j := 0 to M - 1 do
      Write(A[i, j]:3);
    Writeln();
  end;
  
  for var j := 0 to M - 1 do
  begin
    Max[j] := integer.MinValue;
    for var i := 0 to N - 1 do
      if A[i, j] > Max[j] then Max[j] := A[i, j];
  end;
  
  Writeln('Максимумы:');
  for var j := 0 to M - 1 do
    Write(Max[j]:3);
end.

begin
  Print(MatrRandom(3, 3, 0, 10).Cols().Select(x -> x.Max()));
end.

Смотрите также: реализация на C#.

Смотрите также: реализация на VB.

Количество двузначных чисел с четной суммой цифр

править

Формула, по которой можно узнать сумму цифр двузначного числа: n div 10 + n mod 10. 

const
  N = 3;
  M = 3;

var
  A: array [0..N - 1, 0..M - 1] of integer;
  C: integer;

procedure Print(); // Производит вывод матрицы.
begin
  Writeln('Матрица:');
  for var i := 0 to N - 1 do
  begin
    for var j := 0 to M - 1 do
      Write(A[i, j]:3);
    Writeln();
  end;
end;

begin
  for var i := 0 to N - 1 do
    for var j := 0 to M - 1 do
      A[i, j] := Random(100);
  
  Print();
  
  for var i := 0 to N - 1 do
    for var j := 0 to M - 1 do
      if (Abs(A[i, j]) >= 10) and (Abs(A[i, j]) < 100) and ((A[i, j] div 10 + A[i, j] mod 10) mod 2 = 0) then
        Inc(C);
  
  WritelnFormat('Количество двузначных чисел с четной суммой цифр равно {0}.', C);
end.

Смотрите также: реализация на С#.

Смотрите также: реализация на VB.

Наибольший по модулю элемент матрицы

править 
const
  N = 3;
  M = 3;

var
  A: array [0..N - 1, 0..M - 1] of integer;
  Max, MaxI, MaxJ: integer;

procedure Print();
begin
  Writeln('Матрица:');
  for var i := 0 to N - 1 do
  begin
    for var j := 0 to M - 1 do
      Write(A[i, j]:3);
    Writeln();
  end;
end;

begin
  for var i := 0 to N - 1 do
    for var j := 0 to M - 1 do
      A[i, j] := -10 + Random(20);
  
  Print();
  
  Max := 0;
  for var i := 0 to N - 1 do
    for var j := 0 to M - 1 do
      if Abs(A[i, j]) > Max then
      begin
        Max := Abs(A[i, j]);
        MaxI := i; MaxJ := j;
      end;
  
  WritelnFormat('Наибольший по модулю элемент матрицы с индексами [{0}, {1}] равен {2}.', MaxI, MaxJ, Max);
end.

Смотрите также: реализация на C#.

Смотрите также: реализация на VB.

Поменять местами строки матрицы

править 
const
  N = 3;
  M = 3;

var
  A: array [0..N - 1, 0..M - 1] of integer;

procedure Print();
begin
  Writeln('Матрица:');
  for var i := 0 to N - 1 do
  begin
    for var j := 0 to M - 1 do
      Write(A[i, j]:3);
    Writeln();
  end;
end;

begin
  for var i := 0 to N - 1 do
    for var j := 0 to M - 1 do
      A[i, j] := Random(10);
  
  Print();
  
  var i1 := Random(N);
  var i2 := Random(N);
  
  for var j := 0 to M - 1 do
    Swap(A[i1, j], A[i2, j]);
  
  Print();
end.

Смотрите также: реализация на C#.

Произведение элементов матрицы

править 
const
  N = 3;
  M = 3;

var
  A: array [0..N - 1, 0..M - 1] of integer;
  Mult: integer;

procedure Print();
begin
  Writeln('Матрица:');
  for var i := 0 to N - 1 do
  begin
    for var j := 0 to M - 1 do
      Write(A[i, j]:3);
    Writeln();
  end;
end;

begin
  for var i := 0 to N - 1 do
    for var j := 0 to M - 1 do
      A[i, j] := 1 + Random(10);
  
  Print();
  
  Mult := 1;
  for var i := 0 to N - 1 do
    for var j := 0 to M - 1 do
      Mult *= A[i, j];
  
  WritelnFormat('Произведение элементов матрицы равно {0}.', Mult);
end.

Узнать, сколько раз встречается данное число в матрице

править 
const
  N = 3;
  M = 3;

var
  A: array [0..N - 1, 0..M - 1] of integer;
  C, K: integer;

procedure Print();
begin
  Writeln('Матрица:');
  for var i := 0 to N - 1 do
  begin
    for var j := 0 to M - 1 do
      Write(A[i, j]:3);
    Writeln();
  end;
end;

begin
  Readln(K);
  
  for var i := 0 to N - 1 do
    for var j := 0 to M - 1 do
      A[i, j] := Random(10);
  
  Print();
  
  for var i := 0 to N - 1 do
    for var j := 0 to M - 1 do
      if A[i, j] = K then
        Inc(C);
  
  WritelnFormat('Количество чисел, равных K, равно {0}.', C);
end.

Смотрите также: реализация на C#.

Запись матрицы в список по столбцам

править 
begin
  var A := MatrRandom();
  var L := new List<integer>();
  
  for var j := 0 to Length(A, 1) - 1 do
    for var i := 0 to Length(A, 0) - 1 do
      L.Add(A[i, j]);
  
  L.ToArray().Println();
end.

Количество единиц в столбце, равное номеру столбца

править 
begin
  var A := MatrFill(ReadlnInteger(), ReadlnInteger(), 0);
  
  for var j := 0 to Length(A, 1) - 1 do
    for var i := 0 to j do
      A[i, j] := 1;
  
  A.Println();
end.

4 варианта заполнения матрицы по треугольникам

править 
const
  N = 10;

var
  A: array [0..N - 1, 0..N - 1] of char;

begin
  for var i := 0 to N - 1 do
    for var j := 0 to N - 1 do
      if (i > j) and (N - i - 1 > j) then
        A[i, j] := '+'
      else
        A[i, j] := '.';
  
  for var i := 0 to N - 1 do
  begin
    for var j := 0 to N - 1 do
      Write(A[i, j]);
    Writeln();
  end;
end.

const
  N = 10;

var
  A: array [0..N - 1, 0..N - 1] of char;

begin
  for var i := 0 to N - 1 do
    for var j := 0 to N - 1 do
      if (i < j) and (N - i - 1 > j) then
        A[i, j] := '+'
      else
        A[i, j] := '.';
  
  for var i := 0 to N - 1 do
  begin
    for var j := 0 to N - 1 do
      Write(A[i, j]);
    Writeln();
  end;
end.

const
  N = 10;

var
  A: array [0..N - 1, 0..N - 1] of char;

begin
  for var i := 0 to N - 1 do
    for var j := 0 to N - 1 do
      if (i < j) and (N - i - 1 < j) then
        A[i, j] := '+'
      else
        A[i, j] := '.';
  
  for var i := 0 to N - 1 do
  begin
    for var j := 0 to N - 1 do
      Write(A[i, j]);
    Writeln();
  end;
end.

const
  N = 10;

var
  A: array [0..N - 1, 0..N - 1] of char;

begin
  for var i := 0 to N - 1 do
    for var j := 0 to N - 1 do
      if (i > j) and (N - i - 1 < j) then
        A[i, j] := '+'
      else
        A[i, j] := '.';
  
  for var i := 0 to N - 1 do
  begin
    for var j := 0 to N - 1 do
      Write(A[i, j]);
    Writeln();
  end;
end.

Арифметические прогрессии в строках матрицы

править 
const
  N = 3;
  M = 3;

var
  A: array [0..N - 1, 0..M - 1] of integer;
  IsProgression: boolean;

begin
  for var i := 0 to N - 1 do
  begin
    WritelnFormat('Ввод {0}-ой строки:', i + 1);
    for var j := 0 to M - 1 do
      Readln(A[i, j]);
  end;
  
  IsProgression := true;
  if M > 2 then
    for var i := 0 to N - 1 do
    begin
      var D := A[i, 1] - A[i, 0];
      for var j := 2 to M - 1 do
        if A[i, j] - A[i, j - 1] <> D then
        begin
          IsProgression := false;
          break;
        end;
      if not IsProgression then break;
    end;
  
  if IsProgression then
    Writeln('Каждая строка матрицы является арифметической прогрессией.')
  else
    Writeln('Существует несколько или одна строк, которые не являются арифметическими прогрессиями.');
end.

Средняя сложность

править

Удаление строк с нулями

править 
const
  N = 4;
  M = 5;

var
  A: array [0..N - 1, 0..M - 1] of integer;
  Size: integer;

procedure Print();
begin
  Writeln('Матрица:');
  for var i := 0 to Size - 1 do
  begin
    for var j := 0 to M - 1 do
      Write(A[i, j]:3);
    Writeln();
  end;
end;

function HasZeros(i: integer): boolean; // Возвращает true, если i-ая строка матрицы имеет нули.
begin
  Result := false;
  var j := 0;
  while (j < M) and not Result do
  begin
    if A[i, j] = 0 then Result := true;
    Inc(j);
  end;
end;

procedure RemoveStr(n: integer); // Удаляет i-ую строку матрицы.
begin
  if Size > 0 then
  begin
    for var i := n to Size - 2 do
      for var j := 0 to M - 1 do
        A[i, j] := A[i + 1, j];
    for var j := 0 to M - 1 do
      A[Size - 1, j] := -1;
    Dec(Size);
  end;
end;

begin
  Size := N;
  for var i := 0 to N - 1 do
    for var j := 0 to M - 1 do
      A[i, j] := Random(10);
  
  Print();
  
  var i := 0;
  while i < Size do
    if HasZeros(i) then
      RemoveStr(i)
    else
      Inc(i);
  
  Print();
end.

Суммирование элементов строки до последнего отрицательного

править

Суммировать положительные элементы строки до последнего отрицательного и записать в список. Если отрицательных чисел в строке нет - записать в список 0. 

begin
  var Matrix := MatrRandom(5, 5, -10, 10).Print();
  var R := Matrix.Rows().ToArray();
  
  var L := new List<integer>;
  
  for var i := 0 to R.Length - 1 do
    if not R[i].Any(x -> x < 0) then
      L.Add(0)
    else
    begin
      var row := R[i].ToArray();
      L.Add(row.Where((x, index) -> (x > 0) and (index < row.FindLastIndex(x -> x < 0))).Sum());
    end;
  
  L.Println();
end.

Количество отрицательных элементов под главной диагональю

править 
const
  N = 4;

var
  A: array [0..N - 1, 0..N - 1] of integer;
  C: integer;

procedure Print();
begin
  Writeln('Матрица:');
  for var i := 0 to N - 1 do
  begin
    for var j := 0 to N - 1 do
      Write(A[i, j]:3);
    Writeln();
  end;
end;

begin
  for var i := 0 to N - 1 do
    for var j := 0 to N - 1 do
      A[i, j] := Random(10) - 3;
  
  Print();
  
  for var i := 0 to N - 1 do
    for var j := 0 to N - 1 do
      if (i > j) and (A[i, j] < 0) then
        Inc(C);
  
  WritelnFormat('Количество отрицательных элементов под главной диагональю матрицы равно {0}.', C);
end.

Смотрите также: реализация на C#.

Смотрите также: реализация на VB.

Минимальные элементы на пересечении строк и столбцов

править 
const
  N = 3;
  M = 3;

var
  A: array [0..N - 1, 0..M - 1] of integer;
  Min, MinI, MinJ: integer;
  Found: boolean;

procedure Print();
begin
  Writeln('Матрица:');
  for var i := 0 to N - 1 do
  begin
    for var j := 0 to M - 1 do
      Write(A[i, j]:3);
    Writeln();
  end;
end;

begin
  for var i := 0 to N - 1 do
    for var j := 0 to M - 1 do
      A[i, j] := Random(100);
  
  Print();
  
  for var i := 0 to N - 1 do
  begin
    Min := integer.MaxValue;
    Found := true;
    for var j := 0 to M - 1 do
      if A[i, j] < Min then
      begin
        Min := A[i, j];
        MinI := i;
        MinJ := j;
      end;
    for var i2 := 0 to N - 1 do
      if A[i2, MinJ] < Min then
        Found := false;
    if Found then break;
  end;
  
  if not Found then
    Writeln('Минимального элемента на пересечении строк и столбцов не найдено.')
  else
    WritelnFormat('Индексы минимального элемента {0} равны [{1}, {2}].', Min, MinI, MinJ);
end.

Смотрите также: реализация на C#.

Максимальный элемент диагонали

править 
const
  N = 3;

var
  A: array [0..N - 1, 0..N - 1] of integer;
  Max: integer;

procedure Print();
begin
  Writeln('Матрица:');
  for var i := 0 to N - 1 do
  begin
    for var j := 0 to N - 1 do
      Write(A[i, j]:3);
    Writeln();
  end;
end;

begin
  for var i := 0 to N - 1 do
    for var j := 0 to N - 1 do
      A[i, j] := Random(10);
  
  Print();
  
  Max := integer.MinValue;
  for var i := 0 to N - 1 do
    if A[i, i] > Max then
      Max := A[i, i];
  
  WritelnFormat('Максимальный элемент диагонали равен {0}.', Max);
end.

Последний элемент строки матрицы - сумма всех элементов в той же строке матрицы

править 
const
  N = 3;
  M = 3;

var
  A: array [0..N - 1, 0..M - 1] of integer;
  i, j: integer;
  S: integer;

procedure Print();
begin
  Writeln('Матрица:');
  for var i := 0 to N - 1 do
  begin
    for var j := 0 to M - 1 do
      Write(A[i, j]:5);
    Writeln();
  end;
end;

begin
  for i := 0 to N - 1 do
    for j := 0 to M - 1 do
      A[i, j] := Random(10);
  
  Print();
  
  for i := 0 to N - 1 do
  begin
    S := 0;
    for j := 0 to M - 2 do
      Inc(S, A[i, j]);
    A[i, j + 1] := S;
  end;
  
  Print();
end.

Заполнение матрицы одним циклом

править 
const
  N = 5;

var
  A: array [0..N - 1, 0..N - 1] of integer;

procedure Print(d: integer);
begin
  for var i := 0 to Pred(N) do
  begin
    for var j := 0 to Pred(N) do
      Write(A[i, j]:d);
    Writeln();
  end;
  Writeln();
end;

begin
  for var i := 0 to Pred(Sqr(N)) do
    A[i div N, i mod N] := i;
  
  Print(4);
end.

Сложные задачи

править

Переворот главной диагонали

править 
const
  N = 4;

var
  A: array [0..N - 1, 0..N - 1] of integer;

procedure Print();
begin
  Writeln('Матрица:');
  for var i := 0 to N - 1 do
  begin
    for var j := 0 to N - 1 do
      Write(A[i, j]:3);
    Writeln();
  end;
end;

begin
  for var i := 0 to N - 1 do
    for var j := 0 to N - 1 do
      A[i, j] := Random(10);
  
  Print();
  
  for var i := 0 to N div 2 - 1 do
    Swap(A[i, i], A[N - i - 1, N - i - 1]);
  
  Print();
  
  Readln();
end.

Переворот побочной диагонали

править 
const
  N = 4;

var
  A: array [0..N - 1, 0..N - 1] of integer;

procedure Print();
begin
  Writeln('Матрица:');
  for var i := 0 to N - 1 do
  begin
    for var j := 0 to N - 1 do
      Write(A[i, j]:3);
    Writeln();
  end;
end;

begin
  for var i := 0 to N - 1 do
    for var j := 0 to N - 1 do
      A[i, j] := Random(10);
  
  Print();
  
  for var i := 0 to N div 2 - 1 do
    Swap(A[i, N - i - 1], A[N - i - 1, i]);
  
  Print();
end.

Произведение ненулевых диагональных элементов

править 
const
  N = 4;

var
  A: array [0..N - 1, 0..N - 1] of integer;
  M: integer;

procedure Print();
begin
  Writeln('Матрица:');
  for var i := 0 to N - 1 do
  begin
    for var j := 0 to N - 1 do
      Write(A[i, j]:3);
    Writeln();
  end;
end;

begin
  for var i := 0 to N - 1 do
    for var j := 0 to N - 1 do
      A[i, j] := Random(4);
  
  Print();
  
  M := 1;
  for var i := 0 to N - 1 do
    if (A[i, i] <> 0) and (i <> N div 2) then
      M *= A[i, i];
  
  for var i := 0 to N - 1 do
    if A[i, N - i - 1] <> 0 then
      M *= A[i, N - i - 1];
  
  WritelnFormat('Произведение ненулевых элементов равно {0}.', M);
end.

Заполнение матрицы по правилу

править

Вариант 1

править
1 0 2 0 3
0 4 0 5 0
6 0 7 0 8 
const
  N = 4;
  M = 7;

var
  A: array [0..N - 1, 0..M - 1] of integer;
  V: integer;

procedure Print();
begin
  Writeln('Матрица:');
  for var i := 0 to N - 1 do
  begin
    for var j := 0 to N - 1 do
      Write(A[i, j]:5);
    Writeln();
  end;
end;

begin
  for var i := 0 to Pred(N) do
  begin
    for var j := 0 to Pred(M) do
      if (i + j) mod 2 = 0 then
      begin
        Inc(V);
        A[i, j] := V;
      end;
  end;
  
  Print();
end.

Вариант 2

править

Правило заполнения:

1 2 3 4 5
2 1 2 3 4
3 2 1 2 3
4 3 2 1 2
5 4 3 2 1 
const
  N = 5;

var
  A: array [0..N - 1, 0..N - 1] of integer;

procedure Print();
begin
  Writeln('Матрица:');
  for var i := 0 to N - 1 do
  begin
    for var j := 0 to N - 1 do
      Write(A[i, j]:5);
    Writeln();
  end;
end;

begin
  for var d := -N + 1 to N - 1 do
    for var j := 0 to N - 1 do
    begin
      var i := j + d;
      if (i >= 0) and (i < N) then
        A[i, j] := Abs(d) + 1;
    end;
  
  Print();
end.

Смотрите также: реализация на C#.

Смотрите также: реализация на VB.

i := j + d можно рассматривать как функцию, где вместо f(x) пишется i, а вместо правой части выражения - j + d.

Вариант 3

править
1 2 3 4
8 7 6 5
9 10 11 12
16 15 14 13 
const
  N = 5;

var
  A: array [0..N - 1, 0..N - 1] of real;
  Value: integer := Sqr(N);

procedure Print(d: integer);
begin
  for var i := 0 to Pred(N) do
  begin
    for var j := 0 to Pred(N) do
      Write(A[i, j]:d);
    Writeln();
  end;
  Writeln();
end;

begin
  if N mod 2 = 0 then
    for var i := Pred(N) downto 0 do
      for var j := 0 to Pred(N) do
      begin
        var f := i mod 2 <> 0;
        A[i, Ord(f) * j + Ord(not f) * (Pred(N) - j)] := Value;
        Dec(Value);
      end
  else
    for var i := Pred(N) downto 0 do
      for var j := 0 to Pred(N) do
      begin
        var f := i mod 2 = 0;
        A[i, Ord(f) * j + Ord(not f) * (Pred(N) - j)] := Value;
        Dec(Value);
      end;
  
  Print(3);
end.

Заполнение матрицы по спирали

править 
const
  N = 10;

var
  A: array [0..N - 1, 0..N - 1] of integer;
  i, j: integer;
  Count: integer;
  Value: integer;

procedure Print();
begin
  for var i1 := 0 to N - 1 do
  begin
    for var j1 := 0 to N - 1 do
      Write(A[i1, j1]:6);
    Writeln();
  end;
end;

begin
  repeat
    var b := Pred(N) - Count;
    while j <= b do
    begin
      A[i, j] := Value;
      Inc(j);Inc(Value);
    end;
    
    Inc(i);Dec(j);
    while i <= b do
    begin
      A[i, j] := Value;
      Inc(i);Inc(Value);
    end;
    
    Dec(i);Dec(j);
    while j >= Count do
    begin
      A[i, j] := Value;
      Dec(j);Inc(Value);
    end;
    
    Dec(i);Inc(j);Inc(Count);
    while i >= Count do
    begin
      A[i, j] := Value;
      Dec(i);Inc(Value);
    end;
    Inc(i);Inc(j);
  until Count > N div 2;
  Print();
end.

Транспонирование матрицы

править

Пример транспонирования матрицы:

-1 2 4 0 7
3 -5 24 9 -3
-10 -8 -2 -4 1

преобразовать в:

-1 3 -10
2 -5 -8
4 24 -2
0 9 -4
7 -3 11 
const
  N = 3;
  M = 1;

var
  MatrixA, MatrixB: array [,] of integer;

procedure Print(a: array [,] of integer);
begin
  Writeln('Матрица:');
  for var i := 0 to Length(a, 0) - 1 do
  begin
    for var j := 0 to Length(a, 1) - 1 do
      Write(a[i, j]:3);
    Writeln();
  end;
end;

begin
  SetLength(MatrixA, N, M);
  SetLength(MatrixB, M, N);
  
  for var i := 0 to N - 1 do
    for var j := 0 to M - 1 do
      MatrixA[i, j] := Random(10);
  
  for var i := 0 to N - 1 do
    for var j := 0 to M - 1 do
      MatrixB[j, i] := MatrixA[i, j];
  
  Print(MatrixA);
  Print(MatrixB);
end.

Сортировка столбцов матрицы по первой строке

править 
const
  N = 4;
  M = 7;

type
  TData = auto class
    Key, Index: integer;
  end;

var
  A: array [0..N - 1, 0..M - 1] of integer;
  Outcome: array [0..N - 1, 0..M - 1] of integer;
  DataArray: array [0..M - 1] of TData;

procedure Print();
begin
  Writeln('Матрица:');
  for var i := 0 to N - 1 do
  begin
    for var j := 0 to M - 1 do
      Write(Outcome[i, j]:3);
    Writeln();
  end;
end;

procedure Sort(l, r: integer);
begin
  var i := l;
  var j := r;
  var m := DataArray[Round((l + r) / 2)].Key;
  
  repeat
    while DataArray[i].Key < m do Inc(i);
    while DataArray[j].Key > m do Dec(j);
    
    if i <= j then 
    begin
      Swap(DataArray[i], DataArray[j]); 
      Inc(i); 
      Dec(j); 
    end;
    
    if l < j then Sort(l, j);
    if i < r then Sort(i, r);
  until i > j;
end;

begin
  for var i := 0 to N - 1 do
    for var j := 0 to M - 1 do
      A[i, j] := Random(10);
  
  for var j := 0 to M - 1 do
    DataArray[j] := new TData(A[0, j], j);
  
  Sort(0, M - 1);
  
  for var j := 0 to M - 1 do
    for var i := 0 to N - 1 do
      Outcome[i, j] := A[i, DataArray[j].Index];
      
  Print();
end.

Узоры на матрицах

править

Математика индексов матрицы - теория.

Бабочка

править 
const
  N = 10;

var
  A: array [0..N - 1, 0..N - 1] of char;

begin
  for var i := 0 to N - 1 do
    for var j := 0 to N - 1 do
      if (i <= N - j - 1) or (i <= j) then
        A[i, j] := '+'
      else
        A[i, j] := '.';
  
  for var i := 0 to N - 1 do
  begin
    for var j := 0 to N - 1 do
      Write(A[i, j]:2);
    Writeln();
  end;
end.

Песочные часы

править 
const
  N = 9;

var
  A: array [0..N - 1, 0..N - 1] of char;

begin
  for var i := 0 to N - 1 do
    for var j := 0 to N - 1 do
      if (i <= N - j - 1) and (i <= j) or (i >= N - j - 1) and (i >= j) then
        A[i, j] := '+'
      else
        A[i, j] := '.';
  
  for var i := 0 to N - 1 do
  begin
    for var j := 0 to N - 1 do
      Write(A[i, j]:2);
    Writeln();
  end;
end.

Заполнение диагоналей матрицы по правилу

править
0 1 2 3 4
0 0 1 2 3
0 0 0 1 2
0 0 0 0 1
0 0 0 0 0 
const
  N = 10;

var
  A: array [0..N - 1, 0..N - 1] of integer;
  K: integer;

begin
  K := 1;
  for var D := 1 to N - 1 do
  begin
    for var i := 0 to N - 1 do
      for var j := 0 to N - 1 do
        if i <= j - D then
          A[i, j] := K;
    Inc(K);
  end;
  
  for var i := 0 to N - 1 do
  begin
    for var j := 0 to N - 1 do
      Write(A[i, j]:5);
    Writeln();
  end;
end.
Источник — https://ru.wikibooks.org/w/index.php?title=Книга_программиста/Обработка_матриц_на_PascalABC.Net&oldid=163438