lambdabot-4.1: scripts/BF.hs
{-# OPTIONS -cpp #-}
-- This is an interpreter of the braif*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
--
import Data.Array.IO
#if __GLASGOW_HASKELL__ >= 606
import Data.Array hiding (array)
#else
import Data.Array hiding (array,bounds)
#endif
import Data.Array.Base (unsafeRead, unsafeWrite, array)
import Data.Word ( Word8(..) )
import Data.Char ( ord, chr )
import Data.List ( find, findIndex, groupBy )
import Data.Maybe ( catMaybes )
import Control.Monad ( when )
import Control.Monad.State
import System.Posix.Resource
rlimit = ResourceLimit 3
main = setResourceLimit ResourceCPUTime (ResourceLimits rlimit rlimit) >> run
run = do
prog <- getContents
c <- core
let cmds = loadProgram prog
when debug $ print cmds
execute cmds (snd (bounds cmds)) (BF c 0 0)
{- | 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 (Show, Eq)
type Core = IOUArray Int Word8
type InstPtr = Int
type CorePtr = Int
data BF = BF !Core !CorePtr !InstPtr
instance Show BF where
show (BF c cp ip) = "BF <core> CorePtr = " ++ show cp ++ " InstPtr = " ++ show ip
coreSize = 30000
core :: IO Core
core = newArray (0, coreSize - 1) (0::Word8)
decode :: Char -> State Int Command
decode '>' = return IncPtr
decode '<' = return DecPtr
decode '+' = return IncByte
decode '-' = return DecByte
decode '.' = return OutputByte
-- decode ',' = return InputByte
decode '[' = do n <- get
put (n+1)
return $ JmpForward n
decode ']' = do n <- get
put (n-1)
return $ JmpBackward (n-1)
decode '@' = return Halt
decode _ = return Ignored
debug = False
incIP :: InstPtr -> InstPtr
incIP = (+ 1)
{-# INLINE incIP #-}
incCP :: CorePtr -> CorePtr
incCP = (`mod` coreSize) . (1 +)
{-# inlinE incCP #-}
decCP :: CorePtr -> CorePtr
decCP = (`mod` coreSize) . subtract 1
{-# INLINE decCP #-}
doCommand :: Array Int Command -> BF -> IO BF
doCommand cmds bf@(BF _ _ ip) = doCommand' (cmds ! ip) cmds bf
where
doCommand' :: Command -> Array Int Command -> BF -> IO BF
doCommand' Halt _ _ = undefined
doCommand' Ignored _ (BF c cp ip) = {-# SCC "Ignored" #-} do
when debug $ putStrLn $ "Ignored " ++ show bf
return (BF c cp (incIP ip))
doCommand' IncPtr _ bf@(BF c cp ip) = {-# SCC "IncPtr" #-} do
when debug $ putStrLn $ "IncPtr " ++ show bf
return (BF c (incCP cp) (incIP ip))
doCommand' DecPtr _ bf@(BF c cp ip) = {-# SCC "DecPtr" #-} do
when debug $ putStrLn $ "DecPtr " ++ show bf
return (BF c (decCP cp) (incIP ip))
doCommand' (IncPtrBy n) _ bf@(BF c cp ip) = {-# SCC "IncPtrBy" #-} do
when debug $ putStrLn $ "IncPtrBy " ++ show n ++ " " ++ show bf
return (BF c ((cp + n) `mod` coreSize) (incIP ip))
doCommand' IncByte _ bf = {-# SCC "IncByte" #-} do
when debug $ putStrLn $ "IncByte " ++ show bf
updateByte bf (+1)
doCommand' DecByte _ bf = {-# SCC "DecByte" #-} do
when debug $ putStrLn $ "DecByte " ++ show bf
updateByte bf (subtract 1)
doCommand' (IncByteBy n) _ bf = {-# SCC "IncByteBy" #-} do
when debug $ putStrLn $ "IncByteBy " ++ show n ++ " " ++ show bf
updateByte bf (+ fromIntegral n)
doCommand' OutputByte _ bf@(BF c cp ip) = {-# SCC "OutputByte" #-} do
when debug $ putStrLn $ "OutputByte " ++ show bf
c' <- unsafeRead c cp
putChar (word8ToChr c')
return (BF c cp (incIP 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 n) cmds bf@(BF c cp ip) = {-# SCC "JmpForw" #-} do
c' <- unsafeRead c cp
case c' of
0 -> {-# SCC "JmpForward1" #-} do
when debug $ putStrLn $ "JmpForward1 " ++ show bf
return (BF c cp newInstPtr)
_ -> {-# SCC "JmpForward2" #-} do
when debug $ putStrLn $ "JmpForward2 " ++ show bf
let newBF = (BF c cp (incIP ip))
when debug $ putStrLn $ "JmpForward3" ++ show newBF
return newBF
where
-- we add one to go one past the next back jump
newInstPtr = (nextJmp cmds ip (+1) (JmpBackward n)) + 1
doCommand' (JmpBackward n) cmds bf@(BF c cp ip) = {-# SCC "JmpBack" #-} do
c' <- unsafeRead c cp
if (c' /= 0)
then do when debug $ putStrLn $ "JmpBackward1 " ++ show bf
return (BF c cp newInstPtr)
else do when debug $ putStrLn $ "JmpBackward2 " ++ show bf
return (BF c cp (incIP ip))
where
newInstPtr = nextJmp cmds ip (subtract 1) (JmpForward n)
doCommand' (SetIpTo i) _ bf@(BF c cp ip) = {-# SCC "SetIPTo" #-} do
c' <- unsafeRead c cp
when debug $ putStrLn $ "SetIpTo " ++ show i ++ " "
++ show bf ++ " @" ++ show 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 i > 0
then if (c' == 0)
then return $ BF c cp i
else return $ BF c cp (incIP ip)
else if (c' /= 0)
then return $ BF c cp (-i)
else return $ BF c cp (incIP ip)
nextJmp :: Array Int Command
-> InstPtr
-> (InstPtr -> InstPtr) -> Command -> InstPtr
nextJmp cmds ip f cmd = if cmds ! ip == cmd
then ip
else nextJmp cmds (f ip) f cmd
chrToWord8 :: Char -> Word8
chrToWord8 = fromIntegral . ord
word8ToChr :: Word8 -> Char
word8ToChr = chr . fromIntegral
updateByte (BF c cp ip) f = do
e <- unsafeRead c cp
unsafeWrite c cp (f e)
return (BF c cp (incIP ip))
{-# INLINE updateByte #-}
loadProgram :: String -> Array Int Command
loadProgram [] = array (0, 0) [(0, Halt)]
-- adding a halt on to the end fixes a bug when called from an irc session
loadProgram prog = optimize (cs++[Halt])
where
cs = fst $ runState (mapM decode prog) 0
n = length cs
optimize :: [Command] -> Array Int Command
optimize cmds = listArray (0, (length reduced)-1) reduced
where
reduced = phase3 . phase2 . phase1 $ cmds
-- phase1 removes ignored things
phase1 :: [Command] -> [Command]
phase1 = filter (/=Ignored)
-- in phase2 group inc/dec into special instructions
phase2 :: [Command] -> [Command]
phase2 cs = concat $ map reduce $ groupBy (==) cs
where
reduce :: [Command] -> [Command]
reduce cs
| all (==IncPtr) cs = [IncPtrBy (length cs)]
| all (==DecPtr) cs = [IncPtrBy (-(length cs))]
| all (==IncByte) cs = [IncByteBy (length cs)]
| all (==DecByte) cs = [IncByteBy (-(length cs))]
| otherwise = cs
-- now we can turn jumps into changes of the ip
phase3 :: [Command] -> [Command]
phase3 cmds = updates (updates cmds jmpBs) jmpFs
where
jmpBs = calcJmpBs (zip [0..] cmds)
jmpFs = calcJmpFs (zip [0..] cmds)
update :: [a] -> (Int, a) -> [a]
update xs (i, a) = take i xs ++ [a] ++ drop (i+1) xs
updates :: [a] -> [(Int, a)] -> [a]
updates xs [] = xs
updates xs (u:us) = updates (update xs u) us
nested :: Command -> Int
nested (JmpForward n) = n
nested (JmpBackward n) = n
nested _ = undefined
isJmp (JmpForward _) = True
isJmp (JmpBackward _) = False
isJmpB (JmpBackward _) = True
isJmpB _ = False
isJmpF (JmpForward _) = True
isJmpF _ = False
calcJmpBs :: [(Int, Command)] -> [(Int, Command)]
calcJmpBs cmds = catMaybes $ map newCmd (filter (isJmpB . snd) cmds)
where
newCmd (i, c) = absJmpB (i, findPrevJmpF (map snd cmds) i (nested c))
calcJmpFs :: [(Int, Command)] -> [(Int, Command)]
calcJmpFs cmds = catMaybes $ map newCmd (filter (isJmpF . snd) cmds)
where
newCmd (i, c) = absJmpF (i, findNextJmpB (map snd cmds) i (nested c))
absJmpB :: (Int, Maybe Int) -> Maybe (Int, Command)
absJmpB (_, Nothing) = Nothing
absJmpB (i, Just n) = Just $ (i, SetIpTo (-n))
absJmpF (_, Nothing) = Nothing
absJmpF (i, Just n) = Just $ (i, SetIpTo (n+1))
findPrevJmpF :: [Command]
-> Int -- ^ index to start at
-> Int -- ^ nesting level to match
-> Maybe Int -- ^ index of next JmpF
findPrevJmpF _ i _ | i < 0 = Nothing
findPrevJmpF cmds i n = case (cmds !! i) of
(JmpForward l) | l == n -> Just i
_ -> findPrevJmpF cmds (i-1) n
findNextJmpB :: [Command]
-> Int -- ^ index to start at
-> Int -- ^ nesting level to match
-> Maybe Int -- ^ index of next JmpF
findNextJmpB cmds i _ | i >= length cmds = Nothing
findNextJmpB cmds i n = case (cmds !! i) of
(JmpBackward l) | l == n -> Just i
_ -> findNextJmpB cmds (i+1) n
execute :: Array Int Command -> Int -> BF -> IO ()
execute cmds n bf@(BF c cp ip) = do
if ip >= n || cmds ! ip == Halt
then halt
else doCommand cmds bf >>= execute cmds n
halt = if debug
then putStrLn "Machine Halted.\n"
else putStrLn "\n"
-- Example Programs
helloWorld =
">+++++++++[<++++++++>-]<.>+++++++[<++++>-]<+.+++++++..+++.[-]>++++++++[<++++>-]"++
"<.#>+++++++++++[<+++++>-]<.>++++++++[<+++>-]<.+++.------.--------.[-]>++++++++["++
"<++++>-]<+.[-]++++++++++."
-- works now, thanks to int-e for explaining the BF spec to me
bottles =
"99 Bottles of Beer in Urban Mueller's BrainF*** (The actual"++
"name is impolite)"++
""++
"by Ben Olmstead"++
""++
"ANSI C interpreter available on the internet; due to"++
"constraints in comments the address below needs to have the"++
"stuff in parenthesis replaced with the appropriate symbol:"++
""++
"http://www(dot)cats(dash)eye(dot)com/cet/soft/lang/bf/"++
""++
"Believe it or not this language is indeed Turing complete!"++
"Combines the speed of BASIC with the ease of INTERCAL and"++
"the readability of an IOCCC entry!"++
""++
">+++++++++[<+++++++++++>-]<[>[-]>[-]<<[>+>+<<-]>>[<<+>>-]>>>"++
"[-]<<<+++++++++<[>>>+<<[>+>[-]<<-]>[<+>-]>[<<++++++++++>>>+<"++
"-]<<-<-]+++++++++>[<->-]>>+>[<[-]<<+>>>-]>[-]+<<[>+>-<<-]<<<"++
"[>>+>+<<<-]>>>[<<<+>>>-]>[<+>-]<<-[>[-]<[-]]>>+<[>[-]<-]<+++"++
"+++++[<++++++<++++++>>-]>>>[>+>+<<-]>>[<<+>>-]<[<<<<<.>>>>>-"++
"]<<<<<<.>>[-]>[-]++++[<++++++++>-]<.>++++[<++++++++>-]<++.>+"++
"++++[<+++++++++>-]<.><+++++..--------.-------.>>[>>+>+<<<-]>"++
">>[<<<+>>>-]<[<<<<++++++++++++++.>>>>-]<<<<[-]>++++[<+++++++"++
"+>-]<.>+++++++++[<+++++++++>-]<--.---------.>+++++++[<------"++
"---->-]<.>++++++[<+++++++++++>-]<.+++..+++++++++++++.>++++++"++
"++[<---------->-]<--.>+++++++++[<+++++++++>-]<--.-.>++++++++"++
"[<---------->-]<++.>++++++++[<++++++++++>-]<++++.-----------"++
"-.---.>+++++++[<---------->-]<+.>++++++++[<+++++++++++>-]<-."++
">++[<----------->-]<.+++++++++++..>+++++++++[<---------->-]<"++
"-----.---.>>>[>+>+<<-]>>[<<+>>-]<[<<<<<.>>>>>-]<<<<<<.>>>+++"++
"+[<++++++>-]<--.>++++[<++++++++>-]<++.>+++++[<+++++++++>-]<."++
"><+++++..--------.-------.>>[>>+>+<<<-]>>>[<<<+>>>-]<[<<<<++"++
"++++++++++++.>>>>-]<<<<[-]>++++[<++++++++>-]<.>+++++++++[<++"++
"+++++++>-]<--.---------.>+++++++[<---------->-]<.>++++++[<++"++
"+++++++++>-]<.+++..+++++++++++++.>++++++++++[<---------->-]<"++
"-.---.>+++++++[<++++++++++>-]<++++.+++++++++++++.++++++++++."++
"------.>+++++++[<---------->-]<+.>++++++++[<++++++++++>-]<-."++
"-.---------.>+++++++[<---------->-]<+.>+++++++[<++++++++++>-"++
"]<--.+++++++++++.++++++++.---------.>++++++++[<---------->-]"++
"<++.>+++++[<+++++++++++++>-]<.+++++++++++++.----------.>++++"++
"+++[<---------->-]<++.>++++++++[<++++++++++>-]<.>+++[<----->"++
"-]<.>+++[<++++++>-]<..>+++++++++[<--------->-]<--.>+++++++[<"++
"++++++++++>-]<+++.+++++++++++.>++++++++[<----------->-]<++++"++
".>+++++[<+++++++++++++>-]<.>+++[<++++++>-]<-.---.++++++.----"++
"---.----------.>++++++++[<----------->-]<+.---.[-]<<<->[-]>["++
"-]<<[>+>+<<-]>>[<<+>>-]>>>[-]<<<+++++++++<[>>>+<<[>+>[-]<<-]"++
">[<+>-]>[<<++++++++++>>>+<-]<<-<-]+++++++++>[<->-]>>+>[<[-]<"++
"<+>>>-]>[-]+<<[>+>-<<-]<<<[>>+>+<<<-]>>>[<<<+>>>-]<>>[<+>-]<"++
"<-[>[-]<[-]]>>+<[>[-]<-]<++++++++[<++++++<++++++>>-]>>>[>+>+"++
"<<-]>>[<<+>>-]<[<<<<<.>>>>>-]<<<<<<.>>[-]>[-]++++[<++++++++>"++
"-]<.>++++[<++++++++>-]<++.>+++++[<+++++++++>-]<.><+++++..---"++
"-----.-------.>>[>>+>+<<<-]>>>[<<<+>>>-]<[<<<<++++++++++++++"++
".>>>>-]<<<<[-]>++++[<++++++++>-]<.>+++++++++[<+++++++++>-]<-"++
"-.---------.>+++++++[<---------->-]<.>++++++[<+++++++++++>-]"++
"<.+++..+++++++++++++.>++++++++[<---------->-]<--.>+++++++++["++
"<+++++++++>-]<--.-.>++++++++[<---------->-]<++.>++++++++[<++"++
"++++++++>-]<++++.------------.---.>+++++++[<---------->-]<+."++
">++++++++[<+++++++++++>-]<-.>++[<----------->-]<.+++++++++++"++
"..>+++++++++[<---------->-]<-----.---.+++.---.[-]<<<]"++
"@"
helloum =
"++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++.>+.+++++++..+++.>++.<<+++++++++++++++.>.+++.------.--------.>+.>.@"
-- can't figure this one out either...
sort =
"Here is a Brainf*** program that bubblesorts its input and spits it out:"++
">>>>>,+[>>>,+]<<<[<<<"++
"[>>>[-<<<-<+>[>]>>]<<<[<]>>"++
"[>>>+<<<-]<[>+>>>+<<<<-]"++
"<<]>>>[-.[-]]>>>[>>>]<<<]"
toupper =
",----------[----------------------.,----------]"
{-
Example optimized programs:
++++[>++++++++<-]>[.+]
[(0,IncByteBy 4), (1,SetIpTo 7), (2,IncPtrBy 1),
(3,IncByteBy 8), (4,IncPtrBy (-1)), (5,IncByteBy (-1)),
(6,SetIpTo (-1)), (7,IncPtrBy 1), (8,SetIpTo 12),
(9,OutputByte), (10,IncByteBy 1), (11,SetIpTo (-8)),
(12,Halt)
]
[[]]
[(0,SetIpTo 4),
(1,SetIpTo 3),
(2,SetIpTo (-1)),
(3,SetIpTo 0),
(4,Halt)
]
-}