Haskell Turing Machine

Turing.hs

{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}
module Turing where

import           Control.Applicative
import           Data.Foldable(asum)
import           Data.Map(Map)
import qualified Data.Map as Map
import           Data.Maybe

-- |State of the turing machine
type State
  = Int

-- |Single cell on a tape
data Cell
  = Blank
  | Zero
  | One
  deriving ( Eq, Ord, Show )

-- |Tape consists of multiple cells
type Tape
  = Map Int Cell

-- |Step taken by the turing machine
data Step
  = SLeft
  | SRight
  | Still
  deriving ( Eq, Ord, Show )

-- |Transition from a state to another
data Transition
  = Transition { tInit  :: State
               , tFinal :: State
               , tRead  :: Cell
               , tWrite :: Cell
               , tMove  :: Step
               }
  deriving ( Eq, Ord, Show )

-- |Turing machine
data Machine
  = Machine { mInit  :: State
            , mFinal :: [ State ]
            , mTrans :: [ Transition ]
            }
  deriving ( Eq, Ord, Show )

-- |Sample machine to increment a binary number
increment :: Machine
increment
  = Machine { mInit = 0
            , mFinal = [ 2 ]
            , mTrans = [ Transition 0 0 Zero  Zero  SRight
                       , Transition 0 0 One   One   SRight
                       , Transition 0 1 Blank Blank SLeft
                       , Transition 1 1 One   Zero  SLeft
                       , Transition 1 2 Zero  One   Still
                       , Transition 1 2 Blank One   Still
                       ]
            }

-- |Run a turing machine on a tape
run :: Int -> Tape -> Machine -> Maybe Tape
run pos tape m@Machine{..}
  = run' mInit pos tape
  where
    run' state pos tape
      | state `elem` mFinal = Just tape
      | otherwise = asum $ map step trans
      where
        cell
          = fromMaybe Blank (Map.lookup pos tape)
        trans
          = filter (\t -> tInit t == state && tRead t == cell) mTrans
        step (Transition{..})
          = run' tFinal pos' (Map.insert pos tWrite tape)
          where
            pos' = case tMove of
              SLeft  -> pos - 1
              SRight -> pos + 1
              Still  -> pos

-- |Test case
test :: Maybe Tape
test
  = run 0 tape increment
  where
    tape = Map.fromList
      [ ( 0, One  )
      , ( 1, Zero )
      , ( 2, One )
      , ( 3, One  )
      ]