Другое: Готовые решённые задачи в формате ТХТ
Описание
Характеристики учебной работы
Список файлов
- Массив записей
- Города и температура.txt 1,4 Kb
- Другая задача с точками.txt 1,05 Kb
- Куклы.txt 1,63 Kb
- Спортсмены.txt 1,14 Kb
- Точки.txt 1,47 Kb
- Треугольники.txt 1,37 Kb
- Матрицы
- Задача 1 (найти сумму мин и макс на побочной диаг и поделить всю матрицу на эту сумму).txt 1,35 Kb
- Задача 10 (перестановка наибольшего и наименьшего элемента в каждом столбце).txt 1,4 Kb
- Задача 11 (умножение каждого столбца на макс элемент этого столбца).txt 1,23 Kb
- Задача 12 (поменять макс элемент каждый строки с 1ым элементом (например)).txt 1,19 Kb
- Задача 13 (найти мин элемент и поделить на него всю матрицу).txt 1,38 Kb
- Задача 14 (убрать столбец с минималным элементом на побочной диагонали).txt 1,61 Kb
- Задача 15 (умножить четные столбцы на сумму мин и макс матрицы).txt 1,16 Kb
- Задача 2 (каждый элемент строки делится на макс элемент этой строки).txt 1,15 Kb
- Задача 4 (умножить числа главной диагонали на кол-во четных элементов всей матрицы).txt 1,06 Kb
- Задача 5 (найти в каждой строке ср арифметическое и из них массив).txt 1,02 Kb
- Задача 6 (умножить числа главной диагонали на кол-во нечетных элементов).txt 1,11 Kb
- Задача 7 (все элементы матрицы делятся на минимальный главной диагонали).txt 1,2 Kb
- Задача 8 (создать новую матрицу без столбца с мин элементом).txt 1,46 Kb
- Задача 9 (удалить столбец, содержащий мин элемент побочной диагонали).txt 1,34 Kb
- задача 3 (найти макс элемент на главной диагонале, удаляет строку с макс).txt 1,24 Kb
- Строки
- Внимание.txt 65 b
- Задача 1 (найти в каждой строке кол-во самых длинных слов).txt 1,45 Kb
- Задача 4 (посчитать количество четных слов в каждой строке).txt 1,11 Kb
- Задача 5 (поменять местами первое и последнее слово).txt 1,18 Kb
- Задача 6 (количество букв в строке).txt 1,55 Kb
- Задача 7 (функция-найти количество наименьших слов).txt 1,3 Kb
- Задача 8 (функция - количество различных букв в строке).txt 867 b
- Задача 9 (функция - количество мин слов).txt 1,42 Kb
- Задача фотка (изменить строку по правилу).txt 1,28 Kb
- кол-во слов заданной длины.txt 767 b
program temperatura;
{$APPTYPE CONSOLE}
uses
SysUtils;
type goroda=record
nazvanie:string[20];
temp:integer;
end;
tmas=array[1..10] of goroda;
massiv=array[1..20] of string;
procedure VVOD (var A:tmas;var n:integer);
var i:integer;
begin
writeln('VVedite kolichestvo gorodov');
readln(n);
for i:=1 to n do begin
writeln('Vvedite nazvanie');
readln(A[i].nazvanie);
writeln('Vvedite temperaturu');
readln(A[i].temp);
end;
end;
procedure VIBOR (A:tmas;n:integer;var B:massiv;var kol:integer);
var i,nizk:integer;
begin
nizk:=a[1].temp;
for i:=1 to n do if a[i].temp<nizk then nizk:=a[i].temp;
kol:=0;
for i:=1 to n do if a[i].temp=nizk then begin
kol:=kol+1;
B[kol]:=a[i].nazvanie;
end;
end;
procedure SORT (var B:massiv;kol:integer);
var i,j:integer;
buf:string;
begin
for j:=1 to kol-1 do
for i:=1 to kol-j do
if B[i]> B[i+1]then begin
buf:=B[i];
B[i]:=B[i+1];
B[i+1]:=buf;
end;
end;
var Gor:tmas;
Nizk:massiv;
i,n,k:integer;
begin
VVOD(Gor,n);
VIBOR(Gor,n,Nizk,k);
SORT(Nizk,k);
writeln;
Writeln ('Yporiadochennii massiv strok');
for i:=1 to k do write (Nizk[i],' ');
writeln;
readln;
end.
запись точки,сортирует по длине от точки до следующей точки
program Project1;
{$APPTYPE CONSOLE}
uses
SysUtils;
type XY=record
x:integer;
x1:integer;
y:integer;
y1:integer;
l:real;
end;
Tmas=array [1..100] of XY;
procedure vvod (var A:tmas;var n:integer);
Var i:integer;
begin
writeln ('vvedite kolvo elementov');
readln (n);
writeln ('VVEDITE massiv');
for i:=1 to n do begin
writeln ('vvedite x');
readln (A[i].x);
writeln ('vvedite x1') ;
readln (A[i].x1);
writeln ('vvedite y');
readln (a[i].y);
writeln ('vvedite Y1') ;
readln (A[i].y1); end;
end;
procedure vivod (a:tmas;n:integer);
var i: integer;
begin
writeln ('l' );
for i:=1 to n do
writeln (A[i].l:2:3);
end;
procedure sort (var A:tmas;var n:integer);
var i,j:integer; b:XY;
begin
for i:=1 to n do
A[i].l:=sqrt(sqr(A[i].x-A[i].x1)+sqr(A[i ].y-A[i].y1));
for i:=1 to n do begin
for j:=1 to n-i do
if a[j].l>a[j+1].l then begin
b:=A[j];
A[j]:=A[j+1];
A[j+1]:= B; end; end;
end;
var b:tmas;k:integer;
BEGIN
vvod (b,k);
sort (b,k);
vivod (b,k);readln;
END.
program igruski;
{$APPTYPE CONSOLE}
uses
SysUtils;
type igruski=record
nazvanie:string[10];
zena:integer;
min:integer;
max:integer;
end;
tmas=array[1..10] of igruski;
procedure VVOD (var A:tmas; var n:integer);
var i:integer;
begin
repeat writeln('Vvedite kolichestvo igrushek (ne bolshe 10)');
readln(n);
until n<=10;
for i:=1 to n do begin
writeln('Vvedite nazvanie');
readln(A[i].nazvanie);
writeln('Vvedite zenu');
readln(A[i].zena);
writeln('Vvedite minimalnii vozrast');
readln(A[i].min);
writeln('Vvedite maximalnii vozrast');
readln(A[i].max);
end;
end;
procedure PROV (A:tmas;n:integer;sum:integer;vozr:integ er;var C:tmas;var kol:integer);
var i:integer;
begin
kol:=0;
for i:=1 to n do if (sum>A[i].zena) and (vozr>a[i].min) and (vozr<a[i].max) then begin
kol:=kol+1;
C[kol]:=A[i];
end;
end;
procedure VIVOD (A:tmas;kol:integer);
var i:integer;
begin
if kol=0 then writeln('Takix igrushek net')
else writeln ('Nazvanie Zena Min vozr Max vozr');
for i:=1 to kol do writeln (A[i].nazvanie,' ',A[i].zena,' ',A[i].min,' ',A[i].max);
end;
var B,D:tmas;
n,k,summa,vozrast:integer;
begin
VVOD(B,n);
writeln ('Vvedite vashu summu deneg');
readln(summa);
writeln('Vvedite vozrast rebenka');
readln(vozrast);
writeln('Isxodnii massiv');
VIVOD(B,n);
writeln;
writeln('To,chto podoidet po vozrastu i zene');
PROV(B,n,summa,vozrast,D,k);
VIVOD(D,k);
readln;
end.
PROV(B,n,D,k);
VIVOD(D,k);
readln;
end.
program cpot;
{$APPTYPE CONSOLE}
uses
SysUtils;
type sport=record
fam:string[10];
ball:array [1..3] of integer;
end;
sportsmen=array[1..10] of sport;
procedure VVOD(var A:sportsmen; var n:integer);
var i,j:integer;
begin
writeln('Vvedite kolichestvo sportsmenov');
readln(n);
for i:=1 to n do begin
writeln('Vvedite familiu');
readln(A[i].fam);
writeln('Vvedite 3 rezultata');
for j:=1 to 3 do begin
read (a[i].ball[j]);
end;
readln;
end;
end;
procedure VIVOD(A:sportsmen;n:integer);
var i,j:integer;
begin
writeln('Familia ball 1 ball 2 ball 3');
for i:=1 to n do begin writeln(a[i].fam,' ');
for j:=1 to 3 do write(a[i].ball[j]:6);
end;
end;
function REC (A:sportsmen;n:integer;star:integer):boo lean;
var i,j,s:integer;
begin
REC:=false;
for i:=1 to n do begin
S:=0;
for j:=1 to 3 do S:=s+a[i].ball[j];
if S>star then
REC:=true;
end;
end;
var Sp:sportsmen;
n,star:integer;
begin
VVOD(Sp,n);
writeln('Vvedite starii rezultat');
readln(star);
if REC(Sp,n,star) then writeln('ruzeltat pobit')
else writeln('rezultat ne pobit');
readln;
end.
Дан массив записей о точках на плоскости. Проверить, расположены ли расстояния от точек до начала координат в порядке возрастания, если нет - отсортировать.
program toch;
{$APPTYPE CONSOLE}
uses
SysUtils;
type tochki=record
x:real;
y:real;
end;
tmas=array[1..20] of tochki; {massiv tochek}
var n,m:integer;
t:tmas;
i:integer;
procedure vvod(n1:integer;var t1:tmas);
var i:integer;
begin
for i:=1 to n1 do begin
writeln('Vvedite koordinaty X',i);readln(t1[i].x);
writeln('Vvedite koordinaty Y',i);readln(t1[i].y);
end;
end;
procedure vivod(n1:integer;t1:tmas);
begin
for i:=1 to n1 do
writeln(t1[i].x:2:0,' ',t1[i].y:2:0);
end;
function rast(x1:real;y1:real):real;
var q:real;
begin
q:=sqrt(sqr(x1)+sqr(y1));
rast:=q;
end;
procedure proverka(n1:integer;var m1:integer; var t1:tmas);
var p,j:integer;
ra:array[1..20] of real;
buf:tochki;
begin
for i:=1 to n1 do
ra[i]:=rast(t1[i].x,t1[i].y);
p:=1;
for i:=1 to n1-1 do
if ra[i]>ra[i+1] then p:=0;
if p=0 then m1:=0
else m1:=1;
if p=0 then
for i:=1 to n1-1 do begin
for j:=1 to n1-i do
if rast(t[j].x,t[j].y)>rast(t[j+1].x,t[j+1] .y) then begin
buf.x:=t[j].x;
buf.y:=t[j].y;
t[j].x:=t[j+1].x;
t[j].y:=t[j+1].y;
t[j+1].x:=buf.x;
t[j+1].y:=buf.y;
end;
end;
end;
begin {osn programma}
writeln('Vvedite kol-vo tochek');
readln(n);
vvod(n,t);
proverka(n,m,t);
if m=0 then writeln('Net. Ots. massiv: ');
vivod(n,t);
if m=1 then writeln('DA');
readln;
end.
Занести в другой массив записей прямоугольные треугольники. Даны в записи их стороны
program Project2;
{$APPTYPE CONSOLE}
uses
SysUtils;
type zap=record
AB:integer;
BC:integer;
AC:integer;
end;
tre=array[1..20] of zap;
procedure VVOD (var a:tre;var n:integer);
var i:integer;
begin
writeln('Vvedite kolichestvo treygolnikov');
readln(n);
for i:=1 to n do begin
writeln('Vvedite storonu AB');
readln(a[i].AB);
writeln('Vvedite storonu BC');
readln(a[i].BC);
writeln('Vvedite storonu AC');
readln(a[i].AC);
end;
end;
procedure VIBOR(a:tre;n:integer;var b:tre;var k:integer);
var i:integer;
begin
k:=0;
for i:=1 to n do if
(sqr(a[i].AC)=sqr(a[i].AB)+sqr(a[i].BC))
or (sqr(a[i].AB)=sqr(a[i].AC)+sqr(a[i].BC))
or (sqr(a[i].BC)=sqr(a[i].AB)+sqr(a[i].AC)) then begin
k:=k+1;
b[k]:=a[i];
end;
end;
procedure VIVOD(b:tre;k:integer);
var i:integer;
begin
writeln('AB BC AC');
for i:=1 to k do writeln(b[i].AB,' ',b[i].BC,' ',b[i].AC);
end;
var A,C:tre;
n,k:integer;
begin
VVOD(A,n);
VIBOR(A,n,C,k);
writeln('Priamoygolnie treygolniki');
VIVOD(C,k);
readln;
end.
1) в матрице найти минимальный и максимальный элементы побочной диагонали, поделить все элементы на их сумму (используя процедуру/функцию)
program matrizi;
{$APPTYPE CONSOLE}
uses
SysUtils;
type mas=array[1..15,1..15] of double;
procedure VVOD (var a:mas;var n:integer);
var i,j:integer;
begin
writeln('VVedite kolichestvo strok/stolbzov');
readln(n);
writeln('Vvedite matrizu');
for i:=1 to n do begin
for j:=1 to n do read (a[i,j]);
readln;
end;
end;
procedure POISK (a:mas;n:integer;var sum:double);
var i,j:integer;
min,max:double;
begin
min:=a[1,n];
for i:=1 to n do if a[i,n+1-i]<min then min:=a[i,n+1-i];
max:=a[1,n];
for i:=1 to n do if a[i,n+1-i]>max then max:=a[i,n+1-i];
sum:=min+max;
writeln('Min element pobochnoi diag ',min:0:0);
writeln('Max element pobochnoi diag ',max:0:0);
writeln('Cymma ',sum:0:0);
end;
procedure DELENIE (a:mas;n:integer;sum:double;var c:mas);
var i,j:integer;
begin
for i:=1 to n do begin
for j:=1 to n do c[i,j]:=a[i,j]/sum;
end;
end;
procedure VIVOD (c:mas;n:integer);
var i,j:integer;
begin
for i:=1 to n do begin
for j:=1 to n do write (c[i,j]:1:1,' ');
writeln;
end;
end;
var M,K:mas;
n:integer;
summa:double;
begin
VVOD(M,n);
POISK(M,n,summa);
DELENIE(M,n,summa,K);
VIVOD(K,n);
readln;
end.
10) квадратная матрица, надо написать процедуру перестановки наибольшего и наименьшего элементов в каждом столбце и процедуру вывода/ввод в основной программе
program matrizi;
{$APPTYPE CONSOLE}
uses
SysUtils;
type mas=array[1..15,1..15] of integer;
procedure VVOD (var a:mas;var n:integer);
var i,j:integer;
begin
writeln('VVedite kolichestvo strok/stolbzov');
readln(n);
writeln('Vvedite matrizu');
for i:=1 to n do begin
for j:=1 to n do read (a[i,j]);
readln;
end;
end;
procedure POISK (var a:mas;n:integer);
var i,j,min,max,imin,imax,buf:integer;
begin
for j:=1 to n do begin
min:=a[1,j];
imin:=1;
for i:=1 to n do if a[i,j]<min then begin
min:=a[i,j];
imin:=i;
end;
max:=a[1,j];
imax:=1;
for i:=1 to n do if a[i,j]>max then begin
max:=a[i,j];
imax:=i;
end;
a[imax,j]:=min;
a[imin,j]:=max;
end;
end;
procedure VIVOD (a:mas;n:integer);
var i,j:integer;
begin
for i:=1 to n do begin
for j:=1 to n do write (a[i,j],' ');
writeln;
end;
end;
var A:mas;
n:integer;
begin
VVOD(A,n);
POISK(A,n);
writeln('Poluchennaya matriza');
VIVOD(A,n);
readln;
end.
11) матрицу n x m чтоб н<=10 м<=12 вещественных чисел.
Создать проедуру обработки матрицы чтобы она находила в каждом столбце максимальный элемент и умножала этот столбец на максимальный элемент своего столбца. Вывод матрицв сделать в основной программе
program matrizi;
{$APPTYPE CONSOLE}
uses
SysUtils;
type mas=array[1..10,1..12] of double;
procedure VVOD (var a:mas;var n,m:integer);
var i,j:integer;
begin
repeat
writeln('VVedite kolichestvo strok');
readln(n);
until n<=10;
repeat
writeln('VVedite kolichestvo stolbzov');
readln(m);
until n<=12;
writeln('Vvedite matrizu');
for i:=1 to n do begin
for j:=1 to n do read (a[i,j]);
readln;
end;
end;
procedure POISK (var a:mas;n,m:integer);
var i,j:integer;
max:double;
begin
for j:=1 to m do begin
max:=a[1,j];
for i:=1 to n do if a[i,j]>max then max:=a[i,j];
for i:=1 to n do a[i,j]:=a[i,j]*max;
end;
end;
procedure VIVOD (a:mas;n,m:integer);
var i,j:integer;
begin
for i:=1 to n do begin
for j:=1 to m do write (a[i,j]:1:1,' ');
writeln;
end;
end;
var A:mas;
n,m:integer;
begin
VVOD(A,n,m);
POISK(A,n,m);
writeln('Poluchennaya matriza');
VIVOD(A,n,m);
readln;
end.
12) в строках матрицы - найти макс и поменять местами с чем-то
(я меняла для разнообразия с первым элементом)
program matrizi;
{$APPTYPE CONSOLE}
uses
SysUtils;
type mas=array[1..15,1..20] of integer;
procedure VVOD (var a:mas;var n,m:integer);
var i,j:integer;
begin
writeln('VVedite kolichestvo strok');
readln(n);
writeln('VVedite kolichestvo stolbzov');
readln(m);
writeln('Vvedite matrizu');
for i:=1 to n do begin
for j:=1 to m do read (a[i,j]);
readln;
end;
end;
procedure POISK (var a:mas;n,m:integer);
var i,j,max,kol,jmax:integer;
begin
for i:=1 to n do begin
max:=a[i,1];
jmax:=1;
for j:=1 to m do if a[i,j]>max then begin
max:=a[i,j];
jmax:=j;
end;
a[i,jmax]:=a[i,1];
a[i,1]:=max;
end;
end;
procedure VIVOD (a:mas;n,m:integer);
var i,j:integer;
begin
for i:=1 to n do begin
for j:=1 to m do write (a[i,j],' ');
writeln;
end;
end;
var A:mas;
n,m:integer;
begin
VVOD(A,n,m);
POISK(A,n,m);
writeln('Poluchennaya matriza');
VIVOD(A,n,m);
readln;
end.
13) В матрице 12х15 найти минимальный элемент в матрице. Поделить всю матрицу на этот элемент , если он = 0 , не изменить матрицу. Использовать процедуру. Вывести исходную матрицу и полученную в основной программе
program matrizi;
{$APPTYPE CONSOLE}
uses
SysUtils;
type mas=array[1..12,1..15] of double;
procedure VVOD (var a:mas;var n,m:integer);
var i,j:integer;
begin
repeat
writeln('VVedite kolichestvo strok');
readln(n);
until n<12;
repeat
writeln('VVedite kolichestvo stolbzov');
readln(m);
until m<15;
writeln('Vvedite matrizu');
for i:=1 to n do begin
for j:=1 to m do read (a[i,j]);
readln;
end;
end;
procedure POISK (a:mas;n,m:integer;var b:mas);
var i,j:integer;
min:double;
begin
min:=a[1,1];
for i:=1 to n do begin
for j:=1 to m do if a[i,j]<min then min:=a[i,j];
end;
for i:=1 to n do begin
for j:=1 to m do begin
b[i,j]:=a[i,j];
b[i,j]:=b[i,j]/min;
end;
end;
end;
procedure VIVOD (a:mas;n,m:integer);
var i,j:integer;
begin
for i:=1 to n do begin
for j:=1 to m do write (a[i,j]:1:1,' ');
writeln;
end;
end;
var A,B:mas;
n,m:integer;
begin
VVOD(A,n,m);
POISK(A,n,m,B);
writeln('Isxodnaya matriza');
VIVOD(A,n,m);
writeln('Poluchennaya matriza');
VIVOD(B,n,m);
readln;
end.
14) Задана квадратная матрица А(n,n) n<=10. вещественных чисел.Написать процедуру новой матрицы путем вычеркивания солбца, где расположен минимальный элемент ПОБОЧНОЙ диагонали исходной матрицы.считать элемент единственный. В основной пограмме распечатать исходную и полученную матрицу.
program matrizi;
{$APPTYPE CONSOLE}
uses
SysUtils;
type mas=array[1..10,1..10] of double;
procedure VVOD (var a:mas;var n,m:integer);
var i,j:integer;
begin
repeat
repeat
writeln('VVedite kolichestvo strok');
readln(n);
until n<=10;
repeat
writeln('VVedite kolichestvo stolbzov');
readln(m);
until m<=10;
until m=n;
writeln('Vvedite matrizu');
for i:=1 to n do begin
for j:=1 to m do read (a[i,j]);
readln;
end;
end;
procedure POISK (a:mas;n:integer;var b:mas;var m:integer);
var i,j,jmin:integer;
min:double;
begin
min:=a[1,m];
jmin:=m;
for i:=1 to n do if a[i,m+1-i]<min then begin
min:=a[i,m+1-i];
jmin:=m+1-i;
end;
for i:=1 to n do
for j:=1 to m do b[i,j]:=a[i,j];
for i:=1 to n do
for j:=jmin to m-1 do begin b[i,j]:=b[i,j+1];
end;
m:=m-1;
end;
procedure VIVOD (a:mas;n,m:integer);
var i,j:integer;
begin
for i:=1 to n do begin
for j:=1 to m do write (a[i,j]:1:1,' ');
writeln;
end;
end;
var A,B:mas;
n,m:integer;
begin
VVOD(A,n,m);
POISK(A,n,B,m);
writeln('Isxodnaia matriza');
VIVOD(A,n,n);
writeln('Poluchennaya matriza');
VIVOD(B,n,m);
readln;
end.
15) в матрице прямоугольной элементы чётных столбов умножить на сумма минмального и максимального элемента всей матрицы
program Project2;
{$APPTYPE CONSOLE}
uses
SysUtils;
type mas=array[1..20,1..20] of integer;
procedure VVOD (var A:mas; var n,m:integer);
var i,j:integer;
begin
writeln('Vvedite kolichestvo strok');
readln(n);
writeln('Vvedite kolichestvo stolbzov');
readln(m);
writeln('Vvedite matrizu');
for i:=1 to n do begin
for j:=1 to m do read (a[i,j]);
readln;
end;
end;
procedure POISK (var A:mas;n,m:integer);
var i,j,min,max,sum:integer;
begin
min:=a[1,1];
for i:=1 to n do
for j:=1 to m do if a[i,j]<min then min:=a[i,j];
max:=a[1,1];
for i:=1 to n do
for j:=1 to m do if a[i,j]>max then max:=a[i,j];
sum:=max+min;
for i:=1 to n do begin
for j:=1 to m do if (j mod 2) = 0 then a[i,j]:=a[i,j]*sum;
end;
end;
procedure VIVOD (A:mas;n,m:integer);
var i,j:integer;
begin
for i:=1 to n do begin
for j:=1 to m do write (a[i,j],' ');
writeln;
end;
end;
var n,m:integer;
A:mas;
begin
VVOD(A,n,m);
POISK(A,n,m);
VIVOD(A,n,m);
readln;
end.
2) Матрица. Процедура: в строке находит максимальный элемент и делит каждый элемент на него. Если искомый элемент 0, то оставляет строку без изменений. В основной программе провести процедуру на всех строках.
program matrizi;
{$APPTYPE CONSOLE}
uses
SysUtils;
type mas=array[1..15,1..15] of double;
var M,K:mas;
n,i:integer;
procedure VVOD (var a:mas;var n:integer);
var i,j:integer;
begin
writeln('VVedite kolichestvo strok/stolbzov');
readln(n);
writeln('Vvedite matrizu');
for i:=1 to n do begin
for j:=1 to n do read (a[i,j]);
readln;
end;
end;
procedure POISK_Del (a:mas;n:integer;var c:mas);
var j:integer;
max,del:double;
begin
max:=a[i,1];
for j:=1 to n do if a[i,j]>max then max:=a[i,j];
for j:=1 to n do begin
del:=a[i,j]/max;
C[i,j]:=del;
end;
end;
procedure VIVOD (c:mas;n:integer);
var i,j:integer;
begin
for i:=1 to n do begin
for j:=1 to n do write (c[i,j]:1:1,' ');
writeln;
end;
end;
begin
VVOD(M,n);
for i:=1 to n do
POISK_Del(M,n,K);
writeln('Poluchennaya matriza');
VIVOD(K,n);
readln;
end.
4) Умножить все элементы главной диагонали квадратной матрицы на кол-во четных элементов всей матрицы. Вывести сообщение, если матрица не изменится.
program matrizi;
{$APPTYPE CONSOLE}
uses
SysUtils;
type mas=array[1..15,1..15] of integer;
procedure VVOD (var a:mas;var n:integer);
var i,j:integer;
begin
writeln('VVedite kolichestvo strok/stolbzov');
readln(n);
writeln('Vvedite matrizu');
for i:=1 to n do begin
for j:=1 to n do read (a[i,j]);
readln;
end;
end;
procedure POISK (var a:mas;n:integer);
var i,j,max,kol:integer;
begin
kol:=0;
for i:=1 to n do
for j:=1 to n do
if (a[i,j] mod 2) = 0 then kol:=kol+1;
if kol=1 then writeln ('matriza ne izmenitsia')
else begin
for i:=1 to n do a[i,i]:=a[i,i]*kol;
end;
end;
procedure VIVOD (a:mas;n:integer);
var i,j:integer;
begin
for i:=1 to n do begin
for j:=1 to n do write (a[i,j],' ');
writeln;
end;
end;
var M:mas;
n:integer;
begin
VVOD(M,n);
POISK(M,n);
writeln('Poluchennaya matriza');
VIVOD(M,n);
readln;
end.
5) матрица m<30 n<20 найти в каждой строке среднее арифм и из этих этих ср.арифм создать массив
program matrizi;
{$APPTYPE CONSOLE}
uses
SysUtils;
type mas=array[1..30,1..20] of integer;
massiv=array[1..30] of double;
procedure VVOD (var a:mas;var n,m:integer);
var i,j:integer;
begin
writeln('VVedite kolichestvo strok');
readln(n);
writeln('VVedite kolichestvo stolbzov');
readln(m);
writeln('Vvedite matrizu');
for i:=1 to n do begin
for j:=1 to m do read (a[i,j]);
readln;
end;
end;
procedure POISK (a:mas;n,m:integer;var b:massiv);
var i,j,sum:integer;
ar:double;
begin
for i:=1 to n do begin
sum:=0;
for j:=1 to m do sum:=sum+a[i,j];
ar:=sum/m;
b[i]:=ar;
end;
end;
procedure VIVOD (b:massiv;n:integer);
var i:integer;
begin
for i:=1 to n do write (b[i]:1:1,' ');
writeln;
end;
var A:mas;
b:massiv;
n,m:integer;
begin
VVOD(A,n,m);
POISK(A,n,m,b);
writeln('Poluchennaya matriza');
VIVOD(b,n);
readln;
end.
6) матрица, главная диагональ, умножить все члены диагонали на колво нечетных в матрице, и если не изменится - вывести сообщение (теоретические вопросы в этом билете: оперативная память и условный оператор)
program matrizi;
{$APPTYPE CONSOLE}
uses
SysUtils;
type mas=array[1..15,1..15] of integer;
procedure VVOD (var a:mas;var n:integer);
var i,j:integer;
begin
writeln('VVedite kolichestvo strok/stolbzov');
readln(n);
writeln('Vvedite matrizu');
for i:=1 to n do begin
for j:=1 to n do read (a[i,j]);
readln;
end;
end;
procedure POISK (var a:mas;n:integer);
var i,j,max,kol:integer;
begin
kol:=0;
for i:=1 to n do
for j:=1 to n do
if (a[i,j] mod 2) = 1 then kol:=kol+1;
if kol=1 then writeln ('matriza ne izmenitsia')
else begin
for i:=1 to n do a[i,i]:=a[i,i]*kol;
end;
end;
procedure VIVOD (a:mas;n:integer);
var i,j:integer;
begin
for i:=1 to n do begin
for j:=1 to n do write (a[i,j],' ');
writeln;
end;
end;
var M:mas;
n:integer;
begin
VVOD(M,n);
POISK(M,n);
writeln('Poluchennaya matriza');
VIVOD(M,n);
readln;
end.
7) дана квадратна матрица n<=10. Разработать процедуру, в которой все элементы матрицы делятся на минимальный элемент главной диагонали. В основной программе вывести преобразованную матрицу или сообщение , что преобразовать нельзя
program matrizi;
{$APPTYPE CONSOLE}
uses
SysUtils;
type mas=array[1..10,1..10] of double;
procedure VVOD (var a:mas;var n:integer);
var i,j:integer;
begin
repeat
writeln('VVedite kolichestvo strok/stolbzov');
readln(n);
until n<=10;
writeln('Vvedite matrizu');
for i:=1 to n do begin
for j:=1 to n do read (a[i,j]);
readln;
end;
end;
procedure POISK (var a:mas;n:integer);
var i,j:integer;
min:double;
begin
min:=a[1,1];
for i:=1 to n do if a[i,i]<min then min:=a[i,i];
if min=0 then writeln ('Preobrazovat nelzia')
else begin
for i:=1 to n do begin
for j:=1 to n do a[i,j]:=a[i,j]/min
end;
end;
end;
procedure VIVOD (a:mas;n:integer);
var i,j:integer;
begin
for i:=1 to n do begin
for j:=1 to n do write (a[i,j]:1:1,' ');
writeln;
end;
end;
var M:mas;
n:integer;
begin
VVOD(M,n);
POISK(M,n);
writeln('Poluchennaya matriza');
VIVOD(M,n);
readln;
end.
8) найти минимальный эл в матрице запомнить этот слобец и записать все элементы в новую матрицу без этого столбца
program matrizi;
{$APPTYPE CONSOLE}
uses
SysUtils;
type mas=array[1..15,1..10] of integer;
procedure VVOD (var a:mas;var n,m:integer);
var i,j:integer;
begin
writeln('VVedite kolichestvo strok');
readln(n);
writeln('VVedite kolichestvo stolbzov');
readln(m);
writeln('Vvedite matrizu');
for i:=1 to n do begin
for j:=1 to m do read (a[i,j]);
readln;
end;
end;
procedure POISK (a:mas;n:integer;var m:integer;var b:mas);
var i,j,min,jmin:integer;
begin
min:=a[1,1];
jmin:=1;
for i:=1 to n do begin
for j:=1 to m do if a[i,j]<min then begin
min:=a[i,j];
jmin:=j;
end;
end;
writeln('Min el ',min,' stoit v stolbze ',jmin);
for i:=1 to n do
for j:=1 to m do b[i,j]:=a[i,j];
for i:=1 to n do begin
for j:=jmin to m-1 do begin
b[i,j]:=b[i,j+1];
end;
end;
m:=m-1;
end;
procedure VIVOD (b:mas;n,m:integer);
var i,j:integer;
begin
for i:=1 to n do begin
for j:=1 to m do write (b[i,j],' ');
writeln;
end;
end;
var A,B:mas;
n,m:integer;
begin
VVOD(A,n,m);
POISK(A,n,m,B);
writeln('Poluchennaya matriza');
VIVOD(B,n,m);
readln;
end.
9) дана квадратная матрица. Найти минимальный элемент побочной диагонали и удалить столбец его содержащий.
program matrizi;
{$APPTYPE CONSOLE}
uses
SysUtils;
type mas=array[1..15,1..15] of integer;
procedure VVOD (var a:mas;var n,m:integer);
var i,j:integer;
begin
repeat
writeln('VVedite kolichestvo strok');
readln(n);
writeln('Vvedite kolichestvo stolbzov');
readln(m);
until n=m;
writeln('Vvedite matrizu');
for i:=1 to n do begin
for j:=1 to n do read (a[i,j]);
readln;
end;
end;
procedure POISK (var a:mas;n:integer;var m:integer);
var i,j,min,jmin:integer;
begin
min:=a[1,n];
jmin:=n;
for i:=1 to n do begin
if a[i,n+1-i]<min then begin
min:=a[i,n+1-i];
jmin:=n+1-i;
end;
end;
writeln('min el ',min,' v ',jmin);
for i:=1 to n do begin
for j:=jmin to m-1 do begin
a[i,j]:=a[i,j+1];
end;
end;
m:=m-1;
end;
procedure VIVOD (a:mas;n,m:integer);
var i,j:integer;
begin
for i:=1 to n do begin
for j:=1 to m do write (a[i,j],' ');
writeln;
end;
end;
var A:mas;
n,m:integer;
begin
VVOD(A,n,m);
POISK(A,n,m);
writeln('Poluchennaya matriza');
VIVOD(A,n,m);
readln;
end.
3) На главной диагонали находит максимум и удаляет строку содержащую этот максимум.
program matrizi;
{$APPTYPE CONSOLE}
uses
SysUtils;
type mas=array[1..15,1..15] of integer;
procedure VVOD (var a:mas;var n,m:integer);
var i,j:integer;
begin
repeat
writeln('VVedite kolichestvo strok');
readln(n);
writeln('Vvedite kolichestvo stolbzov');
readln(m);
until m=n;
writeln('Vvedite matrizu');
for i:=1 to n do begin
for j:=1 to m do read (a[i,j]);
readln;
end;
end;
procedure Del (var a:mas;n:integer;m:integer;var s:integer);
var i,j,imax,max:integer;
begin
max:=a[1,1];
imax:=1;
for i:=1 to n do
for j:=i to i do
if a[i,j]>max then begin
max:=a[i,j];
imax:=i;
end;
for j:=1 to m do
for i:=imax to n do begin
a[i,j]:=a[i+1,j];
s:=n-1;
end;
end;
procedure VIVOD (a:mas;s,m:integer);
var i,j:integer;
begin
for i:=1 to s do begin
for j:=1 to m do write (a[i,j],' ');
writeln;
end;
end;
var A:mas;
m,n,s:integer;
begin
VVOD(A,n,m);
DEL(A,n,m,s);
writeln('Poluchennaya matriza');
VIVOD(A,s,m);
readln;
end.
Задачи на строки надо решать по примеру задачи 1! (осн программа)
1) найти кол-во максимальных элементов в массиве строк (как понимаю, надо написать процедуру/функцию, которая находит максимальное кол-во элементов в строке, а в основной программе уже найти кол-во максимальных элементов в тексте)
program Project1;
{$APPTYPE CONSOLE}
uses
SysUtils;
type mas=array[1..20] of string;
procedure SLOVO (var s:string;var b:mas;var kol:integer);
var slovo,max:string;
i,n,p:integer;
begin
{удаление пробелов - необязательно думаю}
p:=pos(' ',s);
while p>0 do
begin
delete(s,p,1);
p:=pos(' ',s);
end;
{сама программа}
s:=s+' ';
slovo:='';
n:=0;
for i:=1 to length(s) do if s[i]<>' ' then slovo:=slovo+s[i]
else begin
n:=n+1;
b[n]:=slovo;
slovo:=''
end;
max:=b[1];
for i:=1 to n do
if length(b[i])>length(max) then max:=b[i];
kol:=0;
for i:=1 to n do
if length(b[i])=length(max) then
kol:=kol+1;
end;
var s:string;
b,b1:mas;
n,i:integer;kol:array[1..20] of integer;
begin
writeln('Vvedite kolichestvo strok');
readln(n);
for i:=1 to n do begin
writeln('Vvedite stroku');
readln(b1[i]);
end;
for i:=1 to n do SLOVO(b1[i],b,kol[i]);
writeln('Izmenennie stroki');
for i:=1 to n do
writeln('Kolichestvo max dlin slov ',kol[i],' v stroke ',i);
readln;
end.
4) процедура в строке удаляет лишнии пробелы и подсчитыает слова с четным количеством букв
program Project2;
{$APPTYPE CONSOLE}
uses
SysUtils;
procedure Izmen (var s:string;var chet:integer);
var i,p,kol:integer;
slovo:string;
begin
writeln('Vvedite stroku');
readln(s);
{удаление пробелов}
p:=pos(' ',s);
while p>0 do begin
delete(s,p,1);
p:=pos(' ',s);
end;
if s[1]=' ' then delete(s,1,1);
if s[length(s)]=' ' then delete (s,length(s),1);
s:=s+' ';
slovo:='';
chet:=0;
for i:=1 to length(s) do
if s[i]<>' ' then slovo:=slovo+s[i]
else begin if length(slovo) mod 2=0 then begin
chet:=chet+1;
slovo:='';
end
else slovo:='';
end;
writeln('kol-vo chet slov ',chet);
end;
var n,k,j:integer;
s:string;
begin
writeln('Vvedite kolichestvo strok');
readln(n);
for j:=1 to n do begin
Izmen(s,k);
end;
readln;
end.
5) разработать процедуру которая в строке меняет первое и последнее слово
program Project1;
{$APPTYPE CONSOLE}
uses
SysUtils;
type mas=array[1..20] of string;
procedure ZAMENA (var s:string;n:integer;var b:mas;var k:integer);
var i,p,j:integer;
slovo,buf:string;
begin
writeln('vvedite stroku');
readln(s);
{удаление пробелов}
p:=pos(' ',s);
while p>0 do begin
delete(s,p,1);
p:=pos(' ',s);
end;
if s[1]=' ' then delete(s,1,1);
if s[length(s)]=' ' then delete (s,length(s),1);
s:=s+' ';
slovo:='';
k:=0;
for i:=1 to length(s) do if s[i]<>' ' then slovo:=slovo+s[i]
else begin
k:=k+1;
b[k]:=slovo;
slovo:='';
end;
for i:=1 to k do begin
buf:=b[1];
b[1]:=b[k];
b[k]:=buf;
end;
end;
var n,i,kol,j:integer;
st:string;
B:mas;
begin
writeln('Vvedite kolichestvo strok');
readln(n);
for i:=1 to n do begin
ZAMENA(st,n,B,kol);
for j:=1 to kol do write (B[j],' ');
writeln;
end;
readln;
end.
6) используя процедуру, посчитать сколько букв в строке произвольной длины
program Project1;
{$APPTYPE CONSOLE}
uses
SysUtils;
procedure CHISLO (var s:string;n:integer;var k:integer);
var i,p,j:integer;
slovo,buf:string;
begin
writeln('vvedite stroku');
readln(s);
{удаление пробелов}
p:=pos(' ',s);
while p>0 do begin
delete(s,p,1);
p:=pos(' ',s);
end;
if s[1]=' ' then delete(s,1,1);
if s[length(s)]=' ' then delete (s,length(s),1);
s:=s+' ';
slovo:='';
k:=0;
for i:=1 to length(s) do if s[i]<>' ' then k:=k+1;
end;
var n,i,kol,j:integer;
st:string;
begin
writeln('Vvedite kolichestvo strok');
readln(n);
for i:=1 to n do begin
CHISLO(st,n,kol);
writeln('Kolicestvo bukv v ',i,' stroke ravno ',kol);
end;
readln;
end.
___________
6) используя процедуру, посчитать сколько букв в строке произвольной длины (если учитывать, что заданы разные символы)
program Project2;
{$APPTYPE CONSOLE}
uses
SysUtils;
type mn=set of char;
function Kol(var s:string;n:integer):integer;
var i,p,k:integer;
M:mn;
begin
writeln('Vvedite stroku');
readln(s);
{поиск букв}
M:=['A'..'Z'];
k:=0;
for i:=1 to length(s) do if upcase(s[i]) in M then k:=k+1;
Kol:=k;
end;
var n,i,kolich:integer;
st:string;
begin
writeln('Vvedite kol-vo strok');
readln(n);
for i:=1 to n do begin
kolich:=kol(st,n);
writeln('Kolichestvo bukv v stroke ravno ',kolich);
end;
readln;
end.
7) Составить функцию, которая в строке произвольной длины находит число слов с минимальной длиной.
program Project1;
{$APPTYPE CONSOLE}
uses
SysUtils;
type mas=array[1..20] of string;
function CHISLO (var s:string;var b:mas;var kol:integer):integer;
var slovo,min:string;
i,n,p:integer;
begin
writeln('Vvedite stroku');
readln(s);
{удаление пробелов}
p:=pos(' ',s);
while p>0 do
begin
delete(s,p,1);
p:=pos(' ',s);
end;
if s[1]=' ' then delete(s,1,1);
if s[length(s)]=' ' then delete (s,length(s),1);
{сама программа}
s:=s+' ';
slovo:='';
n:=0;
for i:=1 to length(s) do if s[i]<>' ' then slovo:=slovo+s[i]
else begin
n:=n+1;
b[n]:=slovo;
slovo:=''
end;
min:=b[1];
for i:=1 to n do
if length(b[i])<length(min) then min:=b[i];
kol:=0;
for i:=1 to n do
if length(b[i])=length(min) then
kol:=kol+1;
CHISLO:=kol;
end;
var s:string;
b:mas;
n,i,kol:integer;
begin
writeln('Vvedite kolichestvo strok');
readln(n);
for i:=1 to n do begin
CHISLO(s,b,kol);
writeln('Kolichestvo min dlin slov ',kol,' v stroke ',i);
end;
readln;
end.
8) Написать функцию, которая определяет, сколько различных (именно различных:) букв есть в строке. Разработать эту функцию для N строк.
program Project1;
{$APPTYPE CONSOLE}
uses
SysUtils;
type mn=set of char;
function CHISLO (var s:string;n:integer):integer;
var i,kol:integer;
M:mn;
begin
writeln('Vvedite stroku');
readln(s);
M:=['A'..'Z'];
kol:=0;
for i:=1 to length(s) do if upcase(s[i]) in M then begin
kol:=kol+1;
M:=M-[upcase(s[i])];
end;
CHISLO:=kol;
end;
var n,i,kol:integer;
st:string;
begin
writeln('Vvedite kolichestvo strok');
readln(n);
for i:=1 to n do begin
kol:=CHISLO(st,n);
writeln('kol-vo razlichnix bukz v stroke ',kol);
end;
readln;
end.
9) разработать функцию для подсчета в строке минимального слова. (не поняла что это значит, то ли указать длину мин слова, то ли указать количество таких слов, но если писать длину слова, то тогда не учитывается условие, "их может быть несколько", поэтому думаю надо искать их количество) Учитывать , что их может быть несколько. Функцию применить для многих строк , количесво которых вводится с клавиатуры.
program Project2;
{$APPTYPE CONSOLE}
uses
SysUtils;
type mas=array[1..20] of string;
function Min_sl (var s:string;n:integer):integer;
var i,kol:integer;
slovo,min:string;
b:mas;
begin
writeln('Vvedite stroku');
readln(s);
s:=s+' ';
slovo:='';
n:=0;
for i:=1 to length(s) do if s[i]<>' ' then slovo:=slovo+s[i]
else begin
n:=n+1;
b[n]:=slovo;
slovo:=''
end;
min:=b[1];
for i:=1 to n do
if length(b[i])<length(min) then min:=b[i];
kol:=0;
for i:=1 to n do
if length(b[i])=length(min) then
kol:=kol+1;
Min_sl:=kol;
end;
var n,k,i:integer;
st:string;
begin
writeln('Vvedite kol-vo strok');
readln(n);
for i:=1 to n do begin
k:=Min_sl(st,n);
writeln('Kolichestvo min slov ravno ',k);
end;
readln;
end.
Задача с фотки (изменить строку по правилу: пробел должен быть после . , ; а не перед ними)
program Project1;
{$APPTYPE CONSOLE}
uses
SysUtils;
procedure OSHIBKI(var s:string);
var p,k,i:integer;
begin
p:=pos(' ',s);
while p>0 do begin
delete(s,p,1);
p:=pos(' ',s);
end;
if s[1]=' ' then delete(s,1,1);
if s[length(s)]=' ' then delete(s,length(s),1);
k:=pos(' ,',s);
while k>0 do begin
delete(s,k,1);
k:=pos(' ,',s);
end;
k:=pos(' ;',s);
while k>0 do begin
delete(s,k,1);
k:=pos(' ;',s);
end;
k:=pos(' .',s);
while k>0 do begin
delete(s,k,1);
k:=pos(' .',s);
end;
for i:=length(s) downto 1 do if s[i]=',' then insert(' ',s,i+1);
for i:=length(s) downto 1 do if s[i]='.' then insert(' ',s,i+1);
for i:=length(s) downto 1 do if s[i]=';' then insert(' ',s,i+1);
p:=pos(' ',s);
while p>0 do begin
delete(s,p,1);
p:=pos(' ',s);
end;
end;
var n,i:integer;
st:array[1..10] of string;
begin
writeln('Vvedite kolichestvo strok');
readln(n);
for i:=1 to n do begin
writeln('Vvedite stroku');
readln(st[i]);
end;
for i:=1 to n do OSHIBKI(st[i]);
writeln('Izmenennie stroki');
for i:=1 to n do writeln(st[i]);
readln;
end.
program Pr1;
{$APPTYPE CONSOLE}
uses
SysUtils;
function kol_sl(x:string; n:integer):integer;
var i,k,kol:integer;
slovo:array[1..30]of string;
begin
kol:=1;k:=0;
for i:=1 to length(x) do
{slovo[kol]:='';}
if x[i]<>' ' then
slovo[kol]:=slovo[kol]+x[i]
else kol:=kol+1;
for i:=1 to kol do
if length (slovo[i])=n then
k:=k+1;
kol_sl:=k;
end;
var a:array[1..30]of string;
s,n,i,k:integer;
begin
{основная программа}
writeln('vvedite kol. strok');
readln(n);
writeln('vvedite stroki');
for i:=1 to n do
readln(a[i]);
writeln('vvedite zadannuy dlinu slov');
readln(k);
s:=0;
for i:=1 to n do
s:=s+kol_sl(a[i],k);
if s=0 then writeln('takix slov net')
else writeln('kol. slov zadannoy dliny =',s );
readln;
end.
Начать зарабатывать