Решения (задачи 224-241)
Задача 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: = -1;
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.