#18 Started conversion to Game

lib/RPGEngine/Parse/StructElement.hs

@@ -0,0 +1,200 @@
+module RPGEngine.Parse.StructElement where
+
+import RPGEngine.Data (Action(..), Condition(..), Layout, Direction(..), Physical(..), Strip)
+import RPGEngine.Parse.Core ( ignoreWS )
+
+import Text.Parsec
+    ( char,
+      many,
+      try,
+      alphaNum,
+      digit,
+      noneOf,
+      oneOf,
+      between,
+      choice,
+      many1,
+      notFollowedBy,
+      sepBy )
+import qualified Text.Parsec as P ( string )
+import Text.Parsec.String ( Parser )
+
+-------------------------- StructureElement --------------------------
+
+-- See documentation for more details, only a short description is
+-- provided here.
+data StructElement = Block [StructElement]
+                   | Entry Key StructElement -- Key + Value
+                   | Regular Value -- Regular value, Integer or String or Infinite
+                   deriving (Eq, Show)
+
+----------------------------------------------------------------------
+
+structElement :: Parser StructElement
+structElement = try $ choice [block, entry, regular]
+
+-- A list of entries
+block :: Parser StructElement
+block = try $ do
+    open   <- ignoreWS $ oneOf openingBrackets
+    middle <- ignoreWS $ choice [entry, block] `sepBy` char ','
+    let closingBracket = getMatchingClosingBracket open
+    ignoreWS $ char closingBracket
+    return $ Block middle
+
+entry :: Parser StructElement
+entry = try $ do
+    key <- ignoreWS key
+    -- TODO Fix this
+    oneOf ": " --  Can be left out
+    value <- ignoreWS structElement
+    return $ Entry key value
+
+regular :: Parser StructElement
+regular = try $ Regular <$> value
+
+--------------------------------- Key --------------------------------
+
+data Key = Tag String
+         | ConditionList [Condition]
+         deriving (Eq, Show)
+
+data ConditionArgument = ArgString String
+                       | Condition Condition
+                       deriving (Eq, Show)
+
+----------------------------------------------------------------------
+
+key :: Parser Key
+key = try $ choice [conditionList, tag]
+
+tag :: Parser Key
+tag = try $ Tag <$> many1 alphaNum
+
+conditionList :: Parser Key
+conditionList = try $ do
+    open <- ignoreWS $ oneOf openingBrackets
+    list <- ignoreWS condition `sepBy` char ','
+    let closingBracket = getMatchingClosingBracket open
+    ignoreWS $ char closingBracket
+    return $ ConditionList $ extract list
+    where extract ((Condition cond):list) = cond:extract list
+          extract _                       = []
+
+condition :: Parser ConditionArgument
+condition = try $ do
+    text <- ignoreWS $ many1 $ noneOf illegalCharacters
+    open <- ignoreWS $ oneOf openingBrackets
+    cond <- ignoreWS $ choice [condition, argString]
+    let closingBracket = getMatchingClosingBracket open
+    ignoreWS $ char closingBracket
+    return $ Condition $ make text cond
+    where make "inventoryFull"     _                = InventoryFull
+          make "inventoryContains" (ArgString arg)  = InventoryContains arg
+          make "not"               (Condition cond) = Not cond
+          make _                   _                = AlwaysFalse
+          argString = try $ ArgString <$> many (noneOf illegalCharacters)
+
+-------------------------------- Value -------------------------------
+
+data Value = String String
+           | Integer Int
+           | Infinite
+           | Action Action
+           | Direction Direction
+           | Layout Layout
+           deriving (Eq, Show)
+
+----------------------------------------------------------------------
+
+value :: Parser Value
+value = choice [string, integer, infinite, action, direction]
+
+string :: Parser Value
+string = try $ String <$> between (char '\"') (char '\"') reading
+    where reading = ignoreWS $ many1 $ noneOf illegalCharacters
+
+integer :: Parser Value
+integer = try $ do
+    value <- ignoreWS $ many1 digit
+    return $ Integer (read value :: Int)
+
+infinite :: Parser Value
+infinite = try $ do
+    ignoreWS $ P.string "infinite"
+    notFollowedBy alphaNum
+    return Infinite
+
+action :: Parser Value
+action = try $ do
+    script <- ignoreWS $ many1 $ noneOf "("
+    arg    <- ignoreWS $ between (char '(') (char ')') $ many $ noneOf ")"
+    let answer | script == "leave"            = Leave
+               | script == "retrieveItem"     = RetrieveItem arg
+               | script == "useItem"          = UseItem arg
+               | script == "decreaseHp"       = DecreaseHp first second
+               | script == "increasePlayerHp" = IncreasePlayerHp arg
+               | otherwise                    = RPGEngine.Data.Nothing
+        (first, ',':second) = break (== ',') arg
+    return $ Action answer
+
+direction :: Parser Value
+direction = try $ do
+    value <- choice [
+        ignoreWS $ P.string "up",
+        ignoreWS $ P.string "down",
+        ignoreWS $ P.string "left",
+        ignoreWS $ P.string "right"
+        ]
+    notFollowedBy alphaNum
+    return $ Direction $ make value
+    where make "up"    = North
+          make "right" = East
+          make "down"  = South
+          make "left"  = West
+          make _       = Center
+
+layout :: Parser Value
+layout = try $ do
+    ignoreWS $ char '|'
+    list <- ignoreWS strip `sepBy` ignoreWS (char '|')
+    return $ Layout list
+
+strip :: Parser Strip
+strip = try $ do
+    physical `sepBy` char ' '
+
+physical :: Parser Physical
+physical = try $ do
+    value <- choice [
+        char 'x',
+        char '.',
+        char '*',
+        char 's',
+        char 'e'
+        ]
+    return $ make value
+    where make '.' = Walkable
+          make '*' = Blocked
+          make 's' = Entrance
+          make 'e' = Exit
+          make _   = Void
+
+
+------------------------------ Brackets ------------------------------
+
+openingBrackets :: [Char]
+openingBrackets = "<({["
+
+closingBrackets :: [Char]
+closingBrackets = ">)}]"
+
+illegalCharacters :: [Char]
+illegalCharacters = ",:\"" ++ openingBrackets ++ closingBrackets
+
+----------------------------------------------------------------------
+
+getMatchingClosingBracket :: Char -> Char
+getMatchingClosingBracket opening = closingBrackets !! index
+    where combo = zip openingBrackets [0 ..]
+          index = head $ [y | (x, y) <- combo, x == opening]