1 files changed, 88 insertions, 0 deletions
diff --git a/Brainfuck.icl b/Brainfuck.icl
new file mode 100644
index 0000000..197a54b
--- /dev/null
+++ b/Brainfuck.icl
@@ -0,0 +1,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 ['>','<','+','-','.',',','[',']']]