ダウンロード

マンデルブロ集合(mandel brot set)

マンデルブロ集合とは
集合の計算手順
ワークシートでの計算
終了条件
色の設定
エクセルでの限界
シート構成
サンプル画像2010
VBAコード
サンプルファイルのダウンロード
リンクリスト
VBAコードを 全て展開 折り畳む




マンデルブロ集合(Mandel Brot set)とは


マンデルブロ集合は、1980年頃にアメリカ人数学者のブノワ・マンデルブロさん(Benoit B. Mandelbrot)が発見したフラクタル集合の一種です。
自己相似の性質を持ち、拡大していくと似たような画像(同じではない)が繰り返し現れてきます。
拡大図 拡大図


0.原図
1.左のピンク枠内を拡大


拡大図
拡大図


2.右上のピンク枠内を拡大
3.左のピンク枠内を拡大


表示領域の拡大方法

マウスを押してドラッグすると四角の枠が表示されます。
  枠が表示されている状態で「選択域拡大」ボタンをクリックすることで、選択域のみが再計算されます。





二乗して定数を加えたものを新たな値とする。

この単純な操作の繰り返しだけで、とてつもなく複雑な世界が誕生します。

細部を探索していくに従い広がる無限の世界、さまざまな繰り返し、多様な模様、そして、ところどころに浮かぶ真っ黒な物体。
大宇宙そのものを連想させられます。

この暗黒物体は、全て相互に細い線で繋がっているそうですが、物体の近辺以外は1兆倍に拡大しても確認はできません。
とてつもなく細い線のようです。


集合の計算手順

漸化式

漸化式

で定義される複 素数列 Zn が n → ∞ の極限で無限大に発散しないという条件を満たす複素数 C 全体が作る集合、これがマンデルブロ集合となります。

図中の黒い部分は収束域、 周囲の色は無限大に発散する速さを表します。


ここでは、マンデルブロ集 合の zn を点 (xn, yn) に、c を点 (a, b) にそれぞれ置き代えて、

漸化式

として計算します。

   Zn = Xn + i Yn とすると
   Zn+1 = Zn2 + C
       = Xn2 - Yn2 + i 2XnYn + a + ib

   Zn+1 = Xn+1 + iYn+1 

   なので、実数部、虚数部は、それぞれ
   Xn+1 = Xn2 - Yn2 + a
   Yn+1 = 2XnYn + b


座標

マンデルブロ集合は瓢箪形 の図形の周囲に自己相似的な図形が無数に連なった形をしていて、
それぞれに、点々となサイズの異なる黒い部分が見られますが、これらは全て、細い細い蜘蛛の糸のような線でマンデルブロ集合本体に連結してい るそうです。



終了条件


下記の場合に計算を打ち切る

 ・計算回数が所定の回数に達する
 ・|Z| > 2 になった場合(発散が証明済み)
 ・Zn+1 = Zn となる場合(収束)



ワークシートでの計算


計算式を立てて漸化式を計算してみます。
下図は、閾値(発散条件)を4.0とし、
初期値Cを、 -1.2 -0.2i として順次計算したものです。

18回目に、閾値を超え、28回目には計算限界を超えて発散していくのがわかります。

漸化式


下図は、初期をそれぞれ X軸、Y軸にとり、変化させたものです。
表示されている数値は閾値を超える計算回数を示しています。
(最大計算回数は100回)

設定されている計算式の「CalDivCount」関数は、上記の漸化式をユーザー 定義関数化したものです。

計算座標はDouble型(倍精度浮動小数点型)としているので有効数字は15桁となり、1兆倍以上の拡大可能。
Function CalDivCount(x0 As Double, y0 As Double, a As Double, b As Double, _
                    Optional MaxCnt As Long = 100) As Long
'
' 発散するまでの反復回数を計算
'
    Dim Cnt As Long
    Dim x As Double, y As Double, xn As Double, yn As Double
    Dim S As Double, S0 As Double
        
    xn = x0: yn = y0
    Cnt = 0
    Do
    
        x = xn * xn - yn * yn + a
        y = 2 * xn * yn + b
       
        S = x * x + y * y

        
        xn = x: yn = y
        Cnt = Cnt + 1
        
        If S = S0 Then Cnt = MaxCnt
        
        S0 = S
    
    Loop While ((S < 4#) And (Cnt < MaxCnt))

    CalDivCount = Cnt

End Function

なにやら、数字で模様が浮かび上がってきました。
これが、マンデルブロ集合となります。

平面表示

もっと細かく計算すると、ナスカの地上絵みたいな図が現れて来ました。

シートでの計算

上記の3Dグラフを作成してみると、
3Dグラフ

以降、VBAを使って数字ではなく、色で表すと不思議で複雑な美しい画像が現れて来ます。


色の設定


・白黒の場合

 計算回数に応じて、255〜1までの輝度を割り当てる。
 発散する場合は、0(黒)

・カラーの場合

 収束色(黒)と区別できるように、RGB(100,100,100)を基礎色とし、
 それより大きい値〜白までの値を計算回数に応じて割り当てる。
 割り当てる値は、最大計算回数に対する比とする。

 具体的には、

  色 = ColorBase + ( &HFFFFFF-ColorBase ) * v / MaxLimit
  としている。 発散する場合は、0(黒)

  計算回数:v
  基礎色:ColorBase=RGB(100,100,100)
  最大計算回数:MaxLimit

 
            '-------------------------------------
            ' 着色処理
            '-------------------------------------
            Color = 0   '黒
            If v < max_cnt Then '反復計算回数最大値より小さい場合
            
                If blColor Then '着色要?
                    Dim ColorBase As Long
                    ColorBase = RGB(100, 100, 100)
                    Color = ColorBase + (&HFFFFFF - ColorBase) * v / MAX_CNT_LIMIT   'カラー
                Else
                    v = 255 * (1 - v / max_cnt)             '白黒
                    Color = RGB(v, v, v)
                End If
            
            End If

    

エクセルでの限界


解像度

エクセルワークシートを使用しているため、エクセル2003以前では解像度の限界があります。
列数は255なので、ワークシート列を最大限近くまで使用しています。
ここでは、列数と行数を切りよく4:3の比で、240列x180行とします。
(列幅:0.08、行高:0.75)

列幅を大きくするとギザギザが目立ってしまいますので、列幅を最小幅に縮小しています。

かなり描画エリアが小さくなりますが、鑑賞に堪えられる画質にはなっています。

エクセル2010で列幅を拡張したものを同梱しています。
エクセル2007以降では列数は6万5千以上なので、理論的には十分大きな描画エリアをとれますが、
計算時間の壁がありますので、ここでは控えめに、720列x580行としています。

拡大倍率

倍精度(Double)型( -1.79769313486231570E+308 〜 -4.94065645841246544E-324)
を使用しているため、1兆倍くらいまでは拡大可能。
(限界に近づくとモザイク状になり、最後は単色表示)


エクセル2003 作成時間7秒 (2.99GHz 3GB RAM)
マンデル・ブロー集合 2003
マンデル・ブロー集合 2003
白黒モード 

カラーモード



エクセル2010(2007、2013含)での注意点

表示領域が広い(2003の9倍)ので、PCの計算パワーが小さいと表示完了まで時間が掛かるこ とがあります。
その場合、「STOP」キーで中断し、「解像度」を下げて(x 1/3)、目標領域 を絞り込んでください。
概要を把握した後、解像度を(x 1)として「再計算」すると効率よく画像探索が出 来ます。

エクセル2010 作成時間1分30秒(2.99GHz 3GB RAM)
マンデル・ブロー集合 2010



シート構成



フォーム構成







K 一括描画行数
    高速に描画するための一括描画行数を指定
    (20行を一括で描画すると1/3程の短縮になる)

L 所要時間
    描画に要した時間を表示
@:初期状態(左画面)に戻す

A選択域拡大
  拡大したい部分を選択すると有効になる

B選択域細密
  解像度が 「x 1」以外の場合、
  選択域のみを「x 1」に細密表示

  画像表示に時間がかかるエクセル2010ブックの場合、
  解像度を「x 1」以外で粗く表示しておき、
  必要な部分だけを細密化すると効率的に画像探索ができる。


C再計算
  同じ描画範囲で再計算する。
  粗い画像で確認後、解像度を上げて再描画したい場合、
  または、計算回数変更後の再描画時など。

D戻る
  ひとつ前の画像に戻る
  拡大画像をやり直したい場合など。

ESTOP
  計算停止

F解像度
  x 1:最大解像度(描画時間大)
  x 7:最小解像度(描画時間小)

G最大計算回数
  拡大を繰り返していくと、発散までの計算回数が多い領域が出てきます。
  最大計算回数を超えると収束と見なして黒く塗り潰すため、
  輪郭がぼやけてくることがあります。
  不自然な黒の領域が現れたら、最大計算回数を上げて下さい。

HColor
  オンの場合、カラー表示。オフは白黒画像。

Iセル座標、前図からの倍率、原図からの倍率

J計算座標




サンプル画像(エクセル 2010)


アンテナ部分(ピンク四角枠)を拡大
サンプル画像2010

80倍。以下、ピンク四角枠を拡大していきます。
サンプル画像2010

45倍、原図から3590倍
サンプル画像2010

65倍、原図から約23万倍
サンプル画像2010

34倍、原図から約8百万倍
サンプル画像2010

29倍、原図から約2億3千万倍 最大計算回数5000
サンプル画像2010

48倍、原図から約110億倍
サンプル画像2010

40倍、原図から約4千億倍
サンプル画像2010

48倍、原図から約17兆倍
サンプル画像2010

30倍、原図から約533兆倍。ここで解像度限界!
無限に続けるには、もう一工夫必要!
サンプル画像2010


VBAコード

変数定義部

Option ExplicitOption Explicit

'-------------------------------------
' マンデル・ブロー集合
'
' 複素数の数列 Zn+1=Zn^2+C
'
'  が発散する回数を複素平面での色として求める
'
'  Z = X+iY  C=a+ib (i 虚数単位)として
'
'  実数 Xn+1 = Xn^2 - Yn^2 + a
'  虚数 Yn+1 = 2*Xn*Yn + b
'
'  の数列を計算する
'
'--------------------------------------

Dim Rng As Range        'セル範囲オブジェクト
Dim Selected As Range   '選択されている範囲

Dim 中止 As Boolean     '中止フラグ

'---------------------
' 初期値
'---------------------

    
'計算範囲
Const INIT_AMAX = 0.9   '実数軸最大
Const INIT_AMIN = -2.3  '  最小
Const INIT_BMAX = 1.2   '虚数軸最大
Const INIT_BMIN = -1.2  '  最小

'セル範囲
Dim CMax As Integer        '列最大
Dim CMin As Integer        ' 最小
Dim RMax As Integer        '行最大
Dim RMin As Integer        ' 最小
Dim RC_ratio As Double     '比

Dim xmax As Double, xmin As Double
Dim ymax As Double, ymin As Double

Dim cs As Integer, ce As Integer
Dim rs As Integer, re As Integer


Dim max_cnt As Long         '指定反復計算最大回数
Const MAX_CNT_LIMIT = 5000  '同上限

'------------------------------------
' 履歴
'------------------------------------
Private Type TYPE_HISTORY
    xmin As Double
    xmax As Double
    ymin As Double
    ymax As Double
    max_cnt As Long
    rs As Integer
    re As Integer
    cs As Integer
    ce As Integer
End Type

Dim History(1) As TYPE_HISTORY  '履歴


イベント処理

'////////////////////////////////////////////
'
' イベント処理
'
'////////////////////////////////////////////

Private Sub cmdStop_Click()     '中止
    中止 = True
End Sub


Private Sub cmdInit_Click() ' 初期状態に戻す
    Call Init                       '初期化
    Rng.Interior.Pattern = xlNone   'クリア
    Set Selected = Nothing              '未選択状態
    Range("XY").Value = GetXY       '計算範囲
    Range("MAG").Value = GetMag     '拡大率表示
    Call Go                         '開始
End Sub


Private Sub cmdReCal_Click()  '再計算
    Call Go
End Sub


Private Sub cmdBack_Click()
'
' 戻る
'
    Set Rng = Range("DATA")                 '描画域
    With History(1)
        xmin = .xmin: xmax = .xmax: ymin = .ymin: ymax = .ymax
        max_cnt = .max_cnt
        rs = .rs: re = .re: cs = .cs: ce = .ce
    End With
    cmbCalCount.Value = max_cnt
    cmdBack.Enabled = False

    
    Call Go '作成開始
    
    Range("DATA").Range("A1").Select 'セル選択

End Sub


Private Sub cmdMagnify_Click()
'
' 選択範囲を拡大
'
    Dim xs As Double, xe As Double
    Dim ys As Double, ye As Double
    Dim Lc As Double, Lr As Double
    Dim Lx As Double, Ly As Double

    Set Rng = Range("DATA")                 '描画域
    Rng.Interior.Pattern = xlNone   'クリア
    
    '-------------------------
    ' 選択範囲チェック
    '-------------------------
    Dim blErr As Boolean
    blErr = False
    If Selected Is Nothing Then '未選択
        blErr = True
    ElseIf Selected.Rows.Count + Selected.Columns.Count < 4 Then    '範囲不足
        blErr = True
    End If
    If blErr Then
        MsgBox "拡大範囲を選択して下さい!"
        Exit Sub
    End If
    '-------------------------
   
    If xmax = 0 And xmin = 0 Then Call Init    '範囲選択−未

    Lc = CMax - CMin + 1
    Lr = RMax - RMin + 1
    Lx = xmax - xmin
    Ly = ymax - ymin
    
    cs = Selected.Column - CMin             '選択セル 列開始
    ce = cs + Selected.Columns.Count - 1    '         列終わり
    
    rs = Selected.Row - RMin                '選択セル 行開始
    re = rs + (ce - cs) * RC_ratio          '     列幅にあわせる
    
    '------------------------------------
    ' 履歴
    '------------------------------------
    With History(1)
        .xmin = xmin: .xmax = xmax: .ymin = ymin: .ymax = ymax
        .max_cnt = max_cnt
        .rs = rs: .re = re: .cs = cs: .ce = ce
    End With
    '------------------------------------

    xmax = xmin + Lx * (ce - 1) / (Lc - 1)
    xmin = xmin + Lx * (cs - 1) / (Lc - 1)
    
    ymin = ymin + Ly * (rs - 1) / (Lr - 1)
    ymax = ymin + (xmax - xmin) * (INIT_BMAX - INIT_BMIN) / (INIT_AMAX - INIT_AMIN)
    

    cmdBack.Enabled = False  '「戻る」ボタン無効

    Call Go '作成開始
    
    cmdBack.Enabled = True  '「戻る」ボタン有効
    
End Sub


Private Sub cmdDetail_Click()
'
' 選択域を細密表示
'
    中止 = False

    With Selected
        Go_Sub .Row, _
               .Row + .Rows.Count - 1, _
               .Column, _
               .Column + .Columns.Count - 1, _
               1 '解像度に応じて
        .Select
    End With
    
End Sub


Private Sub Worksheet_Activate()    'ワークシートがアクティブになった
    Call Init   '初期値
End Sub


Private Sub Worksheet_SelectionChange(ByVal Target As Range)    '選択範囲が変更された
    
    Dim Data As Range

    Set Data = Range("DATA")
    Set Selected = Intersect(Target, Data)

    Dim Rng As Range
    Set Rng = Intersect(Target, Data)
    Application.StatusBar = GetMag(Rng) & "    " & _
                            GetSel(Rng) & "     " & _
                            GetXY(Rng)   '計算範囲、拡大率表示

End Sub



内部サブルーチン/関数

'////////////////////////////////////////////
'
' 内部関数
'
'////////////////////////////////////////////

Private Sub Init()          '初期値設定
    Set Rng = Range("DATA")                 '描画域
    RMin = 1: RMax = Rng.Rows.Count         'セル行−開始/終了
    CMin = 1: CMax = Rng.Columns.Count      '  列−開始/終了
    RC_ratio = (RMax - RMin) / (CMax - CMin) '行列数比
    xmax = INIT_AMAX: xmin = INIT_AMIN      '描画範囲 x軸 開始/終了
    ymax = INIT_BMAX: ymin = INIT_BMIN      '     y軸
End Sub


Private Sub Go(Optional Stp As Integer = 1)

    Dim St As Date
    Range("所要時間") = "描画中"
    St = Now()
    
    Set Rng = Range("DATA")                 '描画域
    Range("SELCEL").Value = GetSel(Selected)  '選択範囲
    Range("A2").Select      '描画エリアを未選択状態にする
    
    中止 = False

    Go_Sub RMin, RMax, CMin, CMax, 2 * lstResolution.ListIndex + 1 '解像度に応じて

    Range("所要時間") = Now() - St
    
End Sub

内部サブルーチン/関数

Private Sub Go_Sub(rrmin As Integer, rrmax As Integer, _
                   ccmin As Integer, ccmax As Integer, _
                   Optional Stp As Integer = 1)
'
' 作成開始
'
    Dim v As Double
    
    Dim r As Integer, c As Integer  '行、列
    Dim rrs As Integer, rre As Integer
    Dim ccs As Integer, cce As Integer
    
    Dim x As Double, y As Double

    Dim blColor As Boolean  '着色−描画時に有効
    Dim intDrawRows As Integer  '一回の描画行数

    Dim Color As Long

    
    cmdStop.Enabled = True  '中止ボタンを有効

    If xmax = 0 And xmin = 0 Then Call Init     '計算範囲未設定→初期化
    
    '---------------------------
    ' 可変値
    '---------------------------
    intDrawRows = Int(Range("描画行数"))    '一回の描画行数
    blColor = CBool(chkColor.Value)         '着色
    max_cnt = Val(cmbCalCount.Value)        '反復計算回数

    Range("MAG0").Value = GetMag0       '拡大率(前回比)
    Range("MAG").Value = GetMag         '拡大率

    Range("XY").Value = GetXY                   '計算範囲
    
    MyWait 100, 中止
    
    '--------------------------------------
    ' 解像度に応じて計算中心位置を決定
    '--------------------------------------
    Dim Span As Integer
    Span = (Stp + 1) / 2 - 1
    rrs = rrmin + Span: rre = rrmax - Span
    ccs = ccmin + Span: cce = ccmax - Span

    If intDrawRows > 1 Then Application.ScreenUpdating = False
    
    For r = rrs To rre - Span Step Stp

        For c = ccs To cce - Span Step Stp
        
            x = xmin + (xmax - xmin) * (c - CMin + 1) / (CMax - CMin + 1)
            y = ymin + (ymax - ymin) * (r - RMin + 1) / (RMax - RMin + 1)
            v = CalDivCount(0, 0, x, y, max_cnt)

            '-------------------------------------
            ' 着色処理
            '-------------------------------------
            Color = 0   '黒
            If v < max_cnt Then '反復計算回数最大値より小さい場合
            
                If blColor Then '着色要?
                    Dim ColorBase As Long
                    ColorBase = RGB(100, 100, 100)
                    Color = ColorBase + (&HFFFFFF - ColorBase) * v / MAX_CNT_LIMIT   'カラー
                Else
                    v = 255 * (1 - v / max_cnt)             '白黒
                    Color = RGB(v, v, v)
                End If
            
            End If
            
,            Rng.Range(Cells(r - Span, c - Span), Cells(r + Span, c + Span)).Interior.Color = Color
            '--------------------------------------

        Next c

        If (intDrawRows > 1) And (r Mod intDrawRows) = 0 Then
            Range("所要時間") = Range("所要時間") & "."
            Application.ScreenUpdating = True
            Application.ScreenUpdating = False
        End If
        
        If 中止 Then Exit For
        Application.StatusBar = (r & "/" & RMax)    'ステータスバーに進行状況表示
        
        DoEvents

    Next r
    
    If intDrawRows > 1 Then Application.ScreenUpdating = True
    
    cmdStop.Enabled = False '中止ボタンを無効

End Sub

16,47,79−83,92 高速描画用処理
  行数に1より大きい値を指定されている場合、画面更新をオフ(Application.ScreenUpdating=False)とし、
  複数行を描画後に画面更新をオン(Application.ScreenUpdating=True)とする。
  これにより、描画速度が数倍に上がる。

範囲選択処理

Private Function GetSel(Optional Target As Range) As String
'
' 選択セル情報取得
'
    Dim r0 As Integer, c0 As Integer, r As Integer, c As Integer
    Dim Data As Range
    
    Set Data = Range("DATA")
    
    With Target
        
        If Target Is Nothing Then
            
            cmdMagnify.Enabled = False  '選択域拡大 有効
            cmdDetail.Enabled = False   '   細密
            
            GetSel = RMin & "," & CMin & " - " & RMax & "," & CMax
        Else
            
            cmdMagnify.Enabled = True
            cmdDetail.Enabled = True
            
            r0 = Data.Row - 1: c0 = Data.Column - 1
            r = .Row - r0: c = .Column - c0
            GetSel = r & "," & c & " - " & _
                               (r + .Rows.Count - 1) & "," & (c + .Columns.Count - 1)   '選択セル
        End If
        
    End With
    
End Function


Private Function GetMag0(Optional Target As Range) As String
'
' 拡大率(前回比)
'
    Dim v As Double
    v = 0
    With History(1)
        If (.xmax <> .xmin) And (xmax <> xmin) Then
            v = (.xmax - .xmin) / (xmax - xmin)                '拡大率
        End If
    End With
    GetMag0 = ""
    If v >= 1 Then GetMag0 = Format(v, "x#,###")
    
End Function


Private Function GetMag(Optional Target As Range) As String
'
' 拡大率(原図比)
'
    Dim XY As Range
    Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double
    
    Set XY = Range("XY")
    
    If Target Is Nothing Then
        x1 = xmin: x2 = xmax: y1 = ymin: y2 = ymax
    Else
        With Target
            Call CellToXY(.Row, .Column, x1, y1)
            Call CellToXY(.Row + .Rows.Count - 1, .Column + .Columns.Count - 1, x2, y2)
        End With
    End If

    If x1 <> x2 Then GetMag = _
            Format((INIT_AMAX - INIT_AMIN) / (x2 - x1), "x#,###")    '拡大率
End Function


Private Function GetXY(Optional Target As Range) As String
'
' 計算範囲算出
'
    Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double
    
    If Target Is Nothing Then
        x1 = xmin: x2 = xmax: y1 = ymin: y2 = ymax
    Else
        With Target
            Call CellToXY(.Row, .Column, x1, y1)
            Call CellToXY(.Row + .Rows.Count - 1, .Column + .Columns.Count - 1, x2, y2)
        End With
    End If
    
    GetXY = x1 & " , " & y1 & " : " & x2 & " , " & y2            '計算範囲

End Function


Private Function CellToXY(r As Integer, c As Integer, ByRef x As Double, ByRef y As Double)
'
' セル座標から計算座標を求める
'
'  出力:x,y
        If CMax = 0 Then Exit Function
        x = xmin + (xmax - xmin) * (c - CMin) / (CMax - CMin)
        y = ymin + (ymax - ymin) * (r - RMin) / (RMax - RMin)
End Function



×
PageTop