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

## 今回のテーマ

Mathematicaショートフラクタルシリーズ、第2回は前回のシェルピンスキーのギャスケットの四角形版ともいえる、[シェルピンスキーのカーペット](https://ja.wikipedia.org/wiki/%E3%82%B7%E3%82%A7%E3%83%AB%E3%83%94%E3%83%B3%E3%82%B9%E3%82%AD%E3%83%BC%E3%81%AE%E3%82%AB%E3%83%BC%E3%83%9A%E3%83%83%E3%83%88)です。


## ほぼ完成形

```mathematica
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.png](https://qiita-image-store.s3.amazonaws.com/0/6117/8f020213-ece9-f749-f0bf-3733673d18bf.png)

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

これ、自力で導出したものだったとは記憶していますが、[Sierpinski carpet - Rosetta Code](http://rosettacode.org/wiki/Sierpinski_carpet#Mathematica)でもほぼ同じ処理のコードが書いてありました。

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

## 生成過程

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

数値``1``に対して、

```mathematica
  1 -> {
   {1, 1, 1},
   {1, 0, 1},
   {1, 1, 1}
  }
```

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

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

2重にしましょう。

```mathematica
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]]]
```

![sierpinski-carpet_2.png](https://qiita-image-store.s3.amazonaws.com/0/6117/a5ef7342-f4c0-d1d6-95d6-9439d45b334d.png)

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

```mathematica
{{{{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](http://reference.wolfram.com/language/ref/ArrayFlatten.html)で平坦化することにより、常に2次元リストが保たれ、いつでもプロットできる状態になります。

## ショートコード化

- 別途定義していたsierpinskiCarpet関数を即時関数化
- 0だけの3×3のリストを作るのに[ConstantArray](http://reference.wolfram.com/language/ref/ConstantArray.html)を使う
- 5回のネスト

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

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

<blockquote class="twitter-tweet" lang="ja"><p lang="en" dir="ltr"><a href="https://twitter.com/butchi_y">@butchi_y</a> (More info: <a href="https://t.co/HBUuaZOB3w">https://t.co/HBUuaZOB3w</a>) <a href="https://twitter.com/hashtag/wolframlang?src=hash">#wolframlang</a> <a href="https://t.co/REZVZvkJcs">pic.twitter.com/REZVZvkJcs</a></p>&mdash; Tweet-a-Program (@wolframtap) <a href="https://twitter.com/wolframtap/status/676726599182655488">2015, 12月 15</a></blockquote>
<script async src="//platform.twitter.com/widgets.js" charset="utf-8"></script>

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


```mathematica
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](http://reference.wolfram.com/language/ref/Raster.html)のグラフィックプリミティブを使ってもいいかもしれませんね。

```mathematica
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](http://jsdo.it/butchi/carpet_fractal)
[![jsdo.itデモのサムネイル](http://jsdo-it-static-contents.s3.amazonaws.com/images/capture/j/B/0/jB0K.jpg?t=1335166551)](http://jsdo.it/butchi/carpet_fractal)

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

![sierpinski_carpet_small.png](https://qiita-image-store.s3.amazonaws.com/0/6117/53eb83f5-3659-ba3b-4c56-eee7362ea565.png)

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

![sierpinski_gasket.png](https://qiita-image-store.s3.amazonaws.com/0/6117/8776e6d7-15b5-6135-fe7d-f54c67db0ae4.png)

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

![cantor_dust.png](https://qiita-image-store.s3.amazonaws.com/0/6117/5a17f32e-3d68-50b3-7217-dc4b346b0e6a.png)

↑ カントールの塵集合

![vicsek_fractal.png](https://qiita-image-store.s3.amazonaws.com/0/6117/9ee70570-43e4-29b5-4ceb-0d613714cf45.png)

↑ Vicsek Fractal

![hexaflake.png](https://qiita-image-store.s3.amazonaws.com/0/6117/0c204568-2161-d764-5af5-bc38058e059c.png)

↑ Hexaflake

## 予告
明日は[コッホ曲線](https://ja.wikipedia.org/wiki/%E3%82%B3%E3%83%83%E3%83%9B%E6%9B%B2%E7%B7%9A)です。