206 lines
No EOL
6.2 KiB
Haskell
206 lines
No EOL
6.2 KiB
Haskell
module RPGEngine.Parse.TextToStructure
|
|
-- Everything is exported for testing
|
|
where
|
|
|
|
import RPGEngine.Parse.Core ( ignoreWS )
|
|
|
|
import RPGEngine.Data (Action (..), Condition (..), Direction (..), Layout, Strip, Physical (..))
|
|
|
|
import Text.Parsec
|
|
( alphaNum,
|
|
char,
|
|
digit,
|
|
noneOf,
|
|
oneOf,
|
|
between,
|
|
choice,
|
|
many1,
|
|
notFollowedBy,
|
|
sepBy,
|
|
many,
|
|
try, spaces, endOfLine )
|
|
import qualified Text.Parsec as P ( string )
|
|
import Text.Parsec.String ( Parser )
|
|
import Text.Parsec.Combinator (lookAhead)
|
|
|
|
gameFile :: Parser [Structure]
|
|
gameFile = try $ do many1 $ ignoreWS structure
|
|
|
|
-------------------------- StructureElement --------------------------
|
|
|
|
-- See documentation for more details, only a short description is
|
|
-- provided here.
|
|
data Structure = Block [Structure]
|
|
| Entry Key Structure -- Key + Value
|
|
| Regular Value -- Regular value, Integer or String or Infinite
|
|
deriving (Eq, Show)
|
|
|
|
----------------------------------------------------------------------
|
|
|
|
structure :: Parser Structure
|
|
structure = try $ choice [block, entry, regular]
|
|
|
|
-- A list of entries
|
|
block :: Parser Structure
|
|
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 Structure
|
|
entry = try $ do
|
|
key <- ignoreWS key
|
|
-- TODO Fix this
|
|
oneOf ": " -- Can be left out
|
|
value <- ignoreWS structure
|
|
return $ Entry key value
|
|
|
|
regular :: Parser Structure
|
|
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 [layout, string, integer, infinite, direction, action]
|
|
|
|
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 (filter (/= ' ') second) -- TODO Work this hack away
|
|
| script == "increasePlayerHp" = IncreasePlayerHp arg
|
|
| otherwise = DoNothing
|
|
(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"
|
|
]
|
|
-- lookAhead $ char ','
|
|
return $ Direction $ make value
|
|
where make "up" = North
|
|
make "right" = East
|
|
make "down" = South
|
|
make "left" = West
|
|
make _ = Stay
|
|
|
|
layout :: Parser Value
|
|
layout = try $ do
|
|
open <- ignoreWS $ oneOf openingBrackets
|
|
let closing = getMatchingClosingBracket open
|
|
value <- many1 strip <* ignoreWS (char closing)
|
|
return $ Layout value
|
|
|
|
strip :: Parser Strip
|
|
strip = try $ do ignoreWS (char '|') *> ignoreWS (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] |