qipa turing machine

Main.hs

{-# LANGUAGE NoMonomorphismRestriction #-}

module Main where

import Control.Monad.State

data Tape a = Tape { left :: [a]
                   , right :: [a]
                   }

data Action a = MoveLeft
              | MoveRight
              | WriteSymbol a
              | PrintSymbol

type TuringM a = StateT (Tape a) IO
type Table s a = [( (s, a), (s, Action a) )]

class InitialTape a where
  emptySymbol :: a
  initialTape :: Tape a
  initialTape = let z = repeat emptySymbol in Tape z z

instance InitialTape Integer where
  emptySymbol = 0

moveLeft :: TuringM a ()
moveLeft = modify (\(Tape (l:ls) rs) -> Tape ls (l:rs))

moveRight :: TuringM a ()
moveRight = modify (\(Tape ls (r:rs)) -> Tape (r:ls) rs)

writeSymbol :: a -> TuringM a ()
writeSymbol x = modify (\(Tape ls (_:rs)) -> Tape ls (x:rs))

getSymbol :: TuringM a a
getSymbol = gets (\(Tape _ (a:_)) -> a)

printSymbol :: Show a => TuringM a ()
printSymbol = getSymbol >>= liftIO . print

runAction :: Show a => Action a -> TuringM a ()
runAction MoveLeft = moveLeft
runAction MoveRight = moveRight
runAction (WriteSymbol a) = writeSymbol a
runAction PrintSymbol = printSymbol

runTuring :: InitialTape a => TuringM a b -> IO b
runTuring t = evalStateT t initialTape

makeTuring :: Show a => ((s,a) -> Maybe (s,Action a)) -> s -> TuringM a ()
makeTuring fun st = loop st
  where loop s = do
          a <- getSymbol
          let res = fun (s, a)
          case res of
            Just (s', ac) -> runAction ac >> loop s'
            Nothing -> return ()

tableTuring :: (Show a, Eq a, Eq s) => [( (s, a), (s, Action a) )] -> s -> TuringM a ()
tableTuring table s = makeTuring (flip lookup table) s

exampleTable :: Table Integer Integer
exampleTable = [ ( (0,0), (1, MoveRight) )
               , ( (1,0), (1, WriteSymbol 1) )
               , ( (1,1), (2, PrintSymbol) )
               ]

exampleTuring = tableTuring exampleTable 0

main = runTuring exampleTuring