gdritter repos simple-befunge / 3835cc5
Small working Befunge interpreter Getty Ritter 9 years ago
10 changed file(s) with 261 addition(s) and 0 deletion(s). Collapse all Expand all
+30
-0
LICENSE less more
1 Copyright (c) 2015, Getty Ritter
2
3 All rights reserved.
4
5 Redistribution and use in source and binary forms, with or without
6 modification, are permitted provided that the following conditions are met:
7
8 * Redistributions of source code must retain the above copyright
9 notice, this list of conditions and the following disclaimer.
10
11 * Redistributions in binary form must reproduce the above
12 copyright notice, this list of conditions and the following
13 disclaimer in the documentation and/or other materials provided
14 with the distribution.
15
16 * Neither the name of Getty Ritter nor the names of other
17 contributors may be used to endorse or promote products derived
18 from this software without specific prior written permission.
19
20 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23 A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24 OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25 SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26 LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27 DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28 THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29 (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30 OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+2
-0
Setup.hs less more
1 import Distribution.Simple
2 main = defaultMain
+2
-0
samples/README.md less more
1 All of these samples were borrowed from the [Esolang](http://esolangs.org/wiki/Main_Page)
2 article [about Befunge](http://esolangs.org/wiki/Befunge).
+2
-0
samples/factorial.bfng less more
1 0&>:1-:v v *_$.@
2 ^ _$>\:^
+1
-0
samples/hello.bfng less more
1 0"!dlroW ,olleH">:#,_@
+1
-0
samples/hello.bfng~ less more
1 0"!dlroW ,olleH">:#,_@⏎
+1
-0
samples/quine.bfng less more
1 01->1# +# :# 0# g# ,# :# 5# 8# *# 4# +# -# _@
+4
-0
samples/sieve.bfng less more
1 2>:3g" "-!v\ g30 <
2 |!`"O":+1_:.:03p>03g+:"O"`|
3 @ ^ p3\" ":<
4 2 234567890123456789012345678901234567890123456789012345678901234567890123456789
+25
-0
simple-befunge.cabal less more
1 name: befunge
2 version: 0.1.0.0
3 -- synopsis:
4 -- description:
5 license: BSD3
6 license-file: LICENSE
7 author: Getty Ritter
8 maintainer: gettylefou@gmail.com
9 -- copyright:
10 category: Language
11 build-type: Simple
12 -- extra-source-files:
13 cabal-version: >=1.10
14
15 executable befunge
16 main-is: Main.hs
17 -- other-modules:
18 -- other-extensions:
19 build-depends: base >=4.7 && <4.8,
20 transformers,
21 mtl,
22 array,
23 random
24 hs-source-dirs: src
25 default-language: Haskell2010⏎
+193
-0
src/Main.hs less more
1 {-# LANGUAGE MultiWayIf #-}
2
3 module Main where
4
5 import Data.Array (Array, array, (!), (//))
6 import Data.Char (chr, ord)
7 import Data.Maybe (fromMaybe)
8 import Control.Monad (void, forever)
9 import Control.Monad.IO.Class (liftIO)
10 import Control.Monad.State ( StateT(runStateT)
11 , get
12 , put
13 , modify
14 )
15 import System.Exit (exitSuccess)
16 import System.Environment (getArgs)
17 import System.IO (stdout, hFlush)
18 import System.Random (randomIO)
19
20 type Board = Array (Int, Int) Char
21 data Direction = U | R | D | L deriving (Eq, Show, Enum)
22 data FungeState = FS
23 { location :: (Int, Int)
24 , stack :: [Int]
25 , direction :: Direction
26 , board :: Board
27 , stringMode :: Bool
28 } deriving (Eq, Show)
29 type FungeM a = StateT FungeState IO a
30
31 terminate :: String -> FungeM a
32 terminate s = liftIO $ do
33 putStrLn ("\n" ++ s)
34 exitSuccess
35
36 debug :: FungeM ()
37 debug = do
38 st <- get
39 liftIO $ do
40 putStrLn $ "FS {"
41 putStrLn $ " , loc=" ++ show (location st)
42 putStrLn $ " , stk=" ++ show (stack st)
43 putStrLn $ " , dir=" ++ show (direction st)
44 putStrLn $ " }"
45
46 pop :: FungeM Int
47 pop = do
48 st <- get
49 case stack st of
50 [] -> terminate "Popping from empty stack!"
51 (x:xs) -> do
52 put st { stack = xs }
53 return x
54
55 push :: Int -> FungeM ()
56 push x = modify go where go st = st { stack = x : stack st }
57
58 binOp :: (Int -> Int -> Int) -> FungeM ()
59 binOp op = do
60 a <- pop
61 b <- pop
62 push (b `op` a)
63
64 unOp :: (Int -> Int) -> FungeM ()
65 unOp op = do
66 a <- pop
67 push (op a)
68
69 setDirection :: Direction -> FungeM ()
70 setDirection d = modify go where go st = st { direction = d }
71
72 randomDirection :: FungeM ()
73 randomDirection = do
74 x <- liftIO randomIO
75 setDirection (toEnum x)
76
77 fungeIf :: Direction -> Direction -> FungeM ()
78 fungeIf thenDir elseDir = do
79 c <- pop
80 setDirection (if c /= 0 then thenDir else elseDir)
81
82 toggleStringMode = modify go
83 where go st = st { stringMode = not (stringMode st) }
84
85 goDir :: Direction -> (Int, Int) -> (Int, Int)
86 goDir U (x, y) = (x, y - 1)
87 goDir R (x, y) = (x + 1, y)
88 goDir D (x, y) = (x, y + 1)
89 goDir L (x, y) = (x - 1, y)
90
91 move :: FungeM ()
92 move = modify go
93 where go st@(FS { direction = d, location = l }) =
94 st { location = goDir d l }
95
96 getInstr :: FungeM ()
97 getInstr = do
98 y <- pop
99 x <- pop
100 st <- get
101 push (ord (board st ! (x, y)))
102
103 putInstr :: FungeM ()
104 putInstr = do
105 y <- pop
106 x <- pop
107 c <- pop
108 modify (\ st -> st { board = board st // [((x, y), chr c)] })
109
110 step :: Char -> FungeM ()
111 step '+' = binOp (+)
112 step '-' = binOp (-)
113 step '*' = binOp (*)
114 step '/' = binOp div
115 step '%' = binOp mod
116 step '!' = unOp go where go 0 = 1; go _ = 0
117 step '`' = binOp go where go x y | x > y = 1 | otherwise = 0
118 step '>' = setDirection R
119 step '<' = setDirection L
120 step '^' = setDirection U
121 step 'v' = setDirection D
122 step '?' = randomDirection
123 step '_' = fungeIf L R
124 step '|' = fungeIf U D
125 step '"' = toggleStringMode
126 step ':' = do { x <- pop; push x; push x }
127 step '\\' = do { x <- pop; y <- pop; push x; push y }
128 step '$' = void pop
129 step '.' = do { x <- pop; liftIO (print x) }
130 step ',' = do { x <- pop; liftIO (putChar (chr x) >> hFlush stdout) }
131 step '#' = move
132 step 'g' = getInstr
133 step 'p' = putInstr
134 step '&' = do
135 liftIO (putStr "num> " >> hFlush stdout)
136 n <- liftIO getLine
137 push (read n)
138 step '~' = do
139 liftIO (putStr "chr> " >> hFlush stdout)
140 n <- liftIO getLine
141 push (ord (head n))
142 step '@' = terminate "Finished"
143 step n | n >= '0' && n <= '9' = push (ord n - ord '0')
144 step _ = return ()
145
146 run :: FungeM ()
147 run = do
148 st <- get
149 let c = board st ! location st
150 if | stringMode st && c == '"' -> toggleStringMode
151 | stringMode st && c /= '"' -> push (ord c)
152 | otherwise -> step c
153 move
154
155 (!?) :: [[a]] -> (Int, Int) -> Maybe a
156 xs !? (x, y)
157 | x < 0 || y < 0 = Nothing
158 | y >= length xs = Nothing
159 | x >= length (xs !! y) = Nothing
160 | otherwise = Just ((xs !! y) !! x)
161
162 buildBoard :: String -> Board
163 buildBoard s =
164 array ((0, 0), (width-1, height-1))
165 [ ((x, y), c)
166 | x <- [0..width-1]
167 , y <- [0..height-1]
168 , let c = fromMaybe ' ' (strs !? (x, y))
169 ]
170 where strs = lines s
171 height = length strs
172 width = maximum (map length strs)
173
174 buildInitialState :: String -> FungeState
175 buildInitialState s =
176 FS { board = buildBoard s
177 , stack = []
178 , direction = R
179 , location = (0, 0)
180 , stringMode = False
181 }
182
183 runFunge :: FungeState -> IO ()
184 runFunge st = void (runStateT (forever run) st)
185
186 main :: IO ()
187 main = do
188 args <- getArgs
189 case args of
190 [] -> putStrLn "No filename given!"
191 (f:_) -> do
192 c <- readFile f
193 runFunge (buildInitialState c)