Haskell でチューリングマシン的な何か inspired by http://d.hatena.ne.jp/its_out_of_tune/20111221/1324491653

Tape.hs

module Tape(
  Tape(), initTape, moveRight, moveLeft,
  readHead, writeHead, modifyHead) where

import Data.List (intercalate)

data InfList a = InfList a (InfList a) | Repeat a

splitHead :: InfList a -> (a, InfList a)
splitHead (InfList a as) = (a, as)
splitHead (Repeat a)     = (a, Repeat a)

instance Eq a => Eq (InfList a) where
  Repeat a == Repeat b = (a == b)
  as == bs = (a == b) && (as' == bs')
    where (a, as') = splitHead as
          (b, bs') = splitHead bs

take' :: Int -> InfList a -> [a]
take' n lst | n <= 0    = []
            | otherwise = let (x, xs) = splitHead lst in
                            x : take' (n-1) xs

data Tape a = Tape { rightValues :: InfList a,
                     headValue   :: a,
                     leftValues  :: InfList a } deriving Eq

instance Show a => Show (Tape a) where
  show (Tape ls h rs) =
    intercalate " " $
      ["..."] ++
      map show (reverse $ take' 3 ls) ++
      ["|" ++ show h ++ "|"] ++
      map show (take' 3 rs) ++
      ["..."]

initTape :: a -> Tape a
initTape d = Tape (Repeat d) d (Repeat d)

moveRight :: Tape a -> Tape a
moveRight (Tape ls h rs) = Tape (InfList h ls) r rs'
  where (r, rs') = splitHead rs

moveLeft :: Tape a -> Tape a
moveLeft (Tape ls h rs) = Tape ls' l (InfList h rs)
  where (l, ls') = splitHead ls

readHead :: Tape a -> a
readHead = headValue

writeHead :: Tape a -> a -> Tape a
writeHead t h = t { headValue = h }

modifyHead :: Tape a -> (a -> a) -> Tape a
modifyHead t f = writeHead t $ f $ readHead t