moudame

bf1.hs

import Data.Char
import Data.List
import Text.Regex
import Text.Regex.Base.RegexLike

splitJmp :: String -> (String, String)
splitJmp ss = 
    let isLoop s = head s == '[' && last s == ']' && matchCount (mkRegex "\\[") s == matchCount (mkRegex "\\]") s in
    case elemIndex True $ map (\i -> isLoop $ take i ss) [1..length ss] of
        Just i  -> (init . tail $ take i ss, drop i ss)
        Nothing -> error "lack of ]"

splitJmp' :: Int -> String -> String -> (String, String)
splitJmp' 0 acc (']':xs) = (reverse acc, xs)
splitJmp' n acc (']':xs) = splitJmp' (n-1) (']':acc) xs
splitJmp' n acc ('[':xs) = splitJmp' (n+1) ('[':acc) xs
splitJmp' n acc (x:xs) = splitJmp' n (x:acc) xs

bf :: String -> [Int] -> Int -> [String] -> IO ()
bf (c:tape) mem ptr stack = case c of
    '>' -> bf tape mem (ptr + 1) stack
    '<' -> bf tape mem (ptr - 1) stack
    '+' -> bf tape ((take ptr mem) ++ [(mem !! ptr) + 1] ++ (drop (ptr + 1) mem)) ptr stack
    '-' -> bf tape ((take ptr mem) ++ [(mem !! ptr) - 1] ++ (drop (ptr + 1) mem)) ptr stack
    '.' -> do
        putChar . chr $ mem !! ptr
        bf tape mem ptr stack
    ',' -> do
        ch <- getChar
        bf tape (take ptr mem ++ [ord ch] ++ drop (ptr + 1) mem) ptr stack
    -- '[' | mem !! ptr == 0 -> bf (tail $ dropWhile (/= ']') tape) mem ptr stack
    --     | otherwise       -> bf tape mem ptr $ (takeWhile (/= ']') tape):stack
    -- ']' | mem !! ptr == 0 -> bf tape mem ptr stack
    --     | otherwise       -> bf (head stack ++ (']':tape)) mem ptr stack
    '[' | mem !! ptr == 0 -> bf (snd ss) mem ptr stack
        | otherwise       -> bf tape mem ptr $ (fst ss):stack
    ']' | mem !! ptr == 0 -> bf tape mem ptr stack
        | otherwise       -> bf (head stack ++ ']':tape) mem ptr stack
    _   -> error $ "invalid call \"" ++ c:"\""
    where ss = splitJmp (c:tape)

-- bf ('>':tape) mem ptr stack = bf tape mem (ptr + 1) stack
-- bf ('<':tape) mem ptr stack = bf tape mem (ptr - 1) stack
-- bf ('+':tape) mem ptr stack = 
-- bf ('-':tape) mem ptr stack = 
-- bf ('.':tape) mem ptr stack = do
--     putChar . chr $ mem !! ptr
--     
-- bf (',':tape) mem ptr stack = do
--     c <- getChar
--     bf tape (take ptr mem ++ [ord c] ++ drop (ptr + 1) mem) ptr stack
-- bf ('[':tape) mem ptr stack
--     | mem !! ptr == 0 = bf (tail $ dropWhile (/= ']') tape) mem ptr stack
--     | otherwise       = bf tape mem ptr $ (takeWhile (/= ']') tape):stack
-- bf (']':tape) mem ptr (ss:stack)
--     | mem !! ptr == 0 = bf tape mem ptr stack
--     | otherwise       = bf (ss ++ (']':tape)) mem ptr (ss:stack)
-- bf (']':_) _ _ [] = error "lack of ]"
-- bf (c:_) _ _ _ = error $ "invalid call \"" ++ c:"\""
bf [] _ _ _ = return ()

main :: IO ()
main = do
    -- bf "+++++++++[>++++++++<-]>." (take 1000 (repeat 0)) 0 []
    -- putStrLn ""
    bf "+++++++++[>++++++++>+++++++++++>+++++<<<-]>.>++.+++++++..+++.>-.------------.<++++++++.--------.+++.------.--------.>+." (take 1000 (repeat 0)) 0 []
    -- bf ">++++[<++++++++>-]>+++++++[<++++++++>-]<+>+++++++++>>++++++++++[<++++++++++>-]<--[>[-]<[->+>+<<]>>[-<<+>>]<-[>[-]<<[->>+>+<<<]>>>[-<<<+>>>]<+[>>[-]>[-]<<[>+>+<<-]>>[<<+>>-]<>[-]+<[>-<[-]]>[-<<<<[->>+>>+<<<<]>>>>[-<<<<+>>>>]<<+>>]<<-<-]>>[-]+<[[-]>-<]>[-<>>[-]+<<<<[-]+>>>]<<<-]>>>>>[-]+<[[-]>-<]>[-<<<<<<<<.>>>[-]++++++[<<++++++++>>-]<<.>>++++++[<<-------->>-]<<<<.>>>>>>>>>]<<<<<<->>[-]<<<[->>+>+<<<]>>>[-<<<+>>>]<>+<[[-]>-<<<->>]>[-<<<+++++++++<->>>>]<<]" (take 1000 (repeat 0)) 0 []