summaryrefslogtreecommitdiff
path: root/src/Thue
diff options
context:
space:
mode:
authorJed Barber <jjbarber@y7mail.com>2014-04-10 05:25:03 +1000
committerJed Barber <jjbarber@y7mail.com>2014-04-10 05:25:03 +1000
commit281425310c5db21f87981eeb9601a71d1974d98d (patch)
treebef4643d906c93622c311fef2cf758fe94f1f651 /src/Thue
parente8695600977769008f285f9958eb043cca1b9b29 (diff)
Rearranging files
Diffstat (limited to 'src/Thue')
-rw-r--r--src/Thue/Interpreter.hs77
-rw-r--r--src/Thue/Parser.hs84
-rw-r--r--src/Thue/Test.hs52
3 files changed, 213 insertions, 0 deletions
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)
+