На сортировку / 2 / 1 курс / 5.Алгоритм и языки программ / Асем
.docxprogram sedl;
uses crt;
const NN = 20;
type AA = array [1..NN,1..NN] of integer;
type SS = array [1..NN] of integer;
var N,M,i,j,k: integer;
A: AA;
S: SS;
procedure readmatrix(N,M: integer; var Matr: AA);
var i,j: integer;
begin
for i:=1 to N do
for j:=1 to M do
read(Matr[i,j]);
readln;
clrscr;
end;
procedure writematrix(N,M: integer; var Matr: AA);
var i,j: integer;
begin
for i:=1 to N do
begin
for j:=1 to M do
write(Matr[i,j]:4);
writeln;
end;
writeln;
end;
procedure writearray(N:integer; var arr: SS);
var i: integer;
begin
for i:=1 to N do
write(arr[i]:4,' ');
end;
function sedl1(N,M,l,k: integer; Matr: AA): boolean;
var i,j,min,max: integer;
q:boolean;
begin
q:=false;
min:=Matr[l,1];
max:=Matr[1,k];
for j:=1 to M do
if Matr[l,j]<min then min:=Matr[l,j];
for i:=1 to N do
if Matr[i,k]>max then max:=Matr[i,k];
if (Matr[l,k]=min) and (Matr[l,k]=Max) then q:=true;
sedl1:=q;
end;
function sedl2(N,M,l,k: integer; Matr: AA): boolean;
var i,j,min,max: integer;
q:boolean;
begin
q:=false;
max:=Matr[l,1];
min:=Matr[1,k];
for j:=1 to M do
if Matr[l,j]>max then max:=Matr[l,j];
for i:=1 to N do
if Matr[i,k]<min then min:=Matr[i,k];
if (Matr[l,k]=min) and (Matr[l,k]=Max) then q:=true;
sedl2:=q;
end;
begin
clrscr;
repeat
write('Vvedite kol-vo strok ne bolee ',NN,',',' N=');
readln(N);
until N in [1..NN];
repeat
write('Vvedite kol-vo stolbcov ne bolee ',NN,',',' M=');
readln(M);
until M in [1..NN];
readmatrix(N,M,A);
writeln('Matrix A:');
writematrix(N,M,A);
k:=0;
for i:=1 to N do
for j:=1 to M do
if (sedl1(N,M,i,j,A)=true) or (sedl2(N,M,i,j,A)=true) then
begin
inc(k);
S[k]:=A[i,j];
end;
if k<>0 then writearray(k,S)
else write('Sedlovih tochek net!');
readln
end.
program sedl;
uses crt;
const NN = 20;
type AA = array [1..NN,1..NN] of integer;
type SS = array [1..NN] of integer;
var N,M,i,j,k: integer;
A: AA;
S: SS;
procedure readmatrix(N,M: integer; var Matr: AA);
var i,j: integer;
begin
for i:=1 to N do
for j:=1 to M do
read(Matr[i,j]);
readln;
clrscr;
end;
procedure writematrix(N,M: integer; var Matr: AA);
var i,j: integer;
begin
for i:=1 to N do
begin
for j:=1 to M do
write(Matr[i,j]:4);
writeln;
end;
writeln;
end;
procedure writearray(N:integer; var arr: SS);
var i: integer;
begin
for i:=1 to N do
write(arr[i]:4,' ');
end;
function sedl1(N,M,l,k: integer; Matr: AA): boolean;
var i,j,min,max: integer;
q:boolean;
begin
q:=false;
min:=Matr[l,1];
max:=Matr[1,k];
for j:=1 to M do
if Matr[l,j]<min then min:=Matr[l,j];
for i:=1 to N do
if Matr[i,k]>max then max:=Matr[i,k];
if (Matr[l,k]=min) and (Matr[l,k]=Max) then q:=true;
sedl1:=q;
end;
function sedl2(N,M,l,k: integer; Matr: AA): boolean;
var i,j,min,max: integer;
q:boolean;
begin
q:=false;
max:=Matr[l,1];
min:=Matr[1,k];
for j:=1 to M do
if Matr[l,j]>max then max:=Matr[l,j];
for i:=1 to N do
if Matr[i,k]<min then min:=Matr[i,k];
if (Matr[l,k]=min) and (Matr[l,k]=Max) then q:=true;
sedl2:=q;
end;
begin
clrscr;
repeat
write('Vvedite kol-vo strok ne bolee ',NN,',',' N=');
readln(N);
until N in [1..NN];
repeat
write('Vvedite kol-vo stolbcov ne bolee ',NN,',',' M=');
readln(M);
until M in [1..NN];
readmatrix(N,M,A);
writeln('Matrix A:');
writematrix(N,M,A);
k:=0;
for i:=1 to N do
for j:=1 to M do
if (sedl1(N,M,i,j,A)=true) or (sedl2(N,M,i,j,A)=true) then
begin
inc(k);
S[k]:=A[i,j];
end;
if k<>0 then writearray(k,S)
else write('Sedlovih tochek net!');
readln
end.
Var
A : Array [1..5, 1..5] Of Integer; // Массив.
x, y, z : Integer; // Переменые циклов.
Min, Max : Integer; // Минимальное и максимальное значение.
InMin, InMax : Integer; // Индексы минимального(в строке) и максимального(в столбце) элемента.
Begin
//Заполним массив и выведем его не экран.
Randomize;
For x := 1 To 5 Do
Begin
For y := 1 To 5 Do
Begin
A[x,y] := 10 + Random(90);
Write(A[x,y], ' ');
End;
Writeln;
End;
// Найдём "седловую точку"
Writeln;
For x := 1 To 5 Do
Begin
// Для начала найдём минимальный элемент в строке.
// и для наглядности выведем их индексы и значения.
Min := A[x,1];
InMin := 1;
For y := 2 To 5 Do If A[x,y] < Min Then
Begin
Min := A[x,y];
InMin := y;
End;
Writeln(x, '. Stroka');
Writeln('Minimum = ', Min, ' , a ego nomer = [', x, ',' , InMin, ']');
// Теперь найдём индекс максимального элемента по столбцу с номером InMin.
Max := A[1, InMin];
InMax := 1;
For z := 2 To 5 Do If A[z, InMin] > Max Then
Begin
Max := A[z, InMin];
InMax := z;
End;
Writeln('Dla stolbca:');
Writeln('Maximum = ', Max, ' , a ego nomer = [', InMax, ',' , InMin, ']');
// Проверим является ли эта точка "седловой".
If (x = InMax) Then Writeln('True') Else Writeln('False');
Writeln;
End;
Readln;
End.
uses TpCrt;
const Max = 10;
var
Mat : array[1..max,1..max] of Integer;
i,j : Byte;
Sedl: Boolean;
function OtrEl(st:Byte) : Boolean;
var j,kol : Byte; B : Boolean;
begin
b:=False; kol:=0;
for j:=1 to Max do begin
if Mat[st,j]<0 then Inc(kol); { Подсчет отриц. эелем }
if Mat[st,j]=0 then b:=true; { Проверка наличия нуля в строке }
end;
if b then Write(kol,' отрицательных элементов ');
OtrEl:=b;
end;
procedure SedlPointMin;
var
i,j,n : Byte;
min : Integer;
b : Boolean;
begin
for i:=1 to max do begin //для каждой строки
min:=Mat[i,1];
for j:=1 to Max do begin
if Mat[i,j]<min then begin //ищем миниамльное значение
Min:=Mat[i,j];
end;
end;
b:=true;
for j:=1 to Max do if mat[i,j]=Min then begin // для каждого мин значения в строке
for n:=1 to Max do begin
if Mat[n,j]>min then b:=false; // проверяем его максимум для столбца
end;
if b then begin
Writeln('седло : ',i:4,j:4);
Sedl:=True;
end; end; end; end;
procedure SedlPointMax;
var
i,j,n : Byte;
m : Integer;
b : Boolean;
begin
for i:=1 to max do begin
m :=Mat[i,1];
for j:=1 to Max do begin
if Mat[i,j]>m then begin
M:=Mat[i,j];
End; end;
b:=true;
for j:=1 to Max do if mat[i,j]=M then begin // для каждого макс значения в строке
for n:=1 to Max do begin
if Mat[n,j]<m then b:=false; // проверяем его мин в столбце
end;
if b then begin
Writeln('седло : ',i:4,j:4);
Sedl:=True;
end; end; end; end;
Begin
ClrScr; randomize; Writeln('Матрица :');
for i:=1 to Max do begin
for j:=1 to Max do begin
Mat[i,j]:=random(25)-5;
Write(Mat[i,j]:6);
end;
Writeln;
end;
for i:=1 to Max do if OtrEl(i) then begin
Writeln(' в строке ',i);
end;
Sedl:=False;
SedlPointMin;
SedlPointMax;
if not Sedl then Writeln('В этой матрице нет седловых елементов.');
Readln;
End.