haskellでチューリングマシンでも作ってみた。

授業でチューリングマシン(TM)とか習ったんで作ってみた。
1テープTMです。

あと、プログラムは掛け算するTM
初期テープ状態(入力)が

で、最終テープ状態(出力)が

という単純なもの。
具体例で言えば、"000100001"は3*4を意味して、このTMは"000000000000"を最後に残して終了する。
実用性はないけどまぁ、見て眺めるものかな？
多テープじゃないんで往復の手間がひどい...(д)
そのうち多テープTMでもつくって万能TMでも書いてみるか...。
設計がめんどくさそう。

-- TM (Q, sigma, gamma, delta, q0, qAccept, qReject)
data Letter = Empty | X | Zero | One | Nil deriving Eq
data State = Q0 | Q1 | Q2 | Q3 | Q4 | Q5 | Q6 | Q7 | Q8 | Q9 | QA | QB | QC deriving (Show, Eq)
data Direction = R | L | S
instance Show Letter where
	showsPrec _ Empty	= ('_':)
	showsPrec _ Nil		= ('_':)
	showsPrec _ X		= ('X':)
	showsPrec _ Zero	= ('0':)
	showsPrec _ One		= ('1':)

-- テープ
tape :: [Letter]
tape =
	replicate 10 Zero ++ [One] ++
	replicate 10 Zero ++ [One] ++
	[Nil]


-- 初期状態
q0 :: State
q0 = Q0

-- Acceptする状態
qAccept :: State
qAccept = QB

-- Rejectする状態
qReject :: State
qReject = QC

-- delta
delta :: State -> Letter -> (State, Letter, Direction)
-- 入力のNilはEmptyに同じ
delta q Nil	= delta q Empty
-- 遷移関数の定義
delta Q0 Zero	= (Q6, Empty, R)
delta Q6 Zero	= (Q6, Zero, R)
delta Q6 One	= (Q1, One, R)
-- ここにサブルーチン
delta Q5 Zero	= (Q5, Zero, L)
delta Q5 One	= (Q7, One, L)
-- 分岐(まだ計算終わらない
delta Q7 Zero	= (Q8, Zero, L)
delta Q8 Zero	= (Q8, Zero, L)
delta Q8 Empty	= (Q0, Empty, R)
-- 分岐(計算終了
delta Q7 Empty	= (Q9, Empty, R)
delta Q9 One	= (QA, Empty, R)
delta QA Zero	= (QA, Empty, R)
delta QA One	= (QB, Empty, R)
-- サブルーチン
delta Q1 Zero	= (Q2, X, R)
delta Q2 Zero	= (Q2, Zero, R)
delta Q2 One	= (Q2, One, R)
delta Q2 Empty	= (Q3, Zero, L)
delta Q3 Zero	= (Q3, Zero, L)
delta Q3 One	= (Q3, One, L)
delta Q3 X	= (Q1, X, R)
delta Q1 One	= (Q4, One, L)
delta Q4 X	= (Q4, Zero, L)
delta Q4 One	= (Q5, One, R)
-- 受理状態(念のため
delta QB _	= (QB, Empty, R)
-- その他は全てReject
delta _ _	= (qReject, Empty, R)


-- 8<- - - 切 - り - 取 - り - 線 - - - - -

setValue :: a -> Int -> [a] -> [a]
setValue value index array = (take index array) ++ [value] ++ (drop (index+1) array)

step :: [Letter] -> State -> Int -> ([Letter], State, Int)
step letters state pos = (letters', state', pos')
		where	(state', top, direction) = delta state (letters !! pos)
			letters' = setValue top pos letters
			pos' = case direction of
				L -> pos - 1
				R -> pos + 1
				S -> pos

showLetters :: [Letter] -> String
showLetters = foldr ($) "" . map shows . takeWhile (/= Nil)

mainloop :: [Letter] -> State -> Int -> IO ()
mainloop letters state pos = do
		putStrLn $ showLetters letters
		putStr $ map (const ' ') $ showLetters $ take pos letters
		putStr "^"
		print state
--		getLine
		case state of
			st | st == qAccept -> putStrLn "Accept"
			st | st == qReject -> putStrLn "Reject"
			_ -> mainloop letters' state' pos'
		where (letters', state', pos') = step letters state pos

main :: IO ()
main = mainloop (tape ++ repeat Nil) q0 0

いらんと思うけど一応パートごとに詳細説明。

dateの定義

-- TM (Q, sigma, gamma, delta, q0, qAccept, qReject)
data Letter = Empty | X | Zero | One | Nil deriving Eq
data State = Q0 | Q1 | Q2 | Q3 | Q4 | Q5 | Q6 | Q7 | Q8 | Q9 | QA | QB | QC deriving (Show, Eq)
data Direction = R | L | S
instance Show Letter where
	showsPrec _ Empty	= ('_':)
	showsPrec _ Nil		= ('_':)
	showsPrec _ X		= ('X':)
	showsPrec _ Zero	= ('0':)
	showsPrec _ One		= ('1':)

CharとIntでもいいかな、とか思ったけど、なんとなくdataで宣言してみた。

Letterはテープ上に乗せられるアルファベット*1。
入力記号とテープ記号って別だっけ？まぁ、いいや。
Zero,One,X,Emptyはまぁ、教科書にも出ているような基本なアルファベットです。
Nilはウチが勝手に作ったもので、TMが書き換えたモノでないEmpty。
なんでこんなんを用意したかというと出力する関係。
同じEmptyにしてしまうとむ無限リスト全部吐いてしまう(д)
あとは適当にshowsPrecをば。

Stateはまんまステート。
名前長一定にしたかったので16進。
とくに深い意味はない。

Directionはヘッダの制御。
右と左と停止。
こいつは拡張前のプログラム使ってるんで停止は使ってないケドね。
RightとLeftって名前にしたかったのだが、Eitherが使っちゃってるんだよね。
Xもそうだけど一文字名ってヤだな。
まぁいいや。

テープの初期状態。

-- テープ
tape :: [Letter]
tape =
	replicate 10 Zero ++ [One] ++
	replicate 5 Zero ++ [One] ++
	[Nil]

まぁ、そのまんまだな。
とりあえずテストのまんまなんで決め打ち。10*5なり。
最後のNilは実はいらない。まぁ。適当に。

ステートの意味づけ。

-- 初期状態
q0 :: State
q0 = Q0

-- Acceptする状態
qAccept :: State
qAccept = QB

-- Rejectする状態
qReject :: State
qReject = QC

といってもこんだけ、初期、受理、拒否をそれぞれ定義。

遷移関数。

-- delta
delta :: State -> Letter -> (State, Letter, Direction)
-- 入力のNilはEmptyに同じ
delta q Nil	= delta q Empty
-- 遷移関数の定義
delta Q0 Zero	= (Q6, Empty, R)
delta Q6 Zero	= (Q6, Zero, R)
delta Q6 One	= (Q1, One, R)
-- ここにサブルーチン
delta Q5 Zero	= (Q5, Zero, L)
delta Q5 One	= (Q7, One, L)
-- 分岐(まだ計算終わらない
delta Q7 Zero	= (Q8, Zero, L)
delta Q8 Zero	= (Q8, Zero, L)
delta Q8 Empty	= (Q0, Empty, R)
-- 分岐(計算終了
delta Q7 Empty	= (Q9, Empty, R)
delta Q9 One	= (QA, Empty, R)
delta QA Zero	= (QA, Empty, R)
delta QA One	= (QB, Empty, R)
-- サブルーチン
delta Q1 Zero	= (Q2, X, R)
delta Q2 Zero	= (Q2, Zero, R)
delta Q2 One	= (Q2, One, R)
delta Q2 Empty	= (Q3, Zero, L)
delta Q3 Zero	= (Q3, Zero, L)
delta Q3 One	= (Q3, One, L)
delta Q3 X	= (Q1, X, R)
delta Q1 One	= (Q4, One, L)
delta Q4 X	= (Q4, Zero, L)
delta Q4 One	= (Q5, One, R)
-- 受理状態(念のため
delta QB _	= (QB, Empty, R)
-- その他は全てReject
delta _ _	= (QC, Empty, R)

この辺を綺麗に書けるのがさすが関数言語といった感じ？
というかパターンマッチか。
一番最初のNilのは入力のNilをEmptyと区別しないため。
あとはひたすらに遷移関数。
現在のステートQとヘッダの位置にあるアルファベットを入力にして、次の状態、ヘッダの位置に上書きするアルファベット、ヘッダをごう動かすか、を返す。
教科書のδ関数まんま。
んー。QBとQCは名前変えた方がよかったかかも。

リストの操作。

setValue :: a -> Int -> [a] -> [a]
setValue value index array = (take index array) ++ [value] ++ (drop (index+1) array)

値とインデックス、配列を受け取って、配列の要素を書き換え。
書き換えというか、それ以外を全部コピった配列を生成。かな。
さいしょはIORefでやろうかなとか思ったんだけど、IO絡むんで無限リストが使えないのと、実際書いてみたら意外に遅かったのでリストで実装。
まぁ、単に実装方法がマズかっただけな気がしないでもない。
長くなってくると非常に遅くなる予感バリバリ。
まぁ、後ろの方は使いまわせるだろうけど。

deltaの糖衣

step :: [Letter] -> State -> Int -> ([Letter], State, Int)
step letters state pos = (letters', state', pos')
		where	(state', top, direction) = delta state (letters !! pos)
			letters' = setValue top pos letters
			pos' = case direction of
				L -> pos - 1
				R -> pos + 1
				S -> pos

delta関数そのまんまだと扱いづらいのでもちっと甘い関数を定義。
授業だと"|-"みたいな記号使ってたけど、読み方わからねぇ。

テープを出力。

showLetters :: [Letter] -> String
showLetters = foldr ($) "" . map shows . takeWhile (/= Nil)

Nilを作ったのはこのため。
TMが一切いじってない部分はNilになってる + 最初のposは0、ということで、takeWhile (/=Nil)すれば動きのある部分だけ拾ってこれる。
最初はposの最大値でも記憶してtakeすればいいかな、とか思ったけど面倒だったのでこちらに。
で、IOはなるべく消したかったのでStringで返してる。
foldr ($) + [ShowS]つかっております。

メインループ

mainloop :: [Letter] -> State -> Int -> IO ()
mainloop letters state pos = do
		putStrLn $ showLetters letters
		putStr $ map (const ' ') $ showLetters $ take pos letters
		putStr "^"
		print state
--		getLine
		case state of
			st | st == qAccept -> putStrLn "Accept"
			st | st == qReject -> putStrLn "Reject"
			_ -> mainloop letters' state' pos'
		where (letters', state', pos') = step letters state pos

状態を表示したり再起でループしたり。
putStr $ map (const ' '...の部分は単純に

putStr $ replicate pos ' '

でも良かったのだけど、まぁ、一応Letterが複数文字になってもいいようにとこんなことしてます。

putStr $ replicate (sum $ map (length . show) letters) ' '

とかでもいいのかな？まぁ、せっかくshowLettersを作ったのでこれでいいでしょ。
qAcceptとqRejectを定義せずにここで決め打ちにしてもいいのだけどなんとなく。
そうすりゃStateはEqじゃなくてもよかったのだけど。
まぁ、いいや。

main

main :: IO ()
main = mainloop (tape ++ repeat Nil) q0 0

で、main。
上で定義したtapeだと作業領域が足りないので無限リストをくっつけてます。
VIVA遅延評価。
mainloopの引数はテープ、ステート、ヘッダ位置でございます。

んー。
date TM = TM [Letter] State Int
とかやってShowで時点表示を吐くようにするとよりよいのかねぇ？
でも個人的にテープをガーッて吐いて下に矢印書いた方がわかりやすいんでこれでFA
個人的には結構綺麗に書けたかなと。

-- firefox3がご乱心して送信したと思ったのができてなかった。激氣
-- まあ、vimで書いてgg"+yGしてShift-Insなんで被害はなかったのですが。

*1:世にいうアルファベットではなく計算幾何学的な意味でのアルファベットです。