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
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
|
// The MIT License (MIT)
//
// Copyright (c) 2015 Camil Staps
//
// Permission is hereby granted, free of charge, to any person obtaining a copy
// of this software and associated documentation files (the "Software"), to deal
// in the Software without restriction, including without limitation the rights
// to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
// copies of the Software, and to permit persons to whom the Software is
// furnished to do so, subject to the following conditions:
//
// The above copyright notice and this permission notice shall be included in all
// copies or substantial portions of the Software.
//
// THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
// IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
// FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
// AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
// LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
// OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
// SOFTWARE.
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 *env -> *env | FileSystem env
run p world = run` p 0 0 [0,0..] world
where
run` :: Program InstrPointer DataPointer Tape *env -> *env | FileSystem env
run` p iptr dptr t world
| iptr >= length p = world
| p!!iptr == INC || p!!iptr == DEC = run` p (iptr + 1) dptr (apply (p!!iptr) dptr t) world
| p!!iptr == INCP = run` p (iptr + 1) (dptr + 1) t world
| p!!iptr == DECP = run` p (iptr + 1) (dptr - 1) t world
| p!!iptr == IFZ && t!!dptr <> 0 = run` p (iptr + 1) dptr t world
| p!!iptr == IFZ = run` p (forward p iptr) dptr t world
| p!!iptr == IFNZ && t!!dptr == 0 = run` p (iptr + 1) dptr t world
| p!!iptr == IFNZ = run` p (backward p iptr) dptr t world
// must be IN / OUT now
# (io,world) = stdio world
| p!!iptr == IN
# (ok,c,io) = freadc io
| not ok = abort "Couldn't read input"
# (ok,world) = fclose io world
| not ok = abort "Couldn't close stdio"
| otherwise = run` p (iptr + 1) dptr (update t dptr c) world
// must be OUT now
# io = io <<< toChar (t!!dptr)
# (ok,world) = fclose io world
| not ok = abort "Couldn't close stdio"
| otherwise = run` p (iptr + 1) dptr t 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)
update :: Tape DataPointer Char -> Tape
update t ptr c = (take ptr t) ++ [fromChar c : drop (ptr + 1) t]
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 ['>','<','+','-','.',',','[',']']]
|
