module Game.Antisplice.Lang (act) where
import Text.Chatty.Printer
import Text.Chatty.Scanner
import Text.Chatty.Expansion
import Game.Antisplice.Errors
import Game.Antisplice.Monad
import Game.Antisplice.Monad.Dungeon
import Game.Antisplice.Monad.Vocab
import Game.Antisplice.Utils.Graph
import Game.Antisplice.Utils.AVL
import Game.Antisplice.Utils.TST
import Game.Antisplice.Rooms
import Control.Monad.Error
import Text.Printf
import Data.Text (unpack)
aliases :: [(String,String)]
aliases =
("l","look"):
("n","go north"):
("ne","go northeast"):
("e","go east"):
("se","go southeast"):
("s","go south"):
("sw","go southwest"):
("w","go west"):
("nw","go northwest"):
("u","ascend"):
("d","descend"):
("q","quit"):
("i","list inventory"):
("ex","list exits"):
("get","acquire"):
("take","acquire"):
("show","list"):
[]
defVocab :: TST Token
defVocab = foldr (\(k,v) -> tstInsert k (v k)) EmptyTST (
("look",Verb):
("quit",Verb):
("read",Verb):
("acquire",Verb):
("drop",Verb):
("idiot",Noun):
("first",Ordn 1):
("next",Ordn 1):
("primary",Ordn 1):
("second",Ordn 2):
("commit",Verb):
("suicide",Noun):
("go",Verb):
("ascend",Verb):
("descend",Verb):
("north",Fixe):
("south",Fixe):
("east",Fixe):
("west",Fixe):
("northeast",Fixe):
("northwest",Fixe):
("southeast",Fixe):
("southwest",Fixe):
("at",Prep):
("enter",Verb):
("list",Verb):
("exits",Fixe):
("inventory",Fixe):
[])
replaceAliases :: [String] -> [String]
replaceAliases [] = []
replaceAliases (s:ss) = words (aliasOf s) ++ replaceAliases ss
where aliasOf x = case filter ((==x).fst) aliases of
[] -> x
(a:_) -> snd a
isIntellegible :: Token -> Bool
isIntellegible (Unintellegible _) = False
isIntellegible _ = True
isNoun :: Token -> Bool
isNoun (Noun _) = True
isNoun _ = False
isAdj :: Token -> Bool
isAdj (Adj _) = True
isAdj _ = False
mergeNouns :: [Token] -> [Token]
mergeNouns [] = []
mergeNouns (Noun s:ts) = Nounc [] Nothing s : mergeNouns ts
mergeNouns ts@(Adj _:_) =
let as = takeWhile isAdj ts
ns = dropWhile isAdj ts
in case ns of
(n:nx) -> Nounc (map (\(Adj a) -> a) as) Nothing ((\(Noun n) -> n) n) : mergeNouns nx
_ -> as
mergeNouns (o@(Ordn i _):ts) =
let as = takeWhile isAdj ts
ns = dropWhile isAdj ts
in case ns of
(n:nx) -> Nounc (map (\(Adj a) -> a) as) (Just i) ((\(Noun n) -> n) n) : mergeNouns nx
_ -> o:as
mergeNouns (t:ts) = t : mergeNouns ts
act :: String -> ChattyDungeonM ()
act s = do
ts <- mapM lookupVocab $ replaceAliases $ words s
let ss = mergeNouns ts
unless (all isIntellegible ss) $ throwError UnintellegibleError
case ss of
[] -> return ()
(Verb v:_) -> act' ss
_ -> throwError VerbMustFirstError
return ()
act' (Verb "quit":[]) = throwError QuitError
act' (Verb "look":[]) = roomTriggerOnLookOf =<< getRoomState
act' (Verb "look":Prep "at":n@Nounc{}:[]) = getObject n >>= objectTriggerOnLookAtOf
act' (Verb "read":n@Nounc{}:[]) = getObject n >>= objectTriggerOnReadOf
act' (Verb "enter":n@Nounc{}:[]) = getObject n >>= objectTriggerOnEnterOf
act' (Verb "ascend":[]) = changeRoom Up
act' (Verb "descend":[]) = changeRoom Down
act' (Verb "go":Fixe d:[]) =
changeRoom $ case d of
"north" -> North
"south" -> South
"east" -> East
"west" -> West
"northeast" -> NorthEast
"northwest" -> NorthWest
"southeast" -> SouthEast
"southwest" -> SouthWest
"up" -> Up
"down" -> Down
act' (Verb "list":Fixe "exits":[]) = do
s <- getDungeonState
let (Just r) = currentRoomOf s
forM_ (listEdges r $ roomsOf s) $ \(l,n) -> do
mprint " " >> mprint (show l) >> mprint " -> "
mprintLn =<< withRoom n getRoomTitle
act' (Verb "list":Fixe "inventory":[]) = do
ps <- getPlayerState
mprintLn "Your inventory:"
forM_ (avlInorder $ playerInventoryOf ps) $ \os -> mprintLn $ printf " %s" $ unpack $ objectTitleOf os
act' (Verb "acquire":n@Nounc{}:[]) = getObject n >>= (acquireObject . objectIdOf)
act' (Verb "drop":n@Nounc{}:[]) = getObject n >>= (dropObject . objectIdOf)
act' _ = throwError UnintellegibleError
getObject :: (MonadRoom m,MonadError SplErr m,MonadPlayer m) => Token -> m ObjectState
getObject (Nounc as i n) = do
rs <- getRoomState
ps <- getPlayerState
let os = avlInorder (roomObjectsOf rs) ++ avlInorder (playerInventoryOf ps)
ns1 = filter (elem n . objectNamesOf) os
ns2 = foldr (\a ns -> filter (elem a . objectAttributesOf) ns) ns1 as
case ns2 of
[] -> throwError CantSeeOneError
xs -> case i of
Nothing -> case xs of
[x] -> return x
_ -> throwError WhichOneError
Just idx -> if idx > length xs then throwError CantSeeOneError
else return (xs !! (idx1))