uses
crt;
var
FText: text;
//создаем свои типы
type
matrix = array [1..15, 1..15] of real;//матрица
arrayB = array [1..50] of real;//матрица-строка
function F(x: real): real;
begin
if x <= 0 then //при х<=-3
F := sqrt(-x) //1-я формула
else if ((x>=0) and (x<5)) then //при х<3
F := x //2-я формула
else //иначе
F := 4*x*x; //3-я формула
end;
//функция инициализации матрицы
function CreateMatrix(n: integer; xn: real; xk: real): matrix;
var
i, j: integer;
x, h: real;
a: matrix;
begin
x := xn;
h := (xk - xn) / (n * n - 1); //высчитываем шаг
for i := 1 to n do //перебираем строки
for j := 1 to n do //перебираем столбцы
begin
a[i, j] := f(x);
x := x + h;//увеличиваем х на шаг;
a[i, j]:=i*n-n+j;// удобно для теста
end;
CreateMatrix := a; //возвращаем матрицу
end;
//функция печати массива
procedure PrintMatrix(a: matrix; n: integer);
var
i, j: integer;
begin
for i := 1 to n do //перебираем строки
begin
for j := 1 to n do //перебираем столбцы
begin
write(a[i, j]:8:2, ' '); //выводим элемент матрицы
write(Ftext,a[i, j]:8:2, ' '); //выводим элемент матрицы
end;
writeln(Ftext,'');
writeln; //после каждой строки переход
end;
end;
//функци замены областей местами
procedure SwapMatrix(var a: matrix; n: integer);
var
i, j, h, h2: integer;
begin
h := n div 2; //высчитвыем номер первой строки второй области
for i := 1 to h do //перебираем строки перволй половины матрицы
begin
for j := 2*i-1 to min(2*i-2+h,n) do //перебираем строки
swap(a[i, j], a[i + h+(n mod 2), j]); //меняем на соответсвующие элмементы второй области
end;
end;
//функция создания матрицы чтроки
function CreateArray(a: matrix; n: integer; var m: integer): arrayB;
var
i, h, j, k: integer;
b: arrayB;
begin
m := 0;
h := n div 2;
for i := 1 to h do
begin
m := m + 1; //увеличиваем индекс в матрице строке
b[m] := a[i,min(2*i-2+h,n)]; //вставляем значение
end;
k:=n;
if n mod 2 = 1 then
i:=i+1
else
k:=n-1;
for j := k downto 1 do
begin
m := m + 1; //увеличиваем индекс в матрице строке
b[m] := a[i,j]; //вставляем значение
end;
k:=0;
for i := i+1 to n do
begin
m := m + 1; //увеличиваем индекс в матрице строке
k:=k+1;
b[m] := a[i,2*k-1]; //вставляем значение
end;
CreateArray := b; //возвращаем результат
end;
//функция печати матрицы-строки
procedure PrintArray(a: arrayB; n: integer);
var
i: integer;
begin
for i := 1 to n do //перебор индексов
begin
write(Ftext,a[i]:8:2, ' ');
write(a[i]:8:2, ' '); //печать элемента
end;
writeln(Ftext,'');
writeln;
end;
//функция сортировки пузырьком
procedure SortArray(var arr: arrayB; m: integer; IsDesc: Boolean);
var
i, j: integer;
k: real;
begin
for i := 1 to m - 1 do //перебор элементов
for j := 1 to m - i do
// если текущий элемент больше или меньше следующего в зависимости от параметра IsDesc
if (arr[j] > arr[j + 1]) and IsDesc or not IsDesc and (arr[j] < arr[j + 1]) then
begin
//то меняем местами элементы
k := arr[j];
arr[j] := arr[j + 1];
arr[j + 1] := k
end;
end;
//покраска элементов
procedure PrintMatrixColor(a: matrix; n: integer);
var
i, j, h, h2: integer;
begin
h := n div 2 ;
h2 := h + n mod 2 ;
for i := 1 to n do //перебор строк
begin
for j := 1 to n do //перебор столбцов
begin
if (i<=h) and (j=min(2*i-2+h,n)) or (i=h2) or (i>h) and (j=2*(i-h2)-1) then //проверка принадлежности стрелок
textcolor(green)
else if (i<=h) and (j>=2*i-1) and (j<=min(2*i-2+h,n))
or (i>h2) and (j>=2*(i-h2)-1) and (j<=min(2*(i-h2)-2+h,n)) then //принадлежность верхенму участку
textcolor(red)
else if (i>h) and (j<=h-(n mod 2)) and (i-h<=j) then //принадлежность нижнему участку
textcolor(Cyan)
else
textcolor(white);
write(a[i, j]:8:2, ' ');
end;
writeln;
end;
textcolor(white);
end;
//поиск минимального и максимального элемента
procedure MinMaxMatrix(var a: matrix; n: integer; var mn: real; var max: real);
var
i, j, h, h2: integer;
begin
h := n div 2 ;
h2 := h + n mod 2 ;
max := a[2, 1]; //изначально считаем что мин и мак элемент по индексу 2,1
mn := a[2, 1];
for i := 1 to n do //перебераем строки
for j := 1 to n do //перебераем столбцы
if not((i<=h) and (j>=2*i-1) and (j<=min(2*i-2+h,n))
or (i>h2) and (j>=2*(i-h2)-1) and (j<=min(2*(i-h2)-2+h,n))) then
begin
if max < a[i, j] then //если тек. элемент больше максимального
max := a[i, j]; //то делаем его максимальным
if mn > a[i, j] then //аналогично для минимального
mn := a[i, j];
end;
end;
// замена элементов в диагонали
procedure SwapDiagonalMatrix(var a: matrix; n: integer);
var
i, j: integer;
min: real;
begin
min:=a[1,n];
for i := 1 to n do //перебераем строки
if min > a[i, i] then //если тек. элемент больше минмльного
min := a[i, i]; //то делаем его минимальным
//если несколько максимальных, то замени все
for i := 1 to n do //перебераем строки
begin
a[i,i] := min;
a[i, n-i+1]:=min;
end;
end;
var
a: matrix;
n, m: integer;
xn, xk, mx, mn: real;
b: arrayB;
begin
//ввод разномернос с проверкой
assign(Ftext,'result.txt');
Rewrite (Ftext);
repeat
write('Введите число в диапазоне от 5 до 15: ');
readln(n);
until (n >= 5) and (n <= 15);
write('Введите x начальное: ');
readln(xn);
write('Введите x конечное: ');
readln(xk);
a := CreateMatrix(n, xn, xk);//создаем матрицу
writeln('Исходная матрица: ');
writeln(Ftext,'Исходная матрица: ');
PrintMatrix(a, n); //печатаем ее
writeln('Измененный массив: ');
writeln(Ftext,'Измененный массив: ');
SwapMatrix(a,n);
PrintMatrix(a, n);
writeln('Массив B: ');
writeln(Ftext,'Массив B: ');
b := CreateArray(a, n, m);
PrintArray(b, m);
writeln('Массив B отсоритрованный по возростанию: ');
writeln(Ftext,'Массив B отсоритрованный по возростанию: ');
SortArray(b,m,true);
PrintArray(b, m);
writeln('Массив B отсоритрованный по убыванию: ');
writeln(Ftext,'Массив B отсоритрованный по убыванию: ');
SortArray(b,m,false);
PrintArray(b, m);
MinMaxMatrix(a,n,mn,mx);
writeln('Максимальный элемент: ',mx:0:3);
writeln('Минимальный элемент: ',mn:0:3);
writeln(Ftext,'Максимальный элемент: ',mx:0:3);
writeln(Ftext,'Минимальный элемент: ',mn:0:3);
close(Ftext);
end.
Указать номера строк и номера столбцов на пересечении, которых находятся максимальный и минимальный элементы., Дописать код |