Turing Machine interpreter written in Haskell

Turing Machine descriptions are passed to the program in the form of a config file containing a description of the transition function. A line starting with '#' is treated as a comment and ignored. Check the enclosed sample configurations for the layout of the machine descriptions.

The second parameter gives the initial input on which to run the Turing Machine. This is the blank symbol ('⎵') by default.

Here, have an example:

~/turing-hs % ./turing ./busybeaver3-2 "⎵1"  
╭A ╮  
╰⎵1╯  
╭ B╮  
╰11╯  
╭  B╮  
╰11⎵╯  
╭   C╮  
╰11⎵⎵╯  
╭  C ╮  
╰11⎵1╯  
╭ C  ╮  
╰1111╯  
╭A   ╮  
╰1111╯  
╭ H  ╮  
╰1111╯  

Caveats

• Technically, the config file is redundant - alphabet and state list can be extracted from the function table alone. I haven't gotten around to fixing this yet
• Spacing is crucial in the function table - ('⎵',L,"A") is a legal transition, ('⎵', L, "A") isn't.

-- Turing machine interpreter written in haskell
import System.IO
import System.Environment
import Data.List

type Symbol = Char
type State = String
data Direction = L | R | N deriving (Read, Show)
blankSym = '⎵'

-- Formal definition of a Turing Machine as a 7-tuple
-- (Q, Γ, ⎵, Σ, ð, q0, F)
data Automaton = Automaton {
	states :: [State],
	tapeAlpha :: [Symbol],
	blankSymbol :: Symbol,
	inputAlpha :: [Symbol],
	delta :: (State -> Symbol -> (Symbol, Direction, State)),
	startState :: State,
	acceptStates :: [State]
}

-- Data type for the state of an operating turing machine
data OpState = OpState {
	tape :: [Symbol],
	headPosition :: Int,
	machineState :: State
} deriving (Read)

instance Show OpState where
	show (OpState tape headPosition machineState) =
		'╭'
		: (take headPosition spaces)
		++ machineState
		++ (take ((length tape) - (length machineState) - (headPosition)) spaces)
		++ "╮\n╰"
		++ tape
		-- We may have to fill up because of long state names
		++ (take (headPosition + (length machineState) - (length tape)) spaces)
		++ "╯"
		where spaces = repeat ' '

-- We need to do this to satisfy the Show typeclass
instance Show Automaton where
	show (Automaton q tAlpha blank iAlpha _ q0 acceptStates) =
		"("
		++ show q
		++ ", "
		++ show tAlpha
		++ ", "
		++ (blank
		: ", "
		++ iAlpha
		-- We really don't want to dump functions to stdout
		++ ", ð, "
		++ show acceptStates
		++ ")")


first :: (a, b, c) -> a
first (a, _, _) = a

second :: (a, b, c) -> b
second (_, b, _) = b

third :: (a, b, c) -> c
third (_, _, c) = c

-- This is for convenience
emptyMachine :: Automaton
emptyMachine = Automaton ["A"] ['a'] blankSym ['a'] (\x y -> (blankSym, N, "A")) "A" ["A"]

-- the logical state of a turing machine is given by its 'state' and the tape's state
step :: Automaton -> OpState -> Maybe OpState
step machine state =
	if (machineState state) `elem` (acceptStates machine)
		-- We're in a halting state, there's nowhere to go
		then Nothing
		else Just (handleState $ handleMovement $ handleOutput state)
			where
				handleOutput s = writeSymbol (first next) s
				handleMovement s = case second next of
					L -> moveLeft s
					N -> s
					R -> moveRight s
				handleState s = OpState (tape s) (headPosition s) (third next)
				next = (delta machine) (machineState state) ((tape state)!!(headPosition state))
	
	

moveLeft :: OpState -> OpState
moveLeft (OpState tape headPosition mState) =
	if headPosition == 0
		then OpState (blankSym:tape) 0 mState
		else OpState tape (headPosition - 1) mState


moveRight :: OpState -> OpState
moveRight (OpState tape headPosition mState) =
	OpState paddedTape (headPosition + 1) mState
		where paddedTape = if headPosition == length tape - 1
			then (tape ++ [blankSym])
			else tape


writeSymbol :: Symbol -> OpState -> OpState
writeSymbol sym (OpState tape headPosition mState) =
	OpState newTape headPosition mState
		where newTape = (take headPosition tape)
			++ [sym]
			++ (drop (headPosition + 1) tape)

main :: IO ()
main = do
	args <- getArgs
	-- if no parameter is given, we look for "conf" in the current directory
	let conf = if (length args) /= 0
		then args!!0
		else "./conf"
	let input = if (length args) < 2
		then [blankSym]
		else args!!1
	machine <- loadConf conf
	let startConfig = OpState input 0 (startState machine)
	putStrLn $ show startConfig
	simulateMachine machine startConfig

-- "Inner run loop", if you will
simulateMachine :: Automaton -> OpState -> IO ()
simulateMachine machine state = do
	case step machine state of
		Nothing       -> return ()
		Just newState -> do
			putStrLn $ show newState
			simulateMachine machine newState

-- Reads and parses config and returns an Automaton if the config was well-formed
loadConf :: FilePath -> IO Automaton
loadConf path = do
	rawConf <- readFile path
	let filteredConf = commentLess $ lines rawConf

	let states = read (filteredConf!!0) :: [State]
	let tAlphabet = read (filteredConf!!2) :: [Symbol]
	let iAlphabet = blankSym : tAlphabet
	let acceptStates = read (filteredConf!!1) :: [State]
	let delta = parseDelta $ map words $ drop 2 filteredConf
	let tm = Automaton states tAlphabet blankSym iAlphabet delta (states!!0) acceptStates
	return tm
		where
			commentLess [] = []
			commentLess (x:xs)
				| x == "" || (head x == '#') = commentLess xs
				| otherwise 				 = x:(commentLess xs)


-- Parses the function table of the transition function
-- The expected input is a list of rows, separated into words
parseDelta :: [[String]] -> (State -> Symbol -> (Symbol, Direction, State))
parseDelta funcTable state sym =
	let
		inputInd = case ind of
			Just val -> val + 1
			Nothing -> error "Transistion function definition not exhaustive: input symbol not found"
		-- Since we don't know which states are halting states, we can't just jump into one here.
		stateRow [] = error "transition Function definition not exhaustive: state not found"
		stateRow (x:xs) = if (head x) == state
			then x
			else stateRow xs
	in read ((stateRow funcTable)!!(inputInd)) :: (Symbol,Direction,State)
			where ind = elemIndex sym (map head (funcTable!!0))