はじめに

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

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

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

今回のテーマ

第1回は「フラクタル図形といえば」で5本の指には入るであろう、シェルピンスキーのギャスケットです。

ほぼ完成形

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

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

生成過程

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

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

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

出ましたね、複素数の魔法。
僕はこの書き方が大好きなので、本シリーズほぼフル出場です（明日だけこの魔法はお休みです）。

IFS

これを反復関数系（IFS: Iterated Function System）で分身させます。

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

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

ifs[x_]で定義した

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

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

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

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回に増やしてショートコード化しましょう。

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

@butchi_y (More info: https://t.co/HBUuaZOB3w) #wolframlang pic.twitter.com/iYjxpxqepu
— Tweet-a-Program (@wolframtap) 2015, 12月 14

112文字です。

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

代案

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

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

@butchi_y (More info: https://t.co/HBUuaZOB3w) #wolframlang pic.twitter.com/5VvPjEY08k
— Tweet-a-Program (@wolframtap) 2015, 12月 14

予告

明日は名前が似てるシェルピンスキーのカーペットです。