Другое: Готовые решённые задачи в формате ТХТ

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.