Classy Turing machines

Turing.hs

{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, ScopedTypeVariables #-}
module TuringMachine where

import Control.Monad.State.Lazy
import Data.Array.ST
import Data.Array
import Data.Default
import Control.Monad.ST
import Control.Arrow ((&&&))

-- |Possible moves on the tape
data Shift = ShiftLeft | ShiftRight deriving (Read, Show, Eq, Ord)

-- |Class for a tape monad with symbols in sym.
class Monad m => Tape m sym | m -> sym where
    shift :: Shift -> m ()
    scan  :: m sym       -- |Read the current symbol
    store :: sym -> m () -- |Write a symbol

-- |The state of a tape backed by an array, with a "cursor" specifying an
-- index
data ArrayTapeState arr ix el = ATS {
    atCursor :: ix,
    atTape :: arr ix el
}

-- |Tape backed by an ST array. This is unsafe if the index isn't contained
-- in the array, which can happen if (ix ~ Int). This might be fixed by
-- using (i ~ Z/nZ) where n is the length of the array, thus making
-- the tape circular.
--
-- Type variables:
-- - ix: Type of the array index
-- - sym: Type of symbols on the tape
-- - s: Type of ST state thread
type ArrayTape ix sym s = StateT (ArrayTapeState (STArray s) ix sym) (ST s)

instance (Ix ix, Enum ix) => Tape (ArrayTape ix sym s) sym where
    shift ShiftLeft  = modify (\st -> st {atCursor = pred . atCursor $ st})
    shift ShiftRight = modify (\st -> st {atCursor = succ . atCursor $ st})
    scan = do
        (ATS ix arr) <- get
        lift $ readArray arr ix

    store sym = do
        (ATS ix arr) <- get
        lift $ writeArray arr ix sym

data TM state sym = TM {
    tmInit :: state,
    tmTrans :: state -> sym -> Maybe (state, sym, Shift)
}

-- |Run a Turing machine, with effects in some tape monad
runTM :: Tape m sym => TM state sym -> m ()
runTM tm = do
    sym <- scan
    case tmTrans tm (tmInit tm) sym of
        Just (st, sym', sh) -> do
            store sym'
            shift sh
            runTM $ tm {tmInit = st}
        Nothing -> return ()

-- Implementation of a two-state, two-symbol Turing machine
data TMSym = Blank | One deriving (Read, Show, Eq, Ord)
data TMState = StZero | StOne deriving (Read, Show, Eq, Ord)

instance Default TMSym where
    def = Blank

twoStateTM :: TM TMState TMSym
twoStateTM = TM {
    tmInit = StZero,
    tmTrans = \st sym -> case (st, sym) of
        (StZero, Blank) -> Just (StOne,  One, ShiftRight)
        (StOne,  Blank) -> Just (StZero, One, ShiftLeft)
        (StZero, One)   -> Just (StOne,  One, ShiftLeft)
        (StOne,  One)   -> Nothing
}

-- |Convenience function to create blank tapes
initArrayTapeState :: Default sym => Int
                                  -> Int
                                  -> ST s (ArrayTapeState (STArray s) Int sym)
initArrayTapeState size index = do
    arr <- newListArray (0, size - 1) . replicate size $ def
    return ATS {atCursor = index, atTape = arr}

-- |Helper function to unwrap the StateT monad transformer
-- and freeze the array holding the tape.
runArrayTapeState :: Ix ix => ArrayTape ix sym s a
                           -> ArrayTapeState (STArray s) ix sym
                           -> ST s (ArrayTapeState Array ix sym)
runArrayTapeState tapeAction initTape = do
    tapeState <- execStateT tapeAction initTape
    let mutArr = atTape tapeState
    (frozenArr :: Array ix sym) <- freeze mutArr
    return $ ATS (atCursor tapeState) frozenArr

-- Run a Turing machine in the ST monad. Freeze the array and print
-- out a pair (i, arr) where arr is an array representation of the
-- final contents of the tape, and i is an index representing the tape
-- head.
main = print . (atCursor &&& atTape) $ runST $ do
    -- Tape of 10 elements
    initState <- initArrayTapeState 10 4
    runArrayTapeState (runTM twoStateTM) initState