ペンローズ『皇帝の新しい心』（みすず書房 ; ISBN: 4622040964 ; 1994/12,
以下ENM）の万能テューリング機械（のための万能テューリング機械）をMathematicaで実装した。これは自己完結的な説明ではない。ENMを読んでいないと何をしているのかほとんどわからないと思う。ペンローズ『皇帝の新しい心』（みすず書房 ; ISBN: 4622040964 ; 1994/12,
以下ENM）の万能テューリング機械（のための万能テューリング機械）をMathematicaで実装した。これは自己完結的な説明ではない。ENMを読んでいないと何をしているのかほとんどわからないと思う。
用語：ユニバーサル（万能）・チューリング（テューリング）・マシン（機械），universal turing machine
まず、省略されている先頭の110と末尾の110を付け加える。次に、{0 → 0, 1→ 10, R → 110, L → 1110, STOP → 11110}のルールで符号化された2進数列を復号する（ENM p.60-61）。
decode1[n_] := decodeBinary@IntegerDigits[n, 2]
decodeBinary[input_List]:=Module[{i=input,result={}},
i=Join[{1,1,0},i,{1,1,0}];
While[i=!={},
If[Length@i>4&&Take[i,5]==={1,1,1,1,0},
i=Drop[i,5];
AppendTo[result,STOP],
If[Length@i>3&&Take[i,4]==={1,1,1,0},
i=Drop[i,4];
AppendTo[result,L],
If[Length@i>2&&Take[i,3]==={1,1,0},
i=Drop[i,3];
AppendTo[result,R],
If[Length@i>1&&Take[i,2]==={1,0},
i=Drop[i,2];
AppendTo[result,1],
i=Drop[i,1];
AppendTo[result,0]]]]]];
result]
例として、UN+1 (177642)を復号すると次のようになる。
> decode1@177642
{R, 1, 1, R, 1, STOP, 1, 1, R}
実装上の問題から、XN*2のようにルールの数が奇数だったら、{R}を補うことにする。これによってENMでは適切でなかった記述が適切なものになってしまうことはあり得るが、適切だったものの振る舞いは変わらない。たとえば7はENMでは「正しい仕様が与えられていない」が、ここでは与えられる（いずれにしても止まらない）。
decode2[i_List]:=
Module[{result={},start=1,end=1},
While[end<=Length@i,
If[i[[end]]===R||i[[end]]===L||i[[end]]===STOP,
AppendTo[result,Take[i,{start,end}]];
start=end+1];
end++];
If[OddQ@Length@result,AppendTo[result,{R}]];
Partition[
Prepend[Take[#,-2],FromDigits[Drop[#,-2],2]]&
/@
(result/.{
{R}->{0,0,R},
{L}->{0,0,L},
{STOP}->{0,0,STOP},
{1,R}->{0,1,R},
{1,L}->{0,1,L},
{1,STOP}->{0,1,STOP}})
,2]]
例として、UN+1 (177642)を復号すると次のようになる。
> decode2@decode1@177642
{{{0, 0, R}, {1, 1, R}}, {{0, 1, STOP}, {1, 1, R}}}
Mathematica 6でテューリング機械をシミュレートする関数TuringMachineが導入された。
関数TuringMachineには次のような問題があり、ここでの目的には使いにくい。
このような欠点があるが、計算過程を視覚化する際にこの関数は便利なため、この関数用のルールも作れるようにしておく。
tmRule[x_] :=
Flatten[
Table[
Table[{state - 1, color - 1} -> x[[state, color]] /. {L -> -1, STOP -> 0, R -> 1}
,{color, 1, Length@First@x}]
,{state, 1, Length@x}]
,1]
例として、UN+1 (177642)のルールを作ると次のようになる。
> tmRule@decode2@decode1@177642
{{0, 0} -> {0, 0, 1}, {0, 1} -> {1, 1, 1}, {1, 0} -> {0, 1, 0}, {1, 1} -> {1, 1, 1}}
ペンローズの方法で記述されたテューリング機械を与えるとそのとおりに振る舞う。
上記の方法で変換テーブルを作り、それにもとづくテューリング機械を動作させる。
tm[n_Integer, rightTape_List, stepLimit_:Infinity]:=tm[decode2@decode1@n, rightTape, stepLimit]
このテューリング機械は、装置の右側テープが入力で、停止時の装置の左側（装置の場所も含む）テープが出力になるような仕様である。停止すると装置の{左のテープ, 状態, ステップ数}を返す。
tm[ruleSet_List, rightTape_List, stepLimit_:Infinity] :=
Module[{
state = 0,
head = First@rightTape,
rTape = Rest@rightTape,
lTape = {},
direction, rule, step = 0,
tTable = ruleSet /. {L -> -1, STOP -> 0, R -> 1} (*高速化のため*)
},
While[step++ < stepLimit,
rule = tTable[[state + 1, head + 1]];
state = rule[[1]];
head = rule[[2]];
direction = rule[[3]];
If[direction == 1, (* right move *)
AppendTo[lTape, head];
If[rTape === {}, head = 0,
head = First@rTape;
rTape = Rest@rTape],
If[direction == -1, (* left move *)
PrependTo[rTape, head];
If[lTape === {}, head = 0,
head = Last@lTape; (* 並び方を反対にして実装しても速くはならない *)
lTape = Drop[lTape, -1]],
Break[]]]];
If[step < stepLimit,
AppendTo[lTape, head];
{If[MemberQ[lTape, 1],
FixedPoint[If[First@# == 0, Rest@#, #] &, lTape],
{0}],
state, step},
{Null, Null, stepLimit}]]
テープは0と1のみだから算術化してリストでなく整数として実装したほうが速いと思うかもしれないが、そうしてもたいして変わらない。逆にテープが長くなってもリストなら遅くならないが整数だと遅くなってしまうかもしれない。
高速化したければC++で書き直せばよい。上のtmをそのまま書き直すだけでも100倍程度速くなる。テープはstd::listではなくstd::stringで実装した方が速いはず。
> un1 = 177642;
> decode2@decode1@un1
{{{0, 0, R}, {1, 1, R}},
{{0, 1, STOP}, {1, 1, R}}}
> {tape, state, stepLimit} = tm[un1, {1, 1, 1}]
{{1, 1, 1, 1}, 0, 4}
関数TuringMachineを使って計算過程を視覚化すると図のようになる。
ArrayPlot[Function[u, MapAt[Red &, u[[2]], u[[1, 2]]]] /@
TuringMachine[tmRule@decode2@decode1@un1, {0, {initTape, 0}}, stepLimit]]
> xn2 = 10389728107;
> decode2@decode1@xn2
{{{0, 0, R}, {1, 0, R}},
{{0, 1, R}, {2, 0, R}},
{{3, 1, R}, {0, 0, R}},
{{0, 1, STOP}, {0, 0, R}}}
> {tape, state, stepLimit} = tm[xn2, {1, 0, 0, 1, 0, 0, 0, 1, 0, 1, 0, 1, 0, 1, 1, 0}]
{{1, 0, 0, 1, 0, 0, 0, 1, 0, 1, 0, 1, 0, 0, 1, 1}, 0, 17}
関数TuringMachineを使って計算過程を視覚化すると図のようになる。
ArrayPlot[Function[u, MapAt[Red &, u[[2]], u[[1, 2]]]] /@
TuringMachine[tmRule@decode2@decode1@xn2, {0, {initTape, 0}}, stepLimit]]
> un2 = 1492923420919872026917547669;
> decode2@decode1@un2 // ColumnForm
{{{0, 0, R}, {1, 0, R}},
{{2, 1, L}, {1, 1, R}},
{{3, 0, R}, {4, 0, R}},
{{0, 1, STOP}, {3, 1, R}},
{{5, 1, L}, {4, 1, R}},
{{2, 1, L}, {5, 1, L}}}
> {tape, state, stepLimit} = tm[un2, {1, 1, 1}]
{{1, 1, 1, 1, 1, 1}, 0, 25}
関数TuringMachineを使って計算過程を視覚化すると図のようになる。
ArrayPlot[Function[u, MapAt[Red &, u[[2]], u[[1, 2]]]] /@
TuringMachine[tmRule@decode2@decode1@un2, {0, {initTape, 0}}, stepLimit]]
> xn1 = 450813704461563958982113775643437908;
> decode2@decode1@xn1
{{{0, 0, R}, {1, 1, R}},
{{0, 0, R}, {2, 1, R}},
{{3, 0, L}, {2, 1, R}},
{{0, 1, STOP}, {4, 0, L}},
{{5, 1, L}, {4, 1, L}},
{{6, 0, R}, {2, 1, R}},
{{0, 0, R}, {7, 1, R}},
{{3, 1, R}, {7, 0, R}}}
> {tape, state, stepLimit} = tm[xn1, {1, 0, 0, 1, 0, 0, 0, 1, 0, 1, 0, 1, 0, 1, 1}]
{{1, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0, 1, 1}, 0, 57}
関数TuringMachineを使って計算過程を視覚化すると図のようになる。
ArrayPlot[Function[u, MapAt[Red &, u[[2]], u[[1, 2]]]] /@
TuringMachine[tmRule@decode2@decode1@xn1, {0, {initTape, 0}}, stepLimit]]
> euc = 267556252842584231926905232066896095708779077170409889426;
> decode2@decode1@euc
{{{0, 0, R}, {1, 1, L}},
{{2, 1, R}, {1, 1, L}},
{{10, 0, R}, {3, 0, R}},
{{4, 0, R}, {3, 1, R}},
{{4, 0, R}, {5, 0, R}},
{{7, 0, L}, {6, 1, L}},
{{6, 0, L}, {1, 1, L}},
{{7, 0, L}, {8, 1, L}},
{{9, 0, L}, {8, 1, L}},
{{2, 0, R}, {1, 1, L}},
{{0, 0, STOP}, {10, 1, R}}}
> {tape, state, stepLimit} = tm[euc, {1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0}]
{{1, 1, 0}, 0, 235}
関数TuringMachineを使って計算過程を視覚化すると図のようになる。
ArrayPlot[Function[u, MapAt[Red &, u[[2]], u[[1, 2]]]] /@
TuringMachine[tmRule@decode2@decode1@euc, {0, {initTape, 0}}, stepLimit]]
Mathematicaで書いた万能テューリング機械に与えると、やはり万能テューリング機械として振る舞うような記述。
ENM p.83には「私が計算したuの2進表現を10進形式に変換してくださったことで、デイヴィッド・ドイッチ氏にお礼を申し上げる」とある。こんなところで量子計算や『世界の究極理論は存在するか』で有名なドイッチが出てくるのは驚きである。彼にこんなことをやらせていいのだろうか。ここでは逆に次のように10進形式で与え（本から写せる）、2進形式に変換する。
変換はMathematicaなら簡単（おそらくドイッチも同じように変換しただけだろう）。
> BaseForm[u,2]
次の方が重要だろう。
また、氏が次のことを確かめてくださったことにもお礼を申し上げなくてはならない。uのこの2進数値は確かに万能テューリング機械をもたらす。
“人間”が確かめたのである。
状態数は、
> Length@decode2@decode1@u 201
> decode2@decode1@u
下はこの万能テューリング機械の状態遷移図である。
> tm[u,
Join[IntegerDigits[un1, 2],
{1, 1, 1, 1, 1, 0},
{1, 1, 1}]]
{{1, 1, 1, 1}, 0, 3301}
ふつうにやれば4ステップで終わる計算に3301ステップもかかっている（計算過程を視覚化すると図のようになる）。
> tm[u,
Join[IntegerDigits[xn2, 2],
{1, 1, 1, 1, 1, 0},
{1, 0, 0, 1, 0, 0, 0, 1, 0, 1, 0, 1, 0, 1, 1, 0}]]
{{1, 0, 0, 1, 0, 0, 0, 1, 0, 1, 0, 1, 0, 0, 1, 1}, 0, 11299}
ふつうにやれば17ステップで終わる計算に11299ステップもかかっている。
> tm[u,
Join[IntegerDigits[un2, 2],
{1, 1, 1, 1, 1, 0},
{1, 1, 1}]]
{{1, 1, 1, 1, 1, 1}, 0, 74158}
ふつうにやれば25ステップで終わる計算に74158ステップもかかっている。
> tm[u,
Join[IntegerDigits[xn1, 2],
{1, 1, 1, 1, 1, 0},
{1, 0, 0, 1, 0, 0, 0, 1, 0, 1, 0, 1, 0, 1, 1}]]
{{1, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0, 1, 1}, 0, 156960}
ふつうにやれば57ステップで終わる計算に156960ステップもかかっている。
> tm[u,
Join[IntegerDigits[euc, 2],
{1, 1, 1, 1, 1, 0},
{1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0}]]
{{1, 1, 0}, 0, 1052980}
ふつうにやれば235ステップで終わる計算に1052980ステップもかかっている。
次のようにシステムを構成することはできるだろうか。
つまり、以下を実行できるだろうか。
tm[ (* 万能テューリング機械tmに *)
u, (* 万能テューリング機械Aと（ *)
Join[IntegerDigits[u, 2], (* （Aへの入力としての）万能テューリング機械Bと *)
{1, 1, 1, 1, 1, 0},
IntegerDigits[un1, 2], (* （Bへの入力としての）（テューリング機械UN+1と *)
{1, 1, 1, 1, 1, 0},
{1}] (* （UN+1への入力としての）1を与える）） *)
ヒント：できるならステップ数は13億程度になるだろう。
C++でナイーブに実装し、手元のマシンで時間を計ると表のようになった。
| std::string | std::list | |
|---|---|---|
| g++ 4.3.2 (-O3) | 15s | 46s |
| icc 11.0 (-O3) | 25s | 49s |
ヒントではないけど、Mathematicaだけなら簡単。最終的にはたぶんこんな感じ。
ReleaseHold[Hold[ReleaseHold[#1[#2]] &][Hold[Hold[ReleaseHold[#1[#2]] &], Hold[Hold[#1 + 1 &], 1]]]]
同じくLispだけの場合も簡単。ちょっと違うけどだいたいこんな感じ。
(EVAL '((LAMBDA (X) (EVAL X)) '((LAMBDA (X) (EVAL X)) '((LAMBDA (X) (+ X 1)) '1))))