module Data.Turing (
TuringMachine
, mkTuringMachine
, Movement (..)
, TransitionFunction
, MachineResult (..)
, run
, runFor
) where
import Data.List (unfoldr, genericTake)
data TuringMachine s q = TM q [q] (TransitionFunction s q)
mkTuringMachine :: TransitionFunction s q -> q -> [q] -> TuringMachine s q
mkTuringMachine f initState acceptingStates = TM initState acceptingStates f
data Movement = MoveLeft
| MoveRight
| DontMove
deriving (Eq, Show)
type TransitionFunction s q = (q, Maybe s) -> Maybe (q, Maybe s, Movement)
data MachineResult = Accept
| Reject
deriving (Eq, Show)
data MachineEnvironment s q = MS [Maybe s] [Maybe s] q
run :: Eq q => TuringMachine s q -> [s] -> MachineResult
run (TM initState acceptingStates f) input =
let executionStates = stateSequence initState f input
terminationState = last executionStates
in if terminationState `elem` acceptingStates then Accept else Reject
runFor :: (Integral i, Eq q) => i -> TuringMachine s q -> [s] -> Maybe MachineResult
runFor maxSteps (TM initState acceptingStates f) input =
let executionStates = genericTake (maxSteps + 2) (stateSequence initState f input)
terminationState = last executionStates
in if length executionStates > fromIntegral maxSteps + 1
then Nothing
else Just $ if terminationState `elem` acceptingStates then Accept else Reject
step :: TransitionFunction s q -> MachineEnvironment s q -> Maybe (MachineEnvironment s q)
step f (MS (l:ls) (r:rs) currentState) =
case f (currentState, r) of
Nothing -> Nothing
Just (newState, writeValue, movement) -> case movement of
MoveLeft -> Just $ MS ls (l:writeValue:rs) newState
MoveRight -> Just $ MS (writeValue:l:ls) rs newState
DontMove -> Just $ MS (l:ls) (writeValue:rs) newState
stateSequence :: q -> TransitionFunction s q -> [s] -> [q]
stateSequence initState f input = initState : (unfoldr (exec f) initialEnv)
where initialEnv = MS (repeat Nothing) (map Just input ++ repeat Nothing) initState
exec f e = case step f e of
Nothing -> Nothing
Just ne@(MS _ _ s) -> Just (s, ne)