Just storing this here for a bit
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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