Одномерные массивы. Организация ввода и вывода данных

Колледж Экономики и информационных технологий





















Отчет по учебной практике



Дисциплина: Основы алгоритмизации.



































Выполнила: Гавриляченко Н.

Группа Г-121

                                                                              Проверила: Абилова Ж.М.

















Уральск, 2009



Одномерные массивы. 

Организация ввода и вывода данных



Вариант- 6.

Задание 1.

Организовать ввод и вывод одномерного массива А1..А10 из вещественных чисел с помощью формулы А[i]:=cos(i+2i+1).

program p1;

var a:array [1..10] of integer;

i:integer;

begin

for i:=1 to 10 do a[i]:=cos(sqr(i)+2*i+1)

for i:=1 to 10 do

 writeln ('a[',i,']=',a[i]);

 readln;

 end.





Задание 2.

Напишите программу, которая сначало вводит 15 чисел, складывает отдельно элементы с четными номерами и складывает отдельно нечетные элементы и выдает полученные результаты.



Program p1;

Var a: array [1..15] of integer;

i,j,k,n:integer;

Begin

For i:=1 to 15 do

Read(a[i]);

For i:=1 to 15 do

Write(' ',a[i]);

For i:=1 to 15 do

Begin

If i mod 2=0 then k:=k+a[i];

If i mod 2=1 then n:=n+a[i];

End;

WriteLn('k=',k);

Writeln('n=',n);

Readln;

End.



Задание 3. Организовать одномерный массив из 20 целых чисел. Найти сумму всех квадратных элементов в массиве и вывести на экран.



program p2;

uses crt;

var a:array [1..20] of integer;

    i,s:integer;

begin clrscr;

      writeln ('vvedi 20 chisel');

      for i:=1 to 20 do readln (a[i]);

      for i:=1 to 20 do a[i]:=sqr(i);

      for i:=1 to 20 do writeln ('a[','i',']=',a[i]);

      for i:=1 to 20 do

      s:=s+a[i];

      writeln ('summa vsex kvadratnix elementov=',s);

      readln;

      end.





Задание 4.

Организовать одномерный массив путем заполнения его квадратами чисел от 1 до 10. Найти сумму чисел кратных 3.



Program p4;

Uses crt;

Var a:array[1..10] of integer;

i,s:integer;

Begin

ClrScr;

Writeln('vvedite 10 chisel');

for i:=1 to 10 do Readln (a[i]);

for i:=1 to 10 do a[i]:=Sqr(i);

For i:=1 to 10 do WriteLn('a[',i,']=',a[i]);

For i:=1 to 10 do

if (a[i] mod 3=0) then

s:=s+a[i];

writeln('s=',s);

Readln;

End.



Задание 5.

Организовать одномерный массив из 20 чисел.  Удвоить наибольший и наименьший элементы.



Program p6;

Uses crt;

Var a:array[1..20] of integer;

i,max,min:integer;

Begin

ClrScr;

WriteLn('Vvedite massiv');

For i:=1 to 20 do readln(a[i]);

max:=a[1];

For i:=1 to 20 do If a[i]>max then max:=a[i];

max:=max*2;

min:=a[1];

For i:=1 to 20 do If a[i]<min then min:=a[i];

min:=min*2;

Writeln('Maksimalnij element massiva=',max);

Writeln('Minimalnij element massiva=',min);

Readln; End.



Задание 6.

Организовать массив из 20 чисел. Отсортировать по возрастанию. Вывести массив до и после обработки.



Program sortirovka;

Uses crt;

Var a:array[1..20] of integer;

i,j,b,d:integer;

Begin

ClrScr;

Randomize;

For i:=1 to 20 do a[i]:=random(51);

For i:=1 to 20 do Write('a[',i,']=',a[i]:3);

For j:=1 to 19 do

For i:=1 to 19 do

If a[i]>a[i+1] then

Begin

b:=a[i];

a[i]:=a[i+1];

a[i+1]:=b

End;

For i:=1 to 20 do Write('a[',i,']=',a[i]:3);

Readln;

End.





Задание 7

Организовать одномерный массив из 15 чисел. Первые 7 чисел отсортировать по возрастанию, последние 7 чисел  по возрастанию. Вывести массив до и после обработки.



Program p8;

Uses crt;

Var a:array [1..15] of integer;

i,j,t,b:integer;

Begin

ClrScr;

For i:=1 to 15 do ReadLn(a[i]);

For j:=1 to 7 do

Begin

t:=j;

For i:=j to 7 do

If a[i]<a[t] then

t:=i;

b:=a[t];

a[t]:=a[j];

a[i]:=b; End;

For j:=9 to 15 do

Begin

t:=i;

For i:=j to 15 do

If a[i]<a[t] then

t:=i;  b:=a[t];  a[t]:=a[j];

a[j]:=b; End;

For i:=1 to 15 do

Write(' ',a[i]); End.



Задание 8.

В одномерном массиве целых чисел определить минимальный элемент, заменить его на 0. Стоящие за ним элементы на 6.



Program p2;

Var a: array [1..10] of integer;

i,min,j,t:integer;

begin

Writeln ('vvedite massiv');

For i:=1 to 10 do Readln(a[i]);

For j:=1 to 10 do

begin

min:=a[1];

t:=1;

for i:=2 to 10 do

If a[i] <min: =a[i];

t:=i; End;

a[t]:=0;

for i:=t+1 to 10 do

a[i]:=6;

for i:=1 to 10 do

Writeln('a[',i,']=',a[i]); Readln; End.



Задание 9.

Организовать одномерный массив целых положительных чисел. Найти среднее арифметическое, определить количество элементов, больших этого среднего.

Program p3;

Uses crt;

Var a :array[1..10] of integer;

i,s,n:integer;

sa,sg:real;

Begin

ClrScr;

Writeln ('vvedite massiv');

Begin

For i:=1 to 10 do Readln(a[i]);

End;

For i: =1 to 10 do

s:=s+a[i];

sa:=s/5;

For i:=1 to 10 do

If a[i]>sa then

Begin

n:=n+1;

End;

Writeln ('srednee arifmeticheskoe=', sa:3:2);

Writeln ('V massive',n,'elementov bolshih sred.arifmetich'); Readln; End.



Задание 10.

Организовать массив. Определить среднее арифметическое и геометрическое, сравнить их между собой, если ср. арифметическое>ср. геометрического, то прибавить к каждому элементу массива 2, если ср. геометрическое>ср. арифметического, то умножить на 2.



Program p4;

Uses crt;

Var a :array[1..10] of integer;

c,n:real;

i:integer;

Begin

ClrScr;

Writeln('vvedite massiv');

for i:=1 to 10 do readln(a[i]);

for i:=1 to 10 do

c:=(c+a[i]);

c:=c/10;

for i:=1 to 10 do

n:=sqr(10);

if c>n then for i:=1 to 10 do

a[i]:=a[i]+2 else if n>c then for i:=1 to 10 do a[i]:=a[i]*2;

Writeln('c=',c,' n=',n);

Readln;

End.



Задание 11.

Дан массив 10 целых чисел. Отсортируйте его, найдите в нем контрольное число. Все элементы до контрольного числа замените на противоположные.



Program p5;

Uses crt ;

Var a:array [1..10] of integer;

c,b,i,t,j:integer;

begin

Writeln('vvedite massiv');

For i:=1 to 10 do Readln(a[i]);

For j:=1 to 10 do

Begin

t:=j;

For i:=j to 10 do

If a[i]<a[t] then t:=i;

b:=a[t];

a[t]:=a[j];

a[j]:=b;

End;

Write('vivesti kontrolnoe chislo b=');

readln(b);

c:=0;

For i:=1 to 10 do

if a[i]=b then c:=i;

If c:=0 then

WriteLn('ravnih b net')

else for i:=1 to c-1 do a[i]:=-a[i];

For i:=1 to 10 do write(a[i]:2);

Readln;

End.





Задание 12.

Дан массив, состоящий из 20 символов. Отсортировать его по возрастанию. Ввести 2 числа a и b от 0 до 255. Определить количество элементов, входящие в отрезок [char(a), char(b)].



Program p6;

Uses crt;

Var a:array[1..10] of integer;

i,j,b,t,c,f:integer;

Begin

Writeln('vvedite 20 elemenyov');

for i:=1 to 20 do Readln(a[i]);

for j:=1 to 20 do

Begin

t:=j;

for i:=j to 20 do

if a[i]<a[t] then t:=i;

b:=a[t];

a[t]:=a[j];

a[j]:=b;

End;

writeln('vvedite 2 chisla c<f');

Readln(c,f);

Writeln('elementi vhodyachie v otrezok [c,f]');

for i:=1 to 20 do

if (a[i]>=c) and (a[i]<=f) then write(a[i]:3);

WriteLn;

For i:=1 to 20 do

Write(' ',a[i]);

Readln;

End.





Задание 13.

Дан одномерный массив из 10 целых чисел. Среди элементов массива найти корни квадратного уравнения  x2+5-6=0. Если таковые отсутствуют, то вывести сообщение об этом.

Program P8;

var m:array [1..5] of integer;

   p,  i:integer;

     a,b,c,x1,x2:real;

     D:real;

Begin

    a:=1;

    b:=5;

    c:=-6;

    D:=b*b-4*a*c;

    If D>0 then

       begin

         x1:=(-b+sqrt(D))/(2*a);

         x2:=(-b-sqrt(D))/(2*a);

Writeln('pervii koren yravneniya=',x1:1:1);

Writeln('vtoroi koren yravneniya=',x2:1:1);

    Writeln('Vvedite massiv');

For i:=1 to 5 do Readln(m[i]);  p:=0;

For i:=1 to 5 do

    If x1=m[i] then

       p:=i;

    if p<>0 then Writeln (' ',x1:1:1,' est v massive'); end else

	                      Writeln(' ',x1:1:1,' net v massive');	

For i:=1 to 5 do If x2=m[i] then p:=i;

    if p<>0 then begin  Writeln ('',x2:1:1,' est v massive');end else

                      Writeln(' ',x2:1:1,' net v massive');	

Readln;End.



Вариант 12.

Задание 14.

Дан массив из 10 чисел, отсортируйте его. Найдите в нем контрольное число. Все элементы после контрольного числа заменить на их квадраты.



Рrogram p1;

Uses crt;

Var a:array[1..10] of integer;

c,b,i,j,t:integer;

Begin

ClrScr;

Writeln('vvedite 10 chisel');

For i:=1 to 10 do ReadLn(a[i]);

For j:=1 to 10 do

Begin

t:=j;

for i:=j to 10 do

If a[i]<a[t] then t:=i;

b:=a[t];

a[t]:=a[j];

a[j]:=b;

End;

Write('vvedite kontrolnoe chislo b=');

Readln(b);

a[t]:=0;

for i:=t+1 to 10 do

a[i]:=sqr(a[i]);



For i:=1 to 10 do

if a[i]=b then c:=i;

If c=0 then

Writeln('a[',i,']=',a[i]); Readln; End.

Задание 15.

Напишите программу, которая вводит с клавиатуры 30 целых чисел, определяет среднее арифметическое первых  десяти чисел, вторых десяти и последних десяти. После этого определяется максимальное и минимальное среднее арифметическое и выводится сообщение.

Program p2;

Uses crt;

Var a:array[1..30]of integer;

i,max,min:integer;

s,sa[1],sa[2],sa[3]:real;

Begin

Writeln('vvedite massiv');

for i:=1 to 30 do Readln(a[i]);



Begin

for i:=1 to 10 do

s:=s+a[i];

sa[1]:=s/10;

Writeln('srednee arifmeticheskoe pervih 10 chisel=',sa[1]:2:2);



for i:=11 to 20 do

s:=s+a[i];

sa[2]:=s/10;

Writeln('srednee arifmeticheskoe vtorih 10 chisel=',sa[2]:2:2);



for i:=21 to 30 do

s:=s+a[i];

sa[3]:=s/10;

Writeln('srednee arifmeticheskoe tretih 10 chisel=',sa[3]:2:2);

End;



max:=sa[1];

for i:=1 to 3 do

if sa[i]>max then

Begin

max:=sa[i];

End;



 min:=a[1];

 for i:=1 to 3 do

if sa[i]<min then

Begin

 min:=sa[i];

End;















Двумерные массивы. Организация ввода и  вывода.









Задание 16.

Организовать два массива a[i] и b[i] целых чисел. Окружность задана уравнением (х-1)2+(у+2)2=16. Среди соответствующих пар (a[i], b[i]) вывести те, которые являются координатами внешних точек окружности.



Program p3;

Uses crt;

Var a:array[1..10]of integer;

    b:array[1..10]of integer;

    i:integer;

    x,y:real;

Begin

ClrScr;

Writeln('Vvedite massiv a');

For i:=1 to 10 do Readln(a[i]);

Writeln('Vvedite massiv b');

For i:=1 to 10 do Readln(b[i]);

Writeln(' koordinati vneshnih tochek okrugnosti (x-1)^2+(y+2)^2');

For I:=1 to 10 do

If Sqr(a[i]-1)+Sqr(b[i]+2)>16 then

Writeln('[',a[i],',',b[i],']');

 Readln;

 End.





Задание 17.

Дана функция  Z=6x2+7y. Организовать двумерный массив, значений функции  Z от индексов i, j.

а)Определить максимум, минимум функции;

б) Найти среднее арифметическое.

Program p1;

Uses crt;

Var z:array[1..3,1..3] of integer;

i,j,min,max:integer;

sa,s:real;

Begin

ClrScr;

for i:=1 to 3 do

For j:=1 to 3 do

Begin

z[i,j]:=6*Sqr(i)+7*j;

Writeln('z[',i,',',j,']=',z[i,j]); End;

max:=z[1,1];

for i:=1 to 3 do

For j:=1 to 3 do

If z[i,j]>max then

max:=z[i,j];

writeln('maksimalnoe znachenie=',max);

min:=z[1,1];

for i:=1 to 3 do

For j:=1 to 3 do

If z[i,j]<min then

min:=z[i,j];

writeln('Minimalnoe znachenie=',min);

For i:=1 to 3 do

For j:=1 to 3 do

s:=s+z[i,j];

sa:=s/9;

Writeln('srednee arifmeticheskoe=',sa:2:2);

Readln;

End.



Задание 17.

Дана матрица целых чисел размером 5х6 (random). Отсортировать каждую строку матрицы по возрастанию. Вывести матрицу до и после обработки.



Program p2;

Uses crt;

Var a: array[1..5,1..6] of integer;

i,j,n,t:integer;

Begin

ClrScr;

Randomize;

For i:=1 to 5 do

For j:=1 to 6 do a[i,j]:=random(50);

For i:=1 to 5 do begin

For j:=1 to 6 do Write(a[i,j]:3);

Writeln;

End;

Writeln;

For i:=1 to 5 do

For n:=1 to 5 do

For j:=1 to 5 do

If a[i,j]>a[i,j+1] then

Begin

t:=a[i,j];

a[i,j]:=a[i,j+1];

a[i,j+1]:=t;

End;

For i:=1 to 5 do

Begin

For j:=1 to 6 do

Write(a[i,j]:3);

Writeln;

End;

Readln;

end.





Задание 18.

Дана матрица целых чисел размером 3х5. Заменить все положительные элементы на 5, все отрицательные на 3, все нули на нуль.



Program p3;

Uses crt;

Var a:array[1..3,1..5] of integer;

i,j:integer;

Begin

ClrScr;

Writeln('vvedite elementi massiva');

For i:=1 to 3 do

for j:=1 to 5 do Read(a[i,j]);

For i:=1 to 3 do

For j:=1 to 5 do

Begin



If a[i,j]>0 then a[i,j]:=5;

If a[i,j]<0 then a[i,j]:=3  end;

For i:=1 to 3 do begin

For j:=1 to 5 do

Write(a[i,j]:2);

Writeln;End;

readln;

End.



Задание 19.

Даны две матрицы А и В размером 4х4. Вычислить и вывести на экран матрицу С=А+В. Найти сумму элементов матрицы С, кратных 3, но не кратных 2.



Program p4;

Uses crt;

Var A,B,C:array[1..4,1..4] of integer;

i,j,sum:integer;

begin

ClrScr;

Writeln('vvedite elementi massiva A');

For i:=1 to 4 do

For j:=1 to 4 do Read(A[i,j]);

Writeln('vvedite elementi massiva B');

For i:=1 to 4 do

For j:=1 to 4 do Read(B[i,j]);

Writeln;

For i:=1 to 4 do

For j:=1 to 4 do

C[i,j]:=A[i,j]+B[i,j];

Write('C[i,j]=',C[i,j]);

for i:=1 to 4 do

For j:=1 to 4 do

Writeln(c[i,j]);

for i:=1 to 4 do

 For i:=1 to 4 do

 For j:=1 to 4 do

 If (C[i,j] mod 3=0) and (c[i,j] mod 2<>0)  then

 sum:=sum+c[i,j];

 Writeln('symma elementov matrici C=',sum:2);

 For i:=1 to 4 do

 For j:=1 to 4 do

 Writeln('C[',i,', ',j,']=',C[i,j]); writeln; Readln; End.



Задание 20.

Даны две матрицы А и В. Сравнить матрицы поэлементно. Найти количество элементов матрицы А, больших, чем элементы матрицы В и наоборот. Сравнить  их. Вывести сообщение: А>В или В>А.



Program p5;

Uses crt;

var a,b:array [1..4,1..4] of integer;

i,j,t,k:integer;

Begin

ClrScr;



Writeln('vvedite elementi matrici a');

For i:=1 to 4 do

For j:=1 to 4 do Read(a[i,j]);



Writeln('vvedite elementi massiva b');

For i:=1 to 4 do

For j:=1 to 4 do Read(b[i,j]);

 For i:=1 to 4 do

 For j:=1 to 4 do

 Begin

 If a[i,j]>b[i,j] then t:=t+1;

 If b[i,j]>a[i,j] then k:=k+1;

 end;

 Writeln('t=',t);

 Writeln('k=',k);



 If t>k then Writeln('elementi massiva a bolshe b') else

 Writeln('elementi massiva b bolshe a');

 If t=k then Writeln('elementi massiva a i b ravni');

 Writeln;

 Readln;

 End.



Задание 21.

Организовать двумерный массив (размерность 3х3). Вывести на экран в виде матрицы.



Program p1;

Uses crt;

var a:array[1..3,1..3] of integer;

i,j:integer;

Begin

ClrScr;

Writeln('vvedite elementi matrici: a[',i,' ',j,']');

For i:=1 to 3 do

For j:=1 to 3 do

Readln(a[i,j]);

For i:=1 to 3 do begin

For j:=1 to 3 do

Write(a[i,j]:3);

Writeln;end;

Readln;

End.



Задание 22.

Дана матрица 4х3 целых чисел. Найти сумму элементов, сумма индексов которых является:

а) Четным числом; 

б) Кратно 3.



Program P2;

var a:array[1..4,1..3] of integer;

    i,j,S:integer;

Begin

For i:=1 to 4 do

For j:=1 to 3 do

    read(a[i,j]);

For i:=1 to 4 do

for j:=1 to 3 do

   If (i+j) mod 2 =0 then

   S:=S+a[i,j];

Writeln('Summa elementov,sum  indeksov kot chetnaya=',S);

For i:=1 to 4 do

for j:=1 to 3 do

   if (i+j) mod 3 =0 then

   S:=S+a[i,j];

Writeln('Summa el-v,sum indeksov kratna 3=',S);

Readln;

End.



Задание 23.

Дана матрица вещественных чисел 3х3. Диагональные  элементы матрицы заменить на максимальные.

Program z;

uses crt;

var a:array [1..3,1..3] of integer;

    i,j,max:integer;

begin

clrscr;

    writeln('vvedite massiv');

For i:=1 to 3 do

For j:=1 to 3 do

     readln(a[i,j]);

For i:=1 to 3 do

For j:=1 to 3 do

if a[i,j]>max then max :=a[i,j];

writeln('max=',max);

For i:=1 to 3 do  begin

a[i,i]:=max;

a[i,3+1-i]:=max; end;

for i:=1 to 3 do begin

for j:=1 to 3 do  write(a[i,j]);

    writeln;

end;  readln; end.



Задание 24.

Написать программу, которая вводит по строкам с клавиатуры двумерный массив и вычисляет сумму его элементов: 

а) По столбцам; 

б) По строкам.



Program P4;

var a:array [1..3,1..3] of integer;

    i,j,Sh1,Sh2,Sh3,Sd1,Sd2,Sd3:integer;

Begin

for i:=1 to 3 do

for j:=1 to 3 do read(a[i,j]);

for i:=1 to 3 do begin

    Sd1:=a[i,1]+Sd1;

    Sd2:=a[i,2]+Sd2;

    Sd3:=a[i,3]+Sd3;  end;

for j:=1 to 3 do begin

    Sh1:=a[1,j]+Sh1;

    Sh2:=a[2,j]+Sh2;

    Sh3:=a[3,j]+Sh3; end;

Writeln('Symma 1-i stroki=',Sh1);

Writeln('Symma 2-i stroki=',Sh2);

Writeln('Symma 3-i stroki=',Sh3);

Writeln('Symma 1-go stolbca=',Sd1);

Writeln('Symma 2-go stolbca=',Sd2);

Writeln('Symma 3-go stolbca=',Sd3); readln; End.





Задание 25. 

Организовать двумерный массив (5х5) случайных целых чисел из отрезка [0,60]. Найти минимальный элемент среди элементов, расположенных выше главной диагонали.



Program P5;

var a:array [1..5,1..5] of integer;

    i,j,min:integer;

Begin

randomize;

For i:=1 to 5 do

For j:=1 to 5 do a[i,j]:=random(61);

Writeln('Matrica do obrabotki');

For i:=1 to 5 do     begin

For j:=1 to 5 do write(a[i,j]:5); writeln;end;

min:=a[1,5];

For i:=1 to 5 do

For j:=1 to 5 do

    if (i<j) and (a[i,j]<min) then   min:=a[i,j];

Writeln('Minimym=',min);

Readln;

end.





Организация подпрограмм с помощью функций.

Задание 26.

Написать функцию, которая вычисляет объем цилиндра. Параметрами функции должны быть радиус и высота цилиндра.



Program p1;

Var H,R,O:Real;

function Obem(R,H:real):real;

Begin

Obem:=Pi*Sqr(R)*H;

End;

Begin

Writeln('vvedite R i H');

Readln(R,H);

O:=obem(R,H);

Writeln('Obem=',O:2:2);

Readln;

End.



Задание 27.

Написать фукцию, возвращающую:

  а) минимальное среди двух;

  б) максимальное среди двух;

Program p2;

Uses crt;

Var  a,b:integer;

min,max:integer;

Function maximum(a,b:integer):integer;

Begin

ClrScr;

if a>b then maximum:=a

else maximum:=b;

End;

Function minimum(a,b:integer):integer;

Begin

if a<b then minimum:=a

else minimum:=b;

End;

Begin

Read(a,b);

max:=maximum(a,b);

min:=minimum(a,b);

Write('mininimum=',min);

Write('maximum=',max); End.



Задание 28.

Написать функцию нахождения дискриминанта уравнения и определяющая количество корней (т.е. принимает значения: 0,1, 2).



Program Z3;

var a,b,c:integer;

Function D(a,b,c:integer):integer;

Begin

if Sqr(b)-4*a*c>0 then D:=2;

If Sqr(b)-4*a*c=0 then D:=1;

If Sqr(b)-4*a*c<0 then D:=0;

end;

Begin

Writeln('Vvedite a,b,c');

Readln(a,b,c);

Writeln('Yravnenie imeet' ,D(a,b,c),' kornei' );

Readln;

end.



Задание 29.

Написать функцию нахождения общего сопротивления при параллельном соединении двух проводников.

Rобщ.= 





Program Z4;

var R1,R2,rez:real;

function Sopr(R1,R2:real):real;

Begin

   Sopr:=1/R1+1/R2;

End;

Begin

Writeln('Vvedite R1 i R2');

Readln(R1,R2);

rez:=Sopr(R1,R2);

Writeln('Soprotivlenie=',Sopr(R1,R2):2:2);

Readln;

End.





Задание 30.

Написать функцию,  вычисляющую процент от числа. Параметры- число и процент.



Program Z5;

var N,P,rez:real;

function Procent (N,P:real):real;

Begin

    Procent:=(N*P)/100;

End;

begin

Writeln('Vvedite chislo i procent');

Readln(N,P);

rez:=Procent(N,P);

Writeln('Procent=',Procent(N,P):2:2);

Readln;

End.



Вариант-9.

Задание 31.

Даны три стороны треугольника. Написать функцию нахождения площади вписанной в треугольник окружности.



Program z1;

Var o,a,b,c,S,r,p:real;

Function Ploschad(a,b,c:real):real;

var p,s:real;

Begin

p:=(a+b+c)/2;

S:=Sqrt(p*(p-a)*(p-b)*(p-c));

r:=(2*S)/(a+b+c);

ploschad:=Pi*Sqr(r);

End;

Begin

Writeln('vvedite tri storoni treygolnika');

readln(a,b,c);

O:=Ploschad(a,b,c);

Writeln('ploschad ravna=',O:2:2);

Readln;

End.



Задание 32.

Написать функцию нахождения начальной скорости по конечной скорости, по времени изменения скорости, по ускорению.



Program p2;

Var v,v0,t,a:Real;

Function Skorost(v,v0,a:real):real;

Begin

Skorost:=v-a*t;

End;

Begin

Writeln('vvedite konech.skorost, vremya i yskorenie');

Readln(a,t,v);

v0:=Skorost(a,t,v);

Writeln('Nachalnaya skorost ravna=',v0:4:2);

Readln;

End.



Задание 33.

Написать программу, которая вычисляет квадратный корень произведения трех вещественных чисел, введенных с клавиатуры.



Program z3;

Var kor,a,b,c:real;

Function Koren(a,b,c:real):Real;

Begin

Koren:=Sqrt(a*b*c);

End;

Begin

Writeln('vvedite tri chisla');

Readln(a,b,c);

Kor:=Koren(a,b,c);

Writeln('koren chisel raven=',kor:2:2);

Readln;

End.



Задание 34.

Написать функцию, которая вычисляет значение выражения от аргументов a и b. tg(a)+ctg(b).



 Program p4;

Var arg,a,b:real;

Function Argymenti(a,b:real):real;

Begin

Argymenti:=sin(a)/cos(a)+cos(b)/sin(b);

End;

Begin

Writeln('vvedite dva chisla');

Readln(a,b);

Arg:=Argymenti(a,b);

Writeln('Znachenie virazheniya ravno=',Arg:2:2);

Readln;

End.



Задание 35.

Написать функцию, определяющую среднее арифметическое среди элементов в массиве.



Program p5;

uses crt;

Var a:array[1..4] of real;

i:integer;

sa:real;

Function Srednee(var a:array of real):real;

Var sum:real;

Begin

For i:=0 to 3 do

Sum:=sum+a[i];

Srednee:=sum/4;

End;

Begin

ClrScr;

Writeln('vvedite massiv');

For i:=1 to 4 do

Readln(a[i]);

sa:=Srednee(a);

Writeln('srednee arifmeticheskoe=',sa:4:2);

Readln;

End.





              Организация подпрограмм с помощью процедур.



Задание 36

Даны две точки с координатами (х1, х2), (у1,у2). Найти длину отрезка.

а) без параметра



Procedure dlina;

Var x1,x2,y1,y2:integer;

d:real;

Begin

Writeln('vvedite koordinati');

Write('x1='); readln(x1);

Write('x2='); readln(x2);

Write('y1='); readln(y1);

Write('y2='); readln(y2);

d:=Sqrt(sqr(x1-x2)+sqr(y1-y2));

Writeln('dlina=',d);

End;

Begin

Dlina;

Readln;

End.



б) с параметром

Program p2;

Procedure dlina(x1,x2,y1,y2:integer);

      Var d:real;

begin

d:=Sqrt(Sqr(x1-x2)+sqr(y1-y2));

Writeln(dlina=',d:2:2);

end;

begin

Writeln('vvedite koordinati');

Write('x1='); Readln(x1);

Write('x2='); Readln(x2);

Write('y1='); readln(y1);

write('y2='); Readln(y2);

Dlina(x1,x2,y1,y2);

Readln;

End.













Вариант-9



Задание 37.

Найдите x из пропорции .

Program p1;

    Var a,b,c:real;

Procedure proporciya(a,b,c:real);

    Var x:real;

    Begin

x:=((a+b)*(a+c))/(b-c);

Writeln('proporciya=',x:2:2);

End;

Begin

Writeln('vvedite znacheniya a,b,c');

Readln(a,b,c);

Proporciya(a,b,c);

Readln;

End.



Задание 38.

Даны координаты вершин треугольника. Найти его периметр.



Program p6;

Var x1,y1,x2,y2,x3,y3:real;

Procedure Perimetr(x1,y1,x2,y2,x3,y3:real);

Var P,d1,d2,d3:real;

Begin

d1:=Sqrt(sqr(x1-x2)+sqr(y1-y2));

Writeln('dlina1=',d1:2:2);

d2:=Sqrt(sqr(x2-x3)+sqr(y2-y3));

Writeln('dlina2=',d2:2:2);

d3:=Sqrt(sqr(x1-x3)+sqr(y1-y3));

Writeln('dlina3=',d3:2:2);

If (d1+d2>d3) and (d2+d3>d1) and (d1+d3>d2) then

P:=d1+d2+d3 else

Writeln('Takogo treygolnika ne sychestvyet');

Writeln('Perimetr=',P:2:2);

End;

Begin

Writeln('vvedite koordinati');

Write('x1='); Readln(x1);

Write('x2='); Readln(x2);

Write('x3='); Readln(x3);

Write('y1='); Readln(y1);

Write('y2='); Readln(y2);

Write('y3='); Readln(y3);

Perimetr(x1,y1,x2,y2,x3,y3);

Readln;

End.



Задание 39.

Определить среднесуточную температуру,  если показания термометра: утром-no C, вечером- ko C, днем- mo C.



Program p3;

Var n,k,m:real;

Procedure Temperatyra(n,k,m:real);

Var sst:real;

Begin

sst:=(n+k+m)/3;

Writeln('Temperatyra=',sst:2:2);

End;

Begin

Writeln('vvedite pokazaniya termometra ytrom,vecherom i dnem');

Readln(n,k,m);

Temperatyra(n,k,m);

readln;

End.



Задание 40.

За какое время пешеход доберется до соседнего города, если его скорость равна V(км/ч), а расстояние- S(км).



Program p2;

Var S,v:real;

Procedure Vremya(s,v:real);

Var t:real;

Begin

t:=s/v;

Writeln('Vremya=',t:2:2);

End;

Begin

Writeln('vvedite skorost i rasstoyanie');

readln(s,v);

Vremya(s,v);

Readln;

End.



Задание 41.

Найти площадь круга S, вписанного в квадрат со стороной a.



Program  p5;

Var a:real;

Procedure Ploschad(a:real);

Var s:real;

Begin

S:=pi*sqr(a/2);

Writeln('ploschad=',s:2:2);

End;

Begin

Writeln('vvedite dliny storoni a');

Readln(a);

Ploschad(a); Readln; End.

Задание 42.

Найти значение выражения y= (a+b+c)2 .



Program p4;

Var a,b,c,d:real;

Procedure Virazhenie(a,b,c,d:real);

Var y:real;

Begin

d:=3;

a:=2*d;

b:=3*d;

c:=d/2;

y:=sqr(a+b+c);

Writeln('Virazhenie=',y:2:2);

End;

Begin

Virazhenie(a,b,c,d);

Readln;

End.





Вариант- 5.

	

	Задание 43.

	Дан одномерный массив. Найти и вывести на экран значения и номера элементов не превосходящих контрольное число. Оформить процедурой.

	Program p2;

	Var a:array[1..5]  of integer; i,n:integer;

	Procedure Massiv(a:array of integer;n:integer);

	Var i:integer;

	begin

	for i:=0 to 5 do

	If a[i]<=n then   begin

	Writeln('a[',i,']=' ,a[i]);

	end;end;

	Begin

	Writeln('vvedite kontrolnoe chislo');

	Readln(n);

	Writeln('vvedite massiv');

	For i:=1 to 5 do

	Readln(a[i]);

	Massiv(a,n);

	Readln;

	End.

	

	Задание 44.

	Дана функция y=ax3+bx2+cx+d. Вывести в виде таблицы значения функции на отрезке [-k,k]. Вычисления оформить функцией y(a,b,c,d,k).

	

	Program p3;

	Var a,b,c,d,y:real;

	x,k:integer;

	Function Tablica(a,b,c,d:real; x:integer):real;

	Begin

	Tablica:=a*x*x*x+b*sqr(x)+c*x+d;

	End;

	Begin

	Writeln('vvedite znacheniya fynccii');

	Readln(a,b,c,d,k);

	For x:=-k to k do

	begin

	y:=Tablica(a,b,c,d,x);

	Writeln('y=',y:2:2);

	End;

	Readln;

	End.

	

	Задание 45.

	Даны 4 числа a,b,c,d. Найти объемы параллелепипедов на отрезках  a,b,c,d. Среди объемов найти наименьший. Вычисление объемов оформить функцией V(a,b,c).

	

	Program p4;

	Var  v:array[1..4] of integer;

	    min,i, a,b,c,d,v1,v2,v3,v4:integer;

	Function Obem(a,b,c,d:integer):integer;

	Begin

	obem:=a*b*c;

	end;

	Begin

	Writeln('vvedite znacheniya peremennih');

	readln(a,b,c,d);

	v[1]:=obem(a,b,c,d);

	v[2]:=obem(d,c,b,a);

	v[3]:=obem(b,a,d,c);

	v[4]:=obem(c,d,a,b);

	for i:=1 to 4 do Writeln('obem',i,'parallelepipeda=',v[i]:2);

	min:=v[1];

	for i:=1 to 4 do

	if v[i]<min then

	min:=v[i];

	writeln('min=',min);

	Readln;

	End.

	Комбинированный тип.

	Объявление записи.

	Задание 46.

	Дан список учащихся из 10 записей. Каждая запись имеет поле фамилия, имя, номер класса, буква.

	 а) Найти однофамильцев из одного класса;

	 б) Найти двух учащихся тезок.



Program z;

type ycheniki=record

fam:string[15];

imya:string[10];

class:record

bykva:char;

god:integer;

end;

end;

var spisok:array [1..6] of ycheniki;

    i,j:integer;

begin

   for i:=1 to 6 do begin

      with spisok[i] do begin

   writeln('vvedite familiu ychenika',i);

   readln(fam);

   writeln('vvedite imya',i);

   readln(imya);

   writeln('vvedite ego klass',i);

   readln(class.god);

   writeln('vvedite bykvy klassa');

   readln(class.bykva);

   end;end;

   writeln;

writeln('spisok odnofamilcev v odnom klasse:');

   for i:=1 to 5 do

   for j:=i+1 to 6 do

      if (spisok[i].fam=spisok[j]. fam) and

         (spisok[i].class.god=spisok[j].class.god)

     and (spisok[i].class.bykva=spisok[j].class.bykva)

then writeln(spisok[j].fam, ' ',spisok[i].imya, ' ',

             spisok[i].class.god.bykva,' ',

            spisok[j].imya, ' ',spisok[j].class.god.bykva);

writeln('Ychashiesya tezki:');

   for i:=1 to 5 do

   for j:=i+1 to 6 do

       if (Spisok[i].fam=spisok[j].fam)and(spisok[i].imya=spisok[j].imya)

then

    writeln(spisok[j].fam, ' ', spisok[i].imya, ' ',spisok[i].class.god.bykva,' ',

            spisok[j].imya, ' ', spisok[j].class.god.bykva);

writeln('Spisok ychashixsya s odinakovoi bykvoi klassa:');

   for i:=1 to 5 do

   for j:=i+1 to 6 do

       if spisok[i].class.bykva=spisok[j].class.bykva

then

    writeln(spisok[i].fam, ' ',spisok[i].imya, ' ',spisok[i].class.god, ' ',

           (spisok[j].fam, ' ',spisok[j].imya, ' ',spisok[j].class.god);

readln;





Задание 47. 

Написать программу, выдающую сведения об ассортименте игрушек в магазине. Структура записи: название игрушки, цена, количество, возрастные границы.

      А)вывести названия игрушек, которые подходят детям до 3 лет;

      Б)самая дорогая игрушка;

      В)название игрушки, которая по стоимости не превышает х тг и подходит ребенку в возрасте до а лет.



Program Assortiment;

type Igryshki=record

name:string[15];

cena:integer;

kol:integer;

vozr:integer;

end;

var Magazin:array [1..6] of Igryshki;

    i,j,max,x,a,b:integer;

Begin

    for i:=1 to 6 do begin

        with igryshki[i] do begin

writeln('Vvedite nazvanie  igryshki',i);

readln(name);

writeln('Cena:');

readln(cena);

writeln('Kolichestvo:');

readln(kol);

writeln('Vozrastnie granici:');

readln(vozr);

end;end;

Writeln;

Writeln('Samaya dorogaya igryshka:');

     max:=igryshki[1].cena;

    For i:=1 to 6 do

        if igryshki[i].cena>max then begin

        max:=igryshki[i].cena;

Writeln(igryshki[i].name, ' ', max); end;

Writeln('Igryshki dlya detei v vozraste 3 let:');

     For i:=1 to 6 do

        if igryshki[i].vozr=3 then begin

Writeln(igryshki[i].name, ' stoimostu  ',igryshki[i].cena, 'tg'); end;

writeln('vvedite stoimost');

readln(x);

 For i:=1 to 6 do

     if (igryshki[i].cena<x)  then  begin

writeln('Igryshki ' ,igryshki[i].name, 'stoimostu ' ,igryshki[i].cena,' ne previshaut ',x,' tg' );  end;

writeln('vvedite vozrast ');

readln(a);

   For i:=1 to 6 do

      if igryshki[i].vozr=a then begin

writeln(igryshki[i].name , 'podxodyat dlya vozrasta' , igryshki[i].vozr);      end;

readln;

end.



	

	

	

	

	Задание 48.

	Список книг состоит из 10 записей:

	Поля: Фамилия автора;

	           Название книги;

	           Год издания;

	           Количество страниц;

	а) Найти название книг данного автора, изданных с 1960 года.

	б) Определить имеются ли книги с названием «Информатика», если да, то сообщить фамилию авторов, год издания и количество страниц.

	в) Вывести название книг и их авторов, если количество страниц превосходит среднее количество страниц по всему списку.

	

	PROGRAM P1;

	Type knigi=record

	     fam:string;

	     name:string;

	     page:integer;

	     god:integer;

	End;

	Var Spisok:array[1..5] of knigi;

	    i,o,summa:integer; m:string;

	    Sr:real;

	Begin

	For i:=1 to 5 do

	Begin

	With Spisok[i] do

	Begin

	    Writeln('Vvedite familiu avtora', i);

	Readln(fam);

	    Writeln('Vvedite nazvanie knigi', i);

	Readln(name);

	    Writeln('vvedite god izdaniya');

	Readln(god);

	    Writeln('Vvedite kolichestvo stranic');

	

	Readln(page);

	End;

	End;

	Writeln;

	Writeln('Spisok knig  izdannih s 1960 goda');

	Writeln('Vvedite imya avtora');

	Readln(m);

	    For i:=1 to 5 do

	If (m=spisok[i].fam) and (spisok[i].god>=1960) then

	Writeln(spisok[i].fam,' ',spisok[i].name,' ',spisok[i].god);

	

	Writeln('Imeutsya li knigi s nazvaniem "Informatika"?');

	For i:=1 to 5 do

	begin

	If spisok[i].name='Informatika' then

	Writeln(Spisok[i].fam,' ',spisok[i].god,' ',spisok[i].page); o:=o+1 end;

	if o=0 then Writeln('Takih knig net');

	Summa:=0;

	For i:=1 to 5 do

	Summa:=Summa+Spisok[i].page;

	Sr:=Summa/5;

	Writeln('Srednee kolichestvo stranic=',Sr:2:2);

	For i:=1 to 5 do

	If Spisok[i].page>Sr THEN

	Writeln('Stranici prevoshodyawie srednee kolichestvo stranic po spisky ',Spisok[i].fam,' ',Spisok[i].name);

	Readln;

	End.

	

	Файловая переменная.

	Типизированные файлы.

	

	Задание 49.

	а) Организовать файл CHISLA.dat с целыми числами.

	

	Program p1;

	Var f:file of integer;

	    n,i,c:integer;

	Begin

	Writeln('sozdat fail iz celih chisel');

	Assign (f,'c:\ucheba\CHISLA.dat');

	Rewrite(f);

	Readln(n);

	For i:=1 to n do

	Begin

	Read(c);

	Write(f,c);

	End;

	End.

	

	б) Составить программу, подсчитывающую количество элементов в файле, их сумму, среднее арифметическое.

	

	program p3;

	var

	   f:file of integer;

	   i,n,s:integer;

	   elem,k:integer;   sum:integer;sa:real;

	 begin

	   assign(f,'c:\ucheba\kolichestvo.txt');

	   reset(f);

	   sum:=0;   k:=0;

	   while not eof (f) do

	  begin

	   read(f,elem);  k:=k+1;

	       sum:=sum+elem;

	     end;

	   writeln('summa elementov=',sum);

	   sa:=sum/k;

	   writeln('sa=',sa:4:2);

	   readln;

	    end.

	

	Вариант 4в.

	Задание 50.

	Организовать символьный файл f из  N компонент. После этого организовать файл g, содержащий все компоненты файла f в обратном порядке. Вывести содержимое файлов на экран.

	

	Program p1;

	Var f,g:file of char;

	n,i:integer;

	c:char;

	a:array[1..10] of char;

	Begin

	Assign(f,'c:\ucheba\Simvoli.txt');

	Rewrite(f);

	Writeln('Vvedite kolichestvo komponent ');

	Readln(n); writeln;

	writeln('vvedite komponenti');

	For i:=1 to n do

	Begin

	Readln(c);

	Write(f,c);

	End;

	Close(f);

	Reset(f);

	

	Assign(g,'c:\ucheba\Simvol_.txt');

	Rewrite(g);

	i:=1;

	While not eof (f) do

	Begin

	read(f,c);

	a[i]:=c;

	i:=i+1;

	end;

	for i:=n downto 1 do

	Write(g,a[i]);

	Close(f);

	Close(g);

	Reset(g);

	Writeln('simvoli faila g');

	While not eof(g) do

	Begin

	Read(g,c);

	Writeln(c,' ');

	End;

	Close(g);

	Readln;End.

	Задание 51.

	Организовать файл символов из N компонент. Определить символ, встречающийся в файле наиболее часто. Вывести на экр ан этот символ и его количество в файле.

 

Program z3;

var f:file of char;

    i,n,k,j,max:integer;

    c:char;

    a:array [1..100] of char;

    s:array [1..100] of integer;

Begin

writeln('Sozdat fail iz simvolov');

assign(f,'c:\docume~1\3193~1\0016~1\ucheba\baza4.txt');

rewrite(f);

writeln('vvesti kolichestvo komponentov');

readln(n);

for i:=1 to n do

    begin

    readln(c);

    write(f,c);

    end;

close(f);

reset(f);

i:=1;

while not eof(f) do

   begin

   read(f,c);

   a[i]:=c;

   i:=i+1;

   end;

for k:=1 to i do S[k]:=1;

for k:=1 to i do

for j:=k+1 to i do

    if a[k]=a[j] then s[k]:=s[k]+1;

max:=s[1];

n:=1;

for k:=1 to i do

    if max<s[k] then begin

        max:=s[k];n:=k;end;

for k:=1 to i do

    if s[k]=max then

    writeln('simvol ', a[n],' vstrechaetsya ',n,' raz');

readln;end

.

	Задание 52.

	Напишите программу организующую хранение в файле нескольких записей (до 10) о результатах экзамена. Каждая запись содержит 3 поля: номер записи, фамилия, оценка. Организуйте вывод всей информации по форме: {1 Иванов 3}

	

Program Z1;

type ekzamen=record

n:integer;

fam:string [15];

oc:integer;

end;

var baza1:file of ekzamen;

    rez:array  [1..10] of ekzamen;

    i:integer;  y:integer;f:string[100];

begin

write('vvedite chislo ychenikov');readln(y);

f:='c:\docume~1\3193~1\0016~1\ucheba\baza1.txt';assign(baza1,f);rewrite(baza1);

    for i:=1 to 10 do begin

       with rez[i] do begin

Writeln('Familiya');

readln(fam);

Writeln('Ocenka');

readln(oc);

end;end;

writeln;

reset(baza1);

Writeln('Rezyltati ekzamena:');

for i:=1 to 10 do

Writeln(i,' ', rez[i].fam, ' ', rez[i].oc);

Readln;end.

	

	

	

	Текстовые файлы.

	 Задание 53

	Организовать файл из N строк (текстовый) text.txt.

	

	Program p1;

	Uses Crt;

	Var f:text;

	i,n:integer;

	c:string;

	Begin

	ClrScr;

	Writeln('sozdanie tekstovogo faila ');

	Writeln('vvedite kolichestvi strok');

	Readln(n);

	Assign(f,'c:\ucheba\text.txt');

	Rewrite(f);

	For i:=1 to n do

	Begin

	Readln(c);

	Writeln(f,c);

	End;

	Close(f);

	Readln;

	End.

	 

	

	

	Задание 54

	Подсчитать среднюю длину строк из файла text.txt.

	Program p2;

	Uses crt;

	Var f:text;

	i,n,d:integer;

	c:string;

	Sa:real;

	Begin

	ClrScr;

	Writeln('Nahozhdenie srednej dlini stroki');

	Writeln;

	Assign(f,'c:\ucheba\text.txt');

	Reset(f);

	d:=0;

	While not eof(f) do

	begin

	Readln(f,c);

	n:=n+1;

	d:=d+length(c);

	End;

	Sa:=d/n;

	Writeln('srednee arifmeticheskoe=',sa:4:2);

	Repeat Until Keypressed;

	End.

	

	Задание 55

	Удалить из текстового файла все пробелы(delete (St, n, 1).

	St - строка, n- позиция, 1-количество удаляемых символов.

	

	Program p3;

	Var f:text;

	 i,n:integer;

	 c:string;

	 Begin

	Assign(f,'c:\ucheba\text.txt');

	Reset(f);

	While not eof(f) do

	Begin

	Readln(f,c);

	for i:=1 to length(c) do

	if c[i]=' ' then delete(c,i,1);

	Writeln('Vivod faila bez probelov:',c);

	End;

	Readln;

	End.

	

	Задание 56

	В текстовом файле text.txt определить максимальную длину строки.

	

	Program p2;

	Uses crt;

	Var f:text;

	i,n,max:integer;

	c:string;

	a:array[1..100] of integer;

	Begin

	ClrScr;

	Assign(f,'c:\ucheba\text.txt');

	Reset(f);

	i:=1;

	While not eof(f) do

	Begin

	Readln(f,c);

	a[i]:=length(c);

	i:=i+1;

	End;

	n:=i;

	max:=a[1];

	for i:=1 to n do

	Begin

	If a[i]>max then max:=a[i]; end;

	Writeln('maksimalnaya dlina stroki=',max);

	End.

	

	Задание 57

	Строки из файла  text.txt разбить на части нечетные по счету строки. Записать в файл text.txt, четные- в text2.txt

	Program p5;

	Uses crt;

	var f,g,h:text;

	c:string;

	i,n:integer;

	Begin

	ClrScr;

	Writeln('Sortirovka strok faila na chetnie i nechetnie');

	Writeln;

	Assign(f,'c:\ucheba\text.txt');

	Reset(f);

	Assign(g,'c:\ucheba\text1.txt');

	Rewrite(g);

	Assign(h,'c:\ucheba\text2.txt');

	Rewrite(h);

	i:=0;

	While not eof(f) do

	Begin

	Readln(f,c);

	i:=i+1;

	If(i mod 2)=0 then

	Writeln(g,c) else

	Writeln(h,c);

	End;

	Close(h); Close(g); End.