Форум программистов, компьютерный форум, киберфорум
Pascal ABC
Форум программистов и сисадминов Киберфорум > Форум программистов > Pascal (Паскаль) > Pascal ABC
Войти
Регистрация
Восстановить пароль
Блоги Сообщество Поиск Заказать работу  
 
Рейтинг 4.55/508: Рейтинг темы: голосов - 508, средняя оценка - 4.55
Почетный модератор
 Аватар для ildwine
6201 / 2954 / 1300
Регистрация: 04.03.2013
Сообщений: 5,795
Записей в блоге: 1

Фракталы

03.11.2013, 22:50. Показов 96773. Ответов 11
Метки дерево пифагора, ковер серпинского, кривая гильберта, кривая госпера, кривая дракона, кривая коха, множество мандельброта, папоротник, снежинка коха, треугольник серпинского, фрактал (Все метки)
Студворк — интернет-сервис помощи студентам
Решил создать подобную тему, ибо она довольно актуальна...

Фрактал - геометрическая фигура, обладающая свойством самоподобия, то есть составленная из нескольких частей, каждая из которых подобна всей фигуре целиком. В математике под фракталами понимают множества точек в евклидовом пространстве, имеющие дробную метрическую размерность (в смысле Минковского или Хаусдорфа), либо метрическую размерность, отличную от топологической.

Решил выложить свою подборку известных фракталов (адаптированных под Pascal ABC / Pascal ABC.NET):

1. Кривая Госпера


Кликните здесь для просмотра всего текста
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44

Program Gosper_Curve;
 
Uses CRT, GraphABC;
 
Procedure Draw(x, y, l, u : Real; t, q : Integer);
 
Procedure Draw2(Var x, y: Real; l, u : Real; t, q : Integer);
 
Begin
     Draw(x, y, l, u, t, q);
       x := x + l*cos(u);
       y := y - l*sin(u)
End;
 
Begin
     If t > 0 Then
     Begin
          If q = 1 Then
          Begin
               x := x + l*cos(u);
                     y := y - l*sin(u);
                     u := u + pi
          End;
          u := u - 2*pi/19;
              l := l/sqrt(7);
              Draw2(x, y, l, u, t-1, 0);
              Draw2(x, y, l, u+pi/3, t-1, 1);
              Draw2(x, y, l, u+pi, t-1, 1);
          Draw2(x, y, l, u+2*pi/3, t-1, 0);
          Draw2(x, y, l, u, t-1, 0);
          Draw2(x, y, l, u, t-1, 0);
          Draw2(x, y, l, u-pi/3, t-1, 1)
     End
     Else
         Line(Round(x), Round(y), Round(x + cos(u)*l), Round(y -sin(u)*l))
     End;
 
Begin
     SetWindowCaption('Фракталы: Кривая Госпера');
     SetWindowSize(650,500);
     ClearWindow;
     Draw(100, 355, 400, 0, 4, 0);
     Repeat Until KeyPressed
End.



2. Дерево Пифагора


Кликните здесь для просмотра всего текста
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32

uses CRT, GraphABC;
 
Procedure Rect(x1, y1, l: Integer; a1: Real);
Begin
     MoveTo(x1, y1);
       LineTo(x1 + Round(l * cos(a1)), y1 - Round(l * sin(a1)));
       LineTo(x1 + Round(l * sqrt(2) * cos(a1 + pi/4)),
         y1 - Round(l * sqrt(2) * sin(a1 + pi/4)));
       LineTo(x1 + Round(l * cos(a1 + pi/2)), y1 - Round(l * sin(a1 + pi/2)));
       LineTo(x1, y1)
End;
 
Procedure Draw(x, y, l, a: Real);
Begin
     If l > 4 Then
     Begin
              Rect(Round(x), Round(y), Round(l), a);
              Draw(x - l*sin(a), y - l * cos(a), l / sqrt(2), a + pi / 4);
              Draw(
                     x - l * sin(a) + l / sqrt(2) * cos(a + pi/4),
                     y - l * cos(a) - l / sqrt(2) * sin(a + pi/4),
                     l / sqrt(2),
               a - pi/4)
     End
End;
Begin
     SetWindowCaption('Фракталы: Дерево Пифагора');
     SetWindowSize(730,500);
     ClearWindow;
     Draw(280, 460, 100, 0);
       Repeat Until KeyPressed
End.



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


Кликните здесь для просмотра всего текста
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34

Uses CRT, GraphABC;
Const Z = 6; {Глубина фрактала}
Var
   x1, y1, x2, y2, x3, y3: Real;
 
Procedure Serp(x1, y1, x2, y2: Real; n: Integer);
Var
   x1n, y1n, x2n, y2n: Real;
Begin
     If  n > 0  Then
     Begin
          x1n := 2*x1/3 + x2 / 3;
          x2n := x1/3 + 2*x2 / 3;
          y1n := 2*y1/3 + y2 / 3;
          y2n := y1/3+2*y2 / 3;
          Rectangle(Round(x1n), Round(y1n), Round(x2n), Round(y2n));
          Serp(x1, y1, x1n, y1n, n-1);
          Serp(x1n, y1, x2n, y1n, n-1);
          Serp(x2n, y1, x2, y1n, n-1);
          Serp(x1, y1n, x1n, y2n, n-1);
          Serp(x2n, y1n, x2, y2n, n-1);
          Serp(x1, y2n, x1n, y2, n-1);
          Serp(x1n, y2n, x2n, y2, n-1);
          Serp(x2n, y2n, x2, y2, n-1)
     End
End;
Begin
     SetWindowCaption('Фракталы: Ковер Серпинского');
     SetWindowSize(500,500);
     ClearWindow;
     Rectangle(20, 20, 460, 460);
     Serp(20, 20, 460, 460, Z);
     Repeat Until Keypressed
End.



4. Треугольник Серпинского


Кликните здесь для просмотра всего текста
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36

Uses CRT, GraphABC;
Const Z = 7; {Глубина фрактала}
 
Procedure tr(x1, y1, x2, y2, x3, y3: Real);
Begin
     Line(Round(x1), Round(y1), Round(x2), Round(y2));
       Line(Round(x2), Round(y2), Round(x3), Round(y3));
       Line(Round(x3), Round(y3), Round(x1), Round(y1));
End;
 
Procedure draw(x1, y1, x2, y2, x3, y3: Real; n: Integer);
Var
   x1n, y1n, x2n, y2n, x3n, y3n : Real;
Begin
     If  n > 0  Then
     Begin
          x1n := (x1 + x2) / 2;
          y1n := (y1 + y2) / 2;
          x2n := (x2 + x3) / 2;
          y2n := (y2 + y3) / 2;
          x3n := (x3 + x1) / 2;
          y3n := (y3 + y1) / 2;
          tr(x1n, y1n, x2n, y2n, x3n, y3n);
          draw(x1, y1, x1n, y1n, x3n, y3n, n - 1);
          draw(x2, y2, x1n, y1n, x2n, y2n, n - 1);
          draw(x3, y3, x2n, y2n, x3n, y3n, n - 1)
     End
End;
Begin
     SetWindowCaption('Фракталы: Треугольник Серпинского');
     SetWindowSize(650,500);
     ClearWindow;
     tr(320,10,600,470,40,470);
       draw(320,10,600,470,40,470,Z);
     Repeat Until KeyPressed
End.



5. Кривая Гильберта


Кликните здесь для просмотра всего текста
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82

Uses Crt, GraphABC;
Const
     u = 10;
       p = 5;
Var
   i: Integer;
 
{В PascalABC нет функции LineRel - искусственно реализуем ее через LineTo}
Procedure LineRel(dx, dy : Integer);
Begin
     LineTo(PenX+dx, PenY+dy)
End;
 
Procedure a(i: Integer); forward;
Procedure b(i: Integer); forward;
Procedure c(i: Integer); forward;
Procedure d(i: Integer); forward;
 
Procedure a(i: Integer);
Begin
     If i > 0 Then
     Begin
          d(i - 1);
          LineRel( + u, 0);
              a(i - 1);
              LineRel(0, u);
              a(i - 1);
              LineRel(-u, 0);
              c(i - 1)
     End
End;
 
Procedure b(i: integer);
Begin
     If i > 0 Then
     Begin
          c(i - 1);
              LineRel(-u, 0);
              b(i - 1);
              LineRel(0, -u);
              b(i - 1);
              LineRel(u, 0);
              d(i - 1)
     End
End;
 
Procedure c(i: integer);
Begin
     If i > 0 Then
     Begin
          b(i - 1);
          LineRel(0, -u);
              c(i - 1);
              LineRel(-u, 0);
              c(i - 1);
              LineRel(0, u);
              a(i - 1)
     End
End;
 
Procedure d(i: integer);
Begin
     If i > 0 Then
     Begin
          a(i - 1);
              LineRel(0, u);
              d(i - 1);
              LineRel(u, 0);
              d(i - 1);
              LineRel(0, -u);
              b(i - 1)
     End
End;
{Main Program}
Begin
     SetWindowCaption('Фракталы: Кривая Гильберта');
     SetWindowSize(500,500);
     ClearWindow;
     MoveTo(100, 100);
       a(p);
     Repeat until KeyPressed
End.



6. Снежинка Коха


Кликните здесь для просмотра всего текста
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33

uses CRT, GraphABC;
 
procedure Draw(x, y, l, u : Real; t : Integer);
 
procedure Draw2(Var x, y: Real; l, u : Real; t : Integer);
 
begin
    Draw(x, y, l, u, t);
    x := x + l*cos(u);
    y := y - l*sin(u);
end;
 
begin
    if t > 0 then
    begin
        l := l/3;
        Draw2(x, y, l, u, t-1);
        Draw2(x, y, l, u+pi/3, t-1);
        Draw2(x, y, l, u-pi/3, t-1);
        Draw2(x, y, l, u, t-1);
    end
    else
        Line(Round(x), Round(y), Round(x+cos(u)*l), Round(y-sin(u)*l))
end;
 
begin
  SetWindowSize(425,500);
  SetWindowCaption('Фракталы: Снежинка Коха');
    Draw(10, 354, 400, pi/3, 4);
    Draw(410, 354, 400, pi, 4);
    Draw(210, 8, 400, -pi/3, 4);
 Repeat Until KeyPressed
end.



7. Множество Мандельброта 1


Кликните здесь для просмотра всего текста
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32

uses GraphABC;
 
const
  n=255;
  max=10;
 
var
  x,y,x1,y1,cx,cy: real;
  i,ix,iy: integer;
// z=z^2+c
begin
  SetWindowSize(400,300);
  SetWindowCaption('Фракталы: множество Мандельброта');
  for ix:=0 to WindowWidth-1 do
  for iy:=0 to WindowHeight-1 do
  begin
    x:=0;
    y:=0;
    cx:=0.002*(ix-720);
    cy:=0.002*(iy-150);
    for i:=1 to n do
    begin
      x1:=x*x-y*y+cx;
      y1:=2*x*y+cy;
      if (x1>max) or (y1>max) then break;
      x:=x1;
      y:=y1;
    end;
    if i>=n then SetPixel(ix,iy,clRed)
      else SetPixel(ix,iy,RGB(255,255-i,255-i));
  end;
end.



8. Множество Мандельброта 2

Кликните здесь для просмотра всего текста
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32

uses GraphABC;
 
const
  n=255;
  max=10;
 
var
  x,y,x1,y1,cx,cy: real;
  i,ix,iy: integer;
// z=z^2+c
begin
  SetWindowSize(600,600);
  SetWindowCaption('Фракталы: множество Мандельброта');
  for ix:=0 to WindowWidth-1 do
  for iy:=0 to WindowHeight-1 do
  begin
    x:=0;
    y:=0;
    cx:=0.005*(ix-365);
    cy:=0.005*(iy-300);
    for i:=1 to n do
    begin
      x1:=x*x-y*y+cx;
      y1:=2*x*y+cy;
      if (x1>max) or (y1>max) then break;
      x:=x1;
      y:=y1;
    end;
    if i>=n then SetPixel(ix,iy,clRed)
      else SetPixel(ix,iy,RGB(255,255-i,255-i));
  end;
end.
37
IT_Exp
Эксперт
34794 / 4073 / 2104
Регистрация: 17.06.2006
Сообщений: 32,602
Блог
 03.11.2013, 22:50
Ответы с готовыми решениями:

фракталы
помогите пожалуйста! uses Crt,GraphABC; var Gd,Gm,dL,du: integer; procedure VECTOR( L, ugol: integer); {Отрезок длиной L...

Рекурсия и фракталы
Получить изображение (рис 20.2) с помощью рекурсивной процедуры, считая заданный радиус базового круга, коефициент смещения круга...

Рекурсия и фракталы
Помогите пожалуйста с этой задачей: получить с помощью рекурсивной процедуры изображение Т-образного дерева со случайным расположением...

11
Почетный модератор
 Аватар для ildwine
6201 / 2954 / 1300
Регистрация: 04.03.2013
Сообщений: 5,795
Записей в блоге: 1
05.11.2013, 18:10  [ТС]
9. Множество Апполона


Кликните здесь для просмотра всего текста
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51

uses CRT, GraphABC;
var 
    x, y, a, b: Real;
    r: Real;
    a0, b0: Real;
    a1, b1, a2, b2: Real;
    f1x, f1y: Real;
    x1, y1: Real;
    
begin
    setwindowcaption('Фракталы: Множество Апполона');
  setwindowsize(650, 500);
  clearwindow;
    x := 0.2;
    y := 0.3;
    a := 0;
    b := 0;
    Randomize;
    r := Sqrt(3);
    while not KeyPressed do 
    begin
        a := Random;
        a0 := 3*(1+r-x)/(sqr(1+r-x)+sqr(y))-(1+r)/(2+r);
        b0 := 3*y/(sqr(1+r-x)+sqr(y));
        if (a <= 1/3) and (a>=0) then 
        begin
            x1 := a0;
            y1 := b0;
        end;
        a1 := -1/2;
        b1 := r/2;
        a2 := -1/2;
        b2 := -r/2;
        f1x := a0/(sqr(a0)+sqr(b0));
        f1y := -b0/(sqr(a0)+sqr(b0));
        if (a <= 2/3) and (a > 1/3) then 
        begin
            x1 := f1x*a1-f1y*b1;
            y1 := f1x*b1+f1y*a1;
        end;
        if (a <= 3/3) and (a > 2/3) then 
        begin
            x1 := f1x*a2-f1y*b2;
            y1 := f1x*b2+f1y*a2;
        end;
        x := x1;
        y := y1;
        PutPixel(320+Round(x*50), 240+Round(y*50), clRed);
    end;
    ReadKey 
end.
18
Почетный модератор
 Аватар для ildwine
6201 / 2954 / 1300
Регистрация: 04.03.2013
Сообщений: 5,795
Записей в блоге: 1
16.11.2013, 21:08  [ТС]
10. Ледяной фрактал


Кликните здесь для просмотра всего текста
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32

uses CRT, GraphABC;
 
procedure Draw(x, y, l, u : Real; t : Integer);
 
procedure Draw2(Var x, y: Real; l, u : Real; t : Integer);
begin
    Draw(x, y, l, u, t);
    x := x + l*cos(u);
    y := y - l*sin(u);
end;
begin
    if t > 0 then
    begin
        l := l*0.5;
        Draw2(x, y, l, u, t-1);
        Draw2(x, y, l*0.8, u+pi/2, t-1);
        Draw2(x, y, l*0.8, u-pi/2, t-1);
        Draw2(x, y, l, u, t-1)
    end
    else
        Line(Round(x), Round(y), Round(x+cos(u)*l), Round(y-sin(u)*l))
end;
 
begin
  SetWindowCaption('Фракталы: Ледяной фрактал 1');
  SetWindowSize(420,420);
    Draw(410, 10, 400, -pi, 5);
    Draw(10, 410, 400, 0, 5);
    Draw(10, 10, 400, -pi/2, 5);
    Draw(410, 410, 400, pi/2, 5);
    ReadKey
end.



11. Ледяной фрактал (другой вариант)


Кликните здесь для просмотра всего текста
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34

uses CRT, GraphABC;
 
procedure Draw(x, y, l, u : Real; t : Integer);
procedure Draw2(Var x, y: Real; l, u : Real; t : Integer);
 
begin
    Draw(x, y, l, u, t);
    x := x + l*cos(u);
    y := y - l*sin(u);
end;
 
begin
    if t > 0 then
    begin
        l := l*0.5;
        Draw2(x, y, l, u, t-1);
        Draw2(x, y, l*0.45, u+2*pi/3, t-1);
        Draw2(x, y, l*0.45, u-pi/3, t-1);
        Draw2(x, y, l*0.45, u+pi/3, t-1);
        Draw2(x, y, l*0.45, u-2*pi/3, t-1);
        Draw2(x, y, l, u, t-1)
    end
    else
        Line(Round(x), Round(y), Round(x+cos(u)*l), Round(y-sin(u)*l))
end;
 
begin
  SetWindowCaption('Фракталы: Ледяной фрактал 2');
  SetWindowSize(420,420);
    Draw(210, 8, 400, -2*pi/3, 3);
    Draw(10, 354, 400, 0, 3);
    Draw(410, 354, 400, 2*pi/3, 3);
    ReadKey
end.
14
Почетный модератор
 Аватар для ildwine
6201 / 2954 / 1300
Регистрация: 04.03.2013
Сообщений: 5,795
Записей в блоге: 1
23.01.2014, 08:48  [ТС]
12. Вариация на тему "Кривая Коха"


Кликните здесь для просмотра всего текста
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56

uses graphABC,crt;
procedure koh(x1,y1,x2,y2,x3,y3,k:integer);
var xxs,yys,xx1,yy1,xx2,yy2,xx3,yy3:integer;
al:real;
begin
 if k>0 then
 begin
 {t1,t2}
 xx1:=round((2*x1+x2)/3);
 yy1:=round((2*y1+y2)/3);
 xx2:=round((2*x2+x1)/3);
 yy2:=round((2*y2+y1)/3);
 {t3}
 xxs:=round((x1+x2)/2);
 yys:=round((y1+y2)/2);
 xx3:=abs(round((4*xxs-x3)/3));
 yy3:=abs(round((4*yys-y3)/3));
 {risuem 1-3,3-2}
 SetpenColor(clBlack);
 Setpenwidth(1);
 MoveTo(xx1,yy1);
 LineTo(xx3,yy3);
 LineTo(xx2,yy2);
 koh(xx1,yy1,xx3,yy3,xx2,yy2,k-1);
 koh(xx3,yy3,xx2,yy2,xx1,yy1,k-1);
 koh(x1,y1,xx1,yy1,round((2*x1+x3)/3),round((2*y1+y3)/3),k-1);
 koh(x2,y2,xx2,yy2,round((2*x2+x3)/3),round((2*y2+y3)/3),k-1);
 end;
end;
 
var n,xc,yc,x1,y1,x2,y2,x3,y3,a:integer;
    h:real;
begin
repeat
write('Глубина рекурсии [1..8] n=');
read(n);
until n in [1..8];
hidecursor;
xc:=windowwidth div 2;{centr ekrana}
yc:=windowheight div 2;
a:=300;
h:=a*sin(pi/3);{vysota treugilnika}
x1:=xc-a div 2;
y1:=yc+round(h/3);
x2:=xc;
y2:=yc-round(2*h/3);
x3:=xc+a div 2;
y3:=y1;
Moveto(x1,y1);
LineTo(x2,y2);
LineTo(x3,y3);
LineTo(x1,y1);
koh(x1,y1,x2,y2,x3,y3,n);
koh(x2,y2,x3,y3,x1,y1,n);
koh(x3,y3,x1,y1,x2,y2,n);
end.


13. Что-то наподобие снежинки


Кликните здесь для просмотра всего текста
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22

uses graphABC;
const k=8;
var x,y:integer;
procedure snow (x0,y0,r,n:integer);
const t=2*pi/k;
var i,x,y:integer;
begin
 for i:=1 to k do
  begin
   x:=x0+round(r*cos(i*t));
   y:=y0-round(r*sin(i*t));
   line(x0,y0,x,y);
   if n>1 then snow(x,y,r div 5,n-1);
  end;
end;
begin
SetWindowSize(500,500);
SetWindowCaption('Фракталы: что-то похожее на снежинку');
x:=windowwidth div 2;
y:=windowheight div 2;
snow(x,y,180,4);
end.


Прислано модератором: Puporev
9
Почетный модератор
 Аватар для ildwine
6201 / 2954 / 1300
Регистрация: 04.03.2013
Сообщений: 5,795
Записей в блоге: 1
08.11.2014, 16:42  [ТС]
14. Круговой фрактал



Кликните здесь для просмотра всего текста
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22

uses GraphABC;
procedure Draw (x,y,size:integer);
 var min,m,n:integer;
     i,s1,s2:integer;
 begin
  min:=1;m:=6;n:=3;
  if size > min 
   then
    begin
     s1:=round(size/n );
     s2:=round(size*(n-1)/n );
     for i:= 1 to  m do
      Draw ( x - round ( s2*sin ( 2*pi/m*i ) ) , y + round ( s2*cos ( 2*pi/m*i ) ) , s1 );
     Draw ( x, y, s1 );
    end;
  ellipse ( x - size, y - size, x + size, y + size );
 end; 
begin
  SetBrushStyle(bsclear);
  SetWindowTitle('Фракталы: круговой фрактал');
  Draw(320,240,200);
end.


Прислал форумчанин vint-81
10
Почетный модератор
 Аватар для ildwine
6201 / 2954 / 1300
Регистрация: 04.03.2013
Сообщений: 5,795
Записей в блоге: 1
24.11.2014, 13:02  [ТС]
15. Отпечаток пальца


Кликните здесь для просмотра всего текста
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32

uses GraphABC;
 
const
  n=255;
  max=10;
 
var
  x,y,x1,y1,cx,cy: real;
  i,ix,iy: integer;
// z=z^2+c
begin
  SetWindowCaption('Фракталы: отпечаток пальца');
  SetWindowSize(400,300);
  cx:=0.1;
  cy:=+0.17;
  for ix:=0 to WindowWidth-1 do
  for iy:=0 to WindowHeight-1 do
  begin
    x:=0.005*(ix-200);
    y:=0.005*(iy-150);
    for i:=1 to n do
    begin
      x1:=x*x-y*y+cx;
      y1:=x*y+1.4*y+cy;
      if (x1>max) or (y1>max) then break;
      x:=x1;
      y:=y1;
    end;
    if i>=n then SetPixel(ix,iy,clRed)
      else SetPixel(ix,iy,RGB(255,255-i,255-i));
  end;
end.



16. Папоротник


Кликните здесь для просмотра всего текста
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33

uses GraphABC,Utils;
 
const
  n=255;
  max=10;
 
var
  x,y,x1,y1,cx,cy: real;
  i,ix,iy: integer;
// z=z^2+c
begin
  SetWindowCaption('Фракталы: папоротник');
  SetWindowSize(300,300);
  cx:=0.251;
  cy:=0.95;
  for ix:=0 to WindowWidth-1 do
  for iy:=0 to WindowHeight-1 do
  begin
    x:=0.001*(ix-200);
    y:=0.001*(iy-150);
    for i:=1 to n do
    begin
      x1:=0.5*x*x-0.88*y*y+cx;
      y1:=x*y+cy;
      if (x1>max) or (y1>max) then break;
      x:=x1;
      y:=y1;
    end;
    if i>=n then SetPixel(ix,iy,clGreen)
      else SetPixel(ix,iy,RGB(255-i,255,255-i));
  end;
  writeln('Время расчета = ',Milliseconds/1000,' с');
end.



17. Кривая Дракона


Кликните здесь для просмотра всего текста
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24

Uses CRT, GraphABC;
Const Z= 12; {Glubina Fraktala}
Procedure ris(x1,y1,x2,y2,k:integer);
Var xn,yn:integer;
Begin
     If k>0 Then
     Begin
          xn:=(x1+x2) div 2 +(y2-y1) div 2;
          yn:=(y1+y2) div 2 -(x2-x1) div 2;
          ris(x1,y1,xn,yn,k-1);
          ris(x2,y2,xn,yn,k-1)
     End
     Else
          line(x1,y1,x2,y2)
 
End;
{Main program}
Begin
     SetWindowCaption('Фракталы: Кривая Дракона');
     SetWindowSize(700,512);
     ClearWindow;
     ris(200,300,500,300,Z);
     Repeat Until KeyPressed
End.



18. Фрактальное дерево


Кликните здесь для просмотра всего текста
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45

Uses GraphABC;
Procedure Tree(x, y: Integer; a: Real; l: Integer);
Var
   x1, y1: Integer;
   p, s : Integer;
   i : Integer;
   a1 : Real;   
Begin
     If l < 8 Then
     exit;
     x1 := Round(x + l*cos(a));
     y1 := Round(y + l*sin(a));
     If l > 100 Then p := 100 Else p := l;
     If p < 40 Then
     Begin
          {Генерация листьев}
          If Random > 0.5 Then SetPenColor(clLime) Else SetPenColor(clGreen);
          For i := 0 To 3 Do
              Line(x + i, y, x1, y1)
     End
     Else
     Begin
          {Генерация веток}
          SetPenColor(clBrown);
          For i := 0 To (p div 6) Do
              Line(x + i - (p div 12), y, x1, y1)
     End;
     {Следующие ветки}
     For i := 0 To 9 - Random(9) Do
     Begin
          s := Random(l - l div 6) + (l div 6);
          a1 := a + 1.6 * (0.5 - Random); {Угол наклона веток}
          x1 := Round(x + s * cos(a));
          y1 := Round(y + s * sin(a));
          Tree(x1, y1, a1, p - 5 - Random(30)) {Чем меньше вычитаем, тем пышнее дерево}
     End
End;
 
{Основная программа}
Begin
  SetWindowCaption('Фрактальное дерево');
  SetWindowSize(700,600);
  Randomize;
  Tree(350, 580, 3*pi/2, 200)    
End.



19. Кривая Коха (именно кривая, а не снежинка)


Кликните здесь для просмотра всего текста
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40

uses CRT, GraphABC;
Const
     Z = 50000;
Procedure Draw;
Var
   t, x, y, p : Real;
     k : LongInt;
     mx, my, rad : Integer;
Begin
     mx := 10;
       my := 250;
       rad :=600;
       Randomize;
       x := 0.0;
       y := 0.0;
       For k := 1 To Z do
       Begin
         p := Random;
         t := x;
         If p <= 1/2 Then
         Begin
              x :=  1/2 * x + 1/(2*sqrt(3)) * y;
              y :=  1/(2*sqrt(3)) * t - 1/2 * y;
         End
         Else
         Begin
              x :=  1/2 * x - 1/(2*sqrt(3)) * y +1/2;
              y :=  -1/(2*sqrt(3)) * t - 1/2 * y + 1/(2*sqrt(3))
         End;
         PutPixel(mx + Round(rad * x), my - Round(rad * y), clRed)
    End
End;
{main program}
Begin
     SetWindowCaption('Фракталы: Кривая Коха');
     SetWindowSize(650,400);
     ClearWindow;
     Draw;
     Repeat Until KeyPressed
End.



20. Дерево Пифагора (другой вариант)


Кликните здесь для просмотра всего текста
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28

uses GraphABC;
const
    max = 3;
  
procedure LineTo1(x, y : Integer; l, u : Real);
begin
    Line(x, y, Round(x + l * cos(u)), Round(y - l * sin(u)));
end;
 
procedure Draw(x, y : Integer; l, u : real);
begin   
    if l > max then
    begin
        l := l * 0.7;
        LineTo1(x, y, l, u);
        x := Round(x + l * cos(u));
        y := Round(y - l * sin(u));
        Draw(x, y, l, u + pi / 4); {Угол поворота 1}
        Draw(x, y, l, u - pi / 6); {Угол поворота 2}
    end;
end;
 
begin   
   SetWindowCaption('Фракталы: Дерево Пифагора');
   SetWindowSize(730,500);
   ClearWindow;
   Draw(320, 460, 200, pi/2)   
end.


21. Еще один вариант папоротника


Кликните здесь для просмотра всего текста
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29

uses GraphABC;
const
    min = 1;
    
procedure lineto1(x, y : Integer; l, u : real);
begin
    Line(x, y, Round(x + l * cos(u)), Round(y - l * sin(u)));
end;
 
procedure Draw(x, y : Integer; l, u : real);
 
begin
    if l > min then 
    begin
        lineto1(x, y, l, u);
        x := Round(x + l * cos(u));
        y := Round(y - l * sin(u));
        Draw(x, y, l*0.4, u - 14*pi/30);
        Draw(x, y, l*0.4, u + 14*pi/30);
        Draw(x, y, l*0.7, u + pi/30);
    end;
end;
 
begin
     SetWindowCaption('Фракталы: Папоротник');
   SetWindowSize(730,500);
   ClearWindow;
    Draw(320, 460, 140, pi/2)   
end.
13
Почетный модератор
 Аватар для ildwine
6201 / 2954 / 1300
Регистрация: 04.03.2013
Сообщений: 5,795
Записей в блоге: 1
24.11.2014, 13:06  [ТС]
22. Кривая Дракона (другой вариант)


Кликните здесь для просмотра всего текста
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59

uses GraphABC;
var
  x,y : integer;
  dx,dy: integer;
  turn: array [1..1000] of Boolean;
  a,b,d,t: integer;
  f: Boolean;
  i: integer;
begin
  SetWindowSize(790,500);
  SetWindowCaption('Фракталы. Кривая Дракона');
  f:=true;
  for a := 1 to 64 do
  begin
    turn[2*a-1]:=f;
    f:=not f;
    turn[2*a]:=turn[a];
  end;
  x:=200; dx:=0;
  y:=140; dy:=-4;
  b:=0;
  d:=1;
  f:=false;
  MoveTo(x,y);
  for a:=1 to 128 do
  begin
    for i:=1 to 127*4 do
    begin
      b := b+d; x:=x+dx; y:=y+dy;
      LineTo(x,y);
      if f and not turn[b] or not f and turn[b] then
      begin
        t:=dy;
        dy:=-dx;
      end
      else
      begin
        t:=-dy;
        dy:=dx;
      end;
      dx:=t;
    end;
    b:=b+d; d:=-d;
    f:=not f;
    x:=x+dx; y:=y+dy;
    LineTo(x,y);
    if turn[a] then
    begin
      t:=dy;
      dy:=-dx;
    end
    else
    begin
      t:=-dy;
      dy:=dx;
    end;
    dx:=t;
  end;
end.
10
Почетный модератор
 Аватар для ildwine
6201 / 2954 / 1300
Регистрация: 04.03.2013
Сообщений: 5,795
Записей в блоге: 1
28.11.2014, 19:12  [ТС]
23. Канторова пыль


Кликните здесь для просмотра всего текста
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24

uses GraphABC;
const
    min = 1;
 
procedure Draw(x, y : Real; Size : Real);
var
    s : Real;
 
begin
    if size > min then 
    begin
        s := size / 3;
        Draw(x, y + 20, s);
        Draw(x + s * 2, y + 20, s);
    end;
    Rectangle(Round(x), Round(y), Round(x + size), Round(y + 5))
end;
 
begin
    SetWindowCaption('Фракталы: Канторова пыль');
  SetWindowSize(520,160);
  ClearWindow;
    Draw(10,30,500) 
end.
10
Почетный модератор
 Аватар для ildwine
6201 / 2954 / 1300
Регистрация: 04.03.2013
Сообщений: 5,795
Записей в блоге: 1
28.11.2014, 19:21  [ТС]
24. Кривая Леви


Кликните здесь для просмотра всего текста
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39

uses GraphABC;
 
procedure Draw;
const iter = 50000;
var
    t, x, y, p : Real;
    k : LongInt;
    mx, my, rad : Integer;
begin
    mx := 200;
    my := 300;
    rad := 250;
    Randomize;
    x := 0.0;
    y := 0.0;
    for k := 1 to iter do 
    begin
        p := Random;
        t := x;
        if p <= 1/2 then 
        begin
            x := 0.5*x - 0.5*y;
            y := 0.5*t + 0.5*y;
        end
        else
        begin
            x := 0.5*x + 0.5*y + 0.5;
            y := -0.5*t + 0.5*y + 0.5;
        end;
        PutPixel(mx + Round(rad * x), my - Round(rad * y), clBlue);
    end;
end;
 
begin
    SetWindowCaption('Фракталы: Кривая Леви');
  SetWindowSize(650,450);
  ClearWindow;
    Draw
end.
12
Почетный модератор
 Аватар для ildwine
6201 / 2954 / 1300
Регистрация: 04.03.2013
Сообщений: 5,795
Записей в блоге: 1
28.11.2014, 19:30  [ТС]
25. Обезьянье дерево


Кликните здесь для просмотра всего текста
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60

uses GraphABC;
 
procedure Draw(x, y, l, u : Real; t, q,s : Integer);
 
procedure Draw2(Var x, y: Real; l, u : Real; t, q, s : Integer);
begin
    Draw(x, y, l, u, t, q, s);
    x := x + l*cos(u);
    y := y - l*sin(u);
end;
 
begin
    if t > 0 then 
    begin
        if q = 1 then 
        begin
            x := x + l*cos(u);
            y := y - l*sin(u);
            s := -s;
            u := u + pi
        end 
        else if q = 3 then 
        begin
            x := x + l*cos(u);
            y := y - l*sin(u);
            s := s;
            u := u + pi
        end 
        else if q = 2 then 
        begin
            s:=-s
        end 
        else if q = 0 then 
        begin
            s := s
        end;
        l := l/3;
        Draw2(x, y, l,           u+s*pi/3,   t-1, 2,s);
        Draw2(x, y, l,           u+s*pi/3,   t-1, 1,s);
        Draw2(x, y, l,           u,          t-1, 0,s);
        Draw2(x, y, l,           u-s*pi/3,   t-1, 1,s);
        Draw2(x, y, l*sqrt(3)/3, u-s*7*pi/6, t-1, 1,s);
        Draw2(x, y, l*sqrt(3)/3, u-s*7*pi/6, t-1, 2,s);
        Draw2(x, y, l*sqrt(3)/3, u-s*5*pi/6, t-1, 3,s);
        Draw2(x, y, l*sqrt(3)/3, u-s*pi/2,   t-1, 3,s);
        Draw2(x, y, l*sqrt(3)/3, u-s*pi/2,   t-1, 0,s);
        Draw2(x, y, l,           u,          t-1, 3,s);
        Draw2(x, y, l,           u,          t-1, 0,s);
 
    end
    else 
        Line(Round(x), Round(y), Round(x + cos(u)*l), Round(y - sin(u)*l));
end;
 
begin
    SetWindowCaption('Фракталы: Обезьянье дерево');
  SetWindowSize(520,500);
  ClearWindow;
    Draw(50, 365, 430, 0, 3, 0, 1)
end.
14
Почетный модератор
 Аватар для ildwine
6201 / 2954 / 1300
Регистрация: 04.03.2013
Сообщений: 5,795
Записей в блоге: 1
08.11.2018, 19:30  [ТС]
26. Крест из окружностей


Кликните здесь для просмотра всего текста
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28

uses graphabc;
const 
  k = 2.6;
  n = 4; {глубина 1-6}
var x, y, r : integer;
{функция рисования, x,y-координаты цента,r-начальный радиус, n-глубина рекурсии}
function ris(x, y, r, n : integer) : integer;
begin
  if n = 0 then ris := 0
  else
  begin
    circle(x,y,r);
    dec(n);
    ris := ris(x + round(k * r), y, round(r / k), n);
    ris := ris(x - round(k * r), y, round(r / k), n);
    ris := ris(x, y - round(k * r), round(r / k), n);
    ris := ris(x, y + round(k * r), round(r / k),n)
  end
end;
 
begin
  r := 50;  
  SetWindowSize(500, 500);
  SetWindowCaption('Фракталы: крест из окружностей');
  x := windowwidth div 2;
  y := windowheight div 2;
  ris(x,y,r,n)  
end.


Основано на программе для Turbo Pascal от модератора Puporev
4
Почетный модератор
 Аватар для Puporev
64312 / 47609 / 32742
Регистрация: 18.05.2008
Сообщений: 115,181
29.04.2021, 19:25
27. Фрактал Треугольник

Кликните здесь для просмотра всего текста
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25

uses  GraphABC;
 
procedure Draw(x, y, l, u : Real; t : Integer);
procedure Draw2(var x, y: Real; l, u : Real; t : Integer);
begin
 Draw(x, y, l, u, t);
 x := x + l*cos(u);
 y := y - l*sin(u);
end;
 
begin
 if t > 0 then begin
    l := l/3;
    Draw2(x, y, l, u, t-1);
    Draw2(x, y, l, u+pi/2, t-1);
    Draw2(x, y, l, u, t-1);
    Draw2(x, y, l, u-pi/2, t-1);
    Draw2(x, y, l, u, t-1);
  end
 else Line(Round(x), Round(y), Round(x+cos(u)*l), Round(y-sin(u)*l))
end;
 
begin
 Draw(20, 320, 600, 0, 4);
end.

Выложено canadamoscow
Фрактал «Треугольник»
2
Надоела реклама? Зарегистрируйтесь и она исчезнет полностью.
BasicMan
Эксперт
29316 / 5623 / 2384
Регистрация: 17.02.2009
Сообщений: 30,364
Блог
 29.04.2021, 19:25
Помогаю со студенческими работами здесь

Кривая Гилберта (фракталы)
1. Написать программу для визуализации фрактала Кривая Гилберта 2. Добавить возможность масштабирования , изменения глубины прориосвки и...

Рекурсивные графические объекты. Фракталы
«Правильный» паркет. Нарисовать изображенный на рисунке правильный двухцветный паркет по универсальному (общему) алгоритму.

Фракталы. Начертить кленовый лист, применяя процедуры для построения геометрических фигур
написать программу,которая вычерчивает кленовый лист, применяя процедуры для построения геометрических фигур

Рекурсия и фракталы. Показать процесс "роста дерева"
Здравствуйте форумчане, помогите пожалуйста разобраться в задаче на рекурсию, задание: Показать процесс &quot;роста дерева&quot; с...

Фракталы - ледовый квадрат и резанный квадрат
Как сделать такие фракталы? Можете объяснить сам принцип? Хочу научиться нормально работать с фракталами и уметь строить фракталы любой...


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
12
Закрытая тема Создать тему
Новые блоги и статьи
Разработка плагина для Minecraft
Javaican 09.06.2025
За годы существования Minecraft сформировалась сложная экосистема серверов. Оригинальный (ванильный) сервер не поддерживает плагины, поэтому сообщество разработало множество альтернатив. CraftBukkit. . .
Dapper - лучший среди микроORM под C#
UnmanagedCoder 09.06.2025
Знаете, в мире ORM-инструментов для . NET существует негласная иерархия. На вершине массивных фреймворков возвышается Entity Framework - неповоротливый, но всемогущий. А в категории легковесных. . .
Сравнение GCC 14 и Clang 18 компиляторов C для HPC
bytestream 08.06.2025
В высокопроизводительных вычислениях (HPC) выбор компилятора - это ход, способный радикально изменить производительность всей системы. Работая последние 15 лет с критическими HPC-системами, я видел. . .
Всё о конфигурации ASP.NET Core
stackOverflow 08.06.2025
Старый добрый web. config, похоже, отправился на пенсию вместе с классическим ASP. NET. За годы работы с различными проектами я убедился, что хорошо организованная конфигурация – это половина успеха. . .
dev-c++5.11 Продолжаю движение.
russiannick 08.06.2025
Казалось, день прошел впустую. Просмотрел кучу видео и только потом заметил заголовок - уроки си. Искусители сбивали новичка с пути с++. Так легко ошибиться когда вокруг столько яп содержащих в. . .
Квантовые алгоритмы и обработка строк в Q#
EggHead 07.06.2025
Квантовые вычисления перевернули наше представление о том, как работать с данными, а Q# стал одним из ключевых языков для разработки квантовых алгоритмов. В традиционых системах мы оперируем битами —. . .
NUnit и C#
UnmanagedCoder 07.06.2025
В . NET существует несколько фреймворков для тестирования: MSTest (встроенный в Visual Studio), xUnit. net (более новый фреймворк) и, собственно, NUnit. Каждый имеет свои преимущества, но NUnit. . .
с++ Что нового?
russiannick 06.06.2025
Продолжаю обзор dev-cpp5. 11. Посмотрев на проекты, предоставленные нам для обучения, становится видно, что они разные по содержащимся файлам где: . dev обязательно присутствует . cpp/ . c один из них. . .
WebAssembly в Kubernetes
Mr. Docker 06.06.2025
WebAssembly изначально разрабатывался как бинарный формат инструкций для виртуальной машины, обеспечивающий высокую производительность в браузерах. Но потенциал технологии оказался гораздо шире - она. . .
Как создать первый микросервис на C# с ASP.NET Core, step by step
stackOverflow 06.06.2025
Если говорить простыми словами, микросервисная архитектура — это подход к разработке, при котором приложение строится как набор небольших, слабо связанных сервисов, каждый из которых отвечает за. . .
КиберФорум - форум программистов, компьютерный форум, программирование
Поддержать - Реклама - Условия использования - Обратная связь
Powered by vBulletin
Copyright ©2000 - 2025, CyberForum.ru
OSZAR »