{-

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., 59 Temple Place, Suite 330, Boston, MA  02111-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.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
(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 ',' = return InputByte
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' 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' <- 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
    -- 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 (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'
    -- 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 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)]

-- 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]
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 -- strictness

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 removes ignored things
  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)
  -- in phase2 group inc/dec into special instructions
  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
  -- now we can turn jumps into changes of the ip
  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 -- ^ 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 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 -- ^ 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 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"