Книга программиста/Книга фракталов
(перенаправлено с «Книга фракталов»)
К оглавлению | Назад | Вперёд
Все программы, код которых выложен здесь, являются работоспособными. На момент написания программ использовалась среда PascalABC.Net 3.0.
CodeStyle
правитьСледующего стиля автор придерживается при написании всех программ:
{Описание стиля кода всех программ в данной группе.}
uses GraphABC;
const
{Объявление констант с именами вида NameName.}
Min = 1;
DeltaAng = Pi / 20;
CX = 320;
CY = 240;
var
{Объявление глобальных переменных с именами вида NameName.}
R: real;
A: real;
{Объявление параметров с именами вида nameName.}
procedure Draw(r, angle: real);
begin
{Объявление локальных переменных с именами вида nameName.}
var ang1 := angle + Pi / 4;
var x1 := Round(CX + r * Cos(ang1));
var y1 := Round(CY + r * Sin(ang1));
var ang2 := angle + 3 / 4 * Pi;
var x2 := Round(CX + r * Cos(ang2));
var y2 := Round(CY + r * Sin(ang2));
var ang3 := angle + 5 / 4 * Pi;
var x3 := Round(CX + r * Cos(ang3));
var y3 := Round(CY + r * Sin(ang3));
var ang4 := angle + 7 / 4 * Pi;
var x4 := Round(CX + r * Cos(ang4));
var y4 := Round(CY + r * Sin(ang4));
Line(x1, y1, x2, y2);
Line(x2, y2, x3, y3);
Line(x3, y3, x4, y4);
Line(x4, y4, x1, y1);
end;
begin
R := 320;
A := 0;
repeat
Draw(R, A);
A := A + DeltaAng;
R := R * Sin(Pi / 4) / Sin(3 * Pi / 4 - DeltaAng);
until R <= Min;
end.
Формулы
правитьНахождение координат точки B, которая повернулась на угол angle, относительно точки A на радиусе r:
xB = xA + r * Cos(angle) yB = yA + r * Sin(angle)
PascalABC.Net
правитьРекурсивные решения
правитьГлаз
правитьКомментарии к коду
- C1 - первый цвет круга
- C2 - второй цвет круга
uses GraphABC;
const
C1 = clBlack;
C2 = clWhite;
procedure Draw(x, y, r, angle: real);
begin
if angle < 0 then
begin
SetPenColor(C1);
SetBrushColor(C1);
end
else
begin
SetPenColor(C2);
SetBrushColor(C2);
end;
Circle(Round(x), Round(y), Round(r));
if r > 2 then
begin
var r2 := r / 2;
Draw(x + r2 * Cos(angle), y + r2 * Sin(angle), r / 2, 2 * (-angle));
end;
end;
begin
SetWindowIsFixedSize(true);
var W := Window.Width div 2;
var H := Window.Height div 2;
SetSmoothingOff();
LockDrawing();
while true do
for var i := 0 to 359 do
begin
ClearWindow(clBlack);
var a := DegToRad(i);
Draw(W, H, 200, a);
Redraw();
end;
end.
V-дерево
правитьКомментарии к коду
- Angle - угол наклона прямых относительно оси X
uses GraphABC;
const
Angle = -Pi / 4;
procedure RLine(x, y, x1, y1: real) := Line(Round(x), Round(y), Round(x1), Round(y1));
procedure Draw(x, y, l: real; iterations: integer);
begin
var lx := x + l * Cos(Angle);
var ly := y + l * Sin(Angle);
var angle1 := -Pi / 2 + Angle;
var rx := x + l * Cos(angle1);
var ry := y + l * Sin(angle1);
RLine(x, y, lx, ly);
RLine(x, y, rx, ry);
if iterations > 0 then
begin
Dec(iterations);
l := l / 2;
Draw(lx, ly, l, iterations);
Draw(rx, ry, l, iterations);
end;
end;
begin
LockDrawing();
Draw(300, 300, 200, 7);
Redraw();
end.
Бинарное дерево
правитьКомментарии к коду
- H - смещение вниз во время одной итерации
- Iterations - количество итераций
uses GraphABC;
const
H = 50;
Iterations = 6;
procedure DrawTree(x, y, dx, iterations: integer);
begin
if iterations > 0 then
begin
var xm := x - dx;
var xp := x + dx;
var yp := y + H;
Line(x, y, xm, yp);
Line(x, y, xp, yp);
Dec(iterations);
dx := dx div 2;
DrawTree(xm, yp, dx, iterations);
DrawTree(xp, yp, dx, iterations);
end;
end;
begin
var W := Window.Width;
SetWindowIsFixedSize(true);
SetWindowHeight(20 + Iterations * H);
ClearWindow(clBlack);
SetPenColor(clGreenYellow);
LockDrawing();
DrawTree(W div 2, 10, W div 5, Iterations);
Redraw();
end.
{Адаптировано под PascalABC 3.0.1.35.}
uses GraphABC;
const
H = 50;
Iterations = 6;
procedure DrawTree(x, y, dx, iterations: integer);
var
xm, xp, yp: integer;
begin
if iterations > 0 then
begin
xm := x - dx;
xp := x + dx;
yp := y + H;
Line(x, y, xm, yp);
Line(x, y, xp, yp);
Dec(iterations);
dx := dx div 2;
DrawTree(xm, yp, dx, iterations);
DrawTree(xp, yp, dx, iterations);
end;
end;
var
W: integer;
begin
W := WindowWidth();
SetWindowHeight(20 + Iterations * H);
ClearWindow(clBlack);
SetPenColor(clGreen);
LockDrawing();
DrawTree(W div 2, 10, W div 5, Iterations);
Redraw();
end.
Буква H
правитьuses GraphABC;
procedure RLine(x, y, x1, y1: real):=Line(Round(x), Round(y), Round(x1), Round(y1));
procedure Draw(x, y, l: real);
begin
var xp := x + l;
var xm := x - l;
var yp := y + l;
var ym := y - l;
RLine(x, y, xp, y);
RLine(x, y, xm, y);
RLine(xp, y, xp, ym);
RLine(xp, y, xp, yp);
RLine(xm, y, xm, ym);
RLine(xm, y, xm, yp);
if l > 10 then
begin
l := l / 2;
Draw(xp, ym, l);
Draw(xp, yp, l);
Draw(xm, ym, l);
Draw(xm, yp, l);
end;
end;
begin
LockDrawing();
Draw(Window.Width / 2, Window.Height / 2, 100);
Redraw();
end.
Кривая Пеано
правитьuses GraphABC;
const
Step = 10;
var
angle: integer := 1;
procedure Draw();
begin
angle := angle mod 4;
case angle of
0: LineRel(Step, 0);
1,-3: LineRel(0, Step);
2,-2: LineRel(-Step, 0);
3,-1: LineRel(0, -Step);
end;
end;
procedure Fractal(depth: integer; dividedAngle: integer);
begin
if (depth <= 0) then exit;
Dec(depth);
Fractal(depth, dividedAngle);
Draw();
Fractal(depth, -dividedAngle);
Draw();
Fractal(depth, dividedAngle);
angle += dividedAngle;
Draw();
angle += dividedAngle;
Fractal(depth, -dividedAngle);
Draw();
Fractal(depth, dividedAngle);
Draw();
Fractal(depth, -dividedAngle);
angle -= dividedAngle;
Draw();
angle -= dividedAngle;
Fractal(depth, dividedAngle);
Draw();
Fractal(depth, -dividedAngle);
Draw();
Fractal(depth, dividedAngle);
end;
begin
SetWindowSize(500, 500);
MoveTo(5, 5);
Fractal(3, -1);
end.
Вращающиеся треугольники Серпинского
правитьКомментарии к коду
- N - задает три итерации цикла for
- M - количество фракталов
- Angle - угол поворота при отрисовке треугольника
uses GraphABC;
const
N = 2;
M = 20;
Angle = 120;
var
W, H: integer;
type
Fractal = class
CenterX, CenterY, Length: integer;
C: Color;
Ang: real;
Points: array [0..N] of Point;
constructor ();
begin
for var i := 0 to N do
Points[i] := new Point(0, 0);
Length := Random(100);
C := clRandom();
CenterX := Random(W);
CenterY := Random(H);
end;
procedure Draw(x, y, x1, y1, x2, y2: integer);
begin
Line(x, y, x1, y1);
Line(x1, y1, x2, y2);
Line(x2, y2, x, y);
var cx1 := (x + x1) div 2;
var cy1 := (y + y1) div 2;
var cx2 := (x1 + x2) div 2;
var cy2 := (y1 + y2) div 2;
var cx3 := (x2 + x) div 2;
var cy3 := (y2 + y) div 2;
if Sqrt(Sqr(cx2 - cx1) + Sqr(cy2 - cy1)) > 10 then
begin
Draw(x, y, cx1, cy1, cx3, cy3);
Draw(x1, y1, cx1, cy1, cx2, cy2);
Draw(x2, y2, cx2, cy2, cx3, cy3);
end;
end;
procedure RedrawFractal();
begin
SetPenColor(C);
for var i := 0 to N do
begin
var ang1 := DegToRad(Angle * i + Ang);
Points[i].X := Round(CenterX + Length * Cos(ang1));
Points[i].Y := Round(CenterY + Length * Sin(ang1));
end;
Draw(Points[0].X, Points[0].Y, Points[1].X, Points[1].Y, Points[2].X, Points[2].Y);
for var i := 0 to N do
begin
var ang1 := DegToRad(Angle * i - Ang);
Points[i].X := Round(CenterX + Length * Cos(ang1));
Points[i].Y := Round(CenterY + Length * Sin(ang1));
end;
Draw(Points[0].X, Points[0].Y, Points[1].X, Points[1].Y, Points[2].X, Points[2].Y);
Ang := Ang + 1;
end;
end;
var
Fractals: array [0..M] of Fractal;
begin
W := Window.Width;
H := Window.Height;
SetWindowIsFixedSize(true);
LockDrawing();
for var i := 0 to M do
Fractals[i] := new Fractal();
while true do
begin
ClearWindow(clBlack);
for var i := 0 to M do
Fractals[i].RedrawFractal();
Redraw();
end;
end.
{Адаптировано под PascalABC 3.0.1.35.}
uses GraphABC, PointRect;
const
N = 30;
M = 20;
Angle = 120;
var
W, H: integer;
function DegToRad(x: real): real;
begin
Result := x * 0.0174533;
end;
type
Fractal = class
CenterX, CenterY, Length: integer;
C: ColorType;
Ang: real;
Points: array [0..N] of Point;
constructor Create;
var
i: integer;
begin
for i := 0 to N do
Points[i] := PointF(0, 0);
Length := Random(100);
C := RGB(Random(255), Random(255), Random(255));
CenterX := Random(W);
CenterY := Random(H);
end;
procedure Draw(x, y, x1, y1, x2, y2: integer);
var
cx1, cy1: integer;
cx2, cy2: integer;
cx3, cy3: integer;
begin
Line(x, y, x1, y1);
Line(x1, y1, x2, y2);
Line(x2, y2, x, y);
cx1 := (x + x1) div 2;
cy1 := (y + y1) div 2;
cx2 := (x1 + x2) div 2;
cy2 := (y1 + y2) div 2;
cx3 := (x2 + x) div 2;
cy3 := (y2 + y) div 2;
if Sqrt(Sqr(cx2 - cx1) + Sqr(cy2 - cy1)) > 10 then
begin
Draw(x, y, cx1, cy1, cx3, cy3);
Draw(x1, y1, cx1, cy1, cx2, cy2);
Draw(x2, y2, cx2, cy2, cx3, cy3);
end;
end;
procedure RedrawFractal;
var
i: integer;
ang1: real;
begin
SetPenColor(C);
for i := 0 to N do
begin
ang1 := DegToRad(Angle * i + Ang);
Points[i].X := Round(CenterX + Length * Cos(ang1));
Points[i].Y := Round(CenterY + Length * Sin(ang1));
end;
Draw(Points[0].X, Points[0].Y, Points[1].X, Points[1].Y, Points[2].X, Points[2].Y);
for i := 0 to N do
begin
ang1 := DegToRad(Angle * i - Ang);
Points[i].X := Round(CenterX + Length * Cos(ang1));
Points[i].Y := Round(CenterY + Length * Sin(ang1));
end;
Draw(Points[0].X, Points[0].Y, Points[1].X, Points[1].Y, Points[2].X, Points[2].Y);
Ang := Ang + 1;
end;
end;
var
A: array [0..M] of Fractal;
i: integer;
begin
W := WindowWidth();
H := WindowHeight();
LockDrawing();
for i := 0 to M do
A[i] := Fractal.Create();
while true do
begin
ClearWindow(clBlack);
for i := 0 to M do
A[i].RedrawFractal();
Redraw();
end;
end.
Гребень Кантора
правитьКомментарии к коду
- H - смещение вниз во время одной итерации
uses GraphABC;
const
H = 30;
procedure Draw(x, y, x1, y1: integer; connect: boolean);
begin
var d := x1 - x;
if d > 10 then
begin
if connect then Line(x, y, x1, y1);
var xp1 := Round(x + d / 3);
var xp2 := Round(x + d * 2 / 3);
var y2 := y + H;
var y3 := y2 - 1;
DrawRectangle(x, y, xp1, y2);
DrawRectangle(xp2, y, x1, y2);
Draw(x, y + H - 1, xp1, y3, false);
Draw(xp2, y3, x1, y3, false);
end;
end;
begin
LockDrawing();
Draw(100, 100, 600, 100, true);
Redraw();
end.
Двоичное дерево
правитьuses GraphABC;
procedure RLine(x, y, x1, y1: real):=Line(Round(x), Round(y), Round(x1), Round(y1));
procedure Draw(x, y, l: real);
begin
var ym := y - l;
RLine(x, y, x, ym);
RLine(x - l, ym, x + l, ym);
if l > 5 then
begin
var l2 := l;
var y2 := y - l;
l := l / 2;
Draw(x - l2, y2, l);
Draw(x + l2, y2, l);
end;
end;
begin
LockDrawing();
Draw(300, 500, 60);
Redraw();
end.
Карта высот
правитьКомментарии к коду
- RndMax - верхняя граница
uses GraphABC;
const
RndMax = 255;
type
Point3D = class
X, Y, Z: real;
constructor(px, py, pz: real);
begin
X := px;
Y := py;
Z := pz;
end;
end;
procedure Draw(pA, pC: Point3D; bZ, dZ: real);
begin
var pB := new Point3D(pC.X, pA.Y, bZ);
var pD := new Point3D(pA.X, pC.Y, dZ);
var cx := (pA.X + pB.X) / 2;
var cy := (pB.Y + pC.Y) / 2;
if (pB.X - pA.X) * (pC.Y - pB.Y) > 1 then
begin
var maxz := Max(Max(Max(pA.Z, pB.Z), pC.Z), pD.Z);
var minz := Min(Min(Min(pA.Z, pB.Z), pC.Z), pD.Z);
var randz := 0.0;
if maxz - minz > 0 then randz := minz + Random() * (maxz - minz);
var pCenter := new Point3D(cx, cy, randz);
var p1 := new Point3D(cx, pA.Y, (pA.Z + pB.Z) / 2);
var p2 := new Point3D(pB.X, cy, (pB.Z + pC.Z) / 2);
var p3 := new Point3D(cx, pC.Y, (pC.Z + pD.Z) / 2);
var p4 := new Point3D(pA.X, cy, (pD.Z + pA.Z) / 2);
Draw(pA, pCenter, p1.Z, p4.Z);
Draw(p1, p2, pB.Z, pCenter.Z);
Draw(pCenter, pC, p2.Z, p3.Z);
Draw(p4, p3, pCenter.Z, pD.Z);
end
else
begin
var zv := Round((pA.Z + pB.Z + pC.Z + pD.Z) / 4);
SetBrushColor(RGB(0, zv, 255));
FillRect(Round(pA.X), Round(pA.Y), Round(pC.X), Round(pC.Y));
end;
end;
begin
var W := Window.Width;
var H := Window.Height;
SetWindowIsFixedSize(true);
LockDrawing();
Draw(new Point3D(0, 0, Random(RndMax)), new Point3D(W, H, Random(RndMax)), Random(RndMax), Random(RndMax));
Redraw();
end.
Ковер Серпинского
правитьuses GraphABC;
procedure RDrawRectangle(x, y, x1, y1: real):=DrawRectangle(Round(x), Round(y), Round(x1), Round(y1));
procedure Draw(x, y, w, h: real);
begin
RDrawRectangle(x, y, x + w, y + h);
var w1 := w / 3;
var h1 := h / 3;
RDrawRectangle(x + w1, y + h1, x + 2 * w1, y + 2 * h1);
if (w1 > 3) and (h1 > 3) then
begin
for var i := 0 to 2 do
for var j := 0 to 2 do
if (i <> 1) or (j <> 1) then
Draw(x + w1 * i, y + h1 * j, w1, h1);
end;
end;
begin
SetWindowSize(500, 500);
LockDrawing();
Draw(0, 0, Window.Width, Window.Height);
Redraw();
end.
Кривая Серпинского
правитьuses GraphABC;
procedure RLine(x, y, x1, y1: real) := Line(Round(x), Round(y), Round(x1), Round(y1));
function GetAngle(x, y, x2, y2: real): real;
begin
var angle := Abs(RadToDeg(ArcTan((y2 - y) / (x2 - x))));
if (x2 = x) and (y2 = y) then
Result := 0
else
if x2 > x then
if y2 > y then Result := angle else Result := 360 - angle
else
if y2 > y then Result := 180 - angle else Result := 180 + angle;
end;
procedure Draw(x, y, x1, y1: real; inverted: boolean);
begin
var angle := GetAngle(x, y, x1, y1);
var s := 1 - 2 * Ord(inverted);
var r := Sqrt(Sqr(x1 - x) + Sqr(y1 - y)) / 2;
var ang1 := DegToRad(angle - 60 * s);
var xA := x + r * Cos(ang1);
var yA := y + r * Sin(ang1);
var ang2 := DegToRad(angle - 120 * s);
var xB := x1 + r * Cos(ang2);
var yB := y1 + r * Sin(ang2);
if 2 * r < 8 then
begin
RLine(x, y, xA, yA);
RLine(xA, yA, xB, yB);
RLine(xB, yB, x1, y1);
end
else
begin
Draw(x, y, xA, yA, not inverted);
Draw(xA, yA, xB, yB, inverted);
Draw(xB, yB, x1, y1, not inverted);
end;
end;
begin
Draw(100, 100, 400, 450, false);
end.
Кольцо деревьев
правитьuses GraphABC;
const
K1 = 0.99;
K2 = 0.5;
K3 = 0.45;
IncAngle = 15;
Rotation = 45;
R1 = 130;
R2 = 160;
Iterations = 10;
procedure RLine(x, y, x1, y1: real):=Line(Round(x), Round(y), Round(x1), Round(y1));
procedure Draw(x, y, r, ang: real; toRight: boolean);
begin
var ang1 := DegToRad(ang);
var cx := x + r * Cos(ang1);
var cy := y + r * Sin(ang1);
RLine(x, y, cx, cy);
if r > 1 then
if toRight then
Draw(cx, cy, r * K1, ang + IncAngle, toRight)
else
Draw(cx, cy, r * K1, ang - IncAngle, toRight);
end;
procedure Draw(x, y, r, ang: real);
begin
Draw(x, y, r, ang, true);
Draw(x, y, r, ang, false);
end;
procedure DrawTree(x, y, r, ang: real; iterations: integer);
begin
var ang1 := ang;
ang := DegToRad(ang);
var cx := x + r * Cos(ang);
var cy := y + r * Sin(ang);
var mx := (x + cx) / 2;
var my := (y + cy) / 2;
RLine(x, y, cx, cy);
if r < 30 then
Draw(mx, my, r * 0.069, ang1);
if iterations > 0 then
begin
Dec(iterations);
var r2 := r * K2;
DrawTree(cx, cy, r * K3, ang1, iterations);
DrawTree(mx, my, r2, ang1 + Rotation, iterations);
DrawTree(mx, my, r2, ang1 - Rotation, iterations);
end;
end;
begin
SetWindowSize(600, 600);
SetWindowIsFixedSize(true);
ClearWindow(clBlack);
var W := Window.Width;
var H := Window.Height;
SetPenColor(clPink);
LockDrawing();
var W2 := W / 2;
var H2 := H / 2;
DrawTree(0, 0, R2, 45, Iterations);
DrawTree(W2, 0, R1, 90, Iterations);
DrawTree(W, 0, R2, 135, Iterations);
DrawTree(W, H2, R1, 180, Iterations);
DrawTree(W, H, R2, -135, Iterations);
DrawTree(W2, H, R1, -90, Iterations);
DrawTree(0, H, R2, -45, Iterations);
DrawTree(0, H2, R1, 0, Iterations);
Redraw();
end.
Комок шерсти
правитьКомментарии к коду
- Rotation - угол поворота
- MinAngle - минимальный угол для поворота отрезка
- MaxAngle - максимальный угол для поворота отрезка
- RandomAngle - максимальное значение, которое может принимать по модулю случайный угол
- AngleCount - количество углов
uses GraphABC;
const
Rotation = 15;
MinAngle = -400;
MaxAngle = 400;
RandomAngle = 10;
MaxT = 5;
AngleCount = 10;
procedure Draw(x, y, r, angle: real; n: integer);
begin
var ang := DegToRad(angle);
var x1 := x + r * Cos(ang);
var y1 := y + r * Sin(ang);
SetPenWidth(n);
Line(Round(x), Round(y), Round(x1), Round(y1));
if r > 8 then
begin
r := r * 0.8;
if n > 0 then n := n - 1;
if angle + Rotation < MaxAngle then
Draw(x1, y1, r, angle + Rotation + Random(-RandomAngle, RandomAngle), n);
if angle - Rotation > MinAngle then
Draw(x1, y1, r, angle - Rotation - Random(-RandomAngle, RandomAngle), n);
end;
end;
begin
ClearWindow(clBlack);
SetWindowIsFixedSize(true);
var R := 50;
var PosX := Window.Width div 2;
var PosY := Window.Height div 2;
LockDrawing();
while R > 0 do
begin
var c := clRandom();
SetPenColor(ARGB(50, c.R, c.G, c.B));
for var i := 0 to AngleCount - 1 do
Draw(PosX, PosY, R, (360 / AngleCount) * i, 1);
Dec(R, 2);
end;
Redraw();
end.
Кривая дракона
править{Адаптировано под PascalABC.Net.}
uses GraphABC;
procedure Draw(x, y, x1, y1, k: integer);
begin
if k > 0 then
begin
var xn := (x + x1) div 2 + (y1 - y) div 2;
var yn := (y + y1) div 2 - (x1 - x) div 2;
Dec(k);
Draw(x, y, xn, yn, k);
Draw(x1, y1, xn, yn, k);
end
else
Line(x, y, x1, y1);
end;
begin
LockDrawing();
Draw(200, 300, 500, 300, 20);
Redraw();
end.
Ледовая буква H
правитьuses GraphABC;
const
K = 0.45;
procedure RLine(x, y, x1, y1: real):=Line(Round(x), Round(y), Round(x1), Round(y1));
procedure Draw(x, y, r, angle: real);
begin
var angle1 := DegToRad(angle);
var angle2 := DegToRad(angle - 90);
var x2 := x + r * Cos(angle1);
var y2 := y + r * Sin(angle1);
var mx := (x + x2) / 2;
var my := (y + y2) / 2;
var r2 := r / 2;
var r3 := r2 * K;
var cx := mx + r3 * Cos(angle2);
var cy := my + r3 * Sin(angle2);
RLine(x, y, x2, y2);
RLine(mx, my, cx, cy);
if r > 10 then
SetPenColor(clBlue)
else
SetPenColor(clCyan);
if r > 8 then
begin
Draw(x, y, r2, angle);
Draw(mx, my, r2, angle);
Draw(mx, my, r3, angle - 90);
Draw(cx, cy, r3, angle + 90);
end;
end;
function GetAngle(x, y, x2, y2: real): real;
begin
var angle := Abs(RadToDeg(ArcTan((y2 - y) / (x2 - x))));
if (x2 = x) and (y2 = y) then
Result := 0
else
if x2 > x then
if y2 > y then Result := angle else Result := 360 - angle
else
if y2 > y then Result := 180 - angle else Result := 180 + angle;
end;
procedure DrawIce(x, y, x1, y1: real);
begin
var d := Sqrt(Sqr(x1 - x) + Sqr(y1 - y));
Draw(x1, y1, d, GetAngle(x1, y1, x, y));
Draw(x, y, d, GetAngle(x, y, x1, y1));
end;
procedure Draw(x, y, l: real);
begin
var xp := x + l;
var xm := x - l;
var yp := y + l;
var ym := y - l;
DrawIce(x, y, xp, y);
DrawIce(x, y, xm, y);
DrawIce(xp, y, xp, ym);
DrawIce(xp, y, xp, yp);
DrawIce(xm, y, xm, ym);
DrawIce(xm, y, xm, yp);
if l > 50 then
begin
l := l / 2;
Draw(xp, ym, l);
Draw(xp, yp, l);
Draw(xm, ym, l);
Draw(xm, yp, l);
end;
end;
begin
SetWindowIsFixedSize(true);
ClearWindow(clBlack);
LockDrawing();
Draw(Window.Width / 2, Window.Height / 2, 100);
Redraw();
end.
Ледовый многоугольник
правитьuses GraphABC;
const
N = 4;
R = 300;
Inside = true;
K = 0.5;
procedure RLine(x, y, x1, y1: real):=Line(Round(x), Round(y), Round(x1), Round(y1));
procedure Draw(x, y, r, angle: real);
begin
var angle1 := DegToRad(angle);
var angle2 := DegToRad(angle - 90);
var x2 := x + r * Cos(angle1);
var y2 := y + r * Sin(angle1);
var mx := (x + x2) / 2;
var my := (y + y2) / 2;
var r2 := r / 2;
var r3 := r2 * K;
var cx := mx + r3 * Cos(angle2);
var cy := my + r3 * Sin(angle2);
RLine(x, y, x2, y2);
RLine(mx, my, cx, cy);
if r > 20 then
begin
Draw(x, y, r2, angle);
Draw(mx, my, r2, angle);
Draw(mx, my, r3, angle - 90);
Draw(cx, cy, r3, angle + 90);
end;
end;
function GetAngle(x, y, x2, y2: real): real;
begin
var angle := Abs(RadToDeg(ArcTan((y2 - y) / (x2 - x))));
if (x2 = x) and (y2 = y) then
Result := 0
else
if x2 > x then
if y2 > y then Result := angle else Result := 360 - angle
else
if y2 > y then Result := 180 - angle else Result := 180 + angle;
end;
procedure DrawIce(x, y, x1, y1: real):=Draw(x, y, sqrt(Sqr(x1 - x) + Sqr(y1 - y)), GetAngle(x, y, x1, y1));
begin
FloodFill(1, 1, clBlack);
SetPenColor(clCyan);
var Angle := 360 / N;
var W := Window.Width;
var H := Window.Height;
LockDrawing();
MaximizeWindow();
for var i := 0 to N - 1 do
begin
var ang1 := DegToRad(Angle * i);
var ang2 := DegToRad(Angle * (i + 1));
if not Inside then
DrawIce(W + R * Cos(ang1), H + R * Sin(ang1), W + R * Cos(ang2), H + R * Sin(ang2))
else
DrawIce(W + R * Cos(ang2), H + R * Sin(ang2), W + R * Cos(ang1), H + R * Sin(ang1));
end;
Redraw();
end.
Ледяной квадрат
правитьuses GraphABC;
procedure RLine(x, y, x1, y1: real):=Line(Round(x), Round(y), Round(x1), Round(y1));
procedure Draw(x, y, r, angle: real);
begin
var angle1 := DegToRad(angle);
var angle2 := DegToRad(angle - 90);
var x2 := x + r * Cos(angle1);
var y2 := y + r * Sin(angle1);
var mx := (x + x2) / 2;
var my := (y + y2) / 2;
var r2 := r / 2;
var r3 := r2 * 0.8;
var cx := mx + r3 * Cos(angle2);
var cy := my + r3 * Sin(angle2);
RLine(x, y, x2, y2);
RLine(mx, my, cx, cy);
if r > 30 then
begin
Draw(x, y, r2, angle);
Draw(mx, my, r2, angle);
Draw(mx, my, r3, angle - 90);
Draw(cx, cy, r3, angle + 90);
end;
end;
begin
SetWindowIsFixedSize(true);
SetWindowSize(600, 600);
ClearWindow(clBlack);
SetPenColor(clCyan);
LockDrawing();
Draw(100, 500, 400, 0);
Draw(100, 100, 400, 90);
Draw(500, 500, 400, -90);
Draw(500, 100, 400, -180);
Redraw();
end.
Множество Мандельброта
правитьuses GraphABC;
const
N = 255;
Max = 10;
W = 400;
H = 300;
K = 0.002;
begin
SetWindowIsFixedSize(true);
SetWindowSize(W, H);
LockDrawing();
for var ix := 0 to W - 1 do
for var iy := 0 to H - 1 do
begin
var x := 0.0;
var y := 0.0;
var cy := K * (iy - 150);
var i := 0;
for i := 1 to N do
begin
var x1 := Sqr(x) - Sqr(y) + K * (ix - 720);
var y1 := 2 * x * y + cy;
if (x1 > Max) or (y1 > Max) then break;
x := x1;
y := y1;
end;
if i >= N then
PutPixel(ix, iy, Color.Red)
else
PutPixel(ix, iy, RGB(255, 255 - i, 255 - i));
end;
Redraw();
end.
Папоротники
правитьПапоротник
правитьКомментарии к коду
- Rotate - угол поворота одной ветки относительно другой
- MaxAng - максимальный угол наклона
uses GraphABC;
const
Rotate = 50;
MaxAng = 10;
var
Ang: integer;
procedure Draw(x, y, l, angle: real; s: integer);
begin
var ang1 := DegToRad(angle);
var cx := x + l * Cos(ang1);
var cy := y + l * Sin(ang1);
SetPenWidth(s);
Line(Round(x), Round(y), Round(cx), Round(cy));
if l > 1 then
begin
var l2 := l * 0.72;
l := l * 0.5;
if s > 1 then Dec(s);
var ang3 := angle + Ang;
Draw(cx, cy, l2, ang3, s);
Draw(cx, cy, l, ang3 + Rotate, s);
Draw(cx, cy, l, ang3 - Rotate, s);
end;
end;
begin
var W := Window.Width / 2;
var H := Window.Height;
SetPenColor(clDarkGreen);
SetSmoothingOff();
LockDrawing();
while true do
begin
for Ang := -MaxAng to MaxAng do
begin
ClearWindow();
Draw(W, H, 100, -90, 2);
Redraw();
end;
for Ang := MaxAng downto -MaxAng do
begin
ClearWindow();
Draw(W, H, 100, -90, 2);
Redraw();
end;
end;
end.
Папоротники
правитьuses GraphABC;
const
Rotate = 40;
var
Ang: integer;
procedure Draw(x, y, l, angle: real; s: integer; toRight: boolean);
begin
var ang1 := DegToRad(angle);
var cx := x + l * Cos(ang1);
var cy := y + l * Sin(ang1);
SetPenWidth(s);
Line(Round(x), Round(y), Round(cx), Round(cy));
if l > 1 then
begin
var l2 := l * 0.7;
l := l * 0.5;
if s > 1 then Dec(s);
var ang2 := angle + Ang;
var ang3 := angle - Ang;
if toRight then
begin
Draw(cx, cy, l2, ang2, s, toRight);
Draw(cx, cy, l, ang2 + Rotate, s, toRight);
Draw(cx, cy, l, ang3 - Rotate, s, toRight);
end
else
begin
Draw(cx, cy, l2, ang3, s, toRight);
Draw(cx, cy, l, ang2 + Rotate, s, toRight);
Draw(cx, cy, l, ang3 - Rotate, s, toRight);
end;
end;
end;
var
ToRight: boolean;
begin
var W := Window.Width;
var H := Window.Height;
SetWindowIsFixedSize(true);
ClearWindow(clBlack);
LockDrawing();
SetSmoothingOff();
var X := 0;
var N := 5;
for var i := 0 to 10 do
begin
var j := Random(60);
if j mod 2 = 0 then ToRight := true else ToRight := false;
j := Random(2);
case j of
0: SetPenColor(clPink);
1: SetPenColor(clRed);
end;
Ang := Random(20);
Draw(X + Random(10), H + Random(10), Random(100), -90, 3, ToRight);
Inc(X, W div (N + 1));
end;
Redraw();
end.
Разноцветные прямоугольники
правитьuses GraphABC;
procedure RRect(x, y, x1, y1: real; c: Color);
begin
SetBrushColor(c);
FillRect(Round(x), Round(y), Round(x1), Round(y1));
end;
procedure Draw(x, y, l: real; c1, c2: Color);
begin
var y1 := y - l * 2;
RRect(x, y, x - l, y1, c1);
RRect(x, y, x + l, y1, c2);
if l > 10 then
begin
var y2 := y - l;
l := l / 2;
Draw(x - l, y2, l, c1, c2);
Draw(x + l, y2, l, c1, c2);
end;
end;
begin
SetWindowIsFixedSize(true);
ClearWindow(clBlack);
LockDrawing();
Draw(220, 420, 200, clBlack, clYellowGreen);
Redraw();
end.
Розовое растение
правитьuses GraphABC;
const
Rotation = 10;
MinAngle = -180;
MaxAngle = 0;
RandomAngle = 45;
procedure RLine(x, y, x1, y1: real):=Line(Round(x), Round(y), Round(x1), Round(y1));
procedure Draw(x, y, r, angle: real; n: integer);
begin
var ang := DegToRad(angle);
var x1 := x + r * Cos(ang);
var y1 := y + r * Sin(ang);
SetPenWidth(n);
RLine(x, y, x1, y1);
if r > 1 then
begin
r := r * 0.8;
if n > 0 then n := n - 1;
if angle + Rotation < MaxAngle then
Draw(x1, y1, r, angle + Rotation + Random(RandomAngle), n);
if angle - Rotation > MinAngle then
Draw(x1, y1, r, angle - Rotation - Random(RandomAngle), n);
end;
end;
begin
ClearWindow(clBlack);
SetWindowIsFixedSize(true);
SetPenColor(ARGB(100, clPink.R, clPink.G, clPink.B));
LockDrawing();
Draw(Window.Width / 2, Window.Height / 2 + 50, 50, -90, 5);
Redraw();
end.
Снежинка
правитьКомментарии к коду
- N - количество углов
- K1 - коэффициент изменения первого радиуса
- K2 - коэффициент изменения второго радиуса
- DeltaAngle - угол отклонения веток
uses GraphABC;
const
N = 11;
K1 = 4;
K2 = 0.6;
DeltaAngle = 50;
procedure RLine(x, y, x1, y1: real) := Line(Round(x), Round(y), Round(x1), Round(y1));
procedure Star(x, y, r, angle: real);
procedure Draw(x, y, r, angle: real);
begin
if r > 10 then
begin
var ang1 := DegToRad(angle);
var cx := x + r * Cos(ang1);
var cy := y + r * Sin(ang1);
var mx := (x + cx) / 2;
var my := (y + cy) / 2;
RLine(x, y, mx, my);
Draw(mx, my, r * K2, angle);
Draw(mx, my, r * K2, angle + DeltaAngle);
Draw(mx, my, r * K2, angle - DeltaAngle);
end;
end;
begin
var ang1 := 360 / N;
var ang2 := DegToRad(angle);
var cx := x + r * Cos(ang2);
var cy := y + r * Sin(ang2);
var r2 := r * K1;
Draw(cx, cy, r2, angle);
for var i := 1 to N do
begin
var ang3 := DegToRad(ang1 * i + angle);
var cx2 := x + r * Cos(ang3);
var cy2 := y + r * Sin(ang3);
RLine(x, y, cx2, cy2);
RLine(cx2, cy2, cx, cy);
cx := cx2;
cy := cy2;
Draw(cx2, cy2, r2, RadToDeg(ang3));
end;
end;
begin
SetWindowIsFixedSize(true);
LockDrawing();
SetPenColor(clCyan);
while true do
for var i := 0 to 359 do
begin
ClearWindow(clBlack);
Star(Window.Width / 2, Window.Height / 2, 30, i);
Redraw();
end;
end.
Спиральные квадраты
правитьuses GraphABC;
const
Min = 1;
DeltaAng = Pi / 20;
CX = 320;
CY = 240;
var
R: real;
A: real;
procedure Draw(r, angle: real);
begin
var ang1 := angle + Pi / 4;
var x1 := Round(CX + r * Cos(ang1));
var y1 := Round(CY + r * Sin(ang1));
var ang2 := angle + 3 / 4 * Pi;
var x2 := Round(CX + r * Cos(ang2));
var y2 := Round(CY + r * Sin(ang2));
var ang3 := angle + 5 / 4 * Pi;
var x3 := Round(CX + r * Cos(ang3));
var y3 := Round(CY + r * Sin(ang3));
var ang4 := angle + 7 / 4 * Pi;
var x4 := Round(CX + r * Cos(ang4));
var y4 := Round(CY + r * Sin(ang4));
Line(x1, y1, x2, y2);
Line(x2, y2, x3, y3);
Line(x3, y3, x4, y4);
Line(x4, y4, x1, y1);
end;
begin
R := 320;
A := 0;
LockDrawing();
repeat
Draw(R, A);
A := A + DeltaAng;
R := R * Sin(Pi / 4) / Sin(3 * Pi / 4 - DeltaAng);
until R <= Min;
Redraw();
end.
Дерево Пифагора
правитьТонкое дерево Пифагора
правитьuses GraphABC;
procedure RLine(x, y, x1, y1: real):=Line(Round(x), Round(y), Round(x1), Round(y1));
procedure Draw(x, y, r, angle: real);
begin
var ang1 := DegToRad(angle);
var cx := x + r * Cos(ang1);
var cy := y + r * Sin(ang1);
var ang2 := Pi / 4;
var ang3 := ang1 - ang2;
var cx1 := cx + r * Cos(ang3);
var cy1 := cy + r * Sin(ang3);
var ang4 := ang1 + ang2;
var cx2 := cx + r * Cos(ang4);
var cy2 := cy + r * Sin(ang4);
RLine(x, y, cx, cy);
RLine(cx, cy, cx1, cy1);
RLine(cx, cy, cx2, cy2);
if r > 1 then
begin
r := r * 0.7;
Draw(cx1, cy1, r, RadToDeg(ang3));
Draw(cx2, cy2, r, RadToDeg(ang4));
end;
end;
begin
FloodFill(1, 1, clBlack);
SetPenColor(clCyan);
LockDrawing();
Draw(500, Window.Height - 10, 70, -90);
Redraw();
end.
Толстое дерево Пифагора
правитьКомментарии к коду
- Size - первоначальная длина стороны квадрата
- RotationAngle - угол отклонения веток
uses GraphABC;
const
Size = 100;
RotationAngle = 45;
procedure RLine(x, y, x1, y1: real) := Line(Round(x), Round(y), Round(x1), Round(y1));
procedure Draw(x, y, r, angle: real);
begin
var ang1 := DegToRad(angle + 90);
var x1 := x + r * Cos(ang1);
var y1 := y + r * Sin(ang1);
var ang2 := DegToRad(angle);
var x2 := x1 + r * Cos(ang2);
var y2 := y1 + r * Sin(ang2);
var ang3 := DegToRad(angle - 90);
var x3 := x2 + r * Cos(ang3);
var y3 := y2 + r * Sin(ang3);
var r2 := r / Sqrt(2);
var ang4 := DegToRad(angle - 135);
var x4 := x3 + r2 * Cos(ang4);
var y4 := y3 + r2 * Sin(ang4);
RLine(x, y, x1, y1);
RLine(x1, y1, x2, y2);
RLine(x2, y2, x3, y3);
RLine(x3, y3, x, y);
RLine(x, y, x4, y4);
RLine(x3, y3, x4, y4);
if r2 > 2 then
begin
var angm := angle - 45;
var ang5 := DegToRad(angle - 135);
var ang6 := DegToRad(angm);
Draw(x + r2 * Cos(ang5), y + r2 * Sin(ang5), r2, angm);
Draw(x4 + r2 * Cos(ang6), y4 + r2 * Sin(ang6), r2, angle + 45);
end;
end;
begin
LockDrawing();
Draw(Window.Width / 2 - Size / 2, Window.Height / 2 + 100, Size, 0);
Redraw();
end.
Толстое наклоненное дерево Пифагора
правитьКомментарии к коду
- Size - первоначальная длина стороны квадрата
- RotationAngle - угол отклонения веток
uses GraphABC;
const
Size = 100;
RotationAngle = 50;
procedure RLine(x, y, x1, y1: real) := Line(Round(x), Round(y), Round(x1), Round(y1));
procedure Draw(x, y, r, angle: real);
begin
var ang1 := DegToRad(angle + 90);
var x1 := x + r * Cos(ang1);
var y1 := y + r * Sin(ang1);
var ang2 := DegToRad(angle);
var x2 := x1 + r * Cos(ang2);
var y2 := y1 + r * Sin(ang2);
var ang3 := DegToRad(angle - 90);
var x3 := x2 + r * Cos(ang3);
var y3 := y2 + r * Sin(ang3);
var r2 := r * Cos(DegToRad(RotationAngle));
var r3 := r * Cos(DegToRad(90 - RotationAngle));
var ang4 := DegToRad(angle - RotationAngle);
var x4 := x + r2 * Cos(ang4);
var y4 := y + r2 * Sin(ang4);
RLine(x, y, x1, y1);
RLine(x1, y1, x2, y2);
RLine(x2, y2, x3, y3);
RLine(x3, y3, x, y);
RLine(x, y, x4, y4);
RLine(x4, y4, x3, y3);
if r > 1 then
begin
var ang5 := DegToRad(angle - 90 - RotationAngle);
Draw(x + r2 * Cos(ang5), y + r2 * Sin(ang5), r2, angle - RotationAngle);
var ang6 := DegToRad(angle - RotationAngle);
Draw(x4 + r3 * Cos(ang6), y4 + r3 * Sin(ang6), r3, angle + 90 - RotationAngle);
end;
end;
begin
LockDrawing();
MaximizeWindow();
Draw(Window.Width / 2 - Size / 2, Window.Height / 2 + 200, Size, 0);
Redraw();
end.
Треугольник Серпинского
правитьuses GraphABC;
procedure RLine(x, y, x1, y1: real) := Line(Round(x), Round(y), Round(x1), Round(y1));
procedure Draw(x, y, x1, y1, x2, y2: real; iterations: integer);
begin
if iterations > 0 then
begin
var mx1 := (x + x1) / 2;
var my1 := (y + y1) / 2;
var mx2 := (x1 + x2) / 2;
var my2 := (y1 + y2) / 2;
var mx3 := (x2 + x) / 2;
var my3 := (y2 + y) / 2;
Dec(iterations);
Draw(x, y, mx1, my1, mx3, my3, iterations);
Draw(mx1, my1, x1, y1, mx2, my2, iterations);
Draw(mx3, my3, mx2, my2, x2, y2, iterations);
end
else
begin
RLine(x, y, x1, y1);
RLine(x1, y1, x2, y2);
RLine(x2, y2, x, y);
end;
end;
begin
Lockdrawing();
Draw(100, 500, 100, 100, 500, 500, 8);
Redraw();
end.
Троичное дерево
правитьuses GraphABC;
const
Length = 240;
Angle = 120;
procedure Draw(x, y, r: real; ang, rotation: real);
var
xp, yp: real;
begin
var steps := 360 div Angle - 1;
for var i := 0 to steps do
if i * Angle <> ang then
begin
var ang1 := DegToRad(Angle * i + rotation);
Line(Round(x), Round(y), Round(x + r * Cos(ang1)), Round(y + r * Sin(ang1)));
end;
for var i := 0 to steps do
begin
var r2 := r / 2;
var ang1 := DegToRad(Angle * i + rotation);
xp := x + r2 * Cos(ang1);
yp := y + r2 * Sin(ang1);
if r >= 1 then
Draw(xp, yp, r2 - 10, i * Angle, rotation);
end;
end;
begin
SetWindowIsFixedSize(true);
SetWindowSize(500, 500);
SetSmoothingOff();
LockDrawing();
while true do
begin
var c := clRandom();
for var i := 0 to 360 do
begin
ClearWindow(clBlack);
SetPenColor(c);
Draw(Window.Width / 2, Window.Height / 2, Length, 1, i);
Redraw();
end;
end;
end.
Ураган
правитьuses GraphABC;
const
N = 10;
K1 = 0.67;
K2 = 0.18;
IncAngle = 10;
procedure Draw(x, y, r, ang: real);
begin
if r > 2 then
begin
Draw(x, y, r * K1, ang + IncAngle);
var ang1 := 360 / N;
for var i := 0 to N - 1 do
begin
var angle := DegToRad(ang1 * i + ang);
Draw(x + r * Cos(angle), y + r * Sin(angle), r * K2, ang + IncAngle);
end;
end
else
DrawCircle(Round(x), Round(y), Round(r));
end;
begin
SetWindowIsFixedSize(true);
LockDrawing();
while true do
for var i := 0 to 359 do
begin
ClearWindow();
Draw(Window.Width / 2, Window.Height / 2, 190, i);
Redraw();
end;
end.
Фрактал из окружностей
правитьuses GraphABC;
const
K = 2.6;
procedure RCircle(x, y, r: real):=Circle(Round(x), Round(y), Round(r));
procedure Draw(x, y, r: real);
begin
RCircle(x, y, r / K);
if r > 4 then
begin
var r2 := r;
r := r / K;
Draw(x, y - r2, r);
Draw(x + r2, y, r);
Draw(x, y + r2, r);
Draw(x - r2, y, r);
end;
end;
begin
LockDrawing();
Draw(Window.Width / 2, Window.Height / 2, 130);
Redraw();
end.
Фрактал из прямоугольников
правитьuses GraphABC;
const
P = 49 / 100;
procedure RRect(x, y, x1, y1: real):=Rectangle(Round(x), Round(y), Round(x1 + 1), Round(y1 + 1));
procedure Draw(x, y, x1, y1, n: real);
begin
var dx := Abs((x1 - x) * P);
var dy := Abs((y1 - y) * P);
RRect(x, y, x1, y1);
if dx > 1 then
begin
var xm := x - dx;
var ym := y - dy;
var x1p := x1 + dx;
var y1p := y1 + dy;
if n <> 1 then Draw(xm, ym, x, y, 3);
if n <> 2 then Draw(x1, ym, x1p, y, 4);
if n <> 3 then Draw(x1, y1, x1p, y1p, 1);
if n <> 4 then Draw(xm, y1, x, y1p, 2);
end;
end;
begin
LockDrawing();
Draw(300, 300, 600, 600, 0);
Redraw();
end.
Фракталы в DrawMan
правитьФрактал из прямоугольников
правитьuses DrawMan;
const
W = 300;
H = 300;
Width = 100;
Height = 100;
procedure Draw(x, y, w, h: integer; n: byte);
begin
if (w > 1) and (h > 1) then
begin
PenUp();
ToPoint(x, y);
PenDown();
OnVector(w, 0);
OnVector(0, h);
OnVector(-w, 0);
OnVector(0, -h);
var w2 := w div 2;
var h2 := h div 2;
var xm := x - w2;
var ym := y - w2;
var xp := x + w;
var yp := y + w;
if n <> 1 then Draw(xm, ym, w2, h2, 3);
if n <> 2 then Draw(xp, ym, w2, h2, 4);
if n <> 3 then Draw(xp, yp, w2, h2, 1);
if n <> 4 then Draw(xm, yp, w2, h2, 2);
end;
end;
begin
Field(W, H);
Draw(W div 2 - Width div 2, H div 2 - Height div 2, Width, Height, 0);
end.
Фрактальные окружности
правитьuses GraphABC;
const
N = 5;
procedure RCircle(x, y, r: real):=Circle(Round(x), Round(y), Round(r));
procedure Draw(x, y, r: real);
begin
var r1 := r / 3;
RCircle(x, y, r);
RCircle(x, y, r1);
if r > 10 then
Draw(x, y, r1);
var angle := Pi / 2;
for var i := 0 to N - 1 do
begin
var r2 := 2 * r1;
var cx := x + r2 * Cos(angle);
var cy := y + r2 * Sin(angle);
RCircle(cx, cy, r1);
if r > 10 then
Draw(cx, cy, r1);
angle := angle + 2 * Pi / N;
end;
end;
begin
SetWindowSize(400, 400);
CenterWindow();
LockDrawing();
Draw(Window.Width div 2, Window.Height div 2, 180);
Redraw();
end.
Чертова лестница
правитьuses GraphABC;
procedure RLine(x, y, x1, y1: real):=Line(Round(x), Round(y), Round(x1), Round(y1));
function Distance(x, y, x1, y1: real):= Sqrt(Sqr(x1 - x) + Sqr(y1 - y));
procedure Draw(x, y, x1, y1: real);
begin
var dx := (x1 - x) / 3;
var my := (y1 + y) / 2;
RLine(x + dx, my, x + 2 * dx, my);
var x2 := x + 2 * dx;
if Distance(x, y, x1, y1) < 10 then
begin
RLine(x, y, x + dx, my);
RLine(x2, my, x1, y1);
end
else
begin
Draw(x, y, x + dx, my);
Draw(x2, my, x1, y1);
end;
end;
begin
SetWindowIsFixedSize(true);
var W := Window.Width;
var H := Window.Height;
SetSmoothingOff();
LockDrawing();
Draw(0, H, W, 0);
FloodFill(W - 1, H - 1, clBlack);
Redraw();
end.
Снежинка Коха
правитьuses GraphABC;
procedure RLine(x, y, x1, y1: real) := Line(Round(x), Round(y), Round(x1), Round(y1));
function GetAngle(x, y, x2, y2: real): real;
begin
var angle := Abs(RadToDeg(ArcTan((y2 - y) / (x2 - x))));
if (x2 = x) and (y2 = y) then
Result := 0
else
if x2 > x then
if y2 > y then Result := angle else Result := 360 - angle
else
if y2 > y then Result := 180 - angle else Result := 180 + angle;
end;
function Distance(x, y, x1, y1: real) := Sqrt(Sqr(x1 - x) + Sqr(y1 - y));
procedure Draw(x, y, x1, y1: real);
begin
if Distance(x, y, x1, y1) > 1 then
begin
var dx := (x1 - x) / 3;
var dy := (y1 - y) / 3;
var x2 := x + dx;
var y2 := y + dy;
var angle := DegToRad(GetAngle(x, y, x1, y1) - 60);
var r := Distance(x, y, x2, y2);
var x3 := x2 + r * Cos(angle);
var y3 := y2 + r * Sin(angle);
var x4 := x + dx * 2;
var y4 := y + dy * 2;
Draw(x, y, x2, y2);
Draw(x2, y2, x3, y3);
Draw(x3, y3, x4, y4);
Draw(x4, y4, x1, y1);
end
else
RLine(x, y, x1, y1);
end;
begin
SetWindowSize(500, 500);
SetWindowIsFixedSize(true);
ClearWindow(clBlack);
LockDrawing();
SetPenColor(clCyan);
Draw(100, 100, 400, 100);
Draw(400, 100, 400, 400);
Draw(400, 400, 100, 400);
Draw(100, 400, 100, 100);
Redraw();
end.
Кривая Минковского
правитьuses GraphABC;
procedure RLine(x, y, x1, y1: real) := Line(Round(x), Round(y), Round(x1), Round(y1));
function GetAngle(x, y, x2, y2: real): real;
begin
var angle := Abs(RadToDeg(ArcTan((y2 - y) / (x2 - x))));
if (x2 = x) and (y2 = y) then
Result := 0
else
if x2 > x then
if y2 > y then Result := angle else Result := 360 - angle
else
if y2 > y then Result := 180 - angle else Result := 180 + angle;
end;
function Distance(x, y, x1, y1: real) := Sqrt(Sqr(x1 - x) + Sqr(y1 - y));
procedure Draw(x, y, x1, y1: real);
begin
var r := Distance(x, y, x1, y1);
if r < 10 then
RLine(x, y, x1, y1)
else
begin
var angle := GetAngle(x, y, x1, y1);
var angleP := DegToRad(angle + 90);
var angleM := DegToRad(angle - 90);
r /= 4;
var dx := (x1 - x) / 4;
var dy := (y1 - y) / 4;
var xA := x + dx;
var yA := y + dy;
var xB := xA + dx;
var yB := yA + dy;
var xC := xB + dx;
var yC := yB + dy;
var x2 := xA + r * Cos(angleP);
var y2 := yA + r * Sin(angleP);
var x3 := xB + r * Cos(angleP);
var y3 := yB + r * Sin(angleP);
var x4 := xB + r * Cos(angleM);
var y4 := yB + r * Sin(angleM);
var x5 := xC + r * Cos(angleM);
var y5 := yC + r * Sin(angleM);
Draw(x, y, xA, yA);
Draw(xA, yA, x2, y2);
Draw(x2, y2, x3, y3);
Draw(x3, y3, xB, yB);
Draw(xB, yB, x4, y4);
Draw(x4, y4, x5, y5);
Draw(x5, y5, xC, yC);
Draw(xC, yC, x1, y1);
end;
end;
begin
Draw(100, 200, 400, 200);
end.
Цветок
правитьuses GraphABC;
const
Count = 3;
IncR = 30;
procedure Draw(cx, cy, x, y, a1, a2, r: real; iterations: integer);
begin
var delta := (a2 - a1) / Count;
var disp := delta / 2;
for var i := 0 to Count - 1 do
begin
var angle1 := a1 + delta * i + disp;
var angle2 := DegToRad(angle1);
var pX := cx + r * Cos(angle2);
var pY := cy + r * Sin(angle2);
Line(Round(x), Round(y), Round(pX), Round(pY));
if iterations > 1 then
Draw(cx, cy, pX, pY, angle1 - disp, angle1 + disp, r + IncR, iterations - 1);
end;
end;
begin
SetWindowIsFixedSize(true);
var W := Window.Width / 2;
var H := Window.Height / 2;
LockDrawing();
while true do
begin
for var i := 0 to 360 do
begin
ClearWindow();
Draw(W, H, W, H, 0, i, IncR, 6);
Redraw();
end;
for var i := 0 to 360 do
begin
ClearWindow();
Draw(W, H, W, H, i, 360, IncR, 6);
Redraw();
end;
end;
end.
Решения без рекурсии
правитьЯ не нашел примеров по написанию фракталов без рекурсии, поэтому решил их написать сам.
V-дерево
правитьuses GraphABC;
const
Angle = -Pi / 4;
type
EdgeData = auto class
A, B, C: Point;
R: integer;
end;
var
DataStack: Stack<EdgeData>;
function RotatePoint(pA: Point; r, angle: integer): Point;
begin
var angle2 := DegToRad(angle);
Result := new Point(Round(pA.X + r * Cos(angle2)), Round(pA.Y + r * Sin(angle2)));
end;
procedure PushTreePart(pB: Point; r: integer) := DataStack.Push(new EdgeData(RotatePoint(pB, r, -135), pB, RotatePoint(pB, r, -45), r));
function RIsBig(dt: EdgeData) := dt.R > 5;
begin
LockDrawing();
DataStack := new Stack<EdgeData>();
PushTreePart(new Point(300, 300), 200);
while DataStack.Count > 0 do
begin
var dt := DataStack.Pop();
Line(dt.A.X, dt.A.Y, dt.B.X, dt.B.Y);
Line(dt.B.X, dt.B.Y, dt.C.X, dt.C.Y);
if RIsBig(dt) then
begin
var r2 := dt.R div 2;
PushTreePart(dt.A, r2);
PushTreePart(dt.C, r2);
end;
end;
Redraw();
end.
Буква H
правитьuses GraphABC;
const
Angle = -Pi / 4;
type
EdgeData = auto class
A: Point;
L: integer;
end;
var
DataStack: Stack<EdgeData>;
procedure PushTreePart(pA: Point; l: integer):=DataStack.Push(new EdgeData(pA, l));
function RIsBig(dt: EdgeData):= dt.L > 10;
begin
LockDrawing();
DataStack := new Stack<EdgeData>();
PushTreePart(new Point(300, 220), 100);
while DataStack.Count > 0 do
begin
var dt := DataStack.Pop();
var pA := new Point(dt.A.X - dt.L, dt.A.Y - dt.L);
var pB := new Point(pA.X, dt.A.Y + dt.L);
var pC := new Point(dt.A.X + dt.L, dt.A.Y + dt.L);
var pD := new Point(pC.X, dt.A.Y - dt.L);
Line(pA.X, pA.Y, pB.X, pB.Y);
Line(pC.X, pC.Y, pD.X, pD.Y);
Line(pA.X, dt.A.Y, pC.X, dt.A.Y);
if RIsBig(dt) then
begin
var r2 := dt.L div 2;
PushTreePart(pA, r2);
PushTreePart(pB, r2);
PushTreePart(pC, r2);
PushTreePart(pD, r2);
end;
end;
Redraw();
end.
Двоичное дерево
правитьuses GraphABC;
const
Angle = -Pi / 4;
type
EdgeData = auto class
A, B, C: Point;
R: integer;
end;
var
DataStack: Stack<EdgeData>;
function RotatePoint(pA: Point; r, angle: integer): Point;
begin
var angle2 := DegToRad(angle);
Result := new Point(Round(pA.X + r * Cos(angle2)), Round(pA.Y + r * Sin(angle2)));
end;
procedure PushTreePart(pB: Point; r: integer):=DataStack.Push(new EdgeData(RotatePoint(pB, r, -135), pB, RotatePoint(pB, r, -45), r));
function RIsBig(dt: EdgeData):= dt.R > 5;
begin
LockDrawing();
DataStack := new Stack<EdgeData>();
PushTreePart(new Point(300, 300), 200);
while DataStack.Count > 0 do
begin
var dt := DataStack.Pop();
var pD := new Point((dt.A.X + dt.C.X) div 2, (dt.A.Y + dt.C.Y) div 2);
Line(dt.A.X, dt.A.Y, dt.C.X, dt.C.Y);
Line(pD.X, pD.Y, dt.B.X, dt.B.Y);
if RIsBig(dt) then
begin
var r2 := dt.R div 2;
PushTreePart(dt.A, r2);
PushTreePart(dt.C, r2);
end;
end;
Redraw();
end.