Sync

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

@@ -0,0 +1,152 @@
+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 }