Skip to content

Instantly share code, notes, and snippets.

@ujihisa
Last active August 11, 2022 02:16
Show Gist options
  • Save ujihisa/cfdd9fa720e7ae696b5236a5b3f13199 to your computer and use it in GitHub Desktop.
Save ujihisa/cfdd9fa720e7ae696b5236a5b3f13199 to your computer and use it in GitHub Desktop.
import qualified Data.Map as Map
import qualified Data.List as List
data AST = Cons AST AST | Inst Char | Nil deriving Show
-- Just for debugging purpose
toSEXP :: AST -> String
toSEXP x = case toSEXPList x of
Just xs -> "(" ++ List.intercalate " " xs ++ ")"
Nothing -> toSEXP' x
toSEXPList :: AST -> Maybe [String]
toSEXPList (Cons (Inst a) b) = do
xs <- toSEXPList b
Just $ [a] : xs
toSEXPList (Cons a@(Cons _ _) b) = do
bs <- toSEXPList b
Just $ [toSEXP a] ++ bs
toSEXPList Nil = Just []
toSEXPList _ = Nothing
toSEXP' :: AST -> String
toSEXP' (Cons a b) = "(" ++ toSEXP a ++ " . " ++ toSEXP b ++ ")"
toSEXP' Nil = "nil"
toSEXP' (Inst c) = [c]
parse :: String -> Either String AST
parse x = case parse' x of
Left message -> Left message
Right (ast, "") -> Right ast
Right (_, remaining) -> Left remaining
parse' :: String -> Either String (AST, String)
parse' ('>' : remaining) = (\(a, r) -> (Cons (Inst '>') a, r)) `fmap` parse' remaining
parse' ('<' : remaining) = (\(a, r) -> (Cons (Inst '<') a, r)) `fmap` parse' remaining
parse' ('+' : remaining) = (\(a, r) -> (Cons (Inst '+') a, r)) `fmap` parse' remaining
parse' ('-' : remaining) = (\(a, r) -> (Cons (Inst '-') a, r)) `fmap` parse' remaining
parse' ('.' : remaining) = (\(a, r) -> (Cons (Inst '.') a, r)) `fmap` parse' remaining
parse' (',' : remaining) = (\(a, r) -> (Cons (Inst ',') a, r)) `fmap` parse' remaining
parse' ('[' : remaining) = do
(a, r) <- parse' remaining
(a', r') <- parse' r
return (Cons a a', r')
parse' (']' : remaining) = return (Nil, remaining)
parse' "" = return (Nil, "")
parse' (_ : remaining) = parse' remaining
execute :: AST -> Int -> Map.Map Int Char -> IO (Int, Map.Map Int Char)
execute Nil i tape = return (i, tape)
execute (Cons (Inst '>') x) i tape = execute x (succ i) tape
execute (Cons (Inst '<') x) i tape = execute x (pred i) tape
execute (Cons (Inst '+') x) i tape = execute x i $ Map.alter (return . succ . maybe '\0' id) i tape
execute (Cons (Inst '-') x) i tape = execute x i $ Map.alter (return . pred . maybe '\0' id) i tape
execute (Cons (Inst '.') x) i tape = putChar (Map.findWithDefault '\0' i tape) >> execute x i tape
execute (Cons (Inst ',') x) i tape = print "Error: `,` NOT IMPLEMENTED" >> return (i, tape)
execute (Cons a b) i tape = do
if (Map.findWithDefault '\0' i tape) == '\0'
then execute b i tape
else
do
(i', tape') <- execute a i tape
execute (Cons a b) i' tape'
main = do
case parse "++++++++[>++++[>++>+++>+++>+<<<<-]>+>+>->>+[<]<-]>>.>---.+++++++..+++.>>.<-.<.+++.------.--------.>>+.>++." of
Left message -> print $ "ERROR: " ++ message
Right ast -> do
print ast
putStrLn $ toSEXP ast
execute ast 0 Map.empty
return ()
Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '+') (Cons (Cons (Inst '>') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '+') (Cons (Cons (Inst '>') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '>') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '>') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '>') (Cons (Inst '+') (Cons (Inst '<') (Cons (Inst '<') (Cons (Inst '<') (Cons (Inst '<') (Cons (Inst '-') Nil)))))))))))))))))) (Cons (Inst '>') (Cons (Inst '+') (Cons (Inst '>') (Cons (Inst '+') (Cons (Inst '>') (Cons (Inst '-') (Cons (Inst '>') (Cons (Inst '>') (Cons (Inst '+') (Cons (Cons (Inst '<') Nil) (Cons (Inst '<') (Cons (Inst '-') Nil)))))))))))))))))) (Cons (Inst '>') (Cons (Inst '>') (Cons (Inst '.') (Cons (Inst '>') (Cons (Inst '-') (Cons (Inst '-') (Cons (Inst '-') (Cons (Inst '.') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '.') (Cons (Inst '.') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '.') (Cons (Inst '>') (Cons (Inst '>') (Cons (Inst '.') (Cons (Inst '<') (Cons (Inst '-') (Cons (Inst '.') (Cons (Inst '<') (Cons (Inst '.') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '.') (Cons (Inst '-') (Cons (Inst '-') (Cons (Inst '-') (Cons (Inst '-') (Cons (Inst '-') (Cons (Inst '-') (Cons (Inst '.') (Cons (Inst '-') (Cons (Inst '-') (Cons (Inst '-') (Cons (Inst '-') (Cons (Inst '-') (Cons (Inst '-') (Cons (Inst '-') (Cons (Inst '-') (Cons (Inst '.') (Cons (Inst '>') (Cons (Inst '>') (Cons (Inst '+') (Cons (Inst '.') (Cons (Inst '>') (Cons (Inst '+') (Cons (Inst '+') (Cons (Inst '.') Nil)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
(+ + + + + + + + (> + + + + (> + + > + + + > + + + > + < < < < -) > + > + > - > > + (<) < -) > > . > - - - . + + + + + + + . . + + + . > > . < - . < . + + + . - - - - - - . - - - - - - - - . > > + . > + + .)
Hello World!
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment