CPBrainfuck-1.1: BF.hs

module Main where

import Char (ord,chr)
import System (getArgs,system)
import List (nub,isPrefixOf)
import System.IO.Unsafe (unsafePerformIO)
import System.IO (isEOF,getChar,putChar,hSetBuffering,BufferMode(..)
                 ,stdin,stdout,stderr,hPutStrLn,hFlush)

type Tokens = (String,String,String,String,String,String,String,String)

data Token = MRight | MLeft | Inc | Dec | In | Out | JINZ | JMatch
             deriving Show

data Stmt = TMRight | TMLeft | TInc | TDec | TIn | TOut | TLoop [Stmt]
            deriving Show

type Machine = ([Int],[Int])
type Interpreter = Machine -> String -> String

{- | 
  A brainFuck and derived languages interpreter.  Currently supports Brainfuck
  and Ook. 
  
  Usage:
    BF [-m mode] prog
    
  Options:
    -m  Sets the programming languages interpreted.  Valid options are:
        bf  -- Brainfuck
        ook -- Ook!
-}
main = do args <- System.getArgs
          hSetBuffering stdin  NoBuffering
          hSetBuffering stdout NoBuffering
          let (tokens,prog) = parseArgs args
          interact $ interpret (const (const "")) 
                               (fst $ parse $ tokenise prog tokens)
                               emptyMachine

emptyMachine :: Machine
emptyMachine = (repeat 0,repeat 0)

{- | Parse the arguments given to the BF program -}
parseArgs :: [String] -> (Tokens,String)
parseArgs []  = (("","","","","","","",""),"")
parseArgs [p] = ((">","<","+","-",",",".","[","]")
                ,unsafePerformIO $ readFile p)
parseArgs ("-m":"bf":xs) =
  let (_,f) = parseArgs xs
  in ((">","<","+","-",",",".","[","]"),f)
parseArgs ("-m":"ook":xs) =
  let (_,f) = parseArgs xs
  in (("Ook.Ook?","Ook?Ook.","Ook.Ook.","Ook!Ook!"
      ,"Ook.Ook!","Ook!Ook.","Ook!Ook?","Ook?Ook!"),f)

{- | Tokenise the program -}
tokenise :: String -> Tokens -> [Token]
tokenise p ts@(r,l,i,d,inp,out,j,jm) =
  tokenise'
    (filter ((flip elem) (nub (concat [r, l, i, d, inp, out, j, jm]))) p) ts
  where
    tokenise' :: String -> Tokens -> [Token]
    tokenise' p ts@(r,l,i,d,inp,out,j,jm) =
      if r        `isPrefixOf` p then MRight : tokeniseAfter r   p ts
      else if l   `isPrefixOf` p then MLeft  : tokeniseAfter l   p ts
      else if i   `isPrefixOf` p then Inc    : tokeniseAfter i   p ts
      else if d   `isPrefixOf` p then Dec    : tokeniseAfter d   p ts
      else if inp `isPrefixOf` p then In     : tokeniseAfter inp p ts
      else if out `isPrefixOf` p then Out    : tokeniseAfter out p ts
      else if j   `isPrefixOf` p then JINZ   : tokeniseAfter j   p ts
      else if jm  `isPrefixOf` p then JMatch : tokeniseAfter jm  p ts
      else case p of
             []     -> []
             (_:np) -> tokenise' np ts
    dropToken :: String -> String -> String
    dropToken t p = drop (length t) p
    tokeniseAfter :: String -> String -> Tokens -> [Token]
    tokeniseAfter t p ts = tokenise' (dropToken t p) ts

{- | Parse the program -}
parse :: [Token] -> ([Stmt],[Token])
parse [] = ([],[])
parse (MRight:xs) = ((TMRight:st),r) where (st,r) = parse xs
parse (MLeft:xs)  = ((TMLeft:st),r) where (st,r) = parse xs
parse (Inc:xs)    = ((TInc:st),r) where (st,r) = parse xs
parse (Dec:xs)    = ((TDec:st),r) where (st,r) = parse xs
parse (In:xs)     = ((TIn:st),r) where (st,r) = parse xs
parse (Out:xs)    = ((TOut:st),r) where (st,r) = parse xs
parse (JINZ:xs)   = (TLoop lst:st,rr)
                    where
                      (lst,r) = parse xs
                      (st,rr) = parse r
parse (JMatch:xs) = ([],xs)

{- | Interpret some brain fuck -}
interpret :: Interpreter -> [Stmt] -> Interpreter
interpret c []              x         i = c x i
interpret c (TMRight:xs)    (l,(h:r)) i = interpret c xs ((h:l),r) i
interpret c (TMLeft:xs)     ((h:l),r) i = interpret c xs (l,(h:r)) i
interpret c (TInc:xs)       (l,(h:r)) i = interpret c xs (l,(h+1:r)) i
interpret c (TDec:xs)       (l,(h:r)) i = interpret c xs (l,(h-1:r)) i
interpret c (TIn:xs)        (l,(_:r)) i =
  case i of
    []     -> interpret c xs (l,(-1:r)) []
    (y:ys) -> interpret c xs (l,(ord y:r)) ys
interpret c (TOut:xs)       (l,(x:r)) i = (chr x) : (interpret c xs (l,x:r) i)
interpret c (TLoop loop:xs) (l,(h:r)) i =
  if h == 0 then interpret c xs (l,(h:r)) i
            else interpret (interpret c (TLoop loop:xs)) loop (l,(h:r)) i