HBF.hs

import Data.Word(Word8)
import Data.Char(chr)

data BFData = BFData {
    curr :: Word8,
    left :: [Word8],
    right :: [Word8]
    } deriving(Show)

data BFState = BFState {
    codeLeft :: [Char],
    codeRight :: [Char],
    blockLevel :: Int,
    bfData :: BFData
    } deriving(Show)

createBFData = BFData 0 [] []

--move curr from to
move curr [] to = ( 0, [], (curr:to) )
move curr (f:fs) to = ( f, fs, (curr:to) )

fwd :: BFData -> BFData
fwd d@(BFData curr left right) =
    let (curr', right', left') = move curr right left
    in BFData curr' left' right'

back :: BFData -> BFData
back d@(BFData curr left right) =
    let (curr', left', right') = move curr left right
    in BFData curr' left' right'

modifyValue :: Word8 -> BFData -> BFData
modifyValue n d =  let newValue = curr d + n
                    in d{curr = newValue}

inc = modifyValue 1
dec = modifyValue (-1)

output :: BFData -> Char
output d = chr $ fromInteger $ toInteger $ curr d

createBFState :: [Char] -> BFState
createBFState code =
    BFState {
        codeLeft = [],
        codeRight = code,
        blockLevel = 0,
        bfData = createBFData }

blockBack :: BFState -> BFState
blockBack = blockBack' 1

blockBack' :: Int -> BFState -> BFState
blockBack' 0 state = state
blockBack' n state =
    let c = head $ codeLeft $ state
        n' = case c of
            '[' -> n-1
            ']' -> n+1
            _ -> n
        (l:ls) = codeLeft state
        rs = codeRight state
        state' = state { codeLeft=ls, codeRight=(l:rs) }
    in blockBack' n' state'

stepBFState :: BFState -> IO BFState
stepBFState state =
    let c = head $ codeRight $ state
        d = bfData state
    in  if curr d /= 0 && c == ']' then return $ blockBack state
        else stepBFState' state

execCommand :: Char -> BFData -> IO BFData
execCommand c d =
    case c of
        '+' -> return $ inc d
        '-' -> return $ dec d
        '>' -> return $ fwd d
        '<' -> return $ back d
        '.' -> do putChar $ output d
                  return d
        _ -> return d
       
stepBFState' :: BFState -> IO BFState
stepBFState' state =
    let c = head $ codeRight $ state
        bl = if c=='['
            then blockLevel state
            else blockLevel state + 1
        s' = state {
            codeLeft = (c:(codeLeft state)),
            codeRight = (tail $ codeRight state),
            blockLevel=bl }
        d = bfData state
    in  do
        d' <- execCommand c d
        return s' { bfData=d' }

execState :: BFState -> IO ()
execState state =
    if null $ codeRight state then return ()
    else do
        state' <- stepBFState state
        execState state'

execCode :: String -> IO ()
execCode code =
    let s = createBFState code
    in execState s