-- Brainfuck interpreter in Haskell
-- © 2006 Joachim Breitner

import List
import Maybe
import Char

-- Infinte Tape Type, with default value
data Tape a = Tape a [a] [a]

-- Moves to the next cell on the right
moveRight :: Tape a -> Tape a
moveRight (Tape d b  []  ) = Tape d (d:b) []
moveRight (Tape d b (x:a)) = Tape d (x:b) a

-- Moves to the next cell on the left
moveLeft :: Tape a -> Tape a
moveLeft (Tape d  []   a) = Tape d [] (d:a)
moveLeft (Tape d (x:b) a) = Tape d b  (x:a)

-- Applies a function to the current value
doOn :: Tape a -> (a -> a) -> Tape a
doOn (Tape d b []   ) f = Tape d b [f d]
doOn (Tape d b (x:a)) f = Tape d b  (f x:a)

-- Sets the current value
set :: Tape a -> a -> Tape a
set t v = doOn t (const v)

-- Gets the current value
get :: Tape a -> a
get (Tape d b []   ) = d
get (Tape d b (x:a)) = x

-- For debugging, let us be able to see a Tape
instance Show a => Show (Tape a) where
	show (Tape d b a) = "..."++(show d)++" "++
	       (concat $ intersperse " " $ reverse  $ map show b ) ++
	       "["++(show x)++"]" ++
	       (concat $ intersperse " " $            map show a') ++
	       " "++(show d)++"..."
	       where x  = if null a then d else head a
	             a' = if null a then a else tail a


-- BrainFuck Virtual Machine, has a data tape, a program tape and input and output
data Machine = Machine { tape :: (Tape Int),
                         prog :: (Tape (Maybe Op)),
			 input :: String,
			 output :: String }

-- A Operation changes the machine
type Op = (Machine -> Machine)

-- Parser. Creates a list of function, that we later apply to the machine
parseBFC :: String -> [Op]
parseBFC str = parseBFC' str []

parseBFC' :: String -> [Int] -> [Op]
parseBFC' ('+':code) s = (\m -> m { tape = doOn (tape m) succ }) : parseBFC' code s
parseBFC' ('-':code) s = (\m -> m { tape = doOn (tape m) pred }) : parseBFC' code s
parseBFC' (',':code) s = (\m -> let (x:rest) = (input m) in m {tape = (set $ tape m) (ord x), input = rest }) : parseBFC' code s
parseBFC' ('.':code) s = (\m -> m { output = (chr $ get $ tape m):(output m)}) : parseBFC' code s
parseBFC' ('>':code) s = (\m -> m { tape = moveRight (tape m)}) : parseBFC' code s
parseBFC' ('<':code) s = (\m -> m { tape = moveLeft  (tape m)}) : parseBFC' code s
parseBFC' ('[':code) s = let n = findMatchingBrace code
                        in (\m -> if get (tape m) == 0 then m { prog = doOften n moveRight (prog m) } else m) : parseBFC' code (n:s)
parseBFC' (']':code) (n:s) = (\m -> m { prog = doOften (n+1) moveLeft (prog m) } ) : parseBFC' code s
parseBFC' (_  :code) s = id : parseBFC' code s
parseBFC' ""         _ = []

-- Counts the number of characters 'till the matching brace. Is there a better way?
findMatchingBrace :: [Char] -> Int
findMatchingBrace string = findMatchingBrace' string 0 1

findMatchingBrace' :: [Char] -> Int -> Int -> Int
findMatchingBrace' ('[':string) c n = findMatchingBrace' string (c+1) (n+1)
findMatchingBrace' (']':string) 0 n = n
findMatchingBrace' (']':string) c n = findMatchingBrace' string (c-1) (n+1)
findMatchingBrace' (_  :string) c n = findMatchingBrace' string  c    (n+1)

-- Selects the next operation as active.
nextOp :: Machine -> Machine
nextOp m = m {prog = moveRight (prog m) }

-- Actually runs a piece of BrainFuck code with a given input
run :: String -> String -> String
run code input = let ops = map Just $ parseBFC code
                     machine = Machine (Tape 0 [] []) (Tape Nothing [] ops) (input++(repeat '\0')) []
		     endmachine = head $ dropWhile (isJust.get.prog)
		                       $ iterate (\m -> nextOp $ (fromJust $ get $ prog m) m) machine
	         --in  show $ tape $ endmachine
	         in  reverse $ output $ endmachine

-- Helper Functoin: like (iterate f v)!!n, I think
doOften :: Int -> (a -> a) -> a -> a
doOften 0 f v = v
doOften n f v = doOften (n-1) f (f v)