Implementation of a simple Turing Machine.

TM.hs

module TM.TM where

import           Control.Monad.State        (State, evalState, get, put)
import           Control.Monad.Trans        (lift)
import           Control.Monad.Trans.Writer (WriterT, runWriterT, tell)
import           Data.List                  (intercalate, nub, (\\))
import qualified Data.Map                   as Map (Map, fromList, keys, lookup,
                                                    notMember, null, union)

newtype Tape = Tape { tapeList :: [CellContent] }

instance Show Tape where
    show (Tape s) = '|':(intercalate "|" (map show s) ++ "|")

data TapeState = TapeState { getTape :: Tape, position :: Int }

instance Show TapeState where
    show (TapeState tape pos) = show tape ++ "\n" ++ replicate (pos*2+1) ' ' ++ "^"

makeTS :: Tape -> TapeState
makeTS t = TapeState t (tapeLen t `div` 2)

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

data CellContent = Cell Char | Blank deriving (Ord, Eq)

instance Show CellContent where
    show (Cell c) = [c]
    show Blank    = " "

moveR :: TapeState -> TapeState
moveR (TapeState tape pos)
    | pos == (tapeLen tape - 1) = TapeState tape 0
    | otherwise                 = TapeState tape (pos + 1)

moveL :: TapeState -> TapeState
moveL (TapeState tape pos)
    | pos == 0  = TapeState tape (tapeLen tape - 1)
    | otherwise = TapeState tape (pos - 1)

move :: Direction -> TapeState -> TapeState
move L ts = moveL ts
move R ts = moveR ts
move S ts = ts

tapeLen :: Tape -> Int
tapeLen (Tape t) = length t

emptyTape :: Int -> Tape
emptyTape n = Tape $ replicate n Blank

tapeFromStr :: Int -> String -> Tape
tapeFromStr n s = let l = length s + n - 1
                   in Tape $ replicate l Blank ++ map Cell s ++ replicate n Blank

getCurChar :: TapeState -> CellContent
getCurChar (TapeState t p) = tapeList t !! p

setCharAt :: a -> [a] -> Int -> [a]
setCharAt el l i = take i l ++ [el] ++ drop (i+1) l

setCurChar :: CellContent -> TapeState -> TapeState
setCurChar c ts@(TapeState t p) = ts { getTape = Tape (setCharAt c (tapeList t) p) }

newtype TMState = TMState { getName :: String } deriving (Show, Eq, Ord)

type TransFun = Map.Map (TMState, CellContent) (TMState, CellContent, Direction) 

(==>) :: a -> b -> (a,b)
(==>) = (,)

data TM = TM { transFun :: TransFun,
               states :: [TMState],
               acceptingStates :: [TMState],
               initialState :: TMState }                              

numStates :: TM -> Int
numStates = length . states

type Log = [(TMState, TapeState)]

runTM :: Tape -> TM -> Bool
runTM t tm = fst (runTMLog t tm)

runTMLog :: Tape -> TM -> (Bool, Log)
runTMLog t tm = evalState (runWriterT . runS $ tm) (initialState tm, makeTS t)

writeAndMove :: CellContent -> Direction -> TapeState -> TapeState
writeAndMove c d ts = let ts' = setCurChar c ts
                       in move d ts'

runS :: TM -> WriterT Log (State (TMState, TapeState)) Bool
runS tm = do
     (cur, ts) <- lift get
     tell [(cur, ts)]
     case Map.lookup (cur, getCurChar ts) (transFun tm) of
         Nothing                 -> return $ cur `elem` acceptingStates tm
         (Just (next, out, dir)) -> do { lift $ put (next, writeAndMove out dir ts); runS tm }

invertTF :: [TMState] -> TMState -> TransFun -> (TransFun, Bool)
invertTF st qn tf = let chars = nub (map snd (Map.keys tf))
                        compl = Map.fromList [(qi, c) ==> (qn, Blank, S) | qi <- st, c <- chars, (qi, c) `Map.notMember` tf]
                     in if Map.null compl then (tf, False) else (Map.union compl tf, True)

oppositeTM :: TM -> TM
oppositeTM tm = let qn = TMState "q_"
                    (tf2, addState) = invertTF (states tm) qn (transFun tm)
                 in TM { transFun        = tf2,
                         states          = if addState then qn:states tm else states tm,
                         initialState    = initialState tm,
                         acceptingStates = if addState then qn : (states tm \\ acceptingStates tm)
                                                       else states tm \\ acceptingStates tm }

TMEx.hs

module TM.TMEx where

import           Control.Monad (when, forM_)
import qualified Data.Map      as Map (fromList)
import           System.Exit   (exitFailure)
import           TM.TM         (CellContent (Cell), Direction (R), TM (TM),
                                TMState (TMState), TransFun, acceptingStates,
                                initialState, oppositeTM, runTMLog, states,
                                tapeFromStr, transFun, (==>), getName)

q0 :: TMState
q0 = TMState "q0"
q1 :: TMState
q1 = TMState "q1"

oddTf :: TransFun
oddTf = Map.fromList [(q0, Cell '0') ==> (q0, Cell '0', R),
                      (q0, Cell '1') ==> (q1, Cell '1', R),
                      (q1, Cell '0') ==> (q0, Cell '0', R),
                      (q1, Cell '1') ==> (q1, Cell '1', R)]

oddTM :: TM
oddTM = TM { transFun        = oddTf,
             states          = [q0, q1],
             initialState    = q0,
             acceptingStates = [q1] }

evenTM :: TM
evenTM = oppositeTM oddTM

negateTf :: TransFun
negateTf = Map.fromList [(q0, Cell '0') ==> (q0, Cell '1', R),
                         (q0, Cell '1') ==> (q0, Cell '0', R)]
                         
negateTM :: TM
negateTM = TM { transFun        = negateTf,
                states          = [q0],
                initialState    = q0,
                acceptingStates = [q0] }

notValid :: String -> Bool
notValid = any (\e -> e /= '0' && e /= '1')

main :: IO ()
main = do
    putStrLn "Binary String:"
    line <- getLine
    when (notValid line) (putStrLn "Invalid input!" >> exitFailure)
    let tape = tapeFromStr 1 line
        (_, logTM) = runTMLog tape negateTM
    forM_ logTM $ \(st, ts) -> do
        putStrLn (getName st)
        print ts
    --putStrLn $ "The number " ++ line ++ (if result then " is " else " is not ") ++ "even."