х: real;

Задача 1
х: real; { аргумент функции } у: real; { значение функции }

Для завершения работы программы нажмите

Вычисление площади параллелограмма } var
l,w: real; ( длина и ширина параллелограмма}
s: real; { площадь параллелограмма} begin
writeln('Вычисление площади параллелограмма');
writeln('Введите исходные даные:');
write('Длина (см.) -> ');
readln(1) ;
write('Ширина (см.) ->');
readln(w);
s:=l*w;
writeln('Площадь параллелограмма:',s:6:2, ' кв.см. ') ;
readln; end. Задача 53
{ Вычисление площади поверхности параллелепипеда } var


l,w,h : real; { длина, ширина и высота параллелепипеда}
s: real; { площадь поверхности параллелепипеда} begin
writeln('Вычисление площади поверхности параллелепипеда');
writeln('Введите исходные даные:');
write('Длина (см) —> ');
readln(1) ;
write('Ширина (см) ->');
readln(w);
write('Высота (см) — >') ;
readln(w);
s:=(l*w + l*h + w*h)*2;
' writeln('Площадь поверхности параллелепипеда:',s:б:2,
' кв.см. '); readln; end.
Задача 55
{ Вычисление объема цилиндра } var
r,h,v: real; { радиус основания, высота и объем цилиндра } begin
writeln('Вычисление объема цилиндра');
writeln('Введите исходные данные:');
write('радиус основания (см) —> ');
readln(г) ;
write("высота цилиндра (см) —> ');
readln(h);
v := 2*3.1415926*r*r*h;
writeln('Объем цилиндра ',v:6:2,' см.куб.');
writeln(' Для завершения работы программы нажмите <Enter>');
readln;
end. Задача 56
{ Вычисление стоимости покупки } var
kar,tetr: real; { цена карандаша и тетради }
nk,nt: integer; { количество тетрадей и карандашей }
summ: real; { стоимость покупки } begin
writeln("Вычисление стоимости покупки.');
writeln('Введите исходные данные:');
write('Цена тетради (руб.) —>');
readln(tetr);
write('Количество тетрадей —>') ;
readln(nt);
write('Цена карандаша (руб.) — >');
readln(kar);
write('Количество карандашей —>');
readln(nk);
surnm:=tetr*nt + kar*nk; writeln;
writeln('Стоимость покупки:',summ:6:2,' руб.'); readln; end".
Задача 60
{ Вычисление площади треугольника по двум сторонам и углу между ними } var
a,b: real; { длины сторон }
f: real; { величина угла, выраженная в градусах } s: real; { площадь треугольника } begin
writeln('Вычисление площади треугольника.'); writeln('Введите в одной строке длины сторон треугольника'); write ('->'); readln(a,b); writeln('Введите величину угла между сторонами ',
'треугольника'); ' write('->'); readln(f); ( s=a*h/2
h (высота треугольника) может быть вычислена
по формуле: h=b*sin(f).
Однако, в Turbo Pascal аргумент функции Sin должен быть выражен в радианах (1 рад. = 180/3.1415925, где 3.1415926 - число "ПИ").)
s:=a*b*sin(f*3.1415926/180)/2; writeln;
writeln('Площадь треугольника:',s:6:2,' кв.см.1); readln; end.
Задача 61
{ Вычисление сопротивления электрической цепи,
состоящей из двух параллельно соединенных элементов. }
var
rl,r2: real; { сопротивление элементов цепи } г: real; { суммарное сопротивление цепи }
begin
writeln('Вычисление сопротивления электрической цепи1); writeln('при параллельном соединении элементов.'); writeln('Введите исходные данные:'); write('Величина первого сопротивления (Ом) —>'); readln(rl) ;
write('Величина второго сопротивления (Ом) —>'); readln(r2) ; r:=rl*r2/(rl+r2) ; writeln;
writeln('Сопротивление цепи:',г:6:2, ' Ом'); readln; end.

Решения (Часть 3)

Задача 2 funt: real; { вес в фунтах...

Задача 5

rl: real; { диаметр кольца } r2: real; { диаметр отверстия } s: real; { площадь кольца }

Задача 7 CenaTetr: real; {цена...

п:=п+1;

Задача 14

у:=-2.7*х*х*х+0.23*х*х-1.4;

Приятна мне твоя прощальная

kg:=gunt*0.4095;
Задача 34 sum:=ct*nt+ck*nk+cl;{ct,ck —цена тетради, карандаша и линейки }
{ nt, nk —количество тетрадей и карандашей}
Задача 38 begin
writeln('Унылая пора! Очей очарованье!'); writeln(' Приятна мне твоя прощальная пора.'); writeln('Люблю я пышное природы увяданье,'); writeln('В багрец и золото одетые леса.'); writeln;
writeln(' А.С.Пушкин');
readln; { чтобы стихотворение не исчезло с экрана } end.
Задача 42 writeln(а:6:2); writeln(b:6:2); writeln(с:6:2); Задача 43 writeln('xl=',xl:6:2, ¦ х2=',х2:6:2) Задача 44 uses Crt; begin
TextBackGround(Blue); { цвет фона } TextColor(LightGray); { цвет символов } ClrScr; { очистить экран }
writeln('Буря мглою небо кроет'); writeln('Вихри снежные крутя.'); writeln('То как зверь она завоет,'); writeln('То заплачет, как дитя.');
writeln;
writeln(' А.С.Пушкин');
readln; { чтобы стихотворение не исчезло с экрана } end. Задача 45 Uses Crt; begin
TextBackGround(Black); ClrScr;
TextColor(Red); write('Каждый ');
TextColor(LightRed);{оранжевый заменим светло-красным} write('охотник '); TextColor(Yellow); write('желает '); TextColor(Green); write('знать '); TextColor(LightBlue); write('где '); TextColor(Blue); write('сидит '); TextColor(Magenta); write('фазан.');
readln; { чтобы фраза не исчезала с экрана } end.
Задача 47 readln(и); readln(г);
Задача 48 readln(и,г);
Задача 49 { объявление переменных }
г, h : real; {радиус и высота цилиндра}
v: real; { объем цилиндра}

{ фрагмент программы }
writeln('Введите исходные данные:');
write('Радиус цилиндра —>');
readln ( г ) ;
writeln('Высота цилиндра —>');
readln(h);

Вычисление стоимости поездки на дачу

{ Вычисление стоимости поездки на дачу и обратно } var
rast: real; { расстояние до дачи }
rash: real; { расход бензина на 100 км пути }
cena: real; { цена одного литра бензина }
summ: real; { стоимость поездки на дачу и обратно } begin
writeln('Вычисление стоимости поездки на дачу и обратно.');
write('Расстояние до дачи (км) ->');
readln(rast);
write('Расход бензина (литров на 100 км) ->');
readln(rash);
write('Цена литра бензина (руб.) —>');
readln(cena);
summ:=2*rast/100*rash*cena;
writeln;
writeln('Поездка на дачу и обратно обойдется в',
surran: 6:2, ' руб. ') ; readln; end. Задача 67 { Вычисление площади поверхности цилиндра } var
г: real; { радиус основания цилиндра }
80
Turbo Pascal в задачах и-примерах
h: real; ( высота цилиндра } s: real; { площадь поверхности цилиндра } begin
writeln('Вычисление площади поверхности цилиндра');
writeln('Введите исходные данные:');
write('радиус основания цилиндра (см) —>');
readln(r);
write('высота цилиндра (см) ->');
readln(h);
{
pi - именованная константа, ее значение равно числу "ПИ" Sqr - функция Turbo Pascal, ее значение равно квадрату аргумента, т. е. Sqr(x) = х*х
}
s:=2*pi*sqr(r)+2*pi*r*h; writeln;
writeln('Площадь поверхности цилиндра ',s:6:2,'кв.см.'); readln; end. Задача 69 { Пересчет расстояния из верст в километры } var
v: real; { расстояние в верстах }
k: real; { расстояние в километрах } begin
writeln('Пересчет расстояния из верст в километры');
writeln('Введите расстояние в верстах и нажмите <Enter>');
write('->');
readln(v);
k:=v*1.0668;
writeln(v:6:2,' верст(а/ы) — это ',k:6:2,' км');
writeln('Для завершения работы программы нажмите ',
'<Enter>');
readln; end.
Задача 71 ( Вычисление дохода по вкладу } var
sum: real; { сумма вклада }
srokrreal; { срок вклада } stavka:real; f процентная ставка } dohodrreal; { доход по вкладу } begin
writeln('Вычисление дохода по вкладу.');
writeln('Введите исходные данные:');
write('Величина вклада (руб.) —>');
readln(sum) ;
write('Срок вклада (дней) —>');
readln(srok);
write('Процентная ставка —>');
readln(stavka);
dohod:=(sum*stavka/100)/365*srok; { 365 - кол-
в году } sum:=sum+dohod; writeln;
writelnt'---------------------------------') ;
writeln('Доход:',dohod:9:2,' руб.');
writeln('Сумма по окончании срока вклада:',sum:9:2,
'руб.'); readln; end.
Задача 72
( Преобразование величины, выраженной в минутах, в соответсвующее ей значение, выраженное в часах и минутах ) var
min: integer; { интервал в минутах }
h: integer; ( количество часов }
пк integer; { количество минут } begin
writeln('Введите величину временного интервала (в минутах)');
write('->');
readln(min);
h:= min div 60;
m:= min mod 60;
writeln;
writeln(min,' мин. -это ',h,' час.',т,' мин.');
readln; end.
Задача 73
{ Преобразование числа в денежный формат } var
n:- real; { дробное число }
г: integer; { целая часть числа (рубли) }
к: integer; { дробная часть числа (копейки) ) begin
writeln('Преобразование числа в денежный формат.');
write('Введите дробное число —>');
readln(n);
r:= Round(n*100) div 100;
k:= Round(n*100) mod 100;
writeln;
writeln(n:6:2,' руб. -это ',r,' руб.',к,' коп.');
readln; end.
Задача 76 { Вычисление частного } var
a,b,c: real; { делимое, делитель и частное } begin
writeln('Вычисление частного');
writeln('Введите в одной строке делимое и делитель,');
writeln('затем нажмите <Enter>');
write('->');
readln(a,b);
if b<> 0 then begin c:=a/b;
writeln('частное от деления ',а:6:3,' на ',Ь:6:3, 'равно ',с:6:3);
end else
writeln('Ошибка! Делитель не должен быть ',
1равен нулю!'); readln; end.
Задача 77
{ Вычисление площади кольца } var
rl,r2 : real; { радиус кольца и отверстия } s : real; { площадь кольца } begin
writeln('Введите исходные данные:'); write('радиус кольца (см) —> '); readln(rl);
write('радиус отверстия (см) —> '); readln(r2); if rl > r2 then begin
s:=2*3.14*(rl-r2);
writeln('Площадь кольца ',s:6:2,' кв.см'); end
else writeln('Ошибка! Радиус отверстия не может быть ',
'больше радиуса кольца. ') ;
writeln('Для завершения работы программы нажмите <Enter>'); readln; end. Задача 78
{ Вычисление сопротивления электрической цепи } var
rl,r2: real; { величины сопротивлений цепи }
г: real; { суммарное сопротивление }
t: integer; { тип соединения элементов:
1 — последовательное;
2 — параллельное } begin
writeln('Вычисление сопротивления электрической цепи1);
writeln('Введите исходные данные: ') ;
write('Величина первого сопротивления (Ом) —>');
readln(rl);
write('Величина второго сопротивления (Ом) ->');
readln(r2);
write('Тип соединения элементов (1-последовательное, ',
'2-параллельное) —>'); readln(t);
Задача 79
{ Решение квадратного уравнения }
program sqroot;
var
a,b,с:real;{ коэффициенты уравнения } xl,x2:real;{ корни уравнения } d:real; { дискриминант } begin
writeln('* Решение квадратного уравнения *'); write('Введите в одной строке значения коэффициентов'); writeln(' и нажмите <Enter>'); write('->');
readln(a,b,с); { ввод коэффициентов } d:=b*b-4*a*c; { вычисление дискриминанта } if d >= О then begin
xl:=-b+sqrt(d)/(2*a); x2:=-b-sqrt(d)/(2*a); writeln{'Корни уравнения:'); writeln('xl=',xl:9:3); writeln('x2=',x2:9:3); end else
writeln('Корней нет'); end. Задача 81 Вычисление стоимости покупки с учетом скидки } var
summ: real; { сумма покупки }
begin
writeln('Вычисление стоимости покупки с учетом скидки.'); writeln('Введите стоимость покупки и нажмите <Enter>.'); write('->'); readln (summ) ; if summ > 500
then { предоставляется скидка } begin
if suiran > 1000 then
begin
writeln('Вам предоставляется скидка 5%'); summ:=0.95*summ; end else
begin
writeln('Вам предоставляется скидка 3%'); summ:=0.97*summ; end;
writeln('Сумма покупки с учетом скидки: ', summ: б:2,' руб.');
end else
writeln('Скидка не предоставляется.'); readln; end.

В каком году был основан

{ Проверка знания истории } var
year: integer; { ответ испытуемого } begin '
writeln(' В каком году был основан Санкт-Петербург?');
writeln('Введите число и нажмите <Enter>');
write('->');
readln(year);
if year = 1703
then writeln('Правильно.') else

begin
write('Вы ошиблись, ');
writeln('Санкт-Петербург был основан в 1703 году.1) end; readln; end.
Задача 84
{ Проверка знания истории архитектуры } var
otv: integer; { номер ответа, выбранного испытуемым } begin
writeln('Архитектор Исаакиевского собора:');
writeln('1. Доменико Трезини');
writeln('2. Огюст Монферран');
writeln('3. Карл Росси');
writeln;
writeln('Введите номер правильного ответа и нажмите
<Enter>'); write('->'); readln(otv); if otv = 2
then writeln("Правильно.') else
begin
writeln('Вы ошиблись. ') ;
writeln('Архитектор Исаакиевского собора ', 'Огюст Монферран.');
end;
readln; end.

в одной строке два целых

{ Сравнение двух целых чисел } var
a,b: integer; ( сравниваемые числа } begin
write('Введите в одной строке два целых ');
writeln('числа и нажмите <Enter>');
write('->');
Часть II. Решения
87
readln(a,b); if a = b
then writeln('числа равны') else if a < b
then writeln(а,1 меньше ',b) else writeln(а,' больше ',b); readln;
end. Задача 87
{ Проверка умения умножать числа } var
ml,m2,p: integer; { сомножители и произведение }
otv: integer; { ответ испытуемого } begin
Randomize; { инициализация генератора случайных
чисел } ml:=Random(9)+1; { значение функции Random(а) — число }
{ в диапазоне от 0 до а-1 m2:=Random(9)+l; р:=ml*m2;
writeln('Сколько будет ' ,ml,'x',m2,' ?'); writeln('Введите ответ и нажмите <Enter>'); write('-> '); readln(otv); if p = otv
then writeln('Правильно.')
else writeln('Вы ошиблись. ',ml,'x',m2,'=',p); readln; end.
Задача 89
{ Проверяет на четность введенное с клавиатуры число } var
n: integer; { введенное пользователем число } begin
writeln('Введите целое число и нажмите <Enter>');
write('->');
readln(n);
write ('Число \n, ' - ');
if n mod 2=0
then writeln('четное.') else writeln('нечетное.');
readln; { чтобы результат не исчез с экрана }
end. Задача 91 { Вычисление стоимости телефонного разговора с учетом
скидки, предоставляемой по субботам и воскресеньям } var
Time:integer; { длительность разговора )
Day:integer; { день недели }
Summa:real; { стоимость разговора }
begin
writeln('Вычисление стоимости разговора по телефону.');
writeln('Введите исходные данные:');
write('Длительность разговора');
write(' (целое кол-во минут) —>');
readln(Time);
write('День недели');
write(' (1-понедельник,..,7-воскресенье)-> ');
readln(Day);
Summa:= 2.3 * Time; { цена минуты 2.3 руб.) if (Day = 6) or (Day = 7) then begin
writeln('Предоставляется скидка 20%); Summa:=Summa * 0.8; end;
writeln('Стоимость разговора:',Summa:8:2,' руб.'); readln;
end.
Задача 92
{ Контроль веса var w:real; h:real; } { вес ) { рост }
opt:real; { оптимальный вес } d:real; ( отклонение от оптимального веса } begin
writeln('Введите в одной строке через пробел'); writeln ('рост (см) и вес (кг), затем нажмите <Enter>'); write('->'); readln(h,w); opt:=h-100; if w=opt then
writeln('Ваш вес оптимален!') else
if w<opt
then begin
d:=opt-w;
writeln('Вам надо поправиться на ',
d:5:2,' кг.'); end else begin
d:=w-opt;
writeln('Вам надо похудеть на1,
d:5:2,' кг'); end; readln; end.
Задача 93 Определение времени года по номеру месяца } var
month: integer; { номер месяца } begin
writeln('Введите номер месяца (число от 1 до 12)
и нажмите <Enter>'); write('->'); readln(month); case month of
1,2,12: writeln(•Зима');
3..5: writeln('Весна');
6..8: writeln('Лето');
9.. 11: writeln('Осень');
i 90
else
end;
readln
end.
Задача 95 writeln('Число должно быть от 1 до 12');
( Определение стоимости междугороднего
телефонного разговора } var
kod: integer; { код города } cena: real; { цена минуты ) dlit: integer; { длительность разговора J summ: real; { стоимость разговора } begin
writeln('Вычисление стоимости разговора по телефону.'); writeln('Введите исходные данные:'); write('Код города —>'); readln(kod);
write('Длительность разговора (целое кол-во минут) —>'); readln(dlit); write('Город: '); case kod of 432: begin
writeln('Владивосток'); cena:=2.2; end; 095: begin
writeln('Москва'); cena:=1; end; 815: begin
writeln('Мурманск'); cena:=1.2; end; 846: begin
writeln('Самара'); cena:=1.4; end; end;
suran := cena * dlit; writeln('Цена минуты:',cena:6:2,' руб.');
writeln('Стоимость разговора:',summ:6:2, ' руб.'); readln; end.
Задача 96
{ Дописывает после числа слово "рубль" в правильной форме } var
n: integer; { число }
m: integer; ( остаток от деления п на 100 (последние две цифры) }
г: integer; { остаток от деления п на 10 (последняя цифра) } begin
writeln('Введите целое число (от 1 до 999)', ' и нажмите <Enter>');
write('-> ');
readln(n);
write(n,' ');
{ окончание определяется двумя последними цифрами | if n>100
then m := n mod 100;
if (m >= 11) and (m <= 14) then
writeln('рублей') else begin
r:=n mod 10; case r of
0, 5 .. 9: writeln('рублей'); 1: writeln ('рубль'); 2..4: writeln ('рубля'); end; end; readln; end.
Задача 98
{ Вычисление даты следующего дня } var
day:integer;
month:integer;;
year:integer;:
last .-boolean; { TRUE, если текущий день последний день
месяца } .r:integer; { если год високосный, то остаток от }
{ деления year на 4 равен нулю } begin
write('Введите цифрами сегодняшнюю дату');
write('(число месяц год) —> ');
readln(day,month,year);
last:=FALSE;
case month of
L,3,5,7,8,10,12:if day=31
then last:=TRUE;
4,6,9,11: if day=30
then last:=TRUE;
2: if day = 28 then
begin
r:=year mod 4; if r <> 0
then last:=TRUE; end; end; { case }
if last
then begin
writeln('Последний день месяца!');
day:=l;
if month=12
then begin
month:=1; year:=year + 1;
writeln('C наступающим Новым годом!'); end
else month:=month + 1; end
else day:=day + 1; writelnf'Завтра ',day,'.',month,'.' ,year );
readln;
end.

во суммируемых членов ряда

( Вычисление суммы ряда 1+1/2+1/3+ ... }
var
n: integer; { кол- во суммируемых членов ряда }
i:integer; { номер элемента ряда }
elem:real; { значение элемента ряда }
summ:real; { сумма элементов ряда }
begin
writeln('Вычисление частичной суммы ряда 1+1/2+1/3+...');
writeln('Введите кол-во суммируемых членов ряда');
write('->');
readln(n);
suinm:=O;
for i:=1 to n do
begin
elem:=l/i;
summ: =suimH-elem; end;
write('Сумма первых *,n); writeln(' членов ряда равна ', suram: 6: 4) ; readln;
end.
Задача 106 { Таблица степеней двойки } vax
n: integer; { показатель степени } x: integer; { значение 2 в степени п } begin
writeln('Таблица степеней двойки'); х:=1;
for n:=0 to 10 do begin
writeln(n:2,x:6); x:=x*2; end; readln; end.

нижняя граница диапазона изменения аргумента

{ Таблица функции } const
LB=-2; { нижняя граница диапазона изменения аргумента }
НВ=2; { верхняя граница диапазона изменения аргумента }
DX=0.5; { приращение аргумента } var
х,у: real; { аргумент и значение функции }
n: integer; { кол-во точек }
i: integer; { счетчик циклов }96 in
n:=Round((HB - LB)/DX)+1;
x:=LB;
writelnC-------------------') ;
writeln(' x I y');
writeln('-------------------') ;
for i:=1 to n do begin
y:=-2.4*x*x+5*x-3; writeln(x:8:2,' I ',y:8:2); x:=x+DX; end;
writelnC-------------------') ;
readln; end.

После ввода каждого числа нажимайте

{ Вычисляет среднее арифметическое последовательности
дробных чисел, вводимой с клавиатуры } const
L=5; { длина последовательности } var
a: real; { число }
n: integer; { кол-во введенных чисел } sum: real; { сумма введенных чисел }
sred: real; { среднее арифметическое введенных чисел } begin
writeln('Обработка последовательности дробных чисел'); writeln(' После ввода каждого числа нажимайте <Enter>'); sum:=0;
for n:=l to L do begin
write('->'); readln(a); sum:=sum+a; sred:=sum/n;
writelnf'Введено чисел:',п:3, ' Сумма: ', sum:6:2, ' Сред.арифметическое:',sred:6:2); end;
writeln('Для завершения работы программы нажмите <Enter>'); readln; end.

После ввода каждого числа нажимайте

{ Вычисляет среднее арифметическое и определяет
минимальное и максимальное число последовательности
дробных чисел, вводимых с клавиатуры } var
a: real; { очередное число }
n: integer; { количество чисел }
sum: real; ( сумма введенных чисел }
sred: real; { среднее арифметическое }
min: real; ( минимальное число последовательности }
max: real; { максимальное число последовательности }
i: integer; { счетчик циклов }
begin
writeln('Обработка последовательности дробных чисел.'); write ('Введите количество чисел последовательности ->'); readln(п);
writeln('Вводите последовательность.'); writeln(' После ввода каждого числа нажимайте <Enter>'); write('->');
readln(a); { вводим первое число последовательности } { предположим, что:}
min:=a; { первое число является минимальным } шах:=а; { первое число является максимальным } sum:=a;
{ введем остальные числа } for i:=l to n-1 do begin
write('->');
readln(a);
sum:=sum+a;
if a < min then min:=a;
if a > max then max:=a; end; sred:=sum/n;
teln('Количество чисел:*,п); writeln('Среднее арифметическое:',sred:6:2); writeln('Минимальное число:',min:6:2); writeln('Максимальное число:',шах:б:2);
writeln('Для завершения работы программы нажмите <Enter>'); readln; end.

Генерирует три последовательности случайных чисел

( Генерирует три последовательности случайных чисел и вычисляет среднее арифметическое каждой последовательности } const
N=3; { кол-во последовательностей } L=10; { длина последовательности ) var
г: integer; ( случайное число } sum: integer; { сумма чисел последовательности } sred: real; ( среднее арифметическое } i,j: integer; { счетчики циклов } begin
writeln('Случайные числа');
Randomize; { инициализация генератора случ. чисел } for i:=l to N do begin
{ генерируем последовательность } sum:=0; { не забыть обнулить ! } for j:=1 to L do begin
r:=Random(10)+1; write(r:3); sum:=sum+r; end;
sred:=sum/L;
writeln(' Сред.арифм.: ',sred:6:2); end;
writeln('Для завершения работы программы нажмите <Enter>'); readln; and.

нижняя граница диапазона изменения аргумента

( Таблица функции у»|х| } const
LB=-4; { нижняя граница диапазона изменения аргумента } НВ=4; ( верхняя граница диапазона изменения аргумента } DX=0.5; { приращение аргумента } var
х,у: real; { аргумент и значение функции } n: integer; ( кол-во точек } 1: integer; { счетчик циклов } begin
writeln('Таблица значений функции у=IхI '); n:=Round((НВ - LB)/DX)+1; x:=LB;
for i:=l to n do begin
y:=Abs(x);
writeln(x:6:2,y:6:2); x:=x+DX; end; readln; end.

для которого надо вывести таблицу

{ Вьшодит таблицу умножения на 7 } var
m: integer; { число, для которого надо вывести таблицу умножения (множимое) }
n: integer; { множитель }
р: integer; { произведение } begin
m:=7;
for n:=l to 10 do
begin
p:=ra*n;
writeln(m,'x',n,' =', p) ;
end;
readln; { чтобы результат не исчезал с экрана } end.
Задача 120
( Преобразование десятичного числа в двоичное } var
dec:'integer; { десятичное число }
v: integer; { вес формируемого разряда }
i: integer; { номер формируемого разряда } begin
writeln('Преобразование десятичного числа в двоичное');
writeln('Введите целое число от 0 до 255 и нажмите ',
'<Enter>'); write('->'); readln(dec);
write('Десятичному числу ',dec,' соответствует двоичное '); v:=128; { вес старшего разряда } for i:=l to 8 do begin
if dec >= v then begin
write('1'); dec:=dec-v; end
else write('0'); v:=Round(v/2); { вес следующего разряда в два раза }
{ меньше веса текущего разряда } end; readln; end.

Выводит на экран квадрат Пифагора

{ Выводит на экран квадрат Пифагора - таблицу умножения. } var
i,j: integer; { номер строки и столбца таблицы }
р: integer; { произведение i на j } begin
write('':4); { левая верхняя клетка таблицы }
for j:=l to 10 do { первая строка - номера столбцов } write(j:4);
writeln;
for i:=l to 10 do 101
begin
write(i:4); { номер строки } for j:=l to 10 do { строка таблицы }
write(i*j:4) ; writeln; end;
readln; { чтобы результат не исчезал с экрана } end.

во суммируемых членов ряда

{ Вычисление суммы ряда 1 -1/3 + 1/5 - 1/7 + ... } var
х: real; { член ряда }
n: integer; { количество суммируемых членов } summ: real; { частичная сумма } i: integer; { счетчик циклов } begin
writeln('Вычисление суммы ряда 1 -1/3 + 1/5 - 1/7 + ...'); write('Введите кол- во суммируемых членов ряда ->'); readln(п); summ:=0;
for i: = 1 to n do begin
x:=l/(2*i - 1); if (i mod 2) = 0 then x:=-l*x; summ:=summ+x; end;
writeln('Сумма ряда: ',summ:8:6);
writeln('Значение pi/4 ',pi/4:8:6); { pi - именованная
константа } readln; end.

Приближенное вычисление интеграла методом прямоугольников

{ Приближенное вычисление интеграла методом прямоугольников } var
a,b: real; { границы отрезка }
dx: real; ( приращение аргумента (величина интервалreal; { приближенное значение интеграла} n: integer; { количество интервалов } х: real; { аргумент }
у: real; { значение функции в начале интервала } 1: integer; begin
writeln('Приближенное вычисление интеграла');
write('Нижняя граница отрезка -> ');
readln(a);
write('Верхняя граница отрезка -> ');
readln(b);
write('Приращение аргумента -> ');
readln(dx);
n:=Round((b-a)/dx);
x: =a ;
s:=0;
for i:=l to n do
begin
y:=5*x*x-x+2; { значение функции в начале интервала }
s:=s+y*dx;
x:=x+dx; end;
writeln{'Значение интеграла: *,s:9:3);
writeln('Для завершения работы программы нажмите <Enter>'); readln; end.

Для завершения работы программы нажмите

{ Приближенное var
a,b: real;
dx: real;
s: real; n: integer; x: real; yl,y2: real;
i: integer;
вычисление интеграла методом трапеций }
{ границы отрезка }
{ приращение аргумента (величина интервала)}
{ приближенное значение интеграла} { количество интервалов } { аргумент }
{ значение функции в начале и в конце интервала }
begin
writeln('Приближенное вычисление интеграла1);
write('Нижняя граница отрезка -> ');
readln(a);
write('Верхняя граница отрезка -> ');
readln(b);
write('Приращение аргумента -> ');
readln(dx);
n:=Round((b-a)/dx);
x: =a;
s:=0;
for i:=l to n do
begin
yl:=5*x*x-x+2; { значение ф-и в начале интервала }
x:=x+dx;
у2:=5*х*х-х+2; { значение ф-и в конце интервала }
s:=s+(yl+y2)*dx/2; end;
writeln('Значение интеграла: ',8:9:3);
writelnf' Для завершения работы программы нажмите <Enter>'); readln; end.

Введите целое число от

{ Преобразование десятичного числа в двоичное } var
dec: integer; { десятичное число }
v: integer; { вес формируемого разряда }
i: integer; { номер формируемого разряда } begin
writeln('Преобразование десятичного числа в двоичное');
writeln(' Введите целое число от 0 до 255 и нажмите ', '<Enter>');
write('->');
readln(dec);
write('Десятичному числу ',dec,' соответствует двоичное ');
v:=128; { вес старшего (восьмого) разряда )
for i:=l to 8 do
in
if dec >= v then begin
write('1');
dec:=dec-v; end else write('0');
v:=Round(v/2); { вес следующего разряда в два раза меньше }
end;
readln; end.

Программа проверяет знание таблицы умножения

( Программа проверяет знание таблицы умножения }
uses Crt;
var
numbl, пштЬ2:integer; { Первое и* второе число }
res:integer; ( Результат умножения первого числа на второе }
otv:integer; { Ответ испытуемого }
kol:integer; { Количество правильных ответов }
i:integer;
begin
ClrScr; { очистить экран }
writeln(' *** Проверка знания таблицы умножения ***•);
writeln(' После примера введите ответ и нажмите <Enter>.');
writeln;
kol:=0; ( правильных ответов )
Randomize; ( инициализация генератора случайных чисел }
for i:=l to 10 do { 10 примеров }
begin
numbl:=Random(9)+ 1;
numb2:=Random(9)+1;
res:=numbl * numb2;
write(' (,numbl,'x',numb2,'=');
readln(otv);
if otv=res
then
kol:=kol+l else begin
writeln(' Вы ошиблись! ',numbl,'*',numb2,'=',res);
end; end;
writeln(' Правильных ответов:',kol); write(' Ваша оценка: ') ; case kol of
10: writelnС51); 9,8: writeln('4'); 7,6: writeln('3') ; 0..5:writeln('2') ; end;
writeln(' Для завершения работы с программой нажмите <Enter>') ;
readln; end.

буфер для обмена numbl

{ Проверка умения складывать и вычитать числа. } uses
Crt;
var
numbl,numb2:integer; { числа }
op:integer; { Действие над числами 0 - сложение,
1 - вычитание }
sop: char; { знак операции - "плюс" или "минус" } res:integer; { Результат } otv:integer; { Ответ испытуемого } kol:integer; { Количество правильных ответов }
buf:integer; { буфер для обмена numbl и numb2, в случае, если numbl<numb2 }
i: integer; { счетчик циклов }
begin
ClrScr;
writeln('Проверка умения складывать и вычитать числа.');
writeln('После примера введите ответ и нажмите <Enter>.');
106
l:=0;
Randomize;
for i:=l to 10 do
begin
{ сгенерируем пример }
numbl:=Random(9)+1; { первое число }
numb2:=Random(9)+1; { второе число }
op:=Random(2); ( действие над числами }
if op=0 then
begin { сложение} res:=numbl+numb2; sop:='+'; end else
begin { Вычитание }
if numbl < numb2 then
begin { обменяем numbl и numb2} buf:=numb2; numb2:=numbl; numbl:=buf; end;
res: =numbl-numb2 ; end;
write(' ',numbl,sop,numb2,'='); { вывести пример } readln(otv); { получить ответ
испытуемого } if otv = res then
kol:=kol+l else
begin
writeln(' Вы ошиблись! ',numbl,sop,numb2,'=',res);
end; end;
writeln(' Правильных ответов:',kol); write(' Ваша оценка:'); case kol of
10: writeln(?5');
9,8: writeln(l4l);
7,6: writelrK'31) ; 0..5:writeln('2') ; end; writelnC Для завершения работы с программой нажмите
<Enter>'); readln; end.

и функции библиотеки Crt

{ Простые электронные часы }
uses Crt; { используем процедуры и функции библиотеки Crt }
var
min,sec: integer; { минуты, секунды } begin
ClrScr; { очистить экран } for min:=l to 3 do begin
for sec:=l to 60 do begin
Delay(lOOO); { задержка 1000 ms }
GotoXY(l,l); { установить курсор в 1-ю колонку
1-й строки ) write(min,':',sec,' ');
if KeyPressed ( если нажата клавиша } then Halt; { завершить программу } end; end; end.

Для завершения работы программы нажмите

{ Вычисление среднего арифметического
последовательности положительных чисел } var
а : integer; { число, введенное с клавиатуры } n : integer; { количество чисел } s : integer; { сумма чисел } m : real; { среднее а=0;
writeln('Вычисление среднего арифметического
последовательности положительных чисел.');
writeln('Вводите после стрелки числа. ',
'Для завершения ввода введите ноль.');
repeat
write C> ');
readln(a);
s:=s+a;
n:=n+l; until a <= 0; n:=n-l;
writeln('Введено чисел:',n); writeln('Сумма чисел: ',s); m := s/n; writeln('Среднее арифметическое: ',m:6:2);
writeln(' Для завершения работы программы нажмите <Enter>');
readln;
end.

Определение максимального числа последовательности положительных

( Определение максимального числа последовательности положительных чисел }
var
а : integer; { очередное число } m : integer; { максимальное число } begin
write('Определение максимального числа');
writeln('последовательности положительных чисел.');
writeln('Вводите после стрелки числа. ',
'Для завершения ввода введите ноль.'); т:=0; repeat
write('> ');
readln(a);
if a > т then m := а; until a <= 0; writeln('Максимальное число: ',т);
завершения работы программы нажмите <Enter>');
readln;
end.

сначала будем делить на два

{ Проверка, является ли введенное с клавиатуры
целое число простым } program prost; var
n: integer; d: integer; r: integer; begin
write('Введите целое число-> ');
readln(n);
d:=2; { сначала будем делить на два }
repeat
r:=n mod d;
if r<>0 ( n не разделилось нацело на d }
then d:=d + 1;
until r=0; { пока не нашли число, на которое делится п ) if d=n
then writelnf n,' - простое число. ') else writeln(n,' — не простое число.');

Вы проиграли! Компьютер задумал число

{ Игра "Угадай число" } const
NPOP=5; { количество попыток, предоставляемое игроку } var
comp: integer; { число, "задуманное" компьютером }
igrok: integer; { вариант игрока }
n: integer; { кол-во попыток, сделанное игроком } begin
Randomize; { инициализация генератора случайных чисел }
comp:=Random(9)+1; { компьютер задумал число }
110
teln('Игра "Угадай число". ') ;
writeln('Компьютер "задумал" число от 1 до 10.');
writeln('Угадайте его за ',NPOP,' попыток.');
writeln('Введите число и нажмите <Enter>.');
repeat
n:=n+l;
write('->');
readln(igrok);
until (n = NPOP) or (comp = igrok); if comp = igrok
then writeln('Вы выиграли!')
else writeln(' Вы проиграли! Компьютер задумал число ',
comp); readln;
end.

сигнал частотой 1000 герц}

{ Таймер )
uses Crt;
var .
mm, sec: integer; { задержка: минут и секунд } begin
writeln('Введите величину задержки в минутах и секундах,');
writeln('например 2 30 и нажмите <Enter>.');
write('->');
readln(min,sec);
ClrScr;
GotoXY(2,2);
write(min,':',sec,' ');
repeat
if sec = 0 then begin
min:=min-l;
sec:=60; end; repeat
Delay(1000) ;
sec:=sec-l;
GotoXY(2,2) ; { задержка 1 сек } write(min,':',sec,' '); if KeyPressed { если нажата клавиша } then Halt; { завершить программу } until sec = 0; until (min = 0) and (sec = 0);
{ звуковой сигнал }
Sound(1000); { включить звук - сигнал частотой 1000 герц} Delay(500);
Nosound; { выключить звук} end.

вычисляемое значение ПИ

{ вычисляемое значение ПИ }
{ точность вычисления }
{ номер члена ряда }
{ значение члена ряда }
{ Вычисление числа "ПИ" var
p:real;
t:real;
n:integer;
elemrreal; begin
p:=0;
n:=l;
elem:=l; { начальное значение}
write('Задайте точность вычисления ПИ-> ');
readln(t);
writeln('Вычисление ПИ с точностью',t:9:6);
while elem >= t do
begin
elem:=l/(2*n-l) ; if (n MOD 2) = 0
then p:=p-elem else p:=p+elem; n:=n+l;
end;
p:=p*4;
writeln('Значение ПИ с точностью',t:9:б,' равно1,р:9:6);
writeln('Просуммировано ',п,' членов ряда.');
readln; end.

Вычисление наибольшего общего делителя двух

{ Вычисление наибольшего общего делителя двух целых чисел }
var
nl,n2:integer; { числа, НОД которых надо найти } nod:integer; { наибольший обший делитель } г:integer; { остаток от деления nl на п2 }
begin
writeln('Вычисление наибольшего общего делителя1);
writeln('для двух целых чисел.');
write('Введите в одной строке два числа ');
writeln('и нажмите <Enter>');
write('->');
readln(nl,n2);
while (nl mod n2)<>0 do
begin
r:=nl mod n2; { остаток от деления} nl:=n2; n2:=r;
end;
nod:=n2;
writelnCНОД чисел ',nl,' и ',п2,' это ',nod); readln;

writelnC Как Вас

{ Приветствие } var
name: string[40]; { имя пользователя } begin
writelnC Как Вас зовут?');
writeln('(введите свое имя и нажмите <Enter>');
write('->');
readln(name);
writeln('Здравствуйте, ',name,'!');
readln; end.

Посимвольный вывод сообщения

{ Посимвольный вывод сообщения ) uses
Crt; { для доступа к процедуре Delay } var
msg: string[80]; ( сообщение } n: integer; ( номер выводимого символа } begin
msg:='Приветствую великого программиста! '; for n:=1 to Length(msg) do begin
write(msg[n]);
Delay(lOO); { задержка 0.1 сек } end; readln; end.

Для завершения работы программы введите

{ Выводит код введенного символа } var
sim: char; { символ } code: integer; ( код символа } begin
writeln('Введите символ и нажмите <Enter>.');
writeln(' Для завершения работы программы введите точку.');
repeat
write('->'); readln(sim) ; code:=Ord(sim) ;
writeln('Символ: *,sim, ' Код: ',code); until sim = '.';
end.

Вывод таблицы кодировки символов

{ Вывод таблицы кодировки символов } var
ch:char; { символ }
dec:integer; { десятичный код символа }
i,j:integer;
114
in
dec:=O;
for i:=0 to 15 do ( шестнадцать строк } begin
' dec:=i; { чтобы получить таблицу кодировки} { для символов с кодами 128-255, } { эту инструкцию надо ) { заменить на dec:=i+128;} for j:=l to 8 do { восемь колонок } begin
if(dec<7) or (dec>=14> then
write(dec:4, '-', ' ',
chr(dec):l,chr(179)) else { символы CR,LF,TAB не отображаются }
write(dec:4,'- ',chr(179)); dec:=dec+16; and;
writeln; { переход к новой строке экрана } end; readln; end.

номер обрабатываемого символа

var
st: string[80]; { строка текста } len: integer; { длина строки } i: integer; { номер обрабатываемого символа ) begin
writeln('Введите строку текста и нажмите <Enter>'); write('->'); readln(st); len:=Length(st); for i:=l to len do
case st[i] of
•a'..'n': st[i]:=chr(ord(st[i])-32); 'р'-.'я1: st[i]:=chr(ord(st[i])-80);
end;
writeln('Строка, преобразованная к верхнему регистру: writeln(st); );
readln; end.

Удаление начальных пробелов строки

{ Удаление начальных пробелов строки } var
st:string[80]; { строка } begin
writeln('Удаление начальных пробелов строки.1);
write('Введите строку:');
readln(st);
while (post1 ',st) = 1) and (length(st)>0) do delete(st,1/1);
write('Строка без начальных пробелов:',st);
readln; end.

с клавиатуры строка целым числом

( Проверка, является ли введенная
с клавиатуры строка целым числом } var
st: string[40]; { строка }
n: integer; { номер проверяемого символа } begin
writeln('Введите число и нажмите <Enter>');
write('->');
readln(st);
n:=l;
while (n <= Length(St)) and
((st[n] >= '0') and (st[n] <-'9')) do n:=n+l;
write('Введенная строка '); if n < Length(st)
then write('не '); writeln('является целым числом. '); readln; end.

в строке есть неверный символ

{ проверяет, является ли введенная строка
шестнаддатеричным числом } var
st: string[20]; { строка }
i: integer; { номер проверяемого символа }
error: boolean; { в строке есть неверный символ } begin
writeln('Введите шестнадцатеричное число и нажмите <Enter>');
write('->');
readln(st);
{ преобразуем введенную строку к верхнему регистру for i:=l to Length(st)
do st[i]:=UpCase(st[i]);
error:=FALSE;
while (i <= Length(st)) and fnot error)
do if ((st[i] >= '0') and (st[i] <= '9')) or
((st[i] >= 'A') and (st[i] <= 'F')) then i:=i+l else error:=TRUE;
write('Строка '); if error
then write('не ');
writeln('является шестнадцатеричным числом. '); readln; end. { проверяет, является ли введенная строка дробным числом без знака }
var
st: string[20]; { строка }
i: integer; { номер проверяемого символа }
err: boolean; { TRUE - строка не дробное число }
begin
writeln('Введите дробное число и нажмите <Enter>');
write('->');
readln(st);
i:=l;
err:=TRUE; { пусть строка - не дробное число }
if (st[i] >='l') and (st[i] <='9') then { первый символ
цифра )
begin
{ за цифрой возможно следут еще цифры } while (st[i] >='l') and (st[i] <='9') and (KLength(st) )
do i:=i+l;
{ за цифрами следует точка, но она не последний символ } if ((st[i] = '.') and (i < Length(st))) then { точка } begin
{ за точкой должна быть хотя бы одна цифра } if ((st[i] >='l') and (st[i] <='9')) then begin
while ((st[i] >='l') and (st[i] <='9') and (KLength(st) ) ) do i:=i+l;
if i= Length(st) { последний символ — цифра} then err:=FALSE; { предположение
об ошибке ложно } •nd; end; end;
write('Строка '); if err
then write('не ');
writeln('является дробным числом.'); readln; end.

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

{ Программа преобразует введенное с клавиатуры двоичное восьмиразрядное число в десятичное } var
bin: string[8]; { изображение двоичного числа }
: integer; { десятичное число }
г: string[1]; { i-й разряд двоичного числа }
v: integer; ( вес i-ro разряда двоичного числа }
i: integer; { номер разряда двоичного числа }
in
writeln('Введите восьмиразрядное двоичное число');
writeln('n нажмите <Enter>.');
write ('->');
readln(bin);
if Length(bin) <> 8 then
writeln('Число должно быть восьмиразрядным.') else begin dec:=0;
v:=128; {вес старшего (8-го) разряда двоичного числа } for i:=l to 8 do begin
r:=bin[i]; { выделить i-й разряд } if г = 'I1 then
dec:=dec+v; t
v:=Round(v/2); { вычислить вес следующего разряда } end;
write('Двоичному числу ',bin,'); writeln(' соответствует десятичное ',dec); end;
writeln('Для завершения работы программы нажмите <Enter>.');
readln;

и его вес равен единице

var
st: string[2]; { шестнадцатеричное число }
d: integer; { десятичное число, соответствующее
введенному шестнадцатеричному }
v: integer; { вес разряда шестнадцатеричного числа } 1: integer; begin
writeln('Введите двухразрядное шестнадцатеричное число 'и нажмите <Enter>.');
write('->'); readln (st);
{ преобразуем введенную строку к верхнему регистру } for i:=l to Length(st)
do st[i]:=UpCase(st[i]);
i:=Length(st); { обрабатываем с младшего разряда } v:=l; { и его вес равен единице }
while (i>0) and
(((st[i] >= '0') and (st[i] <= '9')) or
((st[i] >= 'A') and (st[i] <= 'F'))) do begin
{ здесь символ - цифра или
латинская буква от А до F) if (st[i] >= '0') and (st[i] <= '9') then d:=d + v * ( Ord(st[i])-48 )
{ Ord('O') = 48, Ord('l') = 49, и т.д. } else d:=d + v * (Ord(st[i]) - 55);
{ Ord('A') = 65, Ord('B') = 66, и т.д. }
i:=i-l; { к предыдущему разряду } v:=v*16;
end;
if i=0 { обработаны все разряды }
then writeln('Шестнадцатеричному числу ',st,
' соответствуе десятичное ',d) else writeln('Введенная строка не является ',
'шеснадцатеричнои цифрой.');
readln; end.

в указанной пользователем системе счисления

{ Программа преобразует десятичное число
в число в указанной пользователем системе счисления (от 2-х до 10-ти) )
uses Crt;
о:integer; n:integer; г:integer;
s:string[16]
{ Основание системы счисления }
{ Исходное число }
{ Остаток от деления числа на основание
сист. счисл. } { Представление числа в заданной
сист. счисл. }
buf:string[1]; begin
ClrScr;
write('Введите целое число -> '); readln(n);
write('Введите основание системы счисления -> '); readln(o); s: = " ;
{ делим исходное число на основание системы счисления до тех пор, пока остаток от деления больше основания системы счисления. Остаток от деления на каждом шаге - очередная цифра. } repeat
r:=n mod о; n:=n div о; Str(r,buf); s:=buf+s; until(n<o)I Str(n,buf); s:=buf+s; writeln(s); readln; end.
( очередная цифра } { целая часть деления } ( преобразование цифры в строку}
( Программа преобразует десятичное число
в шестнадцатеричное } uses Crt;
var
n:integer; { Исходное число }
r:integer; { Остаток от деления числа на основание сист. счисл. }
s:string[16]; { Представление числа в заданной сист. счисл. }
buf:string[1] ; begin
ClrScr;
write('Введите целое число -> ');
readln(n);
s: = " ;
{ делим исходное число на основание системы
счисления (16) до тех пор, пока остаток от деления
больше основания системы счисления.
Остаток от деления на каждом шаге - очередная
цифра. }
write('Десятичному числу ' ,п) ; write (' соотвествует шестнадцатеричное ') ; repeat
r:=n mod 16; ( очередная цифра } n:=n div 16; { целая часть деления } if r<10
then buf:=chr(r+48) { chr(48) = '0', chr(49)='l'
и т.д. }
else buf:=chr(r+55); { chr(65) = 'A', chr(66)='B'
и т.д. } s:=buf+s; until(n<16) ; if n <> 0 then begin if n<10
then buf:=chr(n+48) else buf:=chr(n+55); s:=buf+s; end;
writeln(s); readln;
end.
{ Программа вычисляет значение арифметического
выражения, введенного с клавиатуры } uses Crt;
s: string[80]; { сторока }
1: integer; { длина строки }
z: integer; { значение выражения }
n: integer; { очередное число }
i: integer; { номер числа в строке }
err: integer; { код ошибки, при преобразовании символа в число }
begin
ClrScr;
writeln('Введите арифметическое выражение,1);
writeln('например, 4+5-3-5+2 и нажмите клавишу <Enter>');
write('->');
readln(s);
val (s[1],z,err);
i: =3 ;
repeat
val(s[i],n,err); { получить очередное однозначное
число }
if s[i-l] = '+' then z:=z+n else z:=z-n;
until i > Length(s) ;
writeln('Значение введенного выражения: *,z); writeln('Для завершения программы нажмите <Enter>.'); readln; end.

x учеников рост превышает

{ Бинарный поиск в упорядоченном массиве }
label
bye;
const
НВ=10;
var
а:array[1..10] of integer; { массив целых }
obr:integer; { образец для поиска }
ok: boolean; { TRUE - массив упорядочен }
sred,verh,niz:integer; { номера среднего, верхнего
и нижнего эл-тов массива}
found:boolean;{ признак совпадения с образцом } n:integer; { счетчик сравнений с образцом } i:integer;
begin
{ ввод массива }
writeln('*** Бинарный поиск в упорядоченном массиве ***');
write('Введите массив (в одной строке ',НВ);
writeln (' целых чисел) и нажмите <Enter>'); write('->'); for i:=l to HB-1 do
read(a[i]) ; readln(a[HB]);
{ проверим, является ли массив упорядоченнteln('Средний рост: ',sred:6:1,' см'); writeln ГУ ',m,'- x учеников рост превышает ', 'средний.');
end
else writeln('Нет данных для обработки.'); readln; end.

Вычисление суммы элементов массива

{ Вычисление суммы элементов массива (по столбцам) const
ROW=3; { кол-во строк } COL=5; { кол-во столбцов } var
a: array[1..ROW,1..COL] of integer; { массив } s: array[1..COL] of integer; { сумма элементов } i,j: integer; begin
writeln('Введите массив.');
writeln('После ввода элементов каждой строки,',
COL,' целых чисел, нажимайте <Enter>'); for i:=l to ROW do { ROW строк } begin
write('->');
for j:=l to COL-1 do
read(a[i,j]) ; readln(a[i,COL]); end;
writeln('Введенный массив'); for i:=l to ROW do begin
for j:=1 to COL-1 do
write(a[i,j]:4); writeln(a[i,COL]:4); end; { обработка }
for j:=1 to COL do { для каждого столбца }
for i:=l to ROW do { суммируем эл-ты одного столбца }
writeln('---------
for i:=l to COL do
write(s[i]:4) ; writeln;
readln;
end.

вычисление определителя матрицы второго порядка

{ вычисление определителя матрицы второго порядка } var
a: array[1..2,1..2] of real; det: real; { определитель (детерминант) } i,j: integer; { индексы массива } begin
writeln('Введите матрицу второго порядка.'); writeln('После ввода элементов строки нажимайте <Enter>'); for i:=l to 2 do begin
write('->'); read(a[i,1]) ; readln(a[i,2]) ; end; det:=a[l,l]*a[2,2] - a[l,2]*a[2,1];
writeln('Определитель матрицы '); for i:=l to 2 do begin
for j:=1 to 2 do
write(a[i,j]:6:2) ; writeln; end;
writeln('равен ',det:6:2); readln; end.

является ли матрица магическим квадратом

{ Проверяет, является ли матрица магическим квадратом } const
МАХ=5; { максимальный размер матрицы }
array[1..МАХ,1..MAX] of integer; { матрица } n: integer; { размер проверяемой матрицы } ok:boolean; { TRUE - матрица является маг. квадратом} i,j: integer; { индексы массива }
sum: integer; { сумма эл-тов главной диагонали матрицы } temp: integer;{ сумма элементов текущей строки, столбца или второй диагонали матрицы }
begin
write('Введите размер матрицы (3..4) ',
"и нажмите <Enter> ->'); readln(n);
Writeln('Введите строки матрицы'); Writeln('После ввода строки',п,' целых чисел,',
'нажимайте <Enter>'); for i:=l to n do begin
write('->');
for j:=l to n-1 do read(a[i,j]); readln(a[i, n] ) ; end;
ok:=TRUE; { пусть матрица - магический квадрат } sum:=0;
{ вычислим сумму элементов главной диагонали } for i:=l to n do sum:=sum+a[i,i];
{ вычисляем суммы по строкам}
i:=l;
repeat
temp:=0; { сумма эл-тов текущей строки }
for j:=l to n do temp:=temp+a [i,j];
i:=i+l;
if temp <> sum then ok:=FALSE; until (not ok) or (i > n);
if ok then
( здесь сумма элементов каждой строки равна сумме эл-тов главной диагонали } begin
{ вычисляем суммы по столбцам }
j:=l;
repeat
temp:=0; { сумма эл-тов текущего столбца } for i:=l to n do temp:=temp+a[i,j]; j:=j+l;
if temp <> sum then ok:=FALSE; until (not ok) or (j > n) ; if ok then
{ здесь сумма эл-тов каждой строки
равна сумме эл-тов каждого столбца и равна сумме эл-тов главной диагонали} begin
{ вычислим сумму эл-тов второй
главной диагонали } temp:=0; j:=n;
for i:=l to n do begin
temp:=temp+a[i,j];
end;
if temp <> sum then ok:=FALSE; end; end;
write('Введенная матрица '); if not ok
then write('не ') ;
writeln('является магическим квадратом.'); readln;
end.

сумма элементов текущей строки, столбца

{ Подводит итоги Олимпийских игр } const
N=10; {количество стран-участниц }
strana: array[1..N] of string[9]=('Австрия','Германия',
'Канада','Китай','Корея','Норвегия','Россия', 'США','Финляндия'array[1..МАХ,1..MAX] of integer; ( матрица } n: integer; { размер проверяемой матрицы } ok:boolean; { TRUE - матрица является маг. квадратом} i,j: integer; { индексы массива }
sum: integer; { сумма эл-тов главной диагонали матрицы ) temp: integer;{ сумма элементов текущей строки, столбца или второй диагонали матрицы }
begin
write('Введите размер матрицы (3..4) ',
'и нажмите <Enter> ->'); readln(n);
Writeln('Введите строки матрицы'); Writeln('После ввода строки',п,' целых чисел,',
1 нажимайте <Enter>'); for i:=1 to n do begin
write ('->');
for j:=l to n-1 do read(a[i,j]); readln(a[i,n]); end;
ok:=TRUE; { пусть матрица - магический квадрат } sum:=0;
{ вычислим сумму элементов главной диагонали } for i:=1 to n do sum:=sum+a[i,i];
{ вычисляем суммы по строкам}
i:=l;
repeat
temp:=0; ( сумма эл-тов текущей строки }
for j:=l to n do temp:=temp+a[i,j];
i:=i+l;
if temp <> sum then ok:=FALSE; until (not ok) or (i > n) ;
if ok then
{ здесь сумма элементов каждой строки равна сумме эл-тов главной диагонали }
begin
{ вычисляем суммы по столбцам }
repeat
temp:=0; { сумма эл-тов текущего столбца } . for i:=l to n do temp:=temp+a[i,j]; j:=j+l;
if temp <> sum then ok:=FALSE; until (not ok) or (j > n) ; if ok then
{ здесь сумма эл-тов каждой строки
равна сумме эл-тов каждого столбца и равна сумме эл-тов главной диагонали} begin
( вычислим сумму эл-тов второй
главной диагонали } temp:=0; j:=n;
for i:=l to n do begin
temp:=temp+a[i,j]; j:=j-l end;
if temp <> sum then ok:=FALSE; end; end;
write('Введенная матрица '); if not ok
then write('не ') ;
writeln('является магическим квадратом.'); readln; end.

f Подводит итоги Олимпийских игр

f Подводит итоги Олимпийских игр } const
N=10; (количество стран-участниц }
strana: array[1..N] of string[9]=('Австрия','Германия',
'Канада','Китай','Корея','Норвегия','Россия', 'США','Финляндия'array[1..МАХ,1..MAX] of integer; { матрица ) n: integer; { размер проверяемой матрицы } ok:boolean; { TRUE - матрица является маг. квадратом} i,j: integer; { индексы массива }
sum: integer; { сумма эл-тов главной диагонали матрицы temp: integer;{ сумма элементов текущей строки, столбца или второй диагонали матрицы }
begin
write('Введите размер матрицы (3..4) ',
'и нажмите <Enter> ->'); readln(n);
Writeln('Введите строки матрицы1); Writeln('После ввода строки',п,' целых чисел,',
'нажимайте <Enter>'); for i:=1 to n do begin
write('->');
for j:=l to n-1 do read(a[i,j]); readln(a[i,n]); end;
ok:=TROE; { пусть матрица - магический квадрат } sum:=0;
{ вычислим сумму элементов главной диагонали } for i: =1 to n do sum:=sum+a[i,i];
{ вычисляем суммы по строкам}
i :=1
repeat
temp:=0; { сумма эл-тов текущей строки }
for j:=l to n do temp:=temp+a[i,j];
i:=i+l;
if temp <> sum then ok:=FALSE; until (not ok) or (i > n) ;
if ok then
{ здесь сумма элементов каждой строки равна сумме эл-тов главной диагонали }
end.
{ вычисляем суммы по столбцам }
repeat
temp:=0; { сумма эл-тов текущего столбца } , for i:=l to n do temp:=temp+a[i,j];
if temp <> sum then ok:=FALSE; until (not ok) or (j > n); if ok then
( здесь сумма эл-тов каждой строки
равна сумме эл-тов каждого столбца и равна сумме эл-тов главной диагонали} begin
( вычислим сумму эл-тов второй
главной диагонали } temp:=0; j:=n;
for i:=l to n do begin
temp:=temp+a[i,j];
end;
if temp <> sum then ok:=FALSE; end; end;
write('Введенная матрица '); if not ok
then write('не '); writeln('является магическим квадратом.');
readln;
{ Подводит итоги Олимпийских игр } const
N=10; (количество стран-участниц }
strana: array[1..N] of string[9]=('Австрия','Германия',
'Канада','Китай','Корея','Норвегия','Россия', 'США','Финляндия'аблица результатов } result: arrayfl..N+l, 1..5] of integer; { N+1-я строка используется как буфер при сортировке таблицы }
i,j: integer;
max: integer; { номер строки таблицы, в которой
количество очков максимально }
buf: string[9]; { используется при сортировке } begin
writeln('Итоги Олимпийских игр');
writeln('Введите в одной строке количество золотых, ', 'серебряных и бронзовых медалей.');
{ ввод исходных данных } for i:=l to N do begin
write(strana[i],' ->');
read(result[i,1],result[i,2]); { кол-во золотых
и серебряных }
readln(result[i,3]); { кол-во бронзовых } end;
{ вычислим общее кол-во медалей и очков } for i:=l to N do begin
result[i,4]:=result[i, 1]+result[i,2]+result[i,3]; result [i,5]:=result[i,1]*7+result[i,2]* 6+result[ i, 3 ] * 5 ;
end;
{ сортировка массива в соответствии с количеством очков } { методом простого выбора } for i:=l to N-l do begin
( в части таблицы начиная со строки i найти j-ю строку, в которой элемент result[j, 5] максимальный }
max:=i; { пусть это строка с номером i } for j:=i+l to N do
if result[j,5] > result[max,5] thenmax:=j;
{ Обменяем i-ю строку со строкой с номером max В качестве буфера используем последнюю, не используемую строку таблицы. } buf:=strana[i]; strana[i]:=strana[max]; strana[max]:=buf; for j:=1 to 5 do begin
result[N+l,j]:=result[ i, j ] ; end;
for j : =1 to 5 do begin
result[i,j]:=result[max,j]; end;
for j:=1 to 5 do begin
result[max,j]:=result[N+l,j]; end; end;
{ здесь таблица упорядочена }
writeln;
writeln('Итоги зимней Олимпиады в Нагано, 1998 г.1);
writeln{'Страна':12 ,'Золото':8,'Серебро':8,'Бронза':8,
'Всего':8,'Очков' : 8) ; for i:=l to N do begin
write(i:2,strana[i]:10); for j:=1 to 5 do
write(result[i,j]:8); writeln; end; readln; end.

с одной из цифр игрока

( Игра "Угадай число" }
const
N=3; { уровень сложности - количество цифр в числ
igrok: array[1..N]of char; { комбинация игрока } comp: array[1..N]of char; { комбинация компьютера }
a:- arrayfl..N] of boolean; { a[i]= TRUE, если i-я цифра компьютера совпала с одной из цифр игрока }
ugad:integer;{ угадано чисел }
mesto:integer;{ из них на своих местах }
i/ji integer; { индексы массива }begin
writeln('Компьютер задумал трехзначное число. ',
'Вы должны его отгадать.'); writeln('После ввода очередного числа, вам будет ',
'сообщено, сколько цифр'); writeln('угадано и сколько из них находятся ',
'на своих местах. ') ; writeln('После ввода числа нажимайте <Enter>.');
{ компьютер "задумывает" свое число }
randomize;
for i:=l to N do
compfi]:=chr(random(lO)+48); ( 48 - код символа '0' }
write('Компьютер задумал: '); for i:=l to N do write(comp[i]); writeln;
repeat
write('Ваш вариант-> '); {получить вариант игрока } for i:=l to N-l do read(igrok[i]); readln(igrok[N]);for i:=l to N do a[i]:=FALSE;
( a[i] = TRUE, если i-я цифра числа компьютера
совпала с одной из цифр числа игрока }
{ проверим, сколько цифр угадано } ugad:=0;
for i:=l to N do { проверим каждую цифру игрока } for j : =1 to N do begin
if (igrok[i] = comp[j]) and not a[j] then begin
ugad:=ugad+l;
a[j]:=TRUE; { запретим сравнивать
эту цифру компьютера с оставшимися, еще не проверенными цифрами игрока } end; end;
{ проверим, сколько на своих местах }
mesto:=0;
for i:=l to N do
if igrok[i] = comp[i] then mesto:=mesto+l;
writeln('Угадано:',ugad,'. На своих местах:',mesto); until (ugad « N) and (mesto = N) ; writeln('***ВЫ УГАДАЛИ ЧИСЛО!***'); write('Нажмите <Enter> для завершения.'); readln; end.

передача сообщений при помощи азбуки

{ Телеграф - передача сообщений при помощи азбуки Морзе. { Замечание: возможно надо увеличить величины задержек. } uses Crt; const
morse: array[128..159] of string[4] =(
I I _
/
I 1 f
I I
I I _ f
1 I
I
I I
. I »___
I I /
1 1 /
_ I I _
1 1 f
I 1 I .
. 1 f .
{А,Б,В,Г}
{Д,Е,Ж,3} {И,Й,К,Л} {М,Н,О,П} {Р,С,Т,У} {Ф,Х,Ц,Ч} {Ш,Щ,Ъ,Ы} {Ь,Э,Ю,Я}
{параметры передачи }
TONE=100; { частота сигнала (гц) }
Ы=50; { длительность (мс) "точки" )
L2=100; ( длительность (мс) "тире"}
L3=50; { пауза (мс) между точками и тире одной буквы }
L4=100; { пауза (мс) между буквами }
L5=150; { пауза (мс) между словами }
var
rues : string; sim: string[4];
{ сообщение }
( символ в кодировке Морзе -
последовательность точек и тире }
{ "передаваемый" знак - тире или точка { номер символа и знака }
znak: string[l] i,j: integer; in
ClrScr;
writelnC*** Телеграф ***');
writeln('Введите сообщение, которое надо передать');
writeln('(используйте только большие русские буквы)');
write('->');
readln(mes);
for i:=l to Length(mes) do
begin
if (mes[i] >= 'A') and (mes[i] <='Я') then begin
( определим код очередной буквы (ф-я Ord) сообщения и получим из таблицы кодировки соответствующий элемент массива - последовательность точек и тире sim:=morse[ord(mes[i])]; repeat
if (sim[j] = •-•) or (sim[j] = begin
write (sim[j]) ; sound(1000); case sim[j] of 1.': Delay(50); '-': Delay(lOO); end;
NoSound; Delay(50); end;
then
until ((sim[j] = ' ') or (j>4)); Delay(100); { пауза между буквами } end else
if mes[i] = ' ' then ( пробел между словами } begin
write(' '); { пробел между словами сообщения } Delay(150); end; end;
writeln;
writeln('Сообщение передано!'); writeln('Для завершения работы с программой нажмите ',
¦<Enter>'); readln; end.

Функция max возвращает максимальное из

{ Функция max возвращает максимальное из двух чисел function max(a,b: integer): integer; begin
if a > b
then max:=a else max:=b; end;

в виде символа отношения

{ Возвращает результат сравнения чисел
в виде символа отношения } function Compare(a,b: real): char; begin
if a > b then Compare:='>' else
if a < b then Compare:='<•
else Compare:='='; end;
xl,x2: real; { сравниваемые числа }
res: char; { результат сравнения } begin
writeln('Введите два числа и нажмите <Enter>');
write('->');
readln(xl,x2);
res:=Compare(xl,x2); ( вызов функции программиста }
writeln(xl:6:2,res,x2:6:2);
readln; end.

Если тип соединения указан неверно,

{ Вычисляет сопротивление электрической цепи } function Sopr(rl,r2: real; t: integer): real; ( rl,r2 - величины сопротивлений t - тип соединения:
1 - последовательное;
2 - параллельное.
Если тип соединения указан неверно, то возвращает -1 }
begin
if t=l then Sopr:= rl+r2;
if t=2 then Sopr:= rl*r2/(rl+r2)
else Sopr:=-1; { неверно указан тип соединения} end;

Нас интересует значение С, поэтому

{ Вычисление степени числа с использованием свойств логарифмов }
function InStep(a,b:real):real;
begin
( А в сепени В равно С
Логарифмируем обе части равенства и получаем: В*In (A) = In (С)
Нас интересует значение С, поэтому вычисляем Е в степени В*In(А). Значение этого выражения равно С,что и требовалось вычислить. }
InStep:=exp(b*ln(a)); end;
var
a: real; { число }
b: real; { степень }
с: real; { число в степени } begin
writeln('Введите число и показатель степени');
readln(a,b);
c:=InStep(a,b);
writeln(a:6:3,' в степени ',Ь:6:3,' = ',с:б:3);
readln; end.
{ вычисляет доход по вкладу }
function Dohod(sum: real; { сумма вклада }
stavka: real; { процентная ставка (годовых) } srok: integer { срок вклада (дней) } ): real; begin
Dohod:=sum*(stavka/100/365)*srok; { 365 кол-во дней
в году } end;

является ли символ гласной буквой

{ Проверяет, является ли символ гласной буквой } Function Glasn(sim:char): boolean; const
{ гласные буквы }
ListOfGlasn:string ='АаЕеИиОоУуЫыЭэЮюЯя'; var
p: byte; { позиция проверяемого символа
в списке гласных } begin
p:=Pos(sim,ListOfGlasn); { !!!! } if p о 0 { символ найден в списке }
146
n Glasn:=True else Glasn:=False;
end;

Удаляет из строки начальные пробелы

{ Удаляет из строки начальные пробелы } function LTrim(st: string): string; begin
while (posC \st) = 1) and (length (st) > 0) do
delete(st,1,1); LTrim:=st; end;
{ проверка работы функции LTrim} var
s:string[80]; { строка } begin
writeln('Удаление из строки начальных пробелов.');
write('Введите строку ->');•
readln (s);
write('Строка без начальных пробелов:',LTrim(s));
readln; end.

Замещает стандартную процедуру UpCase} function

{ Преобразование строчных букв в прописные } ( Замещает стандартную процедуру UpCase} function UpCase(st:string): string; var
i:integer; begin
for i:=0 to Length(st) do { символы нумеруются с нуля ! } case st[i] of
{ латинские буквы}
'a'..'z':UpCase[i]:=chr(ord(st[i])-32);
{ русские буквы}
'a'..'n':UpCase[i]:=chr(ord(st[i])-32);
'p'..'я':UpCase[i]:=chr(ord(st[i])-80);
else { остальные символы не преобразуем
UpCase[i]:=st[i]; end;
end;
{ пример использования функции UpCase } var
st: string; begin
writeln(' Введите текст и нажмите <Enter>');
write('->');
readln(st);
writeln(UpCase(st));
readln; end.

Функция Getlnt предназначена для ввода

{ Решение квадратного уравнения }
function KvadrUr(a,b,c: real; var xl,x2: real): integer; { a,b,c - коэффициенты уравнения } { xl,x2 - корни уравнения } ( значение функции - количество корней
или -1, если неверные исходные данные } var
d: real; ( дискриминант } begin
if a = 0 then KvadrUr := -1 else begin
d:=b*b-4*a*c; if d < 0 then
KvadrUr:=0 { уравнение не имеет решения } else begin if d > О
then KvadrUr:=2 { два разных корня } else KvadrUr:=1; { корни одинаковые } xl:=(-b+Sqrt(d))/(2*a); x2:=(-b-Sqrt(d))/(2*a); end; end; end;
сновная программа } var
a,b,c: real; { коэффициенты уравнения } xl,x2: real; ( корни уравнения } begin
writeln('Решение квадратного уравнения');
writeln('Введите в одной строке коэффициенты и нажмите
'<Enter>'); write('->'); readln(a,b,с); case KvadrUr(a,b,c,xl,x2) of
-1: writeln('Ошибка исходных данных.'); 0: writeln('Уравнение не имеет решения.'); 1: writeln('x=',xl:6:2,' Корни одинаковые.'); 2: writelnГxl=',xl:6:2,' х2=',х2:6:2);
end; readln; end.
uses Crt; var
a:integer; { число, введенное пользователем }
{ Функция Getlnt предназначена для ввода целого
положительного числа, состоящего из одной или двух цифр.
Во время ввода для редактирования может использоваться
<Backspace>.
При нажатии <Enter> функция возвращает введенное число. }
function Getlnt:integer; const
K_BACK=8; { код клавиши <Backspace> }
K_ENTER=13; { код клавиши <Enter> } var
ch:char; { символ }
dec:byte; { код символа }
buf:array[l..2] of char; { введенные цифры }
n:integer; { кол-во введенных цифр }
x,у:integer; { положение курсора } begin
buf[1]:=' '; buf[2]:=' ';
then
n:=0; repeat
ch:=Readkey; dec:=ord(ch);
if (ch>='0') and (ch<='9') and (n<2) begin
write(ch); n:=n+l; buf[n]:=ch; end else
if (dec=K_BACK) and (n>0) then begin
n:=n-l; x:=WhereX; y:=WhereY; GotoXY(x-l,y); write(' '); GotoXY(x-l,y); end;
until (n>0) and (dec=K_ENTER); { преобразуем введенную строку в число } if n=2
then Getlnt:=(ord(buf[1])-48)*10+ord(buf[2])-48 else Getlnt:=ord(buf[1])-48; end;
begin
ClrScr;
writeln('*** Демонстрация работы функции Getlnt. ***');
writeln;
writeln('Функция Getlnt предназначена для ввода целого
'положительного числа,');
writeln('состоящего из одной или двух цифр.'); writeln('Во время ввода для редактирования может ',
'использоваться <Backspace>.'); writeln('При нажатии <Enter> функция возвращает ',
'введенное число.'); writeln;
writeln('Введите число и нажмите <Enter>'); write('->');
teln('ftnH завершения работы программы нажмите ',
1<Enter>'); readln; Halt(l); end;
{ полотнище флага }
SetFillStyle(SolidFill,LightGray); { сплошная заливка
серым цветом } Ваг(80,80,200,135);
{ кольца }
SetColor(Green); ( зеленое }
Circle(100,100,15);
SetColor(Black); { черное }
Circle (140,100,15);
SetColor(Red); { красное }
Circle(180,100,15);
SetColor(Yellow); { желтое }
Circle(120,115,15);
SetColor(Blue); { синее }
Circle(160,115,15);
readln; CloseGraph; end.

с использованием метода базовой точки

{ Рисует кораблик с использованием метода базовой точки }
uses Graph;
const
{ шаг сетки }
dx=5; { по X}
dy=5; ( по Y}
grDriver:integer; { драйвер }
grMode:integer; { графический режим }
grPath:string; { место расположения драйвера }
ErrCode:integer; { результат инициализации граф. режима }
х,у:integer; ( координаты базовой точки кораблика
begin
grDriver := VGA; grMode:=VGAHi; grPath:='e:\tp\bgi'
режим VGA}
разрешение 640x480}
драйвер, файл EGAVGA.BGI, находится
в каталоге d:\tp\bgi }
InitGraph(grDriver, grMode,grPath);
ErrCode : = GraphResult;
if ErrCode <> grOk then Halt(l);
x:=10;
y:=200;
{ корпус }
MoveTo(x,y);
LineTo(x,y-2*dy);
LineTo(x+10*dx,y-2*dy);
LineTo(x+ll*dx,y-3*dy);
LineTo(x+17*dx,y-3*dy);
LineTo(x+14*dx,y);
LineTo(x,y);
{ надстройка }
MoveTo(x+3*dx,y-2*dy);
LineTo(x+4*dx,y-3*dy);
LineTo(x+4*dx,y-4*dy);
LineTo(x+13*dx,y-4*dy);
LineTo(x+13*dx,y-3*dy);
Line(x+5*dx,y-3*dy,x+9*dx,y-3*dy);
{ капитанский мостик }
Rectangle(x+8*dx,y-4*dy,x+ll*dx,y-5*dy);
{ труба }
Rectangle(x+7*dx,y-4*dy,x+8*dx,y-7*dy);
{ иллюминаторы }
Circle(x+12*dx,y-2*dy,Trunc(dx/2));
Circle(x+14*dx,y-2*dy,Trunc(dx/2));
( мачта }
Line(x+10*dx,y-5*dy,x+10*dx,y-10*dy);
{ оснастка }
MoveTo(x+17*dx,y-3*dy);
LineTo(x+10*dx,y-10*dy);
LineTo(x,y-2*dy);
154
dln; CloseGraph; end.

Выводит узор из 100 произвольно

{ Выводит узор из 100 произвольно размещенных окружностей произвольного радиуса и цвета }
Uses Graph; var
grDriver:integer; grMode:integer; grPath:string; ErrCode:integer;
x,y,r: integer; { координаты центра и радиус окружности } i: integer; begin
grDriver:=VGA; grMode:=VGAHi; grPath:='e:\tp\bgi'; InitGraph (grDriver,grMode,grPath); ErrCode:=GraphResult; if ErrCode <> grOK then begin
writeln ('Ошибка инициализации графического режима.1); writeln ('Для завершения работы нажмите <Enter>'); readln; Halt (1); end;
Randomize; for i:=l to 100 do begin
x:=Random(64 0); y:=Random(480); r:=Random(240); Setcolor(Random(16)); Circle(x,y,r); end; readln; end.

Выводит узор из 200 случайно

{ Выводит узор из 200 случайно размещенных линий разного цвета }
Uses Graph; var
grDriver:integer; grMode:integer; grPath:string; ErrCode:integer;
x,y: integer; { координаты конца линии } i: integer; begin
grDriver:=VGA; grMode:=VGAHi; grPath:='e:\tp\bgi'; InitGraph (grDriver,grMode,grPath); ErrCode:=GraphResult; if ErrCode <> grOK then begin
writeln ('Сшибка инициализации графического режима.');
writeln ('Для завершения работы нажмите <Enter>');
readln;
Halt (1); end;Randomize; for i:=l to 200 do begin
x:=Random(640); y:=Random(480); Setcolor(Random(16)); LineTo(x,y); end; readln; end.

и прямой, соединяющей центр звезды

{ Рисует контур пятиконечной звезды } uses Graph;
el
bye; var
r: integer; { радиус звезды )
хО,уО: integer; { координаты центра звезды }
х,у: integer; a: integer;
i: integer;
{ координаты конца луча }
{ угол между осью ОХ и прямой, соединяющей центр звезды и конец луча }
grDriver: Integer; grMode: Integer; ErrCode: Integer; res: integer;
begin
grDriver := detect;
InitGraph(grDriver, grMode,'e:\tp\bgi');
ErrCode := GraphResult;
if ErrCode <> grOk then
begin
writelnf'Ошибка инициализации графического режима.'); goto bye; end;
xO:=100; yO:=100; r:=20;
a:=18; ( строим от правого гор. луча } x:=xO+Round(r*cos(a*2*pi/360)); y:=yO-Round(r*sin(a*2*pi/360)); MoveTo(x,y); for i:=l to 5 do begin
a:=a+36;
x:=xO+Round(r/2*cos(a*2*pi/360));
y:=yO-Round(r/2*sin(a*2*pi/360));
LineTo(x,y);
a:=a+36;
if a > 360 then a:=18;
x:=xO+Round(r*cos(a*2*pi/360));

y:=yO-Round(r*sin(a*2*pi/360)); LineTo(x,y); end; readln; bye: end.

пересчета величины угла из градусов

( Рисует пятиконечную звезду }
uses Graph;
label
bye; const
k=0.01745; { коэф. пересчета величины угла из градусов в радианы к=2*р/360, где р - число "ПИ" }
г: integer; { радиус звезды }
x0,y0: integer; ( координаты центра звезды }
р: array[1..10] of PointType; { координаты концов лучей
и впадин звезды }
a: integer;
i: integer;
{ угол между осью ОХ и прямой, соединяющей центр звезды и конец луча или впадину }
grDriver: Integer; grMode: Integer; ErrCode: Integer; res: integer;
begin
grDriver := detect;
InitGraph(grDriver, grMode,'e:\tp\bgi');
ErrCode := GraphResult;
if ErrCode <> grOk then
begin
writeln('Ошибка инициализации графического режима.');
goto bye; end;
:=1ОО;
уО:=1ОО; г:=20;
а:=18; ( строим от правого гор. луча }
for i:=l to 10 do
begin
if (i mod 2) <> 0 then begin ( луч }
i].x:=xO+Round(r*cos(a*k)); i].y:=yO-Round(r*sin(a*k)); end else
begin { впадина }
p[i].x:=xO+Round(r/2*cos(a*k)); p[i].y:=yO-Round(r/2*sin(a*k)); end;
a:=a+36;
if a > 360 then a:=18; end;
SetFillStyle(SolidFill,Red); FillPoly(10,p); readln; bye: end.
{ Рисует российский флаг }
uses Graph;
var
x,y: integer; { координаты левого верхнего угла флага ) l,h: integer; { длина и высота флага } w: integer; { ширина полосы флага }
grDriver: Integer; grMode: Integer; ErrCode: Integer; res: integer;
grDriver := detect;
InitGraph(grDriver, grMode,'e:\tp\bgi'; ErrCode := GraphResult; if ErrCode = grOk then begin
x:=100;
y:=100;
l:=50;
h:=25;
w:=Round(h/3);
{ рисуем флаг }
SetFillStyle(SolidFill,White);
Bar(x,y,x+l,y+w);
SetFillStyle(SolidFill,Blue);
Bar(x, y+w,x+1,y+2*w);
SetFillStyle(SolidFill,Red);
Bar(x,y+2*w,x+l,y+3*w);
OutTextXY(x,y+h+5,'Россия'); end; readln; CloseGraph; end.

Рисует веселую рожицу желтого цвета

( Рисует веселую рожицу желтого цвета }
uses Graph;
var
grDriver:integer
grMode:integer;
grPath:string;
ErrCode:integer;
{ драйвер }
{ графический режим }
{ место расположения драйвера }
{ результат инициализации граф. режима }
begin
grDriver := VGA; grMode:=VGAHi; grPath:='e:\tp\bgi';
{ режим VGA} { разрешение 64 0x480}
{ драйвер, файл EGAVGA.BGI, находится в каталоге e:\tp\bgi }
InitGraph(grDriver, grMode,grPath); ErrCode := GraphResult;
ErrCode <> grOk then begin
writeln('Ошибка инициализации графического режима.'); writeln('flrm завершения работы программы ',
'нажмите <Enter>'); readln; Halt(l); end;
SetFillStyle(SolidFill,Yellow);
Setcolor(Yellow); ( чтобы на круге не было линии } PieSlice(100,100,0,360,20); SetColor(Black);
Arc(100,102,180,360,10); { рот } { глаза } Circle(93,93,2); Circle(107,93,2); readln; CloseGraph; and.

Выводит узор из концентрических окружностей

{ Выводит узор из концентрических окружностей разного цвета
Uses Graph;
var
grDriver:integer;
grMode:integer;
grPath:string;
ErrCode:integer;
x,y,r: integer; { координаты центра и радиус окружности }
dr:' integer; { приращение радиуса окружности }
i: integer; { счетчик циклов } begin
grDriver:=VGA;
grMode:=VGAHi;
grPath:='e:\tp\bgi';
InitGraph (grDriver,grMode,grPath);
ErrCode:=GraphResult;
if ErrCode <> grOK then
begin
writeln ('Ошибка инициализации графического режима.'); writeln ('Для завершения работы нажмите <Enter>'); readln; Halt (1); end;
x:=100; y:=100; r:=5; dr:=5; for i:=l to 15 do begin
SetColor(i); Circle (x,y, r) ; r:=r+dr; end; readln; end. { Вычерчивает узор из окружностей }
Uses Graph;
var
grDriver:integer;
grMode:integer;
grPath:string;
ErrCode:integer;
x,y: integer;
r: integer;
1: integer;
{ координаты центра окружности }
{ радиус окружности }
{ расстояние между центрами окружностей
i,j: integer; { счетчики циклов } begin
grDriver:=VGA; grMode:=VGAHi; grPath:='e:\tp\bgi'; InitGraph (grDriver,grMode,grPath); ErrCode:=GraphResult; if ErrCode <> grOK then begin
writeln ('Ошибка инициализации графического режима.'] writeln ('Для завершения работы нажмите <Enter>');
dln;
Halt (l);
end;
у:=100;
r:'=20;
1:=30;
for i:=1 to 4 do
begin
x:=100;
for j:=l to 5 do
begin
Circle (x,y,r) ,
x:=x+l ;
end;
y:=y+l;
end;
readln;
end.

левого верхнего угла квадрата

{ Вычерчивает узор из квадратов
Uses Graph;
var
grDriver:integer;
grMode:integer;
grPath:string;
ErrCode:integer;
x,y: integer; { коорд. левого верхнего угла квадрата }
d: integer; { длина с ;тороны квадрата }
n: integer; { кол-во квадратов в ряду }
1: integer; { расстояние между квадратами }
i,j: integer; ( счетчики циклов }
begin
grDriver:=VGA;
grMode:=VGAHi;
grPath:='e:\tp\bgi';
InitGraph (grDriver, grMode grPath);
ErrCode:=GraphResult
if ErrCode <> grOK then begin
writeln ('Ошибка инициализации графического режима.');
writeln ('Для завершения работы нажмите <Enter>');
readln;
Halt (1); end; y:=100; d:=30;
for i:=l to 5 do begin
if ((i mod 2) = 1)
then begin { нечетный ряд }
n:=5; { пять квадратов в ряду } х:=100; end
else begin { четный ряд } п:=4;
x:=100+Round(d/2+l/2); end;
for j : =1 to n do begin
Rectangle(x,y,x+d,y+d); x:=x+d+l; end;
y:=y+Round(d/2+l/2) ; end; readln; end.

рисует на экране шахматную доску

{ рисует на экране шахматную доску } uses Graph;
var
хО,уО: integer; { координаты левого верхнего угла доски }
х,у: integer; { координаты левого верхнего угла клетки }
w: integer; { размер клетки }
i,j: integer; { номер строки и колонки }
grDriver: Integer; grMode: Integer; ErrCode: Integer; res: integer; begin'
grDriver := detect;
InitGraph(grDriver, grMode,'e:\tp\bgi');
ErrCode := GraphResult;
if ErrCode = grOk then
begin
x0:=100;
y0:=100;
w:=25;
x:=xO;
y:=yO;
for i:=l to 8 do { восемь строк }
begin
for j:=l to 8 do { восемь клеток в строке } begin
{ если сумма номера строки и номера колонки, на пересечении которых* находится клетка, четная, то клетка - коричневая, иначе - желтая } if ((i+j) mod 2) = О
then SetFillStyle(SolidFill,Brown) else SetFillStyle(SolidFill,Yellow); Bar(x,y,x+w,y+w); x:=x+w; end; x:=xO; y:=y+w;
end;
readln;
end;
CloseGraph; end. { Рисует флажок } Uses Graph; var
grDriver:integer;
grMode:integer; grPath:string; ErrCode:integer;
flag: array[1..6] of PointType; { коотринаты точек флажка } begin
grDriver:=VGA; grMode:=VGAHi; grPath:='e:\tp\bgi'; InitGraph (grDriver,grMode,grPath); ErrCode:=GraphResult; if ErrCode <> grOK then begin
writeln ('Ошибка инициализации графического режима.');
writeln ('Для завершения работы нажмите <Enter>');
readln;
Halt (1); end; { задать координаты контура - флажка }
flag[l] .х flag[2].x flag[3].x flag[4].x flag[5].x flag[6].x
=100;flag[l].y:=100; =160;flag[2].y:=100; =140;flag[3].y:=120; =160;flag[4].y:=140; =100;flag[5].y:=140; =100;flag[6].y:=100;
SetFillStyle(SolidFill, Red); FillPoly(6,flag); Line(100,140,100,170); readln; end.

Выводит на экран паровоз

{ Выводит на экран паровоз } uses Graph;
grDriver: Integer; grMode: Integer; ErrCode: Integer; res: integer;
,уО: integer; { координаты базовой точки паровоза } dx,dy: integer; { шаг координатной сетки } tr: array[1..15] of PointType; { координаты точек контура
паровоза }
begin
grDriver := detect;
InitGraph(grDriver, grMode,'e:\tp\bgi');
ErrCode : = GraphResult;
if ErrCode = grOk then
begin
x0:=100; y0:=100;
dx:=5; dy:=5;
{ корпус }
tr[l].y:=yO+7*dy; tr[2].y:=yO+6*dy; tr[3].y:=yO+6*dy; tr[4].y:=yO+3*dy; tr[5].y:=yO+3*dy; tr[6].y:=yO+O*dy; tr[7]".y:=y0+0*dy; fcr[8].y:=yO+3*dy; tr[9].y:=yO+3*dy; tr[10].y:=yO+l*dy; .y:=yO+l*dy;
tr[1].x:=xO+O*dx;
tr[2].x:=xO+O*dx;
tr[3].x:=xO+l*dx;
tr[4J .x:=xO+l*dx;
tr[5].x:=xO+2*dx;
tr[6].x:=xO+2*dx;
tr[7].x:=xO+3*dx;
tr[8].x:=xO+3*dx;
tr[9].x:=xO+7*dx;
tr[10].x:=xO+7*dx;
tr[ll].x:=xO+13*dx;
tr[12].x:=xO+13*dx; tr[12].y:=yO+2*dy;
tr[13].x:=xO+12*dx; tr[13].y:=yO+2*dy;
tr[14].x:=xO+12*dx; tr[14].y:=yO+7*dy;
tr[15].x:=xO+O*dx; tr[15].y:=yO+7*dy;
DrawPoly(15,tr);
{ окно )
Rectangle(xO+8*dx,yO+2*dy,x0+10*dx,yO+4*dy),
{ колеса )
SetFillStyle(SolidFill,Red);
SetColor(Red);
PieSlice(xO+3*dx,yO+7*dy, 0,360,l*dx);
PieSlice(xO+6*dx, yO+7*dy,0,360,l*dx);
PieSlice(xO+9*dx,yO+7*dy,0,360,l*dx);
{ окантовка колес }
SetColor(White);
Circle(xO+3*dx,yO+7*dy,l*dx), Circle(xO+6*dx,yO+7*dy,l*dx), Circle(xO+9*dx,yO+7*dy,l*dx),
readln; end;
CloseGraph; end.

шаг координатной сетки 40 пикселей

{ Координатные оси и оцифрованная сетка } program grid; uses Graph;
var
xO,yO:integer; { координаты начала координатных осей } dx,dy:integer; { шаг координатной сетки (в пикселах) ) h,w:integer; { высота и ширина области вывода координатной
сетки > х,у:integer;
lx,ly:real; ( метки (оцифровка) линий сетки по X Y } dlx, dly:real; { шаг меток (оцифровки) линий сетки по X и Y } st:string; { изображение метки линии сетки }
grDriver: Integer; grMode: Integer; ErrCode: Integer;
begin
grDriver := VGA;
grMode:=VGAHi;
InitGraph(grDriver, grMode,'e:\tp\bgi');
ErrCode := GraphResult;
if ErrCode <> grOk then Halt(1);x0:=50; yO:=45O; ( оси начинаются в точке (40,450) } dx:=40; dy:=40; ( шаг координатной сетки 40 пикселей } dlx:=0.5; { шаг меток оси X, метками будут:=l;
шаг меток оси Y, метками будут: 1, 2, и т.д. }
h: =300;
w: =400;
lx :=0;
iy :=0;
{ начало координат помечается метками 0 )Line(x0,y0,x0,y0-h); { ось X } Line(x0,y0,x0+w,y0); { ось Y }
{ засечки, сетка и оцифровка по оси X }
х:=х0;
repeat
{ засечка }
SetLineStyle(SolidLn, 0, NormWidth);
Line(x,yO-3,x,yO+3);
{ оцифровка }
Str(lx:0:l,st);
OutTextXY(x-8,yO+5,st);
lx:=lx+dlx;
{ линия сетки }
SetLineStyle(DottedLn, 0, NormWidth);
Line(x,yO-3,x,yO-h);
x:=x+dx; until (x>x0+w);
{ засечки, сетка и оцифровка по оси Y }
у:=у0;
repeat
{ засечка }
SetLineStyle(SolidLn, 0, NormWidth);
Line(xO-3,y,xO+3,y);
( оцифровка }
Str(ly:0:l,st);
OutTextXY(xO-40,y,st);
ly:=ly+dly;
{ линия сетки }
SetLineStyle(DottedLn, 0, NormWidth);
Line(x0+3,y,xO+w,y);
SetLineStyle(SolidLn, 0, NormWidth); y:=y-dy; until (y<yO-h);
Readln; CloseGraph;
end.

координаты точек на экране

Uses Graph; var
x,dx: real;
xl,x2: real;
y: real;
mx,my: integer;
{ аргумент и его приращение } ( диапазон изменения аргумента } { значение функции } { масштаб по X и Y - кол-во точек
экрана, соответствующее единице
по осям координат } { начало осей координат } { координаты точек на экране }
хО,уО: integer; рх,ру: integer;
grDriver:integer; grMode:integer; grPath:string; ErrCode:integer;
i: integer;
begin
grDriver:=VGA;
grMode:=VGAHi;
grPath:='e:\tp\bgi';
InitGraph (grDriver,grMode,grPath);
ErrCode:=GraphResult;
if ErrCode <> grOK then
begin
writeln ('Ошибка инициализации графического режима.'); writeln ('Для завершения работы нажмите <Enter>'); readln; Halt (1);
end;
:=320; у0:=240;
тх:=20; ту:=20;
{ оси координат }
Line(10,y0,630,y0);
Line(xO,10,xO,470);
{ график }
xl:=-15;
х2:=5;
dx:=0 Л;
х:=xl;
while (x<x2) do
begin
у:= 0.5*х*х+х*4-3;
рх:=xO+Round(x*mx);
py:=yO-Round(y*my) ;
PutPixel(px,py,White);
x:=x+dx; end; readln;
end.

результат инициализации граф. режима

{ Движущееся сложное изображение }
uses Graph, Crt;
var
grDriver:integer; { драйвер } grMode:integer; { графический режим } grPath:string; { место расположения драйвера } ErrCode:integer; { результат инициализации граф. режима }
х,у:integer; { координаты кораблика } color:word; { цвет кораблика } bkcolor:word; { цвет фона экрана }
{ Кораблик }
Procedure Titanik(x,у:integer; color:word); const
dx=5;
dy=5;
координаты базовой точки } цвет корабля }
var
01dColor:word; begin
01dColor:=GetColor; { сохранить текущий цвет ) SetColor(color); { установить новый цвет }
{ корпус } MoveTo(x,y); LineTo(x,y-2*dy); LineTo(x+10*dx,y-2*dy); LineTo(x+ll*dx,y-3*dy); LineTo(x+17*dx,y-3*dy); LineTo(x+14*dx,у); LineTo(x,у); { надстройка } MoveTo(x+3*dx,y-2*dy); LineTo(x+4*dx,y-3*dy); LineTo(x+4*dx,y-4*dy); LineTo(x+13*dx,y-4*dy); LineTo (x+13*dx,y-3*dy) ; Line(x+5*dx,y-3*dy,x+9*dx,y-3*dy); { капитанский мостик }
Rectangle(x+8*dx,y-4*dy,x+ll*dx,y-5*dy); { труба }
Rectangle(x+7+dx,y-4*dy,x+8*dx,y-7*dy); { иллюминаторы }
Circle(x+12*dx,y-2*dy,Trunc(dx/2)); Circle(x+14*dx,y-2*dy,Trunc(dx/2)); { мачта }
Line(x+10*dx,y-5*dy,x+10*dx,y-10*dy); ( оснастка } MoveTo(x+17*dx,y-3*dy); LineTo(x+10*dx, y-10*dy) ; LineTo(x,y-2*dy);
SetColor(OldColor); { восстановить текущий цвет end; begin
grDriver := VGA; grMode:=VGAHi; grPath:='e:\tp\bgi¦;
режим VGA}
разрешение 640x480}
драйвер, файл EGAVGA.BGI, находится
в каталоге d:\tp\bgi }
tGraph(grDriver, grMode,grPath);
ErrCode := GraphResult;
if ErrCode о grOk then Halt(l);
x:=10;
y:=200;
color:=LightGray;
SetBkColor(Blue);
bkcolor:=GetBkColor;
repeat
Titanik(x,y,color);
Delay(lOO);
Titanik(x,y,bkcolor); { стереть корабль }
PutPixel(x,y,color); { след от корабля }
x:=x+2;
until (x>500);
OutTextXY(10,10,'Рейс завершен!'); readln; CloseGraph; end.
нарисовать корабль }

возвращает изображение дробного числа} function

{ Обрабатывает результаты контрольной работы
и отражает их в виде диаграммы } uses Crt, Graph;
( возвращает изображение дробного числа} function RealToStr(r: real; n,m: integer): string; var
st: string; begin
Str(r:n:m,st); RealToStr:=st; end;
const
{ подсказка при вводе исходных данных и
подпись рядом с прямоугольником легенды } mes: array[2..5] of string[10] =
Сдвоек1,'троек','четверок','пятерок');
var
array[2..5] of integer; { количество пятерок, четверок,
integer;
array[2..5] of real;
троек и двоек } { всего оценок } { процент каждой оценки
array[2..5] of integer; { высоты столбиков диаграмм }
integer; { номер максимального эл-та массива п integer; { индекс массива }
х,у: integer; { координаты левого нижнего угла столбика диаграммы }
grDriver:integer; { драйвер }
grMode:integer; { графический режим }
grPath:string; { место расположения драйвера }
ErrCode:integer; { результат инициализации граф.
begin
( ввод исходных данных }
TextBackground(Blue);
TextColor(LightGray) ;
ClrScr;
writeln('Обработка результатов контрольной работы');
writeln('Введите исходные данные:');
for i:=5 downto 2 do begin
write(mes[i],' -> '); readln(n[i]); end;
for i:=2 to 5 do s:=s+n[i]; { всего оценок }
{ вычислим процент каждой оценки } for i:=2 to 5 do p[i]:=(n[i]/s)*100;
{ вычислим высоту каждого столбика диаграммы, } { но сначала определим, каких оценок больше } т:=5; { пусть больше всегоусть количеству оценок, которых больше, соответствует столбик высотой 200 пикселей. Вычислим высоты остальных столбиков. }
for i:=5 downto 2 do
. h[i]:=Round( (200/n[m])*n[i] );
{ обработка выполнена, строим диаграмму }
grDriver := VGA; { режим VGA}
grMode:=VGAHi; { разрешение 640x480}
grPath:='e:\tp\bgi'; { драйвер, файл EGAVGA.BGI, находится
в каталоге e:\tp\bgi } InitGraph(grDriver, grMode,grPath); ErrCode := GraphResult; if ErrCode <> grOk then begin
writeln('Ошибка инициализации графического режима.1); writeln(',njM завершения работы программы ',
'нажмите <Enter>'); readln; Halt (l^-
{ строим диаграмму }
OuttextXY(40,50,'Результаты контрольной работы'); Rectangle(40,80,170,310);
х:=50; у:=300; { левый нижний угол первого столбика } { столбики диаграммы } for i:=5 downto 2 do begin
SetFillStyle(SolidFill,i);
Bar(x,y,x+10,y-h[i]); { столбик }
{ OutTextXY(x,y-h[i]-10,RealToStr(p[i],5,2)+'%');
x:=x+20; end;
{ численные значения } x:=50;
for i:=5 downto 2 do begin
SetFillStyle(SolidFill,i);
{Bar(x,y,x+10,y-h[i]); { столбик }
OutTextXY(x,y-h[i]-10,RealToStr(p[i],5,1)+'%');
x:=x+20; end;
{ легенда } х:=200;у:=100; for i:=5 down to 2 do begin
SetFillStyle(SolidFill,i); Bar(x,y,x+20,y+10); { столбик } OutTextXY(x+25,y,raes[i]); y:=y+20; end; readln; CloseGraph; end. { Выводит круговую диаграмму }
uses Graph;
const
N=4; ( количество категорий }
name: array[1..N] of
string[10]=('Книги','Журналы','Канцтовары','Прочее'); var
kol: array[1..N] of real,
dol: array[l..N] of real;
sum: real; al,a2: integer; x,y: integer; st: string; i: integer;
{ количество для категории }
{ доля категории в общем
количестве }
{ общее кол-во по всем категориям { угол начала и конца сектора } ( координаты вывода легенды } { изображение числа }
grDriver:integer; { драйвер }
grMode:integer; { графический режим }
grPath:string; { место расположения драйвера }
ErrCode:integer; { результат инициализации граф. режима }
begin
grDriver := VGA; { режим VGA} grMode:=VGAHi; ( разрешение 640x480} grPath:='e:\tp\bgi'; ( драйвер, файл EGAVGA.BGI, находится
в каталоге e:\tp\bgi }
tGraph(grDriver, grMode,grPath); ErrCode := GraphResult; if ErrCode о grOk then begin
. writeln('Ошибка инициализации графического режима.');
writeln('Для завершения работы программы ', 'нажмите <Enter>');
readln;
Halt(l); end;
{ ввод исходных данных }
writeln('Введите количество по каждой категории'); sum:=0;
for i:=l to N do begin
write(name[i],' ->'); readln(kol[i]); sum:=sum+kol[i]; end;
f вычислим долю каждой категории в общей сумме } for i:=l to N do
]:=kol[i]/sum*100;
{ строим диаграмму } al:=0; ( от оси ОХ }
x:=350; y:=100; { левый верхний угол области легенды } for i:=l to N do begin
{ сектор }
a2:=al+Round(3.6*Dol[i]); { 1% - 3.6 градуса }
if a2 > 360 then a2:=360;
SetFillstyle(SolidFill,i);
PieSlice(200,200,al,a2,100);
al:=a2; { следующий сектор - от конца текущего }
{ легенда }
Ваг(х,у,х+30,у+10);
Rectangle(х,у,х+30,у+10);
str(dol[i]:6:1,at);
OutTextXY(x+50,y,name[i]+' -'
y:=y+20; end;
readln; CloseGraph; end.

и осью ОХ равен 90

{ Светофор } uses Graph, Crt;
grDriver: Integer; grMode: Integer; ErrCode: Integer; res: integer;
i,j: integer; { счетчики циклов }
{ Рисует круг заданного цвета}
{ х,у,г - координаты центра и радиус круга }
( fc,bc - цвет круга и окантовки }
Procedure Krug(x,y,r: integer; fc,bc: integer);
begin
SetFillStyle(SolidFill,fc);
SetColor(fc);
PieSlice(x,y,0,360,r);
SetColor(be);
Circle(x,y,r); end;
{ Основная программа } begin
grDriver := detect;
InitGraph(grDriver, grMode,'e:\tp\bgi');
ErrCode := GraphResult;
if ErrCode = grOk then
begin
OutTextXYdO,10,'Соблюдайте правила уличного движения!'
Rectangle(88,88,112,152);
{ Горит красный свет }
KrugdOO, 100,10,Red,White) ;
Krug(100,120,10,LightGray,White);
Krug(100,140,10,LightGray,White);
Начальное положение стрелок: угол
между стрелкой и осью ОХ равен 90 град. as:=90; am: =90;
Circle(xO,yO,d+5); SetFillStyle{SolidFill,0); Str(m,stm); repeat
{ вывести секундную стрелку }
MoveTo(x0,y0);
SetColor(Yellow);
Vector(as,d);
( вывести минутную стрелку } MoveTo(x0,y0); SetColor(Green); Vector(am,d-10);
{ вывести "цифровые" часы }
Bar(10,10,50,20);
Str (s,sts) ;
OutTextXy(10,10,stm+':'+sts);
Delay(lOO); { задержка
{ стереть стрелки } SetColor(0); { секундную } MoveTo(x0,y0); Vector(as,d);
{ минутную } MoveTo(x0,y0) ; Vector(am,d-10);
s:=s+l;
if s = 60 then
begin
m:=m+l; Str (m, stm) ; s:=0;
Sound(1000); Delay(10); NoSound;
am:=am-6; { шаг движения минутной
стрелки б градусов } if am < 0 then am:=354; end;
as:=as-6;
if as < 0 then as:=354;
until KeyPressed; end;
CloseGraph; end.
( Построение графика функции } program groffunc; uses Graph;
var
xl,x2:real; yl,y2:real; x:real; y:real; dx:real; l,b:integer; w,h:integer; mx,my:real; xO,yO:integer; st:string;
{границы изменения аргумента функции }
{ границы изменения значения функции }
{ аргумент функции }
{ значение функции в точке х}
( приращение аргумента }
{ левый нижний угол области вывода графика }
{ ширина и высота области вывода графика }
{ масштаб по осям X и Y }
{ точка - начало координат }
( изображение числа }
grDriver: Integer; grMode: Integer; ErrCode: Integer;
Функция, график которой надо построить } Function f(x:real):reain
f:=2*Sin(x)*exp(x/5); end;
Function f2(x:real):real; begin
f2:=Ln(x); end;
begin
grDriver := VGA;
grMode:=VGAHi;
InitGraph(grDriver, grMode,'e:\tp\bgi');
ErrCode := GraphResult;
if ErrCode о grOk then Halt(l);
l:=40; b:=400; h:=200; w:=200;
xl:=0;
x2:=25;
dx:=0.01;
{ найдем максимальное и минимальное значения
функции на отрезке [xl,x2] } yl:=f(xl); { минимум } y2:=f(xl); ( максимум } x:=xl;
repeat y:=f (x); if y<yl then yl:=y; if y>y2 then y2:=y; x:=x+dx; until (x>=x2);
my:=h/abs(y2-yl); mx:=w/abs(x2-xl); { оси } xO:=l; yO:=b-Abs(Round(yl*my));
Line(l,b,l,b-h); Line(xO,yO,xO+w,yO); Str(y2:5:l,st); OutTextXY(l+5,b-h,st); Str(yl:5:l,st); OutTextXY(l+5,b,st);
{ построение графика }
x:=xl;
repeat
y:=f(x);
PutPixel(xO+Round(x*mx),yO-Round(y*my),15);
x:=x+dx; until (x>=x2); Readln; CloseGraph;
end.

ждем нажатия клавиши, курсор мигает

uses Graph,Crt;
{ в графическом режиме вводит с клавиатуры дробное число } Function GetReal: real; var
ch: char; { символ нажатой клавиши }
buf: string[80]; { введенная строка }
numb: real; { введенное число }
code: integer; { код ошибки преобразования строки
в число } begin
buf:=''; repeat
{ ждем нажатия клавиши, курсор мигает } repeat
if not KeyPressed then begin
Setcolor(White);
Line(GetX,GetY,GetX,GetY+8);
Delay(250);
color(Black); Line(GetX,GetY,GetX,GetY+8); end;
if not KeyPressed then Delay(250); until KeyPressed; { здесь нажата клавиша } ch:=ReadKey; SetColor(White); case ch of
'0'..'9': begin Outtext(ch); buf:=buf+ch; end; '.': if Pos('.',Buf) = 0 then begin Outtext(ch);
buf:=buf+ch; end; '-': if Length(buf) » 0 then begin Outtext(ch);
buf:=ch; end;
Chr(8): if Length(buf) <> 0 then { нажата <BackSpace> } begin
SetFillStyle(SolidFill,Black); Bar(GetX,GetY,GetX-8,GetY+8); MoveTo(GetX-8,GetY); Delete (Buf,'Length (buf) , 1) ; end; end;
until ch=Chr(13); Val(buf,numb,code); GetReal:=numb; end; var
grDriver:integer; { драйвер }
grMode:integer; { графический режим }
grPath:string; { место расположения драйвера }
ErrCode:integer; { результат инициализации граф. режима }
n: real; { дробное число }
begin
grDriver := VGA; { режим VGA} grMode:=VGAHi; { разрешение 64 0x480} grPath:='e:\tp\bgi'; { драйвер, файл EGAVGA.BGI, находится
в каталоге e:\tp\bgi }
InitGraph(grDriver, grMode,grPath); ErrCode := GraphResult; if ErrCode <> grOk then begin
writeln('Ошибка инициализации графического режима.'); writeln('Для завершения работы программы нажмите
<Enter>'); readln; Halt(l)i end;
outtext('Введите целое число -> '); n:=GetReal; readln; CloseGraph; end.

Создает на диске А: файл

{ Создает на диске А: файл и записывает в него
5 целых чисел, введенных пользователем } var
f: text; { текстовый файл } n: integer; { число } i: integer; { счетчик чисел } begin
writeln('Создание файла'); writeln('Введите пять целых чисел.1);
writeln('После ввода каждого числа нажимайте <Enter>'); Assign(f,'а:\numbers.txt');
Rewrite(f); { открыть в режиме перезаписи } for i:=l to 5 do begin
write('->'); readln(n); writeln(f,n); end;
close(f); { закрыть файл } writeln('Введенные числа записаны в файл ',
'а:\numbers.txt'); readln; end.

пять введенных пользователем целых чисел

Дописывает в файл a:\numbers.txt
пять введенных пользователем целых чисел }
f: text; { текстовый файл }
n: integer; { число }
i: integer; { счетчик чисел }
begin
writeln('Добавление в файл a:\numbers.txt'); writeln('Введите пять целых чисел.');
writeln('После ввода каждого числа нажимайте <Enter>'); Assign(f,'а:\numbers.txt');
Append(f); { открыть файл в режиме добавления } for i:=l to 5 do begin
write('->');
readln(n);
writeln(f,n); end; Close(f); { закрыть файл }
writeln('Введенные числа добавлены в файл ',
'а:\numbers.txt'); readln;
end.

Выводит на экран содержимое файла

{ Выводит на экран содержимое файла а:\numbers.txt } var
f: text; { текстовый файл } n: integer; { число } begin
writeln('Содержимое файла a:\nunibers.txt1);
writeln ('-----------------------------') ;
Assign(f,'a:\numbers.txt'); Reset(f); { открыть файл для чтения } While not EOF(f) do { пока не достигнут конец файла } begin
readln(f,n); { прочитать число из файла } writeln(n); { вывести прочитанное число на экран } end;
Close(f); writeln ('-readln;
закрыть файл
end.

Вычисляет среднее арифметическое чисел, находящихся

( Вычисляет среднее арифметическое чисел, находящихся в файле a:\numbers.txt }
var
f: text; { текстовый файл } n: integer; { число, прочитанное из файла } kol: integer; { кол-во прочитанных чисел } sum: integer; { сумма прочитанных чисел ) sa: real; { среднее арифметическое }
begin
writeln('Вычисление среднего арифметического чисел, writeln('находящихся в файле a:\numbers.txt'); writeln('Чтение из файла. Подождите.'); sum:=0; kol:-0;
Assign(f,'a:\numbers.txt'); Reset (f); { открыть файл для чтения } While not EOF(f) do { пока не достигнут конец begin
readln(f,n); { прочитать число из файла }
sum:=sum+n;
kol:=kol+l; end;
Close(f); { закрыть файл } sa:=sum/kol;
writeln('Прочитано чисел: ',kol); writeln('Сумма чисел: ',sum) ; writeln('Среднее арифметическое: ',sa:9:2); readln;
end.

Выводит на экран содержимое файла,

{ Выводит на экран содержимое файла, имя которого
указано пользователем } uses Crt;
f: text; { текстовый файл }
fname: string[80]; ( имя файла }
st: string; { строка, прочитанная из файла }
'nst: integer; { кол-во выведенных на экран строк
key: char; { клавиша, нажатая пользователем }
begin
ClrScr; { очистить экран } writeln('Просмотр текстового файла');
writeln('Введите полное имя файла и нажмите <Enter>'); write('-> '); readln(fname); Assign(f,fname);
Reset(f); { открыть файл для чтения } ClrScr; nst:=0;
While not EOF(f) do { пока не достигнут конец файла } begin
readln(f,st); ( прочитать число из файла } writeln(st); • nst:=nst+l;
if nst = 23 then { выведены очередные 23 строки } begin
writeln;
write('Для продолжения вывода ',
'нажмите любую клавишу...'); key:=Readkey;
GotoXY(l,WhereY); { курсор в начало текущей строки } DelLine; { удалить сообщение
"Для продолжения ..."} nst:=0; end; end;
Close(f); { закрыть файл } writeln;
write('Для завершения просмотра нажмите любую ',
'клавишу...'); key:=Readkey;end.

и номер телефона. Если файла

{ Дописывает в файл а:\phone.txt фамилию, имя и номер телефона. Если файла на диске нет, то создает его. } label
bye; var
f: text; { текстовый файл } fam: string[15]; { фамилия } name: string[15]; { имя } tel: string[9]; { номер телефона } begin
writeln('Добавление в телефонный справочник');
Assign(f,'a:\phone.txt'))
{$1-}
Append(f); { сначала откроем в режиме добавления }
if IOResult <> 0 then
{ вероятно файла phone.txt нет на диске А:}
{ создадим его }
begin
Rewrite(f); { открыть в режиме перезаписи } if IOResult О 0 then begin
writeln('Ошибка обращения к диску А:'); goto bye; end; end;
{ получим данные от пользователя } write('Фамилия ->') ; readln(fam); write('Имя ->'); readln(name); write('Телефон ->') ; readln(tel); { и запишем их в файл } writeln(f,fam); writeln(f,name); writeln(f,tel); close(f); writeln('Информация добавлена.': writeln('Для завершения работы ',
'нажмите <Enter>.'); readln; end.

txt на диске А: нет

{ Поиск в телефонном справочнике }
label bye;
var
f: text; { текстовый файл } obr: string[15]; { фамилия для поиска }
n: integer; { кол-во записей, удовлетворяющих запросу }
fam: string[15]; { фамилия } name: string[15]; { имя } tel: string[9]; { номер телефона } begin
writeln('Поиск в телефонном .справочнике'); Assign(f,'a:\phone.txt');
reset (f); ( откроем файл для чтения } if IOResult О 0 then
{ вероятно файла phone. txt на диске А: нет } begin
writeln('Файл a:\phone.txt не доступен'); goto bye; end;
repeat
write('Фамилия ->') ; readln(obr);
if Length(obr) <> 0 then { пользователь ввел строку } begin
reset(f); { просматриваем файл от начала } n:=0;
while not EOF(f) do { просматриваем весь файл } begin
{ читаем из файла } readln(f,fam);
readln(f,name) ; readln(f,tel);
if fam = obr then { найдена нужная фамилия } begin
writeln(fam,' ',name, ' ',tel); n:=n+l; end; end; if n = 0 then writeln('Сведений о ' ,
obr,' нет.'); end;
until Length(obr) = 0; bye:
writeln('Для завершения работы нажмите <Enter>.'); readln; end.

имя файла из командной строки

{ Универсальная программа тестирования } uses Crt;
label
bye;
fname: string[40]; { имя файла теста } f: text; ( файл теста }
VsegoVopr: integer; { количество вопросов теста } PravOtv: integer; { количество правильных ответов }
{ для текущего вопроса }
nOtv: integer; { количество альтернативных ответов }
prav: integer; { номер правильного ответа)
Otv: integer; { номер ответа, выбранного пользователем }
st: string; { строка, читаемая из файла теста } р: integer; { процент правильных ответов }
1: integer; { счетчик циклов } in
if ParamCount = 0 then begin
writeln('He задан файл вопросов теста!'); ' writeln('Командная строка: test ИмяФайлаТеста');
goto bye; end;
fname:=ParamStr(1) ; { имя файла из командной строки } Assign(f,fname);
{$1-} { это директива компилятору, а не коментарий! } Reset (f); { открыть файл для чтения )
if IOResult <> 0 then begin
writeln('Не найден файл теста ', fname); goto bye; end;
writeln('Сейчас Вам будет предложен тест.'); writeln('К каждому вопросу дается несколько вариантов ', 'ответа.'); "
writeln('Вы должны ввести номер правильного ответа',
'и нажать клавишу <Enter>'); writeln;
writeln('Удачи! Для начала тестирования нажмите <Enter>'); TextBackGround(Blue); ClrScr; VsegoVopr:=0; Prav:=0;
while not EOF(f) do begin
(ClrScr;}
VsegoVopr:=VsegoVopr+l;
readln(f,st); { читаем из файла вопрос } TextColor(White);
writeln(st); { выводим вопрос на экран } readln(f,nOtv,Prav); { читаем кол-во альтернативных
ответов и номер правильного ответа } TextColor(LightGray);
for i:=l to nOtv do ( читаем и выводим альтернативные ответы }
begin
readln(f,st); writeln(i,'. ',st); end;
writeln;
write('Ваш выбор ->'); readln(Otv);
if Otv = Prav then PravOtv:=PravOtv+l; writeln; end;
{ обработка результата тестирования } { вычислим процент правильных ответов } p:=Round((PravOtv/VsegoVopr)*100); write('Ваша оценка '); case p of
100:writeln('ОТЛИЧНО!'); 80..99:writeln('ХОРОШО.'); 60..79:writeln('УДОВЛЕТВОРИТЕЛЬНО.); else writeln('ПЛОХО!'); end; bye:
write('Для завершения работы программы нажмите <Enter>'); readln; end.

Выводит таблицу пересчета из дюймов

Выводит таблицу пересчета из дюймов в миллиметры на экран, принтер или в файл
f:text; { файл вывода } fname:string; { имя файла вывода } dest:integer; { 1 - на экран, 2 - на принтер, 3 - в файл }
d: real; { величина в дюймах }
m: real; { величина в миллиметрах}
begin
writeln('*** Таблица пересчета из дюймов ', 'в миллиметры ***');
teln('Результат выводить:'); writeln('l - на экран;'); writeln('2 - на принтер;1); writeln('3 - в файл.');
' writeln('Введите число от 1 до 3 и нажмите <Enter> '); write('Ваш выбор -> '); readln(dest); case dest of
1: fname:=''; {на экран } 2: begin { на принтер } fname:='prn';
write('Включите принтер и нажмите <Enter>'); readln; end; 3: begin { в файл }
write('Задайте имя файла для вывода -> '); readln(fname); end; end;
assign(f,fname); . rewrite(f);
writeln(f,' ------------------') ;
writeln(f,' Дюймы Миллиметры');
writeln(f,' -------------------') ;
d:=0.5;
while d < 10 do begin
m:=25.4*d; { 1 дюйм - 25,4 мм } writeln(f,d:6:l,m:10:1); d:=d+0.5; end;
writeln(f,' -------------------');
close(f); if dest = 3
then writeln('Таблица записана в файл ',fname);
writeln('Для завершения работы программы',
1 нажмите <Enter>'); readln;
end.

Введите число, факториал которого надо

{ Рекурсивная функция "Факториал" } function factorial(k:integer):integer; begin
if к = 1
then factorial:=1
else factorials k*factorial (k-1) ; end;
var
n: integer; { число, факториал которого надо вычислить}
f: integer; ( факториал числа п } begin
writeln('Вычисление факториала.');
writeln(' Введите число, факториал которого надо ', 'вычислить');
write ('->');
readln(n);
f:=factorial(n);
writeln('Факториал числа ',n,' равен ',f);
readln; end.

Используя механизм рекурсии, вычисляет сопротивление

{ Выводит на экран узор } Uses Graph,Crt;
{ Рисует элемент узора } procedure Elem(x,у,r,p: integer);
{ x,y,г - координаты и радиус центра основного
элемента узора р - порядок узора } begin
if p>=0 then begin
Circle(х,у,г); Delay(lOO);
Elem(x+r,y,Round(r/2),p-l) ; Elem(x,y-r,Round(r/2),p-l); Elem(x-r,y,Round(r/2),p-l);
m(x,y+r,Round(r/2) end;
end;
grDriver:integer; { драйвер }
grMode:integer; { графический режим }
grPath:string; { путь к файлу драйвера )
ErrCode:integer; ( код ошибки графического режима }
begin
grDriver:=VGA; grMode:=VGAHi; grPath:='e:\tp\bgi'; InitGraph (grDriver,grMode,grPath); ErrCode:=GraphResult; if ErrCode <> grOK then begin
writeln ('Ошибка инициализации графического режима.1)
writeln ('Для завершения работы нажмите <Enter>');
readln;
Halt (1); end;
{ основная программа }
Elem(320,240,60,3); { рисуем узор 3-го порядка }
OutText('Для завершения работы программы ',
'нажмите <Enter>');
readln; end.
Используя механизм рекурсии, вычисляет сопротивление n-звенной электрической цепи }
rl,r2,r3: real; { величины сопротивлений,
из которых состоит цепь }
n: integer; { количество звеньев (порядок) цепи } re: real; { сопротивление цепи )
{ величина сопротивления цепи n-го порядка } function Cep(n: integer): real; begin
if n=l
then Cep:=Rl+R2+R3 else begin
rc:=Cep(n-1); Cep:=R2*rc/(R2+rc); end; end;
{ основная процедура } begin
writeln('Вычисление сопротивления электрической цепи.
writeln('Введите величины сопротивлений (Ом):');
write('rl ->');
readln(rl);
write Cr2 ->') ;
readln(r2);
write('r3 ->');
readln(r3);
write('Порядок цепи ->');
readln(n);
writelnf'Сопротивление цепи:',Сер(n):6:2,' Ом'); { величины соротивлений передаются
в процедуру Сер через глобальные
переменные rl, r2 и гЗ } readln; end.

Вычерчивает схему сложной электрической цепи.

( Вычерчивает схему сложной электрической цепи. }
{ При вычерчивании схемы цепи используется рекурсия.}
Uses Graph;
const
{ шаг сетки }
dx=7;
dy=7;
river:integer; grMode:integer; grPath:string; ErrCode:integer; x,y: integer;
k: integer;
порядок цепи }
{ выводит схему цепи k-ro порядка } Procedure Cep(k: integer; x,y: integer); begin
SetColor(Green);
Line (x, y, x+2*dx, y) ;
Rectangle (x+2*dx,y-dy,x+6*dx,y+dy);
Line(x+6*dx,y,x+8*dx,y);
OuttextXY(x+3*dx,y-3*dy,'Rl');
SetColor(Yellow);
Line(x+8*dx,y,x+8*dx,y+2*dy);
Rectangle(x+7*dx,y+2*dy,x+9*dx,y+6*dy);
Line(x+8*dx,y+6*dy,x+8*dx", y+8*dy) ;
OuttextXY(x+10Mx,y+2*dy, 'R2') ;
SetColor(LightGray) ;
Line(x,y+8*dy,x+2*dx,y+8*dy);
Rectangle(x+2*dx,y+7*dy,x+6*dx, y+9*dy) ;
Line(x+6*dx,y+8*dy,x+8*dx, y+8*dy); 1 OuttextXY(x+3*dx,y+5*dy,'R3');
if k>l then Cep(k-l,x+8*dx,y);
end;
begin
grDriver:=VGA; grMode:=VGAHi; grPath:='e:\tp\bgi'; InitGraph (grDriver,grMode,grPath); ErrCode:=GraphResult; if ErrCode <> grOK then begin
writeln ('Ошибка инициализации графического режима.1);
writeln ('Для завершения работы нажмите <Enter>');
readln; Halt (I
end;
OutTextXY(10,10,'Введите порядок цепи и нажмите <Enter>'); readln(k); сер (k, 10,50) ; readln; CloseGraph; end.

Заменяет стандартную процедуру для вычерчивания

{ Демонстрация понятия "рекурсия". Программа строит кривую Гильберта. }
uses Graph, Crt;
u: integer; { Длина штриха кривой Гильберта }
( Заменяет стандартную процедуру для вычерчивания по точкам горизонтальных и вертикальных линий. }
procedure LineTo(x2,y2: integer); const
DT = 3; ( задержка между выводом точек линии ) var
xl,yl: integer;
х,у : integer; dx: integer; dy: integer;
color: integer; a,b: real; n: integer; i: integer; begin
xlt-GetX; yl:=GetY;
{ координаты начала прямой, x2,y2 - координаты конца }
( координаты текущей точки }
{ приращение аргумента }
{ приращение у при рисовании вертикальной линии }
{ цвет линии}
( коэф-ты уравнения прямой }
( кол-во точек }
xl <> х2 then begin
( не вертикальная линия } a:=(y2-yl)/(x2-xl); ' b:=yl-a*xl;
n:=abs(x2-xl)+l; if х2 > xl then dx:=l else dx:=-l; x:=xl;
color:=GetColor; for i: =1 to n do begin
y:=Round(a*x+b); PutPixel(x,y,color); delay(DT); x:=x+dx; end; end
else begin { вертикальная л^ния } n:=abs(y2-yl); if y2 > yl then dy:=l else dy:=-l; x:=xl; y:=yl;
color:=GetColor; for i:=l to n do begin
PutPixel (x, y, color) ; delay(DT); y:=y+dy; end; end;
PutPixel(x2,y2,color); MoveTo(x2,y2); end;
{ Кривая состоит из четырех элементов: a,b,c и d.
Каждый элемент строит соответствующая процедура. } procedure a(i:integer); external;
procedure b(i:integer); external; procedure с(i:integer); external; procedure d(i:integer); external;
{ Элементы кривой. } procedure a(i: integer); begin
if i > 0 then begin
d(i-l); LineTo(GetX-u,GetY); a(i-l); LineTo(GetX,GetY+u);
a(i-l) ; LineTo(GetX+u, GetY) ;
b(i-l) ;
end;
end;
procedure b(i: integer);
begin
if i > 0 then
begin
c(i-l) ; LineTo(GetX,GetY-u) ;
b(i-l) ; LineTo(GetX+u,GetY);
b(i-l) ; LineTo(GetX,GetY+u);
a(i-l) ;
end;
end;
procedure c(i: integer);
begin
if i > 0 then
begin
b(i-l) ; LineTo(GetX+u,GetY);
c(i-l) ; LineTo(GetX,GetY-u);
c(i-l) ; LineTo(GetX-u,GetY);
d(i-l) ;
end;
end;
procedure d(i: integer); begin if i > 0 then in
a(i-l); LineTo(GetX,GetY+u); d(i-l); LineTo(GetX-u,GetY); d(i-l); LineTo(GetX,GetY-u); •c(i-l); end; end;
{ главная процедура ) var
grDriver: Integer;
grMode: Integer;
ErrCode: Integer;
res: integer;
p : integer; ( Порядок кривой Гильберта } st: string; begin
grDriver := detect;
InitGraph(grDriver, grMode,'e:\tp\bgi'); ErrCode := GraphResult; if ErrCode = grOk then begin p:=5;
Str(p:2,st);
OuttextXY(0,0,'Кривая Гильберта'+st+'-го порядка.'); MoveTo(450,50) ; u:=10; a (p) ; OuttextXY(0,16,'Для завершения работы программы ',
'нажмите <Enter>.'); readln; end;
CloseGraph; end.

вычерчивает по точкам линию из

{ Программа строит кривую Серпинского.}
uses Graph, Crt;
var
u: integer;
Длина штриха }
{ LineTo - вычерчивает по точкам линию из те* точки в заданную. Заменяет стандартную процедуру LineTo для того, чтобы можно было видеть процесс вычерчивания. Возможно надо увеличить величину задержки между выводом точек. } procedure LineTo(x2,y2: integer);
{ х2,у2 - координаты конца линии} const
DT = 3; { задержка между выводом точек линии } var
xl,yl: integer; { координаты начала прямой } { координаты текущей точки } { приращение аргумента } { приращение у при рисовании
вертикальной линии } { цвет линии}
{ коэф-ты уравнения прямой } { кол-во точек }
х,у : integer; dx: integer; dy: integer;
color: integer; a,b: real; n: integer; i: integer; begin
xl:=GetX; yl:=GetY; if xl <> x2 then begin
{ не вертикальная линия }
a:=(y2-yl)/(x2-xl);
b:=yl-a*xl;
n:=abs(x2-xl)+l;
if x2 > xl then dx:=l else dx:=-l;
x:-xl;
color:=GetColor;
for i:=l to n do
in
y:=Round(a*x+b); PutPixel(x,y,color); delay(DT); x:=x+dx; end; end
else begin { вертикальная линия } n:=abs(y2-yl); if y2 > yl then dy:=l else dy:=-l; x:=xl; y:=yl;
color:=GetColor ; for i:=l to n do begin
PutPixel(x, y, color); delay(DT);
y:=y+dy;
end; end;
PutPixel(x2,y2,color); MoveTo(x2,y2); end;
procedure Vector(a: integer; { a - угол между вектором
и осью ОХ }
1: integer); ( длина вектора } { Угол задается целым числом от 0 до 7.
О соответствует нулю градусов, 1-45, 2 - 90 и т. д. var
x0,y0: integer; ( координаты начала вектора }
xl,yl: integer; { координаты конца вектора } begin
xO:=GetX;
yO:=GetY;
xl:=Round(xO+l*cos(a*Pi/4) ) ;
yl:=Round(yO-l*sin(a*Pi/4) ) ;
LineTo(xl,yl); end;
{ Кривая состоит из четырех элементов: а,Ь,с и d.
Каждый элемент строит соответствующая процедура. procedure a (i:integer); external; procedure b(i:integer); external; procedure с(i:integer); external; procedure d(i:integer); external;
( Элементы кривой. } procedure a(i: integer); begin
if i > 0 then begin
a(i-l);Vector(7,u); b(i-l);Vector(0,2*u); d(i-l);Vector(l,u); a(i-l); end; end;
procedure b(i: integer); begin
if i > 0 then
begin
b(i-l);Vector(5,u) ; c(i-l);Vector(6,2*u) ; a(i-l);Vector(7,u);
b(i-l) end; end;
procedure c(i: integer); begin
if i > 0 then
begin
c(i-l);Vector(3,u); d(i-l);Vector(4,2*u); b(i-l);Vector(5,u); c(i-l); end; end;
cedure d(i: integer); begin
if i > 0 then
begin
d(i-l)/Vector(l,u); a(i-l);Vector(2,2*u); c(i-l);Vector(3,u); d(i-l); end; end;
( главная процедура } var
grDriver: Integer;
grMode: Integer;
ErrCode: Integer;
res: integer;
p : integer; { Порядок кривой Гильберта } st: string;
.
i: integer; begin
writeln('Демонстрация понятия "рекурсия".'); writeln('Программа строит кривую Серпинского.'); writeln('Введите порядок кривой (1-4) ',
'и нажмите <Enter>!); write('->'); readln(p); grDriver := detect;
InitGraph(grDriver, grMode,'e:\tp\bgi'); ErrCode := GraphResult; if ErrCode = grOk then begin
Str(p:2,st);
OuttextXY(0,0,'Кривая Серпинского'+st+'-го порядка.');
MoveTodO, 30) ;
u:=5;
a(p) ; Vector (7, u) ;
b(p) ; Vector (5, u) ;
с(р); Vector(3,и); d(p); Vector (1, и) ; OuttextXY(0,16,
'Для завершения работы программы нажмите <Enter>.') readln; end;
CloseGraph; end.