Викиучебник

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

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

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

Все программы, код которых выложен здесь, являются работоспособными. На момент написания программ использовалась среда PascalABC.Net 3.0.

Фрактальные многоугольники

править

  

uses ABCObjects, GraphABC;
const
  Verts = 6;
  C1 = clRed;
  C2 = clCyan;

procedure FractalCreate(x, y, s: real; n: integer; a: byte);
begin
  if s > 3 then
  begin
    if n mod 2 = 0 then
      new RegularPolygonABC(Round(x), Round(y), Round(s), Verts, C1)
    else
      new RegularPolygonABC(Round(x), Round(y), Round(s), Verts, C2);
    
    var s2 := s * 1.5;
    s := s / 2;
    Inc(n);
    if a <> 1 then FractalCreate(x + s2, y, s, n, 3);
    if a <> 2 then FractalCreate(x, y + s2, s, n, 4);
    if a <> 3 then FractalCreate(x - s2, y, s, n, 1);
    if a <> 4 then FractalCreate(x, y - s2, s, n, 2);
  end;
end;

var
  BG: RectangleABC;

begin
  SetWindowIsFixedSize(true);
  SetWindowSize(500, 500);
  
  var W := Window.Width;
  var H := Window.Height;
  
  BG := new RectangleABC(0, 0, W, H, clBlack);
  FractalCreate(W / 2, H / 2, 80, 0, 0);
  
  LockDrawingObjects();
  while true do
  begin
    for var i := 0 to Objects.Count - 1 do
    begin
      if Objects[i] <> BG then
      begin
        var obj := Objects[i] as RegularPolygonABC;
        if obj.Color = C1 then
          obj.Angle := obj.Angle + 1
        else
          obj.Angle := obj.Angle - 1;
      end;
    end;
    RedrawObjects();
  end;
end.

{Адаптировано под PascalABC 3.0.1.35.}
uses ABCObjects, GraphABC;
const
  Verts = 6;
  C1 = clRed;
  C2 = clOlive;

procedure FractalCreate(x, y, s: real; n: integer; a: byte);
var
  s2: real;

begin
  if s > 3 then
  begin
    if n mod 2 = 0 then
      RegularPolygonABC.Create(Round(x), Round(y), Round(s), Verts, C1)
    else
      RegularPolygonABC.Create(Round(x), Round(y), Round(s), Verts, C2);

    s2 := s * 1.5;
    s := s / 2;
    Inc(n);
    if a <> 1 then FractalCreate(x + s2, y, s, n, 3);
    if a <> 2 then FractalCreate(x, y + s2, s, n, 4);
    if a <> 3 then FractalCreate(x - s2, y, s, n, 1);
    if a <> 4 then FractalCreate(x, y - s2, s, n, 2);
  end;
end;

var
  BG: RectangleABC;
  W, H: integer;

begin
  W := WindowWidth();
  H := WindowHeight();

  BG := RectangleABC.Create(0, 0, W, H, clBlack);
  FractalCreate(W / 2, H / 2, 80, 0, 0);
end.

Новогодний фрактал

править

  

uses ABCObjects, GraphABC;

procedure FractalCreate(x, y, w: real);
begin
  if w > 8 then
  begin
    var wh := w / 3;
    for var i := 0 to 2 do 
      for var j := 0 to 2 do
        if (i = 1) or (j = 1) then 
          FractalCreate(x + wh * i, y + wh * j, wh); 
  end
  else
    new RectangleABC(Round(x), Round(y), Round(w), Round(w), RGB(0, Random(255), 0))
end;

var
  BG: RectangleABC;

begin
  SetWindowIsFixedSize(true);
  SetWindowSize(500, 500);
  
  var W := Window.Width;
  BG := new RectangleABC(0, 0, W, W, clBlack);
  FractalCreate(0, 0, W);
end.

{Адаптировано под PascalABC 3.0.1.35.}
uses ABCObjects, GraphABC;

procedure FractalCreate(x, y, w: real);
var
  wh: real;
  i, j: integer;

begin
  if w > 8 then
  begin
    wh := w / 3;
    for i := 0 to 2 do
      for j := 0 to 2 do
        if (i = 1) or (j = 1) then
          FractalCreate(x + wh * i, y + wh * j, wh);
  end
  else
    RectangleABC.Create(Round(x), Round(y), Round(w), Round(w), RGB(0, Random(255), 0))
end;

var
  BG: RectangleABC;
  W: integer;

begin
  SetWindowWidth(500);
  SetWindowHeight(500);
  
  W := WindowWidth();
  BG := RectangleABC.Create(0, 0, W, W, clBlack);
  FractalCreate(0, 0, W);
end.

Мозаика из треугольника Серпинского

править

  

uses ABCObjects, GraphABC;
const
  StarR = 5;
  N = 4;

procedure CreateFractal(x, y, x1, y1, x2, y2: real; iterations: integer);
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;
  
  var mxA := (x + mx1 + mx3) / 3;
  var myA := (y + my1 + my3) / 3;
  var mxB := (mx1 + x1 + mx2) / 3;
  var myB := (my1 + y1 + my2) / 3;
  var mxC := (mx2 + x2 + mx3) / 3;
  var myC := (my2 + y2 + my3) / 3;
  
  if iterations > 0 then
  begin
    Dec(iterations);
    CreateFractal(x, y, mx1, my1, mx3, my3, iterations);
    CreateFractal(mx1, my1, x1, y1, mx2, my2, iterations);
    CreateFractal(mx3, my3, mx2, my2, x2, y2, iterations);
  end
  else
  begin
    var r2 := Round(StarR * 0.4);
    var A := new StarABC(Round(mxA), Round(myA), StarR, r2, N, clRandom());
    A.Bordered := false;
    var B := new StarABC(Round(mxB), Round(myB), StarR, r2, N, clRandom());
    B.Bordered := false;
    var C := new StarABC(Round(mxC), Round(myC), StarR, r2, N, clRandom());
    C.Bordered := false;
  end;
end;

begin
  FloodFill(1, 1, clBlack);
  CreateFractal(100, 500, 100, 100, 500, 500, 5);
  
  LockDrawingObjects();
  while true do
  begin
    for var i := 0 to Objects.Count - 1 do
      Objects[i].Color := clRandom();
    RedrawObjects();
    Sleep(100);
  end;
end.

Ковер Серпинского

править

  

uses ABCObjects, GraphABC;

procedure FractalCreate(x, y, w: real);
begin
  if w > 8 then
  begin
    var wh := w / 3;
    for var i := 0 to 2 do 
      for var j := 0 to 2 do 
        if (i <> 1) or (j <> 1) then 
          FractalCreate(x + wh * i, y + wh * j, wh); 
  end
  else
    new RectangleABC(Round(x), Round(y), Round(w), Round(w), clRandom())
end;

var
  BG: RectangleABC;

begin
  SetWindowIsFixedSize(true);
  SetWindowSize(500, 500);
  
  var W := Window.Width;
  
  BG := new RectangleABC(0, 0, W, W, clBlack);
  FractalCreate(0, 0, W);
end.
Источник — https://ru.wikibooks.org/w/index.php?title=Книга_программиста/Фрактальная_графика_в_ABCObjects&oldid=163425