hsmachine.hs

import Control.Monad.State
import Data.Set (member, singleton, Set)
type Tape a = ([Maybe a], [Maybe a])

empty::Tape a
empty = ([], [Nothing])

--create a Tape from a list point to the first element of it
fromList:: [a] -> Tape a
fromList a = ([], map (Just) a)

right::Tape a -> Tape a
right (a, []) = (a, [Nothing])
right (a, b:c) = (b:a, c)

left::Tape a -> Tape a
left ([], c) = ([Nothing], c)
left (b:a, c) = (a, b:c)

peek::Tape a -> Maybe a
peek (_, []) = Nothing
peek (_, b:_) = b

set::Maybe a -> Tape a -> Tape a
set x (a, []) = (a, x:[])
set x (a, b:c) = (a, x:c)

tprint:: (Show a) => Tape a -> String
tprint (a, b:c) = concat $ map (surround.unwrap) (reverse a)
                           ++ ((surround'.unwrap) b) : map (surround.unwrap) c
  where unwrap (Just a) = show a
        unwrap Nothing  = "'#'"
        surround  e  = "[" ++ e ++ "]"
        surround' e  = "{" ++ e ++ "}"

data Dir = R | L deriving (Show)
data TuringTransition s t = GOTO s (Maybe t) Dir | STOP
type TuringMachine s t = State (s, Tape t) (Tape t)


fromTable::(s -> Maybe t -> TuringTransition s t) -> TuringMachine s t
fromTable table = do
  (state, tape) <- get
  let transaction = table state $ peek tape
  case transaction of
    STOP -> return tape
    GOTO s o R -> do { put (s, right $ set o tape); fromTable table }
    GOTO s o L -> do { put (s, left  $ set o tape); fromTable table }

exec::(Ord s) => TuringMachine s t -> s -> Set s -> Tape t -> Either (Tape t) (Tape t)
exec m i f t = case runState m (i, t) of
  (ft, (fs, _)) | (member fs f) -> Right ft
                |  otherwise    -> Left ft


atob::Int -> Maybe Char -> TuringTransition Int Char
atob 0 (Just 'a') = GOTO 0 (Just 'b') R
atob 0 (Just 'b') = GOTO 0 (Just 'a') R
atob 0 Nothing    = GOTO 1  Nothing   L
atob 1 (Just  x ) = GOTO 1 (Just  x ) L
atob 1 Nothing    = GOTO 2  Nothing   R
atob 2 _          = STOP

main::IO ()
main = do
  input <- putStr "inform the input: " >> getLine
  putStrLn ""
  case exec (fromTable atob) 0 (singleton 2) (fromList input) of
    Right tape -> putStr "ok: "   >> (putStrLn $ tprint tape)
    Left  tape -> putStr "fail: " >> (putStrLn $ tprint tape)