Помощь - Поиск - Пользователи - Календарь
Полная версия: Занимательная графика
Форум «Всё о Паскале» > Pascal, Object Pascal > Задачи > FAQ
BlackShadow
В этой теме приведены исходники, отрисовывающие следующие фигуры:
  1. "Архимедова спираль" (ниже в этом же сообщении)

  2. Нажмите для просмотра прикрепленного файла
    Исходник для Турбо Паскаля (процедуры)
    Исходник для Турбо Паскаля (ООП)
    Отрисовка только прямыми линиями

  3. Нажмите для просмотра прикрепленного файла
    Исходник для FPC

  4. Нажмите для просмотра прикрепленного файла

  5. Нажмите для просмотра прикрепленного файла

  6. Нажмите для просмотра прикрепленного файла

  7. Нажмите для просмотра прикрепленного файла
    Фрактальные деревья

  8. "Фигуры Лиссажу"
  9. Пример RGB графики в режиме 13h
Архимедова спираль

Цитата
Параметрическое представление спирали: x = r cos t , y = r sin t, r = t/2

Если количество витков = n, то T пробегает от 0 до n*2*pi. r растёт от 0 до R_max (данный внешний радиус), и пропорционален T. Тогда r = T/(n*2*pi)*R_max.

Uses Graph, Crt;

Const
r_max = 200;
n = 7;
Var
gr, gm: Integer;
i, k: Integer;
ZeroX, ZeroY: Integer;
x, y, r, t: Double;

begin
gr := Detect;

InitGraph(gr, gm, '');
k := n * 140;

ZeroX := Round(GetMaxX/2);
ZeroY := Round(GetMaxY/2);
{MoveTo(ZeroX, ZeroY);}
For i := 1 To k Do
Begin
T := (n * 2 * Pi) * i / k;
r := T / (n * 2 * Pi) * r_max;
x := r * Cos(T);
y := r * Sin(T);
PutPixel(ZeroX + Round(x), ZeroY - Round(y), White)
End;
ReadKey;
CloseGraph;
end.
Romtek
program Uzor;
Uses Graph, CRT;

Const
m = 0.1;
Max = 20;

type
TPoint = record
x,y: integer;
end;

TPolygon = Array [0..10] of TPoint;
Var
Length,
x0,y0 : word; { центр экрана, точка отсчёта }

procedure InitGr;
var gd,gm: integer;
begin
gd := Detect;
InitGraph (gd, gm, '..\bgi');
if Graphresult <> 0 then
Halt;
end;

{ Вращение объекта вокруг своей оси на Angle радиан}
procedure Rotate2D( var P: TPolygon; Angle: single);
var
_cos,_sin: single;
k: word;
xx,yy: integer;
begin
_cos := cos (Angle);
_sin := sin (Angle);
for k := 1 to P[0].x do
with P[k] do
begin
xx := round (x * _cos + y * _sin);
yy := round (y * _cos - x * _sin);
{ перевод в экранные координаты }
x := x0 + xx;
y := y0 - yy;
end;
end;

{ построение фигуры }
procedure PlotFigure (P: TPolygon);
var
k: word;
begin
{ установка позиции граф. курсора на 1-ю точку }
MoveTo (P[1].X, P[1].Y);

for k := 2 to P[0].X do
{ отрисовка линий от граф. курсора до точки }
LineTo (P[k].X, P[k].Y);

{ отрисовка замыкающей линии }
LineTo (P[1].X, P[1].Y);
end;

procedure PlotSquare (Length: word; phi: single);
var
Polygon : TPolygon;

begin
{ так зададим кол-во сторон полигона }
Polygon[0].X := 4;

{ инициализация координат, относительно x0 и y0 }
Polygon[1].X := -Length div 2;
Polygon[1].Y := -Polygon[1].X;

Polygon[2].X := Polygon[1].X + length;
Polygon[2].Y := Polygon[1].Y;

Polygon[3].X := Polygon[2].X;
Polygon[3].Y := Polygon[1].Y - length;

Polygon[4].X := Polygon[1].X;
Polygon[4].Y := Polygon[3].Y;

Rotate2D (Polygon, phi);
PlotFigure (Polygon);
end;

var
i: word;
Coeff : single;
Alpha,
Beta : single;

begin
Alpha := Arctan (m / (1.0 - m));
Beta := 0.0;

InitGr;

x0 := GetMaxX div 2;
y0 := GetMaxY div 2;

{ Длина стороны квадрата размером в полэкрана }
Length := y0;

{ коэффициент уменьшения стороны квадрата }
Coeff := M / sin (Alpha);

for i := 1 to Max do
begin
{ построить квадрат со стороной Length и поворотом Beta }
PlotSquare (Length, Beta);

{ увеличить величину поворота на угол Alpha }
Beta := Beta + Alpha;
Length := round (Length * Coeff);
end;

repeat until keypressed;
CloseGraph;
end.


Скачать исходник: Нажмите для просмотра прикрепленного файла
Romtek
Это код для FPC:
program Uzor;
Uses Windows, WinCRT,
Graph;

Const
m = 0.1;
Max = 20;

type
TPolygon = record
Pol: Array [0..10] of PointType;
Size: word;
end;

Var
Length,
Color,
x0,y0 : word;

procedure InitGr;
var gd,gm: smallint;
begin
gd := Detect;
InitGraph (gd, gm, '..\bgi');
if Graphresult <> 0 then
Halt;
end;

procedure Rotate2D( var P: TPolygon; Angle: single);
var
_cos,_sin: single;
k: word;
xx,yy: integer;
begin
_cos := cos (Angle);
_sin := sin (Angle);
for k := 0 to P.Size - 1 do
with P.Pol[k] do
begin
xx := round (x * _cos + y * _sin);
yy := round (y * _cos - x * _sin);
x := x0 + xx;
y := y0 - yy;
end;
end;

procedure PlotFigure (P: TPolygon);
var
k: word;
begin
inc (Color);
SetColor (Color);

with P.Pol[0] do MoveTo (X, Y);

for k := 1 to P.Size - 1 do
with P.Pol[k] do LineTo (X, Y);

with P.Pol[0] do LineTo (X, Y);

FillPoly (P.Size, P.Pol);
end;

procedure PlotSquare (Length: word; phi: single);
var
Polygon : TPolygon;

begin
with Polygon do
begin
Size := 4;

Pol[0].X := -Length div 2;
Pol[0].Y := -Pol[0].X;

Pol[1].X := Pol[0].X + length;
Pol[1].Y := Pol[0].Y;

Pol[2].X := Pol[1].X;
Pol[2].Y := Pol[0].Y - length;

Pol[3].X := Pol[0].X;
Pol[3].Y := Pol[2].Y;
end;

Rotate2D (Polygon, phi);
PlotFigure (Polygon);
end;

var
i: word;
Coeff : single;
Alpha,
Beta : single;

begin
Alpha := Arctan (m / (1.0 - m));
Beta := 0.0;

ShowWindow (GetActiveWindow, 0);
InitGr;

Color := GetMaxColor div 4;

x0 := GetMaxX div 2;
y0 := GetMaxY div 2;

Length := y0;
Coeff := M / sin (Alpha);

for i := 1 to Max do
begin
PlotSquare (Length, Beta);
Beta += Alpha;
Length := round (Length * Coeff);
end;

repeat until keypressed;
CloseGraph;
end.


Скачать исходник: Нажмите для просмотра прикрепленного файла
volvo
Можно задавать разное количество вершин и коэффициент...
{$N+}

Uses Graph;

Type
TPoint =
Record
X, Y: Integer;
End;

PArrPoint = ^arrPoint;
arrPoint =
Array[1 .. maxInt Div SizeOf(TPoint)] Of TPoint;

TFigure =
Object
nPoints: Byte;
arr: PArrPoint;

p: Integer;
a: Double;

Constructor Init(np: Integer;
pVal: Integer; aVal: Double);
Destructor Done;
Procedure Run;

Private
Procedure InitPoints;

Function Recalc: Boolean;
Procedure Draw;
End;

Constructor TFigure.Init(np: Integer;
pVal: Integer; aVal: Double);
Begin
nPoints := np;
a := aVal; p := pVal;
GetMem(arr, nPoints * SizeOf(TPoint));

InitPoints
End;

Destructor TFigure.Done;
Begin
FreeMem(arr, nPoints * SizeOf(TPoint));
End;

Procedure TFigure.InitPoints;

Const
RadToGrad = (180 / Pi);

Procedure GetPoint(Var P: TPoint;
Len: Integer; phi: Integer);
Var fPhi: Double;
Begin
fPhi := phi / RadToGrad;
P.X := (GetMaXX div 2) + Trunc(Len * Sin(fPhi));
P.Y := (GetMaxY div 2) - Trunc(Len * Cos(fPhi));
End;

Var
i, Len, phi: Integer;
x: Double;
Begin
phi := 360 div nPoints;
x := Cos(phi / RadToGrad);
Len := Trunc(p / Sqrt(2* (1 - x)));

For i := 1 To nPoints Do
GetPoint(arr^[i], Len, Pred(i) * phi);
End;

Function TFigure.Recalc: Boolean;
Var
T: PArrPoint;
i, next: Integer;
Begin
GetMem(T, nPoints * SizeOf(TPoint));
For i := 1 To nPoints Do
Begin
If i = nPoints Then next := 1 Else next := Succ(i);

T^[i].x := Trunc((arr^[i].x + a*arr^[next].x) / (1 + a));
T^[i].y := Trunc((arr^[i].y + a*arr^[next].y) / (1 + a));
End;
Recalc := (T^[1].x <> arr^[1].x);

Move(T^, arr^, nPoints * SizeOf(TPoint));
FreeMem(T, nPoints * SizeOf(TPoint))
End;

Procedure TFigure.Draw;

Procedure DrawLine( p1, p2: TPoint );
Begin
Line( p1.X, p1.Y, p2.X, p2.Y )
End;

Var
i, next: Integer;
Begin
For i := 1 To nPoints Do
Begin
next := Succ(i);
If i = nPoints Then next := 1;
DrawLine( arr^[i], arr^[next] );
End;
End;


Procedure TFigure.Run;
Begin
Repeat
Draw
Until not ReCalc;
ReadLn
End;


Var
f: TFigure;

grDriver, grMode, ErrCode: Integer;
Begin
grDriver := Detect;
InitGraph(grDriver, grMode, '');
ErrCode := GraphResult;
If ErrCode <> grOk Then
Begin
WriteLn('Graphic Error: ', GraphErrorMsg(ErrCode));
Halt(100)
End;

{ 7 вершин, длина каждой стороны = 140, коэффициент = 0.05 }
f.Init( 7, 140, 0.05 );
f.Run;
f.Done;

CloseGraph;
End.


Скачать исходник: Нажмите для просмотра прикрепленного файла
Altair
Код
Uses crt,graph;
const
a=1.3; b=-1.3; c=-13; k1=2.1; k2=1;
x0=320; y0=240;
Var Gd,gm,sign:Integer;
x,y,old:real; i:longint;

begin
gd:=detect; initgraph(gd,gm,'');
x:=0; y:=0;
repeat
 PutPixel(Round(x0+k1*x),Round(y0+k2*y), (i mod 6)+9);
 if x<0 then sign:=-1 else sign:=1;
 old:=y;
 y:=a-x;
 x:=old-sign*sqrt(abs(b*x-c));
 inc(i);
until keypressed;
closegraph;
end.
Altair
Код
Uses crt, graph;
var
k:real;
gd,gm:Integer;
x,y,z:Longint;
Begin
gd:=detect; {gm:=VgaHi;} InitGraph(Gm,GD,'');
randomize;
k:=0.00000;
repeat
 for x:=1 to  getMaxX do
  for y:=1 to GetMaxY do
  begin
   If keypressed then halt;
   z:=sqr(x)+Sqr(y);{ 10+random(5);}
   If odd(trunc(z*k)) then putpixel(x,y,15) else  putpixel(x,y,7);
  end;
  k:=k+0.1;
until keypressed;
CloseGraph;
end.
SHnur
Програма, выводит на экран узор как в 1-ой программе выложенной здесь, но другим способом :

uses graph, crt;
var i , j , x :integer;
graphdriver , GraphMode :integer;
ch :boolean;
col1 , col2 : integer;
begin
GraphDriver := VGA;
GraphMode := VGAHI;
InitGraph(graphDriver,GraphMode,'e:\alexiv~1');
COL1 := black;
col2 := blue;

ch := true;
for j := 1 to 2 do begin
if j = 1 then x := 0
else x := 479;
for i := 0 to 639 do begin
line(319,239,i,x);
ch := not(ch);
case ch of
true : setcolor(col1);
false : setcolor(col2);
end;
end;
end;

for j := 1 to 2 do begin
if j = 1 then x := 0
else x := 639;
for i := 0 to 479 do begin
line(319,239,x,i);
ch := not(ch);
case ch of
true : setcolor(col1);
false : setcolor(col2);
end;
end;
end;

readkey;
closegraph;
end.


А самое интересное в нём - это то, если вы заметили, что он рисуется исключительно прямыми линиями.

Скачать исходник: Нажмите для просмотра прикрепленного файла
SHnur
Вот небольшой код, рисующий так называемые "фигуры Лиссажу".
Можно побаловаться с коэфицентами: a1, a2, b1, b2, c1, c2...

program parametr;
uses graph , crt;
const a1 = 200; b1 = 1; c1 = 50;
a2 = 200; b2 = 16; c2 = 50;
var graphdriver , GraphMode :integer;
i : integer;
t , x ,y , x1 ,y1 , step:real;
begin
GraphDriver := VGA;
GraphMode := VGAHI;
InitGraph(graphDriver,GraphMode,'x:\mypasc~1\IVSEM~1\');

setviewport(320,240,639,479,clipoff);
step := 0.0001;
t:= step;

moveto(round(a1 * sin((b1*t+c1))),round(a2 * cos((b2*t+c2))));
t := 0;
repeat
t := t + step;
x := a1 * sin((b1*t+c1));
y := a2 * cos((b2*t+c2));
delay(100);
lineto(round(x),round(y));
until (t >= 10) or keypressed;
readln;
closegraph;
end.
xds
program Circles;

uses
Crt, Graph;

const
grDriver: Integer = VGA;
grMode: Integer = VGAHI;

var
x, y, r: Integer;

begin
Randomize;
InitGraph(grDriver, grMode, '');
repeat
x := Random(640);
y := Random(480);
for r := 0 to 30 + Random(50) do
begin
SetColor(2);
Circle(x, y, r);
SetColor(0);
Circle(x + 1, y + 1, r);
end;
until KeyPressed;
ReadKey;
CloseGraph;
end.
Dark
Очень интересный и красивый пример RGB графики на Паскале в режиме 13h.

Uses Crt;

CONST VGA=$a000;

Var Pall,Pall2 : Array[0..255,1..3] of Byte;

{--------------------------------------------------------------------------}
Procedure SetMCGA; { This procedure gets you into 320x200x256 mode. }
BEGIN
asm
mov ax,0013h
int 10h
end;
END;


{--------------------------------------------------------------------------}
Procedure SetText; { This procedure returns you to text mode. }
BEGIN
asm
mov ax,0003h
int 10h
end;
END;


{--------------------------------------------------------------------------}
procedure WaitRetrace; assembler;

label
l1, l2;
asm
mov dx,3DAh
l1:
in al,dx
and al,08h
jnz l1
l2:
in al,dx
and al,08h
jz l2
end;


{--------------------------------------------------------------------------}
Procedure GetPal(ColorNo : Byte; Var R,G,B : Byte);
Begin
Port[$3c7] := ColorNo;
R := Port[$3c9];
G := Port[$3c9];
B := Port[$3c9];
End;


{--------------------------------------------------------------------------}
Procedure Pal(ColorNo : Byte; R,G,B : Byte);
Begin
Port[$3c8] := ColorNo;
Port[$3c9] := R;
Port[$3c9] := G;
Port[$3c9] := B;
End;


{--------------------------------------------------------------------------}
Procedure Putpixel (X,Y : Integer; Col : Byte);
BEGIN
Mem [VGA:X+(Y*320)]:=Col;
END;


{--------------------------------------------------------------------------}
Procedure line(a,b,c,d,col:integer);
Function sgn(a:real):integer;
BEGIN
if a>0 then sgn:=+1;
if a<0 then sgn:=-1;
if a=0 then sgn:=0;
END;
var u,s,v,d1x,d1y,d2x,d2y,m,n:real;
i:integer;
BEGIN
u:= c - a;
v:= d - b;
d1x:= SGN(u);
d1y:= SGN(v);
d2x:= SGN(u);
d2y:= 0;
m:= ABS(u);
n := ABS(v);
IF NOT (M>N) then
BEGIN
d2x := 0;
d2y := SGN(v);
m := ABS(v);
n := ABS(u);
END;
s := INT(m / 2);
FOR i := 0 TO round(m) DO
BEGIN
putpixel(a,b,col);
s := s + n;
IF not (s<m) THEN
BEGIN
s := s - m;
a:= a +round(d1x);
b := b + round(d1y);
END
ELSE
BEGIN
a := a + round(d2x);
b := b + round(d2y);
END;
END;
END;


{--------------------------------------------------------------------------}
Procedure PalPlay;
Var Tmp : Array[1..3] of Byte;
{ This is used as a "temporary color" in our pallette }
loop1 : Integer;
BEGIN
Move(Pall[200],Tmp,3);
{ This copies color 200 from our virtual pallette to the Tmp variable }
Move(Pall[0],Pall[1],200*3);
{ This moves the entire virtual pallette up one color }
Move(Tmp,Pall[0],3);
{ This copies the Tmp variable to the bottom of the virtual pallette }
WaitRetrace;
For loop1:=1 to 255 do
pal (loop1,pall[loop1,1],pall[loop1,2],pall[loop1,3]);
END;


{--------------------------------------------------------------------------}
Procedure SetUpScreen;
Var Loop : Integer;
BEGIN
FillChar(Pall,SizeOf(Pall),0);
{ Clear the entire PALL variable to zero. }
For Loop := 0 to 200 do BEGIN
Pall[Loop,1] := Loop mod 64;
END;
{ This sets colors 0 to 200 in the PALL variable to values between
0 to 63. the MOD function gives you the remainder of a division,
ie. 105 mod 10 = 5 }

For Loop := 1 to 320 do BEGIN
Line(319,199,320-Loop,0,(Loop Mod 199)+1);
Line(0,0,Loop,199,(Loop Mod 199)+1);
{ These two lines start drawing lines from the left and the right
hand sides of the screen, using colors 1 to 199. Look at these
two lines and understand them. }
PalPlay;
{ This calls the PalPlay procedure }
END;
END;


{--------------------------------------------------------------------------}
Procedure GrabPallette;
VAR loop1:integer;
BEGIN
For loop1:=0 to 255 do
Getpal (loop1,pall2[loop1,1],pall2[loop1,2],pall2[loop1,3]);
END;



{--------------------------------------------------------------------------}
Procedure Blackout;
{ This procedure blackens the screen by setting the pallette values of
all the colors to zero. }
VAR loop1:integer;
BEGIN
WaitRetrace;
For loop1:=0 to 255 do
Pal (loop1,0,0,0);
END;


{--------------------------------------------------------------------------}
Procedure HiddenScreenSetup;
VAR loop1,loop2:integer;
BEGIN
For loop1:=0 to 319 do
For loop2:=0 to 199 do
PutPixel (loop1,loop2,Random (256));
END;


{--------------------------------------------------------------------------}
Procedure Fadeup;
VAR loop1,loop2:integer;
Tmp : Array [1..3] of byte;
{ This is temporary storage for the values of a color }
BEGIN
For loop1:=1 to 64 do BEGIN
{ A color value for Red, green or blue is 0 to 63, so this loop only
need be executed a maximum of 64 times }
WaitRetrace;
For loop2:=0 to 255 do BEGIN
Getpal (loop2,Tmp[1],Tmp[2],Tmp[3]);
If Tmp[1]<Pall2[loop2,1] then inc (Tmp[1]);
If Tmp[2]<Pall2[loop2,2] then inc (Tmp[2]);
If Tmp[3]<Pall2[loop2,3] then inc (Tmp[3]);
{ If the Red, Green or Blue values of color loop2 are less then they
should be, increase them by one. }
Pal (loop2,Tmp[1],Tmp[2],Tmp[3]);
{ Set the new, altered pallette color. }
END;
END;
END;


{--------------------------------------------------------------------------}
Procedure FadeDown;
VAR loop1,loop2:integer;
Tmp : Array [1..3] of byte;
{ This is temporary storage for the values of a color }
BEGIN
For loop1:=1 to 64 do BEGIN
WaitRetrace;
For loop2:=0 to 255 do BEGIN
Getpal (loop2,Tmp[1],Tmp[2],Tmp[3]);
If Tmp[1]>0 then dec (Tmp[1]);
If Tmp[2]>0 then dec (Tmp[2]);
If Tmp[3]>0 then dec (Tmp[3]);
{ If the Red, Green or Blue values of color loop2 are not yet zero,
then, decrease them by one. }
Pal (loop2,Tmp[1],Tmp[2],Tmp[3]);
{ Set the new, altered pallette color. }
END;
END;
END;


{--------------------------------------------------------------------------}
Procedure RestorePallette;
VAR loop1:integer;
BEGIN
WaitRetrace;
For loop1:=0 to 255 do
pal (loop1,Pall2[loop1,1],Pall2[loop1,2],Pall2[loop1,3]);
END;


BEGIN
SetMCGA;
GrabPallette;
SetUpScreen;
repeat
PalPlay;
{ Call the PalPlay procedure repeatedly until a key is pressed. }
Until Keypressed;
RestorePallette;
SetText;
END.


Скачать исходник: Нажмите для просмотра прикрепленного файла
volvo
Фрактальные деревья

Uses Graph, CRT;
Procedure Tree(x, y: Integer; a: Real; l:integer);
Var
x1, y1: Integer;
p, s, i : Integer;
a1 : Real;
Begin

If l<8 Then exit;

x1 := Round(x + l*cos(a));
y1 := Round(y + l*sin(a));

If l > 100 Then p:=100 Else p:=l;
If p < 40 Then Begin
{ Генерировать листья }
If Random > 0.5 Then SetColor(10) Else SetColor(2); { или 4, 14 }
For i:=0 To 3 Do Line(x+i, y, x1, y1)
End
Else Begin
{ Генерировать ветки }
Setcolor(6);
For i:=0 To (p div 6) Do Line(x+i-(p div 12), y, x1, y1);
End;

{ Следующие ветки }
For i:=0 To 9-Random(9) Do Begin
s := Random(l-l div 6) + (l div 6);
a1:= a + 1.6*(0.5-Random); { Угол наклона веток }
x1:= Round(x + s*cos(a));
y1:= Round(y + s*sin(a));
Tree(x1, y1, a1, p-5-Random(30));
{ Чем меньше вычтем, тем пышнее будет дерево }
End;
End;

Var
gd, gm: Integer;
Begin
Randomize;
gd:=Detect;
InitGraph(gd, gm, '');
Tree(320, 480, 3*pi/2, 200);
ReadKey;
CloseGraph;
End.


Скачать исходник: Нажмите для просмотра прикрепленного файла
klem4
Еще немного рекурсии smile.gif Салфетка Серпинского:

uses crt, graph;

var
gd, gm: Integer;

procedure DrawTriangle(const bottomX, bottomY, size: Word);
var
height: Word;
begin
height := round(size * sqrt(3)) div 2;

SetColor(Random(150) + 1);

Line(bottomX, bottomY, bottomX - size div 2, bottomY - height);
Line(bottomX, bottomY, bottomX + size div 2, bottomY - height);
Line(bottomX - size div 2, bottomY - height, bottomX + size div 2, bottomY - height);

delay(30);

end;

procedure Serpinsky(bottomX, bottomY, size, deep: Word);
var
height: Word;
begin
if deep > 0 then begin
height := round(size * sqrt(3)) div 2;
DrawTriangle(bottomX, bottomY, size);
Serpinsky(bottomX - size div 2, bottomY, size div 2, deep - 1);
Serpinsky(bottomX + size div 2, bottomY, size div 2, deep - 1);
Serpinsky(bottomX, bottomY - height, size div 2, deep - 1);
end;
end;

begin
gd := Detect;
InitGraph(gd, gm, '');

Randomize;

Serpinsky(GetMaxX div 2, GetMaxY div 2 + 150, 200, 6);

readkey;
CloseGraph;
end.
Нажмите для просмотра прикрепленного файла
volvo
Его же (в смысле, Серпинского) Ковер:

Uses CRT, Graph;
Var
gd, gm: Integer;

procedure serp(x1, y1, x2, y2: real; n: integer);
var
x1n, y1n, x2n, y2n: real;
begin
if n > 0 then begin
x1n:= 2*x1/3+x2 / 3;
x2n:= x1/3+2*x2 / 3;
y1n:= 2*y1/3+y2 / 3;
y2n:= y1/3+2*y2 / 3;
rectangle(round(x1n),round(y1n),round(x2n),round(y2n));
serp(x1, y1, x1n, y1n, n-1);
serp(x1n, y1, x2n, y1n, n-1);
serp(x2n, y1, x2, y1n, n-1);
serp(x1, y1n, x1n, y2n, n-1);
serp(x2n, y1n, x2, y2n, n-1);
serp(x1, y2n, x1n, y2, n-1);
serp(x1n, y2n, x2n, y2, n-1);
serp(x2n, y2n, x2, y2, n-1);
end;
end;

Begin
gd := detect;
InitGraph(gd, gm, '');
rectangle(20, 20, 460, 460);
Serp(20, 20, 460, 460, 4);
ReadLn;
CloseGraph;
End.


Выглядит вот так:
TarasBer
Красивая анимация. Смысл прост: рисуется ломаная. Каждая вершина движется прямолинейно, отражаясь от стен. Ломаная всё время рисуется заново поверх старой.

Код

program Lines;

uses
  Graph, CRT;

const
  CountPoints = 30;
  CountColors = 5;
  Colors: array [0 .. CountColors - 1] of byte = (4, 2, 6, 14, 15);

var
  i: integer;

  GrDev, GrMode: integer;

  X, Y: array [0 .. CountPoints - 1] of integer;
  dx, dy: array [0 .. CountPoints - 1] of integer;
  Col: array [0 .. CountPoints - 1] of byte;
begin

  Randomize;

  GrDev := VGA;
  GrMode := VGAHi;
  InitGraph(GrDev, GrMode, '');

  for i := 0 to CountPoints - 1 do begin
    X[i] := random(GetMaxX);
    Y[i] := random(GetMaxY);

    dx[i] := random(7) - 3;
    dy[i] := random(7) - 3;

    Col[i] := Colors[random(CountColors)];
  end;

  while KeyPressed do
    ReadKey;

  repeat
    for i := 0 to CountPoints - 1 do begin
      SetColor(Col[i]);
      Line(X[i], Y[i],
        X[(i + 1) mod CountPoints], Y[(i + 1) mod CountPoints]);

      X[i] := X[i] + dx[i];
      Y[i] := Y[i] + dy[i];

      if (X[i] < 0) or (X[i] >= GetMaxX) then
        dx[i] := -dx[i];
      if (Y[i] < 0) or (Y[i] >= GetMaxY) then
        dy[i] := -dy[i];
    end;
  until KeyPressed;

  CloseGraph;

end.


Картинка:
Это текстовая версия — только основной контент. Для просмотра полной версии этой страницы, пожалуйста, нажмите сюда.