Skip to content

Instantly share code, notes, and snippets.

@Sgeo
Last active December 13, 2015 17:39
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
Star You must be signed in to star a gist
Save Sgeo/fe54715fc61d1d98f4cc to your computer and use it in GitHub Desktop.
Just storing this here for a bit
import Control.Monad
import Control.Monad.State
import System.IO
import Data.Maybe
import Control.Applicative
import Data.Char
source :: (String, String) -> String
source code = snd code ++ "\n" ++ fst code ++ " = " ++ show code
data TFCommand = Inc | Dec | Set Int | MoveLeft | MoveRight | Loop [TFCommand] | In | Out | CodeOut | Compile deriving (Show)
interpret :: [TFCommand] -> IO ()
interpret code = do
runStateT (interpret' code) (InterpState { tape = Tape [] 0 [], higherInput = Nothing, currentCompilerStack = compilerStack, codeBlock = "" })
return ()
data Tape = Tape [Int] Int [Int]
incTape (Tape left val right) = Tape left (val+1) right
decTape (Tape left val right) = Tape left (val-1) right
setTape newVal (Tape left _ right) = Tape left newVal right
moveLeftTape (Tape (l:ls) val right) = Tape ls l (val:right)
moveLeftTape (Tape [] val right) = Tape [] 0 (val:right)
moveRightTape (Tape left val (r:rs)) = Tape (val:left) r rs
moveRightTape (Tape left val []) = Tape (val:left) 0 []
curValTape (Tape _ val _) = val
data InterpState = InterpState { tape :: Tape, higherInput :: Maybe String, currentCompilerStack :: [[TFCommand]], codeBlock :: String }
modTape :: (Tape -> Tape) -> StateT InterpState IO ()
modTape modifier = do
t <- gets tape
modify (\s -> s {tape = modifier t})
interpret' :: [TFCommand] -> StateT InterpState IO ()
interpret' [] = return ()
interpret' (Inc:cmds) = modTape incTape >> interpret' cmds
interpret' (Dec:cmds) = modTape decTape >> interpret' cmds
interpret' ((Set n):cmds) = modTape (setTape n) >> interpret' cmds
interpret' (MoveLeft:cmds) = modTape moveLeftTape >> interpret' cmds
interpret' (MoveRight:cmds) = modTape moveRightTape >> interpret' cmds
interpret' curCmds@((Loop innercmds):outercmds) = do
val <- gets (curValTape . tape)
if (val==0)
then interpret' outercmds
else interpret' innercmds >> interpret' curCmds
interpret' (In:cmds) = do
hI <- gets higherInput
maybeIn <- case hI of
Nothing -> liftIO $ do
eof <- isEOF
if eof then return Nothing else Just <$> getChar
Just "" -> return Nothing
Just (c:cs) -> modify (\s -> s { higherInput = Just cs }) >> return (Just c)
let inVal = fromMaybe (-1) (fmap ord maybeIn)
modTape (setTape inVal)
interpret' cmds
interpret' (Out:cmds) = do
curVal <- gets (curValTape . tape)
liftIO . putChar . chr $ curVal
interpret' cmds
interpret' (CodeOut:cmds) = do
curVal <- gets (curValTape . tape)
modify (\s -> s { codeBlock = (chr curVal):(codeBlock s) })
interpret' cmds
interpret' (Compile:[]) = do -- Special case this, so Compiles at the end get TCO treatment
s <- get
case currentCompilerStack s of
(nextCompiler:restCompilers) -> do
put $ InterpState { tape = Tape [] 0 [], higherInput = Just . reverse . codeBlock $ s, currentCompilerStack = restCompilers, codeBlock = "" }
interpret' nextCompiler
[] -> let codeToCompile = reverse . codeBlock $ s in liftIO $ primCompile codeToCompile
interpret' (Compile:cmds) = do
s <- get
interpret' [Compile]
put s
interpret' cmds
primCompile code = do
putStrLn $ source primSource
let translated = primTranslate code
putStr "program ="
putStrLn $ show translated
putStr "compilerStack = "
putStrLn $ show (program:compilerStack)
primTranslate :: String -> [TFCommand]
primTranslate code = let (cmds, rest) = primTranslate' code in if null rest then cmds else error "Unbalanced []"
primTranslate' :: String -> ([TFCommand], String)
primTranslate' [] = ([], "")
primTranslate' ('+':code) = let (cmds, rest) = primTranslate' code in ((Inc:cmds), rest)
primTranslate' ('-':code) = let (cmds, rest) = primTranslate' code in ((Dec:cmds), rest)
primTranslate' ('<':code) = let (cmds, rest) = primTranslate' code in ((MoveLeft:cmds), rest)
primTranslate' ('>':code) = let (cmds, rest) = primTranslate' code in ((MoveRight:cmds), rest)
primTranslate' "\\" = error "Unmatched \\"
primTranslate' ('\\':c:code) = let (cmds, rest) = primTranslate' code in ((Set (ord c)):cmds, rest)
primTranslate' ('[':code) = let (innercmds, innerrest) = primTranslate' code; (cmds, rest) = primTranslate' innerrest in (((Loop innercmds):cmds), rest)
primTranslate' (']':code) = ([], code)
primTranslate' (',':code) = let (cmds, rest) = primTranslate' code in ((In:cmds), rest)
primTranslate' ('.':code) = let (cmds, rest) = primTranslate' code in ((Out:cmds), rest)
primTranslate' (':':code) = let (cmds, rest) = primTranslate' code in ((CodeOut:cmds), rest)
primTranslate' ('!':code) = let (cmds, rest) = primTranslate' code in ((Compile:cmds), rest)
primTranslate' (_:code) = primTranslate' code
main = interpret program
primSource = ("primSource","import Control.Monad\nimport Control.Monad.State\nimport System.IO\nimport Data.Maybe\nimport Control.Applicative\nimport Data.Char\n\nsource :: (String, String) -> String\nsource code = snd code ++ \"\\n\" ++ fst code ++ \" = \" ++ show code\n\n\ndata TFCommand = Inc | Dec | Set Int | MoveLeft | MoveRight | Loop [TFCommand] | In | Out | CodeOut | Compile deriving (Show)\n\ninterpret :: [TFCommand] -> IO ()\ninterpret code = do\n runStateT (interpret' code) (InterpState { tape = Tape [] 0 [], higherInput = Nothing, currentCompilerStack = compilerStack, codeBlock = \"\" })\n return ()\n\ndata Tape = Tape [Int] Int [Int]\n\nincTape (Tape left val right) = Tape left (val+1) right\ndecTape (Tape left val right) = Tape left (val-1) right\nsetTape newVal (Tape left _ right) = Tape left newVal right\nmoveLeftTape (Tape (l:ls) val right) = Tape ls l (val:right)\nmoveLeftTape (Tape [] val right) = Tape [] 0 (val:right)\nmoveRightTape (Tape left val (r:rs)) = Tape (val:left) r rs\nmoveRightTape (Tape left val []) = Tape (val:left) 0 []\ncurValTape (Tape _ val _) = val\n\ndata InterpState = InterpState { tape :: Tape, higherInput :: Maybe String, currentCompilerStack :: [[TFCommand]], codeBlock :: String }\n\nmodTape :: (Tape -> Tape) -> StateT InterpState IO ()\nmodTape modifier = do\n t <- gets tape\n modify (\\s -> s {tape = modifier t})\n\ninterpret' :: [TFCommand] -> StateT InterpState IO ()\n\ninterpret' [] = return ()\ninterpret' (Inc:cmds) = modTape incTape >> interpret' cmds\ninterpret' (Dec:cmds) = modTape decTape >> interpret' cmds\ninterpret' ((Set n):cmds) = modTape (setTape n) >> interpret' cmds\ninterpret' (MoveLeft:cmds) = modTape moveLeftTape >> interpret' cmds\ninterpret' (MoveRight:cmds) = modTape moveRightTape >> interpret' cmds\ninterpret' curCmds@((Loop innercmds):outercmds) = do\n val <- gets (curValTape . tape)\n if (val==0)\n then interpret' outercmds\n else interpret' innercmds >> interpret' curCmds\ninterpret' (In:cmds) = do\n hI <- gets higherInput\n maybeIn <- case hI of\n Nothing -> liftIO $ do\n eof <- isEOF\n if eof then return Nothing else Just <$> getChar\n Just \"\" -> return Nothing\n Just (c:cs) -> modify (\\s -> s { higherInput = Just cs }) >> return (Just c)\n let inVal = fromMaybe (-1) (fmap ord maybeIn)\n modTape (setTape inVal)\n interpret' cmds\ninterpret' (Out:cmds) = do\n curVal <- gets (curValTape . tape)\n liftIO . putChar . chr $ curVal\n interpret' cmds\ninterpret' (CodeOut:cmds) = do\n curVal <- gets (curValTape . tape)\n modify (\\s -> s { codeBlock = (chr curVal):(codeBlock s) })\n interpret' cmds\ninterpret' (Compile:[]) = do -- Special case this, so Compiles at the end get TCO treatment\n s <- get\n case currentCompilerStack s of\n (nextCompiler:restCompilers) -> do\n put $ InterpState { tape = Tape [] 0 [], higherInput = Just . reverse . codeBlock $ s, currentCompilerStack = restCompilers, codeBlock = \"\" }\n interpret' nextCompiler\n [] -> let codeToCompile = reverse . codeBlock $ s in liftIO $ primCompile codeToCompile\ninterpret' (Compile:cmds) = do\n s <- get\n interpret' [Compile]\n put s\n interpret' cmds\n \nprimCompile code = do\n putStrLn $ source primSource\n let translated = primTranslate code\n putStr \"program =\"\n putStrLn $ show translated\n putStr \"compilerStack = \"\n putStrLn $ show (program:compilerStack)\n\nprimTranslate :: String -> [TFCommand]\nprimTranslate code = let (cmds, rest) = primTranslate' code in if null rest then cmds else error \"Unbalanced []\"\nprimTranslate' :: String -> ([TFCommand], String)\nprimTranslate' [] = ([], \"\")\nprimTranslate' ('+':code) = let (cmds, rest) = primTranslate' code in ((Inc:cmds), rest)\nprimTranslate' ('-':code) = let (cmds, rest) = primTranslate' code in ((Dec:cmds), rest)\nprimTranslate' ('<':code) = let (cmds, rest) = primTranslate' code in ((MoveLeft:cmds), rest)\nprimTranslate' ('>':code) = let (cmds, rest) = primTranslate' code in ((MoveRight:cmds), rest)\nprimTranslate' \"\\\\\" = error \"Unmatched \\\\\"\nprimTranslate' ('\\\\':c:code) = let (cmds, rest) = primTranslate' code in ((Set (ord c)):cmds, rest)\nprimTranslate' ('[':code) = let (innercmds, innerrest) = primTranslate' code; (cmds, rest) = primTranslate' innerrest in (((Loop innercmds):cmds), rest)\nprimTranslate' (']':code) = ([], code)\nprimTranslate' (',':code) = let (cmds, rest) = primTranslate' code in ((In:cmds), rest)\nprimTranslate' ('.':code) = let (cmds, rest) = primTranslate' code in ((Out:cmds), rest)\nprimTranslate' (':':code) = let (cmds, rest) = primTranslate' code in ((CodeOut:cmds), rest)\nprimTranslate' ('!':code) = let (cmds, rest) = primTranslate' code in ((Compile:cmds), rest)\nprimTranslate' (_:code) = primTranslate' code\n\nmain = interpret program\n\n\n")
program = primTranslate ",+[-:,+]!"
compilerStack = []
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment