bfLike.hs

module BFLike
  (run, interpret, tobc, eval) where

import Data.Char

qqq :: (a, b, c) -> d -> (a, b, c, d)
qqq (a, b, c) d = (a, b, c, d)

run' :: ([Char], [Int], Int) -> Int -> ([Char], [Int], Int)
run' (value, state, ptr) inst =
     case inst of
        1 -> (value, (take ptr state) ++ [(state !! ptr) + 1] ++ (drop (ptr + 1) state), ptr)
        2 -> (value, (take ptr state) ++ [(state !! ptr) - 1] ++ (drop (ptr + 1) state), ptr)
        3 -> (value, if length state == ptr + 1 then state ++ [0] else state, ptr + 1)
        4 -> (value, state, ptr - 1)
        5 -> (value ++ [chr $ state !! ptr], state, ptr)

while :: ([Char], [Int], Int, (Bool, [Int])) -> ([Char], [Int], Int, (Bool, [Int]))
while (value, state, ptr, rc) =
      if state' !! ptr' < 1
        then (value', state', ptr', (False, []))
        else while (value', state', ptr', rc)
      where (value', state', ptr', rc') = foldl run (value, state, ptr, (False, [])) (snd rc)

run :: ([Char], [Int], Int, (Bool, [Int])) -> Int -> ([Char], [Int], Int, (Bool, [Int]))
run (value, state, ptr, rc) inst =
    if fst rc
      then
        case inst of
           7 -> while (value, state, ptr, (False, snd rc))
           _ -> (value, state, ptr, (True, (snd rc) ++ [inst]))
      else
        case inst of
           6 -> (value, state, ptr, (True, []))
           _ -> qqq (run' (value, state, ptr) inst) rc
        

interpret :: [Int] -> [Char]
interpret l = value where (value, state, ptr, rc) = foldl run ([], [0], 0, (False, [])) l

tobc :: [Char] -> [Int]
tobc = map $ \c-> case c of
                   '+' -> 1
                   '-' -> 2
                   '>' -> 3
                   '<' -> 4
                   '.' -> 5
                   '[' -> 6
                   ']' -> 7

eval :: [Char] -> [Char]
eval = interpret . tobc