    {-

    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
    (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"