Simulate a turing machine using a state monad and I/O

> module Turing where

> import StateMonad_IO


Basic components of a turing machine

> type State = Int

> data Direction = L | R
>                deriving (Show, Ord, Eq)

> data TMProgram a = TMProgram {
>   start :: State,
>   final :: [State],
>   delta :: [((State, a), (State, a, Direction))]
> }


Every tape alphabet must contain a distinct blank symbol

> class HasBlank b where
>   isBlank :: b -> Bool


An ID (instantaneuos description, H&U, p. 148) of a turing machine
with tape alphabet of type a

> data HasBlank a => TMConfiguration a = TMC {
>   left  :: [a],
>   state :: Int,
>   halt  :: Bool,
>   right :: [a]
> } deriving (Eq)

> instance (HasBlank a, Show a) => Show (TMConfiguration a) where
>   -- only show until the first blank
>   showsPrec i TMC { left = l, state = q, right = r } =
>     (showsPrec i . reverse $ takeWhile (not . isBlank) l) .
>     shows ">" .
>     (showsPrec i q) .
>     shows "<" .
>     (showsPrec i $ takeWhile (not . isBlank) r)

>   {--
>    -- If sb wants to see the first of the blanks
>    --
>     (showsPrec i . (\(x,y:ys) -> y : reverse x) $ span (not . isBlank) l) .
>     shows ">" .
>     (showsPrec i q) .
>     shows "<" .
>     (showsPrec i . (\(x,y:ys) -> x ++ [y]) $ span (not . isBlank) r)
>   --}



To read the current configuration from a TM

> readConf :: Monad m => StateTransformerM s m s
> readConf =  STM (\conf ->
>   return (conf, conf))



Start a TM given by "tmProg" on input "input" after computing the
start configuration

> startTM tmProg@TMProgram { start = startState,
>                            final = finalStates,
>                            delta = delta }      input =
>   do
>     apply
>       (tm delta finalStates)
>       -- left and right of the tape are unbounded
>       TMC { left  = repeat Blank,
>             state = startState,
>             halt  = False,
>             right = input ++ repeat Blank }
>     return ()



Execute the steps of a TM given by the step function and the final
states

> tm delta finalStates = do
>   conf <- readConf
>   if halt conf
>    then
>     if not $ (state conf) `elem` finalStates
>      then do
>       ioPrint "not accepted"
>      else do
>       ioPrint "accepted"
>    else do
>     ioPrint conf
>     let
>       action conf@TMC { left = ls@(l:ls'), state = q, right = rs@(r:rs') } =
>         return $ case (lookup (q, r) delta) of
>           Nothing -> ((), conf { halt = True })
>           Just (q', x, L) -> ((),
>             conf { left = ls', state = q', right = x:rs })
>           Just (q', x, R) -> ((),
>             conf { left = x:ls, state = q', right = rs' })
>     STM action
>     k <- ioGetChar
>     -- any key but 'q' executes a further step
>     if k /= 'q'
>      then do
>       tm delta finalStates
>      else do
>       ioPrint "aborted"




Example

> data Binary = Null | One | Blank
>             deriving (Eq, Show)


> instance HasBlank Binary where
>   isBlank Blank = True
>   isBlank _     = False


> tmProg :: TMProgram Binary
> tmProg =  TMProgram {
>   start = 0,
>   final = [0],
>   delta = [((0, One), (1, One, R)),
>            ((0, Null), (0, Null, R)),
>            ((1, Null), (0, Null, R)),
>            ((1, One), (1, One, R))]
> }


> main :: Eq (Int, Binary) => IO ()
> main = startTM tmProg [One, Null, One, Null, Null, One] -- sample call