From 281425310c5db21f87981eeb9601a71d1974d98d Mon Sep 17 00:00:00 2001 From: Jed Barber Date: Thu, 10 Apr 2014 05:25:03 +1000 Subject: Rearranging files --- Brainfuck/Interpreter.hs | 70 ------------------------ Brainfuck/Parser.hs | 62 --------------------- Brainfuck/Tape.hs | 46 ---------------- Fractran/Example.hs | 46 ---------------- Fractran/Interpreter.hs | 29 ---------- Fractran/Parser.hs | 68 ----------------------- Fractran/Test.hs | 53 ------------------ Thue/Interpreter.hs | 77 -------------------------- Thue/Parser.hs | 84 ----------------------------- Thue/Test.hs | 52 ------------------ Unlambda/Builtins.hs | 70 ------------------------ Unlambda/Interpreter.hs | 85 ----------------------------- Unlambda/Parser.hs | 125 ------------------------------------------- Unlambda/Test.hs | 103 ----------------------------------- Unlambda/Types.hs | 108 ------------------------------------- brainfuck.hs | 30 ----------- fractran.hs | 30 ----------- makefile | 16 ++++-- misc.hs | 35 ------------ 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 +++++++++++ test.hs | 29 ---------- thue.hs | 30 ----------- unlambda.hs | 30 ----------- 43 files changed, 1273 insertions(+), 1267 deletions(-) delete mode 100644 Brainfuck/Interpreter.hs delete mode 100644 Brainfuck/Parser.hs delete mode 100644 Brainfuck/Tape.hs delete mode 100644 Fractran/Example.hs delete mode 100644 Fractran/Interpreter.hs delete mode 100644 Fractran/Parser.hs delete mode 100644 Fractran/Test.hs delete mode 100644 Thue/Interpreter.hs delete mode 100644 Thue/Parser.hs delete mode 100644 Thue/Test.hs delete mode 100644 Unlambda/Builtins.hs delete mode 100644 Unlambda/Interpreter.hs delete mode 100644 Unlambda/Parser.hs delete mode 100644 Unlambda/Test.hs delete mode 100644 Unlambda/Types.hs delete mode 100644 brainfuck.hs delete mode 100644 fractran.hs delete mode 100644 misc.hs 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 delete mode 100644 test.hs delete mode 100644 thue.hs delete mode 100644 unlambda.hs diff --git a/Brainfuck/Interpreter.hs b/Brainfuck/Interpreter.hs deleted file mode 100644 index 1085a30..0000000 --- a/Brainfuck/Interpreter.hs +++ /dev/null @@ -1,70 +0,0 @@ -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/Brainfuck/Parser.hs b/Brainfuck/Parser.hs deleted file mode 100644 index 1ea046a..0000000 --- a/Brainfuck/Parser.hs +++ /dev/null @@ -1,62 +0,0 @@ -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/Brainfuck/Tape.hs b/Brainfuck/Tape.hs deleted file mode 100644 index 8da4352..0000000 --- a/Brainfuck/Tape.hs +++ /dev/null @@ -1,46 +0,0 @@ -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/Fractran/Example.hs b/Fractran/Example.hs deleted file mode 100644 index 43d8cc8..0000000 --- a/Fractran/Example.hs +++ /dev/null @@ -1,46 +0,0 @@ -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/Fractran/Interpreter.hs b/Fractran/Interpreter.hs deleted file mode 100644 index 1393991..0000000 --- a/Fractran/Interpreter.hs +++ /dev/null @@ -1,29 +0,0 @@ -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/Fractran/Parser.hs b/Fractran/Parser.hs deleted file mode 100644 index 95aa954..0000000 --- a/Fractran/Parser.hs +++ /dev/null @@ -1,68 +0,0 @@ -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/Fractran/Test.hs b/Fractran/Test.hs deleted file mode 100644 index 2b507b1..0000000 --- a/Fractran/Test.hs +++ /dev/null @@ -1,53 +0,0 @@ -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/Thue/Interpreter.hs b/Thue/Interpreter.hs deleted file mode 100644 index c53bff9..0000000 --- a/Thue/Interpreter.hs +++ /dev/null @@ -1,77 +0,0 @@ -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/Thue/Parser.hs b/Thue/Parser.hs deleted file mode 100644 index 2ee41ae..0000000 --- a/Thue/Parser.hs +++ /dev/null @@ -1,84 +0,0 @@ -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/Thue/Test.hs b/Thue/Test.hs deleted file mode 100644 index 0273c48..0000000 --- a/Thue/Test.hs +++ /dev/null @@ -1,52 +0,0 @@ -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/Unlambda/Builtins.hs b/Unlambda/Builtins.hs deleted file mode 100644 index bb054a1..0000000 --- a/Unlambda/Builtins.hs +++ /dev/null @@ -1,70 +0,0 @@ -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/Unlambda/Interpreter.hs b/Unlambda/Interpreter.hs deleted file mode 100644 index f1dcf05..0000000 --- a/Unlambda/Interpreter.hs +++ /dev/null @@ -1,85 +0,0 @@ -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/Unlambda/Parser.hs b/Unlambda/Parser.hs deleted file mode 100644 index 23bf723..0000000 --- a/Unlambda/Parser.hs +++ /dev/null @@ -1,125 +0,0 @@ -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/Unlambda/Test.hs b/Unlambda/Test.hs deleted file mode 100644 index f049b59..0000000 --- a/Unlambda/Test.hs +++ /dev/null @@ -1,103 +0,0 @@ -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/Unlambda/Types.hs b/Unlambda/Types.hs deleted file mode 100644 index 825a624..0000000 --- a/Unlambda/Types.hs +++ /dev/null @@ -1,108 +0,0 @@ -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/brainfuck.hs b/brainfuck.hs deleted file mode 100644 index 5f13ae6..0000000 --- a/brainfuck.hs +++ /dev/null @@ -1,30 +0,0 @@ - -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/fractran.hs b/fractran.hs deleted file mode 100644 index 224cb05..0000000 --- a/fractran.hs +++ /dev/null @@ -1,30 +0,0 @@ - -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/makefile b/makefile index 66a2928..43c7a44 100644 --- a/makefile +++ b/makefile @@ -1,5 +1,6 @@ OUTPUTDIR = bin +SOURCEDIR = src EXECUTABLES = ${OUTPUTDIR}/test \ ${OUTPUTDIR}/fractran \ @@ -24,16 +25,21 @@ distclean: testprog: - ghc ${SWITCHES} --make test.hs -o ${OUTPUTDIR}/test + cd ${SOURCEDIR}; \ + ghc ${SWITCHES} --make test.hs -o ../${OUTPUTDIR}/test fractranprog: - ghc ${SWITCHES} --make fractran.hs -o ${OUTPUTDIR}/fractran + cd ${SOURCEDIR}; \ + ghc ${SWITCHES} --make fractran.hs -o ../${OUTPUTDIR}/fractran thueprog: - ghc ${SWITCHES} --make thue.hs -o ${OUTPUTDIR}/thue + cd ${SOURCEDIR}; \ + ghc ${SWITCHES} --make thue.hs -o ../${OUTPUTDIR}/thue unlambdaprog: - ghc ${SWITCHES} --make unlambda.hs -o ${OUTPUTDIR}/unlambda + cd ${SOURCEDIR}; \ + ghc ${SWITCHES} --make unlambda.hs -o ../${OUTPUTDIR}/unlambda brainfuckprog: - ghc ${SWITCHES} --make brainfuck.hs -o ${OUTPUTDIR}/brainfuck + cd ${SOURCEDIR}; \ + ghc ${SWITCHES} --make brainfuck.hs -o ../${OUTPUTDIR}/brainfuck diff --git a/misc.hs b/misc.hs deleted file mode 100644 index f7623e4..0000000 --- a/misc.hs +++ /dev/null @@ -1,35 +0,0 @@ - - - - -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/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 ()) ] + diff --git a/test.hs b/test.hs deleted file mode 100644 index 5fc3533..0000000 --- a/test.hs +++ /dev/null @@ -1,29 +0,0 @@ - -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/thue.hs b/thue.hs deleted file mode 100644 index 89afcc3..0000000 --- a/thue.hs +++ /dev/null @@ -1,30 +0,0 @@ - -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/unlambda.hs b/unlambda.hs deleted file mode 100644 index b06b42f..0000000 --- a/unlambda.hs +++ /dev/null @@ -1,30 +0,0 @@ - -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