RosettaCodeData/Task/Universal-Turing-machine/Haskell/universal-turing-machine-6.hs

import Control.Monad.State
import Data.List (intersperse, nub, find)

data TapeMovement = MoveLeft | MoveRight | Stay deriving (Show, Eq)
-- Rule = (state 1, input, output, movement, state 2)
type Rule a = (a, a, a, TapeMovement, a)
-- Execution = (tape position, current machine state, tape)
type Execution a = (Int, a, [a])
type Log a = [Execution a]
type UTM a b = State (Machine a) b

-- can work with data of any type
data Machine a = Machine
    { allStates :: [a] -- not used actually
    , initialState :: a  -- not used actually, initial state in "current"
    , finalStates :: [a]
    , symbols :: [a]     -- not used actually
    , blank :: a
    , noOpSymbol :: a    -- means: don't change input / don't shift tape
    , rules :: [Rule a]
    , current :: Execution a
    , machineLog :: Log a -- stores state changes from last to first
    , machineLogActive :: Bool -- if true, intermediate steps are stored
    , noRuleMsg :: a -- error symbol if no rule matches
    , stopMsg :: a } -- symbol to append to the end result
    deriving (Show)

-- it is not checked whether the input and output symbols are valid
apply :: Eq a => Rule a -> UTM a a
apply (_, _, output, direction, stateUpdate) = do
    m <- get
    let (pos, currentState, tape) = current m
        tapeUpdate = if output == noOpSymbol m
            then tape
            else take pos tape ++ [output] ++ drop (pos + 1) tape
        newTape
            | pos == 0 && direction == MoveLeft = blank m : tapeUpdate
            | succ pos == length tape && direction == MoveRight = tapeUpdate ++ [blank m]
            | otherwise = tapeUpdate
        newPosition = case direction of
            MoveLeft -> if pos == 0 then 0 else pred pos
            MoveRight -> succ pos
            Stay -> pos
        newState = if stateUpdate == noOpSymbol m
            then currentState
            else stateUpdate
    put $! m { current = (newPosition, newState, newTape) }
    return newState

-- rules with no-operation symbols and states must be underneath
-- rules with defined symbols and states
lookupRule :: Eq a => UTM a (Maybe (Rule a))
lookupRule = do
    m <- get
    let (pos, currentState, tape) = current m
        item = tape !! pos
        isValid (e, i, _, _, _) = e == currentState &&
            (i == item || i == noOpSymbol m)
    return $! find isValid (rules m)

msgToLog :: a -> UTM a ()
msgToLog e = do
    m <- get
    let (pos, currentState, tape) = current m
    put $! m { machineLog = (pos, currentState, tape ++ [e]) : machineLog m }

toLog :: UTM a ()
toLog = do
    m <- get
    put $! m { machineLog = current m : machineLog m }

-- execute the machine's program
execute :: Eq a => UTM a ()
execute = do
    toLog -- log the initial state
    loop
    where
        loop = do
            m <- get
            r <- lookupRule -- look for a matching rule
            case r of
                Nothing -> msgToLog (noRuleMsg m)
                Just rule -> do
                    stateUpdate <- apply rule
                    if stateUpdate `elem` finalStates m
                        then msgToLog (stopMsg m)
                        else do
                            when (machineLogActive m) toLog
                            loop

---------------------------
-- convenient functions
---------------------------

-- run execute, format and print the output
runMachine :: Machine String -> IO ()
runMachine m@(Machine { current = (_, _, tape) }) =
    if null tape
        then putStrLn "NO TAPE"
        else case machineLog $ execState execute m of
                [] -> putStrLn "NO OUTPUT"
                xs -> do
                    mapM_ (\(pos, _, output) -> do
                        let formatOutput = concat output
                        putStrLn formatOutput
                        putStrLn (replicate pos ' ' ++ "^")) $ reverse xs
                    putStrLn $ show (length xs) ++ " STEPS. FINAL STATE: " ++
                        let (_, finalState, _) = head xs in show finalState

-- convert a string with format state+space+input+space+output+space+
-- direction+space+new state to a rule
toRule :: String -> Rule String
toRule xs =
    let [a, b, c, d, e] = take 5 $ words xs
        dir = case d of
            "l" -> MoveLeft
            "r" -> MoveRight
            "*" -> Stay
    in  (a, b, c, dir, e)

-- load a text file and parse it to a machine.
-- see comments and examples
-- lines in the file starting with ';' are header lines or comments
-- header and input lines must contain a ':' and after that the content to be parsed
-- so there can be comments between ';' and ':' in those lines
loadMachine :: FilePath -> IO (Machine String)
loadMachine n = do
    f <- readFile n

    let ls = lines f
        -- header: first 4 lines
        ([e1, e2, e3, e4], rest) = splitAt 4 ls
        -- rules and input: rest of the file
        re = map toRule . filter (not . null) $ map (takeWhile (/= ';')) rest
        ei = head . words . tail . snd $ break (== ':') e1
        va = head . words . tail . snd $ break (== ':') e3
        ci = words . intersperse ' ' . tail . snd $ break (== ':') $ last rest

    return Machine
        { rules = re
        , initialState = ei
        , finalStates = words . tail . snd $ break (== ':') e2
        , blank = va
        , noOpSymbol = head . words . tail . snd $ break (== ':') e4
        , allStates = nub $ concatMap (\(a, _, _, _, e) -> [a, e]) re
        , symbols = nub $ concatMap (\(_, b, c, _, _) -> [b, c]) re
        , current = (0, ei, if null ci then [va] else ci)
        -- we assume
        , noRuleMsg = "\tNO RULE." -- error: no matching rule found
        , stopMsg = "\tHALT." -- message: machine reached a final state
        , machineLog = []
        , machineLogActive = True }