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
79
80
81
82
83
84
85
86
87
88
|
implementation module Brainfuck
import StdEnv
instance == Command where
(==) INC INC = True
(==) DEC DEC = True
(==) INCP INCP = True
(==) DECP DECP = True
(==) OUT OUT = True
(==) IN IN = True
(==) IFZ IFZ = True
(==) IFNZ IFNZ = True
(==) _ _ = False
run :: Program Input *env -> *env | FileSystem env
run p i world = run` p 0 0 [0,0..] i world
where
run` :: Program InstrPointer DataPointer Tape Input *env -> *env | FileSystem env
run` p iptr dptr t i world
| iptr >= length p = world
| p!!iptr == INC || p!!iptr == DEC = run` p (iptr + 1) dptr (apply (p!!iptr) dptr t) i world
| p!!iptr == INCP = run` p (iptr + 1) (dptr + 1) t i world
| p!!iptr == DECP = run` p (iptr + 1) (dptr - 1) t i world
| p!!iptr == IN = run` p (iptr + 1) dptr t` i` world
| p!!iptr == IFZ && t!!dptr <> 0 = run` p (iptr + 1) dptr t i world
| p!!iptr == IFZ = run` p (forward p iptr) dptr t i world
| p!!iptr == IFNZ && t!!dptr == 0 = run` p (iptr + 1) dptr t i world
| p!!iptr == IFNZ = run` p (backward p iptr) dptr t i world
// must be OUT now
# (io,world) = stdio world
//# io = io <<< toChar (t!!dptr)
# io = io <<< toChar (t!!dptr)
# (ok,world) = fclose io world
| not ok = abort "Couldn't close stdio"
| otherwise = run` p (iptr + 1) dptr t i world
where
cast :: Cell -> Cell
cast n
| n < 0 = 0
| n > 255 = 255
| otherwise = n
apply :: Command DataPointer Tape -> Tape
apply INC dptr t = (take dptr t) ++ [cast (t!!dptr + 1)] ++ (drop (dptr + 1) t)
apply DEC dptr t = (take dptr t) ++ [cast (t!!dptr - 1)] ++ (drop (dptr + 1) t)
(t`,i`) = input t dptr i
input :: Tape DataPointer Input -> (Tape, Input)
input _ _ [] = abort "No input"
input t dptr [i:is]
| otherwise = ((take dptr t) ++ [i] ++ (drop (dptr + 1) t), is)
forward` :: Program InstrPointer Int -> InstrPointer
forward` _ ptr 0 = ptr
forward` p ptr i
| p!!ptr == IFZ = forward` p (ptr+1) (i+1)
| p!!ptr == IFNZ = forward` p (ptr+1) (i-1)
| otherwise = forward` p (ptr+1) i
backward` :: Program InstrPointer Int -> InstrPointer
backward` _ ptr 0 = ptr + 1
backward` p ptr i
| p!!ptr == IFZ = backward` p (ptr-1) (i-1)
| p!!ptr == IFNZ = backward` p (ptr-1) (i+1)
| otherwise = backward` p (ptr-1) i
forward :: Program InstrPointer -> InstrPointer
forward p ptr = forward` p (ptr+1) 1
backward :: Program InstrPointer -> InstrPointer
backward p ptr = backward` p (ptr-1) 1
read :: String -> Program
read s = [readC c \\ c <- sanitize (fromString s)]
where
readC :: Char -> Command
readC '>' = INCP
readC '<' = DECP
readC '+' = INC
readC '-' = DEC
readC '.' = OUT
readC ',' = IN
readC '[' = IFZ
readC ']' = IFNZ
sanitize :: [Char] -> [Char]
sanitize cs = [c \\ c <- cs | isMember c ['>','<','+','-','.',',','[',']']]
|
