Основные приемы работы в среде ТР

Актюбинский Политехнический колледж

Отчет

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

по программированию

Выполнила:

Волоснова А.С

учащаяся

группы 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.	Изучили принцип работы в графическом режиме.

СОДЕРЖАНИЕ.

1. Линейная программа на Паскаль.

2. Программа с ветвлениями.

3. Циклическая программа.

4. Массивы.

5. Процедуры и функции.

6. Файловые данные в Паскале.

7. Записи в Паскале.

8. Строки.

9. Графика в Турбо-Паскале.

Раздел: Линейные алгоритмы

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.

2.Описание: Программа вычисления площади треугольника.

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.

3.Описание: Программа вычисления количества теплоты по формуле '
Q
=
c
*
m
*(
t
2-
t
1)

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

4.Описание: Программа вычисления величины силы тока I на участке цепи с R Ом и U В.

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.

5.Описание: Программа вычисления расстояния между двумя точками с данными координатами x1,
y
1,
x
2,
y
2

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.

6.Описание: Известна сумма денег,имеющаяся у покупателя и стоимость одной ед. товара. Сколько ед. товара может купить покупатель и какова его сдача?

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.

7.Описание: Сумма цыфр введенного трехзначного натурального числа.

program one;

uses crt;

var a:integer; s,d,e,f:real;

begin clrscr;

writeln ('vvedi 3-hznachnoe chislo');

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.

8.Описание: Найти площадь по известной стороне равностороннего треугольника.

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.

9.Описание: Бабушка вяжет в неделю 3 пары детских носков, пару женских и пару мужских и продает их. Считая, что в месяце 4 недели,определить,какую прибыль бабушка имеет за месяцю.

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

10.Описание: Пирамида из звездочек

program one;

uses crt;

var j,i:integer;

begin clrscr;textcolor(9+5);

for i:=1 to 25 do begin gotoxy(40-i,i);

for j:=2 to 2*i do write('*');

end;

readln;

end.

11.Описание:Вычислить произведение

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.

12.Описание: Вычисление радиуса

Program one;

Uses crt;

Var l:real; r:integer;

begin clrscr;textcolor(5);

writeln ('R=');

readln (r);

l:=2*pi*r;

writeln (‘radius=,r’);

end.

13.Описание: Вычисление периметра квадрата

Program one;

Uses crt;Var а:integer;

begin clrscr;textcolor(5);

writeln ('a=');

readln (a);

p:=4*a;

writeln (‘perimetr=,р’);

end.

14.Описание: Выведение введенного числа

Program one;

Uses crt;Var s:integer;

begin clrscr;textcolor(5);

writeln ('s=');

readln (s);

writeln (‘вы ввели число,s’);

end.

15.Описание: Вычисление плотности по количеству жителей и площади.

Program one;

Uses crt;Var k,s:integer; p:real;

begin clrscr;textcolor(5);

writeln ('число жителей=');

readln (k);

writeln (‘plosh=’);

readln (s);

p:=s/k;

writeln (‘plotnost=’,p);

end.

Раздел: Разветвляющиеся алгоритмы

1.Описание: Вычисление уравнения

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.

2.Описание: Деление нацело

Program ch;

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.

3 .Описание: Написать программу на языке
Pascal
для реализации разветвляющегося алгоритма, где x – известные величины.

program one;

var x,y:real;

begin writeln('');

write('Vvedite x=');

readln(x); if x<=0.8 then

y:=exp(x-1)+3.14 else if (0.8<x) and (X<=5.27) then

y:=ln(x+5.96) else y:=2*x;

writeln('y=',y:4:2); readln;end.

4. Описание: Написать программу на языке Pascal для реализации разветвляющегося алгоритма, где x – известные величины.

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.

5 .Описание: Написать программу на языке Pascal для реализации разветвляющегося алгоритма, где x=ln a2
, y=1/arctg b; a,b – известные величины.

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.

6. Описание: Заданы два прямоугольных параллелепипеда. Можно ли разместить их один в другом?

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 ((a1<=a2) and (b1<=b2) and (c1<=c2)) or ((a1>a2) and (b1>b2) and (c1>c2)) then writeln('mogno') else writeln('nelzya'); readln; end.

7. Описание: номер клетки на шахматной доске 8х8 определяется двумя целыми числами - номер вертикали и номер горизонтали. Даны 4 целых положительных числа a,b,c,d. Выяснить, бьет ли ферзь, находящийся на клетке (a,b) клетку(c,d)

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

8. Описание: Возможно, ли построить треугольник с данными сторонами

program one;

uses crt;

var a,b,c:real;

begin clrscr;

writeln('Стороны треугольника= ');

readln(a,b,c);

if (a<b+c) and (b<a+c)

and(c<a+b) then write('можно')

else write('невозможно');

readkey;

end.

9 .Описание: Даны три неравных числа
a
,
b
,
c
. Составить программу нахождения квадрата большего из этих чисел.

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.

10.Описание:Вычисление большего из двух чисел

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.

11.Описание:Вычисление меньшего из двух чисел

Program m_ch;

Uses crt;

Var a,b:integer;

Min:integer;

Begin clrscr;

Writeln (‘a= b=’);

Readln (a,b);

If a<b then min:=a else min:=b

Writeln (‘min=’,min);

End.

12.Описание:Деление нацело

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.

13.Описание: Сравнение чисел трехзначного числа

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<b) and (b<i) then writeln (‘ravny’)

else writeln (‘ne ravny’);

End.

14.Описание: Принадлежит ли число интервалу

Program ch;

Uses crt;

Var a:integer;

Begin clrscr;

Writeln (‘a=’);

Readln (a);

if (a>=(-5)) and (a<=3) then writeln (‘prinadl’)

else writeln (‘ ne prinadl’);

End.

15.Описание:Сравнить 3 стороны треугольника

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.

Раздел: Алгоритмы циклической структуры:

1.Описание: Написать программу на языке Pascal для реализации циклического алгоритма n, х – известные величины.

var i,j,fact,n:integer;

s,x:real;

begin

writeln;

write('Vvedite n=');

readln(n);

write('Vvedite x=');

readln(x);

s:=0;

for i:=1 to n do begin fact:=1;

for j:=1 to i do Fact:=fact*j;

s:=s+(1/fact+sqrt(abs(x)));

end;

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

readln;

end.

2.Описание: Написать программу на языке Pascal для реализации циклического алгоритма

n – известные величины.
program one;

var i,j,n,zn,factorial:integer; s,x:real; begin writeln; write('Vvedite n='); readln(n); s:=0; factorial:=1; zn:=1; for i:=1 to n do begin zn:=zn*(-1); factorial:=factorial*i; s:=s+(zn*(i+1)/factorial); end; writeln('s=',s:4:3); readln; end.

3.Описание: Написать программу на языке Pascal для реализации циклического алгоритма

s=1/1*2-1/2*3+…+(-1)n+1
/n(n+1) n – известные величины.

program one;

var i,j,n,zn:intege r; s,x:real; begin writeln; write('Vvedite n='); readln(n); s:=0; zn:=-1; for i:=1 to n do begin zn:=zn*(-1); s:=s+zn/(i*(i+1)); end; writeln('s=',s:4:2); readln; end.

4
.Описание: Написать программу на языке Pascal для реализации циклического алгоритма

n – известные величины.
program one;

var i,j,n:integer; stepen:integer; s:real; begin writeln; write('Vvedite n='); readln(n); s:=0; for i:=1 to n do begin stepen:=1; for j:=1 to 5 do begin stepen:=stepen*i; end; s:=s+1/stepen; end; writeln('s=',s:4:2); readln; end.

5. Описание: Написать программу, которая выводит целые четные числа с клавиатуры и складывает их , пока не будет введено число 0.

Program 5;

Uses crt;

Var n,s:integer.;

Begin clrscr;

S:=0;

Repeat;

Writeln(vvedi chislo);

Readln(n);

S:=s+n;

Until n=0;

Writeln(s=,s);

Readln;

End.

6. Описание: Составить программу, подсчета суммы
S
первых 1000 членов гармонического ряда 1+1/2+1/3+…+1/
N

Program 1;

Uses crt;

Var s:real; n;integer;

Begin clrscr;

S:=0; n:=0;

Repeat;

N:=n+1;

S:=s+1/n;

Until n=1000;

Writeln(s);

End.

7. Описание: Напечатать 20 первых степеней числа 2.

Program 2;

Uses crt;

Var n,s:longint;

Begin clrscr;

S:=1;

N:=1;

Repeat S:=s*2;

Writeln(s,);

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 a<>b 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<1000 do begin N:=n+1;

S:=s+1/n;

End;

Writeln(s);

Readln;

End.

11.Описание:Имеется четыре (
A
,
B
,
C
,
D
) числа. Необходимо ответить на вопрос:«Правда ли что все среди этих чисел есть равные?»Ответ вывести в виде текста:«Правда», или «Неправда».

Program z1;

var a,b,c,d:integer; {описываем имеющиеся переменные}

begin writeln('vvedite chislo a'); {вводим все числа по очереди}

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

program z2;

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)

until f+6<0;

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 Описание: Найти, сколько раз каждый элемент встречается в массиве

Дополнительных массивов не создавать.

Program msv;

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<=Size); Randomize;

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<=Size);

Randomize;

a[1]:=Random(Step);

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<=Size);

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]<=b[ib] then begin c[i]:=a[ia];

if ia<n1 then Inc(ia) else begin a[n1]:=b[ib];

if ib<n2 then Inc (ib); end; end

else begin c[i]:=b[ib];

if ib<n2 then Inc(ib) else begin b[n2]:=a[ia];

if ia<n1 then Inc(ia); end; end;

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. Описание: Дан числовой массив. Вычислить сумму элементов,имеющих четное значение индекса. Вычислительную часть организовать в виде функции

Program msv;

Uses crt;

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
. Найти сумму его элементов

Program msv;

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;

begin writeln;

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. Описание: Найти максимальный элемент в линейном массиве.

Вывести результат на экран

program msv;

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] <= max then {esli a[i] <= max to udalyaem etot element}

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)

Program msv;

Const n = 10; {кол-вл элементов массива}

var a, b, t : integer; X: array[1..n] of integer; {сам массив из n элементов}

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<X[b]) do Begin X [b+1]:= X[b];

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] < Min) then Begin Min := 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]) < abs(a[i])) then Begin a[i] := a[i] + 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;

BEGIN writeln('Условие:');

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<0 then angle:=180+angle;

writeln('Угол между векторами: ',angle:7:3,' градусов');

END.

14. Описание: Вычислить сумму двух векторов, первый из которых вводится, а элементы второго вычисляются по формуле
b
[
i
]:=
sin
(
i
*
x
), где 0<=
x
<=3.14

program msv;

const Nm = 10; {размерность вектора}

var Vec1, Vec2, ResVec : array[1..Nm] of Real; i : integer; x : Real; N : integer;

BEGIN writeln('Условие :');

writeln(' вычислить сумму двух векторов, первый из которых вводится, а элементы');

writeln(' второго вычисляются по формуле b[i]:=sin(i*x), где 0<=x<=3.14');

writeln;

Write('введите размерность вектора (N<', Nm, '): ');

Readln(N);

if n <= Nm then begin Writeln('Ввод вектора');

for i := 1 to N do begin Write('Vec1[', i, '] : ');

Readln(Vec1[i]); end;

Write('Введите X (от 0 до 3.14) : '); Readln(x);

if (X <= 3.14) and (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');

end else Writeln('неверная размерность');

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;

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 <3 then begin m := m + 10;

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<=31) and (m>=1) and (m<=12) and (y>=1582) and (y<=4903) then Writeday(d,m,y) else begin writeln ('Nekorrektnyj vvod!');end;end;

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<=n do begin s:=s+'*';

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 := (-1)*Exp(B*Ln(T)) else 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<=n do begin s:=s+l;

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 < a) then begin min := 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) < abs(geometricmean - a)) thenbegin writeln('arifmeticheskomu (',average:0:3,')');

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.Описание:Арккосинус числа. Нахождение из математических соображений

var ca,al,albeg: real; function ArcCos(arg:real):real;

var r:real;

begin if (abs(arg)>1) then begin writeln(' Unavailable argument ');

halt; end;

if abs(arg)<0.000001 then r := pi/2 else r := ArcTan(sqrt(1/arg/arg-1)); { arccos }

if arg<0 then r:=pi-r;

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 <= 57) );

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)<0 then begin YH:=0.5*(p+s);

while abs(F(YH)) > EPS do begin If F(p)*F(YH) <0 then S:=YH else P:=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<1 ');} end; end;

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<=length(s)) do begin sb:=sb+s[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 IOresult<>0 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 IOresult<>0 then begin

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 IOresult<>0 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<6);

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:tptp6Arif.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<=length(s)) do begin sb:=sb+s[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.Описание: Удаление следующих друг за другом нескольких пробелов из файла.

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<=right_value)) then begin new_left:=center;

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.

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<=B) Do Begin WriteLn (FName,X,' | ',F(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<=length(wrd) do begin if wrd[i]<>' ' then sl:=sl+1;

while (wrd[i]<>' ') and (i<=length(wrd)) do inc(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.

15
Задан тектовый файл, содержащий текст. Определить сколько раз встречается в нем самое длинное слово.

program
tp7; 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 ioresult<>0 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;

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;

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 < CalkChar(Temp,M.ch) Then Begin M.num := I;

M.wrd := CalkChar(Temp,M.ch); End;

If N.wrd < CalkChar(Temp,N.ch) Then Begin N.num := I;

N.wrd := CalkChar(Temp,N.ch); End;

Delete(S,1,P); Inc(I); End;

If M.wrd < CalkChar(S,M.ch) Then Begin M.num := I;

M.wrd := CalkChar(S,M.ch); End;

If N.wrd < CalkChar(S,N.ch) Then Begin N.num := I;

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 <= Vozrast) And (Vozrast <= F[I].max) And (F[I].Sale <= Cena) Then Begin

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 <= 20):'); readln(n); for i:=1 to n do begin writeln('Vvedite svedeniya o ',i,'-om bagaje passajira:'); writeln('Vvedite ves bagaja: '); readln(bagage[i].ves); writeln('Vvedite kol-vo veshei bagaja: '); readln(bagage[i].kol_veshei);end; clrscr; writeln('Bagage, sredniy ves odnoi veshi otlichaetsya ne bolee'); writeln('chem na 0.3 kg ot obshego srednego vesa:'); writeln; a:=true; for i:=1 to n do begin rez:=bagage[i].ves/bagage[i].kol_veshei; if (abs(bagage[i].ves - rez) <= 0.3) then begin a:=false; writeln('Bagage nomer ',i); writeln('ves bagaja: ',(bagage[i].ves):5:2,' kg'); writeln('kol-vo veshei: ',bagage[i].kol_veshei);writeln; end;end; if (a) then writeln('Takogo bagaja net!'); writeln; writeln('Kol-vo passajirov imeyushih bolee 2 veshei:'); writeln; temp:=0; for i:=1 to n do if (bagage[i].kol_veshei > 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.

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 <= 0 then break;

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;

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)<3 then writeln('*',m[i]); end; readln;

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) < Length(Copy(C,1,Pb-1)) Then MaxL := Copy(C,1,Pb-1);

Delete(C,1,Pb); End;

If Length(MaxL) < Length(C) Then MaxL := C;

WriteLn;

WriteLn('Samaya bolshayaposledovatelnost'simvolov v predlojenii:');

WriteLn(MaxL);

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 <=79 simvolov'); goto 1; end;

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])<length(min) then min:=m[i]; end;writeln;

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<=n do begin s:=s+l;

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

Раздел: Графика

1.Описание:
Зеленый перевернутый лист папоротника, заполняющийся точками.

program Fract;

uses Graph,Crt;

var Dt,M : integer; R,A,B,C,D,E,F, NewY,NewX,X,Y : real;

begin Dt := Detect;

InitGraph(Dt, M,'');

Randomize;

X := 0; Y := 0;

repeat R := Random;

if R>0.93 then begin A := -0.15; B := 0.28; C := 0.26; D := 0.24; E := 0; F := 0.44;

end else if R>0.86 then begin A := 0.2; B := -0.26; C := 0.23; D := 0.23; E := 0; F := 1.6;

end else if R>0.01 then begin A := 0.85; B := 0.02; C := -0.02; D := 0.85; E := 0; F := 1.6;

end else begin A := 0; B := 0; C := 0; D := 0.16; E := 0; F := 0; end;

NewX := A*X + B*Y + E; NewY := C*X + D*Y + F; X := NewX; Y := NewY;

PutPixel(Round(X*50)+100,Round(Y*50)+50, Green);

until(Keypressed);

CloseGraph;

end.

2.Описание: Стрелочные часы с быстроидущей секундной стрелкой и показом реального времени.

Program 4as;

uses graph, crt, dos;

type TPoint = record

x, y: Real; end;

var H, M, S, Hund : Word; Xc, Yc, i : Integer; P, P2, P3, P4, P5, P6 : TPoint;

procedure Dec2Polar(Ang, Len: Real; var P: TPoint);

begin Ang := Ang - 90; { Correlation for our coord system }

P.x := Xc + Len * cos(Ang * Pi / 180);

P.y := Yc + Len * sin(Ang * Pi / 180);end;

begin i := 0;

InitGraph(i, i, '');

Xc := GetMaxX div 2; Yc := GetMaxY div 2; SetColor(10);

Circle(Xc, Yc, Yc - 30); SetColor(2); Circle(Xc, Yc, 3); SetColor(14);

for i := 0 to 23 do begin Dec2Polar(i * 15, Yc - 40, P);

Circle(Round(P.x), Round(P.y), 2 + 3*Byte(i mod 2 = 0)); end;{ SetLineStyle(0, 0, 3);}

while not keypressed do begin { Erase } SetColor(0); Line(Round(P2.x), Round(P2.y), Round(P.x), Round(P.y));

Line(Round(P4.x), Round(P4.y), Round(P3.x), Round(P3.y));

Line(Round(P6.x), Round(P6.y), Round(P5.x), Round(P5.y));

GetTime(H, M, S, Hund); { Second arrow }

Dec2Polar((S + Hund/100) * 6, Yc - 50, P);

Dec2Polar((S + Hund/100) * 6, 5, P2); { Minute arrow }

Dec2Polar((M + S/60) * 6, Yc - 100, P3);

Dec2Polar((M + S/60) * 6, 5, P4); Dec2Polar((H + M/60) * 30, Yc - 150, P5);

Dec2Polar((H + M/60) * 30, 5, P6); { Redraw } SetColor(15);

Line(Round(P2.x), Round(P2.y), Round(P.x), Round(P.y)); SetColor(9);

Line(Round(P4.x), Round(P4.y), Round(P3.x), Round(P3.y)); SetColor(7);

Line(Round(P6.x), Round(P6.y), Round(P5.x), Round(P5.y)); delay(1000); end; CloseGraph;

end.

3.Описание:
Скачущий мяч с постепенным снижением амплитуды.

program ufo;

uses crt,graph; const r=20;h=5; var gd,gm,i,n,t,x,y,p:integer;

begin clrscr;

gd:=Detect;

initgraph(gd,gm,'c:bpbgi '); setcolor(4); setlinestyle(0,1,1);

line(0,479,639,479);

x:=r;y:=r; t:=479-2*r; n:=t div h; p:=h;

while n<>0 do begin for i:=1 to n do begin setcolor(2); circle(x,y,r); setfillstyle(1,2);

floodfill(x,y,2); delay(10);

setcolor(0); circle(x,y,r);

setfillstyle(1,0); floodfill(x,y,0);

y:=y+p; x:=x+1; end;

if p>0 then begin t:=round(3*t/4);n:=t div h end;

p:=-p end; setcolor(12); circle(x,y,r);

setfillstyle(1,2);

floodfill(x,y,12);

repeat until keypressed;closegraph

end.

4.Описание: Нло в замкнутом пространстве на фоне звездного неба.

program ufo;

uses graph,crt;

const r=20; pause=50; var d,m,e,xm,ym,x,y,lx,ly,rx,ry, size,i,dx,dy,width,height:integer; saucer:pointer;

label loop;

begin d:=detect;

initgraph(d,m,'');

e:=graphresult;

if e<> grok then writeln(grapherrormsg(e)) else begin x:=r*5; y:=r*2;

xm:=getmaxx div 4; ym:=getmaxy div 4;

ellipse(x,y,0,360,r,r div 3+2); ellipse(x,y-4,190,357,r,r div 3);

line(x+7,y-6,x+10,y-12); line(x-7,y-6,x-10,y-12);

circle(x+10,y-12,2); circle(x-10,y-12,2);

floodfill(x+1,y+4,white);

lx:=x-r-1; ly:=y-14;

rx:=x+r+1; ry:=y+r div 3+3;

width:=rx-lx+1; height:=ry-ly+1;

size:=imagesize(lx,ly,rx,ry);

getmem(saucer,size); getimage(lx,ly,rx,ry,saucer^);

putimage(lx,ly,saucer^,xorput);

rectangle(xm,ym,3*xm,3*ym);

setviewport(xm+1,ym+1,3*xm-1,3*ym-1,clipon); xm:=2*xm; ym:=2*ym;

for i:=1 to 200 do

putpixel(random(xm),random(ym),white);

x:=xm div 2;

y:=ym div 2;

dx:=10; dy:=10; repeat putimage(x,y,saucer^,xorput); delay(999);

putimage(x,y,saucer^,xorput);

loop: x:=x+dx; y:=y+dy;

if (x<0) or (x+width+1>xm) or (y<0) or (y+height+1>ym) then begin x:=x-dx; y:=y-dy;

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.

5.Описание: Заполнение квадрата случайными линиями разных цветов.

program graphik;

uses graph,crt;

var d,r,e:integer; x1,y1,x2,y2:integer;

begin clrscr;

d:=detect;

initgraph(d,r,'');

e:=graphresult;

if e <> grok then writeln(grapherrormsg(e)) else begin x1:=getmaxx div 3;

y1:=getmaxy div 3;

x2:=4*x1;y2:=4*y1;

rectangle(x1,y1,x2,y2);

setviewport(x1+1,y1+1,x2-1,y2-1,clipon);

repeat setcolor(succ(random(16)));

line(random(x2-x1),random(y2-y1),random(x2-x1),random(y2-y1))

until keypressed;

if readkey=#0 then d:=ord(readkey);

closegraph

end end.

6.Описание: Медленно выезжающий кусок пирога или пиццы.

program pie;

uses crt,graph;

var graphdriver,graphmode,errorcode:integer; j,v,l,m,k,i:integer;

begin graphdriver:=detect;

initgraph(graphdriver,graphmode,'');

errorcode:=graphresult;

if errorcode<>grOk then begin writeln('ЋиЁЎЄ Ја дЁЄЁ: ',graphErrorMsg(errorcode));

writeln('Џа®Ја ¬¬ ў аЁ©­® § ўҐаиЁ« а Ў®вг...');

halt(1); end;

setcolor(yellow);

circle(200,200,50);

floodfill(199,199,yellow);

delay(30000);

setcolor(black);

pieslice(200,200,30,60,50);

for i:=1 to 20 do begin setcolor(yellow);

pieslice(200+i,200-i,30,60,50);

setcolor(black);

pieslice(200+i,200-i,30,60,50);

delay(30000);

i:=i+1; end;

readkey;

closegraph;

end.

7.Описание: Статичное изображение двухколесного велосипеда.

program gr;

uses graph;

var grDriver:integer;

grMobe:integer;

Begin grDriver:=Detect;

InitGraph(grDriver,grMobe,'');

SetColor(12);

circle(200,150,30);circle(200,150,23);circle(330,150,30);circle(330,150,23);line(200,150,280,150);line(280,150,320,110);line(320,110,210,110);line(210,110,250,150);line(200,150,210,110);circle(200,150,5);circle(270,150,10);line(270,150,270,170);line(265,170,275,170);line(200,145,270,140);line(200,155,270,160);line(330,150,320,110);line(320,110,320,98);line(320,98,310,98);line(210,110,210,100);circle(210,100,5);line(210,100,220,100);line(270,150,270,130);line(265,130,275,130);readln;

End.

8.Описание: Приближающийся на смотрящего квадрат. Увеличение размеров по времени.

program gr;

uses graph,crt;

VAR x,y,i:integer;

PROCEDURE grafika_on;

Var drv,mode:integer;

BEGIN drv:=9; {VGA }mode:=2; {VGAHi}

initgraph(drv,mode,'');END;

BEGIN grafika_on;

x:=300; y:=200;

for i:=1 to 100 do begin setcolor(9);

rectangle(x-i,y-i,x+i,y+i);

delay(100); setcolor(0); rectangle(x-i,y-i,x+i,y+i);

end; readkey; closegraph;

END.

9. Описание:Строительство башни по блокам.

program gr;

Uses crt, Graph;Var P:pointer;Size:Word; X1,Y1:Word; gd,gm: integer;

Begin gd:=detect;

InitGraph(gd,gm,'');

IF GraphResult<>0 THEN Halt(1);

SetViewPort(0,0,640,80,TRUE);

ClearViewPort;

SetBkColor(black);SetColor(yellow);

SetLineStyle(0,1,Thickwidth);Rectangle(120,400,200,440);

Size:=ImageSize(120,400,200,440);

GetMem(p,Size);

GetImage(120,400,200,440,P^);

Y1:=440;

WHILE Y1>=40 DO begin X1:= 120;

begin PutImage(X1,Y1,p^,CopyPut); Delay(59000);

X1:=X1+80 end;

Y1:=Y1-40 end; x1:=x1-160;WHILE X1<=280 DO Begin PutImage(X1,Y1,p^,CopyPut);

X1:=X1 +160 end;

setfillstyle(8,red);

Bar(200,40,280,500); Bar(40,40,120,500);

SetColor(11);SETTEXTSTYLE(6,7,6);

outtextxy(350,100,'BASHNYA!');Readln;

CloseGraph End.

10. Описание:Пульсирующее сердце (анимация).

program gr;

uses crt,graph;var driver,mode,error:integer; l,n,m,x,y,r:integer;

begin driver:=detect;

initgraph(driver,mode,'');

error:=graphresult;

if error<>grOk then begin writeln('ЋиЁЎЄ Ја дЁЄЁ: ',graphErrorMsg(error));

writeln('Џа®Ја ¬¬ ў аЁ©­® § ўҐаиЁ« а Ў®вг...'); halt(1); end;

m:=1;l:=1;x:=1;y:=1;r:=1;n:=1;

repeat x:=1;y:=1;r:=1;l:=1;

repeat begin setcolor(cyan);

arc(170-x,150,0,180,20+r); arc(210+x,150,0,180,20+r);

line(150-2*x,150,190,200+y); line(230+2*x,150,190,200+y);

floodfill(149,150,cyan);

x:=x+1;y:=y+1;r:=r+1;

delay(20); clearviewport;

l:=l+1; end; until l=20;

x:=1;y:=1;r:=1;m:=1;

repeat setcolor(cyan);

arc(150+x,150,0,180,40-r); arc(230-x,150,0,180,40-r);

line(110+2*x,150,190,220-y); line(270-2*x,150,190,220-y);

floodfill(149,150,cyan);

x:=x+1;y:=y+1;r:=r+1;m:=m+1; delay(20);

clearviewport; until m=20; n:=n+1; until n=20; closegraph;

end.

11. Описание:
Динамическое изображение планеты сатурн с помощью эллипсов.

program graphik;

uses graph,crt;

var a,b,e:integer;

begin a:=detect;

initgraph(a,b,'');

e:=graphresult;

if e<>grok then writeln(grapherrormsg(e))

else begin repeat setlinestyle(2,5,2*2+5);

setcolor(random(3));

ellipse(300,250,128,52,random(300),random(100));

setcolor(random(8));

ellipse(300,250,0,360,random(200),200);

until keypressed;

closegraph;end

end.

12.Описание: Медленно поднимающийся вверх воздушный шар.

Program one;

uses crt,graph;

var gd,gm,y,size:integer; p:pointer;

begin initgraph(gd,gm,'');size:=imagesize(50,200,150,400);getmem(p,size);setcolor(14);

setfillstyle(1,14);arc(100,250,0,180,50);line(50,250,150,250);

floodfill(120,240,14);setcolor(1);line(50,250,75,350);

line(150,250,125,350);setcolor(4);setfillstyle(1,4);

bar(75,350,125,400);

getimage(50,200,150,400,p^);setfillstyle(1,0);

for y:=480 downto 0 do begin putimage(50,y,p^,1);delay(1000);cleardevice;

bar(50,y,150,y+100);

end; readln; closegraph;

end.

13.Описание:
Снеговики стоят в несколько рядов один за другим.

program snegovik;

uses graph;

var i,j,x,y:integer;grdriver:integer;grmode:integer;begin grdriver:=detect;initgraph(grdriver,grmode,'c');

x:=50;y:=30;

for i:=1 to 10 do begin for j:=1 to 10 do begin setcolor(blue);

circle(x,y,10);circle(x,y+30,20);

circle(x,y+80,30);circle(x-30,y+30,10);

circle(x+30,y+30,10);setcolor(5);

line(x,y-5,x+15,y);line(x,y+5,x+15,y);setcolor(white);

line(x-5,y+5,x+5,y+5);

putpixel(x-5,y-5,white);putpixel(x+5,y-5,white);

putpixel(x,y+20,white);putpixel(x,y+30,white);

putpixel(x,y+40,white);putpixel(x,y+60,white);

putpixel(x,y+70,white);putpixel(x,y+80,white);

putpixel(x,y+90,white);putpixel(x,y+100,white);setcolor(3);

line(x-5,y-10,x+5,y-10);line(x+5,y-10,x,y-20);line(x,y-20,x-5,y-10);

x:=x+90;end;

y:=y+160;x:=50;

end;readln

end.

14.Описание:
Снежика, рисуемая в зависимости от длины и количества лучей и глубины рекурсии.

Program Snezhinka;

Uses crt, graph;

const k = 150; n = 8; g = 4;

var gd, gm: integer; procedure Snezhinka_v_zh (x, y: word; r, c: byte); var alpha: real; i: byte; xd, yd: integer;

begin if c < 1 then exit;

for i := 1 to n do

begin alpha := 2 * Pi * i / n;

xd := round(x + r * cos(alpha));

yd := round(y + r * sin(alpha));

moveto(x, y); lineto(xd, yd);

Snezhinka_v_zh(xd, yd, r div 3, c - 1); end; end;

BEGIN initgraph(gd, gm, 'h:tpbgi'); setcolor(11);

snezhinka_v_zh(320, 240, k, g); readkey;

closegraph;

END.

15.Описание:
Нарисовать радугу, используя элипсные дуги разных цветов.

Program Raduga;

Uses Graph;

var D,M,y,i : Integer;

begin D := Detect;

InitGraph(D,M,'');

if GraphResult <> grOk then WriteLn(GraphErrorMsg(GraphResult)) else begin y:=200;

for i:=1 to 30 do begin if i<5 then SetColor(4); if (i>5)and(i<10) then SetColor(14); if (i>10)and(i<15) then SetColor(2); if (i>20)and(i<25) then SetColor(1); if i>25 then SetColor(13);

Ellipse(325,y,10,170,240,150); inc(y); end;

Readln; CloseGraph; end;

end.