{-

This is an interpreter of the brainf*ck language, written in
the pure, lazy, functional language Haskell.

Copyright (C) 2006 by Jason Dagit <dagit@codersbase.com>

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1307  USA -}

{-# 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
import Control.Monad.State

{- | The complete BF language:

* \>    Increment the pointer.
* \<    Decrement the pointer.
* +     Increment the byte at the pointer.
* \-    Decrement the byte at the pointer.
* .     Output the byte at the pointer.
* ,     Input a byte and store it in the byte at the pointer.
* [     Jump forward past the matching ] if the byte at the pointer is zero.
* ]     Jump backward to the matching [ unless the byte at the pointer is zero.

-}

data Command = IncPtr
             | IncPtrBy !Int  -- ^ Increment pointer by set amount
             | DecPtr
             | IncByte
             | IncByteBy !Int -- ^ Increment by a set amount
             | DecByte
             | OutputByte
         --  | InputByte
             | JmpForward  !Int -- ^ nesting level
             | JmpBackward !Int -- ^ nesting level
             | SetIpTo !Int   -- ^ Sets the instruction ptr to a specific value
             | Halt
             | Ignored
             deriving (Int -> Command -> ShowS
[Command] -> ShowS
Command -> String
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
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 Core
_ Int
cp Int
ip) = String
"BF <core> CorePtr = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
cp forall a. [a] -> [a] -> [a]
++ String
" InstPtr = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
ip

coreSize :: Int
coreSize = Int
30000

core :: IO Core
core :: IO Core
core = forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Int
0, Int
coreSize forall a. Num a => a -> a -> a
- Int
1) (Word8
0::Word8)

decode :: Char -> State Int Command
decode :: Char -> State Int Command
decode Char
'>' = forall (m :: * -> *) a. Monad m => a -> m a
return Command
IncPtr
decode Char
'<' = forall (m :: * -> *) a. Monad m => a -> m a
return Command
DecPtr
decode Char
'+' = forall (m :: * -> *) a. Monad m => a -> m a
return Command
IncByte
decode Char
'-' = forall (m :: * -> *) a. Monad m => a -> m a
return Command
DecByte
decode Char
'.' = forall (m :: * -> *) a. Monad m => a -> m a
return Command
OutputByte
-- decode ',' = return InputByte
decode Char
'[' = do Int
n <- forall s (m :: * -> *). MonadState s m => m s
get
                forall s (m :: * -> *). MonadState s m => s -> m ()
put (Int
nforall a. Num a => a -> a -> a
+Int
1)
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> Command
JmpForward Int
n
decode Char
']' = do Int
n <- forall s (m :: * -> *). MonadState s m => m s
get
                forall s (m :: * -> *). MonadState s m => s -> m ()
put (Int
nforall a. Num a => a -> a -> a
-Int
1)
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> Command
JmpBackward (Int
nforall a. Num a => a -> a -> a
-Int
1)
decode Char
'@' = forall (m :: * -> *) a. Monad m => a -> m a
return Command
Halt
decode Char
_   = 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 = (forall a. Num a => a -> a -> a
+ Int
1)
{-# INLINE incIP #-}

incCP :: CorePtr -> CorePtr
incCP :: Int -> Int
incCP = (forall a. Integral a => a -> a -> a
`mod` Int
coreSize) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int
1 forall a. Num a => a -> a -> a
+)
{-# inlinE incCP #-}

decCP :: CorePtr -> CorePtr
decCP :: Int -> Int
decCP = (forall a. Integral a => a -> a -> a
`mod` Int
coreSize) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 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
_ = forall a. HasCallStack => a
undefined
  doCommand' Command
Ignored Array Int Command
_ (BF Core
c Int
cp Int
ip) = {-# SCC "Ignored" #-} do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Ignored " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show BF
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' Command
IncPtr Array Int Command
_ bf :: BF
bf@(BF Core
c Int
cp Int
ip) = {-# SCC "IncPtr" #-} do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"IncPtr " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show BF
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' Command
DecPtr Array Int Command
_ bf :: BF
bf@(BF Core
c Int
cp Int
ip) = {-# SCC "DecPtr" #-} do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"DecPtr " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show BF
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 Int
n) Array Int Command
_ bf :: BF
bf@(BF Core
c Int
cp Int
ip) = {-# SCC "IncPtrBy" #-} do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"IncPtrBy " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show BF
bf
    forall (m :: * -> *) a. Monad m => a -> m a
return (Core -> Int -> Int -> BF
BF Core
c ((Int
cp forall a. Num a => a -> a -> a
+ Int
n) 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
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"IncByte " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show BF
bf
    forall {m :: * -> *}.
MArray IOUArray Word8 m =>
BF -> (Word8 -> Word8) -> m BF
updateByte BF
bf (forall a. Num a => a -> a -> a
+Word8
1)
  doCommand' Command
DecByte Array Int Command
_ BF
bf = {-# SCC "DecByte" #-} do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"DecByte " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show BF
bf
    forall {m :: * -> *}.
MArray IOUArray Word8 m =>
BF -> (Word8 -> Word8) -> m BF
updateByte BF
bf (forall a. Num a => a -> a -> a
subtract Word8
1)
  doCommand' (IncByteBy Int
n) Array Int Command
_ BF
bf = {-# SCC "IncByteBy" #-} do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"IncByteBy " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show BF
bf
    forall {m :: * -> *}.
MArray IOUArray Word8 m =>
BF -> (Word8 -> Word8) -> m BF
updateByte BF
bf (forall a. Num a => a -> a -> a
+ 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
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"OutputByte " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show BF
bf
    Word8
c' <- 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')
    forall (m :: * -> *) a. Monad m => a -> m a
return (Core -> Int -> Int -> BF
BF Core
c Int
cp (Int -> Int
incIP Int
ip))

{-
  doCommand' InputByte _ bf@(BF c cp ip) = {-# SCC "InputByte" #-} do
    when debug $ putStrLn $ "InputByte " ++ show bf
    c' <- getChar
    let newByte = chrToWord8 c'
    unsafeWrite c cp newByte
    return (BF c cp (incIP ip))
-}

  doCommand' (JmpForward Int
n) Array Int Command
cmds bf :: BF
bf@(BF Core
c Int
cp Int
ip) = {-# SCC "JmpForw" #-} do
    Word8
c' <- 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
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"JmpForward1 " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show BF
bf
        forall (m :: * -> *) a. Monad m => a -> m a
return (Core -> Int -> Int -> BF
BF Core
c Int
cp Int
newInstPtr)
      Word8
_ -> {-# SCC "JmpForward2" #-} do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"JmpForward2 " forall a. [a] -> [a] -> [a]
++ 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))
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"JmpForward3" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show BF
newBF
        forall (m :: * -> *) a. Monad m => a -> m a
return BF
newBF
    where
    -- we add one to go one past the next back jump
    newInstPtr :: Int
newInstPtr = (Array Int Command -> Int -> (Int -> Int) -> Command -> Int
nextJmp Array Int Command
cmds Int
ip (forall a. Num a => a -> a -> a
+Int
1) (Int -> Command
JmpBackward Int
n)) 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' <- 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' forall a. Eq a => a -> a -> Bool
/= Word8
0)
      then do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"JmpBackward1 " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show BF
bf
              forall (m :: * -> *) a. Monad m => a -> m a
return (Core -> Int -> Int -> BF
BF Core
c Int
cp Int
newInstPtr)
      else do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"JmpBackward2 " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show BF
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 (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' <- forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> m e
unsafeRead Core
c Int
cp
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"SetIpTo " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i forall a. [a] -> [a] -> [a]
++ String
" "
                          forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show BF
bf forall a. [a] -> [a] -> [a]
++ String
" @" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word8
c'
    -- jmping behaves differently depending on jmp forward vs. backward
    -- we handle that with pos. vs. neg addresses
    -- Note: SetIpTo 0 is always a JmpBackward
    -- Because the first instruction cannot be SetIpTo 0
    if Int
i forall a. Ord a => a -> a -> Bool
> Int
0
      then if (Word8
c' forall a. Eq a => a -> a -> Bool
== Word8
0)
             then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Core -> Int -> Int -> BF
BF Core
c Int
cp Int
i
             else forall (m :: * -> *) a. Monad m => a -> m a
return 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' forall a. Eq a => a -> a -> Bool
/= Word8
0)
             then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Core -> Int -> Int -> BF
BF Core
c Int
cp (-Int
i)
             else forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall i e. Ix i => Array i e -> i -> e
! Int
ip 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord

word8ToChr :: Word8 -> Char
word8ToChr :: Word8 -> Char
word8ToChr = Int -> Char
chr forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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  <- forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> m e
unsafeRead Core
c Int
cp
  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)
  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 [] = 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)]

-- adding a halt on to the end fixes a bug when called from an irc session
loadProgram String
prog = [Command] -> Array Int Command
optimize ([Command]
csforall a. [a] -> [a] -> [a]
++[Command
Halt])
  where
  cs :: [Command]
cs = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall s a. State s a -> s -> (a, s)
runState (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) Int
0
  n :: Int
n  = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Command]
cs -- strictness

optimize :: [Command] -> Array Int Command
optimize :: [Command] -> Array Int Command
optimize [Command]
cmds = forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Command]
reduced)forall a. Num a => a -> a -> a
-Int
1) [Command]
reduced
  where
  reduced :: [Command]
reduced = [Command] -> [Command]
phase3 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Command] -> [Command]
phase2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Command] -> [Command]
phase1 forall a b. (a -> b) -> a -> b
$ [Command]
cmds
  -- phase1 removes ignored things
  phase1 :: [Command] -> [Command]
  phase1 :: [Command] -> [Command]
phase1 = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/=Command
Ignored)
  -- in phase2 group inc/dec into special instructions
  phase2 :: [Command] -> [Command]
  phase2 :: [Command] -> [Command]
phase2 [Command]
cs = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map [Command] -> [Command]
reduce forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy forall a. Eq a => a -> a -> Bool
(==) [Command]
cs
    where
    reduce :: [Command] -> [Command]
    reduce :: [Command] -> [Command]
reduce [Command]
cs
      | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
==Command
IncPtr)  [Command]
cs = [Int -> Command
IncPtrBy  (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Command]
cs)]
      | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
==Command
DecPtr)  [Command]
cs = [Int -> Command
IncPtrBy  (-(forall (t :: * -> *) a. Foldable t => t a -> Int
length [Command]
cs))]
      | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
==Command
IncByte) [Command]
cs = [Int -> Command
IncByteBy (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Command]
cs)]
      | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
==Command
DecByte) [Command]
cs = [Int -> Command
IncByteBy (-(forall (t :: * -> *) a. Foldable t => t a -> Int
length [Command]
cs))]
      | Bool
otherwise          = [Command]
cs
  -- now we can turn jumps into changes of the ip
  phase3 :: [Command] -> [Command]
  phase3 :: [Command] -> [Command]
phase3 [Command]
cmds = forall a. [a] -> [(Int, a)] -> [a]
updates (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 (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Command]
cmds)
    jmpFs :: [(Int, Command)]
jmpFs = [(Int, Command)] -> [(Int, Command)]
calcJmpFs (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) = forall a. Int -> [a] -> [a]
take Int
i [a]
xs forall a. [a] -> [a] -> [a]
++ [a
a] forall a. [a] -> [a] -> [a]
++ forall a. Int -> [a] -> [a]
drop (Int
iforall 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) = forall a. [a] -> [(Int, a)] -> [a]
updates (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
_               = 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 = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Int, Command) -> Maybe (Int, Command)
newCmd (forall a. (a -> Bool) -> [a] -> [a]
filter (Command -> Bool
isJmpB forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (forall a b. (a -> b) -> [a] -> [b]
map 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 = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Int, Command) -> Maybe (Int, Command)
newCmd (forall a. (a -> Bool) -> [a] -> [a]
filter (Command -> Bool
isJmpF forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Int, Command)]
cmds)
      where
      newCmd :: (Int, Command) -> Maybe (Int, Command)
newCmd (Int
i, Command
c) = forall {a}. (a, Maybe Int) -> Maybe (a, Command)
absJmpF (Int
i, [Command] -> Int -> Int -> Maybe Int
findNextJmpB (forall a b. (a -> b) -> [a] -> [b]
map 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) = forall a. Maybe a
Nothing
    absJmpB (Int
i, Just Int
n)  = forall a. a -> Maybe a
Just 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) = forall a. Maybe a
Nothing
    absJmpF (a
i, Just Int
n)  = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (a
i, Int -> Command
SetIpTo (Int
nforall a. Num a => a -> a -> a
+Int
1))
    findPrevJmpF :: [Command]
                 -> Int -- ^ index to start at
                 -> Int -- ^ nesting level to match
                 -> Maybe Int -- ^ index of next JmpF
    findPrevJmpF :: [Command] -> Int -> Int -> Maybe Int
findPrevJmpF [Command]
_    Int
i Int
_ | Int
i forall a. Ord a => a -> a -> Bool
< Int
0 = forall a. Maybe a
Nothing
    findPrevJmpF [Command]
cmds Int
i Int
n = case ([Command]
cmds forall a. [a] -> Int -> a
!! Int
i) of
                              (JmpForward Int
l) | Int
l forall a. Eq a => a -> a -> Bool
== Int
n -> forall a. a -> Maybe a
Just Int
i
                              Command
_ -> [Command] -> Int -> Int -> Maybe Int
findPrevJmpF [Command]
cmds (Int
iforall a. Num a => a -> a -> a
-Int
1) Int
n

    findNextJmpB :: [Command]
                 -> Int -- ^ index to start at
                 -> Int -- ^ nesting level to match
                 -> Maybe Int -- ^ index of next JmpF
    findNextJmpB :: [Command] -> Int -> Int -> Maybe Int
findNextJmpB [Command]
cmds Int
i Int
_ | Int
i forall a. Ord a => a -> a -> Bool
>= forall (t :: * -> *) a. Foldable t => t a -> Int
length [Command]
cmds = forall a. Maybe a
Nothing
    findNextJmpB [Command]
cmds Int
i    Int
n = case ([Command]
cmds forall a. [a] -> Int -> a
!! Int
i) of
                                 (JmpBackward Int
l) | Int
l forall a. Eq a => a -> a -> Bool
== Int
n -> forall a. a -> Maybe a
Just Int
i
                                 Command
_ -> [Command] -> Int -> Int -> Maybe Int
findNextJmpB [Command]
cmds (Int
iforall 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 forall a. Ord a => a -> a -> Bool
>= Int
n Bool -> Bool -> Bool
|| Array Int Command
cmds forall i e. Ix i => Array i e -> i -> e
! Int
ip 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 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"