Mathematicaプログラミング ヒント

Paperfolding課題 TeXソースの演習のためのMathematicaプログラムのヒント。

まず、アルファベット$A=\{a,b,c,d\}$の次の代入 $\theta$

\[ \theta(a)=ab,\quad \theta(b)=cb,\quad \theta(c)=cd,\quad\theta(d)=ad \]

から生成される記号列 $\lim_{n\rightarrow\infty}\theta^n(abcd)$で定まる折れ線を描くことから考えてみよう。

ベクトルの加算和列

ベクトルの列 $v_1,v_2, \dots, v_n$ の加算和 を \[ v_1, v_1+v_2, v_1+v_2+v_3,\dots, \sum_{i=1}^k v_i,\dots, \sum_{i=1}^n v_i \] と定義しよう。 Mathematicaでは、リスト $list$ の先頭から $n$ この要素を返す関数 Take[list, n] を使うと、次のようにして、記号からなる list の加算和を返す関数 path[list] を定義することができる。

path[{}] := {};
path[lst_List] := Module[
  {addlst = {}, s},
  Do[s = Apply[Plus, Take[lst, n]];
        AppendTo[addlst, s], {n, 1, Length[lst]}
   ];
  addlst
  ]

ここでは、Mathematicaのリストへの関数の作用の仕組みを使っている。 実際、a + b + c という表式は、リスト {a, b, c} に対する演算（作用）であることが次のようにして分かる。

FullForm[a + b + c]
[Out]	Plis[a, b, c]

Apply[Plus, {a, b, c}]
[Out]	a + b + c

関数 path を使うと、たとえば、次の結果を得る。

path[{a, b, c, d}]
[Out]	{a, a + b, a + b + c, a + b + c + d}

記号からなるリストの加算和を求めることができれば、目的としていたベクトルからなるリストの加算和、つまり、ベクトルの次々と加えていった位置列からなるリストを得ることは、Mathematicaでは簡単だ。

記号 a, b, c, d をそれぞれ単位ベクトルをリストで表して {0,1}, {0,1}, {-1, 0}, {0, -1} （東西南北を向いた4つの互いに直交するベクトル）と見なすことにすれば、記号 a, b, c, d からなる任意のリスト要素（をつかった加減・スカラー倍した結果）list は次のようにしてベクトル（をつかった加減・スカラー倍した結果）に置き換えることができる。 /. は 関数 ReplaceAll の短縮形で、右から作用させているのがMathematica流だ。

list /. {a -> {1, 0}, b -> {0, 1}, c -> {-1, 0}, d -> {0, -1}}

例えば、次のような案配である。

t = {a, b, c, b, c, d, c, b}
pt = path[t]
[Out]	{a, a + b, a + b + c, a + 2 b + c, a + 2 b + 2 c, a + 2 b + 2 c + d, 
		a + 2 b + 3 c + d, a + 3 b + 3 c + d}
points= pt /. {a -> {1, 0}, b -> {0, 1}, c -> {-1, 0}, d -> {0, -1}}
[Out]	{{1, 0}, {1, 1}, {0, 1}, {0, 2}, {-1, 2}, {-1, 1}, {-2, 1}, {-2, 2}}
PrependTo[points, {0, 0}];

ここでは、最後に、点（ベクトル）からなるリスト points の先頭に原点 {0, 0} を追加して、改めて points としている（原点からラインを引きたいから）。 この点列からなるリストを線でつないだグラフィックオブジェクト Line[point] を実際に表示するには次にように書く。

Show[Graphics[Line[points]]]

Substitutionで生成した記号列のベクトル加算列

たとえば、次のようなアルファベット$\{a,b\}$上の代入（substitution）$\sigma$ を考えてみよう。

\begin{align*} & \sigma: a\rightarrow ab,\quad b\rightarrow a,\\ & \sigma(st)=\sigma(s) \sigma(t). \end{align*}

たとえば、$\sigma(a)^3=\sigma^2(ab)=\sigma^2(a)\sigma^2(b)=abaab$. この代入を関数 fibo とするMathematicaコードは次のように定まる。

fibo[a] := {a, b};
fibo[b] := {a};
SetAttributes[fibo, Listable]

属性 Listable は必要であるこのに注意されたい。 $\sigma^n(a)$で生成される記号列を返す関数 fibonacciを与える Mathematicaコードは次のように書くことができる。

fibonacci[lst_List, n_Integer] := Flatten[Nest[fibo, lst, n]]

関数 fibonacciは $\sigma^{n+1}(a)=\sigma^n(a)\sigma^n(b)$ によって再帰的にも定義できるが、ここではMathematicaの強力な関数 Nest を使って再帰を使わずに直接に関数の反復結果を求めていることに注意しよう。 中括弧 { と } の「大発生」を整理するために Flatten を使っている。

記号$a$をベクトル $(1,0)$、$b$を$(0,1)$を見なして、$\sigma^n(a)$ で得られる$\{a,b\}^*$上のベクトル列の加算和の各点を線で結んでみよう。 Mathematicaコードは次のようになる。

DrawFibonacci[k_Integer] := Module[{fibonaccipoints},
  path[{}] := {};
  path[lst_List] := Module[
    {addlst = {}, s},
    Do[s = Apply[Plus, Take[lst, n]];
          AppendTo[addlst, s], {n, 1, Length[lst]}
     ];
    addlst
    ];
  fibonaccipoints = 
   path[fibonacci[{a}, k]] /. {a -> {1, 0}, b -> {0, 1}};
  PrependTo[fibonaccipoints, {0, 0}];
  Show[Graphics[Line[fibonaccipoints], AspectRatio -> Automatic]]
]

無限列 $\lim_{n\rightarrow\infty}\sigma^n(a)$ に対して描いた折れ線の傾きは $\frac{1}{\tau}=\frac{\sqrt{5}-1}{2}=0.61803399$ に漸近する（$\tau$ は黄金比で $\tau^2-\tau-1=0$ を満たす）。 それゆえにこの代入を Fibonacci的というのである。

折り畳み記号列から折り畳み点列を求める

折り畳み操作$D$または折り畳み操作$U$からなるアルファベット$\{D, U\}$上の折り畳み記号列 foldlist $f_1f_2\dots f_n$から、この記号列を先頭から読んでいって、初期方向を右向き$(1,0$とし、現在の方向$v$に対して$D$に会えば$-\frac{\pi}{2}$回転（L）した方向$L\dot v$、$U$に会えば$\frac{\pi}{2}$回転（R）した方向$R\dot v$とすることによってベクトル列 $v=v_1v_2\dots v_n$ が得られる。

こうして折り畳み列 foldlist から記号$D$または$U$によってタートル的に向きを変えて得られた向きベクトル列 $v$ の加算和によって得られる点列の最初に原点を付け加えて、紙の左端からの折り畳み点を返す関数succesiveRotatedSum を定義できる。 この点列をこれをLineで結べば紙の折り畳み（90度）展開図形を描くことができる、 Mathematicaコードは次のようになる。

succesiveRotatedSum[lst_List] :=  Module[{dlst = {}, addlst = {}, R, L, v, s},
    L = {{0, -1}, {1, 0}};
    R = {{0, 1}, {-1, 0}};
    rot[d] = L;
    rot[u] = R;
    v = {1, 0};
    AppendTo[dlst, v];
    Do[
      v = rot[lst[[n]]].v;
      AppendTo[dlst, v], {n, 1, Length[lst]}
    ];
    Do[
      s = Apply[Plus, Take[dlst, n]];
      AppendTo[addlst, s], {n, 1, Length[dlst]}
    ];
    PrependTo[addlst, {0, 0}];
    addlst
  ]

折り畳み記号列

折り畳み操作$D$による2-foldingを繰り返して得られる$\{D, U\}^*$上の折り畳み記号列 $F_n$ は、次のように直接的な再帰的定義によって、または、一般的な折り畳み積から得ることができる。

2-foldingの再帰定義

$ f=f_1f_2\dots f_k \in \{D,U\}^*$に対して、$\overline{f}$を記号$D$と$U$とを入れ替え（$D\rightarrow U,U\rightarrow D$）、さらにその列順を反転（$a_1a_2\dots a_k\rightarrow a_k\dots a_2a_1$）する操作とするとき、

\begin{align*} F_1&=D,\\ F_{n+1}&= F_n D \overline{F_n},\quad n\geqq 2 \end{align*}

で定義される。 $n$回の$D$操作 2-folding後の折り畳み記号列を返す関数は次のようになる。

paper2fold[1] := {d};
paper2fold[2] := {d, d, u};
paper2fold[n_Integer] := 
 Flatten[{pre = paper2fold[n - 1], d, 
   Reverse[pre /. {d -> u, u -> d}]}]

折り畳み積

$m$-folding $T=t_1¥dots t_{m-1}$ を行った後に、次いで $n$-folding $S=s_1¥dots s_{n-1}$ して得られる折り畳み列 foldingConvolution[s, t] を次で定義する。

\[ S*T:= \begin{cases} S t_1\overline{S}t_2 S \dots S t_{m-1}\overline{S},\quad \text{$m$が偶数}\\ S t_1\overline{S}t_2 S \dots S \overline{S}t_{m-1} S,\quad \text{$m$が偶数} \end{cases} \]

つまり、$m$-folding $T$の要素を挟むように$S$と$\overline{S}$を交互に並べるのである。 このMathematicaコードを考えよう。

列 $s$ に $+1$ または $-1$ のスイッチをつけた関数

\begin{gather*} \mathrm{Rev}(s, 1)=\overline{s},\\
\mathrm{Rev}(s, -1)=s \end{gather*}

を用意しておき、$\mathrm{Rev}(s, P)$ において、初期に$P=1$とおき、P *= -1 によって交互に符号を変えながら、次のようにして計算することにしよう。

foldingConvolution[s_List, t_List] := Module[{parity = 1, i, conv = {}},
    rev[st_, 1] := Reverse[st] /. {d -> u, u -> d};
    rev[st_, -1] := st;
    conv = Flatten[Append[conv, s]];
    Do[
      AppendTo[conv, t[[i]]];
      conv = Flatten[Append[conv, rev[s, parity]]];
      parity *= -1;
      , {i, 1, Length[t]}
    ];
    conv
  ]

$k$-folding $s$ を$n$回繰り返して得られる折り畳み記号列を返す関数 iteratedFoldingConvolution[s, n] をMathematica的に定義するには、先の foldingConvolution[s, t] を純関数化 foldingConvolution[s, #] & し（変数は # と見なしている）、これを $s$ に対して $n-1$ 回関数を反復適用すればよい。

iteratedFoldingConvolution[s_List, n_Integer] :=
   Nest[foldingConvolution[s, #] &, s, n - 1]

iteratedFoldingConvolution[{d}, n] は paper2fold[n] と同じ結果を返すことを確認しておこう。

---

Copyright 2004 水谷正大