HBF2.hs

import Control.Monad.State
import Data.Word(Word8)
import Data.Char(chr)

data BFState = BFState {
    dataLeft :: [Word8], 
    dataRight :: [Word8], 
    codeLeft :: [Char], 
    codeRight :: [Char], 
    bfOutput :: [Char]
    }
    
allData s = reverse ( dataLeft s ) ++ dataRight s
    
newBFState = BFState [] [] [] []

instance Show BFState where
    show s = show ( take 10 ( allData s ) ) ++ ", " ++ (show $ bfOutput s)

fwdCode, backCode :: State BFState ()
fwdCode =  modify $ \s@(BFState{codeLeft=ls, codeRight=r:rs}) -> s{codeLeft=r:ls, codeRight=rs}
backCode = modify $ \s@(BFState{codeLeft=l:ls, codeRight=rs}) -> s{codeLeft=ls, codeRight=l:rs}

fwdData, backData :: State BFState ()
fwdData =  modify $ \s@(BFState{dataLeft=ls, dataRight=r:rs}) -> s{dataLeft=r:ls, dataRight=rs}
backData = modify $ \s@(BFState{dataLeft=l:ls, dataRight=rs}) -> s{dataLeft=ls, dataRight=l:rs}


running :: State BFState Bool
running = gets $ not . null . codeRight

currCode :: State BFState Char
currCode = gets $ head . codeRight

getData :: State BFState Word8
getData = gets $ head . dataRight

setData :: Word8 -> State BFState ()
setData value = modify $ \s@BFState{dataRight=(d:ds)} -> s{dataRight=(value:ds)}

output :: Char -> State BFState ()
output c = modify $ \s -> s{ bfOutput=(bfOutput s ++ [c]) }

alterData :: Word8 -> State BFState ()
alterData diff = do 
    v <- getData
    setData (v+diff)
    
incData = alterData 1
decData = alterData (-1)

runBF :: State BFState ()
runBF = do
    r <- running 
    if not r then return () else do
        stepBF
        runBF
        
backBlock :: Int -> State BFState ()
backBlock n = do
    backCode
    c <- currCode
    n' <- return ( case c of ']' -> n + 1
                             '[' -> n - 1
                             _ -> n )
    if n'==0 then return () else backBlock n'
    
stepBF :: State BFState ()
stepBF = do
    c <- currCode
    d <- getData
    fwdCode
    case c of 
        '+' -> incData
        '-' -> decData
        '>' -> fwdData
        '<' -> backData
        ']' -> if d==0 then return () else backBlock 0
        '.' -> getData >>= \c -> output $ chr $ fromInteger $ toInteger c
        _ -> return ()
    
execBF code = runState runBF (BFState [] (replicate 65536 0) [] code [])

test = execBF ">+++++++++[<++++++++>-]<.>+++++++[<++++>-]<+.+++++++..+++.[-]>++++++++[<++++>-] <.>+++++++++++[<++++++++>-]<-.--------.+++.------.--------.[-]>++++++++[<++++>- ]<+.[-]++++++++++."

main = 
    print $ test