Колледж Экономики и информационных технологий
Отчет по учебной практике
Дисциплина: Основы алгоритмизации.
Выполнила: Гавриляченко Н.
Группа Г-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. Если таковые отсутствуют, то вывести сообщение об этом.
ProgramP8;
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]. Найти минимальный элемент среди элементов, расположенных выше главной диагонали.
ProgramP5;
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 из пропорции  .
Programp1;
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
Programp5;
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.
|