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

## はじめに

僕が今までMathematicaでプログラム書いてきて、一番多く書いてるのはフラクタル描画のコードです。
なので今週は独壇場のフラクタル週間とさせてください。

最初「コードゴルフ」と銘打とうとしていましたが、
あまり可読性を下げない程度のコードで止めておくことにしました。
（先週コードゴルフやり過ぎてちょっと限界までコードを削る精神力がなくなってます…。）
Mathematicaは素直に書けば短くしてもあまり可読性が下がらない（と思う）ので素晴らしいです。

ちなみにTwitterに投稿できる140文字弱以下のコード（[wolframtap](https://twitter.com/wolframtap)に投げられる長さ）をショートコードと呼ぶことにします。

## 今回のテーマ

第1回は「フラクタル図形といえば」で5本の指には入るであろう、[シェルピンスキーのギャスケット](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%AE%E3%83%A3%E3%82%B9%E3%82%B1%E3%83%83%E3%83%88)です。


## ほぼ完成形

まずはショートコードにする手前の完成コードをお見せします。

```mathematica
Graphics@Polygon[Transpose[{Re[#], Im[#]}] & /@ 
  Nest[
    Flatten[{#/2, #/2 + 1/4 + Sqrt[3]/4 I, #/2 + 1/2}, 1] &,
    {{0, 1/2 + Sqrt[3]/2 I, 1}},
    6
  ]
]
```

![sierpinski-gasket_ifs.png](https://qiita-image-store.s3.amazonaws.com/0/6117/4000bd5a-bdd4-6a30-ea37-bb45c17afee2.png)


## 生成過程

これを少しずつ紐解いていきましょう。

「第0段階」のベースとなる形は正三角形です。

```mathematica
Graphics[Polygon[{Re[#], Im[#]} & /@ {0, 1/2 + Sqrt[3]/2 I, 1}]]
```

![triangle.png](https://qiita-image-store.s3.amazonaws.com/0/6117/fc88d7f8-0476-2457-7656-ae4c1a5582eb.png)

出ましたね、[複素数の魔法](http://qiita.com/butchi_y/items/a4a7e992870d75e5ee7a)。
僕はこの書き方が大好きなので、本シリーズほぼフル出場です（明日だけこの魔法はお休みです）。


## IFS

これを[反復関数系（IFS: Iterated Function System）](https://ja.wikipedia.org/wiki/%E5%8F%8D%E5%BE%A9%E9%96%A2%E6%95%B0%E7%B3%BB)で分身させます。

```mathematica
ifs[x_] := {x/2, x/2 + 1/4 + Sqrt[3]/4 I, x/2 + 1/2};
triForce = ifs[{0, 1/2 + Sqrt[3]/2 I, 1}];
Graphics[Polygon[Transpose[{Re[#], Im[#]}] & /@ triForce]]
```

![triforce.png](https://qiita-image-store.s3.amazonaws.com/0/6117/a638df3b-c305-bebf-de33-66c80aaf8179.png)


なんだか見覚えのあるシンボルですね。

``ifs[x_]``で定義した

- サイズを半分にする
- サイズを半分にして右に $\frac14$ 、上に $\frac{\sqrt3}4$ 移動する
- サイズを半分にして右に $\frac12$ 移動する

という関数が反復関数です。

この関数をネストさせます。

```mathematica
ifs[x_] := {x/2, x/2 + 1/4 + Sqrt[3]/4 I, x/2 + 1/2};
gasket = Nest[Flatten[ifs[#], 1] &, {{0, 1/2 + Sqrt[3]/2 I, 1}}, 2];
Graphics[Polygon[Transpose[{Re[#], Im[#]}] & /@ gasket]]
```

ちょっとだけフラクタル感が出てきましたね。


## ワンライナー化

では、これをワンライナーになるようまとめて、反復関数を短縮化して、ネスト回数を6回に増やしてショートコード化しましょう。

```mathematica
Graphics@Polygon[Transpose[{Re[#],Im[#]}]&/@Nest[Flatten[{2#,2#+1+Sqrt[3]I,2#+2}/4,1]&,{{0,2+2Sqrt[3]I,4}/4},6]]
```

<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/iYjxpxqepu">pic.twitter.com/iYjxpxqepu</a></p>&mdash; Tweet-a-Program (@wolframtap) <a href="https://twitter.com/wolframtap/status/676414975079014400">2015, 12月 14</a></blockquote>
<script async src="//platform.twitter.com/widgets.js" charset="utf-8"></script>

112文字です。

複素数の魔法により、反復関数の適用はかなり楽になってます。
が、ベースの三角形がリスト表現されていることにより平坦化（Flatten）のレベルを気にする必要があり、
面倒くさいことになってます。


## 代案

三角形の代わりに点を使えば魔法の本領を発揮し、もっとすっきり書けます。

```mathematica
Graphics[Point[{Re[#],Im[#]}&/@Nest[Flatten[{#/2,#/2+1/4+Sqrt[3]/4I,#/2+1/2}]&,0,6]]]
```

<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/5VvPjEY08k">pic.twitter.com/5VvPjEY08k</a></p>&mdash; Tweet-a-Program (@wolframtap) <a href="https://twitter.com/wolframtap/status/676415218600292352">2015, 12月 14</a></blockquote>
<script async src="//platform.twitter.com/widgets.js" charset="utf-8"></script>


## 予告

明日は名前が似てる[シェルピンスキーのカーペット](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)です。