うにゃーーーー

Haskellでなんちゃって Turing Machine 作ろうとしたら謎仕様になったとうという話。
もともと monad 書く練習しようと思って色々データいじっていたんだけど、かなり脱線したので一応書いておきます。
実はこの辺は教科書で勉強したことがなくて、かなり記憶に頼ったおれおれマシン設計になってます。
以下記述：

data Alphabet = Empty | EOF | TChar Char deriving (Show, Eq)
type Tape = Int -> Alphabet
type Head = Int
data Control = NotMove | LeftMove | RightMove | Write {write :: Alphabet} deriving (Show, Eq)
data State = Initial | Halt | FreeState {num :: Int} deriving (Show, Eq)
type MutState = (Head, State)

type TransFunc = State -> Alphabet -> (Control, State)

data TM = TM {stNum :: Int,
              tape :: Tape,
              state :: MutState,
              transFunc :: TransFunc}

readHead :: TM -> Alphabet
readHead m = let t = tape m
                 h = fst $ state m
             in  t $ h

nextTape :: TM -> Tape
nextTape m = let st = snd $ state m
                 h = fst $ state m
                 tp = tape m
                 a = readHead m
                 tr = transFunc m
                 c = fst $ tr st a
             in  case c of NotMove -> tp
                           LeftMove -> tp
                           RightMove -> tp
                           _ -> (\n -> if n == h then (write c) else tp $ n)

nextState :: TM -> MutState
nextState m = let st = snd $ state m
                  a = readHead m
                  tr = transFunc m
                  c = fst $ tr st a
                  nextst = snd $ tr st a
                  h = fst $ state m
              in  case c of LeftMove -> (h-1, nextst)
                            RightMove -> (h+1, nextst)
                            _ -> (h, nextst)

moveTM :: TM -> TM
moveTM m = let nextStN = stNum m
               nextT = nextTape m
               nextS = nextState m
               nextTF = transFunc m
           in  TM {stNum = nextStN,
                   tape = nextT,
                   state = nextS,
                   transFunc = nextTF}

applyWhile :: (a -> Bool) -> (a -> a) -> a -> a
applyWhile b f x = if b x == False then x else applyWhile b f (f $ x)

runTM :: TM -> (Tape, Head)
runTM m = let lastm = applyWhile (\tm -> (snd $ state tm) /= Halt) moveTM $ m
          in  (tape lastm, fst $ state lastm)

showTape :: Tape -> [Alphabet]
showTape t = takeWhile (\a -> a /= EOF) $ map t [0..]

newTapeWithln :: Int -> Tape
newTapeWithln l = \n -> if n == l then EOF else Empty

使用出来るアルファベットAlphabetは空記号Empty,EOF,とChar型のものに限ることとしています。
テープは両側に無限に伸びるテープの表現として型Int->Alphabetを使います。
命令Controlは不動、左移動、右移動、テープへの書込からなります。
状態Stateは始状態Initial, 終状態Halt, あと自由に使える状態からなります。
このもとで、Turing Machine は状態集合、テープ、headの位置を持った状態、遷移関数の四つ組からなるものとして定義します。
ここで、遷移関数の型はState->Alphabet->(Control, State)であり、現在の状態とheadの読むテープのアルファベットを引数として、命令と遷移後の状態の組を返すものです。

まああとは自明でしょう。
普通はEOFなんて記号は使わないのですが今回はテープの表示の便宜上導入しました。
最後のnewTapeWithln関数は引数lに対してl番目にEOFを書き込んだだけの空テープです。

試しに、EOFが出現するまで空テープに'a'を書き込むsampleTM1と、2進数の1bit-shiftをするsampleTM2を書いておきます。

{- The Turing Machine which prints 'a's until EOF appears -}
sampleTM1 = let sampleStN1 = 1
                sampleT1 = newTapeWithln 5 -- represents [Empty, Empty, Empty, Empty, Empty, EOF]
                sampleS1 = (0, Initial)
                sampleTF1 st a = case (st,a) of (Initial, _) -> (NotMove, FreeState 0)
                                                (FreeState 0, TChar 'a') -> (RightMove, FreeState 0)
                                                (FreeState 0, EOF) -> (NotMove, Halt)
                                                (FreeState 0, _) -> (Write (TChar 'a'), FreeState 0)
                                                (_,_) -> (NotMove, Halt)
            in  TM {stNum = sampleStN1,
                    tape = sampleT1,
                    state = sampleS1,
                    transFunc = sampleTF1}

{- The Turing Machine which shifts a binary sequence(i.e., this corresponds to numeric Double-procedure) -}
sampleTM2 = let sampleStN2 = 6
                sampleT2 = \n -> case n of 0 -> TChar '0'
                                           1 -> TChar '1'
                                           2 -> TChar '0'
                                           3 -> TChar '1'
                                           _ -> newTapeWithln 4 $ n
                {- sampleT2 represents [0,1,0,1, EOF] -}
                sampleS2 = (0, Initial)
                sampleTF2 st a = case (st,a) of (Initial, _) -> (NotMove, FreeState 0)
                                                (FreeState 0, TChar '0') -> (Write (TChar '0'), FreeState 1)
                                                (FreeState 0, TChar '1') -> (Write (TChar '0'), FreeState 2)
                                                (FreeState 1, _) -> (RightMove, FreeState 3)
                                                (FreeState 2, _) -> (RightMove, FreeState 4)
                                                (FreeState 3, TChar '0') -> (Write (TChar '0'), FreeState 1)
                                                (FreeState 3, TChar '1') -> (Write (TChar '0'), FreeState 2)
                                                (FreeState 3, EOF) -> (Write (TChar '0'), FreeState 5)
                                                (FreeState 4, TChar '0') -> (Write (TChar '1'), FreeState 1)
                                                (FreeState 4, TChar '1') -> (Write (TChar '1'), FreeState 2)
                                                (FreeState 4, EOF) -> (Write (TChar '1'), FreeState 5)
                                                (FreeState 5, EOF) -> (NotMove, Halt)
                                                (FreeState 5, Empty) -> (Write EOF, FreeState 5)
                                                (FreeState 5, _) -> (RightMove, FreeState 5)
                                                (_, _) -> (NotMove, Halt)
            in TM {stNum = sampleStN2,
                   tape = sampleT2,
                   state = sampleS2,
                   transFunc = sampleTF2}

結果は以下の通り：

*Main> showTape $ fst $ runTM sampleTM1
[TChar 'a',TChar 'a',TChar 'a',TChar 'a',TChar 'a']

*Main> showTape $ fst $ runTM sampleTM2
[TChar '0',TChar '0',TChar '1',TChar '0',TChar '1']

はい、謎設計でごめんなさい。うんコード極まりました。