pl/brainfuck.hs
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Added loops etc

Browse Source
This commit is contained in:
hellerve
2015-06-23 15:57:03 +02:00
parent 75e4f2fc99
commit e0eabe4678
4 changed files with 57 additions and 21 deletions
Download Patch File Download Diff File Expand all files Collapse all files

67
brainf*ck.hs
View File

@@ -1,7 +1,7 @@
module Main where
import Data.Char
import Data.Sequence hiding (null)
import Data.Sequence hiding (length, null, take, reverse, drop)
import System.Console.Haskeline
import System.Environment
@@ -20,7 +20,7 @@ printUsage = do printVersion
"\n\twithout arguments - runs REPL" ++
"\n\t-h/--help - display this help message" ++
"\n\nMore information can be found on " ++
"https://github.com/hellerve/unlambda")
"https://github.com/hellerve/brainfuck")
printVersion :: IO ()
printVersion = putStrLn (name ++ " Version " ++ version)
@@ -28,20 +28,42 @@ printVersion = putStrLn (name ++ " Version " ++ version)
printCommands :: IO ()
printCommands = putStrLn "Press Ctrl-C to exit interpreter"
program :: String -> Seq Int -> Int -> IO ()
program "" _ _ = return ()
program ('>' : l) tape ptr = program l tape (ptr+1)
program ('<' : l) tape ptr = program l tape (ptr-1)
program ('+' : l) tape ptr = let newtape = update ptr ((index tape ptr) + 1) tape
in program l newtape ptr
program ('-' : l) tape ptr = let newtape = update ptr ((index tape ptr) - 1) tape
in program l newtape ptr
program ('.' : l) tape ptr = do putChar $ chr $ index tape ptr
program l tape ptr
program (',' : l) tape ptr = do x <- getChar
let newtape = update ptr (ord x) tape
program l newtape ptr
program (x : _) _ _ = putStrLn ("Unknown instruction: " ++ [x])
program :: String -> String -> Seq Int -> Int -> IO ()
program _ "" _ _ = return ()
program i ('\n' : l) tape ptr = program i l tape ptr
program i (' ' : l) tape ptr = program i l tape ptr
program i ('>' : l) tape ptr = program i l tape (ptr+1)
program i ('<' : l) tape ptr = program i l tape (ptr-1)
program i ('+' : l) tape ptr = let newtape = update ptr ((index tape ptr) + 1) tape
in program i l newtape ptr
program i ('-' : l) tape ptr = let newtape = update ptr ((index tape ptr) - 1) tape
in program i l newtape ptr
program i ('.' : l) tape ptr = do putChar $ chr $ index tape ptr
program i l tape ptr
program i (',' : l) tape ptr = do x <- getChar
let newtape = update ptr (ord x) tape
program i l newtape ptr
program i ('[' : l) tape ptr = if (index tape ptr) == 0
then let x = findJump l 1
in program i x tape ptr
else program i l tape ptr
where findJump :: String -> Integer -> String
findJump f 0 = f
findJump ('[' : f) c = findJump f (c+1)
findJump (']' : f) c = findJump f (c-1)
findJump (_ : f) c = findJump f c
findJump "" _ = error "Loop brackets mismatched: too few closing"
program i (']' : l) tape ptr = if not ((index tape ptr) == 0)
then let x = findJump (reverse (take (length i - length l - 1) i)) 1
in program i (drop (length x) i) tape ptr
else program i l tape ptr
where findJump :: String -> Integer -> String
findJump f 0 = f
findJump ('[' : f) c = findJump f (c-1)
findJump (']' : f) c = findJump f (c+1)
findJump (_ : f) c = findJump f c
findJump "" _ = error "Loop brackets mismatched: too many closing"
program _ (x : _) _ _ = putStrLn ("Unknown instruction: " ++ [x])
main :: IO ()
main = do
@@ -57,7 +79,9 @@ main = do
else exec args
exec :: [String] -> IO ()
exec _ = undefined
exec a = do x <- readFile (head a)
let s = take (length x - 1) x
program s s (zeroes 30000 empty) 0
getInput :: IO String
getInput = runInputT defaultSettings repl_
@@ -72,9 +96,10 @@ repl = do input <- getInput
case input of
"" -> repl
"quit" -> putStrLn "Bye"
x -> do program x (zeroes 30000 empty) 0
x -> do program x x (zeroes 30000 empty) 0
putStrLn ""
repl
where zeroes :: Int -> Seq Int -> Seq Int
zeroes 0 l = l
zeroes n l = zeroes (n-1) (l |> 0)
zeroes :: Int -> Seq Int -> Seq Int
zeroes 0 l = l
zeroes n l = zeroes (n-1) (l |> 0)