{-# 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
showList :: [Command] -> ShowS
$cshowList :: [Command] -> ShowS
show :: Command -> String
$cshow :: Command -> String
showsPrec :: Int -> Command -> ShowS
$cshowsPrec :: Int -> Command -> ShowS
Show, Command -> Command -> Bool
(Command -> Command -> Bool)
-> (Command -> Command -> Bool) -> Eq Command
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Command -> Command -> Bool
$c/= :: Command -> Command -> Bool
== :: Command -> Command -> Bool
$c== :: 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 _ cp :: Int
cp ip :: Int
ip) = "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]
++ " InstPtr = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ip
coreSize :: Int
coreSize = 30000
core :: IO Core
core :: IO Core
core = (Int, Int) -> Word8 -> IO Core
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (0, Int
coreSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) (0::Word8)
decode :: Char -> State Int Command
decode :: Char -> State Int Command
decode '>' = Command -> State Int Command
forall (m :: * -> *) a. Monad m => a -> m a
return Command
IncPtr
decode '<' = Command -> State Int Command
forall (m :: * -> *) a. Monad m => a -> m a
return Command
DecPtr
decode '+' = Command -> State Int Command
forall (m :: * -> *) a. Monad m => a -> m a
return Command
IncByte
decode '-' = Command -> State Int Command
forall (m :: * -> *) a. Monad m => a -> m a
return Command
DecByte
decode '.' = Command -> State Int Command
forall (m :: * -> *) a. Monad m => a -> m a
return Command
OutputByte
decode '[' = 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
+1)
Command -> State Int Command
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 ']' = 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
-1)
Command -> State Int Command
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
-1)
decode '@' = Command -> State Int Command
forall (m :: * -> *) a. Monad m => a -> m a
return Command
Halt
decode _ = Command -> State Int Command
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
+ 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
. (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 1
{-# INLINE decCP #-}
doCommand :: Array Int Command -> BF -> IO BF
doCommand :: Array Int Command -> BF -> IO BF
doCommand cmds :: Array Int Command
cmds bf :: BF
bf@(BF _ _ ip :: 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' Halt _ _ = IO BF
forall a. HasCallStack => a
undefined
doCommand' Ignored _ (BF c :: Core
c cp :: Int
cp ip :: 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
$ "Ignored " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BF -> String
forall a. Show a => a -> String
show BF
bf
BF -> IO BF
forall (m :: * -> *) a. Monad m => a -> m a
return (Core -> Int -> Int -> BF
BF Core
c Int
cp (Int -> Int
incIP Int
ip))
doCommand' IncPtr _ bf :: BF
bf@(BF c :: Core
c cp :: Int
cp ip :: 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
$ "IncPtr " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BF -> String
forall a. Show a => a -> String
show BF
bf
BF -> IO BF
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' DecPtr _ bf :: BF
bf@(BF c :: Core
c cp :: Int
cp ip :: 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
$ "DecPtr " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BF -> String
forall a. Show a => a -> String
show BF
bf
BF -> IO BF
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 n :: Int
n) _ bf :: BF
bf@(BF c :: Core
c cp :: Int
cp ip :: 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
$ "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 -> ShowS
forall a. [a] -> [a] -> [a]
++ BF -> String
forall a. Show a => a -> String
show BF
bf
BF -> IO BF
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' IncByte _ bf :: 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
$ "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
+1)
doCommand' DecByte _ bf :: 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
$ "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 1)
doCommand' (IncByteBy n :: Int
n) _ bf :: 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
$ "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 -> 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' OutputByte _ bf :: BF
bf@(BF c :: Core
c cp :: Int
cp ip :: 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
$ "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 (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 (m :: * -> *) a. Monad m => a -> m a
return (Core -> Int -> Int -> BF
BF Core
c Int
cp (Int -> Int
incIP Int
ip))
doCommand' (JmpForward n :: Int
n) cmds :: Array Int Command
cmds bf :: BF
bf@(BF c :: Core
c cp :: Int
cp ip :: Int
ip) = {-# SCC "JmpForw" #-} do
Word8
c' <- Core -> 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
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
$ "JmpForward1 " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BF -> String
forall a. Show a => a -> String
show BF
bf
BF -> IO BF
forall (m :: * -> *) a. Monad m => a -> m a
return (Core -> Int -> Int -> BF
BF Core
c Int
cp Int
newInstPtr)
_ -> {-# 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
$ "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
$ "JmpForward3" String -> ShowS
forall a. [a] -> [a] -> [a]
++ BF -> String
forall a. Show a => a -> String
show BF
newBF
BF -> IO BF
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
+1) (Int -> Command
JmpBackward Int
n)) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
doCommand' (JmpBackward n :: Int
n) cmds :: Array Int Command
cmds bf :: BF
bf@(BF c :: Core
c cp :: Int
cp ip :: Int
ip) = {-# SCC "JmpBack" #-} do
Word8
c' <- Core -> 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
/= 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
$ "JmpBackward1 " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BF -> String
forall a. Show a => a -> String
show BF
bf
BF -> IO BF
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
$ "JmpBackward2 " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BF -> String
forall a. Show a => a -> String
show BF
bf
BF -> IO BF
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 1) (Int -> Command
JmpForward Int
n)
doCommand' (SetIpTo i :: Int
i) _ bf :: BF
bf@(BF c :: Core
c cp :: Int
cp ip :: Int
ip) = {-# SCC "SetIPTo" #-} do
Word8
c' <- Core -> 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
$ "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 -> 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 -> 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
> 0
then if (Word8
c' Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 0)
then BF -> IO BF
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 (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
/= 0)
then BF -> IO BF
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 (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 cmds :: Array Int Command
cmds ip :: Int
ip f :: Int -> Int
f cmd :: 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 c :: Core
c cp :: Int
cp ip :: Int
ip) f :: Word8 -> Word8
f = do
Word8
e <- Core -> 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 (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 (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 (0, 0) [(0, Command
Halt)]
loadProgram prog :: 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)
mapM Char -> State Int Command
decode String
prog) 0
n :: Int
n = [Command] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Command]
cs
optimize :: [Command] -> Array Int Command
optimize :: [Command] -> Array Int Command
optimize cmds :: [Command]
cmds = (Int, Int) -> [Command] -> Array Int Command
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (0, ([Command] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Command]
reduced)Int -> Int -> Int
forall a. Num a => a -> a -> a
-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 cs :: [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 cs :: [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 (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 (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 (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 (t :: * -> *) a. Foldable t => t a -> Int
length [Command]
cs))]
| Bool
otherwise = [Command]
cs
phase3 :: [Command] -> [Command]
phase3 :: [Command] -> [Command]
phase3 cmds :: [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 [0..] [Command]
cmds)
jmpFs :: [(Int, Command)]
jmpFs = [(Int, Command)] -> [(Int, Command)]
calcJmpFs ([Int] -> [Command] -> [(Int, Command)]
forall a b. [a] -> [b] -> [(a, b)]
zip [0..] [Command]
cmds)
update :: [a] -> (Int, a) -> [a]
update :: [a] -> (Int, a) -> [a]
update xs :: [a]
xs (i :: Int
i, a :: 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
+1) [a]
xs
updates :: [a] -> [(Int, a)] -> [a]
updates :: [a] -> [(Int, a)] -> [a]
updates xs :: [a]
xs [] = [a]
xs
updates xs :: [a]
xs (u :: (Int, a)
u:us :: [(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 n :: Int
n) = Int
n
nested (JmpBackward n :: Int
n) = Int
n
nested _ = Int
forall a. HasCallStack => a
undefined
isJmpB :: Command -> Bool
isJmpB (JmpBackward _) = Bool
True
isJmpB _ = Bool
False
isJmpF :: Command -> Bool
isJmpF (JmpForward _) = Bool
True
isJmpF _ = Bool
False
calcJmpBs :: [(Int, Command)] -> [(Int, Command)]
calcJmpBs :: [(Int, Command)] -> [(Int, Command)]
calcJmpBs cmds :: [(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 (i :: Int
i, c :: 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 cmds :: [(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 (i :: Int
i, c :: 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 (_, Nothing) = Maybe (Int, Command)
forall a. Maybe a
Nothing
absJmpB (i :: Int
i, Just n :: 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 (_, Nothing) = Maybe (a, Command)
forall a. Maybe a
Nothing
absJmpF (i :: a
i, Just n :: 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
+1))
findPrevJmpF :: [Command]
-> Int
-> Int
-> Maybe Int
findPrevJmpF :: [Command] -> Int -> Int -> Maybe Int
findPrevJmpF _ i :: Int
i _ | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0 = Maybe Int
forall a. Maybe a
Nothing
findPrevJmpF cmds :: [Command]
cmds i :: Int
i n :: Int
n = case ([Command]
cmds [Command] -> Int -> Command
forall a. [a] -> Int -> a
!! Int
i) of
(JmpForward l :: 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] -> Int -> Int -> Maybe Int
findPrevJmpF [Command]
cmds (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) Int
n
findNextJmpB :: [Command]
-> Int
-> Int
-> Maybe Int
findNextJmpB :: [Command] -> Int -> Int -> Maybe Int
findNextJmpB cmds :: [Command]
cmds i :: Int
i _ | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [Command] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Command]
cmds = Maybe Int
forall a. Maybe a
Nothing
findNextJmpB cmds :: [Command]
cmds i :: Int
i n :: Int
n = case ([Command]
cmds [Command] -> Int -> Command
forall a. [a] -> Int -> a
!! Int
i) of
(JmpBackward l :: 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] -> Int -> Int -> Maybe Int
findNextJmpB [Command]
cmds (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) Int
n
execute :: Array Int Command -> Int -> BF -> IO ()
execute :: Array Int Command -> Int -> BF -> IO ()
execute cmds :: Array Int Command
cmds n :: Int
n bf :: BF
bf@(BF _ _ ip :: 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 (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 "Machine Halted.\n"
else String -> IO ()
putStrLn "\n"