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




Задача 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.









Начало    Назад