Актюбинский Политехнический колледж
Отчет
по учебной практике
по программированию
Выполнила:
Волоснова А.С
учащаяся
группы 202АС
Проверила:
Гайсагалеева Б.М
Актобе 2010
ДНЕВНИК.
ДАТА
ТЕМА
ПРОДЕЛАННАЯ РАБОТА
ПРОВЕРКА
14.06.10
Виды загрузки. Основные приемы работы в среде ТР. Редактирование текста программы, процесс отладки.
Изучили основные виды загрузки и приемы работы в ТР и процесс отладки.
14.06.10
Изучение команд редактирования отладки программ с помощью командного меню Pascal.
Изучили команды редактирования отладки программ с помощью командного меню Pascal.
14.06.10
Оформление программы. Разделы. Описание разделов. Назначение каждой части программы.
Изучили, как оформлять программы, а также назначение каждой части программы.
15.06.10
Разработка постановки задачи. Разработка простейших программ с использованием команд присваивания, ввода, вывода.
Научились составлять программы с использованием простейших операторов ввода, вывода, присваивания.
15.06.10
Форматы ввода, вывода. Команды Read, Readln, Write, Writeln.
Изучили форматы ввода и вывода и команды Read, Readln, Write, Writeln.
15.06.10
Определение типов данных. Объявление данных. Константы. Метки. Комментарии. Разделители. Признаки концов строк на Pascale
Изучили различные типы данных и признаки концов строки на Pascal
16.06.10
Команды ветвления. Полные и не полные команды ветвления.
Изучили полную и не полную формы команд ветвления.
16.06.10
Составные операторы. Служебные скобки. Использование собственных операторов команды ветвления.
Изучили различные виды составных операторов.
16.06.10
Виды выражения. Сравнения с текстовых и числовых условий.
Изучили виды выражений и сравнения с текстовыми и числовыми условиями.
17.06.10
Составные условия. Оформления составных условий. Союзы составных условий. Примеры применения составных условий.
Изучили составные условия их оформление и применение.
17.06.10
Решение задач по выбору функции по значению аргумента. Команда выбора. Определение принадлежности точки к фигуре, к функции. Словесные условия.
Решали задачи по выбору функции по значению аргумента, определяли принадлежность точки к фигуре, к функции.
17.06.10
Решение задач. Применения. Ограничения отладки.
Решали задачи по ограничению отладки
18.06.10
Организация цикла с условием продолжения. Составные операторы в цикле WHILE DO. Применение. Решение задач. Блок-схема. Отладка.
Изучали составные операторы в цикле WHILE DO. Решали задачи.
18.06.10
Оператор цикла с условием окончания UNTIL, REPEAT. Правила применения.
Изучили оператор цикла с условием окончания UNTIL, REPEAT. Решали задачи.
18.06.10
Решения задач. Блок-схема. Отладка. Результаты.
Решение задач.
19.06.10
Оператор цикла с параметром FOR TO DO. Правила применения. Составные операторы в цикле. Решение задач с использованием оператора цикла с параметром.
Изучили оператор цикла с параметром FOR TO DO. Решение задач.
19.06.10
Нахождение суммы, произведения элементов ряда. Параметр цикла.
Научились находить сумму и произведение элементов ряда.
19.06.10
Цикл с параметром, с выборкой конца. Применение.
Изучили оператор цикла с параметром
21.06.10
Производные типы. Одномерные массивы. Типы индекса. Использование значений регулярного типа.
Рассмотрели одномерные массивы, производные типы. Выполнили практическую работу.
21.06.10
Многомерные массивы.
Рассмотрели многомерные массивы. Выполнили практическую работу.
21.06.10
Синтаксис задания регулярного типа.
Изучили синтаксис регулярного типа
22.06.10
Двумерный массивы. Матрица матриц. Создание формирование и работа с двумерными массивами. Поиск элементов в матрицах.
Изучили двумерный массив и работу с двумерным массивом.
22.06.10
Упорядочивание и сортировка элементов. Решение задач на матрицы.
Научились сортировать элементы массива. Решали задач на матрицы.
22.06.10
Составление программ с использованием матриц.
Составляли программы с использованием матриц.
23.06.10
Процедуры без параметров. Процедуры с параметрами. Параметры — значение. Параметры- переменные
Изучили разные виды процедур: с параметрами, без параметров, параметры- значение, параметр- переменные.
23.06.10
Параметры произвольных типов. Синтаксис процедур.
Рассмотрели параметры произвольных типов. И синтаксис процедур.
23.06.10
Определение оператора процедуры. Примеры использования процедур
Изучили оператора процедуры и его применение.
24.06.10
Описание процедуры- функции. Вызов функции. Побочные эффекты. Рекурсивные функции.
Изучили описание процедуры- функции, её вызов. Побочные эффекты.
24.06.10
Параметры- функции и параметры- процедуры.
Изучили параметры- функции и параметры- процедуры.
24.06.10
Процедуры и шаговая детализация.
Рассмотрели шаговую детализацию.
25.06.10
Строковые величины. Работа со строковыми величинами. Формирование строк с учетом конца строки. Подсчет, замена элементов. Удаление символов, ведущих, ведомых пробелов. Поиск нужного символа.
Научились работать со строковыми величинами.
25.06.10
Работа со стандартными функциями строк- Concat, Copy, Insert, Delete, POS, Length.
Научились работать со стандартными строковыми функциями: Concat, Copy, Insert, Delete, POS, Length.
25.06.10
Функции STR, Val, UpCase.
Изучилифункции: STR, Val, UpCase.
26.06.10
Простейшие комбинированные типы. Описание комбинированных типов. Работа с элементами комбинированного типа. Выборка элементов.
Изучили простейшие комбинированные типы, их описание, принцип работы.
26.06.10
Многоуровневые записи.
Изучили многоуровневые записи
26.06.10
Оператор присоединения.
Изучили оператор присоединения.
28.06.10
Обозначение множеств в Паскале. Задание множественного типа и множественная переменная. Операции над множествами.
Изучили множества в Паскале.
28.06.10
Процедуры работы с множествами.
Изучили процедуры работы с множествами.
28.06.10
Примеры использования множественного типа
Рассмотрели примеры множественного типа
29.06.10
Файлы и работа с ними. Доступ к файлам. Имена файлов. Файлы логических устройств. Инициация файла.
Изучили файлы, доступ к ним, их имена.
29.06.10
Процедуры и функции для работы с файлами Reset, Rewrite, Append, Assign
Изучили процедуры и функции для работы с файлами: Reset, Rewrite, Append, Assign
29.06.10
Процедуры и функции для работы с файлами Reset, Rewrite, Append, Assign
Изучили процедуры и функции для работы с файлами: Reset, Rewrite, Append, Assign
30.06.10
Текстовые файлы. Их объявление. Работа с ними.
Изучили текстовые файлы, и работу с ними.
30.06.10
Буферная переменная и её использование.
Изучили буферную переменную.
30.06.10
Буферная переменная и её использование.
Изучили буферную переменную.
01.07.10
Работа с графикой в Паскале. Графический режим. Установка драйверов графики. Инициализация драйверов графики. Описание драйверов.
Выполняли работы в графическом режиме Паскаль.
01.07.10
Команды вычеркивания точек, линей, окружностей, дуг, секторов и простых геометрических фигур.
Изучили команды вычеркивания простых геометрических фигур.
01.07.10
Команды вычеркивания точек, линей, окружностей, дуг, секторов и простых геометрических фигур.
Изучили команды вычеркивания простых геометрических фигур.
02.07.10
Модуль Граф. Модули установки цветов. Модуливыборастилейзаливок— SetLineStile, SetFileStile, FlodFileStile.
Изучили модуль Граф. И различные модули заливки и стилей.
02.07.10
Вычеркивание геометрических фигур с анимацией и организация движения и перемещения фигур по экрану.
Изучили вычеркивание геометрических фигур с анимацией и организацией движения и перемещения фигур по экрану.
03.07.10
Разработка программы графики с использованием всех модулей Граф.
Изучили разработку программ с использованием модуля Граф.
03.07.10
Разработка программы графики с использованием всех модулей Граф.
Изучили разработку программ с использованием модуля Граф.
03.07.10
Модули работы с текстом в графическом режиме. Модуль CRT. Системный модуль System.
Изучили принцип работы в графическом режиме.
--PAGE_BREAK--
СОДЕРЖАНИЕ.
Линейная программа на Паскаль.
Программа с ветвлениями.
Циклическая программа.
Массивы.
Процедуры и функции.
Файловые данные в Паскале.
Записи в Паскале.
Строки.
Графика в Турбо-Паскале.
Раздел: Линейные алгоритмы
1.Описание: Программа вычисления периметра треугольника.
program one;
uses crt;
var a,b,P:integer;
begin clrscr;
writeln ('a=');
readln (a);
writeln ('b=');
readln (b);
P:=(a+b)*2;
writeln ('P=',P);
end.
program one;
uses crt;
var a,b,h,s:real;
begin clrscr;
writeln('A= B= H= ');
readln(a,b,h);
s:=h*(a+b)/2;
writeln('S=',s:0:4);
readln;
end.
program one;
uses crt;
var Q,c,m,t2,t1:integer;
begin clrscr; textcolor(10);
writeln ('c=');
readln (c);
writeln ('m=');
readln (m);
writeln ('t2=');
readln (t2);
writeln ('t1=');
readln (t1);
Q:=c*m*(t2-t1);
writeln('Q=c*m*(t2-t1)=',Q);
end
program one;
uses crt;
var I,U,R:real;
begin clrscr; textcolor(10);
writeln ('U='); readln (U);
writeln ('R=');
readln (R);
I:=U/R;
writeln('I=',I:5:0);
end.
program one;
uses crt;
var r:real; x1,x2,y1,y2:integer;
begin clrscr;
writeln ('znachenie x1=');
readln (x1);
writeln ('znachenie x2=');
readln (x2);
writeln ('znachenie y1=');
readln (y1);
writeln ('znachenie y2=');
readln (y2);
r:=sqrt(sqr(x2-x1)+sqr(y2-y1));
writeln ('rasstoyanie=',r);
end.
program one;
uses crt; var a,b,c:real; begin clrscr;
writeln ('summa deneg=');
readln (a);
writeln ('cena ed.tovara=');
readln (b);
c:=a/b;
writeln ('ostatok=',c);
end.
program one;
uses crt;
var a:integer; s,d,e,f:real;
begin clrscr;
writeln ('vvedi 3-hznachnoe chislo'); продолжение
--PAGE_BREAK--
readln (a);
s:=a div 100;
d:=a mod 100 div 10;
e:=a mod 100 mod 10;
writeln (d:5:0); writeln (s:5:0); writeln (e:5:0);
f:=d+s+e; writeln (f:5:0);
end.
program one;
uses crt;
var a,S:real;
begin clrscr;
writeln('Vvedite storonu treugolnika');
readln(a);
S:=0;
S:=a*a*sqrt(3)/4;
writeln ('Ploshad ravna:', S:3:1);
readln;
end.
program one;
uses crt; var det,jen,muj,ned,mes:integer;
begin clrscr;
writeln ('det:=');
readln (det);
writeln ('jen:=');
readln (jen);
writeln ('muj:=');
readln (muj);
ned:=muj+jen+det;
mes:=4*ned;
writeln('dohod=',mes);
/>end
Program one;
Uses crt;
Var a,b,p:integer;
begin clrscr;textcolor(9+5);
writeln ('a= b=');
readln (a,b);
p:=a*b;
textcolor (9+16);
writeln (‘p=,p’);
end.
Programone;
Uses crt;
Var l:real; r:integer;
begin clrscr;textcolor(5);
writeln ('R=');
readln (r);
l:=2*pi*r;
writeln (‘radius=,r’);
end.
Program one;
Uses crt;Var а:integer;
begin clrscr;textcolor(5);
writeln ('a=');
readln (a);
p:=4*a;
writeln (‘perimetr=,р’);
end.
Programone;
Uses crt;Var s:integer;
begin clrscr;textcolor(5);
writeln ('s=');
readln (s);
writeln (‘выввеличисло,s’);
end.
Program one;
Uses crt;Var k,s:integer; p:real;
begin clrscr;textcolor(5);
writeln ('числожителей=');
readln (k);
writeln (‘plosh=’);
readln (s); продолжение
--PAGE_BREAK--
p:=s/k;
writeln (‘plotnost=’,p);
end.
program one;
var x,y:integer;; begin write('x='); readln(x); if x>0 then y:=sqr(sin(x)) else y:=1-2*sin(sqr(x)); writeln (y); end.
Programch;
Uses crt;
Var a,m,n:integer;
Begin clrscr;
Writeln (‘m= n=’);
Readln (m,n);
a:=m mod n;
If a=0 then write (m div n)
Else write(‘net resh’)
End.
/>
program one;
var x,y:real;
begin writeln('');
write('Vvedite x=');
readln(x); if x
y:=exp(x-1)+3.14 else if (0.8
y:=ln(x+5.96) else y:=2*x;
writeln('y=',y:4:2); readln;end.
program one; var x,y,z:real; begin writeln(''); write('Vvedite x='); readln(x); write('Vvedite y='); readln(y);
if x-y>0 then z:=1/(x*y) else z:=sqr(x)*sqr(y); writeln('z=',z:4:2); readln; end.
program one; var x,y,z,a,b:real; begin writeln(''); write('Vvedite a='); readln(a); write('Vvedite b='); readln(b); x:=ln(sqr(a)); y:=1/arctan(b); if x-y>0 then z:=1/(x*y) else z:=sqr(x)*sqr(y); writeln('z=',z:4:2); readln; end.
program one; var a1,a2,b1,b2,c1,c2:integer; begin writeln('vvedite shiriny, dliny, vusoty 1');
readln(a1,b1,c1); writeln('vvedite shiriny, dliny, vusoty 2'); readln(a2,b2,c2); if ((a1a2) and (b1>b2) and (c1>c2)) then writeln('mogno') else writeln('nelzya'); readln; end.
/>program one; var a,b,c,d:integer; begin read(a,b); read(c,d); if (a=c) or (b=d) or (abs(c-a)=abs(d-b))
then write('ga') else write('HeT');
readln
end
begin clrscr;
writeln('Стороны треугольника= ');
readln(a,b,c);
if (a
and(c
else write('невозможно');
readkey;
end.
program one; var a,b,c:real; begin read(a,b,c); if (a>b) and (a>c) then write('a^2= ',a*a:1:4); if (b>a) and (b>c) then write('b^2= ',b*b:1:4); if (c>a) and (c>b) then write('c^2= ',c*c:1:4); readln end.
Program b_ch;
Uses crt;
Var a,b:integer;
Max:integer;
Begin clrscr;
Writeln (‘a= b=’);
Readln (a,b);
If a>b then max:=a else max:=b
Writeln (‘max=’,max);
End.
Program m_ch;
Uses crt;
Var a,b:integer;
Min:integer;
Begin clrscr; продолжение
--PAGE_BREAK--
Writeln (‘a= b=’);
Readln (a,b);
If a
Writeln (‘min=’,min);
End.
Program ch;
Uses crt;
Var a,b,c:integer;
Begin clrscr;
Writeln (‘a= b=’);
Readln (a,b);
C:=a mod b;
If c=0 then write (a div b)
Else write(‘net resh’)
End.
Program ch;
Uses crt;
Var a,b,c,d,e,i:integer;
Begin clrscr;
Writeln (‘a=’);
Readln (a);
D:=a div 100;
E:=b mod 100 div 10;
C:=I mod 10;
writeln(d,e,c);
if (a
else writeln (‘ne ravny’);
End.
Program ch;
Uses crt;
Var a:integer;
Begin clrscr;
Writeln (‘a=’);
Readln (a);
if (a>=(-5)) and (a
else writeln (‘ ne prinadl’);
End.
Program ch;
Uses crt;
Var a,b,c:integer;
Begin clrscr;
Writeln (‘a= b= c=’);
Readln (a,b,c);
if (a=c) or (a=b) then writeln (‘ravnobedr’)
else writeln (‘ ne ravnobedr’);
End.
/>
продолжение
--PAGE_BREAK--
N:=n+1;
Until n>20; Readln;
End.
8. Описание: Известны оценки по информатике каждого из 20 учеников класса. В начале списка Перечислены все «5», затем остальные оценки. Сколько учеников имеют оценку «5»?
Program 5;
Uses crt;
Var x,n:word;
Begin clrscr;
Writeln(vvedi ocenki);
Readln(x);
N:=0;
While x=5 do begin n:=n+1;
Writeln(vvedi ocenki);
Readln(x);
End;
Writeln(imeyut 5,n,uchenikov);
Readln;
End.
9. Описание: Вычислить наибольший общий делитель двух натуральных чисел А и В, использую для этого алгоритм Евклида. Будем уменьшать каждый раз большее из чисел на величину меньшего до тех пор, пока оба числа не станут равными.
Program nod;
Uses crt;
Var a,b:integer;
Begin clrscr;
Writeln(vvedi 2 chisla);
Readln(a,b);
While ab do if a>b then a:=a-b else b:=b-a;
Writeln(nod=,a);Readln;
End.
10.Описание: Программа подсчета суммы Sпервых 1000 членов гармонического ряда 1+1/2+1/3+1/4+…+1/N
Program S;
Uses crt;
Var s:real;n:integer;
Begin clrscr;
S:=0; N:=0;
While n
S:=s+1/n;
End;
Writeln(s);
Readln;
End.
11.Описание: Имеется четыре (A, B, C, D) числа. Необходимо ответить на вопрос:«Правда ли что все среди этих чисел есть равные?»Ответ вывести в виде текста:«Правда», или «Неправда».
Programz1;
vara,b,c,d:integer; {описываем имеющиеся переменные}
beginwriteln('vveditechisloa'); {вводим все числа по очереди}
readln(a);
writeln('vvedite chislo b');
readln(b);
writeln('vvedite chislo c');
readln(c);
writeln('vvedite chislo d');
readln(d);
if (a=b)or (a=c) or (a=d)or (b=c) or (b=d) or (d=c) then writeln ('pravda') else writeln ('nepravda');
readln;
end.
12.Описание: Составить программу вычисления и выдачи на печать суммы (произведения) Nэлементов бесконечного ряда. Оформить проверку задания. Y=(-512)*256*(-128)*64…… Общая формула имеет вид: y=±210-i
programz2;
var i,j,zn,n:integer; s:real;
begin writeln;
writeln('vvedite kolichestvo elementov ryada');
write('N='); {вводим количество элементов ряда}
readln(n);
s:=1;
for i:=1 to n do begin zn:=1;
for j:=1 to i+1 do begin zn:=zn*(-1);
end;
s:=s*(-zn)*(exp((10-i)*ln(2))); {вводимформулу}
end;
writeln('s=',s:4:2);
readln;
end.
13.Описание: Дана функция Y=1-[x-2]^2/10 вычислить и напечатать значения этой функции для последовательных значений x=c,x=c+(b+1), x=c+2(b+1),x=c+3(b+1) где а=1; b=9; с=2. Считать до тех пор пока сумма Y+6 не станет отрицательной.
program zad3;
const b=9; c=2;
var x,n:integer; f,s:real; function y(x:integer):real;
begin y:=1-(sqr(x-c)) / (b+1);
end;
begin writeln('Y=1-[x-2]^2/10');
n:=0;
repeat x:=c+n*(b+1);
inc(n);
f:=y(x);
write('x',n,'= ',x,' ');
writeln('y',n,'= ',f:6:5)
untilf+6
readln
end.
14.Описание: Имеется массив А из Nпроизвольных чисел (A(n)), среди которых есть положительные, отрицательные и равные нулю. Напечатать только те числа из массива которые больше предыдущего числа.
program z4;
uses Crt;
const MAX = 100;
var mas: array[1..MAX] of integer; n,i: byte; k,p: integer;
begin ClrScr;
Write('N:=');
Readln(n);
for i:=1 to n do begin Write('vvedite ',i,' element massiva:>');Readln(mas[i]); end;
begin k := 0;
for i := 1 to n do begin if mas[i]>mas[(i-1)] then writeln (mas[i]); end;
readln; end;
end.
15.Описание: Составить программу вычисления числового ряда для известного числа членов ряда N. Y=(7+35/1)(8-3-4/2)(9+33/3)….
program z5;
var i,j,zn,n:integer; s:real;
begin writeln;
writeln('vvedite kolichestvo elementov ryada');
write('N=');
readln(n);
s:=1;
for i:=1 to n do begin zn:=1;
for j:=1 to i+1 do begin zn:=zn*(-1);end;
s:=s*((6+i)+exp((zn*(6-i))*ln(3))/i);end;
writeln('s=',s:4:2);
readln;
end.
Раздел: Массивы
1 Описание: Найти, сколько раз каждый элемент встречается в массиве
Дополнительных массивов не создавать.
Programmsv;
Const Size=10; Diap=10;
var a: array [1..Size] of integer; i,n,k,j:integer;
begin writeln;
repeat write('Введите размерность 1 массива (от 2 до ',Size,'):');
Read (n);
Until (n>1) and (n
a [1]:=Random(Diap);
Write ('A= ', a[1],' ');
For i: =2 to n do begin A[i]:=Random (Diap);
Write (a[i],' '); End;
writeln;
k:=0;
For i: =1 to n do if a[i]=0 then Inc(k);
If k>0 then writeln ('0: ',k);
For i: =1 to n-1 do if a[i]0 then begin K: =1;
For j: =i+1 to n do if a[i]=a[j] then begin A[j]:=0;
Inc (k); End;
writeln (a[i],': ',k); end;
end.
2. Описание: Объединить 2 упорядоченных массива по возрастанию.
Program msv;
const Size=10; Step=5;
var a,b:array [1..Size] of integer; c:array [1..2*Size] of integer; i,n1,n2,ia,ib,ic:integer;
begin writeln;
repeat write('Введите размерность 1 массива (от 2 до ',Size,'):');
read (n1);
until (n1>1) and (n1
Randomize;
a[1]:=Random(Step); продолжение
--PAGE_BREAK--
write ('A= ',a[1],' ');
for i:=2 to n1 do begin a[i]:=a[i-1]+Random(Step);
write (a[i],' '); end;
writeln;
repeat
write('Введите размерность 2 массива (от 2 до ',Size,'):');
read (n2);
until (n2>1) and (n2
b[1]:=Random(Step);
write ('B= ',b[1],' ');
for i:=2 to n2 do begin b[i]:=b[i-1]+Random(Step);
write (b[i],' ');
end;
writeln;
ia:=1; ib:=1;
write ('C= ');
for i:=1 to n1+n2 do begin if a[ia]
if ia
if ib
else begin c[i]:=b[ib];
if ib
if ia
write (c[i],' ');
end;
writeln;
end.
3. Описание: Дан массив чисел. Найтинаибольшее.
Program msv;
Uses crt;
Var i,n,max:integer; a:array[1..100] of integer;
begin clrscr;
read(n);
for i:=1 to n do read(a[i]); {вводчиселвмассив}
max:=a[1];
for i:=2 to n do if a[i] > max then max:=a[i]; {сравниваетсясуженайденнымнаибольшим,}
write('maksimalnoe chislo = ',max);
readln;
end.
4. Описание: Найти сумму элементов числового массива
Program msv;
uses crt;
Var i,n,s:integer; a:array[1..1000] of integer;
begin clrscr;
read(n);
for i:=1 to n do read(a[i]); {вводзначенийвмассив}
s:=0;
for i:=1 to n do s:=s+a[i];
write('Summa = ',s); readln;
readln;
end.
5. Описание: Дан числовой массив. Вычислить сумму элементов, имеющих четное значение индекса. Вычислительную часть организовать в виде функции
Programmsv;
Usescrt;
type mas=array[1..100] of integer;
Var a:mas; i,n:integer; function calc(b:mas;m:integer):integer;
var i,s:integer;
begin s:=0;
for i:=1 to m do;
if i mod 2=0 then s:=s+b[i];
calc:=s;
end;
begin clrscr;
read(n);
for i:=1 to n do read(a[i]);
write('Сумма каждого второго элемента = ',calc(a,n));
readln;
readln;
end.
6. Описание: Дан массив символов. Вычислить, сколько в нем элементов 'a'
Program msv;
Uses crt;
Var i,n,s:integer; a:array[1..100] of char;
begin clrscr;
readln(n); {Объявлениеа:array[1..1000] of char означает,}
for i:=1 to n do readln(a[i]);
s:=0;
for i:=1 to n do readln(a[i]);
s:=0;
for i:=1 to n do if a[i]='a' then s:=s+1;
write('Kolichestvo elementov ravnyh «a» = ',s);
readln;
end.
7. Описание: Дан двумерный массив целых чисел размерностью NxN. Найти сумму его элементов
Programmsv;
Uses crt;
Var s,i,j,n:integer; a:array[1..10,1..10] of integer;
begin clrscr;
read(n);
for i:=1 to n do for j:=1 to n do read(a[i,j]);
for i:=1 to n do for j:=1 to n do s:=s+a[i,j];
write('Сумма элементов = ',s);
readln;
readln;
end.
8. Описание: По заданному массиву X[7] сформировать массив Y, элементы которого вычисляются по формуле
Y[i]= |X[i]-B|, где B— максимальный элемент массива X
program msv;
const Size=7; { Размерностьмассива}
var x:array [1..Size] of real; b:real; i:integer;
beginwriteln;
writeln ('Жду ввода элементов массива размерностью ',Size,':');
for i:=1 to Size do begin write ('x[',i,']=');
readln (x[i]); end;
b:=x[1];
for i:=2 to Size do if x[i]>b then b:=x[i];
writeln ('Максимальный элемент=',b:10:3);
writeln ('Исходный Новый');
writeln ('массив массив');
for i:=1 to Size do begin write (x[i]:10:4);
x[i]:=abs(x[i]-b);
writeln (x[i]:10:4); end;
end.
9. Описание: Найти максимальный элемент в линейном массиве.
Вывести результат на экран
programmsv;
uses crt;
const
nn = 10; var max, i: integer; a: array[1..nn] of integer; begin clrscr;
for i := 1 to nn do a[i] := random(500);
max := a[1];
for i := 2 to nn do if a[i] > max then max := a[i];
for i := 1 to nn do write(a[i], ' '); writeln;
writeln('Max = ', max);
readkey;
end.
10. Описание: Отсев. Удалить в заданном массиве x(n) лишние (кроме первого) элементы так, чтобы оставшиеся образовывали возрастающую последовательность(за один просмотр массива)
program msv;
uses crt;
const n = 10; {dlina massiva}
var a: array[1..n] of integer; i, max, j, k, mi: integer; begin clrscr; randomize;
for i := 1 to n do begin a[i] := random(51);
write(a[i], ' '); end;
max := a[1];
k := 2; {t.k. uslovie zadachi «preobarzovat' za odin prosmotr massiva», to}
{k ne mozhet bit' bol'she N, chem mi vospol'zuemsya v cikle}
for i := 2 to n do begin if k > n then break;
if a[i]
begin for j := i to n — 1 do {etogo cikl mog bi ne viiti, no u nas est' K}
a[j] := a[j + 1];
dec(i); end;
if a[i] > max then begin max := a[i];
mi := i; {MI — poziciya maksimuma v massive} end;
inc(k); {uvelichivaem K, k = [2..n]} End;
Write (#10#13, a[1], ' ');
For i: = 2 to mi do Write (a[i], ' ');
readkey;
end.
11. Описание: В массиве Xиз nэлементов каждый из элементов равен 0, 1 или 2. Переставить элементы массива так, чтобы сначала располагались нули, затем единицы и двойки. Дополнительный массив не использовать.
Программа расширена для возможности переставлять элементы массива, являющимися любыми числами (не только 0, 1, 2)
Programmsv;
Constn= 10; {кол-вл элементов массива}
var a, b, t: integer; X: array[1..n] of integer; {саммассивизn элементов} продолжение
--PAGE_BREAK--
BEGIN For a := 1 to n do {вводмассиваX} Begin Write ('Введите X [', a, ']: ');
Readln(X[a]); End;
for a := 1 to n do begin t := X[a];
b := a — 1;
While (b>=0) and (t
B: = b — 1; End;
X [b+1]:= t; end;
for a := 1 to n do {вывод результата}
Write(X[a]:2);
END. {конец программы}
12. Описание: Операции с массивом, сортировка суммирование.В одномерном массиве, состоящем из Nвещественных элементов, вычислить:1) количество элементов массива, равных 0;2) сумму элементов массива, расположенных после минимального элемента.
Упорядочить элементы массива по возрастанию модулей элементов.
Program msv;
Uses CRT;
Const N = 10; {сколько всего элементов}
Var a: Array[1..N] of Real; i, j: Byte; Zero: Byte; Min: Real; Summ: Real;
Procedure Print;
Begin For i := 1 to N do Write(a[i]:0:1,' ');
Writeln;End;
Procedure CreateMassive;
BeginWriteln('Исходная последовательность');
For i := 1 to N do Begin a[i] := Random(4);
a[i] := a[i] — 2; {Этот и предыдущий операторы можно объединить}
End;
Print;
Writeln;End;
Begin ClrScr;Randomize;
CreateMassive;
Min := a[1];
For i := 2 to N do Begin Summ := Summ + a[i];
If (a[i]
Summ := 0; End; End;
Writeln('Минимальный элемент ',Min:0:1,'. Сумма элементов после: ',Summ:0:1);
For i := 1 to N do Begin For j := i + 1 to N do If (abs(a[j])
a[j] := a[i] — a[j];
a[i] := a[i] — a[j]; End; End;
Writeln(#13#10,'Отсортированняпоследовательность'); Print;
For i := 1 to N do If a[i] = 0 then Inc(Zero);
Write(#13#10,'Нулевыхэлементов: ',Zero);ReadKey;
End.
13. Описание: Вычислить угол между двумя заданными векторами размерности 8, используя функцию скалярного произведения a= arccos((x,y)/((x,x)*(y,y)))
program msv;
uses crt;
type TVector = array[1..8] of Real;
function scal(var Vec1, Vec2: TVector):real; var p: Real; i: integer;
begin p:=0;
for i:=1 to 8 do p:=p+(Vec1[i]*Vec2[i]);
scal := p;end;
var Vec1, Vec2: TVector; i: integer; sc, a, angle: Real;
BEGINwriteln('Условие:');
writeln(' вычислить угол между двумя заданными векторами размерности 8,');
writeln(' используя функцию скалярного произведения');
writeln;
Writeln('Ввод первого вектора');
for i := 1 to 8 do begin Write('Vec1[', i, ']: ');
Readln(Vec1[i]); end;
Writeln('Ввод второго вектора');
for i := 1 to 8 do begin Write('Vec2[', i, ']: ');
Readln(Vec2[i]); end;
sc := scal(Vec1, Vec2);
a:= sc/sqrt(scal(Vec1,Vec1)*scal(Vec2,Vec2)); {Вычисляется косинус}
if a=0 then angle:=90 else angle:=arctan(sqrt(1-a*a)/a)*180/pi;
if a=-1 then angle:=180;
if angle
writeln('Угол между векторами: ',angle:7:3,' градусов');
END.
14. Описание: Вычислить сумму двух векторов, первый из которых вводится, а элементы второго вычисляются по формуле b[i]:=sin(i*x), где 0x
program msv;
constNm= 10; {размерность вектора}
var Vec1, Vec2, ResVec: array[1..Nm] of Real; i: integer; x: Real; N: integer;
BEGINwriteln('Условие :');
writeln(' вычислить сумму двух векторов, первый из которых вводится, а элементы');
writeln(' второго вычисляются по формуле b[i]:=sin(i*x), где 0
writeln;
Write('введите размерность вектора (N
Readln(N);
if n
for i := 1 to N do begin Write('Vec1[', i, ']: ');
Readln(Vec1[i]); end;
Write('Введите X (от 0 до 3.14): '); Readln(x);
if (X = 0) then begin for i := 1 to N do begin Vec2[i] := sin(Vec1[i]*X); ResVec[i] := Vec1[i]*Vec2[i]; {сразужевычисляемпроизведние} end;
Write('Результирующий вектор: '); {выводим на экран результат}
for i := 1 to N do Write(ResVec[i]:6:2); end else Writeln('ВведеноневерноеX');
endelseWriteln('неверная размерность');
END.
15. Описание: Создается случайный массив из 5 элементов. Заменить все четные значения на 1, нечетные – на 0.
Program msv;
uses crt;
const n=5;
var a:array[1..n] of integer; i:integer;
begin clrscr; randomize;
for i:=1 to n do begin a[i]:=random(9);
write(a[i]); end;
writeln;
for i:=1 to n do begin if odd(a[i])=false then a[i]:=1 else a[i]:=0;
write(a[i]);
end;
readkey;
end.
Раздел: Процедуры и функции
1.Описание: Найти последовательности целых чисел те, которые встречаются в ней ровно два раза.
program one;
uses crt;
type mas=array[1..100]of integer; func=function(var x:mas):integer; var a:mas; j,n,m,x:integer;
function kolichestvo(var c:mas):integer; var k,i:integer;
begin k:=0;
for i:=1 to n do if c[i]>m then k:=k+1;
kolichestvo:=k; end;
procedure deist(var b:mas; operation:func);
begin writeln('b[j]');
for j:=1 to n do readln(b[j]);
for j:=1 to n do write(b[j],' '); writeln;
x:=operation(a); end;
begin clrscr;
writeln('vvedite celoe chislo m i razmer massiva(n)');
readln(m,n);
deist(a,kolichestvo);
writeln('kolichestvo=',x);
readkey;
end.
2.Описание: Процедура отображения рамки в текстовом режиме
program frame;
uses Crt;
procedure Frm(l:integer; t:integer; w:integer; h:integer);
var x,y:integer; i:integer; c1,c2,c3,c4,c5,c6:char;
begin clrscr;
c1:=chr(218); c2:=chr(196);
c3:=chr(191); c4:=chr(179);
c5:=chr(192); c6:=chr(217); GoToXY(l,t);
write(c1);
for i:=1 to w-2 do write(c2);
write(c3);
y:=t+1;
x:=l+w-1;
for i:=1 to h-2 do begin GoToXY(l,y);
write(c4);
GoToXY(x,y);
write(c4);
y:=y+1; end;
GoToXY(l,y);
write(c5);
for i:=1 to w-2 do write(c2);
write(c6);
end; продолжение
--PAGE_BREAK--
begin Frm(2,2,15,10);
readln;
end.
3.Описание: Произведение нечетных элементов
Program one;
type massiv= array [1..100] of integer;
var A1,A2:massiv; i,j:integer; n1,n2:integer; function pr_nec(m:massiv; n:integer):integer;
var i,j,pr:integer;
begin pr:=1;
for i:=1 to n do if odd(m[i]) then pr:=pr*m[i];
pr_nec:=pr;
end;
begin writeln('Vvedite PERVYI massiv:');
write('ego razmer «n»: '); readln(n1);
for i:=1 to n1 do begin write('A1[',i,']='); readln(A1[i]); end;
writeln('_______________________');
writeln('Vvedite VTOROI massiv:');
write('ego razmer «n»: '); readln(n2);
for i:=1 to n2 do begin write('A2[',i,']='); readln(A2[i]); end;
writeln('_______________________');
writeln;
writeln('Vi vveli:');
write('A1: '); for i:=1 to n1 do write(A1[i],' '); writeln;
write('A2: '); for i:=1 to n2 do write(A2[i],' '); writeln;
writeln;
writeln('Proizvedenie iz A1= ',pr_nec(A1,n1));
writeln('Proizvedenie iz A2= ',pr_nec(A2,n2));
readln;
end.
4.Описание: Нахождение тангенса tg и котангенса ctg угла, используя выражения sin(x)cos(x) и обратное ему.
Program one;
uses crt;
var y1,y2,z: real; function tg (x: real): real;
begin tg := sin(x)/cos(x);
end;
function ctg (x: real): real;
begin ctg := cos(x)/sin(x);
end;
Begin clrscr;
write ('input x: ');
readln (z);
y1:=tg(z); y2:=ctg(z);
writeln ('tg (',z:0:2,')=',y1:0:2);
writeln ('ctg (',z:0:2,')=',y2:0:2);readln;
End.
5. Описание: Определить максимальное число из четырех введенных, путем сравнения их сначала попарно, а затем результат между собой.
program one;
uses crt;
var a,b,c,d,z,x,y,x1,y1:integer; function max(x,y:integer):integer;
begin if x>y then max:=x else max:=y;
end;
begin clrscr;
writeln('Vvedite chisla');
readln(a,b,c,d);
x1:=max(a,b); y1:=max(c,d); z:=max(x1,y1);
writeln('max=',z);
readkey;
end.
6.Описание: Вычислить день недели по дате
program Kalendar;
uses crt; var y,d,m,c,w: integer; {m-mesiac,d-den, y-god }Procedure WriteDay(d,m,y:Integer);
constDays_of_week: rray [0..6] of String [11] =('Voskresen`e','Ponedelnik','Vtornik', ' Sreda', ' Chetverg', ' Piatnica', ' Subbota') ;
Begin if m
y := y — 1;end else m := m — 2;c := y div 100;y := y mod 100;w := (d+(13*m-1) div 5+y+y div 4+c div 4-2*c+777) mod 7;
WriteLn(Days_of_week[w] );end;
Procedure InputDate(var d,m,y: Integer);
Begin Write('Vvedite datu v formate DD MM GG ');
ReadLn(d,m,y);
if (d>=1)and (d=1) and (m=1582) and (y
BEGIN clrscr;
InputDate(d,m,y);
readkey;
End.
7. Описание: Нахождение процента от числа
Program one;
uses crt;
var k,n:byte; x:real; function procent(n,m:byte):real;
begin procent:=m*100/n;
end;
begin clrscr;
writeln('Vvedite chisla');
readln(k,n);
x:=procent(k,n);
writeln('x=',x:5:2);
readkey;
end.
8. Вывести заданное число звездочек.
program one;;
uses crt;
var n:byte; function zvezda(n:byte):real; var i:integer; s:string;
begin i:=1;
s:='';
while i
inc(i); end;
writeln(s); end;
begin clrscr;
writeln('Vvedite chislo'); readln(n);
zvezda(n); readkey;
end.
9. Описание: Функция возведения числа в степень. С учетом дробных чисел и частных случаев, когда числа отрицательные или равны нулю
program one;
Uses crt;
var x,y,z:real; Function Pow(A,B:Real):Real; Var T,R:Real; L:integer;
Begin T := Abs(A);
If A 0 Then R := Exp(B*Ln(T)) else R:=0;
L := round(B);
If (L mod 2 = 0) Then R:=Abs(R);
If (B=0) Then R:=1;
Pow:=R;
End;
BEGIN clrscr;
Writeln('vvedite chislo:');
readln(x);
Writeln('vvedite stepen:');
readln(y);
z:=Pow(x,y);
Writeln(z:0:2);
readkey;
END.
10. Описание: Вывести заданный символ заданное количество раз
program one;
uses crt;
var n:byte; l:string; function zvezda(n:byte;l:string):real; var i:integer; s:string;
begin i:=1;
s:='';
while i
inc(i); end;
writeln(s); end;
begin clrscr;
writeln('Vvedite chislo'); readln(n);
writeln('Vvedite simvol'); readln(l);
zvezda(n,l);
readkey;
end.
11.Описание: Определить к чему ближе меньшее из двух чисел: к их среднему арифметическому или среднему геометрическому.
Program one;
vara,b: real; average: real; geometricmean: real; minstr: string;function min(a,b: real) :real;
begin min := a;
minstr := 'Pervoe';
if (b
minstr := 'Vtoroe';end;end;
beginwrite('Vvedite 1-e chslo: ');readln(a);
write('Vvedite 2-e chslo: ');readln(b);
average := (a + b) / 2;
geometricmean := sqrt(a*a + b*b);
a := min(a,b);
writeln('Naimenshee chislo — ',minstr,' (',a:0:3,')');
write('Blize k srednemu ');
if (abs(average — a)
end else begin writeln('geometricheskomu (',geometricmean:0:3,')');end;
readln;
end.
12.Описание: Возведение в степень для целого показателя, вычисляемого за время log2(степень).
Program power_maximal;
Uses crt;
Var a,b,c: integer; function power (x,pow:integer):integer; var res: integer;
begin res := 1;
while (pow > 0) do beginif (pow and 1 = 1) then res:= res * x;
x := x * x;
pow := pow shr 1;end;
power := res; end;
Begin Clrscr;
Writeln ('input a,b: ');
Readln (a,b);
c:=power(a,b);
Writeln('a^b = ',c);
Readkey;
End.ъ
13.Описание: Арккосинус числа. Нахождение из математических соображений
varca,al,albeg: real; functionArcCos(arg:real):real;
var r:real;
begin if (abs(arg)>1) then begin writeln(' Unavailable argument ');
halt; end;
if abs(arg)
if arg продолжение
--PAGE_BREAK--
ArcCos := r; end;
begin albeg:=pi/2+0.2;
ca := cos(albeg);
al := arccos(ca);
writeln('ArcCos(',ca:10:7,')=',al:10:7,' AlBeg=',albeg:10:7,
' ChekSum =',al-albeg,' Must be sero');
readln;
end.
14.Описание: Есть ли в строке числовые значения
Function NumInStr(S: String): Boolean;
VAR C, I: INTEGER; N: BOOLEAN;
BEGIN; I:=0;
Repeat;
I:=I+1;
C:=Ord(S[I]);
N:=( (C >= 48) AND (C
Until (NOT N) OR (I=Length(S));
NumInStr:=N;
END;
15.Описание: Нахождение функции методом половинного деления
program half_del;
uses crt;
type ms=array[1..100] of real; { [x,y] }
var Eps,XH,DX,Y,z,X,YH,P,S,A,B:real; N,U,Er:integer; masx,masy:ms;Function F(X:real):real;
beginF:=exp(x)+x*x-2
end;
Function FuncA(Eps,s,p,YH:real):real;
begin if F(p)*F(s)
while abs(F(YH)) > EPS do begin If F(p)*F(YH)
YH:=0.5*(P+S) end; end else er:=1;
FuncA:=YH; end;
procedure P1(a,b,XH:real; N:integer); var z,q:real; u:integer;
begin if x>1 then begin Z:=sqrt(X*sqrt(X-1));
a:=FuncA(Eps,s,p,YH);
for U:=1 to N do begin masx[U]:=X;
masy[U]:=sin(x)/z;
X:=X+DX; end;
{else writeln(' Error: x
Begin clrscr;
write ('vvedite eps: '); readln(eps);
Write ('vvedite dx: '); readln(DX);
write ('vvedite N: '); readln(N);
write ('vvedite x>1 :'); readln(x);
if x1; writeln;
Writeln ('--------------------');
Writeln (' | X | Y ');
writeln ('--------------------');
P1(a,b,XH,N);
for U:=1 to N do writeln('',masx[u]:10:7,' ',masy[u]:10:7);readln;
end.
Раздел: Файлы
1.Описание: Решает простейшие арифметические примеры записанные в файл.
program pn12;
var f:text; s,sa,sb:string; c:char; i,a,b,o,j,code:integer; m,op:set of char;
begin m:=['1','2','3','4','5','6','7','8','9','0'];
op:=['+','-','*','/'];
assign(f,'file.txt');reset(f);
while not(eof(f)) do begin readln(f,s);
writeln(s);
for i:=2 to length(s)-1 do if (s[i] in op)and (s[i-1]in m) and (s[i+1]in m) then begin j:=1;
sa:='';
while (s[i-j] in m) and (i-j>0) do begin sa:=s[i-j]+sa;
j:=j+1 end;
j:=1;
sb:='';
while (s[i+j] in m) and (i+j
j:=j+1 end;
val(sa,a,code);val(sb,b,code);
case s[i] of '+':O:=a+b;
'-':O:=a-b;
'*':O:=a*b;
'/':O:=a div b; end;
writeln(a,s[i],b,'=',O,' ')
end;end; close(f);
readln;
end.
2.Описание: Работа с текстовыми файлами предусматривает собой: создание, редактирование, добавление, удаление.
Program one;
uses Dos,Crt;
var f :text;
FileName :string[9];
st :string; ch :char; vibor :byte;
procedure Head;
begin Writeln('esli vy otkazyvaetes ot deistviya,to naberite v nazvanii faila simvola""');
Write('vvedite imya faila:>');
Readln(FileName);
if FileName='~' then halt(1) else Assign(f,FileName); end;
procedure TextEdit;
begin Writeln('Seichas vy smojetedobavlyat informaciyu v file.');
Writeln('esli vyzahotite prekratit vvod, to naberite sleduschuyu posledovatelnost:"~~"');
repeat Write('>');Readln(st);
if st'~~' then Writeln(f,st);
until st='~~'; end;
procedure WriteToFile;
begin Head;
ReWrite(f);
TextEdit;
Close(f);
Writeln('Vy okonchili vvodit info v file.Najmite lubuyu knopku...');
ReadKey; end;
procedure ReadFromFile;
Head;
Reset(f);
if IOresult0 then begin Writeln('file ',FExpand(filename),' ne sushestvuet.');
Writeln((Y/N).');
ch:=ReadKey;
if (ch='Y') or (ch='y') then ReadFromFile;
end else begin Writeln('Soderjimoe faila:');Writeln;
while not eof(f) do begin Readln(f,st);
Writeln('>',st); end;
Close(f);
Writeln;
Writeln('Najmite lubuyu knopku');
ReadKey; end;end;
procedure AddToFile;
begin Head;
Append(f);
if IOresult0 then begin продолжение
--PAGE_BREAK--
Writeln('faila ',FExpand(filename),' ne sushestvuet.');
Writeln('hotite vvesti drugoe imya faila?(Y/N).');
ch:=ReadKey;
if (ch='Y') or (ch='y') then AddToFile; end else begin TextEdit; Close(f);
Writeln('Vy okon4ili vvodit info v file.Najmite lubuyu knopku...');
ReadKey; end; end;
procedure DelFile;
begin Head;
Reset(f);
if IOresult0 then begin Writeln('file ',FExpand(filename),' ne sushestvuet.');
Writeln('hotite vvesti drugoe imya file??(Y/N).');
ch:=ReadKey; if (ch='Y') or (ch='y') then DelFile; end else begin Writeln('vy uvereny 4to hotite udalit etot file?(Y/N)');
ch:=ReadKey; if (ch='Y') or (ch='y') then Erase(f);
Writeln('vy tolko 4to udalili file.Najmite lubuyu klavishu..');
Readkey; end; end;
procedure Menu;
begin repeat repeat ClrScr;
Writeln('1. record file / sozdanie faila');
Writeln('2. read file');
Writeln('3. Dobavlenie info v file');
Writeln('4. delet file');
Writeln('5. Exit');
Write('Vash vybor:>');Readln(vibor);
until (vibor>0) and (vibor
Writeln;
Write('‚л ўлЎа «Ё: ');
case vibor of 1:begin Writeln(' record file / sozdanie faila');
WriteToFile; end;
2:begin Writeln('read file');
ReadFromFile; end;
3:begin Writeln(' Dobavlenie info v file');
AddToFile; end;
4:begin Writeln('delet file');
DelFile; end; end;
until vibor=5; end;
begin Menu;
end.
3.Описание: Дан файл, содержащий текст и арифметические выражения вида, а*в, где * — один из знаков +, -, *, /.Выписать все арифметические выражения и вычислить их значения
program pn12;
var f:text; s,sa,sb:string; c:char; i,a,b,o,j,code:integer; m,op:set of char;
begin m:=['1','2','3','4','5','6','7','8','9','0'];
op:=['+','-','*','/'];
assign(f,'e:\tp\tp6\Arif.dat');reset(f);
while not(eof(f)) do begin readln(f,s);
writeln(s);
for i:=2 to length(s)-1 do if (s[i] in op)and (s[i-1]in m) and (s[i+1]in m) then begin j:=1;
sa:='';
while (s[i-j] in m) and (i-j>0) do begin sa:=s[i-j]+sa;
j:=j+1 end;
j:=1; sb:='';
while (s[i+j] in m) and (i+j
j:=j+1 end;
val(sa,a,code);val(sb,b,code);
case s[i] of '+':O:=a+b;
'-':O:=a-b; '*':O:=a*b; '/':O:=a div b; end;
writeln(a,s[i],b,'=',O,' ')
end; end;
close(f);
end.
4.Описание: Вывести максимальное число из файла in.txt
Program one;
var t:text; i,p,code:integer; s:string; m:array[1..100] of real; max:real;
begin assign(t,'in.txt'); reset(t);
read(t,s);
i:=0;
repeat p:=pos(' ',s);
inc(i);
val(copy(s,1,p-1),m[i],code);
delete(s,1,p);
until p=0;
max:=m[1];
for p:=2 to i do if m[p]>max then max:=m[p];
writeln('MAX= ',max);
close(t);
readln;
end.
5.Описание: Перекодирование файла из формата DOSв формат Windows.
Program one;
var f,g:text; i,p,n:integer; m:array [1..100] of string; s:string;
begin assign(f,'in.txt'); reset(f);
assign(g,'out.txt'); rewrite(g);
while not eof(f) do begin readln(f,s); {считываемочереднуюстроку}
i:=0; {ставим счётчик слов на 0}
repeat inc(i); {увеличиваем счётчик текущего ПРЕДЛОЖЕНИЯ}
p:=pos(' ',s); {смотрим где находится пробел}
m[i]:=copy(s,1,p-1); {записываем текущее слово в массив}
delete(s,1,p); {то слово, которое заприсали в массив — удаляем}
until p=0; {****************}
n:=i+1; {конец массива}
if s[length(s)]='.' then begin m[n]:=copy(s,1,length(s)-1); m[1]:=m[1]+'.' {то эту точку перемещаем на 1 слово}
end else m[n]:=s; {а если нет точки — то просто его записываем в массив}
writeln(g);;
for i:=n downto 1 do write(g,m[i],' '); {идём с конца массива в начало и записываем слова в обратном порядке}end;
writeln('PEREZAPISANO...');readln;
close(f); close(g);
end.
6.Описание: Удаление следующих друг за другом нескольких пробелов из файла. продолжение
--PAGE_BREAK--
Program one;
const
FileName: String = 'Strings.txt';
VAR f: Text; S: String;
BEGIN Assign(f, FileName); {$I-}Reset(f); {$I+}
if IOResult = 0 then begin ReadLn(f, S); Close(f) end;
WriteLn('input string: ',S);
while (POS(' ', S) > 0) do delete(S, POS(' ',S), 1);
if ( length(S) > 1) and (S[1] = ' ') then Delete(S, 1, 1);
if (length(S)>1) and (S[length(S)] = ' ') then Delete(S, length(S), 1);
writeln('output string: ',s);
readln;
END.
7.Описание: Вывести содержимое файла в обратном порядке в новый файл.
program one;
uses crt;
var fl1,fl2:text;a,b:string; i,l:longint;
begin clrscr;
assign(fl1,'input.txt');
assign(fl2,'output.txt'); reset(fl1); readln(fl1,a);
close(fl1);
l:=length(a);
for i:=l downto 1 do b:=b+a[i];
rewrite(fl2); write(fl2,b);
close(fl2);
write(b); readln;
end.
8.Описание: Бинарный поиск элемента в типизрованном longint файле.
program searches;
uses crt,dos;
type longint_file=file of longint;
procedure files_names_query(var read_file,error:string; var search_value:longint);
var f:text;
begin error:='';
write('‘считываемый файл: ');
readln(read_file);
assign(f,read_file);
reset(f);
if (ioresult=0) then begin close(f);
write('находимоезначение=');
readln(search_value);
end else begin error:='ошибка:файлнесуществует'; end; end;
function bin_search(left,right,search_value:longint;var f:longint_file):boolean;
var center,value,new_left,new_right,right_value,center_value:longint;
begin if (left=right) then begin seek(f,left);
read(f,value);
if (value=search_value) then begin bin_search:=TRUE;
end else begin bin_search:=FALSE; end;
end else begin center:=((left+right) div 2)+1;
seek(f,right);
read(f,right_value);
seek(f,center);
read(f,center_value);
if ((search_value>=center_value)and(search_value
bin_search:=bin_search(new_left,right,search_value,f);
end else begin new_right:=center-1;
bin_search:=bin_search(left,new_right,search_value,f); end; end; end;
function search(read_file:string; search_value:longint):boolean;
var f:longint_file;
finded:boolean;
elements_count:longint;
begin assign(f,read_file);
reset(f);
finded:=FALSE;
elements_count:=filesize(f);
finded:=bin_search(0,elements_count-1,search_value,f);
close(f);
search:=finded; end;
procedure writing_to_file(write_file:string;finded:boolean;begin_time:longint);
var f:text; hour,minutes,seconds,seconds100:word; end_time:longint; time:real;
begin gettime(hour,minutes,seconds,seconds100);
end_time:=minutes*60*100+seconds*100+seconds100;
time:=(end_time-begin_time)/100;
assign(f,write_file);
rewrite(f);
if (finded) then writeln(f,'ok') else writeln(f,'error');
writeln(f,time:4:2);
close(f); end;
procedure writing(finded:boolean; begin_time:longint);
begin if (finded) then begin writeln('Element finded complete');
end else begin writeln('Element not finded'); end;
readln; end;
var read_file,write_file,error,search_value_string:string; hour,minutes,seconds,seconds100:word;
begin_time,search_value:longint; k:integer; result:boolean;
begin gettime(hour,minutes,seconds,seconds100);
begin_time:=minutes*60*100+seconds*100+seconds100;
if (paramstr(1)'') then begin read_file:=paramstr(1);
search_value_string:=paramstr(2);
val(search_value_string,search_value,k);
write_file:=paramstr(3);
result:=search(read_file,search_value);
writing_to_file(write_file,result,begin_time);
end else begin files_names_query(read_file,error,search_value if (error='')
then begin result:=search(read_file,search_value);
writing(result,begin_time);
end else begin writeln(error);
writeln('нажмите Enter для продолжения.');
readln; end; end;
end. продолжение
--PAGE_BREAK--
9.Описание: Вывести таблично результаты расчета функции y=sin(x)/x на указанном диапазоне в файл.
Program one;
Const M=24;
Var FName: Text; AB,H,X: Real;
Function F(X:Real):Real;
Begin F:=Abs(Sin(X)/X);
End;
Begin Write ('vvedite na4alo diapazona: ');
ReadLn (A);
Write ('vvedite konec diapazona: ');
ReadLn (B);
WriteLn('sozdayu LA-BA.TAB');
H:=(B-A)/M;
X:=A;
Assign(FName,'LA-BA.TAB');
ReWrite(FName);
WriteLn (FName,'X | F(X)');
While (X
X:=X+H;
End;
Close (FName);
End.
10.Описание: Дан файл, содержащий текст. Сколько слов в тексте? Сколько цифр в тексте?
program one;
Const mn=['0'..'9'];
Var f3:text; i,j,ch,sl:integer; name:string; s:char; wrd :string;
Begin writeln('vvedite imya faila');
readln(name);
assign(f3,name);
reset(f3);
s:=' '; sl:=0; ch:=0;
while not eof(f3) do begin readln(f3,wrd);
i:=1;
While i' ' then sl:=sl+1;
while (wrd[i]' ') and (i
inc(i) end; end;
close(f3);
reset(f3);
while not eof(f3) do begin while not eoln(f3) do begin read(f3,s);
if (s in mn) then ch:=ch+1;
end; readln(f3); end;
writeln('4islo slov: ',sl,' 4islo cifr: ',ch);
close(f3);
End.
11.Описание: Заменить синонимами слова в файле
program ;
var f1,f2,f3:text; i,n,k,l:integer; s,sout,ss,slovoT,slovo,sinonim:string;
begin assign(f1,'text1.txt');
assign(f2,'text2.txt'); assign(f3,'text3.txt');
rewrite(f1);
writeln('‚ўҐ¤ЁвҐвҐЄбв:');
repeat readln(s);
writeln(f1,s)
until s='';
close(f1); reset(f1);
rewrite(f3);
while not(eof(f1)) do begin readln(f1,s);
s:=s+' ';
sout:='';
while length(s)>0 do begin l:=pos(' ',s);
slovoT:=copy(s,1,l-1);
delete(s,1,l);
reset(f2);
while not(eof(f2)) do begin readln(f2,ss);
k:=pos(',',ss);sinonim:=copy(ss,1,k-1);
if sinonim=slovoT then slovoT:=copy(ss,k+1,length(ss)-k) end;
close(f2);
sout:=sout+slovot+' ' end;
writeln(s);
writeln(f3,sout) end;
close(f3); reset(f3);
while not(eof(f3)) do begin readln(f3,s);
writeln(s) end;
close(f3); readln
end.
12.Описание: Очистить файл, оставив лишь первую строку.
program one;
uses crt;
var fl1:text;a:string;i,l,poz:longint;label m;
begin clrscr;
assign(fl1,'input.txt');
reset(fl1); readln(fl1,a); close(fl1);
l:=length(a);
rewrite(fl1);
for i:=1 to l do if a[i]='.'then begin poz:=i;goto m; end;
m:for i:=1 to poz do write(fl1,a[i]); close(fl1);
writeln('complete!!!');
readkey;
end.
13.Описание: Вывод статистики по файлу
program one; uses crt; var infile:text;file_name,s:string;i, commas, points, blanks,lines:integer; begin clrscr; commas:=0;points:=0;blanks:=0;lines:=0; write('vvedite imya faila'); readln(file_name); assign(infile,file_name);reset(infile); while not eof(infile) do begin readln(infile,s); for i:=1 to length(s) do begin case s[i] of ',' :inc(commas); '.' :inc(points); ' ' :inc(blanks); end; end; inc(lines); end; close(infile); gotoxy(1,3); writeln('zapyatih: ',commas); writeln('predlogenii: ',points); writeln(' probelov: ',blanks); writeln(' strok: ',lines); readln; end.
14Задан файл F, компонентами которого являются целые числа. Переписать в файл G вначале все отрицательные, затем все нулевые, а затем все положительные числа, упорядочив их по возрастанию модуля величины. ФайлG — текстовый. Program Pascal; Const fname='num.txt'; fname2='num2.txt'; Var f,g:text; stroka:string; k,code,i,j,tmp:integer; a:array[1..20] of integer; begin Assign(F, fName); ReSet(F); k:=0; While Not Eof(F) Do Begin ReadLn(F, Stroka); k:=k+1; val(Stroka,tmp,code); a[k]:=tmp; writeln(a[k]); End; close(f); writeln; writeln(k); writeln; for i:=2 to k do for j:= k downto 2 do if a[j-1] > a[j] then begin tmp := a[j-1]; a[j-1] := a[j]; a[j] := tmp; end; for i:=1 to k do write(a[i],' '); Assign(g, fName2); rewrite(g); for i:=1 to k do begin writeln(g,a[i]); end; close(g); writeln; readln; end. продолжение
--PAGE_BREAK--
15Задан тектовый файл, содержащий текст. Определить сколько раз встречается в нем самое длинное слово.
programtp7; const razd=[' ','.',',','?','!',':',')','(']; var f:text; s,slo,slovo,name:string; k,i:integer; begin write('Введитеимяфайла:'); readln(Name); assign(f,name); reset(f); slovo:='';k:=0; while not(EOF(F)) do begin readln(f,s);slo:=''; for i:=1 to length(s) do begin if s[i] in razd then begin if (i>1)and not(s[i-1]in razd) then begin if (length(slo)=length(slovo))and (slo=slovo) then k:=k+1; if length(slo)>length(slovo) then begin slovo:=slo; k:=1 end; end; slo:='' end else begin slo:=slo+s[i] end; end; if (length(slo)=length(slovo))and (slo=slovo) then k:=k+1; if length(slo)>length(slovo) then slovo:=slo; end; writeln('слово',slovo,' встречается',k,' раз'); close(f); readln end.
Раздел: Записи
1.Описание: В файл вводятся имена, пол и рост человека. Программа считывает данные из файла и выдает совпадения, если в нем есть мужчины одного роста.
program one;
const n=2;
type group=record
ser:string[30]; p:string[1]; h:100..250;
end;
var person:array[1..n] of group; f:text; r:boolean; ar:array[1..n] of integer; i,j,z,obr:integer;
begin assign(f,'AAAAAAA.txt');
rewrite(f);
for i:=1 to n do with person[i] do begin writeln('person ',i);
writeln(f,'person ',i);
writeln('sername');
readln(ser);
writeln(f,'sername: ',ser,' ');
writeln('pol');
readln(p);
writeln(f,'pol: ',p,' ');
writeln('rost');
readln(h);
writeln(f,'rost: ',h,' ');
writeln(f);
writeln; end;
close(f);
reset(f);
append(f);
writeln(f,'poisk dvuh men s odinakovim rostom');
j:=1; for i:=1 to n do begin with person[i] do begin if (p='m') or (p='M') then begin ar[j]:=h;
j:=j+1; z:=j-1; end; end; end;
r:=false;
for j:=1 to z do begin obr:=ar[j]; i:=j;
repeat if ar[i+1]=obr then r:=true else i:=i+1;
until (i>z) or (r); end;
if r=true then writeln(f,'sovpadenie naydeno');
if r=false then writeln(f,'sovpadenie ne naydeno');
close(f);
readln;
end.
2.Описание: Телефонный справочник
program one; type Zapis=record fam:string; tel:string;
end; var out: file of Zapis; nam:Zapis; kon:char; begin assign(out,'nomera'); rewrite(out); repeat write('fam?'); readln(nam.fam); write('nomer?'); readln(nam.tel); write(out,nam); writeln('prodolgim? y/N'); readln(kon); until kon 'y'; reset(out); while not eof(out) do begin read(out,nam); writeln(nam.fam,'-',nam.tel); end; close(out); end.
3.Описание: Программа, которая создает файл с описанием студентов:
program one;
type TStudentInfo=record name:string[30]; kurs:string[20]; ekz:array[1..5] of byte; end; var f:file of TStudentInfo; st:TStudentInfo; p:byte; begin assign(f,'students.dat'); reset(f); {Откроем файл. Позиция на данный момент в самом начале} if ioresult0 then rewrite(f); {Если ошибка, занчит файла нет, и значит откоем его подругому} seek(f,filesize(f));
with st do repeat write('Введите имя студента (пустую строку для выхода): '); readln(name); if name='' then break; write('Введите курс:'); readln(kurs); for p:=low(ekz) to high(ekz) do begin write('Введите оценку по экзамену №',p,': '); readln(ekz[p]); end; write(f,st); {Вот эта строка и записывает информацию о студенте в файл} until false; close(f); {Эту команду мы ещё не рассматривали, но об этом я расскажу в конце} end.
4.Описание: Производится ввод даты последовательно: число, месяц, год. Программа проверяет наличие ошибок при вводе.
program lab4;
uses crt;
type day=1..31; mon=1..12; year=1..3000;
var data:record
d:day; m:mon; y:year; end; s:boolean;
function vernaydat:boolean;
begin with data do begin write('chslo: ');
readln(d);
write('mesyc: ');
readln(m);
write('god: ');
readln(y);
s:=true;
if y>3000 then s:=false;
if m>12 then s:=false;
case m of 1,3,5,7,8,10,12:begin if d>31 then s:=false; end;
4,6,9,11:begin if d>30 then s:=false; end;
2:begin if (y mod 4)0 then if d>28 then s:=false;
if (y mod 4)=0 then if d>29 then s:=false;
end; end; продолжение
--PAGE_BREAK--
if s=true then write('OK');
if s=false then write('ERROR');end;end;
begin clrscr;
writeln('Vvedite datu');
Vernaydat; readln;
end.
5.Описание: Формирование базы данных информации о студентах. Вывод из таблицы список студентов:-получивших оценку 4;-получивших оценки 4 и 5;-фамилия которых начинается на 'А'.
Program Laba6;
Uses Crt;
Type Exam = Record
Name: String[20]; Year: Integer; Lesson: String[10]; Prise: Integer;
End;
Mass = Array [1..30] Of Exam;
Var Student: Mass; Prise1, Prise2, Num, I: Integer; Letter: Char;
Procedure InputStudent (Var InpNum: Integer);
Var I:Integer;
Begin ClrScr;
Write ('4islo studentov: ');
ReadLn (InpNum);
For I:=1 To InpNum Do Begin Write ('vvvedite familiyu stud nomer ',I,' [20]: '); ReadLn (Student[I].Name);
Write ('god rojden stud nomer',I,': '); ReadLn (Student[I].Year);
Write ('predmet studenta nomer ',I,' [10]: '); ReadLn (Student[I].Lesson);
Write ('ocenka stud nomer ',I,': '); ReadLn (Student[I].Prise);
WriteLn; End;End;
Procedure OutLine (Line: Integer);
Begin Write (Student[Line].Name:20);
Write (Student[Line].Year:6);
Write (Student[Line].Lesson:10);
Write (Student[Line].Prise:7);
WriteLn;End;
Procedure OutStudent (OutNum: Integer); Var I: Integer;
Begin ClrScr;
WriteLn ('familiya':20,'god':6,'predmet':10,'ocenka':7);
For I:=1 To OutNum Do OutLine (I);End;
Procedure OutStudentPrise1 (OutNum, OutPrise: Integer);Var Col, I: Integer;
Begin WriteLn;
Col:=0;
WriteLn ('dannye o stud-h polu4ivshih ocenki: ',OutPrise);
For I:=1 To OutNum Do If (Student[I].Prise=OutPrise) Then Begin Col:=Col+1;
OutLine (I); End;
WriteLn ('4islo stud polu4ivshih ocenku ',OutPrise,': ',Col);End;
Procedure OutStudentPrise2 (OutNum, OutPrise1, OutPrise2: Integer);
Var I: Integer;
Begin WriteLn;
WriteLn ('dannye o stud polu4ivshih ocenku: ',OutPrise1,' Ё',OutPrise2);
For I:=1To OutNum Do If ((Student[I].Prise=OutPrise1)Or (Student[I].Prise=OutPrise2))Then OutLine (I);
End;
Procedure OutStudentName (OutNum:Integer; OutLetter:Char);Var I: Integer;
Begin WriteLn;
WriteLn ('dannye o studentah 4i familii na4inayutsa na "',OutLetter,'"');
For I:=1 To OutNum Do If (Copy(Student[I].Name,1,1)=OutLetter)Then OutLine (I);End;
Begin InputStudent (Num);
OutStudent (Num); Prise1:=4;
OutStudentPrise1 (Num, Prise1); Prise2:=5;
OutStudentPrise2 (Num, Prise1, Prise2); Letter:='Ђ';
OutStudentName (Num, Letter);
ReadLn;
End.
6.Описание: Дана таблица материалов с следующей информацией по каждому материалу: название, удельный вес, вид проводимости (диэлектрик, полупроводник, проводник). Выписать из таблицы все полупроводники и их удельный вес.
program one;
Uses CRT;
Const Veshestvo = 1;
Type Material = Record
Name: String[20]; Weight: Real; Provod: Integer;
End;
Var Result,I,J,N: Integer; F: Array[1..20] Of Material; Begin
F[1].name := 'med'; F[1].Weight := 4.00; F[1].Provod := 2;
F[2].name := 'bumaga'; F[2].Weight := 66.0; F[2].Provod := 0;
F[3].name := 'ЉаҐ¬Ё©'; F[3].Weight := 5.40; F[3].Provod := 1;
F[4].name := 'germany'; F[4].Weight := 21.5; F[4].Provod := 1;
F[5].name := 'arsenid gallia'; F[5].Weight := 3.00; F[5].Provod := 1;
F[6].name := 'alluminiy'; F[6].Weight := 50.0; F[6].Provod := 2;
F[7].name := 'keramika'; F[7].Weight := 9.90; F[7].Provod := 0;
F[8].name := 'rezina'; F[8].Weight := 80.0; F[8].Provod := 0;
F[9].name := 'ftoroplast'; F[9].Weight := 4.00; F[9].Provod := 0;
ClrScr;
N := 9;
Result := 0;
Writeln('naimenovanie materiala udelny ves provodimost');
Writeln('-----------------------------------------------------------');
For I := 1 to N Do If (F[I].Provod = Veshestvo) Then Begin
Write(F[I].Name:22,F[I].Weight:15:2);
Case F[I].Provod Of
0: WriteLn('izolyator':15);
1: WriteLn('poluprovodnik':15);
2: WriteLn('provodnik':15); End;
Result := Result + 1; End;
Writeln('-----------------------------------------------------------');
Writeln('naideno ',Result,' material.');
If Result = 0 Then WriteLn('takogo materiala net'); Readln;
End.
7.Описание: Вывести из введеной строки слова с максимальным количеством вхождений буквл 'l' и 'o' и подсчитать количество этих вхождений.
Type Info = record
wrd,num: Byte; ch: Char; продолжение
--PAGE_BREAK--
End;
Var S, Temp:String; P,I: Byte; M, N: Info;
Function CalkChar(A:String;C:Char):Byte; Var I, Result: Byte;
Begin Result := 0;
For I := 1 To Length(A) Do If UpCase(A[I]) = UpCase(C) Then Inc(Result);
CalkChar := Result;
End;
Begin WriteLn('vvedite frazu po-angl:');
ReadLn(S);
I := 1;
M.num := 0; M.wrd := 0; M.ch := 'l';
N.num := 0; N.wrd := 0; N.ch := 'o';
While Pos(' ',S) 0 Do Begin P := Pos(' ',S);
Temp := Copy(S,1,P);
If M.wrd
M.wrd := CalkChar(Temp,M.ch); End;
If N.wrd
N.wrd := CalkChar(Temp,N.ch); End;
Delete(S,1,P); Inc(I); End;
If M.wrd
M.wrd := CalkChar(S,M.ch); End;
If N.wrd
N.wrd := CalkChar(S,N.ch); End;
WriteLn('-------------');
If M.wrd 0 Then WriteLn('bukva ',M.ch,'4asche vstre4aetsa v ',M.num,'-¬ slove, celyh ',M.wrd,' raz( )');
If N.wrd 0 Then WriteLn('bukva ',N.ch,' 4asche vstre4aetsa v ',N.num,'-m slove, celyh ',N.wrd,' raz( )');readln;
End.
8.Описание: Из исходной таблицы игрушек с полями: название игрушки, стоимость, возрастные ограничения, выписать сведения для игрушек стоимостью менее 4 рублей, подходящие детям 5 лет.
Uses CRT;
Const Vozrast = 5;
Cena = 400;
Type Toy = Record
Name: String[20]; Sale: Integer; Min: Integer; Max: Integer;
End;
Var Sum,Result,I,J,N: Integer; F: Array[1..20] Of Toy;
Begin
F[1].name := 'mya4'; F[1].Sale := 400; F[1].min := 1; F[1].max := 9;
F[2].name := 'kukla'; F[2].Sale := 660; F[2].min := 3; F[2].max := 7;
F[3].name := 'samolet'; F[3].Sale := 540; F[3].min := 3; F[3].max := 5;
F[4].name := 'pupsik'; F[4].Sale := 210; F[4].min := 1; F[4].max := 3;
F[5].name := 'knijka'; F[5].Sale := 300; F[5].min := 1; F[5].max := 5;
F[6].name := 'mashinka'; F[6].Sale := 500; F[6].min := 3; F[6].max := 8;
F[7].name := 'parovoz'; F[7].Sale := 990; F[7].min := 4; F[7].max := 7;
F[8].name := 'ula'; F[8].Sale := 800; F[8].min := 2; F[8].max := 5;
F[9].name := 'konstruktor'; F[9].Sale := 400; F[9].min := 6; F[9].max := 9;
ClrScr;
N := 9;
Result := 0;
Sum := 0;
Writeln('igryshka cena, kop. Min vozrast Max vozrast');
Writeln('-----------------------------------------------------------');
For I := 1 to N Do If (F[I].min
WriteLn(F[I].Name:20,F[I].Sale:12,F[I].Min:14,F[I].Max:13);
Result := Result + 1; Sum := Sum +F[I].Sale; End;
Writeln('-----------------------------------------------------------');
Writeln('stoimost pokupki: ',Sum/100:3:2,' rub.');
If Result = 0 Then WriteLn('pokupku sovershit nevozmojno!');
Readln;
End.
9.Описание: Из первой таблицы, где заданы коэффициенты для уравнений задания линий выписать в новую таблицу только те коэффициенты, которые формируют линию, параллельную первой в исходной таблице.
Uses CRT;
Type Line = Record
A,B,C: Integer;
End;
Var Result,I,J,N: Integer; F,G: Array[1..20] Of Line;
Begin
F[1].A := 1; F[1].B := 9; F[1].C := 2;
F[2].A := 2; F[2].B := 6; F[2].C := 3;
F[3].A := 3; F[3].B := 5; F[3].C := 1;
F[4].A := 4; F[4].B := 2; F[4].C := 4;
F[5].A := 3; F[5].B := 3; F[5].C := 1;
F[6].A := 2; F[6].B := 5; F[6].C := 2;
F[7].A := 1; F[7].B := 9; F[7].C := 5;
F[8].A := 2; F[8].B := 6; F[8].C := 1;
F[9].A := 3; F[9].B := 5; F[9].C := 2;
ClrScr;
N := 9; Result := 0; I := 1;
For J := 2 to N Do If (F[I].A = F[J].A) And (F[I].B = F[J].B) Then Begin Write('liniya ',I,' paralelna linii ',J,' ');
WriteLn(F[I].A,'X + ',F[I].B,'Y + ',F[I].C);
Result := Result + 1; End;
Writeln('naideno ',Result,' liniy');
If Result = 0 Then WriteLn('takih liniy net');
Readln;
End.
10.Описание: Имеется запись о багаже пассажира (кол-во вещей и общий вес вещей). Выяснить, имеется ли пассажир, багаж которого превышает багаж каждого из остальных пассажиров и по числу вещей и по весу. Дать сведения о багаже, число вещей в котором не меньше, чем в любом другом багаже, а вес вещей не больше, чем в любом другом багаже.
uses crt; type bagaj = record ves:double;kol_veshei: integer; end; var bagage:array[1..20] of bagaj; i,j,n,temp:byte;rez,k:double;a:boolean; begin clrscr; writeln('Vvedite kol-vo passajirov (n 2) then temp:=temp+1; writeln('Takih passajirov ',temp,' chelovek'); if temp = 0 then writeln('Takih passajirov net!'); writeln; writeln('Kol-vo veshei bolshe srednego chisla veshei: '); writeln; rez:=0; temp:=0; for i:=1 to n do rez:=rez+bagage[i].kol_veshei; for i:=1 to n doif (bagage[i].kol_veshei > (rez/n)) then temp:=temp+1; writeln('Takih veshei ',temp); if temp = 0 then writeln('Takih veshei 0');.writeln; writeln('Bagage iz 1 veshi s vesom ne menee 30 kg'); writeln; temp:=0; for i:=1 to n doif bagage[i].kol_veshei = 1 thenif bagage[i].ves >= 30 thentemp:=temp+1; writeln('Imeetsya ',temp,' passajirov s takim bagajom'); readln; end. продолжение
--PAGE_BREAK--
11.Описание: 1.Список книг состоит из 10 записей. Запись содержит поля: Фамилия автора, название книги, год издания.Найти название книг данного автора, изданных с 1960 года.Program df; Uses crt; Type knigi= record Fam:string[15];Naz:string[30];Gad:integer; End; Var s:array[1..10] of knidi; I,k:integer;Av:string;Begin clrscr; For i:=1 tio 10 do begin with s[i] do begin Writeln(vvedi fam,i); Readln(fam); Writeln(vvedi nazv,i); Readln(nazv); Writeln(god); Readln(god);End;end; Writeln(vvedi av); Readln(avt); K:=length(av); For i:=1 to 10 do begin With s[i] do begin If (copy(fam,1,k)=av) and (god>1960) then writeln(nazv,nazv); End;End; End.
12.Описание:Из ведомости 3-х студентов с их оценками ( порядковый номер, Ф.И.О. и три оценки) определить количество отличников и средний бал каждого студента.Program Spic; Type wed = record n:integer; fio:string[40]; bal:array [1..3] of integer end;Var spisok:wed; i,j,kol,s:integer; sr:real; Begin kol:=0; with spisok do For i:=1 to 3 do 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.
13.Описание: программа показывает пример объединения координат точек в запись. Здесь используется массив из записей типа RecPoint. Каждая такая запись содержит в себе поля с координатами x, y, z и поле комментария. Таким образом, одна запись описывает одну точку, а массив из записей представляет собой набор точек. Program Records; Uses crt; type RecPoint = record x, y, z: real; comment: string end; var Point: array [1..10] of RecPoint; i: integrer; delta: real; begin Clrscr; for i := 1 to 10 do begin Point[i].x := 2*i — 3; Point[i].y := 3*Point[i].x + 2; Point[i].z := 6*Point[i].y — 2*Point[i].x + 1; delta := Point[i].z — Point[i].x; if delta > 100 then Point[i].comment := 'z — x > 100.' else Point[i].comment := 'Неткомментариев.'; end; Writeln ('Результарасчёта(полязаписи):'); Write (' ':7,'x'); Write (' ':8,'y'); Write (' ':8,'z'); Writeln (' комментарии'); for i := 1 to 10 do begin Write (Point[i].x:8:3,' '); Write (Point[i].y:8:3,' '); Write (Point[i].z:8:3,' ':2); Writeln (Point[i].comment); end; Readkey; end.
14.Описание: Выравнивание текста
uses crt;
const
l = 79; {kolvo liter, umeshayushihsya na ekrane v DOSe}
var t: text; i, j: integer; s: string; c, ost: byte;
begin clrscr;
assign(t, 'input.txt'); reset(t);
while not EoF(t) do begin readln(t, s);
for i := 1 to length(s) do if s[i] = ' ' then incc;
ost := l — length(s); {ost — kolichestvo probelov, kotorie nado}
j := 1;
while ost > 0 do begin for i := 1 to length(s) + c — 1 do if (s[i] = ' ') then begin if ost
insert(' ', s, i); dec(ost); inc(i, j); end;
inc(j); {t.k. pri prohozhdenii cikla FOR mi vstrechaem pervii probel} end;
c := 0; {obyazatel'no obnulayem kol-vo strok v stroke}
writeln(s); end;
close(t); readkey;
end.
15.Описание: Программа контроля студентов по литературе.Формируется файл вопросов и ответов
program zavd1;
uses crt;
const qfile='quest.txt'; afile='ansver.txt'; var f1,f2:text;i,k:integer; name,ansv:string;
begin clrscr;
assign(f1,qfile);
assign(f2,afile);
rewrite(f2);
reset(f1);
write('vvedi imya ?¬`п, gruppu :');
readln(name);
writeln(f2,name);
while not eof(f1) do begin readln(f1,name);
writeln(name);
write('‚ иў?¤Ї®ў?¤м:');
readln(name);
writeln(f2,name);
readln(f1,ansv);
if ansv=name then k:=k+1;
i:=i+1;end;
writeln(f2,'‚бм®Ј® ЇЁв м:');
writeln(f2,i);
writeln(f2,'Џа ўЁ«мЁеЇЁв м:');
writeln(f2,k);
close(f1); close(f2);
end.
Раздел: Строки
1. Описание: Из строки повторяющихся слов, отделяемых запятыми и заканчивающиеся точкой, выписать все гласные буквы в алфавитном порядке, которые входят не более чем в одно слово.
program one;
Uses CRT;
Type MyType = Set Of Char; Var S,W: String; I,K,L: Integer; J: Char; M,N: MyType; B,C: Array [1..32] of MyType;
Begin ClrScr;
M :=[' ','Ґ','с','Ё','®','г','л','н','о','п']; S := 'е«ҐЎ,¬®«®Є®, аЎг§,алЎ ,ᥫҐ¤Є .'; K := 1;
writeln(s);
While pos(',',S) > 0 Do Begin W := copy(S,1,pos(',',S));
B[K] := [];
For I := 1 To Length(W) Do B[K] := B[K] + [W[I]];
Inc(K);
delete(S,1,pos(',',S)); End;
W := S; B[K] := [];
For I := 1 To Length(W) Do B[K] := B[K] + [W[I]];
For I := 1 To K Do Begin C[I] := B[I]; For L := 1 To K Do If I L Then C[I] := C[I] — B[L]; End;
N := [];
For I := 1 To K Do N := N + C[I];
M := M * N;
For J := ' ' To 'п' Do If J in M Then Write(J,' ');
WriteLn; ReadKey;
End.
2.Описание: Основа алгоритма игры, согласно которой из слова образца, которое является первым в строке (в данном случае Pascal), составляются другие слова из тех же букв. Количество вхождений одной и той же буквы должно быть не больше, чем в образце.
program one;
Uses CRT;
Var S,T: String; N,I,J: Integer; A: Array [1..100] of String; F: Boolean;
Begin ClrScr; продолжение
--PAGE_BREAK--
S := 'pascal cal lasca nosok pasca sapca lapca caplan capla';
N := 1;
While pos(' ', S) > 0 Do Begin A[N] := copy(S, 1, pos(' ', S)-1);
delete(S, 1, pos(' ', S));
inc(N); End;
A[N] := S;
For I := 2 To N Do Begin F := True;
T := A[I];
For J := 1 To Length(T) Do Begin If (pos(T[J], A[1])) >0 Then T[J] := '*' Else F := False; End;
If F Then WriteLn(A[I]); End;
readln;
End.
3.Описание: Вывести каждое слово предложения задом наперед.
Program Stroki;
const chars=['.',',','!','?',' '];var S,S_out,slovo: string; i,j: integer;
begin Writeln('Vv stroku');
Readln(S);
S:= S+' ';
for i:= 1 to Length(S) do if not (S[i] in chars) then Slovo:=slovo+S[i] else if slovo '' then begin for j:= Length(slovo) downto 1 do S_out:=s_out+slovo[j];
s_out:=s_out+' ';
slovo:=''; end;
Writeln(S_out);
Readln;
end.
4.Описание: Расположить слова в порядке возрастания их длины в тексте.
program one;
uses crt;
var a,d,sl1,sl2: string; i,l,k,j: longint; b: array [1..50] of string;
begin clrscr;
write('input s: ');readln(a);l:=length(a);
if a=''then halt;
if a[l]' ' then begin inc(l);a[l]:=' '; end;
for i:=1 to l do if a[i]=' 'then begin inc(j);b[j]:=d;d:=''; end else d:=d+a[i];
for i:=1 to j-1 do for k:=i+1 to j do begin sl1:=b[i]; sl2:=b[k];
if length(sl1)>length(sl2) then begin b[i]:=sl2; b[k]:=sl1; end; end;
for i:=1 to j do write(' ',b[i]); readln;
end.
5.Описание: Найти и заменить определенные символы в тексте (заменяемые) введенным символом с клавиатуры (заменяющий). Каждуюзаменусопровождатьподтверждением.
program one;
uses crt;
var i,l:longint;a,a1,a2,p:string;
begin clrscr;textcolor(11);
write('vvedite text: '); readln(a);
write('zamenyaemyi simvol: '); readln(a1);
write('zamenyauschiy simvol: '); readln(a2);
if (length(a1)>1)or(length(a2)>1) then halt;l:=length(a);
for i:=1 to l do if a[i]=a1 then begin clrscr; a[i]:='_';
writeln(a);
writeln('Vy podtverzhdaete zamenu ',i,'-ogo simvola? (y/n)'); readln(p);
if p='y' then a[i]:=a2[1] else a[i]:=a1[1]; end;
clrscr;
write(a); readln;
end.
6.Описание: Найти похожее слово в предложении, которое отличается не более, чем на два символа. Пример: Pascal=Paskal=Pacsal.
program one;
var s,sl:string; m:array[1..100] of string; i,j,k,p,n,kol:integer;
beginwrite('Vvedite TEXT (slova cerez PROBEL): '); readln(s);
write('ISCEM — ?: '); readln(sl);
i:=0;
repeat inc(i);
p:=pos(' ',s);
m[i]:=copy(s,1,p-1);
delete(s,1,p);
until p=0; n:=i; m[n]:=s;
writeln('Naideno:');writeln;
for i:=1 to n do begin kol:=0;
for j:=1 to length(sl) do if pos(sl[j],m[i])0 then inc(kol);
if (length(m[i])-kol)
end.
7.Описание: Подсчет числа слов в тексте.
program one;
uses crt;
var tec: string; l,i,n: longint;
begin clrscr;
write('input s:');readln(tec);
l:=length(tec)+1;tec[l]:=' ';
for i:=1 to l do if tec[i]=' 'then n:=n+1;
write('in s ',n,' words');
readln;
end.
8.Описание: Максимальное слово в прдложении
program one;
Uses CRT;
Var MaxL,C: String; Pb: Byte;
Begin ClrScr;
WriteLn(vvedite predlojenie:'); ReadLn(C);
MaxL := '';
While Pos(' ',C) 0 Do Begin Pb := Pos(' ',C);
If Length(MaxL)
Delete(C,1,Pb); End;
If Length(MaxL)
WriteLn;
WriteLn('Samaya bolshayaposledovatelnost'simvolov v predlojenii:');
WriteLn(MaxL); продолжение
--PAGE_BREAK--
ReadLn;
End.
9.Описание: Выписать слова из строки, которые начинаются с заданной буквы.
program one;
uses crt;
var a,aa,b: string; i,l,o,oo: longint;
begin clrscr;
write('string: ');readln(a);
write('bukva: ');readln(aa);l:=length(a);
if length(aa)>1 then halt;
if a[l]' 'then begin inc(l);a[l]:=' '; end;
for i:=1 to l do if a[i]=' 'then begin if b[1]=aa then writeln(b) else inc(o);inc(oo);b:='';
end else b:=b+a[i];
if o=oo then write('takix slov net!'); readln;
end.
10.Вводится 10 букв, а затем слово. Проверяется возможность составить введенное слово из этих символов.
program one;
uses crt;
var as:Array[1..10]of Char; s,s2:String; i,b:Byte;
beginclrscr;
Writeln('vvedite 10 simvolov:');
for i:=1 to 10 do begin rite('ь',i,': ');
readln(mas[i]); end;
write('vvedite stroku: '); readln(s);
for i:=1 to Length(s) do for b:=1 to 10 do if s[i]=mas[b] then begin s2:=s2+mas[b];
mas[b]:=' '; b:=10; end;
if s2=s then write('Iz etih simvolov mozhno sostavit' slovo ',s)else writeln('Iz etih simvolov nelzya sostavit slovo',s);
readln;
end.
11.Описание: Найти в строке минимальное и максимальное слова
program gdy;
label 1;
var s:string; m:array[1..100] of string; i,p,n:integer; ax,min:string; c:char;
begin 1:write('Vvedite stroky: '); readln(s);
if s[length(s)]'.' then begin writeln('ERROR: konec stroki okancivaetsia na "."'); goto 1; end;
if length(s)>79 then begin writeln('ERROR: stroka doljna biti
write('Vvedite ZADANII SIMVOL:'); readln(c);
i:=0;
repeat p:=pos(' ',s);
if pos(c,copy(s,1,p-1))0 then begin inc(i); m[i]:=copy(s,1,p-1); end; delete(s,1,p); until p=0; n:=i; f pos(c,copy(s,1,length(s)-1))0 then begin n:=i+1; m[n]:=copy(s,1,length(s)-1); end;
max:=m[1]; min:=m[1];
for i:=2 to n do begin if length(m[i])>length(max) then max:=m[i];
if length(m[i])
writeln('MakS: ',max);
writeln('MIN: ',min);
readln; readln;
end.
12.Описание: Счет количества вхождений каждого символа в строку.
program one;
Var I: Word; M: Array [0..255] Of Byte; S: String;
Begin For I := 0 To 255 Do M[I] := 0;
writeln('input string');
Readln(S);
For I := 1 To Length(S) Do Begin Inc(M[ORD(S[I])]); End;
For I := 0 To 255 Do Begin If M[I] > 0 Then WriteLn(CHR(I):3, M[I]:3); End; readln;
End.
13.Описание: Удаление пробелов из заданной строки и вывод результата.
program one;
Var S,T: String; I: Integer;
Begin writeln('input string');
readln(s);
T := '';
For I := 1 To Length(S) Do Begin If (S[I] ' ') Then T := T + S[I];
End;
WriteLn(T);
ReadLn;
End.
14.Описание: Вывести заданный символ заданное количество раз
program one;
uses crt;
var n:byte; l:string;n function zvezda(n:byte;l:string):real; var i:integer; s:string;
begin i:=1;
s:='';
while i
inc(i); end;
writeln(s); end;
begin clrscr;
writeln('Vvedite chislo'); readln(n);
writeln('Vvedite simvol'); readln(l);
zvezda(n,l);
readkey;
end.
15.Описание: Заменить строку звездочками, если строка содержит кавычки
Program one;
var S: string; i: integer;
found: boolean;
begin Write('vvedite stroku simvolov: ');
Readln(S); Found := FALSE;
for i := 1 to Length(S) do {Length(s) = длиннастроки, стандартнаяфункция}
if s[i] = '''' then found := TRUE; if Found then {еслинайденсимвол"",заменяем}
for i := 1 to Length(S) do s[i] := '*'; Writeln('Rezultiruyuschaya stroka: ', S);
readln;
end
продолжение
--PAGE_BREAK--
Раздел: Графика
1.Описание: Зеленый перевернутый лист папоротника, заполняющийся точками. --PAGE_BREAK--
dx:=getmaxx div 10-random(getmaxx div 5); dy:=getmaxy div 30-random(getmaxy div 15); goto loop end until keypressed;
if readkey=#0 then x:=ord(readkey);
closegraph end
end. --PAGE_BREAK--