From 281425310c5db21f87981eeb9601a71d1974d98d Mon Sep 17 00:00:00 2001 From: Jed Barber Date: Thu, 10 Apr 2014 05:25:03 +1000 Subject: Rearranging files --- src/Brainfuck/Interpreter.hs | 70 ++++++++++++++++++++++++ src/Brainfuck/Parser.hs | 62 +++++++++++++++++++++ src/Brainfuck/Tape.hs | 46 ++++++++++++++++ src/Fractran/Example.hs | 46 ++++++++++++++++ src/Fractran/Interpreter.hs | 29 ++++++++++ src/Fractran/Parser.hs | 68 +++++++++++++++++++++++ src/Fractran/Test.hs | 53 ++++++++++++++++++ src/Thue/Interpreter.hs | 77 ++++++++++++++++++++++++++ src/Thue/Parser.hs | 84 +++++++++++++++++++++++++++++ src/Thue/Test.hs | 52 ++++++++++++++++++ src/Unlambda/Builtins.hs | 70 ++++++++++++++++++++++++ src/Unlambda/Interpreter.hs | 85 +++++++++++++++++++++++++++++ src/Unlambda/Parser.hs | 125 +++++++++++++++++++++++++++++++++++++++++++ src/Unlambda/Test.hs | 103 +++++++++++++++++++++++++++++++++++ src/Unlambda/Types.hs | 108 +++++++++++++++++++++++++++++++++++++ src/brainfuck.hs | 30 +++++++++++ src/fractran.hs | 30 +++++++++++ src/misc.hs | 35 ++++++++++++ src/test.hs | 29 ++++++++++ src/thue.hs | 30 +++++++++++ src/unlambda.hs | 30 +++++++++++ 21 files changed, 1262 insertions(+) create mode 100644 src/Brainfuck/Interpreter.hs create mode 100644 src/Brainfuck/Parser.hs create mode 100644 src/Brainfuck/Tape.hs create mode 100644 src/Fractran/Example.hs create mode 100644 src/Fractran/Interpreter.hs create mode 100644 src/Fractran/Parser.hs create mode 100644 src/Fractran/Test.hs create mode 100644 src/Thue/Interpreter.hs create mode 100644 src/Thue/Parser.hs create mode 100644 src/Thue/Test.hs create mode 100644 src/Unlambda/Builtins.hs create mode 100644 src/Unlambda/Interpreter.hs create mode 100644 src/Unlambda/Parser.hs create mode 100644 src/Unlambda/Test.hs create mode 100644 src/Unlambda/Types.hs create mode 100644 src/brainfuck.hs create mode 100644 src/fractran.hs create mode 100644 src/misc.hs create mode 100644 src/test.hs create mode 100644 src/thue.hs create mode 100644 src/unlambda.hs (limited to 'src') diff --git a/src/Brainfuck/Interpreter.hs b/src/Brainfuck/Interpreter.hs new file mode 100644 index 0000000..1085a30 --- /dev/null +++ b/src/Brainfuck/Interpreter.hs @@ -0,0 +1,70 @@ +module Brainfuck.Interpreter ( + brainfuck + ) where + + +import Data.Char +import Data.Maybe +import Brainfuck.Parser +import Brainfuck.Tape + + + + +brainfuck :: BrainfuckProgram -> IO (Tape Int) +brainfuck program = + let dataTape = (repeat 0, Just 0, repeat 0) + commandTape = shiftRight ([], Nothing, program) + in process commandTape dataTape + + + +endLoop :: Tape BrainCom -> Tape BrainCom +endLoop tape = + let f t c = case (currentCell t, c) of + (Just CloseLoop, 0) -> shiftRight t + (Just OpenLoop, x) -> f (shiftRight t) (x + 1) + (Just CloseLoop, x) -> f (shiftRight t) (x - 1) + (Just com, x) -> f (shiftRight t) x + in f (shiftRight tape) 0 + + + +doLoop :: Tape BrainCom -> Tape BrainCom +doLoop tape = + let f t c = case (currentCell t, c) of + (Just OpenLoop, 0) -> shiftRight t + (Just OpenLoop, x) -> f (shiftLeft t) (x - 1) + (Just CloseLoop, x) -> f (shiftLeft t) (x + 1) + (Just com, x) -> f (shiftLeft t) x + in f (shiftLeft tape) 0 + + + +process :: Tape BrainCom -> Tape Int -> IO (Tape Int) +process commandTape dataTape = + case (currentCell commandTape) of + Nothing -> return dataTape + + Just R -> process (shiftRight commandTape) (shiftRight dataTape) + + Just L -> process (shiftRight commandTape) (shiftLeft dataTape) + + Just Inc -> process (shiftRight commandTape) (applyToCurrentCell ((`mod` 256) . (+1)) dataTape) + + Just Dec -> process (shiftRight commandTape) (applyToCurrentCell ((`mod` 256) . (subtract 1)) dataTape) + + Just Out -> (putChar . chr . fromJust . currentCell $ dataTape) >> process (shiftRight commandTape) dataTape + + Just In -> do { c <- getChar; process (shiftRight commandTape) (applyToCurrentCell (\_ -> ord c) dataTape) } + + Just OpenLoop -> + if (currentCell dataTape == Just 0) + then process (endLoop commandTape) dataTape + else process (shiftRight commandTape) dataTape + + Just CloseLoop -> + if (currentCell dataTape /= Just 0) + then process (doLoop commandTape) dataTape + else process (shiftRight commandTape) dataTape + diff --git a/src/Brainfuck/Parser.hs b/src/Brainfuck/Parser.hs new file mode 100644 index 0000000..1ea046a --- /dev/null +++ b/src/Brainfuck/Parser.hs @@ -0,0 +1,62 @@ +module Brainfuck.Parser ( + BrainfuckProgram, + BrainCom(..), + + parseBrainfuck + ) where + +import Control.Applicative( some ) +import Text.ParserCombinators.Parsec + + + +type BrainfuckProgram = [BrainCom] + + +data BrainCom = R | L | Inc | Dec | Out | In | OpenLoop | CloseLoop + deriving (Show, Eq) + + + + +parseBrainfuck :: String -> Either ParseError BrainfuckProgram +parseBrainfuck = parse brainfuck "error" + + + + +brainfuck = do + many commentChar + bs <- many fuck + eof + return . concat $ bs + + +fuck = (brainCommand >>= return . (:[])) + <|> loop + "brainfuck command" + + +loop = do + char '[' + many commentChar + bs <- many brainCommand + char ']' + many commentChar + return . concat $ [[OpenLoop],bs,[CloseLoop]] + + +brainCommand = do { b <- brainCom; many commentChar; return b } + + +brainCom = (char '>' >> return R) + <|> (char '<' >> return L) + <|> (char '+' >> return Inc) + <|> (char '-' >> return Dec) + <|> (char '.' >> return Out) + <|> (char ',' >> return In) + "brainfuck command" + + +commentChar = noneOf "><+-.,[]" + diff --git a/src/Brainfuck/Tape.hs b/src/Brainfuck/Tape.hs new file mode 100644 index 0000000..8da4352 --- /dev/null +++ b/src/Brainfuck/Tape.hs @@ -0,0 +1,46 @@ +module Brainfuck.Tape ( + Tape, + + shiftLeft, + shiftRight, + currentCell, + applyToCurrentCell + ) where + + +import Control.Monad +import Data.Maybe + + + +type Tape a = ([a], Maybe a, [a]) + + + + +shiftLeft :: Eq a => Tape a -> Tape a +shiftLeft (x,y,z) = + let x' = if (x /= []) then tail x else x + y' = if (x /= []) then Just (head x) else Nothing + z' = if (isJust y) then (fromJust y):z else z + in (x', y', z') + + + +shiftRight :: Eq a => Tape a -> Tape a +shiftRight (x,y,z) = + let x' = if (isJust y) then (fromJust y):x else x + y' = if (z /= []) then Just (head z) else Nothing + z' = if (z /= []) then tail z else z + in (x', y', z') + + + +currentCell :: Tape a -> Maybe a +currentCell (_,c,_) = c + + + +applyToCurrentCell :: (a -> a) -> Tape a -> Tape a +applyToCurrentCell f (x,y,z) = (x, (liftM f) y, z) + diff --git a/src/Fractran/Example.hs b/src/Fractran/Example.hs new file mode 100644 index 0000000..43d8cc8 --- /dev/null +++ b/src/Fractran/Example.hs @@ -0,0 +1,46 @@ +module Fractran.Example ( + addition, + multiply, + prime2, + prime10short, + prime10) where + + +import Fractran.Parser + + + + +-- some simple fractran programs + + +-- these ones need an initial input added of the appropriate form + +-- input: 2^a * 3^b +-- output: 3^(a+b) +addition :: [(Int,Int)] +addition = [(3,2)] + +-- input: 2^a * 3^b +-- output: 5^ab +multiply :: [(Int,Int)] +multiply = [(13,21), (385,13), (1,7), (3,11), (7,2), (1,3)] + + + + +-- these ones are already in ready to interpret, FractranProgram form + +-- input: 2 +-- output: a sequence containing all prime powers of 2 +prime2 :: FractranProgram +prime2 = FractranProgram [(17,91), (78,85), (19,51), (23,38), (29,33), (77,29), (95,23), (77,19), (1,17), (11,13), (13,11), (15,14), (15,2), (55,1)] 2 + +-- input: 10 +-- output: a sequence containing all prime powers of 10 +prime10short :: FractranProgram +prime10short = FractranProgram [(3,11), (847,45), (143,6), (7,3), (10,91), (3,7), (36,325), (1,2), (36,5)] 10 + +prime10 :: FractranProgram +prime10 = FractranProgram [(7,3), (99,98), (13,49), (39,35), (36,91), (10,143), (49,13), (7,11), (1,2), (91,1)] 10 + diff --git a/src/Fractran/Interpreter.hs b/src/Fractran/Interpreter.hs new file mode 100644 index 0000000..1393991 --- /dev/null +++ b/src/Fractran/Interpreter.hs @@ -0,0 +1,29 @@ +module Fractran.Interpreter ( + fractran + ) where + + +import Fractran.Parser + + + + +fractran :: FractranProgram -> [Int] +fractran program = + let prog = map (\(x,y) -> (fromIntegral x, fromIntegral y)) (fractions program) + f = (\p v -> if (p == []) + then [] + else let (curX, curY) = head p + newV = v * curX / curY + in if (isInt newV) + then newV : (f prog newV) + else f (tail p) v) + result = map round (f prog (fromIntegral (initialValue program))) + in (initialValue program) : result + + + +isInt :: (RealFrac a) => a -> Bool +isInt x = + x == fromInteger (round x) + diff --git a/src/Fractran/Parser.hs b/src/Fractran/Parser.hs new file mode 100644 index 0000000..95aa954 --- /dev/null +++ b/src/Fractran/Parser.hs @@ -0,0 +1,68 @@ +module Fractran.Parser ( + FractranProgram(..), + + parseFractran + ) where + + +import Control.Applicative( some ) +import Text.ParserCombinators.Parsec + + + +data FractranProgram = FractranProgram { fractions :: [(Int,Int)] + , initialValue :: Int } + deriving (Show, Eq) + + + + +parseFractran :: String -> Either ParseError FractranProgram +parseFractran = parse fractran "error" + + + + +fractran = do + whiteSpace + value <- initVal + fractionList <- many intPair + eof + return (FractranProgram fractionList value) + + +intPair = do + numerator <- wholeNumber + slash + denominator <- positiveNumber + whiteSpace + return (numerator,denominator) + + +slash = char '/' + "slash character" + + +initVal = do + value <- wholeNumber + whiteSpace + return value + + +wholeNumber = do + value <- some digit + return (read value) + + +positiveNumber = do + firstDigit <- nonZeroDigit + rest <- many digit + return (read (firstDigit:rest)) + + +nonZeroDigit = oneOf "123456789" + "non-zero digit" + + +whiteSpace = many (oneOf "\t\n\r ") + diff --git a/src/Fractran/Test.hs b/src/Fractran/Test.hs new file mode 100644 index 0000000..2b507b1 --- /dev/null +++ b/src/Fractran/Test.hs @@ -0,0 +1,53 @@ +module Fractran.Test ( + parserTests, + interpreterTests, + tests + ) where + + +import Test.HUnit +import Text.Parsec.Error +import Fractran.Parser +import Fractran.Interpreter +import Fractran.Example + + +instance Eq Text.Parsec.Error.ParseError + + + + +parser0 = (Right (FractranProgram [] 2)) ~=? (parseFractran "2") + +parser1 = (Right (FractranProgram [] 2)) ~=? (parseFractran "2\n") + +parser2 = (Right (FractranProgram [] 2)) ~=? (parseFractran "\n2") + +parser3 = (Right (FractranProgram [(1,2)] 2)) ~=? (parseFractran "2 1/2") + +parser4 = (Right (FractranProgram [(2,3)] 3)) ~=? (parseFractran "3\n \n2/3\n") + + + +interpreter0 = [108,162,243] ~=? (fractran (FractranProgram addition 108)) + +interpreter1 = [2,15,825,725,1925,2275,425,390,330,290,770,910,170,156,132,116,308,364,68,4] ~=? (take 20 (fractran prime2)) + +interpreter2 = [5] ~=? (fractran (FractranProgram addition 5)) + + + +parserTests :: Test +parserTests = TestList [parser0, parser1,parser2, parser3, parser4] + + + +interpreterTests :: Test +interpreterTests = TestList [interpreter0, interpreter1, interpreter2] + + + +tests :: Test +tests = case (parserTests, interpreterTests) of + (TestList a, TestList b) -> TestList (a ++ b) + diff --git a/src/Thue/Interpreter.hs b/src/Thue/Interpreter.hs new file mode 100644 index 0000000..c53bff9 --- /dev/null +++ b/src/Thue/Interpreter.hs @@ -0,0 +1,77 @@ +module Thue.Interpreter ( + thue, + extractInfix, + nextInRange + ) where + + +import System.Random +import Data.Maybe +import Data.List +import Thue.Parser + + + + +thue :: ThueProgram -> IO ThueState +thue program = + let rules = thueRules program + state = thueInitialState program + gen = mkStdGen 4 --chosen by fair dice roll, guaranteed to be random + + in interpret state rules gen + + + +interpret :: ThueState -> [ThueRule] -> StdGen -> IO ThueState +interpret state rules gen = do + let possibleRules = rules `applicableTo` state + ruleToApply = if (possibleRules == []) then (ThueRule "" "") else possibleRules !! num + -- ^ dummy rule if no possible rules apply + + (num, gen') = nextInRange 0 (length possibleRules - 1) gen + + (before, after) = fromJust (extractInfix (original ruleToApply) state) + + state' <- case (replacement ruleToApply) of + ":::" -> getLine >>= (\x -> return (before ++ x ++ after)) + + '~':xs -> putStr xs >> return (before ++ after) + + x -> return (before ++ x ++ after) + + if (possibleRules == []) then return state else interpret state' rules gen' + + + +extractInfix :: Eq a => [a] -> [a] -> Maybe ([a], [a]) +extractInfix subList list = + let f = (\pre cur -> case (stripPrefix subList cur) of + Nothing -> f ((head cur):pre) (tail cur) + Just x -> (reverse pre, x)) + + in if (subList `isInfixOf` list) then Just (f [] list) else Nothing + + + +nextInRange :: Int -> Int -> StdGen -> (Int, StdGen) +nextInRange low high random = + let (genLow, genHigh) = genRange random + (rawNext, random') = next random + + irawNext = fromIntegral rawNext + igenLow = fromIntegral genLow + igenHigh = fromIntegral genHigh + ilow = fromIntegral low + ihigh = fromIntegral high + + n' = ((irawNext - igenLow) / (igenHigh - igenLow)) * (ihigh - ilow) + ilow + + in (round n', random') + + + +applicableTo :: [ThueRule] -> ThueState -> [ThueRule] +applicableTo ruleList state = + filter (\r -> (original r) `isInfixOf` state) ruleList + diff --git a/src/Thue/Parser.hs b/src/Thue/Parser.hs new file mode 100644 index 0000000..2ee41ae --- /dev/null +++ b/src/Thue/Parser.hs @@ -0,0 +1,84 @@ +module Thue.Parser ( + ThueProgram(..), + ThueRule(..), + ThueState, + + parseThue + ) where + +import Control.Applicative( some ) +import Text.ParserCombinators.Parsec + + + +data ThueProgram = ThueProgram { thueRules :: [ThueRule] + , thueInitialState :: ThueState } + deriving (Show, Eq) + + +data ThueRule = ThueRule { original :: ThueState + , replacement :: ThueState } + deriving (Show, Eq) + + +type ThueState = String + + + + +parseThue :: String -> Either ParseError ThueProgram +parseThue = parse thue "error" + + + + +thue = do + rs <- many rule + separatorLine + i <- initialState + eof + return (ThueProgram rs i) + + +rule = do + o <- ruleState + separator + r <- state + eol + return (ThueRule o r) + + +separatorLine = whiteSpace >> separator >> whiteSpace >> eol +separator = string "::=" + "rule separator" + + +initialState = do + s <- state `sepEndBy` eol + return (concat s) + + +ruleState = some ruleStateChar + + +ruleStateChar = noneOf "\n\r:" + <|> try (char ':' >> notFollowedBy (string ":=") >> return ':') + "state character" + + +state = many stateChar + + +stateChar = noneOf "\n\r" + "state character" + + +whiteSpace = many (oneOf "\t ") + + +eol = try (string "\r\n") + <|> try (string "\n\r") + <|> try (string "\r") + <|> try (string "\n") + "end of line" + diff --git a/src/Thue/Test.hs b/src/Thue/Test.hs new file mode 100644 index 0000000..0273c48 --- /dev/null +++ b/src/Thue/Test.hs @@ -0,0 +1,52 @@ +module Thue.Test ( + parserTests, + extractInfixTests, + tests + ) where + + +import Test.HUnit +import Text.Parsec.Error +import Thue.Parser +import Thue.Interpreter + + +instance Eq Text.Parsec.Error.ParseError + + + + +parser0 = (Right (ThueProgram [ThueRule "a" "b"] "a")) ~=? (parseThue "a::=b\n::=\na") + +parser1 = (Right (ThueProgram [] "b")) ~=? (parseThue "::=\nb") + + + +extractInfix0 = Nothing ~=? (extractInfix [1,2] [3,4,5]) + +extractInfix1 = (Just ([1,2],[5,6])) ~=? (extractInfix [3,4] [1,2,3,4,5,6]) + +extractInfix2 = (Just ([],[3,4])) ~=? (extractInfix [0,1,2] [0,1,2,3,4]) + +extractInfix3 = (Just ([1],[])) ~=? (extractInfix [2,3] [1,2,3]) + +extractInfix4 = (Just ([],[1])) ~=? (extractInfix [] [1]) + +extractInfix5 = (Just ("before","after")) ~=? (extractInfix "middle" "beforemiddleafter") + + + +parserTests :: Test +parserTests = TestList [parser0, parser1] + + + +extractInfixTests :: Test +extractInfixTests = TestList [extractInfix0, extractInfix1, extractInfix2, extractInfix3, extractInfix4, extractInfix5] + + + +tests :: Test +tests = case (parserTests, extractInfixTests) of + (TestList a, TestList b) -> TestList (a ++ b) + diff --git a/src/Unlambda/Builtins.hs b/src/Unlambda/Builtins.hs new file mode 100644 index 0000000..bb054a1 --- /dev/null +++ b/src/Unlambda/Builtins.hs @@ -0,0 +1,70 @@ +module Unlambda.Builtins ( + k, + s, + i, + dot, + r, + d, + c, + e + ) where + + +import Control.Exception( Exception(..), throw ) + + + +data MyException = MyException { func :: a -> b } + deriving (Show, Eq) + +instance Exception MyException + + + +k :: a -> b -> a +k x y = x + + + +s :: (a -> b -> c) -> (a -> b) -> a -> c +s x y z = (x z) (y z) + + + +i :: a -> a +i = id + + + +class Void a where + v :: a -> r + +instance Void v => Void (a -> r) where + v x = v + + + +dot :: Char -> a -> IO a +dot ch f = putChar ch >> return f + + + +r :: a -> IO a +r f = putChar '\n' >> return f + + + +-- may not work as per unlambda lazy semantics +d :: (a -> b) -> (a -> b) +d x = (\y -> x y) + + + +c :: (a -> b) -> (a -> b) +c x = (`runCont` id) (callCC $ \cont -> x cont) + + + +e :: a -> b +e x = throw (MyException x) + diff --git a/src/Unlambda/Interpreter.hs b/src/Unlambda/Interpreter.hs new file mode 100644 index 0000000..f1dcf05 --- /dev/null +++ b/src/Unlambda/Interpreter.hs @@ -0,0 +1,85 @@ +module Unlambda.Interpreter ( + unlambda + ) where + + +import System.IO.Error +import Control.Monad.Trans.Cont +import Control.Monad.IO.Class +import Data.Maybe +import Unlambda.Parser +import Unlambda.Types + + + + +unlambda :: UnlambdaTerm -> IO UnlambdaTerm +unlambda term = getResult $ eval term + + + +eval :: UnlambdaTerm -> ULM UnlambdaTerm +eval term = + case term of + App f x -> do + t <- eval f + apply t x + _ -> return term + + + +apply :: UnlambdaTerm -> UnlambdaTerm -> ULM UnlambdaTerm +apply firstTerm secondTerm = + case firstTerm of + K -> eval secondTerm >>= return . Kpartial + + Kpartial x -> eval secondTerm >> return x + + S -> eval secondTerm >>= return . Spartial + + Spartial x -> eval secondTerm >>= return . (Sapp x) + + Sapp x y -> do + z <- eval secondTerm + eval (App (App x z) (App y z)) + + I -> eval secondTerm + + V -> eval secondTerm >> return V + + C -> callCC $ \cont -> eval (App secondTerm (Continuation cont)) + + Continuation cont -> eval secondTerm >>= cont + + D -> return (Promise secondTerm) + + Promise x -> eval secondTerm >>= eval . (App x) + + Dot c -> do + t <- eval secondTerm + liftIO (putChar c) + return t + + R -> do + t <- eval secondTerm + liftIO (putChar '\n') + return t + + E -> eval secondTerm >>= doExit + + Reed -> do + t <- eval secondTerm + ch <- liftIO (catchIOError (getChar >>= return . Just) (\e -> return Nothing)) + setCurChar ch + if (isNothing ch) then eval (App t V) else eval (App t I) + + Bar -> do + t <- eval secondTerm + ch <- getCurChar + if (isNothing ch) then eval (App t V) else eval (App t I) + + Compare c -> do + t <- eval secondTerm + ch <- getCurChar + if (ch /= Just c) then eval (App t V) else eval (App t I) + diff --git a/src/Unlambda/Parser.hs b/src/Unlambda/Parser.hs new file mode 100644 index 0000000..23bf723 --- /dev/null +++ b/src/Unlambda/Parser.hs @@ -0,0 +1,125 @@ +module Unlambda.Parser ( + parseUnlambda, + parseUnlambda1 + ) where + + +import Control.Applicative( some ) +import Data.Either +import Text.ParserCombinators.Parsec +import Unlambda.Types + + + + +parseUnlambda :: String -> Either ParseError UnlambdaTerm +parseUnlambda input = + let firstPass = parse removeComments "error" input + in case firstPass of + Left e -> Left e + Right o -> parse unlambda "error" o + + + +parseUnlambda1 :: String -> Either ParseError UnlambdaTerm +parseUnlambda1 input = + let firstPass = parse removeComments "error" input + in case firstPass of + Left e -> Left e + Right o -> parse unlambda1 "error" o + + + + +removeComments = uline `sepEndBy` eol >>= (return . concat) + + +uline = do + l <- many (builtin <|> (oneOf " \t" >>= return . (:[]))) + optional (char '#' >> many (noneOf "\r\n")) + return . concat $ l + + +builtin = (oneOf "`skivrdce|@" >>= return . (:[])) + <|> (char '.' >> anyChar >>= return . ('.':) . (:[])) + <|> (char '?' >> anyChar >>= return . ('?':) . (:[])) + "unlambda builtin function" + + +eol = try (string "\r\n") + <|> try (string "\n\r") + <|> try (string "\r") + <|> try (string "\n") + "end of line" + + +unlambda = do + whiteSpace + t <- term + eof + return t + + +unlambda1 = do + whiteSpace + t <- term1 + eof + return t + + +term = (try term1) + <|> (try e) + <|> (try reed) + <|> (try comp) + <|> (try bar) + "unlambda term" + + +term1 = (try app) + <|> (try s) + <|> (try k) + <|> (try i) + <|> (try v) + <|> (try r) + <|> (try d) + <|> (try c) + <|> (try dot) + "unlambda term" + + +app = do + char '`' + whiteSpace + f <- term + x <- term + return (App f x) + + +s = char 's' >> whiteSpace >> return S +k = char 'k' >> whiteSpace >> return K +i = char 'i' >> whiteSpace >> return I +v = char 'v' >> whiteSpace >> return V +r = char 'r' >> whiteSpace >> return R +d = char 'd' >> whiteSpace >> return D +c = char 'c' >> whiteSpace >> return C +e = char 'e' >> whiteSpace >> return E +reed = char '@' >> whiteSpace >> return Reed +bar = char '|' >> whiteSpace >> return Bar + + +comp = do + char '?' + c <- anyChar + whiteSpace + return (Compare c) + + +dot = do + char '.' + c <- anyChar + whiteSpace + return (Dot c) + + +whiteSpace = many (oneOf "\t\n\r ") + diff --git a/src/Unlambda/Test.hs b/src/Unlambda/Test.hs new file mode 100644 index 0000000..f049b59 --- /dev/null +++ b/src/Unlambda/Test.hs @@ -0,0 +1,103 @@ +module Unlambda.Test ( + parserTests, + interpreterTests, + tests, + ioTests + ) where + + +import Test.HUnit +import Text.Parsec.Error +import Control.Monad +import System.IO.Silently +import Unlambda.Types +import Unlambda.Parser +import Unlambda.Interpreter + + +instance Eq Text.Parsec.Error.ParseError + + + + +parser0 = (Right S) ~=? (parseUnlambda "s") + +parser1 = (Right K) ~=? (parseUnlambda "k") + +parser2 = (Right I) ~=? (parseUnlambda "i") + +parser3 = (Right V) ~=? (parseUnlambda "v") + +parser4 = (Right R) ~=? (parseUnlambda "r") + +parser5 = (Right D) ~=? (parseUnlambda "d") + +parser6 = (Right C) ~=? (parseUnlambda "c") + +parser7 = (Right E) ~=? (parseUnlambda "e") + +parser8 = (Right (App S K)) ~=? (parseUnlambda "`sk") + +parser9 = (Right (Dot 'c')) ~=? (parseUnlambda ".c") + +parser10 = (Right (Compare '?')) ~=? (parseUnlambda "??") + +parser11 = (Right Bar) ~=? (parseUnlambda "|") + +parser12 = (Right Reed) ~=? (parseUnlambda "@") + + + +interpretString :: String -> IO (Maybe (String,UnlambdaTerm)) +interpretString input = + let t = parseUnlambda input + in case t of + Left _ -> return Nothing + Right term -> do + c <- capture (unlambda term) + return (Just c) + + + +interpreter0 = (liftM2 (~=?)) + (return (Just ("\n", R)) ) + (interpretString "``cir") + +interpreter1 = (liftM2 (~=?)) + (return (Just ("", I)) ) + (interpretString "`c``s`kr``si`ki") + +interpreter2 = (liftM2 (~=?)) + (return (Just ("", Promise (App R I))) ) + (interpretString "`d`ri") + +interpreter3 = (liftM2 (~=?)) + (return (Just ("\n", Promise I)) ) + (interpretString "``dd`ri") + + + +parserTests :: Test +parserTests = TestList [parser0, parser1, parser2, parser3, parser4, parser5, parser6, parser7, parser8 + ,parser9, parser10, parser11, parser12] + + + +interpreterTests :: IO Test +interpreterTests = do + t0 <- interpreter0 + t1 <- interpreter1 + t2 <- interpreter2 + t3 <- interpreter3 + return (TestList [t0,t1,t2,t3]) + + + +tests :: Test +tests = parserTests + + + +ioTests :: IO Test +ioTests = interpreterTests + diff --git a/src/Unlambda/Types.hs b/src/Unlambda/Types.hs new file mode 100644 index 0000000..825a624 --- /dev/null +++ b/src/Unlambda/Types.hs @@ -0,0 +1,108 @@ +module Unlambda.Types ( + ULM, + UnlambdaTerm(..), + + getResult, + doExit, + setCurChar, + getCurChar + ) where + + +import Control.Exception +import Control.Monad.Trans.Cont +import Control.Monad.Trans.Class +import Control.Monad.Trans.State.Lazy +import Control.Monad.IO.Class +import Data.Typeable + + + + +data UnlambdaException = UnlambdaException { exitTerm :: UnlambdaTerm } + deriving (Show, Typeable) + +instance Exception UnlambdaException + + + + +type ULM a = ContT UnlambdaTerm (StateT (Maybe Char) IO) a + + + + +data UnlambdaTerm = S | K | I | V | R | D | C | E | Bar | Reed + | Dot Char + | Compare Char + | App UnlambdaTerm UnlambdaTerm + | Kpartial UnlambdaTerm + | Spartial UnlambdaTerm + | Sapp UnlambdaTerm UnlambdaTerm + | Promise UnlambdaTerm + | Continuation (UnlambdaTerm -> ULM UnlambdaTerm) + + +instance Eq UnlambdaTerm where + S == S = True + K == K = True + I == I = True + V == V = True + R == R = True + D == D = True + C == C = True + E == E = True + Bar == Bar = True + Reed == Reed = True + Dot x == Dot y = x == y + Compare x == Compare y = x == y + App a b == App x y = a == x && b == y + Kpartial x == Kpartial y = x == y + Spartial x == Spartial y = x == y + Sapp a b == Sapp x y = a == x && b == y + Promise x == Promise y = x == y + _ == _ = False + + +instance Show UnlambdaTerm where + show S = "s" + show K = "k" + show I = "i" + show V = "v" + show R = "r" + show D = "d" + show C = "c" + show E = "e" + show Bar = "|" + show Reed = "@" + show (Dot x) = ['.', x] + show (Compare x) = ['?', x] + show (App x y) = "`" ++ (show x) ++ (show y) + show (Kpartial x) = "`k" ++ (show x) + show (Spartial x) = "`s" ++ (show x) + show (Sapp x y) = "``s" ++ (show x) ++ (show y) + show (Promise x) = "`d" ++ (show x) + show (Continuation _) = "" + + + + +getResult :: ULM UnlambdaTerm -> IO UnlambdaTerm +getResult m = catches (liftIO ((`evalStateT` Nothing) . (`runContT` return) $ m)) + [ Handler ((\e -> return (exitTerm e)) :: UnlambdaException -> IO UnlambdaTerm) ] + + + +doExit :: UnlambdaTerm -> ULM UnlambdaTerm +doExit term = throw (UnlambdaException term) + + + +setCurChar :: Maybe Char -> ULM () +setCurChar x = lift (put x) + + + +getCurChar :: ULM (Maybe Char) +getCurChar = lift (get) + diff --git a/src/brainfuck.hs b/src/brainfuck.hs new file mode 100644 index 0000000..5f13ae6 --- /dev/null +++ b/src/brainfuck.hs @@ -0,0 +1,30 @@ + +import System.Environment( getArgs ) +import Control.Exception( ErrorCall(..), Handler(..), catches ) +import Brainfuck.Parser +import Brainfuck.Interpreter + + + + +usageString :: String +usageString = "Usage: brainfuck " + + + +program :: IO () +program = do + args <- getArgs + fileContents <- if (length args /= 1) + then error usageString + else readFile (head args) + + case (parseBrainfuck fileContents) of + Left x -> putStrLn (show x) + Right x -> brainfuck x >> return () + + + +main = catches program + [ Handler ((\e -> putStrLn . show $ e) :: ErrorCall -> IO ()) ] + diff --git a/src/fractran.hs b/src/fractran.hs new file mode 100644 index 0000000..224cb05 --- /dev/null +++ b/src/fractran.hs @@ -0,0 +1,30 @@ + +import System.Environment( getArgs ) +import Control.Exception( ErrorCall(..), Handler(..), catches ) +import Fractran.Parser +import Fractran.Interpreter + + + + +usageString :: String +usageString = "Usage: fractran " + + + +program :: IO () +program = do + args <- getArgs + fileContents <- if (length args /= 1) + then error usageString + else readFile (head args) + + case (parseFractran fileContents) of + Left x -> putStrLn (show x) + Right x -> putStrLn (show (fractran x)) + + + +main = catches program + [ Handler ((\e -> putStrLn . show $ e) :: ErrorCall -> IO ()) ] + diff --git a/src/misc.hs b/src/misc.hs new file mode 100644 index 0000000..f7623e4 --- /dev/null +++ b/src/misc.hs @@ -0,0 +1,35 @@ + + + + +modulo :: Int -> Int -> Int +modulo x y = + x - (x `div` y) * y + + + +primeFactors :: Int -> [Int] +primeFactors x = + let p = (\x e c -> if (x == 1) + then (reverse c) + else if (x `modulo` (head e) == 0) + then p (x `div` (head e)) e ((head e) : c) + else p x (tail e) c) + in p x euler [] + + + +euler :: [Int] +euler = + let f = (\list -> (head list) : (f (filter (\x -> x `modulo` (head list) /= 0) list))) + in f [2..] + + + +isPowerOf :: Int -> Int -> Bool +isPowerOf x y = + case (compare x y) of + LT -> False + EQ -> True + GT -> if (x `modulo` y == 0) then isPowerOf (x `div` y) y else False + diff --git a/src/test.hs b/src/test.hs new file mode 100644 index 0000000..5fc3533 --- /dev/null +++ b/src/test.hs @@ -0,0 +1,29 @@ + +import Test.HUnit +import qualified Fractran.Test +import qualified Thue.Test +import qualified Unlambda.Test + + + + +main = do + putStrLn "Fractran Parser" + runTestTT Fractran.Test.parserTests + + putStrLn "\nFractran Interpreter" + runTestTT Fractran.Test.interpreterTests + + putStrLn "\nThue Parser" + runTestTT Thue.Test.parserTests + + putStrLn "\nextractInfix" + runTestTT Thue.Test.extractInfixTests + + putStrLn "\nUnlambda Parser" + runTestTT Unlambda.Test.parserTests + + putStrLn "\nUnlambda Interpreter" + tests <- Unlambda.Test.interpreterTests + runTestTT tests + diff --git a/src/thue.hs b/src/thue.hs new file mode 100644 index 0000000..89afcc3 --- /dev/null +++ b/src/thue.hs @@ -0,0 +1,30 @@ + +import System.Environment( getArgs ) +import Control.Exception( ErrorCall(..), Handler(..), catches ) +import Thue.Parser +import Thue.Interpreter + + + + +usageString :: String +usageString = "Usage: thue " + + + +program :: IO () +program = do + args <- getArgs + fileContents <- if (length args /= 1) + then error usageString + else readFile (head args) + + case (parseThue fileContents) of + Left x -> putStrLn (show x) + Right x -> (thue x) >>= (putStrLn . show) + + + +main = catches program + [ Handler ((\e -> putStrLn . show $ e) :: ErrorCall -> IO ()) ] + diff --git a/src/unlambda.hs b/src/unlambda.hs new file mode 100644 index 0000000..b06b42f --- /dev/null +++ b/src/unlambda.hs @@ -0,0 +1,30 @@ + +import System.Environment( getArgs ) +import Control.Exception( ErrorCall(..), Handler(..), catches ) +import Unlambda.Parser +import Unlambda.Interpreter + + + + +usageString :: String +usageString = "Usage: unlambda " + + + +program :: IO () +program = do + args <- getArgs + fileContents <- if (length args /= 1) + then error usageString + else readFile (head args) + + case (parseUnlambda fileContents) of + Left x -> putStrLn (show x) + Right x -> unlambda x >>= putStrLn . show + + + +main = catches program + [ Handler ((\e -> putStrLn . show $ e) :: ErrorCall -> IO ()) ] + -- cgit