1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
| import Prelude hiding (catch)
import Control.Exception (catch)
import System.IO (stdin, hFlush, hGetContents, openFile, IOMode(ReadMode))
import System.IO.Error (isEOFError)
import System.Environment (getArgs)
import Data.Sequence (singleton, Seq, (<|), (|>), index, length, adjust, update)
import Control.Monad (void, liftM, ap)
import Control.Arrow ((***))
type Program = [Instruction]
data Instruction = MovL | MovR
| Dec | Inc
| Inp | Out
| Loop Program
main :: IO ()
main = do
args <- getArgs
prog <- if Prelude.length args > 0
then hGetContents =<< openFile (head args) ReadMode
else getLine
exec_ . parse $ prog
parse :: String -> Program
parse [] = []
parse ('[':xs) = let (il, ol) = closing ('[', ']') xs in
(Loop . parse$il)
: parse ol
parse ('<':xs) = MovL : parse xs
parse ('>':xs) = MovR : parse xs
parse ('-':xs) = Dec : parse xs
parse ('+':xs) = Inc : parse xs
parse (',':xs) = Inp : parse xs
parse ('.':xs) = Out : parse xs
parse ( _ :xs) = parse xs
closing :: (Char, Char) -> String -> (String, String)
closing brc = (reverse *** reverse) . fst . foldl (folder brc) (("", ""), 1)
where folder :: (Char, Char) -> ((String, String), Int) -> Char -> ((String, String), Int)
folder (co, cc) ((is, os), ct) c
| ct > 0 && c == co = ((c:is, os), ct + 1)
| ct > 0 && c == cc = ((c:is, os), ct 1)
| ct > 0 = ((c:is, os), ct )
| ct == 0 = (( is, c:os), 0)
exec_ :: Program -> IO ()
exec_ prog = void $ exec prog (singleton 0, 0)
exec :: Program -> (Seq Integer, Int) -> IO (Seq Integer, Int)
exec [] mm = return mm
exec (MovL:ps) (mem, pnt) = exec ps
$ if pnt == 0
then (0 <| mem, pnt )
else ( mem, pnt 1)
exec (MovR:ps) (mem, pnt) = exec ps
$ flip (,) (pnt + 1)
$ if Data.Sequence.length mem <= pnt + 1
then mem |> 0
else mem
exec (Dec :ps) (mem, pnt) = exec ps (adjust (+ (1)) pnt mem, pnt)
exec (Inc :ps) (mem, pnt) = exec ps (adjust (+ 1 ) pnt mem, pnt)
exec (Inp :ps) (mem, pnt) = do
c <- (liftM (toEnum . fromEnum) getChar) `catch` excHndl
exec ps (update pnt c mem, pnt)
where excHndl :: IOError -> IO Integer
excHndl e
| isEOFError e = return $ 1
| otherwise = ioError e
exec (Out :ps) mm@(mem, pnt) = do
putChar . toEnum . fromEnum . index mem $ pnt
exec ps mm
exec pro@(Loop q:ps) mm@(mem, pnt) = do
nm <- exec q mm
flip exec nm
$ if mem `index` pnt == 0
then ps
else pro |