Turing machine

Turing.hs

-- Turing machine
-- Author: Ben Gamari

import Graphics.Gloss
import Data.List       
import Data.Function       

type Symbol = Int                
type Position = Int
type Tape = [(Position, Symbol)]
data Direction = DLeft | DRight deriving (Show, Eq)
data Machine state = Machine { state :: state
                             , tape :: Tape
                             , position :: Position
                       }
             deriving (Show, Eq)

data Action = Move Direction
            | Write Symbol
            | Erase
            deriving (Show, Eq)
            
type Program state = state -> Maybe Symbol -> ([Action], state)

readTape :: Tape -> Position -> Maybe Symbol
readTape tape pos = lookup pos tape
        
writeTape :: Position -> Maybe Symbol -> Tape -> Tape
writeTape pos Nothing tape = deleteBy ((==) `on` fst) (pos, undefined) tape
writeTape pos (Just sym) tape =
    (pos, sym) : writeTape pos Nothing tape

doAction :: Machine state -> Action -> Machine state
doAction m (Move DRight)  = m { position = position m + 1 }
doAction m (Move DLeft)   = m { position = position m - 1 }
doAction m (Write s)     = m { tape = writeTape (position m) (Just s) (tape m) }
doAction m (Erase)       = m { tape = writeTape (position m) Nothing (tape m) }

evolve :: Program state -> Machine state -> Machine state
evolve program m =
    let sym = readTape (tape m) (position m)
        (actions, state') = program (state m) sym
    in (foldl' doAction m actions) {state = state'}

turingsFirst :: Program Char
turingsFirst 'b' Nothing = ([Write 0, Move DRight], 'c')
turingsFirst 'c' Nothing = ([Move DRight], 'e')
turingsFirst 'e' Nothing = ([Write 1, Move DRight], 'f')
turingsFirst 'f' Nothing = ([Move DRight], 'b')
turingsFirst _ _         = error "Uh oh. We shouldn't be here"
    
reducedTuringsFirst :: Program ()             
reducedTuringsFirst _ Nothing = ([Write 0], ())
reducedTuringsFirst _ (Just 0) = ([Move DRight, Move DRight, Write 1], ())
reducedTuringsFirst _ (Just 1) = ([Move DRight, Move DRight, Write 0], ())
reducedTuringsFirst _ _ = error "Uh oh. We shouldn't be here"

initialMachine :: state -> Machine state                    
initialMachine state = Machine { state    = state
                               , tape     = []
                               , position = 0
                               }
                               
main = do
     let s = head $ drop 50 $ iterate (evolve turingsFirst) $ initialMachine 'b'
     print s
     --display (InWindow "Turing" (500,500) (500,500)) white $ drawMachine (0,50) s
     simulate (InWindow "Turing" (500,500) (500,500))
              white
              2
              (initialMachine 'b')
              (drawMachine (0,50))
              (\_ _->evolve turingsFirst)

cellSize = 20 :: Float

drawMachine :: (Position,Position) -> Machine state -> Picture
drawMachine (start,end) m =
    let drawCell i =
            case readTape (tape m) i of
                Nothing -> rectangleSolid cellSize cellSize
                Just v  -> pictures [ rectangleWire cellSize cellSize
                                    , translate (-cellSize/3) (-cellSize/3)
                                      $ scale 0.1 0.1 $ text $ show v
                                    ]
        cells = map (\i->translate (cellSize*realToFrac i) 0 $ drawCell i)
                $ [start..end]
        pos = translate (cellSize * realToFrac (position m)) cellSize
              $ circle (cellSize/2)
    in pictures $ cells++[ pos ]