A simple turing machine simulator.

TuringMachine.hs

{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
module TuringMachine where
import           Control.Applicative
import           Control.Arrow       hiding (left, right)
import           Control.Lens        hiding (Tape, Zipper, left, right)
import           Data.List.Lens
import qualified Data.Map            as M
import           Data.Maybe

data Instruction s = GoLeft
                   | GoRight
                   | Clear
                   | Write s
                     deriving (Show, Eq, Ord)

newtype TuringMachine q s = TM { unTM :: M.Map (q, Maybe s) (Instruction s, q) }
type SimpleMachine = TuringMachine Int Char

type Zipper a = ([a], [a])
type Tape   a = Zipper (Maybe a)

right :: Tape a -> Tape a
right ([x], rs)  = ([Nothing], x:rs)
right (x:ls, rs) = (ls, x:rs)
right ([], rs)   = ([Nothing], rs)

left :: Tape a -> Tape a
left (xs, [y]) = (y:xs, [Nothing])
left (xs, y:ys) = (y:xs, ys)
left (xs, []) = (Nothing:xs, [])

getState :: Tape a -> Maybe a
getState (x:_, _) = x
getState ([],  _) = Nothing

toTape :: [a] -> Tape a
toTape [] = ([Nothing], [])
toTape as = (map Just as, [])

fromTape :: Tape a -> [Maybe a]
fromTape (xs, ys) = dropWhile isNothing (reverse ys) ++ reverse (dropWhile isNothing $ reverse xs)

runTM :: (Ord a, Ord q) => TuringMachine q a -> q -> Tape a -> (Tape a, q)
runTM tm q tp =
  case eval q tp tm of
    Nothing        -> (tp, q)
    Just (tp', q') -> runTM tm q' tp'

eval :: (Ord q, Ord a) => q -> Tape a -> TuringMachine q a -> Maybe (Tape a, q)
eval q tape tm = sub <$> step q tape tm
  where
    sub (Clear, q')     = (_1 %~ _head .~ Nothing $ tape, q')
    sub (GoLeft,  q')   = (left tape, q')
    sub (GoRight, q')   = (right tape, q')
    sub (Write c, q') = (_1 %~ _head .~ Just c $ tape, q')

step :: (Ord q, Ord a) => q -> Tape a -> TuringMachine q a -> Maybe (Instruction a, q)
step q tape (TM dic) = M.lookup (q, getState tape) dic

makeTM :: (Ord q, Ord a) => [(q, Maybe a, Instruction a, q)] -> TuringMachine q a
makeTM d = TM $ M.fromList $ map ((view _1 &&& view _2) &&& (view _3 &&& view _4)) d

makeTMSimple :: (Ord q, Ord a) => [(q, a, Instruction a, q)] -> TuringMachine q a
makeTMSimple d = TM $ M.fromList $ map ((view _1 &&& views _2 Just) &&& (view _3 &&& view _4)) d

zeroOneEqual :: SimpleMachine
zeroOneEqual = makeTMSimple [(0, '0', Write 'X', 1)
                            ,(0, 'Y', GoRight, 5)
                            ,(1, 'X', GoRight, 2)
                            ,(2, '0', GoRight, 2)
                            ,(2, 'Y', GoRight, 2)
                            ,(2, '1', Write 'Y', 3)
                            ,(3, 'Y', GoLeft, 4)
                            ,(4, 'Y', GoLeft, 4)
                            ,(4, '0', GoLeft, 4)
                            ,(4, 'X', GoRight, 0)
                            ,(5, '1', GoRight, -1)
                            ,(5, 'Y', GoRight, 5)
                            ]

headTailMarker :: SimpleMachine
headTailMarker = makeTM [(0, Just '1', GoLeft, 0)
                        ,(0, Nothing , Write 'H', 1)
                        ,(1, Just 'H', GoRight, 1)
                        ,(1, Just '1', GoRight, 1)
                        ,(1, Nothing, Write 'T', 2)
                        ]