Haskell Turing Machine

Turing.hs

import Data.Map(Map, fromList, lookup, union)
import Control.Monad(msum)

fromMay d = (!!0) . foldr (:) [d]

mapIns :: (Ord k) => k -> a -> Map k a -> Map k a
mapIns k a = union (fromList [(k, a)])

-- | A TM to add 1 to a binary natural.
incr :: (Int, [Int], [(Int, Int, Char, Char, Int)])
incr
  = (0, [ 2 ],
            [ (0, 0, '0', '0', 1)
            , (0, 0, '1', '1', 1)
            , (0, 1, '_', '_', (-1))
            , (1, 1, '1', '0', (-1))
            , (1, 2, '0', '1', 0)
            , (1, 2, '_', '1', 0)
            ])

-- | Run a TM on a strip
run pos strip (mInit, mFinal, mTrans) = run' mInit pos strip mFinal mTrans
run' situation pos strip mFinal mTrans
  | any (==situation) mFinal = Just strip
  | 1>0 = msum $ [run' tFinal (pos + tDir) (mapIns pos tJot strip) mFinal mTrans
                 | unit <- [fromMay '_' (Data.Map.lookup pos strip)],
                   (tInit, tFinal, tScan, tJot, tDir) <- mTrans,
                   tInit == situation && tScan == unit]

-- | Try it out
strip = Data.Map.fromList
          [ ( 0, '1'  )
          , ( 1, '0' )
          , ( 2, '1' )
          , ( 3, '1'  )
          ]
try = run 0 strip incr