diff --git a/brainfuck2/bf-vector.hs b/brainfuck2/bf-vector.hs new file mode 100644 index 00000000..50e219b7 --- /dev/null +++ b/brainfuck2/bf-vector.hs @@ -0,0 +1,98 @@ +import Data.Vector ((!?)) +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as M +import qualified Data.Vector.Unboxed.Mutable as U +import Data.Char (chr) +import System.Environment (getArgs) +import System.IO (hFlush, hPutChar, stdout) + +data Op = Inc | Dec | MoveL | MoveR | Print | Bne Int | Beq Int + deriving Show + +parse :: [Char] -> IO (V.Vector Op) +parse src = do + ops <- M.unsafeNew len + go [] src' ops 0 + where + src' = filter (`elem` "+-<>.[]") src + len = length src' + + go :: [Int] -> [Char] -> M.IOVector Op -> Int -> IO (V.Vector Op) + go js (c : cs) ops i = case c of + '+' -> do + M.unsafeWrite ops i Inc + go js cs ops (i + 1) + '-' -> do + M.unsafeWrite ops i Dec + go js cs ops (i + 1) + '<' -> do + M.unsafeWrite ops i MoveL + go js cs ops (i + 1) + '>' -> do + M.unsafeWrite ops i MoveR + go js cs ops (i + 1) + '.' -> do + M.unsafeWrite ops i Print + go js cs ops (i + 1) + '[' -> do + M.unsafeWrite ops i (Beq len) + go (i : js) cs ops (i + 1) + ']' -> case js of + [] -> do + M.unsafeWrite ops i (Bne 0) + go [] cs ops (i + 1) + j : jt -> do + M.unsafeWrite ops i (Bne $ j + 1) + M.unsafeWrite ops j (Beq $ i + 1) + go jt cs ops (i + 1) + _ -> do + M.unsafeWrite ops i (Beq $ i + 1) + go js cs ops (i + 1) + go _ [] ops _ = V.unsafeFreeze ops + +run :: V.Vector Op -> IO () +run ops = do + tape <- U.new 8 + go 0 tape 0 + where + go :: Int -> U.IOVector Int -> Int -> IO () + go i tape j = j `seq` case ops !? i of + Just Inc -> do + v <- U.unsafeRead tape j + U.unsafeWrite tape j (v + 1) + go (i + 1) tape j + Just Dec -> do + v <- U.unsafeRead tape j + U.unsafeWrite tape j (v - 1) + go (i + 1) tape j + Just MoveL -> go (i + 1) tape (j - 1) + Just MoveR -> do + let l = U.length tape + if j + 1 >= U.length tape + then do + tape' <- U.grow tape l + go (i + 1) tape' (j + 1) + else go (i + 1) tape (j + 1) + Just Print -> do + v <- U.unsafeRead tape j + hPutChar stdout $ chr v + hFlush stdout + go (i + 1) tape j + Just (Bne k) -> do + v <- U.unsafeRead tape j + if v /= 0 + then go k tape j + else go (i + 1) tape j + Just (Beq k) -> do + v <- U.unsafeRead tape j + if v == 0 + then go k tape j + else go (i + 1) tape j + Nothing -> pure () + +main :: IO () +main = do + [filename] <- getArgs + src <- readFile filename + ops <- parse src + run ops diff --git a/brainfuck2/bf.hs b/brainfuck2/bf.hs index 21fadcd0..737df096 100644 --- a/brainfuck2/bf.hs +++ b/brainfuck2/bf.hs @@ -1,72 +1,58 @@ -module Main where - -import qualified Data.Array.Base as ArrayBase -import qualified Data.Array.Unboxed as UArray +import Control.Arrow (first) import Data.Char (chr) +import Data.Function (fix) import System.Environment (getArgs) -import System.IO (hFlush, stdout) - -data Op = Inc Int | Move Int | Print | Loop [Op] deriving Show -data Tape = Tape { tapeData :: UArray.UArray Int Int - , tapePos :: Int - } deriving Show - -current :: Tape -> Int -current tape = ArrayBase.unsafeAt (tapeData tape) (tapePos tape) +import System.IO (hFlush, hPutChar, stdout) -inc :: Int -> Tape -> Tape -inc delta tape = - tape { tapeData = newData } - where - newData = ArrayBase.unsafeReplace (tapeData tape) - [(tapePos tape, (current tape) + delta)] +data Op = Inc | Dec | MoveL | MoveR | Print | Loop [Op] + deriving Show -move :: Int -> Tape -> Tape -move m tape = - tape { tapeData = newData, tapePos = newPos } +parse :: [Char] -> [Op] +parse = fst <$> go where - curData = tapeData tape - len = ArrayBase.numElements curData - newPos = (tapePos tape) + m - asc = ArrayBase.assocs curData - newData = if newPos < len - then curData - else ArrayBase.unsafeArray (0, newPos) - (asc ++ [(i, 0) | i <- [len..newPos]]) - -parse :: ([Char], [Op]) -> ([Char], [Op]) -parse ([], acc) = ([], reverse acc) -parse (c:cs, acc) = - case c of - '+' -> parse (cs, Inc 1:acc) - '-' -> parse (cs, Inc (-1):acc) - '>' -> parse (cs, Move 1:acc) - '<' -> parse (cs, Move (-1):acc) - '.' -> parse (cs, Print:acc) - '[' -> parse (newCs, Loop loop:acc) - where (newCs, loop) = parse (cs, []) - ']' -> (cs, reverse acc) - otherwise -> parse (cs, acc) + go :: [Char] -> ([Op], [Char]) + go (c : cs) = case c of + '+' -> first (Inc :) (go cs) + '-' -> first (Dec :) (go cs) + '<' -> first (MoveL :) (go cs) + '>' -> first (MoveR :) (go cs) + '.' -> first (Print :) (go cs) + '[' -> first (Loop os :) (go cs') + where (os, cs') = go cs + ']' -> ([], cs) + _ -> go cs + go [] = ([], []) + +data IntStream = !Int :- IntStream + deriving Show + +data Tape = Tape IntStream !Int IntStream + deriving Show + +blank :: Tape +blank = Tape (fix (0 :-)) 0 (fix (0 :-)) run :: [Op] -> Tape -> IO Tape -run [] tape = return tape -run (op:ops) tape = do - case op of - Inc d -> run ops $ inc d tape - Move m -> run ops $ move m tape - Print -> do - putStr $ [chr $ current tape] - hFlush stdout - run ops tape - Loop loop -> do - if current tape == 0 - then run ops tape - else do - newTape <- run loop tape - run (op:ops) newTape - +run (o : os) tape = case o of + Inc -> let Tape ls v rs = tape + in run os $ Tape ls (v + 1) rs + Dec -> let Tape ls v rs = tape + in run os $ Tape ls (v - 1) rs + MoveL -> let Tape (l :- lt) v rs = tape + in run os $ Tape lt l (v :- rs) + MoveR -> let Tape ls v (r :- rt) = tape + in run os $ Tape (v :- ls) r rt + Print -> let Tape _ v _ = tape + in hPutChar stdout (chr v) *> hFlush stdout *> run os tape + Loop os' -> let Tape _ v _ = tape + in if v /= 0 + then run (o : os) =<< run os' tape + else run os tape +run [] tape = pure tape + +main :: IO () main = do [filename] <- getArgs source <- readFile filename - let (_, ops) = parse (source, []) - run ops (Tape (ArrayBase.unsafeArray (0, 0) [(0, 0)]) 0) + _ <- run (parse source) blank + pure ()