diff --git a/antisplice.cabal b/antisplice.cabal --- a/antisplice.cabal +++ b/antisplice.cabal @@ -10,13 +10,13 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.7.0.0 +version: 0.7.2.0 -- A short (one-line) description of the package. synopsis: An engine for text-based dungeons. -- A longer description of the package. --- description: +description: An engine for text-based dungeons. -- The license under which the package is released. license: AGPL-3 @@ -48,7 +48,7 @@ library -- Modules exported by the library. - exposed-modules: Game.Antisplice.Prototypes, Game.Antisplice.Templates, Game.Antisplice.Lang, Game.Antisplice.Monad, Game.Antisplice.Rooms, Game.Antisplice.Errors, Game.Antisplice.Utils.TST, Game.Antisplice.Utils.AVL, Game.Antisplice.Utils.Run, Game.Antisplice.Utils.BST, Game.Antisplice.Utils.Graph, Game.Antisplice.Utils.Counter, Game.Antisplice.Utils.Fail, Game.Antisplice.Monad.Dungeon, Game.Antisplice.Terminal.Repl, Game.Antisplice.Events, Game.Antisplice.Monad.Vocab, Game.Antisplice.Utils.Atoms + exposed-modules: Game.Antisplice.Prototypes, Game.Antisplice.Templates, Game.Antisplice.Lang, Game.Antisplice.Monad, Game.Antisplice.Rooms, Game.Antisplice.Errors, Game.Antisplice.Utils.TST, Game.Antisplice.Utils.AVL, Game.Antisplice.Utils.Run, Game.Antisplice.Utils.BST, Game.Antisplice.Utils.Graph, Game.Antisplice.Utils.Counter, Game.Antisplice.Utils.Fail, Game.Antisplice.Monad.Dungeon, Game.Antisplice.Terminal.Repl, Game.Antisplice.Events, Game.Antisplice.Monad.Vocab, Game.Antisplice.Utils.Atoms, Game.Antisplice.Stats -- Modules included in this library but not exported. -- other-modules: @@ -57,12 +57,10 @@ other-extensions: TemplateHaskell, QuasiQuotes, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances, FlexibleContexts, UndecidableInstances, RankNTypes, TypeFamilies, FunctionalDependencies -- Other library packages from which modules are imported. - build-depends: base >=4.6 && <4.7, chatty >=0.2 && <0.3, text >=0.11 && <0.12, template-haskell >=2.8 && <2.9, mtl >=2.1 && <2.2, transformers >=0.3 && <0.4, haskeline >= 0.7 && < 0.8, time >= 1.4 && < 1.5 + build-depends: base >=4.6 && <4.7, chatty >=0.2 && <0.3, text >=0.11 && <0.12, template-haskell >=2.8 && <2.9, mtl >=2.1 && <2.2, transformers >=0.3 && <0.4, haskeline >= 0.7 && < 0.8, time >= 1.4 && < 1.5, comonad >=4.0 && <4.1 -- Directories containing source files. hs-source-dirs: src -- Base language which the package is written in. default-language: Haskell2010 - - ghc-options: -threaded diff --git a/src/Game/Antisplice/Errors.hs b/src/Game/Antisplice/Errors.hs --- a/src/Game/Antisplice/Errors.hs +++ b/src/Game/Antisplice/Errors.hs @@ -31,6 +31,7 @@ | UnintellegibleError | VerbMustFirstError | CantSeeOneError + | DontCarryOneError | WhichOneError | CantWalkThereError deriving Show diff --git a/src/Game/Antisplice/Lang.hs b/src/Game/Antisplice/Lang.hs --- a/src/Game/Antisplice/Lang.hs +++ b/src/Game/Antisplice/Lang.hs @@ -22,7 +22,7 @@ -} -- | Provides all methods for language intellection. -module Game.Antisplice.Lang (act) where +module Game.Antisplice.Lang (act,defVocab) where import Text.Chatty.Printer import Text.Chatty.Scanner @@ -35,6 +35,7 @@ import Game.Antisplice.Utils.AVL import Game.Antisplice.Utils.TST import Game.Antisplice.Rooms +import Game.Antisplice.Stats import Control.Monad.Error import Text.Printf import Data.Text (unpack) @@ -58,6 +59,7 @@ ("get","acquire"): ("take","acquire"): ("show","list"): + ("sco","list score"): [] defVocab :: TST Token @@ -90,6 +92,7 @@ ("list",Verb): ("exits",Fixe): ("inventory",Fixe): + ("score",Fixe): []) replaceAliases :: [String] -> [String] @@ -142,9 +145,9 @@ 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 "look":Prep "at":n@Nounc{}:[]) = getAvailableObject n >>= objectTriggerOnLookAtOf +act' (Verb "read":n@Nounc{}:[]) = getAvailableObject n >>= objectTriggerOnReadOf +act' (Verb "enter":n@Nounc{}:[]) = getAvailableObject n >>= objectTriggerOnEnterOf act' (Verb "ascend":[]) = changeRoom Up act' (Verb "descend":[]) = changeRoom Down act' (Verb "go":Fixe d:[]) = @@ -169,19 +172,22 @@ 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' (Verb "list":Fixe "score":[]) = do + [str, agi, sta, int, spi, arm, akp] <- mapM calcStat [Strength, Agility, Stamina, Intelligence, Spirit, Armor, AttackPower] + 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" akp +act' (Verb "acquire":n@Nounc{}:[]) = getSeenObject n >>= (acquireObject . objectIdOf) +act' (Verb "drop":n@Nounc{}:[]) = getCarriedObject 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 +getObject :: (MonadError SplErr m) => Token -> [ObjectState] -> SplErr -> m ObjectState +getObject (Nounc as i n) os err = do + let ns1 = filter (elem n . objectNamesOf) os ns2 = foldr (\a ns -> filter (elem a . objectAttributesOf) ns) ns1 as case ns2 of - [] -> throwError CantSeeOneError + [] -> throwError err xs -> case i of Nothing -> case xs of [x] -> return x @@ -189,3 +195,18 @@ Just idx -> if idx > length xs then throwError CantSeeOneError else return (xs !! (idx-1)) +getAvailableObject :: (MonadRoom m, MonadError SplErr m, MonadPlayer m) => Token -> m ObjectState +getAvailableObject n = do + rs <- getRoomState + ps <- getPlayerState + getObject n (avlInorder (roomObjectsOf rs) ++ avlInorder (playerInventoryOf ps)) CantSeeOneError + +getCarriedObject :: (MonadPlayer m, MonadError SplErr m) => Token -> m ObjectState +getCarriedObject n = do + ps <- getPlayerState + getObject n (avlInorder $ playerInventoryOf ps) DontCarryOneError + +getSeenObject :: (MonadRoom m, MonadError SplErr m) => Token -> m ObjectState +getSeenObject n = do + rs <- getRoomState + getObject n (avlInorder $ roomObjectsOf rs) CantSeeOneError diff --git a/src/Game/Antisplice/Monad/Dungeon.hs b/src/Game/Antisplice/Monad/Dungeon.hs --- a/src/Game/Antisplice/Monad/Dungeon.hs +++ b/src/Game/Antisplice/Monad/Dungeon.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, RankNTypes, FlexibleContexts, TypeFamilies #-} +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, RankNTypes, FlexibleContexts, TypeFamilies, DeriveDataTypeable #-} {- This module is part of Antisplice. @@ -22,7 +22,42 @@ -} -- | Provides the basic data types and monads for Antisplice. -module Game.Antisplice.Monad.Dungeon where +module Game.Antisplice.Monad.Dungeon ( + -- * Context quantifiers + DungeonM, + ChattyDungeonM, + Trigger, + TriggerBox (..), + -- * Utilities + IsText (..), + Direction (..), + -- * Rooms + RoomState (..), + RoomT (..), + MonadRoom (..), + -- * Objects + StatKey (..), + EquipKey (..), + Implication (..), + Feature (..), + ObjectId (..), + ObjectState (..), + ObjectT (..), + MonadObject (..), + -- * Factions + Faction (..), + Attitude (..), + -- * Players + PlayerStereo (..), + PlayerState (..), + PlayerT (..), + MonadPlayer (..), + -- * Dungeons + DungeonState (..), + currentRoomOf, + DungeonT (..), + MonadDungeon (..) + ) where import Text.Chatty.Printer import Text.Chatty.Scanner @@ -40,9 +75,11 @@ import Control.Arrow import Control.Monad.Error import Control.Monad.Trans.Class +import Control.Comonad import Data.Text import Control.Monad import Data.Time.Clock +import Data.Typeable -- | Matches any 'MonadDungeon' context type DungeonM a = forall m.(MonadDungeon m) => m a @@ -54,19 +91,19 @@ newtype TriggerBox = TriggerBox { runTrigger :: Trigger } -- | Key for item or player statistics -data StatKey = STR -- ^ Strength - | AGI -- ^ Agility - | STA -- ^ Stamina - | INT -- ^ Intelligence - | SPI -- ^ Spirit - | ARM -- ^ Armor +data StatKey = Strength + | Agility + | Stamina + | Intelligence + | Spirit + | Armor + | AttackPower deriving (Ord,Eq) -- | Key for equipment slot data EquipKey = MainHand | OffHand | Chest | Feet | Wrists | Waist | Head | Legs | Back | Hands | Neck | Finger1 | Finger2 deriving (Ord,Eq) -- | State type for RoomT data RoomState = RoomState { - roomDescOf :: !Text, roomTitleOf :: !Text, roomObjectsOf :: AVL ObjectState, roomTriggerOnFirstEnterOf :: Trigger, @@ -113,8 +150,18 @@ toText = pack fromText = unpack --- | Implications a object infers for its containing room +-- | A faction +data Faction = Faction { + factionName :: !Text, + factionTriggerOnHostileOf :: Trigger, + factionTriggerOnFriendlyOf :: Trigger, + factionTriggerOnExaltedOf :: Trigger + } +data Attitude = Hostile | Friendly | Exalted deriving (Eq,Ord) + +-- | Implications an object infers for its containing room data Implication = DescSeg (Atom String) -- ^ An additional particle for the room description (e.g. saying that XYZ is there). + | StereoSeg (Atom PlayerStereo) -- ^ An additional stereotype for the near/carrying/wearing player -- | Object features. data Feature = Damagable -- ^ May take damage. @@ -124,7 +171,7 @@ deriving (Ord,Eq) -- | Phantom ID type for objects. -newtype ObjectId = ObjectId Int deriving (Eq,Ord) +data ObjectId = ObjectId Int | FalseObject deriving (Eq,Ord) -- | State type for ObjectT data ObjectState = ObjectState { @@ -142,7 +189,10 @@ objectStatsOf :: AVL (StatKey,Int), objectRouteOf :: ![NodeId], objectFeaturesOf :: AVL (Feature,()), - objectImplicationsOf :: [Implication], + objectNearImplicationsOf :: [Implication], + objectCarryImplicationsOf :: [Implication], + objectWearImplicationsOf :: [Implication], + objectFactionOf :: !(Maybe (Atom Faction)), objectTriggerOnFirstSightOf :: Trigger, objectTriggerOnEachSightOf :: Trigger, objectTriggerOnFirstAcquireOf :: Trigger, @@ -160,7 +210,7 @@ objectTriggerOnFirstEquipOf :: Trigger, objectTriggerOnEachEquipOf :: Trigger, objectTriggerOnUnequipOf :: Trigger - } + } deriving Typeable instance Indexable ObjectState ObjectId ObjectState where type IndexOf ObjectState = ObjectId @@ -192,6 +242,11 @@ getObjectState = Object $ \s -> return (s,s) putObjectState s = Object $ \_ -> return ((),s) +-- | A player stereotype +data PlayerStereo = PlayerStereo { + stereoCalcStatBonus :: (StatKey -> Int) -> StatKey -> Int + } deriving Typeable + -- | State type for PlayerT data PlayerState = PlayerState { playerRoomOf :: !NodeId, @@ -199,7 +254,9 @@ playerCurHealthOf :: !Int, playerInventoryOf :: AVL ObjectState, playerEquipOf :: AVL (EquipKey,ObjectState), - playerBaseStatsOf :: AVL (StatKey,Int) + playerBaseStatsOf :: AVL (StatKey,Int), + playerStereosOf :: [Atom PlayerStereo], + playerReputationOf :: AVL (Atom Faction,Int) } -- | The player monad. Used to create or modify players. diff --git a/src/Game/Antisplice/Prototypes.hs b/src/Game/Antisplice/Prototypes.hs --- a/src/Game/Antisplice/Prototypes.hs +++ b/src/Game/Antisplice/Prototypes.hs @@ -41,16 +41,17 @@ import Game.Antisplice.Errors import Text.Printf import Data.Text (pack,unpack) +import Data.List -- | Construct a simple room from a title and a description. -ctorRoom :: Monad m => String -> String -> RoomT m () +ctorRoom :: MonadAtoms m => String -> String -> RoomT m () ctorRoom t d = do setRoomTitle t - setRoomDesc d + addRoomDesc d onAnnounce $ getRoomTitle >>= eprintLn (Dull Magenta) onLook $ do - getRoomDesc >>= expand >>= eprintLn (Dull Green) rs <- getRoomState + eprintLn (Dull Green) =<< expand =<< getRoomDesc sequence_ $ avlInorder $ flip fmap (roomObjectsOf rs) $ \os -> objectTriggerOnAnnounceOf os -- | Construct a sign from a text and some attributes. @@ -122,3 +123,7 @@ forM_ as $ uncurry insertVocab . (,Adj) onLook $ mprintLn d setObjectIsAcquirable True + +-- | Add a room descriptor object to the current room +addRoomDesc :: MonadAtoms m => String -> RoomT m ObjectId +addRoomDesc = addRoomObject . addDescSeg diff --git a/src/Game/Antisplice/Rooms.hs b/src/Game/Antisplice/Rooms.hs --- a/src/Game/Antisplice/Rooms.hs +++ b/src/Game/Antisplice/Rooms.hs @@ -22,7 +22,63 @@ -} -- | A huge pile of utility functions for building our dungeon. -module Game.Antisplice.Rooms where +module Game.Antisplice.Rooms ( + -- * Room modification + modifyRoomState, + getRoomDesc, + --setRoomDesc, + getRoomTitle, + setRoomTitle, + markRoom, + -- * Moving around + enterRoom, + reenterCurrentRoom, + enterAndAnnounce, + changeRoom, + -- * Room construction + constructRoom, + establishWay, + addRoomObject, + removeRoomObject, + insertRoomObject, + -- * Object construction + modifyObjectState, + setObjectDesc, + setObjectTitle, + addObjectName, + addObjectAttr, + setObjectIsMob, + setObjectIsAcquirable, + addNearImplication, + addCarryImplication, + addWearImplication, + addDescSeg, + -- * Object forms + registerForm, + instanciateForm, + -- * Object investigation + getObjectTitle, + getObjectDesc, + getObjectNames, + matchObjectName, + getObjectIsMob, + getObjectIsAcquirable, + roomOfObject, + -- * Object actions + setMobRoute, + continueMobRoute, + -- * Scheduling + schedule, + -- * Players + subscribePlayer, + modifyPlayerState, + setPlayerRoom, + acquireObject, + dropObject, + -- * Masquerades + withRoom, + guardVisible + ) where import Text.Chatty.Printer import Text.Chatty.Scanner @@ -33,12 +89,14 @@ import Game.Antisplice.Utils.Graph import Game.Antisplice.Utils.Counter import Game.Antisplice.Utils.AVL +import Game.Antisplice.Utils.Atoms import Game.Antisplice.Errors import Control.Monad import Control.Monad.Error import Control.Monad.Trans.Class import Data.Text (pack) import Data.Maybe +import Data.List import Data.Time.Clock import Text.Printf @@ -49,10 +107,14 @@ putRoomState (f s) -- | Get the current room's description -getRoomDesc :: (MonadRoom m,IsText t) => m t +getRoomDesc :: (MonadRoom m,MonadAtoms m) => m String getRoomDesc = do s <- getRoomState - return (fromText $ roomDescOf s) + --return (fromText $ roomDescOf s) + let descseg (DescSeg a) = getAtom a + descseg _ = return [] + is <- mapM descseg $ concatMap objectNearImplicationsOf $ avlInorder $ roomObjectsOf s + return $ concat $ intersperse " " is -- | Get the current room's title getRoomTitle :: (MonadRoom m,IsText t) => m t @@ -60,9 +122,9 @@ s <- getRoomState return (fromText $ roomTitleOf s) --- | Set the current room's description +{- | Set the current room's description setRoomDesc :: (MonadRoom m,IsText t) => t -> m () -setRoomDesc t = modifyRoomState $ \s -> s{roomDescOf=toText t} +setRoomDesc t = modifyRoomState $ \s -> s{roomDescOf=toText t}-} -- | Set the current room's title setRoomTitle :: (MonadRoom m,IsText t) => t -> m () @@ -112,7 +174,7 @@ -- | Construct a new room using the room monad. constructRoom :: (Monad m,MonadDungeon (t m),MonadTrans t) => RoomT m a -> t m NodeId constructRoom m = do - (_,rs) <- lift $ runRoomT m $ RoomState (pack "") (pack "") EmptyAVL (return ()) (return ()) (return ()) (return ()) (return ()) + (_,rs) <- lift $ runRoomT m $ RoomState (pack "") EmptyAVL (return ()) (return ()) (return ()) (return ()) (return ()) s <- getDungeonState let (nid,g) = addNode' rs $ roomsOf s s' = if isNothing $ currentRoomOf s then s{roomsOf=g,playerOf=fmap (\p -> p{playerRoomOf=nid}) $ playerOf s} else s{roomsOf=g} @@ -145,17 +207,25 @@ Nothing -> throwError CantWalkThereError -- | Add a new object to the current room. It is contructed using the object monad. -addRoomObject :: (Monad m,MonadCounter (t m),MonadRoom (t m),MonadTrans t) => ObjectT m a -> t m ObjectId +addRoomObject :: (MonadCounter m,MonadRoom m) => ObjectT m a -> m ObjectId addRoomObject m = do i <- countOn - (_,o) <- lift $ runObjectT m $ ObjectState - (ObjectId i) -- id + o <- constructObject m + insertRoomObject o{objectIdOf=ObjectId i} + return $ ObjectId i + +-- | Construct a room object (but don't add it) +constructObject :: Monad m => ObjectT m a -> m ObjectState +constructObject m = do + (_,o) <- runObjectT m $ ObjectState + FalseObject -- id (pack "Something") -- title (pack "I don't know what this is.") -- desc [] [] False False False False -- names, attr, 1seen?, 1acq?, 1insp?, 1eq? 100 100 -- maxhp, curhp EmptyAVL [] -- stats, route - EmptyAVL [] -- feat, impl + EmptyAVL [] [] [] -- feat, impl (n,i,w) + Nothing -- faction (return ()) -- on 1 sight (return ()) -- on sight (return ()) -- on 1 acq @@ -173,8 +243,7 @@ (return ()) -- on 1 eq (return ()) -- on eq (return ()) -- on uneq - insertRoomObject o - return $ ObjectId i + return o -- | Remove an object from the current room and return its state. removeRoomObject :: MonadRoom m => ObjectId -> m ObjectState @@ -214,7 +283,7 @@ setObjectDesc :: (MonadObject m,IsText t) => t -> m () setObjectDesc t = modifyObjectState $ \s -> s{objectDescOf=toText t} --- | Get the object's description +-- | Get the object's names getObjectNames :: MonadObject m => m [String] getObjectNames = do s <- getObjectState @@ -238,7 +307,7 @@ subscribePlayer :: (MonadDungeon (t m),MonadTrans t,Monad m) => PlayerT m a -> t m () subscribePlayer m = do s <- getDungeonState - (_,a) <- lift $ runPlayerT m $ PlayerState (rootNode $ roomsOf s) 100 100 EmptyAVL EmptyAVL EmptyAVL + (_,a) <- lift $ runPlayerT m $ PlayerState (rootNode $ roomsOf s) 100 100 EmptyAVL EmptyAVL EmptyAVL [] EmptyAVL putDungeonState s{playerOf=Just a} -- | Modify the player state @@ -327,3 +396,38 @@ let Just o = avlLookup i $ playerInventoryOf ps putPlayerState ps{playerInventoryOf=avlRemove i $ playerInventoryOf ps} insertRoomObject o + +-- | Add an implication to the current object that is valid for all players in the room +addNearImplication :: MonadObject m => Implication -> m () +addNearImplication i = modifyObjectState $ \o -> o{objectNearImplicationsOf=i:objectNearImplicationsOf o} + +-- | Add an implication to the current object that is valid for all carrying players +addCarryImplication :: MonadObject m => Implication -> m () +addCarryImplication i = modifyObjectState $ \o -> o{objectCarryImplicationsOf=i:objectCarryImplicationsOf o} + +-- | Add an implication to the current object that is valid for all wearing players +addWearImplication :: MonadObject m => Implication -> m () +addWearImplication i = modifyObjectState $ \o -> o{objectWearImplicationsOf=i:objectWearImplicationsOf o} + +-- | Add a room description segment to the current object +addDescSeg :: (MonadObject m,MonadAtoms m) => String -> m () +addDescSeg s = do + a <- newAtom + putAtom a s + addNearImplication $ DescSeg a + +-- | Register an object form and return its atom +registerForm :: (MonadAtoms m) => ObjectT m () -> m (Atom ObjectState) +registerForm m = do + a <- newAtom + o <- constructObject m + putAtom a o + return a + +-- | Instanciate a registered form +instanciateForm :: (MonadAtoms m,MonadRoom m,MonadCounter m) => Atom ObjectState -> m ObjectId +instanciateForm a = do + i <- countOn + o <- getAtom a + insertRoomObject o{objectIdOf=ObjectId i} + return $ ObjectId i diff --git a/src/Game/Antisplice/Stats.hs b/src/Game/Antisplice/Stats.hs new file mode 100644 --- /dev/null +++ b/src/Game/Antisplice/Stats.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} + +-- | Provides utility functions for dealing with stats and stereotypes +module Game.Antisplice.Stats where + +import Control.Monad +import Control.Monad.Identity +import Game.Antisplice.Monad.Dungeon +import Game.Antisplice.Rooms +import Game.Antisplice.Utils.AVL +import Game.Antisplice.Utils.Atoms +import Text.Chatty.Printer + +-- | Typeclass for every pure data that saves stats +class HasStats s where + -- | Set the given key to the given value + setStat :: StatKey -> Int -> s -> s + -- | Lookup the given key + getStat :: StatKey -> s -> Int + +-- | Typeclass for every monad that saves stats +class HasStatsM m where + -- | Set the given key to the given value + setStatM :: StatKey -> Int -> m () + -- | Lookup the given key + getStatM :: StatKey -> m Int + +instance HasStats ObjectState where + setStat k v o = o{objectStatsOf=avlInsert (k,v) $ objectStatsOf o} + getStat k o = case avlLookup k $ objectStatsOf o of + Nothing -> 0 + Just v -> v + +instance Monad m => HasStatsM (ObjectT m) where + setStatM k v = modifyObjectState $ setStat k v + getStatM k = (return . getStat k) =<< getObjectState + +instance HasStats PlayerState where + setStat k v p = p{playerBaseStatsOf=avlInsert (k,v) $ playerBaseStatsOf p} + getStat k p = case avlLookup k $ playerBaseStatsOf p of + Nothing -> 0 + Just v -> v + +instance Monad m => HasStatsM (PlayerT m) where + setStatM k v = modifyPlayerState $ setStat k v + getStatM k = (return . getStat k) =<< getPlayerState + +-- | Sum the stats of the objects the player carries (ignoring base stats and boni) +sumStat :: MonadPlayer m => StatKey -> m Int +sumStat k = do + s <- getPlayerState + let is = map (getStat k) $ avlInorder $ playerInventoryOf s + let es = map (getStat k.snd) $ avlInorder $ playerEquipOf s + return (sum is + sum es + getStat k s) + +-- | Calculates the stats of the objects the player carries +calcStat :: (Functor m,MonadPlayer m,MonadAtoms m,MonadRoom m,MonadPrinter m) => StatKey -> m Int +calcStat k = do + p <- getPlayerState + r <- getRoomState + let ss k = fst $ runIdentity $ runPlayerT (sumStat k) p + steseg (StereoSeg a) = [a] + steseg _ = [] + rsegs = map steseg $ concatMap objectNearImplicationsOf $ avlInorder $ roomObjectsOf r + isegs = map steseg $ concatMap objectCarryImplicationsOf $ avlInorder $ playerInventoryOf p + --wsegs = map steseg $ concatMap objectWearImplicationOf $ avlInorder + stes <- fmap (map stereoCalcStatBonus) $ mapM getAtom (concat rsegs ++ concat isegs ++ playerStereosOf p) + return $ foldr (\f g k -> f g k + g k) ss stes k + +-- | Default stereotype. +defaultStereo = PlayerStereo $ + \get k -> case k of + AttackPower -> get Strength * 2 + _ -> 0 + +-- | Register the given stereotype and return its atom. +registerStereo :: MonadAtoms m => PlayerStereo -> m (Atom PlayerStereo) +registerStereo s = do + a <- newAtom + putAtom a s + return a + +-- | Add the given stereotype to the current player. +addStereo :: MonadPlayer m => Atom PlayerStereo -> m () +addStereo a = modifyPlayerState $ \p -> p{playerStereosOf=a:playerStereosOf p} + +-- | Remove one stereotype and add another +replaceStereo :: MonadPlayer m => Atom PlayerStereo -> Atom PlayerStereo -> m () +replaceStereo rem ins = modifyPlayerState $ \p -> p{playerStereosOf=map (\a -> if a == rem then ins else a) $ playerStereosOf p} diff --git a/src/Game/Antisplice/Terminal/Repl.hs b/src/Game/Antisplice/Terminal/Repl.hs --- a/src/Game/Antisplice/Terminal/Repl.hs +++ b/src/Game/Antisplice/Terminal/Repl.hs @@ -77,6 +77,7 @@ Left CantWalkThereError -> mprintLn "I can't walk there." Left WhichOneError -> mprintLn "Which one do you mean?" Left CantSeeOneError -> mprintLn "I can't see one here." + Left DontCarryOneError -> mprintLn "You don't carry one." Left e -> throwError e throwError DoneError Just Nothing -> liftIO (killThread thr) >> mprintLn "quit" >> throwError QuitError