Turbo Pascal для начинающих

Смотрим тут: https://novostif.ru/


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

Задача 165

{ Бинарный поиск в упорядоченном массиве }
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.

Задача 167

{ Вычисление суммы элементов массива (по столбцам) 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.

Задача 170

{ вычисление определителя матрицы второго порядка } 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.

Задача 171

{ Проверяет, является ли матрица магическим квадратом } 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.

Задача 173

{ Подводит итоги Олимпийских игр } 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.

Задача 173

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.

Задача 174

( Игра "Угадай число" }
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.

Задача 175

{ Телеграф - передача сообщений при помощи азбуки Морзе. { Замечание: возможно надо увеличить величины задержек. } 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.

Задача 177

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

Задача 178

{ Возвращает результат сравнения чисел
в виде символа отношения } 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.

Задача 179

{ Вычисляет сопротивление электрической цепи } 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;

Задача 180

{ Вычисление степени числа с использованием свойств логарифмов }
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;

Задача 183

{ Проверяет, является ли символ гласной буквой } 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;

Задача 184

{ Удаляет из строки начальные пробелы } 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.

Задача 186

{ Преобразование строчных букв в прописные } ( Замещает стандартную процедуру 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.

Задача 188

{ Решение квадратного уравнения }
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.

Задача 198

{ Рисует кораблик с использованием метода базовой точки }
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.

Задача 199

{ Выводит узор из 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.

 

Задача 201

{ Рисует контур пятиконечной звезды } 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.

Задача 202

( Рисует пятиконечную звезду }
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.

Задача 205

( Рисует веселую рожицу желтого цвета }
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.

Задача 208

{ Выводит узор из концентрических окружностей разного цвета
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.

Задача 210

{ Вычерчивает узор из квадратов
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.

Задача 211

{ рисует на экране шахматную доску } 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.

Задача 213

{ Выводит на экран паровоз } 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.

Задача 215

{ Координатные оси и оцифрованная сетка } 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.

Задача 216

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.

Задача 217

{ Движущееся сложное изображение }
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.
нарисовать корабль }

Задача 219

{ Обрабатывает результаты контрольной работы
и отражает их в виде диаграммы } 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.

Задача 221

{ Светофор } 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.

Задача 224

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.

Задача 225

{ Создает на диске А: файл и записывает в него
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.

Задача 226

Дописывает в файл 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.

Задача 227

{ Выводит на экран содержимое файла а:\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.

Задача 228

( Вычисляет среднее арифметическое чисел, находящихся в файле 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.

Задача 229

{ Выводит на экран содержимое файла, имя которого
указано пользователем } 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.

Задача 230

{ Дописывает в файл а:\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.

Задача 232

{ Поиск в телефонном справочнике }
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.

Задача 234

{ Универсальная программа тестирования } 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.

Задача 235

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

Задача 236

{ Рекурсивная функция "Факториал" } 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.

Задача 237

{ Выводит на экран узор } 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.

Задача 239

( Вычерчивает схему сложной электрической цепи. }
{ При вычерчивании схемы цепи используется рекурсия.}
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.

Задача 240

{ Демонстрация понятия "рекурсия". Программа строит кривую Гильберта. }
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.

Задача 241.

{ Программа строит кривую Серпинского.}
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.

Назад Начало