玩一玩简单的分形：分形树

aoe1981

图如下：















原理如下：


（1）6个仿射变换，按指定概率随机选择：
仿射变换1：                                               
X1        =        0        0        X        +        0.55
Y1                0        0.6        Y                0
                                               
仿射变换2：                                               
X1        =        -0.05        0        X        +        0.525
Y1                -0.5        0        Y                0.75
                                               
仿射变换3：                                               
X1        =        0.46        -0.15        X        +        0.27
Y1                0.39        0.38        Y                0.105
                                               
仿射变换4：                                               
X1        =        0.47        -0.15        X        +        0.265
Y1                0.17        0.42        Y                0.465
                                               
仿射变换5：                                               
X1        =        0.43        0.28        X        +        0.285
Y1                -0.25        0.45        Y                0.625
                                               
仿射变换6：                                               
X1        =        0.42        0.26        X        +        0.29
Y1                -0.35        0.31        Y                0.525


（2）初始点：(X,Y)，变换点：(X1,Y1)；

（3）迭代至指定次数：(X1,Y1)→(X,Y)。

代码如下：

1. Option Explicit
   
2. Public Sub FX_s()
   
3.     Dim X#, Y#, p, i&, j&, ds&, sjd#(), n%, r#
   
4.     Dim a11#(), a12#(), a21#(), a22#(), b11#(), b21#()
   
5.     n = Range("k2").Value
   
6.     ReDim a11#(1 To n), a12#(1 To n), a21#(1 To n), a22#(1 To n), b11#(1 To n), b21#(1 To n)
   
7.     For i = 1 To n
   
8.         a11(i) = Cells(2 + (i - 1) * 4, 3).Value
   
9.         a12(i) = Cells(2 + (i - 1) * 4, 4).Value
   
10.         a21(i) = Cells(3 + (i - 1) * 4, 3).Value
    
11.         a22(i) = Cells(3 + (i - 1) * 4, 4).Value
    
12.         b11(i) = Cells(2 + (i - 1) * 4, 7).Value
    
13.         b21(i) = Cells(3 + (i - 1) * 4, 7).Value
    
14.     Next i
    
15.     Range("m2").Resize(1000000, 3).ClearContents
    
16.     p = Range("k11").Resize(n).Value
    
17.     For i = UBound(p, 1) To LBound(p, 1) + 1 Step -1
    
18.         For j = 1 To i - 1
    
19.             p(i, 1) = p(i, 1) + p(j, 1)
    
20.         Next j
    
21.     Next i
    
22.     Randomize
    
23.     ds = Range("k3").Value
    
24.     X = Range("k5").Value
    
25.     Y = Range("k6").Value
    
26.     ReDim sjd#(1 To ds, 1 To 3)
    
27.     For i = 1 To ds
    
28.         r = Rnd()
    
29.         For j = 1 To n
    
30.             If r < p(j, 1) Then Exit For
    
31.         Next j
    
32.         sjd(i, 1) = j
    
33.         sjd(i, 2) = a11(j) * X + a12(j) * Y + b11(j)
    
34.         sjd(i, 3) = a21(j) * X + a22(j) * Y + b21(j)
    
35.         X = sjd(i, 2)
    
36.         Y = sjd(i, 3)
    
37.     Next i
    
38.     Range("m2").Resize(ds, 3).Value = sjd
    
39. End Sub

复制代码

这次向通用方向改了下，反而短了。

附件如下：

分形树.zip (329.57 KB, 下载次数: 30)

2020-1-10 19:25 上传

点击文件名下载附件

想来，那些发现“特定变换参数”的人，真是生猛！

FOB_FN_L

玩出了新高度呀

kuangben8

厉害！论坛里还有一位大神在分形方面做的很牛塔！

dongdonggege

老师，你好
我有的数据改成数组，改编后，47行，出现下标越界，请帮我看看是哪里有问题。如果使用数组，怎么改，谢谢。

1. Option Explicit
   
2. 
   
3. Public Sub FX_s()
   
4.     Dim X#, Y#, i&, j&, ds&, sjd#(), n%, r#
   
5.     Dim a11#(), a12#(), a21#(), a22#(), b11#(), b21#()
   
6.     n = 6 'Range("k2").Value
   
7.     ReDim a11#(1 To n), a12#(1 To n), a21#(1 To n), a22#(1 To n), b11#(1 To n), b21#(1 To n)
   
8.     For i = 1 To n
   
9.         a11(i) = Cells(2 + (i - 1) * 4, 3).Value
   
10.         a12(i) = Cells(2 + (i - 1) * 4, 4).Value
    
11.         a21(i) = Cells(3 + (i - 1) * 4, 3).Value
    
12.         a22(i) = Cells(3 + (i - 1) * 4, 4).Value
    
13.         b11(i) = Cells(2 + (i - 1) * 4, 7).Value
    
14.         b21(i) = Cells(3 + (i - 1) * 4, 7).Value
    
15.     Next i
    
16.     a11(1) = 0: a11(2) = -0.05: a11(3) = 0.46: a11(4) = 0.47: a11(5) = 0.43: a11(6) = 0.42
    
17.     a12(1) = 0: a12(2) = 0: a12(3) = -0.15: a12(4) = -0.15: a12(5) = 0.28: a12(6) = 0.26
    
18.     a21(1) = 0: a21(2) = -0.5: a21(3) = 0.39: a21(4) = 0.17: a21(5) = -0.25: a21(6) = -0.35
    
19.     a22(1) = 0.6: a22(2) = 0: a22(3) = 0.38: a22(4) = 0.42: a22(5) = 0.45: a22(6) = 0.31
    
20.     b11(1) = 0.55: b11(2) = 0.525: b11(3) = 0.27: b11(4) = 0.265: b11(5) = 0.285: b11(6) = 0.29
    
21.     b21(1) = 0: b21(2) = 0.75: b21(3) = 0.105: b21(4) = 0.465: b21(5) = 0.625: b21(6) = 0.525
    
22.     Range("m2").Resize(1000000, 3).ClearContents
    
23.     Dim p(6, 1) As Integer
    
24.     'p = Range("k11").Resize(n).Value
    
25.     p(1, 1) = 0.1: p(2, 1) = 0.1: p(3, 1) = 0.2: p(4, 1) = 0.2: p(5, 1) = 0.2: p(6, 1) = 0.2
    
26.     For i = UBound(p, 1) To LBound(p, 1) + 1 Step -1
    
27.         For j = 1 To i - 1
    
28.             p(i, 1) = p(i, 1) + p(j, 1)
    
29.         Next j
    
30.     Next i
    
31.     Randomize
    
32.     'ds = Range("k3").Value
    
33.     'X = Range("k5").Value
    
34.     'Y = Range("k6").Value
    
35.     ds = 5000: X = 0: Y = 0
    
36.     ReDim sjd#(1 To ds, 1 To 3)
    
37.     For i = 1 To ds
    
38.         r = Rnd()
    
39.         For j = 1 To n
    
40.             If r < p(j, 1) Then Exit For
    
41.         Next j
    
42.         sjd(i, 1) = j
    
43.         sjd(i, 2) = a11(j) * X + a12(j) * Y + b11(j)
    
44.         sjd(i, 3) = a21(j) * X + a22(j) * Y + b21(j)
    
45.         X = sjd(i, 2)
    
46.         Y = sjd(i, 3)
    
47.     Next i
    
48.     Range("m2").Resize(ds, 3).Value = sjd
    
49. End Sub

复制代码

麻烦老师了。