シェルピンスキーのカーペット（Mathematicaショートフラクタルシリーズ）

今回のテーマ

Mathematicaショートフラクタルシリーズ、第2回は前回のシェルピンスキーのギャスケットの四角形版ともいえる、シェルピンスキーのカーペットです。

ほぼ完成形

sierpinskiCarpet[x_] := ArrayFlatten[x /. {
  0 -> {
   {0, 0, 0},
   {0, 0, 0},
   {0, 0, 0}
  },
  1 -> {
   {1, 1, 1},
   {1, 0, 1},
   {1, 1, 1}
  }
}]
ArrayPlot[Nest[sierpinskiCarpet, 1, 5], PixelConstrained -> 1, Frame -> False]

描画としてはこれで充分です。

これ、自力で導出したものだったとは記憶していますが、Sierpinski carpet - Rosetta Codeでもほぼ同じ処理のコードが書いてありました。

今回もコードを紐解きながら、ショートコード化しましょう。

生成過程

In[1] = sierpinskiCarpet[1]
Out[1] = {{1, 1, 1}, {1, 0, 1}, {1, 1, 1}}

数値1に対して、

  1 -> {
   {1, 1, 1},
   {1, 0, 1},
   {1, 1, 1}
  }

のルールが適用されるので、{{1, 1, 1}, {1, 0, 1}, {1, 1, 1}}が返ってきます。

フラクタルは反復です。再帰です。ネストです。

2重にしましょう。

In[2] = sierpinskiCarpet[sierpinskiCarpet[1]]
Out[2] = {{1, 1, 1, 1, 1, 1, 1, 1, 1}, {1, 0, 1, 1, 0, 1, 1, 0, 1}, {1, 1, 1, 
  1, 1, 1, 1, 1, 1}, {1, 1, 1, 0, 0, 0, 1, 1, 1}, {1, 0, 1, 0, 0, 0, 
  1, 0, 1}, {1, 1, 1, 0, 0, 0, 1, 1, 1}, {1, 1, 1, 1, 1, 1, 1, 1, 
  1}, {1, 0, 1, 1, 0, 1, 1, 0, 1}, {1, 1, 1, 1, 1, 1, 1, 1, 1}}

既にけっこう長いリストですが、プロットするとこうです。

ArrayPlot[sierpinskiCarpet[sierpinskiCarpet[1]]]

すんなり描画できてますが、仮に数字をリストに置換するだけでは、以下のようにどんどん深いネストになってしまいます。

{{{{1, 1, 1}, {1, 0, 1}, {1, 1, 1}}, {{1, 1, 1}, {1, 0, 1}, {1, 1, 
    1}}, {{1, 1, 1}, {1, 0, 1}, {1, 1, 1}}}, {{{1, 1, 1}, {1, 0, 
    1}, {1, 1, 1}}, {{0, 0, 0}, {0, 0, 0}, {0, 0, 0}}, {{1, 1, 1}, {1,
     0, 1}, {1, 1, 1}}}, {{{1, 1, 1}, {1, 0, 1}, {1, 1, 1}}, {{1, 1, 
    1}, {1, 0, 1}, {1, 1, 1}}, {{1, 1, 1}, {1, 0, 1}, {1, 1, 1}}}}

毎回ArrayFlattenで平坦化することにより、常に2次元リストが保たれ、いつでもプロットできる状態になります。

ショートコード化

• 別途定義していたsierpinskiCarpet関数を即時関数化
• 0だけの3×3のリストを作るのにConstantArrayを使う
• 5回のネスト

で、以下の95文字のプログラムができました。

ArrayPlot[Nest[ArrayFlatten[#/.{0->ConstantArray[0,{3,3}],1->{{1,1,1},{1,0,1},{1,1,1}}}]&,1,5]]

@butchi_y (More info: https://t.co/HBUuaZOB3w) #wolframlang pic.twitter.com/REZVZvkJcs

— Tweet-a-Program (@wolframtap) 2015, 12月 15

ちなみに、128文字まで増えちゃいますが、ビットマップ書き出しする際には、PixelConstrained->1とFrame->Falseのオプションを付けないと綺麗に書き出せないんですよね。

ArrayPlot[
  Nest[
    ArrayFlatten[
      #/.{
        0 -> ConstantArray[0,{3,3}],
        1 -> {{1,1,1},{1,0,1},{1,1,1}}
      }
    ]&,
    1,
    5
  ],
  PixelConstrained->1,
  Frame->False
]

それか、白黒反転して、Rasterのグラフィックプリミティブを使ってもいいかもしれませんね。

Graphics[Raster[Nest[
  ArrayFlatten[
    #/.{
      1 -> ConstantArray[1,{3,3}],
      0 -> {{0,0,0},{0,1,0},{0,0,0}}
    }
  ]&,
  0,
  5
]]]

デモ

Mathematica版のオンラインデモはまだ上げられていませんが、
JavaScript版 (jsdo.it)ならありますので、遊んでみてください。

カーペットフラクタル - jsdo.it

これ、デフォルトではシェルピンスキーのカーペットですが、チェックボックスクリックでジェネレーターを変化させて、3×3だけでも他にも有名なフラクタル図形を数々描画できます。

↑ シェルピンスキーのカーペット

↑ シェルピンスキーのギャスケット（昨日のやつの変形版）

↑ カントールの塵集合

↑ Vicsek Fractal

↑ Hexaflake

予告

明日はコッホ曲線です。