write('Введите код ',i,'-го города: ');
readln(tel.kod);
write('Введите общее время разговора с городом ',tel.kod,' за 1-й месяц: ');
readln(tel.tpm1);
write('Введите стоимость одной минуты разговора с городом ',tel.kod,' в 1-м месяце: ');
readln(tel.price1);
write('Введите общее время разговора с городом ',tel.kod,' за 2-й месяц: ');
readln(tel.tpm2);
write('Введите стоимость одной минуты разговора с городом ',tel.kod,' в 2-м месяце: ');
readln(tel.price2);
write('Введите общее время разговора с городом ',tel.kod,' за 3-й месяц: ');
readln(tel.tpm3);
write('Введите стоимость одной минуты разговора с городом ',tel.kod,' в 3-м месяце: ');
readln(tel.price3);
write(a,tel);
end;
close(a);reset(a);
s:=1;
while not eof(a) do begin
read(a,tel);
res[s].kod:=tel.kod;
res[s].tpm:=tel.tpm1+tel.tpm2+tel.tpm3;
res[s].pr1:=tel.tpm1*tel.price1;
res[s].pr2:=tel.tpm2*tel.price2;
res[s].pr3:=tel.tpm3*tel.price3;
res[s].ob:=res[s].pr1+res[s].pr2+res[s].pr3;
s:=s+1;
end;close(a);
clrscr;
writeln('Код города Общее время разговора за каждый месяц Стоимость минуты разговора');
reset(a);
while not eof(a) do
begin
read(a,tel);
writeln(' ',tel.tpm1,' ',tel.price1);
writeln(' ',tel.kod,' ',tel.tpm2,' ',tel.price2);
writeln(' ',tel.tpm3,' ',tel.price3);
end;
textcolor(14);
gotoxy(18,24);
writeln('Для продолжения работы программы нажмите ENTER');
readln;
clrscr;
textcolor(0);
writeln('Код города Общее время разговора за квартал Плата за месяц Общая плата');
for i:=1 to 7 do
begin
aa:=res[i].kod;
writeln(' ',res[i].pr1);
writeln(' ',aa,' ',res[i].tpm,' ',res[i].pr2,' ',res[i].ob);
writeln(' ',res[i].pr3);
end;
max:=res[1].ob;
for i:=1 to 6 do begin
if res[i+1].ob>max then
begin
max:=res[i+1].ob;
j:=i+1;
end;
end;
writeln('Город с наибольшей платой: ',res[j].kod);
textcolor(14);
gotoxy(18,24);
writeln('Для завершения работы программы нажмите ENTER');
readln;
end.
Задание 5 Упорядочить список студентов по среднему балу и распечатать его
Program spisok_grupp;
Uses Crt;
Const kurs=3;
Const kol=5;
Type
sved=record
famil:string[25];
datar:string[8];
god: integer;
gruppa: integer;
ocenki:array[1..3,1..5] of integer;
srball:array[1..25] of real;
End;
Var
spisok: array[1..25] of sved;
i,i1,j, s,mesto,n,g:integer;
max,t:real;
q:string[25];
Begin
ClrScr;
writeln('Введите количество учеников');
readln(n);
for i:=1 to n do
With spisok[i] do
Begin
Writeln ('Фамилия ',i,' студента');
Readln (famil);
Writeln('Дата рождения');
Readln (datar);
Writeln ('Год поступления');
Readln (god);
Writeln ('Группа');
Readln (gruppa);
s:=0;
for i1:=1 to kurs do
begin
writeln('Оценки ',i1,' года');
for j:=1 to kol do
Begin
Writeln (j,' Предмет');
Readln (ocenki[i1,j]);
s:=s+ocenki[i1,j];
End;
end;
srball[i]:=s/(kol*kurs);
ClrScr;
End;
writeln('Фамилия':8,'Дата рождения':16,'Год поступления':18,'Курс':7,'Группа':8);
for i:=1 to n do
begin
with spisok[i] do write(famil:8,datar:16,god:18,kurs:7,gruppa:8);
writeln;
writeln;
for g:=1 to kurs do
begin
write(g,' год:');
for j:=1 to kol do
with spisok[i] do write(ocenki[g,j]:4);
writeln;
end;
with spisok[i] do writeln('Средний бал =',srball[i]:6:2);
writeln;
end;
writeln;
writeln('По порядку');
for j:=1 to n do
Begin
max:=spisok[j].srball[j];
mesto:=j;
for i:=j to n do
if spisok[i].srball[i]<=max then
Begin
max:=spisok[i].srball[i];
mesto:=i;
End;
t:=spisok[j].srball[j];
spisok[j].srball[j]:=spisok[mesto].srball[mesto];
spisok[mesto].srball[mesto]:=t;
q:=spisok[j].famil;
spisok[j].famil:=spisok[mesto].famil;
spisok[mesto].famil:=q;
with spisok[j] do writeln(famil:8,srball[j]:6:2);
End;
End.
Задание 6. Запись с вариантами
var R = Record
rem: string;
Case byte of
3: (n:integer);
5: (x,y,z:char);
'a': (i,j:byte);
end;
begin
R.rem:='запись с ваpиантами';
R.n:=25000;
write(R.i,R.x,R.j,R.y); {168и97a}
{ord('и')=168, ord('a')=97, 168+97*256=25000}
end.
Задание 7. Пример объявления типа запись
type Men = Record
FIO,Adress: string;
Year: byte;
End;
var A,B: Men;
begin
A.FIO:='Иванов И.И.';
A.Adress:='пp. Ленина, д. 40, кв. 10';
A.Year:=1981;
end.
Задание 8. Составить программу в которой известны Фамилия, адрес и номера Телефонов 15 человек, организовать поиск номера телефона по фамилии абонента
Program as;
Type
person=record
surname: string[40]
adres: string[20]
nomer: integer
var
mas:array[1..15] of person;
i:integer; poisk: string;
procedure Input.date;
var
begin
writeln(‘Введи данные’,I,’ абонента’);
writeln(‘Фамилия’);
readln(mas[i].surname);
writeln(‘адрес’);
readln(mas[i].adres);
writeln(‘Номер телефона’);
readln(mas[i].nomer);
end;
Procedure write date;
Begin
With mas[i] do
Begin
Writeln(‘фамилия’,surname);
Writeln(‘адрес’,adres);
Writeln(‘номер’,nomer);
End;
End;
Begin
For i:=1 to 15 do Input.date;
Writeln(‘Введи фамилию абонента’);
Readln(poisk);
For i:=1 to 15 do
If mas[i] nomer=poisk then write date;
End.
Задание 9. Создать список учеников класса и вывести на экран Фамилии и Имена в виде таблицы
Program as;
Uses crt;
Type
Klass=record
Surname:string[15];
Name:string[10];
End;
Var A:array [1..10] of klass;
I:integer;
Begin clrscr;
For i:=1 to 10 do begin
Writeln(‘введи фамилию’);
Readln(a[i].surname);
Writeln(‘введи имя’);
Readln(a[i].name);
End;
Writeln;
Clrscr;
For i:=1 to 10 do writeln(a[i].surname,’ ‘,a[i].name);
End.
Задание10. Известны данные о 6 сотрудниках фирмы Фамилия, возраст, и отношение к воен.службе. Вывести на экран фамилии всех военнообязанных сотрудников
Program as;
Uses crt;
Type
S=record
N:string[10]; voz:integer;
V:string[8];
End;
Var a:array[1..6] of s;
I:integer;
Begin clrscr;
For i:=1 to 6 do begin
Writeln(‘какая у тебя фамилия’);
Readln(a[i].s);
Writeln(‘сколько тебе лет’);
Readln(a[i].voz);
Writeln(‘ты относешся к военной части’);
Readln(a[i].v);
End; Writeln; Clrscr;
For i:=1 to 6 do if a[i].v=’DA’ then writeln(a[i].s);
End.
Задание11. Даны названия 6 городов и стран, среди них есть город находящийся в Италии напечатать их название
Program as;
Uses crt;
Type
S=record
strana: string[10];
gorod:string[8];
End;
Var a:array[1..6] of s;
I:integer;
Begin clrscr;
For i:=1 to 6 do begin
Writeln(‘страна?’);
Readln(a[i].strana);
Writeln(‘город’);
Readln(a[i]. gorod);
End; Writeln; Clrscr;
For i:=1 to 6 do if a[i]. strana =’italia’ then writeln(a[i].gorod);
End.
Задание12. Даны названия 10 стран и частей света. Напечатать на экране все страны находящиеся в Азии
Program as;
Uses crt;
Type
S=record
strana: string[10];
ch:string[8];
End;
Var a:array[1..10] of s;
I:integer;
Begin clrscr;
For i:=1 to 10 do begin
Writeln(‘страна’);
Readln(a[i].strana);
Writeln(‘часть света’);
Readln(a[i]. ch);
End; Writeln; Clrscr;
For i:=1 to 10 do if a[i]. ch =’Azia’ then writeln(a[i]. strana);
End.
Задание13. Из ведомости 3-х студентов с их оценками (порядковый номер, Ф.И.О. и три оценки) определить количество отличников и средний бал каждого студента
Program Spic;
Type wed = record {Тип wed включает 3 поля: n, fio, bal}
n: integer;
fio: string[40];
bal: array [1..3] of integer {Поле bal – массив из 3 оценок }
end;
Var spisok: wed; {Запись spicok типа wed}
i, j, kol, s: integer; sr: real;
Begin
kol:=0; {kol- количество отличников}
With spisok do {with присоединяет имя записи spisok ко всем }
For i:=1 to 3 do { полям внутри цикла For по i }
begin
n:=i;
Write (' Vvedite FIO # ', i,' ');
Readln (fio);
s:=0;
For j:= 1 to 3 do
begin
write ('Vvedite ocenky: ');
readln (bal [j]);
s:= s+ bal [j];
end;
if s=15 then kol:=kol+1; {подсчет количества отличников}
sr:= s/3; writeln (fio, ', Sredniy bal = ', sr:4:1); end;
writeln (' Kolichestvo otlichnikov = ', kol);
readln;
end.
Задание14. Пусть нам необходимо заполнить сведения о студенте (Ф.И.О., дата рождения, адрес, курс и группа), а затем вывести эти сведения на экран
program primer1;
type anketa=record
fio: string[45];
dat_r: string[8];
adres: string[50];
curs: 1..5;
grupp: string[3]
end;
var student: anketa;
begin
writeln (‘введите сведения о студенте’);
{обратите внимание, ввод каждого поля осуществляется отдельно}
writeln (‘введите фамилию, имя и отчество’);
readln (student.fio);
writeln (‘введите дату рождения’);
readln (student.dat_r);
writeln (‘введите адрес’);
readln(student.adres);
writeln (‘введите курс’);
readln(student.curs);
writeln (‘введите группу’);
readln (student.grupp);
writeln (‘ввод закончен’);
writeln;
{обратите внимание, что вывод записи осуществляется по полям}
writeln (‘фамилия студента: ’, student. fio);
writeln(‘ дата рождения: ’, student.dat_r);
writeln(‘ адрес: ’, student.adres);
writeln(‘ курс: ’, student.curs);
writeln(‘ группа: ’, student.grupp);
end.
Задание15. Пусть нам необходимо иметь сведения о многих студентах, например, нашего факультета. Следовательно, необходимо организовать массив записей Паскаля. А затем из общего списка вывести фамилии студентов 2-го курса
program primer 2;
type anketa=record
fio: string[45];
dat_r: string[8];
adres: string[50];
curs: 1..5;
grupp: string[3]
end;
var student: array [1..100] of anketa;
I: integer;
begin
{последовательно вводим каждую запись}
for I:=1 to 100 do
begin
writeln (‘введите сведения о’, I, ‘-м студенте’);
writeln (‘введите фамилию, имя и отчество’);
readln (student[I].fio);
writeln (‘введите дату рождения’);
readln (student[I].dat_r);
writeln (‘введите адрес’);
readln(student[I].adres);
writeln (‘введите курс’);
readln(student[I].curs);
writeln (‘введите группу’);
readln (student[I].grupp);
end;
writeln (‘ввод закончен’);
writeln;
{просматриваем массив записей и выбираем только студентов 2-го курса }
for I:=1 to 100 do
if student[I].curs=2 then
writeln(‘ фамилия студента: ’, student[I].fio);
end.
Задание 1. Дана последовательность слов. Напечатать те слова последовательности, которые отличны от последнего слова и удовлетворяют свойству: слово симметрично
Program Stroki;
Uses Crt;
Var s,k:string;
a:array[1..100] of string;
i,n,j,l:Integer;
f:boolean;
begin
ClrScr;
{Ввод последовательности слов}
Writeln('Введите последовательность слов:');
Readln(s);
{Запись слов в массив a}
for i:=1 to length(s) do begin
if (s[i-1]<>' ') and (s[i]=' ') and (length(k)<>0) then begin
inc(n);
a[n]:=k;
k:='';
end;
if s[i]<>' ' then k:=k+s[i];
if (i=length(s)) and (length(k)<>0) then begin
inc(n);
a[n]:=k;
k:='';
end;
end;
{Проверка на симметричность слов, содержащихся в массиве а}
l:=0;
for i:=1 to n-1 do begin
f:=false;
if a[i]<>a[n] then
if length(a[i]) mod 2 = 0 then begin
for j:=1 to length(a[i]) div 2 do
if a[i][j]<>a[i][length(a[i])+1-j] then f:=true;
if f=False then begin
l:=l+1;
if l=1 then Write('Симметричные слова: ');
Write(a[i],' ');
end;
end;
end;
Writeln;
if l=0 then Writeln('Симметричные слова отсутствуют');
Write('Нажмите Enter');
Readln;
end.
Задание 2. Дана строка символов. Преобразовать эту строку удалив из нее каждые ">>" и повторив (вставив еще раз) каждую пару символов "<<". После преобразования полученную строку вывести на печать
Program Stroki;
Uses Crt;
Var s:string;
i:integer;
begin
ClrScr;
Write('Введите строку символов: ');
Readln(s);
for i:=1 to length(s) do begin
if (s[i-1]='>') and (s[i]='>') then delete(s,i-1,2);
if (s[i-1]='<') and (s[i]='<') then begin