module Game.Antisplice.Lang (act,defVocab) where
import Text.Chatty.Printer
import Text.Chatty.Scanner
import Text.Chatty.Expansion
import Text.Chatty.Extended.Printer
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.Utils.None
import Game.Antisplice.Utils.ListBuilder
import Game.Antisplice.Rooms
import Game.Antisplice.Stats
import Control.Arrow
import Control.Monad.Error
import Text.Printf
import Data.Text (unpack)
import Data.Maybe
import Data.Char
aliases :: [(String,String)]
aliases = strictBuild $ do
lit "l" "look"
lit "n" "go north"
lit "ne" "go northeast"
lit "e" "go east"
lit "se" "go southeast"
lit "s" "go south"
lit "sw" "go southwest"
lit "w" "go west"
lit "nw" "go northwest"
lit "u" "ascend"
lit "d" "descend"
lit "q" "quit"
lit "i" "list inventory"
lit "ex" "list exits"
lit "get" "acquire"
lit "take" "acquire"
lit "show" "list"
lit "sco" "list score"
lit "eq" "list equipment"
defVocab :: TST Token
defVocab = foldr (\(k,v) -> tstInsert k (v k)) none $ strictBuild $ do
lit "quit" Verb
lit "acquire" Verb
lit "drop" Verb
lit "idiot" Noun
lit "first" $ Ordn 1
lit "next" $ Ordn 1
lit "primary" $ Ordn 1
lit "second" $ Ordn 2
lit "third" $ Ordn 3
lit "commit" Verb
lit "suicide" Noun
lit "go" Verb
lit "ascend" Verb
lit "descend" Verb
lit "north" Fixe
lit "south" Fixe
lit "east" Fixe
lit "west" Fixe
lit "northeast" Fixe
lit "northwest" Fixe
lit "southeast" Fixe
lit "southwest" Fixe
lit "at" Prep
lit "on" Prep
lit "enter" Verb
lit "list" Verb
lit "exits" Fixe
lit "inventory" Fixe
lit "score" Fixe
lit "main" Fixe
lit "hand" Fixe
lit "off" Fixe
lit "chest" Fixe
lit "feet" Fixe
lit "wrists" Fixe
lit "waist" Fixe
lit "head" Fixe
lit "legs" Fixe
lit "back" Fixe
lit "hands" Fixe
lit "neck" Fixe
lit "finger" Fixe
lit "left" Fixe
lit "right" Fixe
lit "equipment" Fixe
lit "equip" Verb
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 $ map toLower s
let ss = mergeNouns ts
unless (all isIntellegible ss) $ throwError UnintellegibleError
case ss of
[] -> return ()
(Verb v:_) -> act' ss
(Skilln n:ps) -> do
ste <- totalStereo
case stereoSkillBonus ste n of
Nothing -> throwError CantCastThatNowError
Just t -> runHandler . t =<< do
gao <- liftM getObject' availableObjects
gco <- liftM getObject' carriedObjects
gso <- liftM getObject' seenObjects
let getters = Getters gao gco gso
tmplt = none{paramGettersOf=getters}
case ps of
[] -> return tmplt
[n@Nounc{}] -> return tmplt{paramDirectOf=Just n}
[Prep "at",n@Nounc{}] -> return tmplt{paramAtOf=Just n}
[n1@Nounc{},Prep "at",n2@Nounc{}] -> return tmplt{paramDirectOf=Just n1,paramAtOf=Just n2}
[Prep "on",n@Nounc{}] -> return tmplt{paramOnOf=Just n}
[n1@Nounc{},Prep "on",n2@Nounc{}] -> return tmplt{paramDirectOf=Just n1,paramOnOf=Just n2}
_ -> throwError UnintellegibleError
_ -> throwError VerbMustFirstError
return ()
act' (Verb "quit":[]) = throwError QuitError
act' (Verb "commit":Nounc _ _ "suicide":[]) = do
eprintLn (Vivid Red) "You stab yourself in the chest, finally dying."
throwError QuitError
act' (Verb "enter":n@Nounc{}:[]) = getAvailableObject_ 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,c,n) -> do
b <- pathPrerequisiteOf c
mprint " " >> mprint (show l) >> mprint " -> "
mprint =<< withRoom n getRoomTitle
if not b then mprintLn " (locked)"
else mprintLn ""
act' (Verb "list":Fixe "inventory":[]) = do
ps <- getPlayerState
mprintLn "Your inventory:"
forM_ (avlInorder $ playerInventoryOf ps) $ \os -> mprintLn $ printf " %s" $ unpack $ objectTitleOf os
act' (Verb "list":Fixe "score":[]) = do
[str, agi, sta, int, spi, arm, akp] <- mapM calcStat [Strength, Agility, Stamina, Intelligence, Spirit, Armor, AttackPower]
[hst, gcd] <- mapM calcStat [Haste, CooldownDuration]
mprintLn $ printf "Strength: %5i Agility: %5i" str agi
mprintLn $ printf "Intelligence: %5i Spirit: %5i" int spi
mprintLn $ printf "Stamina: %5i Armor: %5i" sta arm
mprintLn $ printf "Attack power: %5i Haste: %5i" akp hst
mprintLn $ printf "Global cooldown: %5i" gcd
act' (Verb "equip":n@Nounc{}:[]) = do
o <- getCarriedObject_ n >>= equipObject
case o of
Nothing -> noneM
Just o -> modifyPlayerState $ \s -> s{playerInventoryOf=avlInsert o $ playerInventoryOf s}
act' (Verb "equip":n@Nounc{}:Prep "at":ps) = do
k <- case ps of
[Fixe "main",Fixe "hand"] -> return MainHand
[Fixe "off",Fixe "hand"] -> return OffHand
[Fixe "chest"] -> return Chest
[Fixe "feet"] -> return Feet
[Fixe "wrists"] -> return Wrists
[Fixe "waist"] -> return Waist
[Fixe "head"] -> return Head
[Fixe "legs"] -> return Legs
[Fixe "back"] -> return Back
[Fixe "hands"] -> return Hands
[Fixe "neck"] -> return Neck
[Fixe "right",Fixe "finger"] -> return Finger1
[Fixe "left",Fixe "finger"] -> return Finger2
_ -> throwError UnintellegibleError
o <- getCarriedObject_ n >>= equipObjectAt k
case o of
Nothing -> noneM
Just o -> modifyPlayerState $ \s -> s{playerInventoryOf=avlInsert o $ playerInventoryOf s}
act' (Verb "list":Fixe "equipment":[]) =
let pr (Just k) s = mprintLn $ printf "%-15s%s" s $ unpack $ objectTitleOf k
pr Nothing _ = noneM
firstM = runKleisli . first . Kleisli
in mapM_ (firstM getEquipment >=> uncurry pr) $ lazyBuild $ do
lit MainHand "Main hand:"
lit OffHand "Off hand:"
lit Chest "Chest:"
lit Feet "Feet:"
lit Wrists "Wrists:"
lit Waist "Waist:"
lit Head "Head:"
lit Legs "Legs:"
lit Back "Back:"
lit Hands "Hands:"
lit Neck "Neck:"
lit Finger1 "Right finger:"
lit Finger2 "Left finger:"
act' (Verb "acquire":n@Nounc{}:[]) = getSeenObject_ n >>= (acquireObject . objectIdOf)
act' (Verb "drop":n@Nounc{}:[]) = getCarriedObject_ n >>= (dropObject . objectIdOf)
act' _ = throwError UnintellegibleError
getObject :: (MonadError SplErr m) => Token -> [ObjectState] -> SplErr -> m ObjectState
getObject n os err =
case getObject' os n of
NoneFound -> throwError err
TooMany -> throwError WhichOneError
Found x -> return x
getObject' :: [ObjectState] -> Token -> GetterResponse
getObject' os (Nounc as i n) =
let ns1 = filter (elem n . objectNamesOf) os
ns2 = foldr (\a ns -> filter (elem a . objectAttributesOf) ns) ns1 as
in case ns2 of
[] -> NoneFound
xs -> case i of
Nothing -> case xs of
[x] -> Found x
_ -> TooMany
Just idx -> if idx > length xs then NoneFound
else Found (xs !! (idx1))
availableObjects :: (MonadRoom m,MonadPlayer m) => m [ObjectState]
availableObjects = do
rs <- getRoomState
ps <- getPlayerState
return (avlInorder (roomObjectsOf rs) ++ avlInorder (playerInventoryOf ps))
getAvailableObject_ :: (MonadRoom m, MonadError SplErr m, MonadPlayer m) => Token -> m ObjectState
getAvailableObject_ n = do
os <- availableObjects
getObject n os CantSeeOneError
carriedObjects :: MonadPlayer m => m [ObjectState]
carriedObjects = liftM (avlInorder.playerInventoryOf) getPlayerState
getCarriedObject_ :: (MonadPlayer m, MonadError SplErr m) => Token -> m ObjectState
getCarriedObject_ n = do
os <- carriedObjects
getObject n os DontCarryOneError
seenObjects :: MonadRoom m => m [ObjectState]
seenObjects = liftM (avlInorder.roomObjectsOf) getRoomState
getSeenObject_ :: (MonadRoom m, MonadError SplErr m) => Token -> m ObjectState
getSeenObject_ n = do
os <- seenObjects
getObject n os CantSeeOneError