Отчет по практике: Редактирование и отладка программ с помощью Pascal

Отчет по практике: Редактирование и отладка программ с помощью Pascal

АКТЮБИНСКИЙ ПОЛИТЕХНИЧЕСКИЙ КОЛЛЕДЖ

ОТЧЕТ

ПО УЧЕБНОЙ ПРАКТИКЕ

Выполнил: Журмухамедов Марат

Проверила: Гайсагалеева Б.М.

АКТОБЕ 2010 г.

ДНЕВНИК

Содержание

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

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

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

Массивы

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

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

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

Строки

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

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

Задание 1. Составить алгоритм вычисления y=55*(a +b)

program as;                                                                   Блок-схема

uses crt;

var a,b,c,y:integer;

begin clrscr;

writeln('Введи значение a,b);

readln(a,b);

y:=55*c;

writeln('y=',y);

end.

(Вводим значение 5,3)

Ответ:440

Задание 2. Составить алгоритм обмена значений 2х переменных A и B

program as;                                                                   Блок-схема

uses crt;

var a,b,c:integer;

begin clrscr;

writeln(‘Введи значение a,b');

readln(a,b);

c:=a;

b:=c;

writeln('obmen',a,'-',b);

readln;

end.

(Вводим значение 5,6)

Ответ: 6,5

Задание 3. Вычислить площадь огорода, имеющего форму прямоугольника, если известны стороны А и В

program as;                                                                  Блок-схема

uses crt;

var a,b,c:integer;

begin clrscr;

writeln('Введи стороны А и В ');

readln(a,b);

writeln('Площадь огорода =',c);

readln;

end.

(Вводим значение 5,6)

Ответ:22

Задание 4. Найти среднее арифметическое чисел x,y,z

program as;                                               Блок-схема

uses crt;

var x,y,z:integer; d:real;

begin clrscr;

writeln('Bведи x,y,z');

readln(x,y,z);

writeln(d:5:2);

readln;

end.

(Вводим значение 5,6,7)

Ответ: 6.00

Задание 5.Найти массу х литров молока, если известно, что плотность молока р кг/м3

program as;                                                                  Блок-схема

uses crt;

var x,p,m:real;

begin clrscr;

writeln('Bведи х(литры),р(плотность)молока ');

m:=x/100*p;

writeln(m);

readln;

end.

(Вводим значение 7л, 1030кг/м3)

Ответ: 7,21 кг

Задание 6.Объем цилиндра равен V,а площадь основания – S. Какова высота цилиндра H?

program as;                                                                  Блок-схема

uses crt;

var v,s,h:real;

begin clrscr;

writeln('Введи объем цилиндра и площ. его осн. ');

readln(v,s);

writeln('Высота цилиндра=',H);

readln;

end.

(Вводим значение 10,5)

Ответ: 2м

Задание 7.Дана длина куба а. Найти объем куба v и площадь его боковой поверхности s.

program as;

uses crt;

var v,s,a:real;

begin clrscr;

readln(a);

v:=a*a*a;

s:=4*a*a;

writeln(‘объем=’,v,’площ.бок.пов.=’,s);

readln;

end.

(Вводим значение 5)

Ответ:v=125,s=100

Задание 8. Составить алгоритм вычисления y=22*((a +b)/2)

program as;                                               Блок-схема

uses crt;

var a,b,c:integer; d,y:real;

begin clrscr;

writeln('Введи значение а,b');

readln(a,b);

y:=sqr(2)*d;

readln;

end.

(Вводим значение 5,5)

Ответ: 20

Задание 9.Известна длина окружности.Найти площадь круга, огранич. этой окружностью

program as;                                               Блок-схема

uses crt;

var a,b:real;

begin clrscr;

writeln('Введи длину окужности');

readln(a);

writeln('Найти S круга=',b:5:2);

end.

(Вводим значение 5)

Ответ:78,5

Задание10. Дано натуральное число n(n>9).Найти число единиц в нем

program as;                                                                  Блок-схема

uses crt;

var a,d:integer;

begin clrscr;

writeln('Введи натуральное чисно');

readln(a);

writeln('Число единиц в нем=',d);

readln;

end.

(Вводим значение 6)

Ответ: единиц=6

Задание11.Дано расстояние в сантиметрах. Найти число полных метров в нем.

program as;                                                                  Блок-схема

uses crt;

var a,m:integer;

begin clrscr;

writeln('Введи расстояние в сантиметрах');

readln(a);

writeln('Получи расстояние в метрах',m);

readln;

end.

(Вводим значение 200)

Ответ: 2м

Задание12. Составить алгоритм вычисления y=7x2-3x+6

program as;                                                        Блок-схема

uses crt;

var x,y:integer;

begin clrscr;

writeln('Bведи значение х ');

y:=7*(sqr(x))-3*x+6;

writeln('Y=',y);

end.

(Вводим значение 6)

Ответ: 240

Задание13.Каков объем кислорода, содержащегося в комнате размером a*b*c,если кислород составляет 21% объема воздуха?

program as;                                                                  Блок-схема

uses crt;

var a,b,c,v:real;

begin clrscr;

writeln('Bвeди a,b,c');

readln(a,b,c);

writeln('объем кислорода=',v);

readln;

end.

(Вводим значение 5,6,7)

Ответ: 4.41

Задание14. Составить алгоритм вычисления A=x2+bx/2

program as;  Блок-схема

uses crt;

var a,b,x,z,s,v:real;

begin clrscr;

writeln('Введи значение x,b');

s:=b*x;

A:=v/2;

readln;

end.

(Вводим значение 2,3)

Ответ: 1.9

Задание15.Определить время падения камня на поверхность земли с высоты h.

program as;                                                        Блок-схема

uses crt;

var g,t,h:real;

begin clrscr;

writeln('Введи значение h');

t:=sqrt(2*h/g);

readln;

end.

(Вводим значение 10 м)

Ответ: 1,4278с

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

Задание 1.Даны 2 целых числа, определить какое из них больше

Program as;                                                        Блок-схема

Uses crt;

Var a,b:integer;

 Max:integer;

Begin clrscr;

Writeln(‘Введи 2 числа’);

Readln(a,b);

Writeln(‘Максимально=’,max);

Readln;

End.

(Вводим значение 5,6)

Ответ: 6

Задание 2.Известны стороны треугольника, определить равны ли его стороны (равноб) или разносторон.

program as;                                                                  Блок-схема

uses crt;

var a,b,c:integer;

begin clrscr;

writeln('Введи стороны ');

readln(a,b,c);

if (a=b) or (a=c) or (c=b)  Да Нет

then writeln('равноб.') else writeln

('разност.');

readln;

end.

(Вводим значение 5,5,6)

Ответ: Равноб.

Задание 3.Проверить, принадлежит ли число, введенное с клавиатуры, интервалу (-5;3).

Program as;                                                                  Блок-схема

Uses crt;

Var a,b,x:integer;

Begin clrscr;

Readln(x);

If (x>=-5) and (x<=3) then

Writeln(‘да’) else writeln(‘нет’);

End.

(Вводим значение 2)

Ответ: Принадлежит

Задание 4.Дано 2х зн. число. Определить входит ли в него цифра 3

Program as;                                                        Блок-схема

Uses crt;

Var a: integer;

Begin clrscr;

Writeln(‘Введи 2х зн. число’);

Readln(a);

If (a div 10=3) or (a mod 10=3)

Then writeln(‘Входит’);

Else writeln(‘Не входит’);

Readln;

End.

(Вводим значение 53)

Ответ: Входит

Задание 5. Дано 2х зн. число. Определить какая из его цифр больше

Program as; Блок-схема

Uses crt;

Var a,d,e, max: integer;

Begin clrscr;

Writeln(‘Дано 2х зн. число’);

D:=a div 10;

E:=a mod 10;

If d>e then max:=d else max:=e;

Writeln(‘Макс=’,max);

Readln;

(Вводим значение 96)

Ответ: 9

Задание 6.Даны 2 целых числа А и В, выяснить яв. ли 2 числа, четными

Program as;                                                                  Блок-схема

Var a,b: integer;

Begin clrscr;

Writeln(‘Введи 2 целых числа А и В’);

Readln (a,b);

If a mod 2=0 then writeln(‘четное’)

 else writeln(‘не четное’);

If b mod 2=0 then writeln(‘четное’);

 else writeln(‘не четное’);

Readln;

End.

(Вводим значение 5,6)

Ответ: не четное, четное

Задание 7.Решить пример -4x2+8,x<0

Y= 

x2 +3x+4,x>0                                                     Блок-схема

Program as;

Uses crt;

Var x,y:integer;

Begin clrscr;

Writeln(‘Введи аргумент x’);

Readln(x);

If x>0 then Y:=-4*sqr(x)+8

writeln(‘Y=’,y);

readln;

end.

Задание 8. Даны три вещественных числа a,b,c. Проверить выполняется ли неравенство a<b<c.

program as;                                                                  Блок-схема

uses crt;

var a,b,c:integer;

begin clrscr;

writeln(‘Введи три числа’);

readln(a,b,c);

if (a<b) and (b<c) then writeln(‘верно’)

 else writeln(‘не верно’);

readln;

end.

(Вводим значение 5,6,7)

Ответ: выполняется

Задание 9.Даны три вещественных числа. Определить, имеется ли среди них хотя бы пара равных между собой чисел

Program as;                                                        Блок- схема

Uses crt;

Var a,b,c:integer;

Begin clrscr;

Writeln(‘Введи 3 числа’);

Readln(a,b,c);

If (a=b) or (a=c) or (b=c) then writeln(‘имеется’)

 else writeln(‘не имеется’);

end.

(Вводим значение 5,6,7)

Ответ: не имеется

Задание10.Дано вещественное число. Вывести на экран его абсолютную величину

Program as;                                                        Блок-схема

Uses crt;

Var a:real;

Begin clrscr;

Readln(a);

if (a>0) or (a<0)then writeln(abs(a):5:2);

readln;

end.

(Вводим значение 56)

Ответ: получаем абсол. величину.

Задание11. Даны 2 целых числа, определить какое из них меньше

Program as;                                                        Блок-схема

Uses crt;

Var a,b:integer;

 Min:integer;

Begin clrscr;

Writeln(‘Введи 2 числа’);

Readln(a,b);

Writeln(‘Минимальное=’,min);

Readln;

End.

(Вводим значение 5,6) Ответ: 5

Задание12. Даны 2 числа. Если кв.корень из второго числа меньше первого числа, то увеличить второе число в 5 раз

program as;                                                                  Блок-схема

uses crt;

var a,b,d,c:real;

begin clrscr;

writeln(‘Введи 2 числа’);

readln(a,b);

c:=sqrt(b);

if (d<c) then

writeln(‘увеличить 2 число в 5 раз’,c*c*c*c*c:5:2)

 else writeln(‘нет решения’);

readln;

end.

Ответ: нет решения

Задание13. Дано число. Если это число чётное, то /2 если нет, то *2

Program as;                                                        Блок-схема

Var a: integer;

Begin clrscr;

Writeln(‘Введи число’);

Readln (a);

If a mod 2=0 then writeln(a/2)

 else writeln(a*2);

Readln;

End.

(Вводим значение 5)

Ответ:10

Задание14.Даны 4 вещественных числа. Найти сумму тех чисел, которые больше 5

Program as;                                                        Блок-схема

Uses crt;

Var a,b,c,d,k,z,x,v:integer;

Begin clrscr;

Writeln(‘Введи 4 числа’);

Readln(a,b,c,d);

If a>5 then k:=a;

If b>5 then z:=b;

If c>5 then x:=c;

If d>5 then v:=d;

Writeln(‘Общая сумма=’,k+z+x+v);

End.

(Вводим значение 6,6,6,6)

Ответ: 24

Задание15.Даны 3 числа a,b,c. Найти максимальное

Program as;                                                        Блок-схема

Uses crt;

Var a,b,c:integer;

 Max,max1:integer;

Begin clrscr;

Writeln(‘Введи 3 числа’);

Readln(a,b,c);

If max>c then max1:=max else max1:=c;

Writeln(‘Максимально=’,max1);

Readln;

(Вводим значение 5,6,7)

Ответ: 7

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

Задание 1.Напечатать “столбиком”: все целые числа от 20 до 35

Program as;                                                        Блок-схема

Uses crt;

Var a:integer;

For a:=20 to 35 do writeln(a);

Readln;

end.

Задание 2.Напечатать “столбиком”: квадраты всех целых чисел от 10 до b (значение b вводится с клавиатуры, причем b>10)

Program as;                                                        Блок-схема

Uses crt;

Var a,j:integer;

Writeln(‘Введи число’);

Readln(j);

For a:=10 to j do writeln(sqrt(a):5:2);

Readln;

end.

		A+1

Задание 3.Найти сумму квадратов всех целых чисел от 10 до 50

Program as;

Uses crt;

Begin clrscr;

For a:=10 to 50 do s:=sqr(a)+s;

Writeln(s);

Задание 4.Одна штука некоторого товара стоит 20 тенге. Напечатать таблицу стоимости 2,3…20 штук этого товара

Блок-схема

Program as;

Var a,b:integer;

Begin clrscr;

B:=20;

For a:=2 to 20 do writeln(a*b);

Readln;

end.

Задание 5. Найти произведение всех целых чисел от 1 до А (значение А вводится с клавиатуры; 1<=A<=20.

program as;                                                         Блок-схема.

uses crt;

begin clrscr;

p:=1;

readln(a);

for b:=1 to a do if (1<=a) and (a<=20) then

p:=p*a;

writeln(p);

readln;

end.  

 Ответ:256

Задание 6.Напечатать программу, печатающую таблицу значений функции y=cos2x на отрезке [0;1] с шагом h=0,1

Program as;                                               Блок-схема

Uses crt;  

Var y,x:real;

X:=0;

While x<=1 do begin y:=cos(2*x);

Writeln(y:5:2);

End;

End.

Задание 7.Напечатать программу, вычисления факториала

Program as;                                               Блок-схема

Uses crt;  

Var i,n:integer;

Begin clrscr;

Readln(n);

F:=1; i:=1;

While i<=n do begin f:=f*i;

end;

Writeln(‘факториал от’,n,’равен’,f);

End.

Задание 8.Программа подсчета суммы S первых 1000 членов гармонического ряда 1+1/2+1/3+…1/N

Program as;                                               Блок-схема

Uses crt;  

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.

Задание 9.Вычислить наибольший общий делитель двух натуральных чисел А и В.

Program as;                                               Блок-схема

Uses crt;  

Var a,b:integer;

Begin clrscr;

writeln(‘Введи 2 натур. Числа’);

readln(a,b);

While a<>b do if a>b then a:=a-b

 Else b:=b-a;

Readln;

End.

Задание10. Даны целые числа А и В (а>b).Определить: Результат целочисленного деления А на В, не используя стандартную операцию целочисленного деления

Program as;                                               Блок-схема

Uses crt;  

Var a,b,n:integer;

Begin clrscr;

writeln(‘Введи 2 числа,a>b’);

readln(a,b);

While a<=b do begin

 N:=n+1;

A:=a-b;

\ End;

Writeln(‘результат=’,n);

Readln;

End.

Задание11.Напишите программу, которая вводит целые числа с клавиатуры и складывает их, пока не будет введено число 0

Program as;                                     Блок-схема

Uses crt;

Var N,s:integer;

S:=0;

Repeat write (‘Введи число’);

S:=s+n;

Until n=0;

Writeln(‘S=’,s);

Readln;

End.

Задание12. Напечатайте 20 первых степеней числа 2

Program as;                                     Блок-схема

Uses crt;

Var N,s:longint;

Repeat s:=s*2;

Write(s,’ ‘);

 N:=n+1;

Until n>20;

Readln;

End.

Задание13. Известны оценки по информатике 20 учеников класса. В начале списка перечислены все пятерки, затем все остальные оценки. Сколько учеников имеют по инфор-ке оценку «5»?

Program as; Блок-схема

Uses crt;

Var x,n:integer;

Begin clrscr;

Write(‘Введи оценку’);

Readln(x);

N:=0;

N:=n+1;

 Write(‘Введи оценку’);

 Readln(x);

End;

Writeln(‘имеют отлично’,n,’учеников’);

End.

Задание14.Вывести на экран таблицу умножения.

Program as; Блок-схема

Uses crt;

Var I,j:integer;

For i:=1 to 9 do

 For j:=1 to 9 do writeln(I,*,j,’ ‘,i*j);

Readln;

Задание15.Составить программу, печатающую на экране все четные числа в диапазоне от 100 до 999.

Program as;  Блок-схема

Uses crt;

Var a:integer;

For a:=100 to 999 do

 If a mod 2=0 then writeln(a);

End.

Массивы

Задание 1.Создать одномерный массив и найти сумму четных элементов и произведение нечетных элементов

program as;

uses crt;

var a:array[1..5] of integer;

i,s,p:integer;

begin clrscr;

for i:=1 to 5 do a[i]:=random(8);

for i:=1 to 5 do begin

writeln;

for i:=1 to 5 do write(a[i]:5);

end;

writeln;

for i:=1 to 5 do

if a[i] mod 2=0 then

s:=s+a[i]; writeln;

p:=1;

for i:=1 to 5 do

if a[i] mod 2<>0 then p:=p*a[i];

writeln;

writeln(s);

writeln(p);

end.

Задание 2.Составить программу формирования одномерного массива и вычисления произведения всех элементов массива

program as;

uses crt;

var a:array[1..5] of integer;

i,s,p:integer;

begin clrscr;

for i:=1 to 5 do a[i]:=random(8);

for i:=1 to 5 do begin

writeln;

for i:=1 to 5 do write(a[i]:5);

end;

writeln;

p:=1;

for i:=1 to 5 do p:=p*a[i];

writeln(p); end.

Задание 3.Дан одномерный массив вычислить произведение всех четных элементов массива

program as;

uses crt;

var a:array[1..5] of integer;

i,s,p:integer;

begin clrscr;

for i:=1 to 5 do a[i]:=random(8);

for i:=1 to 5 do begin

writeln;

for i:=1 to 5 do write(a[i]:5);

end;

writeln;

p:=1;

for i:=1 to 5 do if a[i] mod 2=0 then p:=p*a[i];

writeln(p);

end.

Задание 4.Дан массив вычислить сумму всех элементов больше 5

program as;

uses crt;

var a:array[1..5] of integer;

i,s,p:integer;

begin clrscr;

for i:=1 to 5 do a[i]:=random(88);

for i:=1 to 5 do begin

writeln;

for i:=1 to 5 do write(a[i]:5);

end;

writeln;

for i:=1 to 5 do if a[i]>5 then p:=p+a[i];

writeln(p);

readln;

end.

Задание 5.Подщитать кол-во элементов равных 7

program as;

uses crt;

var a:array[1..7] of integer;

i,s,p:integer;

begin clrscr;

for i:=1 to 7 do a[i]:=random(88);

for i:=1 to 7 do begin

writeln;

for i:=1 to 7 do write(a[i]:5);

end;

writeln;

for i:=1 to 7 do if a[i]=7 then p:=p+1;

writeln(p);

readln;

end.

Задание 6. Дан массив умножить все элементы на 20

program as;

uses crt;

var a:array[1..7] of integer;

i,s,p:integer;

begin clrscr;

for i:=1 to 7 do a[i]:=random(88);

for i:=1 to 7 do begin

writeln;

for i:=1 to 7 do write(a[i]:5);

end;

writeln;

for i:=1 to 7 do

write(a[i]*20:3);

readln;

end.

Задание 7. Дан массив все четные элементы заменить на 2, а не четные удвоить

program as;

uses crt;

var a:array[1..7] of integer;

i,s,p:integer;

begin clrscr;

for i:=1 to 7 do a[i]:=random(88);

for i:=1 to 7 do begin

writeln;

for i:=1 to 7 do write(a[i]:5);

end;

writeln;

for i:=1 to 7 do if a[i] mod 2=0 then writeln(sqr(a[i]));

for i:=1 to 7 do if a[i] mod 2<>0 then writeln(2*a[i]);

readln;

end.

Задание 8. Дан одномерный массив найти максимальный элемент

program as;

uses crt;

var a:array[1..15] of integer;

i,max:integer;

begin clrscr;

for i:=1 to 15 do a[i]:=random(88);

for i:=1 to 15 do begin

writeln;

for i:=1 to 15 do write(a[i]:5);

end;

writeln;

max:=1;

for i:=1 to 15 do if a[i] >a[max] then max:=i;

writeln(a[max]);

readln;

end.

Задание 9. Дан одномерный массив найти min элемент

program as;

uses crt;

var a:array[1..15] of integer;

i,min:integer;

begin clrscr;

for i:=1 to 15 do a[i]:=random(88);

for i:=1 to 15 do begin

writeln;

for i:=1 to 15 do write(a[i]:5);

end;

writeln;

min:=1;

for i:=1 to 15 do if a[i]<a[min] then min:=i;

writeln(a[min]);

readln;

end.

Задание10. Дан массив скопировать все его элементы в другой массив такого же элемента

program as;

uses crt;

var a:array[1..15] of integer;

I,b:integer;

begin clrscr;

for i:=1 to 15 do a[i]:=random(88);

for i:=1 to 15 do begin

writeln;

for i:=1 to 15 do write(a[i]:5);

end;

writeln;

for i:=1 to 15 do a[i]:=b[i];

for i:=1 to 15 do write(a[i]);

writeln(‘скопир’);

for i:=1 to 15 do write(b[i]:4);

readln;

end.

Задание11. Составить программу обмена первого и третьего элем. строки матрицы

program as;

uses crt;

var a:array[1..15] of integer;

I,b,c:integer;

begin clrscr;

for i:=1 to 15 do a[i]:=random(88);

for i:=1 to 15 do begin

writeln;

for i:=1 to 15 do write(a[i]:5);

end;

writeln;

c:=a[1];

a[1]:=a[3];

a[3]:=c;

for i:=1 to 15 do write(a[i]:5);

end.

Задание12. Дан 2 мерный массив. Вывести на экран все элементы второй строки

program as;

uses crt;

var a:array[1..4,1..4] of integer;

i,j:integer;

begin clrscr;

for i:=1 to 4 do

for j:=1 to 4 do a[i,j]:=random(99);

for i:=1 to 4 do begin

writeln;

for j:=1 to 4 do write(a[i,j]:5);

end;

writeln;

writeln;

for j:=1 to 4 do write(a[2,j]:3);

end.

Задание13. Дан одномерный массив. Поменять содержимое двух произвольных ячеек

program as;

uses crt;

var a:array [1..10] of integer;

i,k,m:integer;

begin clrscr;

writeln;

for i:=1 to 10 do a[i]:=random(99);

for i:=1 to 10 do write(a[i]:5);

writeln;

writeln;

k:=a[2];

a[2]:=a[4];

a[4]:=k;

for i:=1 to 10 do write(a[i]:5);

end.

Задание14. Дан 2 мерный массив. Заменить все элементы кратные 5, нулями

program as;

uses crt;

var a:array[1..5,1..5] of integer;

i,j,s:integer;

begin clrscr;

for i:=1 to 5 do

for j:=1 to 5 do a[i,j]:=random(6);

for i:=1 to 5 do begin

writeln;

for j:=1 to 5 do write(a[i,j]:5);

end;

writeln;

for i:=1 to 5 do

for j:=1 to 5 do begin

if a[i,j] mod 5=0 then a[i,j]:=0;

end;

for i:=1 to 5 do begin writeln;

for j:=1 to 5 do write(a[i,j]:5);

end;

end.

Задание15. Дан массив вычислить сумму всех элементов больше 20

program as; end;

uses crt;  writeln;

var a:array[1..10] of integer; for i:=1 to 10 do if a[i]>20 then p:=p+a[i];

i,s,p:integer;  writeln(p);

begin clrscr;  readln;

for i:=1 to 10 do a[i]:=random(88); end.

for i:=1 to 10 do begin

writeln;

for i:=1 to 10 do write(a[i]:5);

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

Задание 1. Составить программу вычисления числа сочетания C= n!(n-m)!

program as;

uses crt;

var m,n,p1,p2,p3:integer;

c:real;

procedure factor(x:integer; var p:integer);

var i:integer;

begin p:=1;

for i:=1 to x do p:=p*i;

end;

begin clrscr;

writeln('Vvedi m,n');

readln(m,n);

factor(m,p1);

factor(n,p2);

factor(n-m,p3);

c:=p1/(p2*p3);

writeln(c:5:2);

end.

Задание 2. Составить программу нахождения меньшего из 5 заданных чисел, используя процедуру нахождения меньшего из 2 заданных чисел

Program as;

Uses crt;

Var a,b,c,d,e,z1,z2,z3,z4,z5:integer;

Procedure min(x,y:integer; var z:integer);

Begin;

If x<y then z:=x else z:=y;

Writeln(z);

End;

Begin clrscr;

Readln(a,b,c,d,e);

Min(a,b,z1);

Min(z1,c,z3);

Min(z3,d,z4);

Min(z4,e,z5);

End.

Задание 3. Написать программу нахождения суммы большего и меньшего из 3 заданных чисел

Program as;

Uses crt;

Var a,b,c,d,v,v1,max,max1,min,min1:integer;

Procedure ma(x,y,z:integer; var v:integer);

Begin clrscr;

If x<y then max:=x else max:=y;

If max<z then max1:=max else max1:=z;

If x>y then min:=x else min:=y;

If min>z then min1:=min else min1:=z;

V:=min1+max1;

End;

Begin clrscr;

Readln(a,b,c);

Ma(a,b,c,v1);

Writeln(v1);

End.

Задание 4. Составить программу вычисления суммой фактор. всех четных чисел от m до n

program as;

uses crt;

var a,b,c,n,m,s,k,p1,p:integer;

procedure factor(x:integer; var p:integer);

var i:integer;

begin p:=1;

for i:=1 to x do begin p:=p*I; end;

writeln(p);

end;

begin clrscr;

writeln( Vvedi n,m’);

readln(n,m);

for k:=n to m do if k mod 2=0 then begin

factor(k,p1);

s:=s+p1;

end;

writeln(s);

end.

Задание 5. Даны 5 чисел, найти их наибольший общий делитель, используя процедуру. Для алгоритма их вида

program as;

uses crt;

var a,b,c,d,e,z1,z2,z3,z:integer;

procedure E(x,y:integer; var z:integer);

begin

while x<>y do if x>y then x:=x-y

else y:=y-1;

z:=x;

end;

begin clrscr;

writeln( Vvedi a,b,c,d,e’);

readln(a,b,c,d,e);

E(a,b,z);

E(c,d,z1);

E(z,z1,z2);

E(z2,e,z3);

writeln(z3);

end.

 M!

Задание 6. Составить программу вычисления числа сочетания C= n!(n-m)! с помощью функции

program as;

uses crt;

var f1,f2,f3,m,m1,n:integer;

c:real;

Function factor(n:integer):integer;

var p,i:integer;

begin p:=1;

for i:=1 to n do p:=p*i;

factor:=p;

end;

begin

read(m, n);

f1:=factor(m);

f2:=factor(n);

m1:=n-m;

f3:=factor(m1);

c:=f1/(f2*m1);

writeln(c:5:2);

end.

Задание 7. Найти НОК двух чисел по формуле НОК(a,b)=НОД

Program as;

Uses crt;

Var m, n,z,nod,a,nok:integer;

Procedure F (a,b:integer; var nod:integer);

Begin

While a<>b do if a>b then a:=a-b else b:=b-a;

Nod:=a;

End;

Begin clrscr;

Readln(m,n);

F (m,n,z);

Nok:= trunk (z/(m*n));

Writeln(nok);

End.

Задание 8. Трехугольник задан с координ. своих вершин. Составить программу вычисления его периметра

Program as;

Uses crt;

Var a1,a2,c1,c2,b1,b2:integer;

d1,d2,d3,d:real;

c,p:real;

procedure F(x1,x2,y1,y2:integer; var d:read);

begin

d:=sqrt(sqr(x2-x1)+sqr(y2-y1));

writeln(d:5:2);

end;

begin clrscr;

readln(a1,a2,b1,b2,d1,d2);

F(a1,a2,c1,c2,d1);

F(c1,c2,b1,b2,d2);

F(d1,d2,a1,a2,d3);

P:=d1+d2+d3;

Writeln(p:8:5);

End.

Задание 9. Увеличить вдвое все элементы массива

program as;

const          n=10; m=20;

type T1 = array[1..n] of integer;

T2 = array[-m..m] of integer;

var    A: T1;         B: T2;         k: integer;

Procedure Double(var X: array of integer);

var i: byte;

begin

for i:=0 to High(X)-1 do X[i]:=X[i]*2;

end;

begin

for k:=1 to n do read(A[k]);

for k:=-m to m do read(B[k]);

Double(A);

Double(B);

Double(k);

writeln('k=',k);

for k:=1 to n do write(A[k],' ');

writeln;

for k:=-m to m do write(B[k],' ');

end.

Задание 10. Использование типизированных констант

program typed_const;

var N:integer;

procedure Test;

const k:integer=1;

begin

if k<N then

begin

writeln(k,'-й вызов процедуры');

k:=k+1;     

Test;

end

else writeln('последний вызов процедуры');

end;

begin

read(N);

if N>0 then Test;

end.

Задание 11. Вычислить N-е число Фиббоначчи

program Fib;

var n:byte;

function F(k:byte):word;

begin

if k<2 then F:=1 else F:=F(k-1)+F(k-2);

end;

begin

write('введите номер числа Фиббоначчи ');

readln(N);

writeln(N,'-е число Фиббоначчи =',F(N));

readln

end.

Задание12. Даны 5 чисел, найти их наибольший общий делитель, используя процедуру. Для алгоритма их вида

program as;

uses crt;

var a,b,c,d,e,z1,z2,z3,z:integer;

procedure E(x,y:integer; var z:integer);

begin

while x<>y do if x>y then x:=x-y

else y:=y-1;

z:=x;

end;

begin clrscr;

writeln( Vvedi a,b,c,d,e’);

readln(a,b,c,d,e);

E(a,b,z);

E(c,d,z1);

E(z,z1,z2);

E(z2,e,z3);

writeln(z3);

end.

Задание13. Трехугольник задан с координ. своих вершин. Составить программу вычисления его периметра

Program as;

Uses crt;

Var a1,a2,c1,c2,b1,b2:integer;

d1,d2,d3,d:real;

c,p:real;

procedure F(x1,x2,y1,y2:integer; var d:read);

begin

d:=sqrt(sqr(x2-x1)+sqr(y2-y1));

writeln(d:5:2);

end;

begin clrscr;

readln(a1,a2,b1,b2,d1,d2);

F(a1,a2,c1,c2,d1);

F(c1,c2,b1,b2,d2);

F(d1,d2,a1,a2,d3);

P:=d1+d2+d3;

Writeln(p:8:5);

End.

Задание14. Составить программу для вычисления определенного интеграла

tk

2t

I= S--------------- dt

sqrt(1-sin2t)

tn

вычисляется по формуле:

ISimps=2*h/3*(0.5*F(A)+2*F(A+h)+F(A+2*h)+2*F(A+3*h)+...

+2*F(B-h)+0.5*F(B))

Program INTEGRAL;

type

Func= function(x: Real): Real;

var

I,TN,TK:Real;

N:Integer;

{$F+}

Function Q(t: Real): Real;

begin

Q:=2*t/Sqrt(1-Sin(2*t));

end;

{$F-}

Procedure Simps(F:Func; a,b:Real; N:Integer; var INT:Real);

var

sum, h: Real;

j:Integer;

begin

if Odd(N) then N:=N+1;

h:=(b-a)/N;

sum:=0.5*(F(a)+F(b));

for j:=1 to N-1 do

sum:=sum+(j mod 2+1)*F(a+j*h);

INT:=2*h*sum/3

end; begin WriteLn(' ВВЕДИ TN,TK,N');

Read(TN,TK,N);

Simps(Q,TN,TK,N,I);

WriteLn('I=',I:8:3)

end.

Задание15. Записать отрезок -X(-1,-10), с помощью функции

program as;

function A(x:integer):integer;

begin

a:=-x;

end;

var i:integer;

begin

for i:=1 to 10 do writeln(a(i));

end.

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

Задание 1. Дан текстовый файл, посчитать кол-во строк в нем

Program as;

Uses crt;

Var F:text; a:string; s:integer;

Begin clrscr;

Assign (f,’a1.txt’);

Reset (f);

While not (eof(f)) do begin

Readln(f,a);

S:=s+1; end;

Close(f);

Writeln(s);

End.

Задание 2. Создать текстовый файл и записать в него фразу: «Здравствуй Мир!»

Program as;

Uses crt;

Var F:text; a:string;

Begin clrscr;

Assign (f,’a.txt’);

Rewrite (f);

Readln(a);

Writeln(f,a);

Close(f);

End.

Задание 3. Создать текстовый файл и записать в него слово «Привет»

Program as;

Uses crt;

Var F:text; a:string;

Begin clrscr;

Assign (f,’A.txt’);

Rewrite (f);

Readln(a);

Writeln(f,a);

Close(f);

End.

Задание 4. Создать текстовый файл и записать в него 5 одинаковых чисел

Program as;

Uses crt;

Var F:text; a:string; i:integer;

Begin clrscr;

Assign (f,’text.txt’);

Rewrite (f);

For i:=1 to 5 do

Writeln(f,5);

Close(f);

End.

Задание 5. Создать текстовый файл и записать в него все числа от 10 до 16

Program as;

Uses crt;

Var F:text; a:string; i:integer;

Begin clrscr;

Assign (f,’text.txt’);

Rewrite (f);

For i:=10 to 16 do

Writeln(f,i);

Close(f);

End.

Задание 6. Создать текстовый файл и записать в него 5 одинаковых слов

Program as;

Uses crt;

Var F:text; a:string;

Begin clrscr;

Assign (f,’A.txt’);

Rewrite (f);

Readln(a);

Writeln(f,a);

Close(f);

End.

Задание 7. Дан текстовый файл перенести его строки в другой файл

Program as;

Uses crt;

Var f,t:text; a:string;

Begin clrscr;

Assign(f,’202as.txt’); assign(t,’201as.txt’);

Reset(f); rewrite(t);

While not(eof(f)) do begin

Readln(f,a);

Writeln(t,a);

End;

Close(f);

Close(t);

Readln;

End.

Задание 8. Имеется текстовый файл, напечатать все его строки начиная с буквы Т

Program as;

Uses crt;

Var f:text; a:string;

Begin clrscr;

Assign(f,’202as.txt’);

Reset(f);

While not(eof(f)) do begin

Readln(f,a);

If copy (a,1,1)=’T’ then

Writeln(a);

End;

Close(f);

Readln;

End.

Задание 9. Имеется текстовый файл посчитать кол-во строк начинающихся на букву А

Program as; readln(f,a);

Uses crt; if copy(a,1,1)=’A’ then k:=k+1;

Var F:text; a:string; k:integer; end;

Begin clrscr;  close(f);

Assign(f,’abc.txt’); writeln(k);

Reset(f); end.

While not(Eof(f)) do begin

Задание10. Все четные строки этого файла записать во 2 файл, а не четные в 3 файл

Program as;

Uses crt;

Var F,t,g:text; a:string; k:integer;

Begin clrscr;

Assign(f,’abc.txt’); assign(t,’cop.txt’); Assign(g,’cap.txt’);

Reset(f); rewrite(t); rewrite(g);

While not(Eof(f)) do begin

Readln(f,a);

K:=k+1;

If k mod 2=0 then writeln(t,a) else writeln(g,a);

End;

Close(f); close(t); close(g);

End.

Задание11. Найти сумму элементов одномерного массива рез-т записать в текстовый файл

Program as;

Uses crt;

Var f:text; a:array[1..10] of integer; i,s:integer;

Begin clrscr;

Writeln(‘Ввод массива’);

Assign(f,’abc.txt’); rewrite(f);

For i:=1 to 10 do begin write(‘Введи’,I,’ элемент массива’);

Readln(a[i]);

End;

Writeln;

For i:=1 to 10 do s:=s+a[i];

Writeln(f,s);

Close(f);

End.

Задание12. Создать текстовый файл и записать в него все числа от 5 до 25

Program as;

Uses crt;

Var F:text; a:string; i:integer;

Begin clrscr;

Assign (f,’text.txt’);Rewrite (f);

For i:=5 to 25 do

Writeln(f,i);

Close(f);

End.

Задание13. Дано слово удвоить его каждую букву и записать его в текст. файл

Program as;

Uses crt;

Var f:text; a:string; I,s:integer;

Readln(a);

For i:=1 to length (a)*2 do begin insert

Copy(a,I,1),a,i);

I:=i+1;

End;

Writeln(f,a);

Close(f);

End.

Задание14. Имеется текстовый файл посчитать кол-во строк начинающихся на букву М

Program as;

Uses crt;

Var F:text; a:string; k:integer;

Begin clrscr;  

Assign(f,’abc.txt’);

Reset(f);

While not(Eof(f)) do begin

readln(f,a);

if copy(a,1,1)=’М’ then k:=k+1;

end; close(f);

writeln(k);

end.

Задание 15. Создать текстовый файл и записать в него 6 одинаковых чисел

Program as;

Uses crt;

Var F:text; a:string; i:integer;

Begin clrscr;

Assign (f,’text.txt’);

Rewrite (f);

For i:=1 to 6 do

Writeln(f,6);

Close(f);

End.

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

Задание 1. Составить список учебной группы, включающей 25 человек. Для каждого учащегося указать дату рождения, год поступления в техникум, курс, группу, оценки каждого года обучения. Информацию о каждом учащемся оформить в программе в виде записи. Совокупность записей объединить в массив.

Составить программу, которая обеспечивает ввод полученной информации, распечатку ее в виде таблицы, а также распечатку информации о отличниках

Program Pascal;

Uses crt;

type student=record

fio: string;

d_r:1..31;  {день рождения}

m_r:1..12; {месяц рождения}

god_r:1965..1975; {год рождения}

god_p:2004..2008;  {год поступления}

group:string; {название группы}

ocenki:array[1..3,1..5] of integer; {оценки по трем предметам}

end;

var

s1: array[1..25] of student;

i,j,x:integer;

ch:char;

f:boolean;

begin

clrscr;

for i:=1 to 25 do begin

writeln('Сведения о ',i,' студенте');

with s1[i] do begin

write('ФИО:');readln(fio);

write('Дата рождения:.. г.');

x:=wherex;

gotoxy(x-13,wherey); read(d_r);

gotoxy(x-10,wherey-1); read(m_r);

gotoxy(x-7,wherey-1); read(god_r);

if keypressed then begin

ch:=readkey;

if ch=#0 then ch:=readkey;

end;

write('Год поступления: ');readln(god_p);

write('Группа: ');readln(group);

j:=0;

for i:=god_p to 2008 do begin

j:=j+1;

writeln('Оценки за ',i,' год:');

write('Математика: ');readln(ocenki[1,j]);

write('Информатика: ');readln(ocenki[2,j]);

write('История: ');readln(ocenki[3,j]);

end;

end;

writeln;

end;

writeln('список отличников');

for i:=1 to 25 do begin

with s1[i] do begin

j:=0;

f:=true;

for i:=god_p to 2008 do begin

j:=j+1;

if not((ocenki[1,j]=5) and (ocenki[1,j]=5) and (ocenki[1,j]=5)) then f:=false;

end;

if f=true then writeln(fio,', группа ',group,', год поступления ',god_p);

end;

end;

writeln('Для выхода нажмите Enter');

readln;

end.

Задание 2. Разработать программу формирования файла, содержащего сведения о студентах. Каждый элемент этого файла должен содержать следующие данные: номер группы; номер в группе по списку; фамилию, имя, отчество; год рождения; оценки за последнюю сессию

Program Pascal;

Uses crt;

Const fname='students.dat';

n=5; {количество предметов за последнию сессию}

Type st=record

n_group:integer; {номер группы}

n_sp:integer;  {номер в группе по списку}

fam:string; {фамилия}

im:string; {имя}

ot:string; {отчество}

god_r:integer; {год рождения}

oc:array [1..n] of integer; {оценки за последнию сессию}

end;

Var t:array[1..30] of st;

i,ch,j:integer;

h: file of st;

begin

write('Введите количество студентов в группе: '); readln(ch);

for i:=1 to ch do begin

writeln('Сведения о ',i,' студенте');

write('Номер группы: '); readln(t[i].n_group);

write('Номер в группе по списку: '); readln(t[i].n_sp);

write('Фамилия: '); readln(t[i].fam);

write('Имя: '); readln(t[i].im);

write('Отчество: '); readln(t[i].ot);

write('Год рождения: '); readln(t[i].god_r);

writeln('Оценки за последнию сессию: ');

for j:=1 to n do begin

case j of

1:write('Математика: ');

2:write('Физика: ');

3:write('Химия: ');

4:write('Культурология: ');

5:write('История: ');

end;

readln(t[i].oc[j]);

if not ((t[i].oc[j]>0) and (t[i].oc[j]<=5)) then begin

writeln('Неверно введена оценка! Повторите ввод.');

j:=j-1;

end;

end;

writeln;

end;

Assign (h,fname);

{$I-}

reset(h);

If Ioresult<>0 then rewrite(h);

{$I+}

for i:=1 to ch do write(h,t[i]);

close(h);

writeln('Данные занесены в файл ',fname);

readln;

end.

Задание 3. В ГИБДД имеется следующая информация об автомобилях и их владельцах:

а) марка машины;

б) номер машины;

в) Фамилия владельца.

Необходимо организовать поиск количества автомобилей определенной марки. Информацию об автомобилях и их владельцах оформить в виде записей, хранимых в файле. Ввод данных в запись и сохранение записи в файле

Program N10_1;

Uses Crt;

Const fname='spisok.dat';

{Имя файла, в который будет производиться запись}

Type Person=record

marka:string;

number:string;

familia:string;

end;

Var auto:array[1..5] of person;

i:integer;

h: file of person;

begin

Clrscr;

auto[1].marka:='Мерседес';

auto[1].number:='235';

auto[1].familia:='Иванов';

auto[2].marka:='Мерседес';

auto[2].number:='289';

auto[2].familia:='Петров';

auto[3].marka:='Волга';

auto[3].number:='365';

auto[3].familia:='Сидоров';

auto[4].marka:='Жигули';

auto[4].number:='896';

auto[4].familia:='Кузнецов';

auto[5].marka:='Вольво';

auto[5].number:='957';

auto[5].familia:='Тимофеев';

Assign (h,fname);

{$I-}

reset(h);

If Ioresult<>0 then rewrite(h);

{$I+}

for i:=1 to 5 do begin

write(h,auto[i]);

end;

writeln('Данные занесены в файл ',fname);

write('Нажмите Enter');

readln;

end.

Выполнение задания

Program N10_2;

Uses Crt;

Const fname='spisok.dat';

Type Person=record

marka:string;

number:string;

familia:string;

end;

Var auto:array[1..5] of person;

i,j,l,q:integer;

h: file of person;

s:string;

f:boolean;

begin

Clrscr;

Assign (h,fname);

Reset (h);

i:=0;

While Eof (h) = false do begin

i:=i+1;

Read(h,auto[i]);

end;

Close(h);

writeln('Информация, считанная из файла ',fname);

writeln;

q:=i;

for j:=1 to q do begin

with auto[j] do begin

gotoxy(1,wherey);

write(marka);

gotoxy(15,wherey);

write(number);

gotoxy(20,wherey);

writeln(familia);

end;

end;

writeln;

write('Введите интересующую Вам марку автомобиля: ');

readln(s);

writeln;

l:=0;

for j:=1 to q do begin

with auto[j] do begin

if marka=s then begin

l:=l+1;

gotoxy(1,wherey);

write(number);

gotoxy(10,wherey);

writeln(familia);

end;

end;

end;

writeln('Количество автомобилей данной марки - ',l);

write('Нажмите Enter');

readln;

end.

Задание 4. На телефонном узле в конце каждого квартала составляется на каждого абонента ведомость оплаты междугородных телефонных разговоров (с 7-ю городами) в течение квартала (3 месяца)

Написать программу, которая вводит исходные данные, выполняет расчеты и выводит на экран:

ü  Исходные данные в виде таблицы, где указаны коды городов, с которыми велись разговоры, общее время разговора с каждым городом за один месяц, стоимость одной минуты разговора (меняется каждый месяц);

ü  Общая продолжительность разговоров с каждым городом за квартал;

ü  Плата за каждый месяц;

ü  Общая плата за 3 месяца;

ü  Город с наибольшей платой.

program kursovik;

uses crt;

type

telef=record

kod:integer;

tpm1,tpm2,tpm3,price1,price2,price3:integer;

end;

telef1=record

kod,tpm,ob:integer;

pr1,pr2,pr3:integer;

end;

var

a:file of telef;

res:array[1..7] of telef1;

i,j,s,aa,max:integer;

begin;

textbackground(10);

clrscr;

textcolor(0);

gotoxy(15,2);

writeln('Курсовая работа студента группы 01М22 Белоусовой Е.В.');

gotoxy(27,3);

writeln('Задание на курсовую работу:');

textcolor(4);

writeln;

writeln(' На телефонном узле в конце каждого квартала составляется на каждого абонента');

writeln('ведомость оплаты междугородных телефонных разговоров (с 7-ю городами) в течение');

writeln('квартала (3 месяца).');

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

writeln('выводит на экран:');

writeln(' - исходные данные в виде таблицы, где указаны коды городов, с которыми велись');

writeln(' разговоры, общее время разговора с каждым городом за один месяц, стоимость');

writeln(' одной минуты разговора (меняется каждый месяц);');

writeln(' - общая продолжительность разговоров с каждым городом за квартал;');

writeln('плата за каждый месяц;');

writeln('общая плата за 3 месяца;');

writeln('город с наибльшей платой.');

gotoxy(27,18);

textcolor(0);

writeln('Требование к вводу информации');

textcolor(4);

writeln(' - исходные данные вводятся с клавиатуры.');

textcolor(0);

writeln;

writeln(' Требование к выводу результатов');

textcolor(4);

writeln(' - результат выводятся на экран.');

textcolor(14);

writeln;

writeln(' Для продолжения работы программы нажмите ENTER');

readln;

clrscr;

textcolor(0);

writeln(' Требования к структуре программы ');

textcolor(4);

writeln(' Программа должна состоять из следующих частей:');

writeln(' - вывод заставки с информацией о студенте и задании;');

writeln(' - ввод данных (выполняется в диалоговом режиме);');

writeln(' - вывод исходных данных и результатов (на один экран).');

textcolor(0);

writeln(' Требования к размещению исходных данных внутри программы ');

textcolor(4);

writeln(' Исходные данные располагаются в файле, компонентами которого являются записи.');

writeln('Структура каждой записи и типы ее полей выбираются в зависимости от задания.');

textcolor(0);

writeln(' Используемые цвета ');

textcolor(4);

writeln(' - черный(0),красный(4), светло-зеленый(10), желтый(14)');

textcolor(14);

gotoxy(18,24);

writeln('Для продолжения работы программы нажмите ENTER');

readln;

clrscr;

assign(a,'kurs.dat');

rewrite(a);

textcolor(0);

for i:=1 to 7 do

begin

write('Введите код ',i,'-го города: ');

readln(tel.kod);

write('Введите общее время разговора с городом ',tel.kod,' за 1-й месяц: ');

readln(tel.tpm1);

write('Введите стоимость одной минуты разговора с городом ',tel.kod,' в 1-м месяце: ');

readln(tel.price1);

write('Введите общее время разговора с городом ',tel.kod,' за 2-й месяц: ');

readln(tel.tpm2);

write('Введите стоимость одной минуты разговора с городом ',tel.kod,' в 2-м месяце: ');

readln(tel.price2);

write('Введите общее время разговора с городом ',tel.kod,' за 3-й месяц: ');

readln(tel.tpm3);

write('Введите стоимость одной минуты разговора с городом ',tel.kod,' в 3-м месяце: ');

readln(tel.price3);

write(a,tel);

end;

close(a);reset(a);

s:=1;

while not eof(a) do begin

read(a,tel);

res[s].kod:=tel.kod;

res[s].tpm:=tel.tpm1+tel.tpm2+tel.tpm3;

res[s].pr1:=tel.tpm1*tel.price1;

res[s].pr2:=tel.tpm2*tel.price2;

res[s].pr3:=tel.tpm3*tel.price3;

res[s].ob:=res[s].pr1+res[s].pr2+res[s].pr3;

s:=s+1;

end;close(a);

clrscr;

writeln('Код города Общее время разговора за каждый месяц Стоимость минуты разговора');

reset(a);

while not eof(a) do

begin

read(a,tel);

writeln(' ',tel.tpm1,' ',tel.price1);

writeln(' ',tel.kod,' ',tel.tpm2,' ',tel.price2);

writeln(' ',tel.tpm3,' ',tel.price3);

end;

textcolor(14);

gotoxy(18,24);

writeln('Для продолжения работы программы нажмите ENTER');

readln;

clrscr;

textcolor(0);

writeln('Код города Общее время разговора за квартал Плата за месяц Общая плата');

for i:=1 to 7 do

begin

aa:=res[i].kod;

writeln(' ',res[i].pr1);

writeln(' ',aa,' ',res[i].tpm,' ',res[i].pr2,' ',res[i].ob);

writeln(' ',res[i].pr3);

end;

max:=res[1].ob;

for i:=1 to 6 do begin

if res[i+1].ob>max then

begin

max:=res[i+1].ob;

j:=i+1;

end;

end;

writeln('Город с наибольшей платой: ',res[j].kod);

textcolor(14);

gotoxy(18,24);

writeln('Для завершения работы программы нажмите ENTER');

readln;

end.

Задание 5 Упорядочить список студентов по среднему балу и распечатать его

Program spisok_grupp;

Uses Crt;

Const kurs=3;

Const kol=5;

Type

sved=record

famil:string[25];

datar:string[8];

god: integer;

gruppa: integer;

ocenki:array[1..3,1..5] of integer;

srball:array[1..25] of real;

End;

Var

spisok: array[1..25] of sved;

i,i1,j, s,mesto,n,g:integer;

max,t:real;

q:string[25];

Begin

ClrScr;

writeln('Введите количество учеников');

readln(n);

for i:=1 to n do

With spisok[i] do

Begin

Writeln ('Фамилия ',i,' студента');

Readln (famil);

Writeln('Дата рождения');

Readln (datar);

Writeln ('Год поступления');

Readln (god);

Writeln ('Группа');

Readln (gruppa);

s:=0;

for i1:=1 to kurs do

begin

writeln('Оценки ',i1,' года');

for j:=1 to kol do

Begin

Writeln (j,' Предмет');

Readln (ocenki[i1,j]);

s:=s+ocenki[i1,j];

End;

end;

srball[i]:=s/(kol*kurs);

ClrScr;

End;

writeln('Фамилия':8,'Дата рождения':16,'Год поступления':18,'Курс':7,'Группа':8);

for i:=1 to n do

begin

with spisok[i] do write(famil:8,datar:16,god:18,kurs:7,gruppa:8);

writeln;

writeln;

for g:=1 to kurs do

begin

write(g,' год:');

for j:=1 to kol do

with spisok[i] do write(ocenki[g,j]:4);

writeln;

end;

with spisok[i] do writeln('Средний бал =',srball[i]:6:2);

writeln;

end;

writeln;

writeln('По порядку');

for j:=1 to n do

Begin

max:=spisok[j].srball[j];

mesto:=j;

for i:=j to n do

if spisok[i].srball[i]<=max then

Begin

max:=spisok[i].srball[i];

mesto:=i;

End;

t:=spisok[j].srball[j];

spisok[j].srball[j]:=spisok[mesto].srball[mesto];

spisok[mesto].srball[mesto]:=t;

q:=spisok[j].famil;

spisok[j].famil:=spisok[mesto].famil;

spisok[mesto].famil:=q;

with spisok[j] do writeln(famil:8,srball[j]:6:2);

End;

End.

Задание 6. Запись с вариантами

var R = Record

rem: string;

Case byte of

3: (n:integer);

5: (x,y,z:char);

'a': (i,j:byte);

end;

begin

R.rem:='запись с ваpиантами';

R.n:=25000;

write(R.i,R.x,R.j,R.y); {168и97a}

{ord('и')=168, ord('a')=97, 168+97*256=25000}

end.

Задание 7. Пример объявления типа запись

type Men = Record

FIO,Adress: string;

Year: byte;

End;

var A,B: Men;

begin

A.FIO:='Иванов И.И.';

A.Adress:='пp. Ленина, д. 40, кв. 10';

A.Year:=1981;

end.

Задание 8. Составить программу в которой известны Фамилия, адрес и номера Телефонов 15 человек, организовать поиск номера телефона по фамилии абонента

Program as;

Type

person=record

surname: string[40]

adres: string[20]

nomer: integer

var

mas:array[1..15] of person;

i:integer; poisk: string;

procedure Input.date;

var

begin

writeln(‘Введи данные’,I,’ абонента’);

writeln(‘Фамилия’);

readln(mas[i].surname);

writeln(‘адрес’);

readln(mas[i].adres);

writeln(‘Номер телефона’);

readln(mas[i].nomer);

end;

Procedure write date;

Begin

With mas[i] do

Begin

Writeln(‘фамилия’,surname);

Writeln(‘адрес’,adres);

Writeln(‘номер’,nomer);

End;

End;

Begin

For i:=1 to 15 do Input.date;

Writeln(‘Введи фамилию абонента’);

Readln(poisk);

For i:=1 to 15 do

If mas[i] nomer=poisk then write date;

End.

Задание 9. Создать список учеников класса и вывести на экран Фамилии и Имена в виде таблицы

Program as;

Uses crt;

Type

Klass=record

Surname:string[15];

Name:string[10];

End;

Var A:array [1..10] of klass;

I:integer;

Begin clrscr;

For i:=1 to 10 do begin

Writeln(‘введи фамилию’);

Readln(a[i].surname);

Writeln(‘введи имя’);

Readln(a[i].name);

End;

Writeln;

Clrscr;

For i:=1 to 10 do writeln(a[i].surname,’ ‘,a[i].name);

End.

Задание10. Известны данные о 6 сотрудниках фирмы Фамилия, возраст, и отношение к воен.службе. Вывести на экран фамилии всех военнообязанных сотрудников

Program as;

Uses crt;

Type

S=record

N:string[10]; voz:integer;

V:string[8];

End;

Var a:array[1..6] of s;

I:integer;

Begin clrscr;

For i:=1 to 6 do begin

Writeln(‘какая у тебя фамилия’);

Readln(a[i].s);

Writeln(‘сколько тебе лет’);

Readln(a[i].voz);

Writeln(‘ты относешся к военной части’);

Readln(a[i].v);

End; Writeln; Clrscr;

For i:=1 to 6 do if a[i].v=’DA’ then writeln(a[i].s);

End.

Задание11. Даны названия 6 городов и стран, среди них есть город находящийся в Италии напечатать их название

Program as;

Uses crt;

Type

S=record

strana: string[10];

gorod:string[8];

End;

Var a:array[1..6] of s;

I:integer;

Begin clrscr;

For i:=1 to 6 do begin

Writeln(‘страна?’);

Readln(a[i].strana);

Writeln(‘город’);

Readln(a[i]. gorod);

End; Writeln; Clrscr;

For i:=1 to 6 do if a[i]. strana =’italia’ then writeln(a[i].gorod);

End.

Задание12. Даны названия 10 стран и частей света. Напечатать на экране все страны находящиеся в Азии

Program as;

Uses crt;

Type

S=record

strana: string[10];

ch:string[8];

End;

Var a:array[1..10] of s;

I:integer;

Begin clrscr;

For i:=1 to 10 do begin

Writeln(‘страна’);

Readln(a[i].strana);

Writeln(‘часть света’);

Readln(a[i]. ch);

End; Writeln; Clrscr;

For i:=1 to 10 do if a[i]. ch =’Azia’ then writeln(a[i]. strana);

End.

Задание13. Из ведомости 3-х студентов с их оценками (порядковый номер, Ф.И.О. и три оценки) определить количество отличников и средний бал каждого студента

Program Spic;

Type wed = record {Тип wed включает 3 поля: n, fio, bal}

n: integer;

fio: string[40];

bal: array [1..3] of integer {Поле bal – массив из 3 оценок }

end;

Var spisok: wed; {Запись spicok типа wed}

i, j, kol, s: integer; sr: real;

Begin

kol:=0; {kol- количество отличников}

With spisok do {with присоединяет имя записи spisok ко всем }

For i:=1 to 3 do { полям внутри цикла For по i }

begin

n:=i;

Write (' Vvedite FIO # ', i,' ');

Readln (fio);

s:=0;

For j:= 1 to 3 do

begin

write ('Vvedite ocenky: ');

readln (bal [j]);

s:= s+ bal [j];

end;

if s=15 then kol:=kol+1; {подсчет количества отличников}

sr:= s/3; writeln (fio, ', Sredniy bal = ', sr:4:1); end;

writeln (' Kolichestvo otlichnikov = ', kol);

readln;

end.

Задание14. Пусть нам необходимо заполнить сведения о студенте (Ф.И.О., дата рождения, адрес, курс и группа), а затем вывести эти сведения на экран

program primer1;

type anketa=record

fio: string[45];

dat_r: string[8];

adres: string[50];

curs: 1..5;

grupp: string[3]

end;

var student: anketa;

begin

writeln (‘введите сведения о студенте’);

{обратите внимание, ввод каждого поля осуществляется отдельно}

writeln (‘введите фамилию, имя и отчество’);

readln (student.fio);

writeln (‘введите дату рождения’);

readln (student.dat_r);

writeln (‘введите адрес’);

readln(student.adres);

writeln (‘введите курс’);

readln(student.curs);

writeln (‘введите группу’);

readln (student.grupp);

writeln (‘ввод закончен’);

writeln;

{обратите внимание, что вывод записи осуществляется по полям}

writeln (‘фамилия студента: ’, student. fio);

writeln( дата рождения: ’, student.dat_r);

writeln( адрес: ’, student.adres);

writeln( курс: ’, student.curs);

writeln( группа: ’, student.grupp);

end.

Задание15. Пусть нам необходимо иметь сведения о многих студентах, например, нашего факультета. Следовательно, необходимо организовать массив записей Паскаля. А затем из общего списка вывести фамилии студентов 2-го курса

program primer 2;

type anketa=record

fio: string[45];

dat_r: string[8];

adres: string[50];

curs: 1..5;

grupp: string[3]

end;

var student: array [1..100] of anketa;

I: integer;

begin

{последовательно вводим каждую запись}

for I:=1 to 100 do

begin

writeln (‘введите сведения о’, I, ‘-м студенте’);

writeln (‘введите фамилию, имя и отчество’);

readln (student[I].fio);

writeln (‘введите дату рождения’);

readln (student[I].dat_r);

writeln (‘введите адрес’);

readln(student[I].adres);

writeln (‘введите курс’);

readln(student[I].curs);

writeln (‘введите группу’);

readln (student[I].grupp);

end;

writeln (‘ввод закончен’);

writeln;

{просматриваем массив записей и выбираем только студентов 2-го курса }

for I:=1 to 100 do

if student[I].curs=2 then

writeln( фамилия студента: ’, student[I].fio);

end.

Строки

Задание 1. Дана последовательность слов. Напечатать те слова последовательности, которые отличны от последнего слова и удовлетворяют свойству: слово симметрично

Program Stroki;

Uses Crt;

Var s,k:string;

a:array[1..100] of string;

i,n,j,l:Integer;

f:boolean;

begin

ClrScr;

{Ввод последовательности слов}

Writeln('Введите последовательность слов:');

Readln(s);

{Запись слов в массив a}

for i:=1 to length(s) do begin

if (s[i-1]<>' ') and (s[i]=' ') and (length(k)<>0) then begin

inc(n);

a[n]:=k;

k:='';

end;

if s[i]<>' ' then k:=k+s[i];

if (i=length(s)) and (length(k)<>0) then begin

inc(n);

a[n]:=k;

k:='';

end;

end;

{Проверка на симметричность слов, содержащихся в массиве а}

l:=0;

for i:=1 to n-1 do begin

f:=false;

if a[i]<>a[n] then

if length(a[i]) mod 2 = 0 then begin

for j:=1 to length(a[i]) div 2 do

if a[i][j]<>a[i][length(a[i])+1-j] then f:=true;

if f=False then begin

l:=l+1;

if l=1 then Write('Симметричные слова: ');

Write(a[i],' ');

end;

end;

end;

Writeln;

if l=0 then Writeln('Симметричные слова отсутствуют');

Write('Нажмите Enter');

Readln;

end.

Задание 2. Дана строка символов. Преобразовать эту строку удалив из нее каждые ">>" и повторив (вставив еще раз) каждую пару символов "<<". После преобразования полученную строку вывести на печать

Program Stroki;

Uses Crt;

Var s:string;

i:integer;

begin

ClrScr;

Write('Введите строку символов: ');

Readln(s);

for i:=1 to length(s) do begin

if (s[i-1]='>') and (s[i]='>') then delete(s,i-1,2);

if (s[i-1]='<') and (s[i]='<') then begin

insert('<<',s,i-1);

i:=i+2;

end;

end;

Writeln('Преобразованная строка: ',s);

Write('Нажмите Enter');

Readln;

end.

Задание 3. Составить программу, которая запрашивает имя человека и повторяет его на экране с Приветствием

Program as;

Uses crt;

Var K:string;

Begin clrscr;

Writeln(‘Как вас зовут’);

Readln(k);

Writeln(‘Привет, ,k’!’);

End.

Задание 4. Составить программу, которая запрашивает название футбольной команды и повторить его на экране со словом «Это чемпион!»

Program as;

Uses crt;

Var k:string;

Begin clrscr;

Writeln(‘Введите название футб. команды’);

Readln(k);

Writeln(k, ,’Чемпион!’);

End.

Задание 5. Дана строка символов s1,s2,...sn, в которой встречаются цифры, пробелы, буква Е и знаки + и -. Известно, что первый символ строки является цифрой. Из данной строки выделить подстроку предшествующую первому пробелу. Требуется: определить является ли это подстрока числом, если да, то выяснить целым или вещественным, положительным или отрецательным

Program Stroki;

Uses Crt;

Var s1,s2:string;

i:Integer;

k:Real;

f:boolean;

begin

ClrScr;

Writeln('Введите строку символов:');

Readln(s1);

s2:='';

f:=true;

for i:=1 to length(s1) do begin

if s1[i]=' ' then f:=false;

if (s1[i]<>' ') and (f=true) then s2:=s2+s1[i];

end;

Writeln('Выделенная подстрока: ',s2);

Val(s2,k,i);

if i<>0 then Writeln('Выделенная подстрока не содержит числовое значение')

else begin

f:=false;

for i:=1 to length(s2) do

if s2[i]='E' then begin

Write('Число в подстроке вещественного типа, ');

f:=true;

end;

if f=false then Write('Число в подстроке целочисленного типа, ');

if k<0 then Writeln('отрицательное')

else Writeln('положительное')

end;

Write('Для выхода нажмите Enter');

Readln;

end.

Задание 6. Дано название футбольного клуба, определить кол-во символов в нем

Program as;

Uses crt;

Var k:string; M:integer;

Begin clrscr;

Writeln(‘Введите название Ф.К’);

Readln(k);

M:=length(k);

Writeln(M);

End.

Задание 7. Дано название города, определить четно или нет, кол-во символов в нем

Program as;

Uses crt;

Var k:string;b:integer;

Begin clrscr;

A:=’Aktobe’;

B:=length(a);

If b mod 2=0 then write(‘четно ‘) else write(‘нечетно ‘);

Readln;

End.

Задание 8. Дана строка, содержащая текст. Записать её в обратном порядке

program з8;

var s1,s2: String;

i: Integer;

begin

Write('Введите строку=');

ReadLn(s1); s2:='';

for i:=Length(s1) downto 1 do s2:=s2+s1[i]; WriteLn('Обратная строка=',s2);

ReadLn; end.

Задание 9. Дано слово. Заменить «о» на «е»

Program as;

Uses crt;

Var a:string; e,I,b:integer;

Begin clrscr;

Writeln(‘Dano clovo’);

Readln(a);

B:=length(a);

For i:=1 to b do if copy(a,I,1)=’o’ then begin

Delete(a,I,1);

Insert(‘e’,a,i);

End;

Writeln(a);

End.

Задание10. Даны 2 фамилии опред какая из них длиннее

Program as;

Uses crt;

Var a,b:string; c,d:integer;

Begin clrscr;

A:=’kolin’;

B:=’imanalin’;

C:=length(a);

D:=:=length(b);

If c>d then write(a) else write(b);

End.

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

Задание 1. При нажатии на Enter плавно перемещает треугольник c вершинами (10,10);(10,100);(100,100) на 10 пунктов по X, и по Y

uses crt,graph;

const n=4;

type

Point=record

x,y:integer;

end;

mas=array[1..n] of Point;

procedure Z(x,y:integer;var m:mas;c:byte);

var i:byte;

begin

Setcolor(c);

m[1].x:=x;m[1].y:=y;

m[2].x:=x;m[2].y:=y+90;

m[3].x:=x+90;m[3].y:=y+90;

m[4].x:=x;m[4].y:=y;

moveto(m[1].x,m[1].y);

for i:=1 to n do

lineto(m[i].x,m[i].y);

Setfillstyle(1,c);

end;

var gd,gm:integer;

x,y,x1,y1,i:integer;

p:mas;

c1,c2:byte;

k:char;

move:boolean;

begin

gd:=VGA;

gm:=VGAHi;

Initgraph(gd,gm,'..\bgi');

Setbkcolor(8);

x:=10;y:=10;

c1:=7;c2:=8;

move:=true;

repeat

if keypressed then

begin

k:=readkey;

if k=#13 then {if enter}

for i:=1 to 10 do

begin

y1:=y;

x1:=x;

y:=y+1;

x:=x+1;

delay(6000);

Z(x1,y1,p,c2);

Z(x,y,p,c1);

move:=true;

end;

end;

if move then

begin

Z(x1,y1,p,c2);

Z(x,y,p,c1);

move:=false;

end;

OutTextXY(320,240,'Press Enter to continue');

until k=#27; {until escape}

closegraph;

end.

Задание 2. Изобразить на экране скачущий мяч. Использовать графический режим

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:\bp\bgi ');

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); repeat until keypressed;closegraph

floodfill(x,y,12); end.

Задание 3. Анимационная картинка - кораблик совершает путь по заданной траектории...все происходит довольно быстро

program corablik;

uses Graph, Crt;

var

grDriver: integer;

grMode: integer;

ErrCode: integer;

x,y,y0,a,b: integer;{a,b-переменные для линии моря, чтоб они не зависели от х,у}

procedure more(a,b:integer);

begin

moveto(0,y0);

setcolor(blue);

for a:=0 to 680 do{слева направо рисуем синусоиду синего чвета}

begin

b:=y0-round(sin(a*pi/180)*30);{30-коэффициент масштабирования по оси Х,

чем больше, тем волна круче}

lineto(a,b);

end;

end;

begin

grDriver:= Detect;

InitGraph(grDriver, grMode, '..\BGI');

ErrCode:= GraphResult;

y0:= 250;

if ErrCode = grOk then

begin

x:=600;

while x>=0 do{лучше использовать цикл while, можно менять величину шага,

что тоже влияет на скорость и частоту смены картинки}

begin

cleardevice;

more(a,b);{рисуем волну}

setcolor(white);{устанавливаем цвет кораблика}

y:=y0-40-round(sin(x*pi/180)*30);{движемся по волне}

MoveTo(x - 40, y + 20);

LineTo(x - 20, y + 40);

LineTo(x + 20, y + 40);

LineTo(x + 40, y + 20);

LineTo(x - 40, y + 20);

MoveTo(x + 15, y + 20);

LineTo(x + 15, y - 40);

LineTo(x - 20, y + 20);

LineTo(x + 15, y + 20);

delay(100); {нормальная скорость, если модули *.TPL не глючные как у Вас,

время должно быть в миллисекундах, а не в каких-нибудь наносекундах}

x:=x-2;{шаг движения}

end;

end

else Writeln('Graphics error: ', GraphErrorMsg(ErrCode));

Settextstyle(0,0,3);{устанавливаем стиль шрифта}

cleardevice;

setcolor(red);

OuttextXY(200,240,'Rejs zavershen!');{выводим надпись}

readln;

CloseGraph;

end.

Задание 4. Анимация - прямоугольничек красного цвета совершает полный путь по экрану монитора!

program kv;

uses

crt, graph;

var

x, y, dx, dy, w, h, driver, mode: integer;

begin

initgraph(driver, mode, 'G:/BP/BGI');

if graphresult<>0 then begin

writeln('none');

halt

end;

dx:=1;

dy:=0;

w:=100;

h:=10;

repeat

setfillstyle(1, black);

bar(x, y, x+w, y+h);

x:=x+dx;

y:=y+dy;

setfillstyle(1, red);

bar(x, y, x+w, y+h);

delay(100);

if (x+w>=getmaxx)and(y<=0) then

begin

dx:=0;

dy:=1;

end

else

if (y+h>=getmaxy)and(x+w>=getmaxx) then

begin

dx:=-1;

dy:=0;

end

else

if (x<=0)and(y+h>=getmaxy) then

begin

dx:=0;

dy:=-1;

end

else

if (y<=0)and(x<=0) then

begin

dx:=1;

dy:=0;

end;

until keypressed;

closegraph;

end.

Задание 5. Люди часто просят нарисовать самый обычный рисунок из разных тем...например нарисую"программиста"

Program bugalteria;

Uses crt,graph;

Var gd,gm:integer;

begin

clrscr;

Detectgraph (gd,gm);

Initgraph (gd,gm,'C:\tp7');

{Зарисовка стола}

Bar (120,330,360,360);

Bar (180,360,330,480);

{Зарисовка компьютера}

Line (180,240,180,330);

Line (180,270,210,330);

Line (172,210,202,300);

Line (180,210,210,300);

Line (210,300,202,300);

Line (180,210,172,210);

Line (270,322,270,330);

Line (270,322,330,330);

{Зарисовка стула}

Bar (420,405,510,420);

Bar (456,420,480,480);

{Зарисовка бухгалтера работающего за компьютером}

Line (510,405,540,300);

Line (334,480,390,390);

Line (390,390,510,390);

Line (360,480,420,405);

Line (510,390,450,240);

Line (480,390,420,300);

Line (420,300,430,240);

Line (450,270,330,300);

Line (330,300,310,310);

Circle (435,195,40);

Readln

end.

Задание 6. Построить один прямоугольник и заполнить его случайно расположенными точками (в пределах 100 штук) и второй прямоугольник в котором проведены случайные линии (различными цветами)

program пример;

uses graph, crt;

var gd,gm,xl,yl,x2,y2,x,y,x3,y3,i,errcode: integer;

begin

gd:=0; gm:=0;

InitGraph (gd,gm,’ ‘);

[построение первого прямоугольника]

x1:=10; y1:=10; x2:=200; y2:=200;

rectangle(x1,y1,x2,y2);

[вывод случайных точек]

for i:=1 to 100 do

begin

x:=random(x2-xl)+x1;

у:=random(y2-yl)+y1;

putpixel(x,y,2)

end;

[построение второго прямоугольника]

xl:=210; yl:=210; x2:=400; y2:=400;

rectangle(xl,yl, x2,y2);

[вывод случайных линий]

for i:=l to 100 do

begin

setcolor(random(15));

x:=random(x2-xl)+xl;

y:=random(y2-yl)+yl;

x3:=random(x2-xl)+xl;

y3:=random(y2-yl)+yl;

Iine(x,y,x3,y3);

end;

while not keypressed do;

closegraph

end.

Задание 7. Изобразить линии разного стиля и толщины

program пример;

[ вывод линий разного вида]

uses graph,crt;

var gd,gm: integer;

begin

gd:=0; gm:=0; initgraph (gd, gm, ' ');

line (0, 0, 300, 0); [линия обычного образца]

setlinestyle(l,0,l);line(0,20,300,20);[линия из точек]

setlinestyle(2,0,l);line(0,40,300,40);[пунктирная линия]

setlinestyle (3,0,1);line(0,60,300,60);[штриховая линия]

setlinestyle(0,0,3);line(0,80,300,80);[сплошная толстая линия]

while not keypressed do;

closegraph end.

Задание 8. Построить окружность и описать вокруг нее квадрат

program пример;

[квадрат и вписанная окружность]

uses graph, crt;

var gd,gm,x,y,r,x1,y1,x2,y2: integer; xa,ya:word;

begin

writeIn (‘введи координаты центра окружности и радиус’);

readln(x,y,r);

gd:=0; gm:=0; initgraph(gd,gm, ‘ ‘);

circle(x, у, г);

getaspectratio(xa,ya);

x1:= x-r; у1:= round (y -r*(xa/ya));

x2:=x+r; y2:= round (y+r*(xa/ya));

rectangle(xl,yl,x2,y2);

while not keypressed do;

closegraph end.

Задание 9. Построить дугу от 0 до 90 градусов и от 270 до 450 градусов

program пример;

[дуги окружности от 0 до 90 и от 270 до 450]

uses graph,crt;

var gd,gm,x,y,r,xl,yl: integer; xа,уа:word;

begin

gd:=0; gm:=0; initgraph(gd,gm,’ ‘);

getaspectratio(xa,ya);

{строим оси координат}

line(0,100,300,100); line(150,0,150,200);

{ строим дугу от 0 до 90 }

агс(150,100,0,90,40);,

line (310, 100,610,100); line(460,0,460,200);

{ строим дугу от 270 до 450 }

arc(460,100,270,540,40);

while not keypressed do; end.

Задание10. Построить дуги элипсов

program пример;

[дуги эллипсов при разном соотношении Rx и Ry]

uses graph,crt;

var gd,gm:integer; xa,ya:word;

begin

gd:=0; gm:=4; initgraph (gd, gm, ‘ ‘);

getaspectratio(xa, ya);

{ первая дуга}

line(0,100,l60,100);

line(80, 55, 80,145);

ellipse(80,100,180, 90,40,40);

{ вторая дуга}

line(190,100,410,100);

line(300,55,300, 145);

ellipse(300, 100, 0, 359,100,20);

{ третья дуга}

line(440,100,600,100);

line(520,55,520,145);

ellipse (520, 100, 0,270,40, round (40* (xa/ya)));

while not keypressed do; end.

Задание11. Построить прямоугольники в два ряда по четыре прямоугольника в ряд и заполнить их соответственно 12-ю различными типами штриховки

program пример;

{демонстрация цветов заполнения}

uses graph,crt;

var gd,gm,x,y,k, j:integer;

begin

gd:=0; gm:=0; initgraph (gd, gm, ' ');

x:=60; y:=40;

for j:=0 to 2 do

for k:=0 to 3 do

begin

rectangle ((k + 1) *x,(j+1)*y, (k+2)*x, (j+2)*y);

setfillstyle{k+j*4, j+1);

bar((k+1)*x+1, (j+1)*y+1, (k+2)*x-1, (j+2)*y-1)

end;

while not keypressed do;

end.

Задание12. Построить окружность и описать вокруг нее квадрат,а затем область внутри квадрата, но вне окружности закрасить цветом фона

program пример;

{ квадрат и вписанная окружность}

uses graph,crt;

var gd, gm, x, y, r,xl,yl,x2,y2: integer; xa,ya:word;

begin 

writeln('введи координаты центра окружности и радиус’);

readln (х,у,г);

gd:=0; gm:=0; initgraph (gd, gm, ‘ ‘);

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

getaspectratio(xa,ya);

x1:=x-r; yl:=round(у-r*(xa/ya));

x2:=x+r; y2:=round(y+r*(xa/ya));

rectangle(x1,y1,x2,y2);

floodfill(x1+1,y1+1,3);

floodfill(x2-1,y1+1,3);

floodfill(x1+1,y2-1,3);

floodfill(x2-1,y2-1,3);

while not keypressed do;

closegraph

end.

Задание13. Вывести точечным шрифтом горизонтально, начиная с точки (100,20), сообщение "horisontal (горизонтально)" и прямым шрифтом вывести вертикально сообщение "vertical (вертикально)", начиная с точки (5,10)

program пример;

{ графика и текст}

uses graph,crt;

var gd,gm: integer;

begin

gd:=0; gm:=0; initgraph(gd,gm, ‘ ‘);

outtextxy(100,20, horisontal (горизонтально)’);

settextstyle(0,1,1);

outtextxy (50,10, ‘vertical (вертикально)’);

while not keypressed do;

end;

Задание14. Изобразить треугольник, вращающийся вокруг одной из вершин

program пример;

{ вращение треугольника вокруг одной вершины}

uses graph,crt;

var

gd,gm,I,xc,yc,x1,y1,x2,y2,x1n,x2n,y1n,y2n:integer;

xa,ya:word; t: real;

begin

gd:=9; gm:=2; initgraph (gd, gm, ‘ ‘);

getaspectratio(xa,ya);

xc:=300; yc:=100; t:=0; x1:=400; y1:=10; x2:=500;

y2:=100;

for i:=0 to 360 do

begin

t:=t+pi/180;

xln:=round (xc+ (xl-xc) *cos (t)+(yl-yc)*sin(t) *ya/xa);

у1n:=round (yc+ (yl-yc) *cos (t) - (xl-xc)*sin(t) *xa/ya);

x2n:=round (xc+(x2-xc) *cos(t)+(y2-yc)*sin(t) *ya/xa);

y2n: =round (yc+ (y2-yc) *cos (t) + (x2-xc)*sin(t) *xa/ya);

setcolor (15);

line (xc,yc, xln, yln); line (xln,yln,x2n,y2n);

line (x2n,y2n,xc,yc); delay(20);

setcolor(0);

line(xc,yc,xln,yln); line (xln,yln,x2n,y2n);

Iine(x2n,y2n,xc,yc); delay(20);

end; while not keypressed do;

closegraph

end.

Задание15. Изобразить движение шара(точнее круга)по горизонтали

program пример;

{ движение шара по горизонтали}

uses qraph,crt;

var gd,gm,i: integer; p:pointer; s:word;

begin;

gd:=0; gm:=0; initgraph (gd, gm, ‘ ‘);

{ рисуем шар}

for i:=l to 10 do circle (20, 30, i);

{ выделяем память}

s:=imagesize(9, 20,30, 40); getmem(p,s);

{ запоминаем рисунок}

getimage(9, 20, 30, 40,p^); cleardevice;

{ изображаем полет шара }

for i:=l to 600 do

begin putimage(10+i, 100,p^,0); delay(10); end;

while not keypressed do;

end.