Викиучебник

Книга программиста/Книга фракталов

< Книга программиста

К оглавлению | Назад | Вперёд

Все программы, код которых выложен здесь, являются работоспособными. На момент написания программ использовалась среда 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

править

Рекурсивные решения

править

Глаз

править 
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-дерево

править

  

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.

Бинарное дерево

править

  

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.

Вращающиеся треугольники Серпинского

править

  

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.

Гребень Кантора

править

  

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.

Карта высот

править

  

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.

Комок шерсти

править

  

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.

Папоротники

править

Папоротник

править

  

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.

Снежинка

править

  

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.

Толстое дерево Пифагора

править

  

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.

Толстое наклоненное дерево Пифагора

править

  

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.
Источник — https://ru.wikibooks.org/w/index.php?title=Книга_программиста/Книга_фракталов&oldid=163481