packages feed

antisplice 0.7.0.0 → 0.7.2.0

raw patch · 8 files changed

+326/−50 lines, 8 filesdep +comonad

Dependencies added: comonad

Files

antisplice.cabal view
@@ -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
src/Game/Antisplice/Errors.hs view
@@ -31,6 +31,7 @@             | UnintellegibleError             | VerbMustFirstError             | CantSeeOneError+            | DontCarryOneError             | WhichOneError               | CantWalkThereError deriving Show
src/Game/Antisplice/Lang.hs view
@@ -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
src/Game/Antisplice/Monad/Dungeon.hs view
@@ -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.
src/Game/Antisplice/Prototypes.hs view
@@ -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
src/Game/Antisplice/Rooms.hs view
@@ -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
+ src/Game/Antisplice/Stats.hs view
@@ -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}
src/Game/Antisplice/Terminal/Repl.hs view
@@ -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