brainfuck.hs

-- Released under CC0.

import System.IO
import Control.Applicative

type Code = [Cmd]
data Cmd = L | R | I | D | P | G | W Code deriving Show

data CodeZipper = CZ Code [(Code,Code)] deriving Show
data DataZipper = DZ [Int]  Int  [Int] deriving Show

run :: CodeZipper -> DataZipper -> IO ()
run (CZ []      [])         _                  = return ()
run (CZ (R:c)   js)         (DZ pds d (d':ds)) = run (CZ c js)         (DZ (d:pds) d'    ds)
run (CZ (L:_)   _ )         (DZ []  _ _      ) = fail "pointer out of bound"
run (CZ (L:c)   js)         (DZ (d':pds) d ds) = run (CZ c js)         (DZ pds     d'    (d:ds))
run (CZ (I:c)   js)         (DZ pds      d ds) = run (CZ c js)         (DZ pds     (d+1) ds)
run (CZ (D:c)   js)         (DZ pds      d ds) = run (CZ c js)         (DZ pds     (d-1) ds)
run (CZ (P:c)   js)      dz@(DZ _        d _ ) = do
                                                 putChar (toEnum d)
                                                 run (CZ c js)         dz
run (CZ (G:c)   js)         (DZ pds      _ ds) = do
                                                 d <- fromEnum <$> getChar
                                                 run (CZ c js)         (DZ pds     d     ds)
run (CZ (W _:c) js)      dz@(DZ _        0 _ ) = run (CZ c js)         dz
run (CZ (W c:f) js)      dz                    = run (CZ c ((c,f):js)) dz
run (CZ [] ((_,c):js))   dz@(DZ _        0 _ ) = run (CZ c js)         dz
run (CZ [] js@((c,_):_)) dz                    = run (CZ c js)         dz

data ParseZipper = PZ Code [Code] deriving Show

parse :: String -> Code
parse = parseRev (PZ [] []) . reverse
  where
    parseRev (PZ c [])      []       = c
    parseRev (PZ c cs)      ('>':xs) = parseRev (PZ (L:c)    cs)     xs
    parseRev (PZ c cs)      ('<':xs) = parseRev (PZ (R:c)    cs)     xs
    parseRev (PZ c cs)      ('+':xs) = parseRev (PZ (I:c)    cs)     xs
    parseRev (PZ c cs)      ('-':xs) = parseRev (PZ (D:c)    cs)     xs
    parseRev (PZ c cs)      ('.':xs) = parseRev (PZ (P:c)    cs)     xs
    parseRev (PZ c cs)      (',':xs) = parseRev (PZ (G:c)    cs)     xs
    parseRev (PZ c (c':cs)) ('[':xs) = parseRev (PZ (W c:c') cs)     xs
    parseRev (PZ c cs)      (']':xs) = parseRev (PZ []       (c:cs)) xs
    parseRev _              _        = error "wrong code"

initCZ :: Code -> CodeZipper
initCZ code = CZ code []

initDZ :: DataZipper
initDZ = DZ [] 0 (repeat 0)

main :: IO ()
main = run (initCZ $ parse ",[.[-],]") initDZ