はじめに
僕が今まで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
予告
明日は名前が似てるシェルピンスキーのカーペットです。