でもってHaskellでBF。先日のbf.plより速くなると思う……がその分やや長い。

bf.hs

import System.IO
import System.Environment
import Data.Word
import qualified Data.ByteString as B

-- Utilities

applyFst :: (a -> c) -> (a, b) -> (c, b)
applyFst f (x, y) = (f x, y)

applySnd :: (b -> c) -> (a, b) -> (a, c)
applySnd f (x, y) = (x, f y)

repeatApply :: Int -> (a -> a) -> a -> a
repeatApply n f = foldr1 (.) (replicate n f)


-- Tape, which reperesents finite/infinite list and current position
-- fst: members prior to the current position in reverse order.
-- snd: the current position and members after the current position.
type Tape a = ([a], [a])

tapeFromList :: [a] -> Tape a
tapeFromList xs = ([], xs)

-- Increase the position of a tape.
tapeInc :: Tape a -> Tape a
tapeInc (xs, y:ys) = (y:xs, ys)

tapeIncWithAutoExtension :: a -> Tape a -> Tape a
tapeIncWithAutoExtension init (xs, [y])  = (y:xs, [init])
tapeIncWithAutoExtension _    (xs, y:ys) = (y:xs, ys)

-- Decrease the position of a tape.
tapeDec :: Tape a -> Tape a
tapeDec (x:xs, ys) = (xs, x:ys)

tapeDecWithAutoExtension :: a -> Tape a -> Tape a
tapeDecWithAutoExtension init ([], ys)   = ([], init:ys)
tapeDecWithAutoExtension _    (x:xs, ys) = (xs, x:ys)

tapeApplyCurrent :: (a -> a) -> Tape a -> Tape a
tapeApplyCurrent f tape = applySnd (\(x:xs) -> f x : xs) tape

tapeGetCurrent :: Tape a -> a
tapeGetCurrent (_, y:_) = y

tapeTryGetCurrent :: Tape a -> Maybe a
tapeTryGetCurrent (_, [])   = Nothing
tapeTryGetCurrent (_, y:_) = Just y

-- Brainf*ck instructions for internal use.
-- A series of instructions are compounded to one internal instruction.
data BFInst = PAccum Int     -- accumulate pointer
            | DAccum Int     -- accumulate data
            | Outb           -- output byte
            | Inb            -- input byte
            | While [BFInst] -- while block
              deriving Show

seriesCount :: Char -> Char -> String -> (Int, String)
seriesCount _ _ [] = (0, [])
seriesCount incChar decChar src@(s:ss) | s == incChar = applyFst (+1)         $ seriesCount incChar decChar ss
                                       | s == decChar = applyFst (flip (-) 1) $ seriesCount incChar decChar ss
                                       | otherwise    = (0, src)

compoundInst :: (Int -> BFInst) -> Char -> Char -> Int -> String -> ([BFInst], String)
compoundInst inst incChar decChar level src
  = let (n, src2) = seriesCount incChar decChar src in
     if n == 0 then readBFSourceWithLevel level src2
               else applyFst (inst n :) $ readBFSourceWithLevel level src2

-- block-nest-level -> source -> (instructions, the-rest-of-source)
readBFSourceWithLevel :: Int -> String -> ([BFInst], String)
readBFSourceWithLevel _ [] = ([], [])
readBFSourceWithLevel level src@(s:ss) | (s == '>') || (s == '<') = compoundInst PAccum '>' '<' level src
                                       | (s == '+') || (s == '-') = compoundInst DAccum '+' '-' level src
                                       | s == '.'                 = applyFst (Outb:) $ readBFSourceWithLevel level ss
                                       | s == ','                 = applyFst (Inb:)  $ readBFSourceWithLevel level ss
                                       | s == '['                 = let (block, src2) = readBFSourceWithLevel (level + 1) ss
                                                                    in applyFst (While block :) $ readBFSourceWithLevel level src2
                                       | s == ']'                 = ([], ss)
                                       | otherwise                = readBFSourceWithLevel level ss
-- read a string and convert to brainf*ck instructions
readBFSource :: String -> [BFInst]
readBFSource src = fst $ readBFSourceWithLevel 0 src


runBF :: Handle -> Handle -> [BFInst] -> IO()
runBF ihandle ohandle prog
  = do runBFWithProgTape (tapeFromList prog) (tapeFromList [0])
       return ()
    where
      -- a tape of program -> a tape of data -> a tape of program with the next position
      runBFWithProgTape :: Tape BFInst -> Tape Word8 -> IO (Tape Word8)
      runBFWithProgTape progTape dataTape
        = case tapeTryGetCurrent progTape of
            Just (PAccum n)    -> runBFWithProgTape nextTape $ if n > 0 then repeatApply n    (tapeIncWithAutoExtension 0) dataTape
                                                                        else repeatApply (-n) (tapeDecWithAutoExtension 0) dataTape
            Just (DAccum n)    -> runBFWithProgTape nextTape $ tapeApplyCurrent (fromIntegral . (+n) . fromIntegral) dataTape
            Just Outb          -> do B.hPut ohandle $ B.pack [tapeGetCurrent dataTape]
                                     runBFWithProgTape nextTape dataTape
            Just Inb           -> do bs <- B.hGet ihandle 1
                                     runBFWithProgTape nextTape $ tapeApplyCurrent (\_ -> B.head bs) dataTape
            Just (While block) -> if tapeGetCurrent dataTape == 0
                                  then runBFWithProgTape nextTape dataTape
                                  else do dataTape2 <- runBFWithProgTape (tapeFromList block) dataTape
                                          runBFWithProgTape progTape dataTape2
            Nothing             -> return dataTape
            where nextTape = tapeInc progTape

main = do args <- getArgs
          source <- readFile (if args == [] then "/dev/stdin" else head args)
          runBF stdin stdout $ readBFSource source