summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Brainfuck/Interpreter.hs70
-rw-r--r--src/Brainfuck/Parser.hs62
-rw-r--r--src/Brainfuck/Tape.hs46
-rw-r--r--src/Fractran/Example.hs46
-rw-r--r--src/Fractran/Interpreter.hs29
-rw-r--r--src/Fractran/Parser.hs68
-rw-r--r--src/Fractran/Test.hs53
-rw-r--r--src/Thue/Interpreter.hs77
-rw-r--r--src/Thue/Parser.hs84
-rw-r--r--src/Thue/Test.hs52
-rw-r--r--src/Unlambda/Builtins.hs70
-rw-r--r--src/Unlambda/Interpreter.hs85
-rw-r--r--src/Unlambda/Parser.hs125
-rw-r--r--src/Unlambda/Test.hs103
-rw-r--r--src/Unlambda/Types.hs108
-rw-r--r--src/brainfuck.hs30
-rw-r--r--src/fractran.hs30
-rw-r--r--src/misc.hs35
-rw-r--r--src/test.hs29
-rw-r--r--src/thue.hs30
-rw-r--r--src/unlambda.hs30
21 files changed, 1262 insertions, 0 deletions
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 _) = "<cont>"
+
+
+
+
+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 file>"
+
+
+
+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 file>"
+
+
+
+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 file>"
+
+
+
+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 file>"
+
+
+
+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 ()) ]
+
generated by cgit (git 2.30.0) at 2024-12-22 22:11:20 +0000