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.