Haskellでチューリングマシン(3) モナドを使ってどうするか

Haskell Haskellチューリングマシン

チューリングマシンを作るに当たって、テープを操作する処理をモナドにするというのを試みたわけですが、もとよりモナドの使い方がよく解っていないため改めて見返すとなかなか酷い出来です。

結局、自分でもしっくり収まっていなかったのでしばらく停滞していましたが、チマチマ勉強を進めたおかげで、ようやく方向性が見えてきました。
って、もったいぶるような事じゃないですね、実のところ前回のStateモナド再発明はそのための前置きだったんですけど。


というわけで、改めて考えましょう、テープの定義はこうでした。

--テープの値
data TapeValue = T0 | T1 deriving Eq
instance Show TapeValue where
  show T0 = "0"
  show T1 = "1"

--無限長の長さを持つテープ
data Tape = Tape [TapeValue] [TapeValue] deriving Eq
instance Show Tape where
  show (Tape front forward) =
    toStr (reverse front) ++ "|" ++ show (head forward) ++ "| " ++ toStr (tail forward)
    where toStr l = concat $ map (\v -> show v ++ " ") l

で、こんな感じで意味のないデータ型を作って無理やりモナドと名付けていたのですが・・・

--チューリングマシンモナド 
data TuringMachine a = TuringMachine a deriving (Show,Eq)
instance Monad TuringMachine where
  return a = TuringMachine a
  (TuringMachine x) >>= f = f x

チューリングマシンの「状態」はテープの移動や読み書きで変わります、ヘッドには常にステータスが保持されています。なのでこれらはStateモナドと同じ容量で水面下でもち回すことにしましょう。
次のように書き直します。

--ヘッドの状態 (テープ、ステータス)
data MachineState = MachineState Tape Int deriving Show

--チューリングマシンモナド　Stateモナドと同様の仕組みで MachineState を保持する
newtype Machine a = Machine { runMachine :: MachineState -> (a,MachineState) }
instance Functor Machine where
  fmap f m = Machine $ \s -> let
    (a,s') = runMachine m s
    in (f a,s')
instance Monad Machine where
  return a = Machine $ \s -> (a,s)
  m >>= k = Machine $ \s -> let
    (a,s') = runMachine m s
    in runMachine (k a) s'

とりあえず動かすことに注視してたのでこのブログではあまり触れていなかったのですが、モナドを語るためにはすごく重要なFunctorという型クラスもここではちゃんと定義してやります。
GeneralizedNewtypeDerivingで簡潔にできると思いますが、とりあえず後にしておきましょう。型の関係で、できませんでした。仕方ないのでボイラープレート書きます。

処理開始時にテープが初期化されている事を保証するため、rumMachineフィールドラベルは使わず（エクスポートせず）、次のようなstartMachine関数を定義します。

getTape関数はMachineStateからテープのみ取り出す関数ですが・・・フィールドで定義したほうが良かったかな・・・

--モナドを使った処理の開始
startMachine :: Machine a -> Tape
startMachine f = getTape.snd.(runMachine f) $ MachineState (Tape [] [T0]) 0

いくつかの操作用関数を書いたのですが、ここではとりあえずエクスポート文だけ掲載。それなりの規模になってきたので、プログラム全体は最後に掲載します。

module Machine(
  --テープの値 T0 または T1
  TapeValue(..),
  --Machineモナド開始関数
  startMachine,
  --ヘッドの移動
  moveFront,
  moveForward,
  --テープ値操作
  writeTape,
  readTape,
  --ヘッドの値操作
  writeState,
  readState
  ) where


これで、モナド内で常にチューリングマシンの状態が保持される事が保証されました。さっそく試してみましょう。

module Main where
import Control.Monad(replicateM_)
import Machine 

test1 = do
  moveFront
  writeTape T1
  moveFront 

test2 = do
  moveFront >> moveFront
  writeTape T1
  tmp <- readTape
  moveForward >> moveForward 
  writeTape tmp
  moveForward >> moveForward
  writeTape tmp
  moveFront >> moveFront
  writeTape T0
  
test3 = do
  replicateM_ 10 moveFront
  replicateM_ 5 moveForward
  writeTape T1

main = do
  putStrLn.show $ startMachine test1
  putStrLn.show $ startMachine test2
  putStrLn.show $ startMachine test3

実行結果：

$ runghc Main.hs
|0| 1 0 
1 0 |0| 0 1 
0 0 0 0 0 |1| 0 0 0 0 0

テープの移動や読み書きはバッチリですね。

ヘッドのステータスが正しく読み書きできているかどうかは、ghciで確認できます。

*Machine> let init = MachineState (Tape [] [T0]) 0
*Machine> runMachine (do{ writeState 1; }) init
((),MachineState |0|  1)
*Machine> runMachine (do{ writeState 1; x <- readState; return x }) init
(1,MachineState |0|  1)
*Machine> runMachine (do{ writeState 1; x <- readState; writeState 10; return x }) init
(1,MachineState |0|  10)


今後は、入出力と併用できるようにモナド変換子にする事も考えなくてはいけないので、先はまだまだ長いです。というかそもそもモナド変換子の仕組みがまだよく解っていないので、まずは使えるようにする所からですね。

Machine.hs 全体：

module Machine(
  --テープの値 T0 または T1
  TapeValue(..),
  --Machineモナド開始関数
  startMachine,
  --ヘッドの移動
  moveFront,
  moveForward,
  --テープ値操作
  writeTape,
  readTape,
  --ヘッドの値操作
  writeState,
  readState
  ) where

------------------------------------------------
-- データ定義 
------------------------------------------------
--テープの値
data TapeValue = T0 | T1 deriving Eq
instance Show TapeValue where
  show T0 = "0"
  show T1 = "1"

--無限長の長さを持つテープ
data Tape = Tape [TapeValue] [TapeValue] deriving Eq
instance Show Tape where
  show (Tape front forward) = 
    toStr (reverse front) ++ "|" ++ show (head forward) ++ "| " ++ toStr (tail forward)
    where toStr l = concat $ map (\v -> show v ++ " ") l

--ヘッドの状態 (テープ、ステータス)
data MachineState = MachineState { msTape :: Tape, msState :: Int } deriving Show

--チューリングマシンモナド　Stateモナドと同様の仕組みで MachineState を保持する
newtype Machine a = Machine { runMachine :: MachineState -> (a,MachineState) }
instance Functor Machine where
  fmap f m = Machine $ \s -> let
    (a,s') = runMachine m s
    in (f a,s')
instance Monad Machine where
  return a = Machine $ \s -> (a,s)
  m >>= k = Machine $ \s -> let
    (a,s') = runMachine m s
    in runMachine (k a) s'

--モナドを使った処理の開始
startMachine :: Machine a -> Tape
startMachine f = msTape.snd.(runMachine f) $ MachineState (Tape [] [T0]) 0

------------------------------------------------
-- 状態操作用関数 
------------------------------------------------
--テープ移動
moveFront :: Machine ()
moveFront = Machine $ \s -> ((),mapMachine mFront s)
  where mFront (Tape [] forward) = Tape [] (T0 : forward)
        mFront (Tape front forward) = Tape (tail front) (head front : forward)

moveForward :: Machine ()
moveForward = Machine $ \s -> ((),mapMachine mForward s)
  where mForward (Tape front (position : [])) = Tape (position : front) [T0]
        mForward (Tape front forward) = Tape (head forward : front) (tail forward)

--読み書き
writeTape :: TapeValue -> Machine ()
writeTape v = Machine $ \s -> ((),mapMachine (wTape v) s)
  where wTape val (Tape front forward) = Tape front (val : tail forward)

readTape :: Machine TapeValue 
readTape = Machine $ \s -> (rTape $ msTape s,s)
  where rTape (Tape _ v) = head $ v

--ステータスの読み書き
writeState :: Int -> Machine ()
writeState v = Machine $ \s -> ((),seted s)
  where seted (MachineState t _) = MachineState t v 

readState :: Machine Int
readState = Machine $ \s -> (getState s,s)
  where getState (MachineState _ v) = v 

-------- 補助
mapMachine :: (Tape -> Tape) -> MachineState -> MachineState 
mapMachine f (MachineState t s) = MachineState (f t) s

2012/01/29 リファクタリングしたものに差し替えました