{-# LANGUAGE FlexibleContexts #-}
module Language.Brainfuck where
import Data.Array.IO
import Data.Array hiding (array)
import Data.Array.Base (unsafeRead, unsafeWrite, array)
import Data.Word ( Word8 )
import Data.Char ( ord, chr )
import Data.List ( groupBy )
import Data.Maybe ( catMaybes )
import Control.Monad.State
data Command = IncPtr
| IncPtrBy !Int
| DecPtr
| IncByte
| IncByteBy !Int
| DecByte
| OutputByte
| JmpForward !Int
| JmpBackward !Int
| SetIpTo !Int
| Halt
| Ignored
deriving (Int -> Command -> ShowS
[Command] -> ShowS
Command -> String
(Int -> Command -> ShowS)
-> (Command -> String) -> ([Command] -> ShowS) -> Show Command
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Command -> ShowS
showsPrec :: Int -> Command -> ShowS
$cshow :: Command -> String
show :: Command -> String
$cshowList :: [Command] -> ShowS
showList :: [Command] -> ShowS
Show, Command -> Command -> Bool
(Command -> Command -> Bool)
-> (Command -> Command -> Bool) -> Eq Command
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Command -> Command -> Bool
== :: Command -> Command -> Bool
$c/= :: Command -> Command -> Bool
/= :: Command -> Command -> Bool
Eq)
type Core = IOUArray Int Word8
type InstPtr = Int
type CorePtr = Int
data BF = BF !Core !CorePtr !InstPtr
instance Show BF where
show :: BF -> String
show (BF Core
_ Int
cp Int
ip) = String
"BF <core> CorePtr = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
cp String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" InstPtr = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ip
coreSize :: Int
coreSize = Int
30000
core :: IO Core
core :: IO Core
core = (Int, Int) -> Word8 -> IO Core
forall i. Ix i => (i, i) -> Word8 -> IO (IOUArray i Word8)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Int
0, Int
coreSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Word8
0::Word8)
decode :: Char -> State Int Command
decode :: Char -> State Int Command
decode Char
'>' = Command -> State Int Command
forall a. a -> StateT Int Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Command
IncPtr
decode Char
'<' = Command -> State Int Command
forall a. a -> StateT Int Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Command
DecPtr
decode Char
'+' = Command -> State Int Command
forall a. a -> StateT Int Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Command
IncByte
decode Char
'-' = Command -> State Int Command
forall a. a -> StateT Int Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Command
DecByte
decode Char
'.' = Command -> State Int Command
forall a. a -> StateT Int Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Command
OutputByte
decode Char
'[' = do Int
n <- StateT Int Identity Int
forall s (m :: * -> *). MonadState s m => m s
get
Int -> StateT Int Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
Command -> State Int Command
forall a. a -> StateT Int Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Command -> State Int Command) -> Command -> State Int Command
forall a b. (a -> b) -> a -> b
$ Int -> Command
JmpForward Int
n
decode Char
']' = do Int
n <- StateT Int Identity Int
forall s (m :: * -> *). MonadState s m => m s
get
Int -> StateT Int Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
Command -> State Int Command
forall a. a -> StateT Int Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Command -> State Int Command) -> Command -> State Int Command
forall a b. (a -> b) -> a -> b
$ Int -> Command
JmpBackward (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
decode Char
'@' = Command -> State Int Command
forall a. a -> StateT Int Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Command
Halt
decode Char
_ = Command -> State Int Command
forall a. a -> StateT Int Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Command
Ignored
debug :: Bool
debug :: Bool
debug = Bool
False
incIP :: InstPtr -> InstPtr
incIP :: Int -> Int
incIP = (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
{-# INLINE incIP #-}
incCP :: CorePtr -> CorePtr
incCP :: Int -> Int
incCP = (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
coreSize) (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+)
{-# inlinE incCP #-}
decCP :: CorePtr -> CorePtr
decCP :: Int -> Int
decCP = (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
coreSize) (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1
{-# INLINE decCP #-}
doCommand :: Array Int Command -> BF -> IO BF
doCommand :: Array Int Command -> BF -> IO BF
doCommand Array Int Command
cmds bf :: BF
bf@(BF Core
_ Int
_ Int
ip) = Command -> Array Int Command -> BF -> IO BF
doCommand' (Array Int Command
cmds Array Int Command -> Int -> Command
forall i e. Ix i => Array i e -> i -> e
! Int
ip) Array Int Command
cmds BF
bf
where
doCommand' :: Command -> Array Int Command -> BF -> IO BF
doCommand' :: Command -> Array Int Command -> BF -> IO BF
doCommand' Command
Halt Array Int Command
_ BF
_ = IO BF
forall a. HasCallStack => a
undefined
doCommand' Command
Ignored Array Int Command
_ (BF Core
c Int
cp Int
ip) = {-# SCC "Ignored" #-} do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Ignored " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BF -> String
forall a. Show a => a -> String
show BF
bf
BF -> IO BF
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Core -> Int -> Int -> BF
BF Core
c Int
cp (Int -> Int
incIP Int
ip))
doCommand' Command
IncPtr Array Int Command
_ bf :: BF
bf@(BF Core
c Int
cp Int
ip) = {-# SCC "IncPtr" #-} do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"IncPtr " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BF -> String
forall a. Show a => a -> String
show BF
bf
BF -> IO BF
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Core -> Int -> Int -> BF
BF Core
c (Int -> Int
incCP Int
cp) (Int -> Int
incIP Int
ip))
doCommand' Command
DecPtr Array Int Command
_ bf :: BF
bf@(BF Core
c Int
cp Int
ip) = {-# SCC "DecPtr" #-} do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"DecPtr " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BF -> String
forall a. Show a => a -> String
show BF
bf
BF -> IO BF
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Core -> Int -> Int -> BF
BF Core
c (Int -> Int
decCP Int
cp) (Int -> Int
incIP Int
ip))
doCommand' (IncPtrBy Int
n) Array Int Command
_ bf :: BF
bf@(BF Core
c Int
cp Int
ip) = {-# SCC "IncPtrBy" #-} do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"IncPtrBy " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BF -> String
forall a. Show a => a -> String
show BF
bf
BF -> IO BF
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Core -> Int -> Int -> BF
BF Core
c ((Int
cp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
coreSize) (Int -> Int
incIP Int
ip))
doCommand' Command
IncByte Array Int Command
_ BF
bf = {-# SCC "IncByte" #-} do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"IncByte " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BF -> String
forall a. Show a => a -> String
show BF
bf
BF -> (Word8 -> Word8) -> IO BF
forall {m :: * -> *}.
MArray IOUArray Word8 m =>
BF -> (Word8 -> Word8) -> m BF
updateByte BF
bf (Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+Word8
1)
doCommand' Command
DecByte Array Int Command
_ BF
bf = {-# SCC "DecByte" #-} do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"DecByte " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BF -> String
forall a. Show a => a -> String
show BF
bf
BF -> (Word8 -> Word8) -> IO BF
forall {m :: * -> *}.
MArray IOUArray Word8 m =>
BF -> (Word8 -> Word8) -> m BF
updateByte BF
bf (Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
subtract Word8
1)
doCommand' (IncByteBy Int
n) Array Int Command
_ BF
bf = {-# SCC "IncByteBy" #-} do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"IncByteBy " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BF -> String
forall a. Show a => a -> String
show BF
bf
BF -> (Word8 -> Word8) -> IO BF
forall {m :: * -> *}.
MArray IOUArray Word8 m =>
BF -> (Word8 -> Word8) -> m BF
updateByte BF
bf (Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
doCommand' Command
OutputByte Array Int Command
_ bf :: BF
bf@(BF Core
c Int
cp Int
ip) = {-# SCC "OutputByte" #-} do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"OutputByte " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BF -> String
forall a. Show a => a -> String
show BF
bf
Word8
c' <- Core -> Int -> IO Word8
forall i. Ix i => IOUArray i Word8 -> Int -> IO Word8
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> m e
unsafeRead Core
c Int
cp
Char -> IO ()
putChar (Word8 -> Char
word8ToChr Word8
c')
BF -> IO BF
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Core -> Int -> Int -> BF
BF Core
c Int
cp (Int -> Int
incIP Int
ip))
doCommand' (JmpForward Int
n) Array Int Command
cmds bf :: BF
bf@(BF Core
c Int
cp Int
ip) = {-# SCC "JmpForw" #-} do
Word8
c' <- Core -> Int -> IO Word8
forall i. Ix i => IOUArray i Word8 -> Int -> IO Word8
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> m e
unsafeRead Core
c Int
cp
case Word8
c' of
Word8
0 -> {-# SCC "JmpForward1" #-} do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"JmpForward1 " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BF -> String
forall a. Show a => a -> String
show BF
bf
BF -> IO BF
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Core -> Int -> Int -> BF
BF Core
c Int
cp Int
newInstPtr)
Word8
_ -> {-# SCC "JmpForward2" #-} do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"JmpForward2 " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BF -> String
forall a. Show a => a -> String
show BF
bf
let newBF :: BF
newBF = (Core -> Int -> Int -> BF
BF Core
c Int
cp (Int -> Int
incIP Int
ip))
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"JmpForward3" String -> ShowS
forall a. [a] -> [a] -> [a]
++ BF -> String
forall a. Show a => a -> String
show BF
newBF
BF -> IO BF
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return BF
newBF
where
newInstPtr :: Int
newInstPtr = (Array Int Command -> Int -> (Int -> Int) -> Command -> Int
nextJmp Array Int Command
cmds Int
ip (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int -> Command
JmpBackward Int
n)) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
doCommand' (JmpBackward Int
n) Array Int Command
cmds bf :: BF
bf@(BF Core
c Int
cp Int
ip) = {-# SCC "JmpBack" #-} do
Word8
c' <- Core -> Int -> IO Word8
forall i. Ix i => IOUArray i Word8 -> Int -> IO Word8
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> m e
unsafeRead Core
c Int
cp
if (Word8
c' Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0)
then do Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"JmpBackward1 " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BF -> String
forall a. Show a => a -> String
show BF
bf
BF -> IO BF
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Core -> Int -> Int -> BF
BF Core
c Int
cp Int
newInstPtr)
else do Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"JmpBackward2 " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BF -> String
forall a. Show a => a -> String
show BF
bf
BF -> IO BF
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Core -> Int -> Int -> BF
BF Core
c Int
cp (Int -> Int
incIP Int
ip))
where
newInstPtr :: Int
newInstPtr = Array Int Command -> Int -> (Int -> Int) -> Command -> Int
nextJmp Array Int Command
cmds Int
ip (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1) (Int -> Command
JmpForward Int
n)
doCommand' (SetIpTo Int
i) Array Int Command
_ bf :: BF
bf@(BF Core
c Int
cp Int
ip) = {-# SCC "SetIPTo" #-} do
Word8
c' <- Core -> Int -> IO Word8
forall i. Ix i => IOUArray i Word8 -> Int -> IO Word8
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> m e
unsafeRead Core
c Int
cp
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"SetIpTo " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ BF -> String
forall a. Show a => a -> String
show BF
bf String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" @" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
c'
if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
then if (Word8
c' Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0)
then BF -> IO BF
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BF -> IO BF) -> BF -> IO BF
forall a b. (a -> b) -> a -> b
$ Core -> Int -> Int -> BF
BF Core
c Int
cp Int
i
else BF -> IO BF
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BF -> IO BF) -> BF -> IO BF
forall a b. (a -> b) -> a -> b
$ Core -> Int -> Int -> BF
BF Core
c Int
cp (Int -> Int
incIP Int
ip)
else if (Word8
c' Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0)
then BF -> IO BF
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BF -> IO BF) -> BF -> IO BF
forall a b. (a -> b) -> a -> b
$ Core -> Int -> Int -> BF
BF Core
c Int
cp (-Int
i)
else BF -> IO BF
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BF -> IO BF) -> BF -> IO BF
forall a b. (a -> b) -> a -> b
$ Core -> Int -> Int -> BF
BF Core
c Int
cp (Int -> Int
incIP Int
ip)
nextJmp :: Array Int Command
-> InstPtr
-> (InstPtr -> InstPtr) -> Command -> InstPtr
nextJmp :: Array Int Command -> Int -> (Int -> Int) -> Command -> Int
nextJmp Array Int Command
cmds Int
ip Int -> Int
f Command
cmd = if Array Int Command
cmds Array Int Command -> Int -> Command
forall i e. Ix i => Array i e -> i -> e
! Int
ip Command -> Command -> Bool
forall a. Eq a => a -> a -> Bool
== Command
cmd
then Int
ip
else Array Int Command -> Int -> (Int -> Int) -> Command -> Int
nextJmp Array Int Command
cmds (Int -> Int
f Int
ip) Int -> Int
f Command
cmd
chrToWord8 :: Char -> Word8
chrToWord8 :: Char -> Word8
chrToWord8 = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord
word8ToChr :: Word8 -> Char
word8ToChr :: Word8 -> Char
word8ToChr = Int -> Char
chr (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral
updateByte :: BF -> (Word8 -> Word8) -> m BF
updateByte (BF Core
c Int
cp Int
ip) Word8 -> Word8
f = do
Word8
e <- Core -> Int -> m Word8
forall i. Ix i => IOUArray i Word8 -> Int -> m Word8
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> m e
unsafeRead Core
c Int
cp
Core -> Int -> Word8 -> m ()
forall i. Ix i => IOUArray i Word8 -> Int -> Word8 -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> e -> m ()
unsafeWrite Core
c Int
cp (Word8 -> Word8
f Word8
e)
BF -> m BF
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Core -> Int -> Int -> BF
BF Core
c Int
cp (Int -> Int
incIP Int
ip))
{-# INLINE updateByte #-}
loadProgram :: String -> Array Int Command
loadProgram :: String -> Array Int Command
loadProgram [] = (Int, Int) -> [(Int, Command)] -> Array Int Command
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [(i, e)] -> a i e
array (Int
0, Int
0) [(Int
0, Command
Halt)]
loadProgram String
prog = [Command] -> Array Int Command
optimize ([Command]
cs[Command] -> [Command] -> [Command]
forall a. [a] -> [a] -> [a]
++[Command
Halt])
where
cs :: [Command]
cs = ([Command], Int) -> [Command]
forall a b. (a, b) -> a
fst (([Command], Int) -> [Command]) -> ([Command], Int) -> [Command]
forall a b. (a -> b) -> a -> b
$ State Int [Command] -> Int -> ([Command], Int)
forall s a. State s a -> s -> (a, s)
runState ((Char -> State Int Command) -> String -> State Int [Command]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Char -> State Int Command
decode String
prog) Int
0
n :: Int
n = [Command] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Command]
cs
optimize :: [Command] -> Array Int Command
optimize :: [Command] -> Array Int Command
optimize [Command]
cmds = (Int, Int) -> [Command] -> Array Int Command
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, ([Command] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Command]
reduced)Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [Command]
reduced
where
reduced :: [Command]
reduced = [Command] -> [Command]
phase3 ([Command] -> [Command])
-> ([Command] -> [Command]) -> [Command] -> [Command]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Command] -> [Command]
phase2 ([Command] -> [Command])
-> ([Command] -> [Command]) -> [Command] -> [Command]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Command] -> [Command]
phase1 ([Command] -> [Command]) -> [Command] -> [Command]
forall a b. (a -> b) -> a -> b
$ [Command]
cmds
phase1 :: [Command] -> [Command]
phase1 :: [Command] -> [Command]
phase1 = (Command -> Bool) -> [Command] -> [Command]
forall a. (a -> Bool) -> [a] -> [a]
filter (Command -> Command -> Bool
forall a. Eq a => a -> a -> Bool
/=Command
Ignored)
phase2 :: [Command] -> [Command]
phase2 :: [Command] -> [Command]
phase2 [Command]
cs = [[Command]] -> [Command]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Command]] -> [Command]) -> [[Command]] -> [Command]
forall a b. (a -> b) -> a -> b
$ ([Command] -> [Command]) -> [[Command]] -> [[Command]]
forall a b. (a -> b) -> [a] -> [b]
map [Command] -> [Command]
reduce ([[Command]] -> [[Command]]) -> [[Command]] -> [[Command]]
forall a b. (a -> b) -> a -> b
$ (Command -> Command -> Bool) -> [Command] -> [[Command]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy Command -> Command -> Bool
forall a. Eq a => a -> a -> Bool
(==) [Command]
cs
where
reduce :: [Command] -> [Command]
reduce :: [Command] -> [Command]
reduce [Command]
cs
| (Command -> Bool) -> [Command] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Command -> Command -> Bool
forall a. Eq a => a -> a -> Bool
==Command
IncPtr) [Command]
cs = [Int -> Command
IncPtrBy ([Command] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Command]
cs)]
| (Command -> Bool) -> [Command] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Command -> Command -> Bool
forall a. Eq a => a -> a -> Bool
==Command
DecPtr) [Command]
cs = [Int -> Command
IncPtrBy (-([Command] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Command]
cs))]
| (Command -> Bool) -> [Command] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Command -> Command -> Bool
forall a. Eq a => a -> a -> Bool
==Command
IncByte) [Command]
cs = [Int -> Command
IncByteBy ([Command] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Command]
cs)]
| (Command -> Bool) -> [Command] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Command -> Command -> Bool
forall a. Eq a => a -> a -> Bool
==Command
DecByte) [Command]
cs = [Int -> Command
IncByteBy (-([Command] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Command]
cs))]
| Bool
otherwise = [Command]
cs
phase3 :: [Command] -> [Command]
phase3 :: [Command] -> [Command]
phase3 [Command]
cmds = [Command] -> [(Int, Command)] -> [Command]
forall a. [a] -> [(Int, a)] -> [a]
updates ([Command] -> [(Int, Command)] -> [Command]
forall a. [a] -> [(Int, a)] -> [a]
updates [Command]
cmds [(Int, Command)]
jmpBs) [(Int, Command)]
jmpFs
where
jmpBs :: [(Int, Command)]
jmpBs = [(Int, Command)] -> [(Int, Command)]
calcJmpBs ([Int] -> [Command] -> [(Int, Command)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Command]
cmds)
jmpFs :: [(Int, Command)]
jmpFs = [(Int, Command)] -> [(Int, Command)]
calcJmpFs ([Int] -> [Command] -> [(Int, Command)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Command]
cmds)
update :: [a] -> (Int, a) -> [a]
update :: forall a. [a] -> (Int, a) -> [a]
update [a]
xs (Int
i, a
a) = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
i [a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
a] [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [a]
xs
updates :: [a] -> [(Int, a)] -> [a]
updates :: forall a. [a] -> [(Int, a)] -> [a]
updates [a]
xs [] = [a]
xs
updates [a]
xs ((Int, a)
u:[(Int, a)]
us) = [a] -> [(Int, a)] -> [a]
forall a. [a] -> [(Int, a)] -> [a]
updates ([a] -> (Int, a) -> [a]
forall a. [a] -> (Int, a) -> [a]
update [a]
xs (Int, a)
u) [(Int, a)]
us
nested :: Command -> Int
nested :: Command -> Int
nested (JmpForward Int
n) = Int
n
nested (JmpBackward Int
n) = Int
n
nested Command
_ = Int
forall a. HasCallStack => a
undefined
isJmpB :: Command -> Bool
isJmpB (JmpBackward Int
_) = Bool
True
isJmpB Command
_ = Bool
False
isJmpF :: Command -> Bool
isJmpF (JmpForward Int
_) = Bool
True
isJmpF Command
_ = Bool
False
calcJmpBs :: [(Int, Command)] -> [(Int, Command)]
calcJmpBs :: [(Int, Command)] -> [(Int, Command)]
calcJmpBs [(Int, Command)]
cmds = [Maybe (Int, Command)] -> [(Int, Command)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Int, Command)] -> [(Int, Command)])
-> [Maybe (Int, Command)] -> [(Int, Command)]
forall a b. (a -> b) -> a -> b
$ ((Int, Command) -> Maybe (Int, Command))
-> [(Int, Command)] -> [Maybe (Int, Command)]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Command) -> Maybe (Int, Command)
newCmd (((Int, Command) -> Bool) -> [(Int, Command)] -> [(Int, Command)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Command -> Bool
isJmpB (Command -> Bool)
-> ((Int, Command) -> Command) -> (Int, Command) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Command) -> Command
forall a b. (a, b) -> b
snd) [(Int, Command)]
cmds)
where
newCmd :: (Int, Command) -> Maybe (Int, Command)
newCmd (Int
i, Command
c) = (Int, Maybe Int) -> Maybe (Int, Command)
absJmpB (Int
i, [Command] -> Int -> Int -> Maybe Int
findPrevJmpF (((Int, Command) -> Command) -> [(Int, Command)] -> [Command]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Command) -> Command
forall a b. (a, b) -> b
snd [(Int, Command)]
cmds) Int
i (Command -> Int
nested Command
c))
calcJmpFs :: [(Int, Command)] -> [(Int, Command)]
calcJmpFs :: [(Int, Command)] -> [(Int, Command)]
calcJmpFs [(Int, Command)]
cmds = [Maybe (Int, Command)] -> [(Int, Command)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Int, Command)] -> [(Int, Command)])
-> [Maybe (Int, Command)] -> [(Int, Command)]
forall a b. (a -> b) -> a -> b
$ ((Int, Command) -> Maybe (Int, Command))
-> [(Int, Command)] -> [Maybe (Int, Command)]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Command) -> Maybe (Int, Command)
newCmd (((Int, Command) -> Bool) -> [(Int, Command)] -> [(Int, Command)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Command -> Bool
isJmpF (Command -> Bool)
-> ((Int, Command) -> Command) -> (Int, Command) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Command) -> Command
forall a b. (a, b) -> b
snd) [(Int, Command)]
cmds)
where
newCmd :: (Int, Command) -> Maybe (Int, Command)
newCmd (Int
i, Command
c) = (Int, Maybe Int) -> Maybe (Int, Command)
forall {a}. (a, Maybe Int) -> Maybe (a, Command)
absJmpF (Int
i, [Command] -> Int -> Int -> Maybe Int
findNextJmpB (((Int, Command) -> Command) -> [(Int, Command)] -> [Command]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Command) -> Command
forall a b. (a, b) -> b
snd [(Int, Command)]
cmds) Int
i (Command -> Int
nested Command
c))
absJmpB :: (Int, Maybe Int) -> Maybe (Int, Command)
absJmpB :: (Int, Maybe Int) -> Maybe (Int, Command)
absJmpB (Int
_, Maybe Int
Nothing) = Maybe (Int, Command)
forall a. Maybe a
Nothing
absJmpB (Int
i, Just Int
n) = (Int, Command) -> Maybe (Int, Command)
forall a. a -> Maybe a
Just ((Int, Command) -> Maybe (Int, Command))
-> (Int, Command) -> Maybe (Int, Command)
forall a b. (a -> b) -> a -> b
$ (Int
i, Int -> Command
SetIpTo (-Int
n))
absJmpF :: (a, Maybe Int) -> Maybe (a, Command)
absJmpF (a
_, Maybe Int
Nothing) = Maybe (a, Command)
forall a. Maybe a
Nothing
absJmpF (a
i, Just Int
n) = (a, Command) -> Maybe (a, Command)
forall a. a -> Maybe a
Just ((a, Command) -> Maybe (a, Command))
-> (a, Command) -> Maybe (a, Command)
forall a b. (a -> b) -> a -> b
$ (a
i, Int -> Command
SetIpTo (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1))
findPrevJmpF :: [Command]
-> Int
-> Int
-> Maybe Int
findPrevJmpF :: [Command] -> Int -> Int -> Maybe Int
findPrevJmpF [Command]
_ Int
i Int
_ | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = Maybe Int
forall a. Maybe a
Nothing
findPrevJmpF [Command]
cmds Int
i Int
n = case ([Command]
cmds [Command] -> Int -> Command
forall a. HasCallStack => [a] -> Int -> a
!! Int
i) of
(JmpForward Int
l) | Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i
Command
_ -> [Command] -> Int -> Int -> Maybe Int
findPrevJmpF [Command]
cmds (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Int
n
findNextJmpB :: [Command]
-> Int
-> Int
-> Maybe Int
findNextJmpB :: [Command] -> Int -> Int -> Maybe Int
findNextJmpB [Command]
cmds Int
i Int
_ | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [Command] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Command]
cmds = Maybe Int
forall a. Maybe a
Nothing
findNextJmpB [Command]
cmds Int
i Int
n = case ([Command]
cmds [Command] -> Int -> Command
forall a. HasCallStack => [a] -> Int -> a
!! Int
i) of
(JmpBackward Int
l) | Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i
Command
_ -> [Command] -> Int -> Int -> Maybe Int
findNextJmpB [Command]
cmds (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
n
execute :: Array Int Command -> Int -> BF -> IO ()
execute :: Array Int Command -> Int -> BF -> IO ()
execute Array Int Command
cmds Int
n bf :: BF
bf@(BF Core
_ Int
_ Int
ip) = do
if Int
ip Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n Bool -> Bool -> Bool
|| Array Int Command
cmds Array Int Command -> Int -> Command
forall i e. Ix i => Array i e -> i -> e
! Int
ip Command -> Command -> Bool
forall a. Eq a => a -> a -> Bool
== Command
Halt
then IO ()
halt
else Array Int Command -> BF -> IO BF
doCommand Array Int Command
cmds BF
bf IO BF -> (BF -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Array Int Command -> Int -> BF -> IO ()
execute Array Int Command
cmds Int
n
halt :: IO ()
halt = if Bool
debug
then String -> IO ()
putStrLn String
"Machine Halted.\n"
else String -> IO ()
putStrLn String
"\n"