antisplice 0.8.0.1 → 0.11.0.3
raw patch · 22 files changed
+1143/−233 lines, 22 filesdep ~chatty
Dependency ranges changed: chatty
Files
- antisplice.cabal +3/−3
- src/Game/Antisplice.hs +10/−1
- src/Game/Antisplice/Action.hs +149/−0
- src/Game/Antisplice/Errors.hs +13/−11
- src/Game/Antisplice/Events.hs +31/−31
- src/Game/Antisplice/Lang.hs +54/−9
- src/Game/Antisplice/Monad.hs +5/−1
- src/Game/Antisplice/Monad/Dungeon.hs +121/−47
- src/Game/Antisplice/Monad/Vocab.hs +1/−0
- src/Game/Antisplice/Paths.hs +103/−0
- src/Game/Antisplice/Prototypes.hs +1/−1
- src/Game/Antisplice/Rooms.hs +167/−43
- src/Game/Antisplice/SingleUser.hs +6/−1
- src/Game/Antisplice/Skills.hs +202/−0
- src/Game/Antisplice/Stats.hs +50/−46
- src/Game/Antisplice/Stereos.hs +157/−0
- src/Game/Antisplice/Templates.hs +1/−1
- src/Game/Antisplice/Terminal/Repl.hs +12/−8
- src/Game/Antisplice/Utils/BST.hs +12/−0
- src/Game/Antisplice/Utils/Focus.hs +1/−1
- src/Game/Antisplice/Utils/Graph.hs +35/−29
- src/Game/Antisplice/Utils/None.hs +9/−0
antisplice.cabal view
@@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.8.0.1+version: 0.11.0.3 -- A short (one-line) description of the package. synopsis: An engine for text-based dungeons.@@ -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, Game.Antisplice.Stats, Game.Antisplice.Utils.None, Game.Antisplice.Utils.Focus, Game.Antisplice.SingleUser, Game.Antisplice+ 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, Game.Antisplice.Utils.None, Game.Antisplice.Utils.Focus, Game.Antisplice.SingleUser, Game.Antisplice, Game.Antisplice.Skills, Game.Antisplice.Stereos, Game.Antisplice.Paths, Game.Antisplice.Action -- Modules included in this library but not exported. -- other-modules: @@ -57,7 +57,7 @@ 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.3 && <0.4, 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 -- Directories containing source files. hs-source-dirs: src
src/Game/Antisplice.hs view
@@ -35,17 +35,22 @@ module Game.Antisplice.Utils.Counter, module Game.Antisplice.Rooms, module Game.Antisplice.Stats,+ module Game.Antisplice.Stereos,+ module Game.Antisplice.Skills, module Game.Antisplice.Prototypes, module Game.Antisplice.Lang, module Game.Antisplice.Errors, module Game.Antisplice.Terminal.Repl, module Game.Antisplice.Events,+ module Game.Antisplice.Paths,+ module Game.Antisplice.Action, -- * Type abbreviations Constructor) where import Text.Chatty.Printer import Text.Chatty.Scanner import Text.Chatty.Expansion+import Text.Chatty.Expansion.Vars import Text.Chatty.Extended.Printer import System.Chatty.Misc import Game.Antisplice.Monad@@ -58,12 +63,16 @@ import Game.Antisplice.Utils.Counter import Game.Antisplice.Rooms import Game.Antisplice.Stats+import Game.Antisplice.Stereos+import Game.Antisplice.Skills import Game.Antisplice.Prototypes import Game.Antisplice.Lang import Game.Antisplice.Errors import Game.Antisplice.Terminal.Repl import Game.Antisplice.Events+import Game.Antisplice.Action+import Game.Antisplice.Paths import Control.Monad.Error.Class -- | A dungeon constructor function-type Constructor = forall m.(Functor m,ExtendedPrinter m,MonadExpand m,ExpanderEnv m,MonadScanner m,MonadAtoms m,MonadClock m,MonadVocab m,MonadError SplErr m) => DungeonT m ()+type Constructor = forall m.(Functor m,ExtendedPrinter m,MonadExpand m,ExpanderEnv m,MonadAtoms m,MonadClock m,MonadVocab m,MonadError SplErr m,MonadDungeon m) => m ()
+ src/Game/Antisplice/Action.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE RankNTypes, FlexibleContexts #-}++{-+ This module is part of Antisplice.+ Copyleft (c) 2014 Marvin Cohrs++ All wrongs reversed. Sharing is an act of love, not crime.+ Please share Antisplice with everyone you like.++ Antisplice is free software: you can redistribute it and/or modify+ it under the terms of the GNU Affero General Public License as published by+ the Free Software Foundation, either version 3 of the License, or+ (at your option) any later version.++ Antisplice is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU Affero General Public License for more details.++ You should have received a copy of the GNU Affero General Public License+ along with Antisplice. If not, see <http://www.gnu.org/licenses/>.+-}++-- | Provides brick-by-brick composition for general actions, which may be used for skills and gates.+module Game.Antisplice.Action where++import Control.Monad+import Data.Monoid+import Game.Antisplice.Monad.Dungeon+import Game.Antisplice.Rooms+import Game.Antisplice.Stats+import Game.Antisplice.Utils.Counter+import Game.Antisplice.Utils.None++-- | A typeclass for all action types carrying an execution condition.+class IsAction a where+ -- | Conjunction _with_ short evaluation.+ infixl 6 #&&+ (#&&) :: a -> a -> a+ -- | Disjunction _with_ short evaulation.+ infixl 6 #||+ (#||) :: a -> a -> a+ -- | Conjunction _without_ short evaluation.+ infixl 6 !&&+ (!&&) :: a -> a -> a+ -- | Disjunction _without_ short evaluation.+ infixl 6 !||+ (!||) :: a -> a -> a++instance Monoid PrerequisiteBox where+ mempty = none+ p `mappend` q = Prerequisite $ do+ a <- runPrerequisite p+ b <- runPrerequisite q+ return (a && b)++instance IsAction PrerequisiteBox where+ p #&& q = Prerequisite $ do+ a <- runPrerequisite p+ if a then runPrerequisite q+ else return False+ p #|| q = Prerequisite $ do+ a <- runPrerequisite p+ if a then return True+ else runPrerequisite q+ p !&& q = p <> q+ p !|| q = Prerequisite $ do+ a <- runPrerequisite p+ b <- runPrerequisite q+ return (a || b)++-- | A general action, which may be used for skills and gates.+data Action = Action { askAction :: Prerequisite, runAction :: Handler }++instance None Action where+ none = Action (return True) noneM++instance Monoid Action where+ mempty = none+ a `mappend` b = Action (runPrerequisite $ Prerequisite (askAction a) <> Prerequisite (askAction b)) (runAction a >> runAction b)++instance IsAction Action where+ a #&& b = Action+ (runPrerequisite $ Prerequisite (askAction a) #&& Prerequisite (askAction b))+ (runAction a >> runAction b)+ a #|| b = Action+ (runPrerequisite $ Prerequisite (askAction a) #|| Prerequisite (askAction b))+ (askAction a >>= \q -> if q then runAction a else runAction b)+ a !&& b = a <> b+ a !|| b = Action+ (runPrerequisite $ Prerequisite (askAction a) !|| Prerequisite (askAction b))+ (askAction a >>= \q -> askAction b >> if q then runAction a else runAction b)++-- | An action that is run /after/ a specific event.+newtype ActionAfter = ActionAfter { runActionAfter :: Action }+-- | An action that is run /before/ a specific event.+newtype ActionBefore = ActionBefore { runActionBefore :: Action }++instance None ActionAfter where+ none = ActionAfter none+instance None ActionBefore where+ none = ActionBefore none++instance Monoid ActionAfter where+ mempty = none+ a `mappend` b = ActionAfter $ runActionAfter a <> runActionAfter b+instance Monoid ActionBefore where+ mempty = none+ a `mappend` b = ActionBefore $ runActionBefore a <> runActionBefore b++instance IsAction ActionAfter where+ a #&& b = ActionAfter $ runActionAfter a #&& runActionAfter b+ a #|| b = ActionAfter $ runActionAfter a #|| runActionAfter b+ a !&& b = ActionAfter $ runActionAfter a !&& runActionAfter b+ a !|| b = ActionAfter $ runActionAfter a !|| runActionAfter b+instance IsAction ActionBefore where+ a #&& b = ActionBefore $ runActionBefore a #&& runActionBefore b+ a #|| b = ActionBefore $ runActionBefore a #|| runActionBefore b+ a !&& b = ActionBefore $ runActionBefore a !&& runActionBefore b+ a !|| b = ActionBefore $ runActionBefore a !|| runActionBefore b++-- | Use for actions that consume a given currency.+consumeCurrencyA :: CurrencyId -> Int -> Action+consumeCurrencyA c h = Action+ (do+ c1 <- getCurrency c+ return (c1 > h))+ (modifyCurrency c (subtract h))++-- | Deal damage to opponent+dealDamageA :: ChattyDungeonM Int -> Action+dealDamageA m = Action (return True) (dealDamage =<< m)++-- | Use for actions that require a cooldown time.+implyCooldownA :: MonadCounter m => Integer -> m Action+implyCooldownA ms = do+ cid <- liftM CooldownId countOn+ return (Action+ (liftM not $ getCooldown cid)+ (setCooldown cid True >> schedule ms (setCooldown cid False)))++-- | Use for actions that suffer from global cooldown.+implyGlobalCooldownA :: Action+implyGlobalCooldownA = Action+ (liftM not $ getCooldown GlobalCooldown)+ (do+ setCooldown GlobalCooldown True+ cd <- calcStat CooldownDuration+ schedule (fromIntegral cd) $ setCooldown GlobalCooldown False)
src/Game/Antisplice/Errors.hs view
@@ -26,17 +26,19 @@ -- | Antisplice errors data SplErr = UnknownError- | QuitError- | DoneError - | UnintellegibleError- | VerbMustFirstError- | CantSeeOneError- | DontCarryOneError- | WhichOneError- | CantEquipThatError- | CantEquipThatThereError- | WhereToEquipError- | CantWalkThereError deriving Show+ | QuitError -- ^ Triggers program termination+ | DoneError -- ^ Escape the waiter loop+ | UnintellegibleError -- ^ "I don't understand that."+ | VerbMustFirstError -- ^ "Please start with a verb."+ | CantSeeOneError -- ^ "I can't see one here."+ | DontCarryOneError -- ^ "You don't carry one."+ | WhichOneError -- ^ "Which one do you mean?"+ | CantEquipThatError -- ^ "I can't equip that."+ | CantEquipThatThereError -- ^ "I can't wear that there. You might want to try some other place?"+ | WhereToEquipError -- ^ "Where?"+ | CantCastThatNowError -- ^ "Sorry, I can't cast that now. Check you health, mana and cooldowns."+ | CantWalkThereError -- ^ "I can't walk there."+ deriving Show -- | Alias for 'FailT' 'SplErr' type SplErrT m = FailT SplErr m
src/Game/Antisplice/Events.hs view
@@ -31,112 +31,112 @@ import Game.Antisplice.Rooms import Game.Antisplice.Monad.Dungeon -roomOnFirstEnter :: MonadRoom m => Trigger -> m ()+roomOnFirstEnter :: MonadRoom m => Handler -> m () roomOnFirstEnter t = modifyRoomState $ \s -> s{roomTriggerOnFirstEnterOf=t} -roomOnEachEnter :: MonadRoom m => Trigger -> m ()+roomOnEachEnter :: MonadRoom m => Handler -> m () roomOnEachEnter t = modifyRoomState $ \s -> s{roomTriggerOnEachEnterOf=t} -roomOnLook :: MonadRoom m => Trigger -> m ()+roomOnLook :: MonadRoom m => Handler -> m () roomOnLook t = modifyRoomState $ \s -> s{roomTriggerOnLookOf=t} -roomOnAnnounce :: MonadRoom m => Trigger -> m ()+roomOnAnnounce :: MonadRoom m => Handler -> m () roomOnAnnounce t = modifyRoomState $ \s -> s{roomTriggerOnAnnounceOf=t} -objectOnFirstSight :: MonadObject m => Trigger -> m ()+objectOnFirstSight :: MonadObject m => Handler -> m () objectOnFirstSight t = modifyObjectState $ \s -> s{objectTriggerOnFirstSightOf=t} -objectOnEachSight :: MonadObject m => Trigger -> m ()+objectOnEachSight :: MonadObject m => Handler -> m () objectOnEachSight t = modifyObjectState $ \s -> s{objectTriggerOnEachSightOf=t} -objectOnFirstAcquire :: MonadObject m => Trigger -> m ()+objectOnFirstAcquire :: MonadObject m => Handler -> m () objectOnFirstAcquire t = modifyObjectState $ \s -> s{objectTriggerOnFirstAcquireOf=t} -objectOnEachAcquire :: MonadObject m => Trigger -> m ()+objectOnEachAcquire :: MonadObject m => Handler -> m () objectOnEachAcquire t = modifyObjectState $ \s -> s{objectTriggerOnEachAcquireOf=t} -objectOnFirstInspection :: MonadObject m => Trigger -> m ()+objectOnFirstInspection :: MonadObject m => Handler -> m () objectOnFirstInspection t = modifyObjectState $ \s -> s{objectTriggerOnFirstInspectionOf=t} -objectOnEachInspection :: MonadObject m => Trigger -> m ()+objectOnEachInspection :: MonadObject m => Handler -> m () objectOnEachInspection t = modifyObjectState $ \s -> s{objectTriggerOnEachInspectionOf=t} -objectOnLookAt :: MonadObject m => Trigger -> m ()+objectOnLookAt :: MonadObject m => Handler -> m () objectOnLookAt t = modifyObjectState $ \s -> s{objectTriggerOnLookAtOf=t} -objectOnLookInto :: MonadObject m => Trigger -> m ()+objectOnLookInto :: MonadObject m => Handler -> m () objectOnLookInto t = modifyObjectState $ \s -> s{objectTriggerOnLookIntoOf=t} -objectOnRead :: MonadObject m => Trigger -> m ()+objectOnRead :: MonadObject m => Handler -> m () objectOnRead t = modifyObjectState $ \s -> s{objectTriggerOnReadOf=t} -objectOnEnter :: MonadObject m => Trigger -> m ()+objectOnEnter :: MonadObject m => Handler -> m () objectOnEnter t = modifyObjectState $ \s -> s{objectTriggerOnEnterOf=t} -objectOnRoomEnter :: MonadObject m => Trigger -> m ()+objectOnRoomEnter :: MonadObject m => Handler -> m () objectOnRoomEnter t = modifyObjectState $ \s -> s{objectTriggerOnRoomEnterOf=t} -objectOnRoomLeave :: MonadObject m => Trigger -> m ()+objectOnRoomLeave :: MonadObject m => Handler -> m () objectOnRoomLeave t = modifyObjectState $ \s -> s{objectTriggerOnRoomLeaveOf=t} -objectOnAnnounce :: MonadObject m => Trigger -> m ()+objectOnAnnounce :: MonadObject m => Handler -> m () objectOnAnnounce t = modifyObjectState $ \s -> s{objectTriggerOnAnnounceOf=t} -- | Triggered when the user enters a room or object.-class OnEnter e where onEnter :: Trigger -> e ()+class OnEnter e where onEnter :: Handler -> e () instance Monad m => OnEnter (RoomT m) where onEnter = roomOnEachEnter instance Monad m => OnEnter (ObjectT m) where onEnter = objectOnEnter -- | Triggered when the user enters a room the first time.-class OnFirstEnter e where onFirstEnter :: Trigger -> e ()+class OnFirstEnter e where onFirstEnter :: Handler -> e () instance Monad m => OnFirstEnter (RoomT m) where onFirstEnter = roomOnFirstEnter -- | Triggered when the user looks around or looks at a specific object.-class OnLook e where onLook :: Trigger -> e ()+class OnLook e where onLook :: Handler -> e () instance Monad m => OnLook (RoomT m) where onLook = roomOnLook instance Monad m => OnLook (ObjectT m) where onLook = objectOnLookAt -- | Triggered when the user looks into a specific object.-class OnLookInto e where onLookInto :: Trigger -> e ()+class OnLookInto e where onLookInto :: Handler -> e () instance Monad m => OnLookInto (ObjectT m) where onLookInto = objectOnLookInto -- | Triggered when (a) the room is announced (e.g. when entered), (b) the user looks around in the room containing the object.-class OnAnnounce e where onAnnounce :: Trigger -> e ()+class OnAnnounce e where onAnnounce :: Handler -> e () instance Monad m => OnAnnounce (RoomT m) where onAnnounce = roomOnAnnounce instance Monad m => OnAnnounce (ObjectT m) where onAnnounce = objectOnAnnounce -- | Triggered when the user sees the object (e.g. he enters its room).-class OnSight e where onSight :: Trigger -> e ()+class OnSight e where onSight :: Handler -> e () instance Monad m => OnSight (ObjectT m) where onSight = objectOnEachSight -- | Triggered when the user sees the object the first time.-class OnFirstSight e where onFirstSight :: Trigger -> e ()+class OnFirstSight e where onFirstSight :: Handler -> e () instance Monad m => OnFirstSight (ObjectT m) where onFirstSight = objectOnFirstSight -- | Triggered when the user acquires the object.-class OnAcquire e where onAcquire :: Trigger -> e ()+class OnAcquire e where onAcquire :: Handler -> e () instance Monad m => OnAcquire (ObjectT m) where onAcquire = objectOnEachAcquire -- | Triggered when the user acquires the object the first time.-class OnFirstAcquire e where onFirstAcquire :: Trigger -> e ()+class OnFirstAcquire e where onFirstAcquire :: Handler -> e () instance Monad m => OnFirstAcquire (ObjectT m) where onFirstAcquire = objectOnFirstAcquire -- | Triggered when the user inspects the object (looks at/into it, listens to it, ...)-class OnInspection e where onInspection :: Trigger -> e ()+class OnInspection e where onInspection :: Handler -> e () instance Monad m => OnInspection (ObjectT m) where onInspection = objectOnEachInspection -- | Triggered when the user inspects the object the first time.-class OnFirstInspection e where onFirstInspection :: Trigger -> e ()+class OnFirstInspection e where onFirstInspection :: Handler -> e () instance Monad m => OnFirstInspection (ObjectT m) where onFirstInspection = objectOnFirstInspection -- | Triggered when the user reads the object.-class OnRead e where onRead :: Trigger -> e ()+class OnRead e where onRead :: Handler -> e () instance Monad m => OnRead (ObjectT m) where onRead = objectOnRead -- | Triggered when the object (e.g. a mob with a route) enters the room of the user.-class OnRoomEnter e where onRoomEnter :: Trigger -> e ()+class OnRoomEnter e where onRoomEnter :: Handler -> e () instance Monad m => OnRoomEnter (ObjectT m) where onRoomEnter = objectOnRoomEnter -- | Triggered when the object (e.g. a mob with a route) leaves the room of the user.-class OnRoomLeave e where onRoomLeave :: Trigger -> e ()+class OnRoomLeave e where onRoomLeave :: Handler -> e () instance Monad m => OnRoomLeave (ObjectT m) where onRoomLeave = objectOnRoomLeave
src/Game/Antisplice/Lang.hs view
@@ -39,9 +39,11 @@ 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 aliases :: [(String,String)] aliases = strictBuild $ do@@ -66,10 +68,8 @@ lit "eq" "list equipment" defVocab :: TST Token-defVocab = foldr (\(k,v) -> tstInsert k (v k)) EmptyTST $ strictBuild $ do- lit "look" Verb+defVocab = foldr (\(k,v) -> tstInsert k (v k)) none $ strictBuild $ do lit "quit" Verb- lit "read" Verb lit "acquire" Verb lit "drop" Verb lit "idiot" Noun@@ -92,6 +92,7 @@ lit "southeast" Fixe lit "southwest" Fixe lit "at" Prep+ lit "on" Prep lit "enter" Verb lit "list" Verb lit "exits" Fixe@@ -160,6 +161,30 @@ 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 =<<+ case ps of+ [] -> return none+ [n@Nounc{}] -> do+ o <- getAvailableObject n+ return none{paramDirectOf=Just o}+ [Prep "at",n@Nounc{}] -> do+ o <- getAvailableObject n+ return none{paramAtOf=Just o}+ [n1@Nounc{},Prep "at",n2@Nounc{}] -> do+ o1 <- getAvailableObject n1+ o2 <- getAvailableObject n2+ return none{paramDirectOf=Just o1,paramAtOf=Just o2}+ [Prep "on",n@Nounc{}] -> do+ o <- getAvailableObject n+ return none{paramOnOf=Just o}+ [n1@Nounc{},Prep "on",n2@Nounc{}] -> do+ o1 <- getAvailableObject n1+ o2 <- getAvailableObject n2+ return none{paramDirectOf=Just o1,paramOnOf=Just o2} _ -> throwError VerbMustFirstError return () @@ -167,9 +192,6 @@ act' (Verb "commit":Nounc _ _ "suicide":[]) = do eprintLn (Vivid Red) "You stab yourself in the chest, finally dying." throwError QuitError-act' (Verb "look":[]) = roomTriggerOnLookOf =<< getRoomState-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@@ -188,19 +210,24 @@ act' (Verb "list":Fixe "exits":[]) = do s <- getDungeonState let (Just r) = currentRoomOf s- forM_ (listEdges r $ roomsOf s) $ \(l,n) -> do+ forM_ (listEdges r $ roomsOf s) $ \(l,c,n) -> do+ b <- pathPrerequisiteOf c mprint " " >> mprint (show l) >> mprint " -> "- mprintLn =<< withRoom n getRoomTitle+ 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" akp+ 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@@ -226,6 +253,24 @@ 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
src/Game/Antisplice/Monad.hs view
@@ -25,6 +25,8 @@ module Game.Antisplice.Monad where import Game.Antisplice.Templates+import Game.Antisplice.Utils.AVL+import Game.Antisplice.Utils.None import Game.Antisplice.Utils.Fail import Game.Antisplice.Utils.Counter import Game.Antisplice.Monad.Dungeon@@ -32,12 +34,14 @@ import Game.Antisplice.Utils.Atoms import Game.Antisplice.Errors import Control.Monad.Trans.Class+import Text.Chatty.Expansion+import Text.Chatty.Expansion.Vars import Text.Chatty.Templates import Text.Chatty.Interactor.Templates --import Language.Haskell.TH mkInteractor ''SplErrT mkChatty mkRoom mkDungeon mkObject mkCounter mkPlayer mkIO mkVocab mkAtoms-mkInteractor ''DungeonT mkChatty (mkFail ''SplErr) mkCounter mkIO mkVocab mkAtoms+mkInteractor ''DungeonT mkPrinter mkScanner mkFinalizer mkClock mkExpanderEnv mkHistoryEnv mkRandom (mkFail ''SplErr) mkCounter mkIO mkVocab mkAtoms mkInteractor ''RoomT mkChatty (mkFail ''SplErr) mkCounter mkIO mkVocab mkAtoms mkInteractor ''ObjectT mkChatty (mkFail ''SplErr) mkCounter mkIO mkVocab mkAtoms mkInteractor ''CounterT mkChatty (mkFail ''SplErr) mkRoom mkObject mkDungeon mkPlayer mkIO mkVocab mkAtoms
src/Game/Antisplice/Monad/Dungeon.hs view
@@ -26,8 +26,10 @@ -- * Context quantifiers DungeonM, ChattyDungeonM,- Trigger,- TriggerBox (..),+ Handler,+ HandlerBox (..),+ Prerequisite,+ PrerequisiteBox (..), -- * Utilities IsText (..), Direction (..),@@ -35,10 +37,11 @@ RoomState (..), RoomT (..), MonadRoom (..),+ PathState (..), -- * Objects StatKey (..), EquipKey (..),- Implication (..),+ Relation (..), Feature (..), ObjectId (..), ObjectState (..),@@ -47,12 +50,20 @@ -- * Factions Faction (..), Attitude (..),+ -- * Currencies+ Currency (..),+ CurrencyId (..),+ -- * Fight+ DamageTarget (..), -- * Players PlayerId (..),- PlayerStereo (..), PlayerState (..), PlayerT (..), MonadPlayer (..),+ -- * Stereotypes+ PlayerStereo (..),+ CooldownId (..),+ SkillParam (..), -- * Dungeons DungeonState (..), currentRoomOf,@@ -64,6 +75,7 @@ import Text.Chatty.Printer import Text.Chatty.Scanner import Text.Chatty.Expansion+import Text.Chatty.Expansion.Vars import System.Chatty.Misc import Text.Chatty.Extended.Printer import Game.Antisplice.Utils.Graph@@ -88,12 +100,21 @@ -- | Matches any 'MonadDungeon' context type DungeonM a = forall m.(MonadDungeon m) => m a -- | Matches any 'MonadDungeon' context that also implements most of the Chatty classes and some of our utility classes.-type ChattyDungeonM a = forall m.(Functor m,ExtendedPrinter m,MonadScanner m,MonadExpand m,ExpanderEnv m,MonadDungeon m,MonadError SplErr m,MonadAtoms m,MonadClock m,MonadVocab m) => m a+type ChattyDungeonM a = forall m.(Functor m,ExtendedPrinter m,MonadExpand m,ExpanderEnv m,MonadDungeon m,MonadError SplErr m,MonadAtoms m,MonadClock m,MonadVocab m,MonadRandom m) => m a -- | The common type of all event handlers.-type Trigger = ChattyDungeonM ()--- | A boxed 'Trigger' to avoid ImpredicativeTypes-newtype TriggerBox = TriggerBox { runTrigger :: Trigger }+type Handler = ChattyDungeonM ()+-- | A boxed 'Handler' to avoid ImpredicativeTypes+newtype HandlerBox = Handler { runHandler :: Handler }+-- | The common type of all prerequisites.+type Prerequisite = ChattyDungeonM Bool+-- | A boxed 'Prerequisite' to avoid ImpredicativeTypes+newtype PrerequisiteBox = Prerequisite { runPrerequisite :: Prerequisite } +instance None HandlerBox where+ none = Handler $ return ()+instance None PrerequisiteBox where+ none = Prerequisite $ return True+ -- | Key for item or player statistics data StatKey = Strength | Agility@@ -101,6 +122,8 @@ | Intelligence | Spirit | Armor+ | Haste+ | CooldownDuration | AttackPower deriving (Ord,Eq) -- | Key for equipment slot@@ -116,11 +139,11 @@ data RoomState = RoomState { roomTitleOf :: !Text, roomObjectsOf :: AVL ObjectState,- roomTriggerOnFirstEnterOf :: Trigger,- roomTriggerOnEachEnterOf :: Trigger,- roomTriggerOnLeaveOf :: Trigger,- roomTriggerOnLookOf :: Trigger,- roomTriggerOnAnnounceOf :: Trigger+ roomTriggerOnFirstEnterOf :: Handler,+ roomTriggerOnEachEnterOf :: Handler,+ roomTriggerOnLeaveOf :: Handler,+ roomTriggerOnLookOf :: Handler,+ roomTriggerOnAnnounceOf :: Handler } -- | The room monad. Used to create or modify room data.@@ -163,21 +186,26 @@ -- | A faction data Faction = Faction { factionName :: !Text,- factionTriggerOnHostileOf :: Trigger,- factionTriggerOnFriendlyOf :: Trigger,- factionTriggerOnExaltedOf :: Trigger+ factionTriggerOnHostileOf :: Handler,+ factionTriggerOnFriendlyOf :: Handler,+ factionTriggerOnExaltedOf :: Handler } 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+-- | Relation between the player and the object.+data Relation = Near | Carried | Worn deriving (Ord,Eq) -- | Object features. data Feature = Damagable -- ^ May take damage. | Acquirable -- ^ May be acquired. | Equipable EquipKey -- ^ May be equipped at the given slot.+ | Redeemable Currency Int -- ^ May be redeemed for the given currency.+ | AutoRedeem Currency Int -- ^ Redeem automatically for a given currency.+ | Weighty Int -- ^ Has a known weight.+ | Played PlayerId -- ^ Is connected to a real player. | Mobile -- ^ May move around.+ | Stereo Relation (Atom PlayerStereo) -- ^ Implies an additional stereotype for the near/carrying/wearing player+ | Described (Atom String) -- ^ Implies an additional particle for the room description deriving (Ord,Eq) instance Indexable Feature Feature Feature where@@ -192,6 +220,9 @@ instance None ObjectId where none = FalseObject +-- | Target for attacks. May be a player or an object.+data DamageTarget = TargetPlayer PlayerId | TargetObject ObjectId+ -- | State type for ObjectT data ObjectState = ObjectState { objectIdOf :: !ObjectId,@@ -205,31 +236,28 @@ objectOnceEquippedOf :: !Bool, objectMaxHealthOf :: !Int, objectCurHealthOf :: !Int,- objectStatsOf :: AVL (StatKey,Int), objectRouteOf :: ![NodeId], objectFeaturesOf :: AVL Feature,- objectWearableAtOf :: AVL EquipKey,- objectNearImplicationsOf :: [Implication],- objectCarryImplicationsOf :: [Implication],- objectWearImplicationsOf :: [Implication], objectFactionOf :: !(Maybe (Atom Faction)),- objectTriggerOnFirstSightOf :: Trigger,- objectTriggerOnEachSightOf :: Trigger,- objectTriggerOnFirstAcquireOf :: Trigger,- objectTriggerOnEachAcquireOf :: Trigger,- objectTriggerOnFirstInspectionOf :: Trigger,- objectTriggerOnEachInspectionOf :: Trigger,- objectTriggerOnLookAtOf :: Trigger,- objectTriggerOnLookIntoOf :: Trigger,- objectTriggerOnReadOf :: Trigger,- objectTriggerOnEnterOf :: Trigger,- objectTriggerOnRoomEnterOf :: Trigger,- objectTriggerOnRoomLeaveOf :: Trigger,- objectTriggerOnAnnounceOf :: Trigger,- objectTriggerOnDropOf :: Trigger,- objectTriggerOnFirstEquipOf :: Trigger,- objectTriggerOnEachEquipOf :: Trigger,- objectTriggerOnUnequipOf :: Trigger+ objectTriggerOnFirstSightOf :: Handler,+ objectTriggerOnEachSightOf :: Handler,+ objectTriggerOnFirstAcquireOf :: Handler,+ objectTriggerOnEachAcquireOf :: Handler,+ objectTriggerOnFirstInspectionOf :: Handler,+ objectTriggerOnEachInspectionOf :: Handler,+ objectTriggerOnLookAtOf :: Handler,+ objectTriggerOnLookIntoOf :: Handler,+ objectTriggerOnReadOf :: Handler,+ objectTriggerOnEnterOf :: Handler,+ objectTriggerOnRoomEnterOf :: Handler,+ objectTriggerOnRoomLeaveOf :: Handler,+ objectTriggerOnAnnounceOf :: Handler,+ objectTriggerOnDropOf :: Handler,+ objectTriggerOnFirstEquipOf :: Handler,+ objectTriggerOnEachEquipOf :: Handler,+ objectTriggerOnUnequipOf :: Handler,+ objectTriggerOnDieOf :: Handler,+ objectTriggerOnTakeDamageOf :: Handler } deriving Typeable instance Indexable ObjectState ObjectId ObjectState where@@ -264,23 +292,46 @@ -- | A player stereotype data PlayerStereo = PlayerStereo {- stereoCalcStatBonus :: (StatKey -> Int) -> StatKey -> Int+ stereoCalcStatBonus :: (StatKey -> Int) -> StatKey -> Int,+ stereoSkillBonus :: String -> Maybe (SkillParam -> HandlerBox) } deriving Typeable -- | Phantom ID type for players newtype PlayerId = PlayerId Int deriving (Eq,Ord)+-- | Phantom ID type for cooldowns+data CooldownId = GlobalCooldown | CooldownId Int deriving (Eq,Ord)+-- | Phantom ID type for currencies+data CurrencyId = Health | CurrencyId Int deriving (Ord,Eq)+-- | Currency descriptor (description and expander name)+data Currency = Currency {+ currencyIdOf :: CurrencyId,+ currencyDescOf :: String,+ currencyNameOf :: String+ } deriving (Ord,Eq) +-- | Parameter for skill invocation+data SkillParam = SkillParam {+ paramDirectOf :: Maybe ObjectState,+ paramAtOf :: Maybe ObjectState,+ paramOnOf :: Maybe ObjectState+ }++instance None SkillParam where+ none = SkillParam Nothing Nothing Nothing+ -- | State type for PlayerT data PlayerState = PlayerState { playerIdOf :: !PlayerId, playerRoomOf :: !NodeId, playerMaxHealthOf :: !Int,- playerCurHealthOf :: !Int, playerInventoryOf :: AVL ObjectState, playerEquipOf :: AVL (EquipKey,ObjectState), playerBaseStatsOf :: AVL (StatKey,Int), playerStereosOf :: [Atom PlayerStereo],- playerReputationOf :: AVL (Atom Faction,Int)+ playerReputationOf :: AVL (Atom Faction,Int),+ playerCurrenciesOf :: AVL (CurrencyId,Int),+ playerCooldownsOf :: AVL CooldownId,+ playerOpponentOf :: !ObjectId } instance Indexable PlayerState PlayerId PlayerState where@@ -289,6 +340,18 @@ indexOf = playerIdOf valueOf = id +instance Indexable CooldownId CooldownId CooldownId where+ type IndexOf CooldownId = CooldownId+ type ValueOf CooldownId = CooldownId+ indexOf = id+ valueOf = id++instance Indexable Currency CurrencyId Currency where+ type IndexOf Currency = CurrencyId+ type ValueOf Currency = Currency+ indexOf = currencyIdOf+ valueOf = id+ -- | The player monad. Used to create or modify players. newtype PlayerT m a = Player { runPlayerT :: PlayerState -> m (a,PlayerState) } @@ -318,18 +381,29 @@ getPlayerState = Player $ \s -> return (s,s) putPlayerState s = Player $ \_ -> return ((),s) +-- | State type for a path from one room to another+data PathState = PathState {+ pathPrerequisiteOf :: Prerequisite,+ pathTriggerBeforeWalkOf :: Handler,+ pathTriggerAfterWalkOf :: Handler+ }++instance None PathState where+ none = PathState (return True) noneM noneM+ -- | 10 directions to go data Direction = North | NorthEast | East | SouthEast | South | SouthWest | West | NorthWest | Up | Down deriving (Eq,Show) -- | State type for DungeonT data DungeonState = DungeonState {- roomsOf :: Graph RoomState Direction,+ roomsOf :: Graph RoomState Direction PathState, playersOf :: Focus PlayerState,- timeTriggersOf :: AVL (NominalDiffTime,TriggerBox)+ timeTriggersOf :: AVL (NominalDiffTime,HandlerBox),+ currenciesOf :: AVL Currency } instance None DungeonState where- none = DungeonState none none none+ none = DungeonState none none none none -- | For compatibility. Earlier versions of DungeonT had a field for that. currentRoomOf = fmap playerRoomOf . playerOf
src/Game/Antisplice/Monad/Vocab.hs view
@@ -37,6 +37,7 @@ | Adj String | Ordn Int String | Fixe String+ | Skilln String | Nounc [String] (Maybe Int) String -- ^ Complex noun, with attributes and maybe ordinal index. deriving Show
+ src/Game/Antisplice/Paths.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE RankNTypes, FlexibleContexts #-}++{-+ This module is part of Antisplice.+ Copyleft (c) 2014 Marvin Cohrs++ All wrongs reversed. Sharing is an act of love, not crime.+ Please share Antisplice with everyone you like.++ Antisplice is free software: you can redistribute it and/or modify+ it under the terms of the GNU Affero General Public License as published by+ the Free Software Foundation, either version 3 of the License, or+ (at your option) any later version.++ Antisplice is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU Affero General Public License for more details.++ You should have received a copy of the GNU Affero General Public License+ along with Antisplice. If not, see <http://www.gnu.org/licenses/>.+-}++-- | Some utility functions for constructing paths between rooms.+module Game.Antisplice.Paths where++import Data.Monoid+import Game.Antisplice.Action+import Game.Antisplice.Monad.Dungeon+import Game.Antisplice.Rooms+import Game.Antisplice.Utils.Graph+import Game.Antisplice.Utils.None++-- | A one-way path from 'f' to 't'.+unipath :: MonadDungeon m => NodeId -> NodeId -> Direction -> m ()+unipath f t d = establishWay f t d none++-- | A mutual path. The specified direction is for the path from 'f' to 't', the opposite one is chosen for 't' to 'f'.+bipath :: MonadDungeon m => NodeId -> NodeId -> Direction -> m ()+bipath f t d = unipath f t d >> unipath t f (opp d)+ where opp North = South+ opp NorthEast = SouthWest+ opp East = West+ opp SouthEast = NorthWest+ opp South = North+ opp SouthWest = NorthEast+ opp West = East+ opp NorthWest = SouthEast+ opp Up = Down+ opp Down = Up++-- | A unipath that is guarded by a prerequisite.+guardedPath :: MonadDungeon m => NodeId -> NodeId -> Direction -> Prerequisite -> m ()+guardedPath f t d p = establishWay f t d $ PathState p noneM noneM++-- | A composable wrapper for a path state+newtype Gate = Gate { runGate :: PathState }++instance None Gate where+ none = Gate $ PathState (return True) noneM noneM+instance Monoid Gate where+ mempty = none+ mappend g h = Gate $ PathState+ (runPrerequisite $ Prerequisite (pathPrerequisiteOf $ runGate g) <> Prerequisite (pathPrerequisiteOf $ runGate h))+ (pathTriggerBeforeWalkOf (runGate g) >> pathTriggerBeforeWalkOf (runGate h))+ (pathTriggerAfterWalkOf (runGate g) >> pathTriggerAfterWalkOf (runGate h))++instance IsAction Gate where+ g #&& h = Gate $ PathState+ (runPrerequisite $ Prerequisite (pathPrerequisiteOf $ runGate g) #&& Prerequisite (pathPrerequisiteOf $ runGate h))+ (pathTriggerBeforeWalkOf (runGate g) >> pathTriggerBeforeWalkOf (runGate h))+ (pathTriggerAfterWalkOf (runGate g) >> pathTriggerAfterWalkOf (runGate h))+ g #|| h = Gate $ PathState+ (runPrerequisite $ Prerequisite (pathPrerequisiteOf $ runGate g) #|| Prerequisite (pathPrerequisiteOf $ runGate h))+ (pathPrerequisiteOf (runGate g) >>= \b -> if b then pathTriggerBeforeWalkOf (runGate g) else pathTriggerBeforeWalkOf (runGate h))+ (pathPrerequisiteOf (runGate g) >>= \b -> if b then pathTriggerAfterWalkOf (runGate g) else pathTriggerAfterWalkOf (runGate h))+ g !&& h = Gate $ PathState+ (runPrerequisite $ Prerequisite (pathPrerequisiteOf $ runGate g) !&& Prerequisite (pathPrerequisiteOf $ runGate h))+ (pathTriggerBeforeWalkOf (runGate g) >> pathTriggerBeforeWalkOf (runGate h))+ (pathTriggerAfterWalkOf (runGate g) >> pathTriggerAfterWalkOf (runGate h))+ g !|| h = Gate $ PathState+ (runPrerequisite $ Prerequisite (pathPrerequisiteOf $ runGate g) !|| Prerequisite (pathPrerequisiteOf $ runGate h))+ (pathPrerequisiteOf (runGate g) >>= \b -> pathPrerequisiteOf (runGate h) >> if b then pathTriggerBeforeWalkOf (runGate g) else pathTriggerBeforeWalkOf (runGate h))+ (pathPrerequisiteOf (runGate g) >>= \b -> pathPrerequisiteOf (runGate h) >> if b then pathTriggerAfterWalkOf (runGate g) else pathTriggerAfterWalkOf (runGate h))++-- | Typeclass for everything that may be converted to a gate.+class Gatifiable g where+ toGate :: g -> Gate++instance Gatifiable Gate where+ toGate = id++instance Gatifiable PrerequisiteBox where+ toGate g = Gate $ PathState (runPrerequisite g) noneM noneM++instance Gatifiable PathState where+ toGate g = Gate g++instance Gatifiable ActionBefore where+ toGate (ActionBefore g) = Gate $ PathState (askAction g) (runAction g) noneM++instance Gatifiable ActionAfter where+ toGate (ActionAfter g) = Gate $ PathState (askAction g) noneM (runAction g)
src/Game/Antisplice/Prototypes.hs view
@@ -97,7 +97,7 @@ ctorRoute rs d = do i <- fmap objectIdOf getObjectState setMobRoute rs- let cmr :: Trigger+ let cmr :: Handler cmr = continueMobRoute i >> schedule d cmr onFirstSight $ schedule d cmr
src/Game/Antisplice/Rooms.hs view
@@ -48,10 +48,9 @@ addObjectAttr, setObjectIsMob, setObjectIsAcquirable,- addNearImplication,- addCarryImplication,- addWearImplication,+ addFeature, addDescSeg,+ addEquipSlot, -- * Object forms registerForm, instanciateForm,@@ -75,8 +74,19 @@ dropObject, equipObject, equipObjectAt,+ getEquipment,+ getCooldown,+ setCooldown,+ getCurrency,+ modifyCurrency,+ -- * Fight+ damage,+ focusOpponent,+ dealDamage, -- * Masquerades withRoom,+ withPlayer,+ withObject, guardVisible ) where @@ -93,6 +103,7 @@ import Game.Antisplice.Utils.Atoms import Game.Antisplice.Utils.None import Game.Antisplice.Errors+import Control.Arrow import Control.Monad import Control.Monad.Error import Control.Monad.Trans.Class@@ -113,9 +124,9 @@ getRoomDesc = do s <- getRoomState --return (fromText $ roomDescOf s)- let descseg (DescSeg a) = getAtom a+ let descseg (Described a) = getAtom a descseg _ = return none- is <- mapM descseg $ concatMap objectNearImplicationsOf $ avlInorder $ roomObjectsOf s+ is <- liftM (filter $ not.null) $ mapM descseg $ concatMap (avlInorder.objectFeaturesOf) $ avlInorder $ roomObjectsOf s return $ concat $ intersperse " " is -- | Get the current room's title@@ -174,9 +185,9 @@ when r $ roomTriggerOnLookOf rs -- | Construct a new room using the room monad.-constructRoom :: (Monad m,MonadDungeon (t m),MonadTrans t) => RoomT m a -> t m NodeId+constructRoom :: (MonadDungeon m) => RoomT m a -> m NodeId constructRoom m = do- (_,rs) <- lift $ runRoomT m $ RoomState none none noneM noneM noneM noneM noneM+ (_,rs) <- runRoomT m $ RoomState none none noneM noneM noneM noneM noneM s <- getDungeonState let (nid,g) = addNode' rs $ roomsOf s putDungeonState s{roomsOf=g}@@ -193,10 +204,10 @@ return a -- | Establish a path from one room to another one (one-way only).-establishWay :: MonadDungeon m => NodeId -> NodeId -> Direction -> m ()-establishWay f t d = do+establishWay :: MonadDungeon m => NodeId -> NodeId -> Direction -> PathState -> m ()+establishWay f t d c = do s <- getDungeonState- let g = addEdge f t 0 d $ roomsOf s+ let g = addEdge f t 0 d c $ roomsOf s putDungeonState s{roomsOf=g} -- | Enter a neighbouring room by its direction.@@ -204,29 +215,32 @@ changeRoom d = do s <- getDungeonState case currentRoomOf s of- Just r -> case followEdge r d (roomsOf s) of- Just n -> enterAndAnnounce n+ Just r -> case queryEdge r d (roomsOf s) of+ Just c -> do+ b <- pathPrerequisiteOf c+ unless b $ throwError CantWalkThereError+ case followEdge r d (roomsOf s) of+ Just n -> enterAndAnnounce n Nothing -> throwError CantWalkThereError -- | Add a new object to the current room. It is contructed using the object monad. addRoomObject :: (MonadCounter m,MonadRoom m) => ObjectT m a -> m ObjectId addRoomObject m = do- i <- countOn- o <- constructObject m- insertRoomObject o{objectIdOf=ObjectId i}- return $ ObjectId i+ i <- liftM ObjectId countOn+ o <- constructObject m $ Just i+ insertRoomObject o+ return i -- | Construct a room object (but don't add it)-constructObject :: Monad m => ObjectT m a -> m ObjectState-constructObject m = do+constructObject :: Monad m => ObjectT m a -> Maybe ObjectId -> m ObjectState+constructObject m j = do (_,o) <- runObjectT m $ ObjectState- none -- id+ (if isJust j then (\(Just j) -> j) j else none) -- id (pack "Something") -- title (pack "I don't know what this is.") -- desc none none False False False False -- names, attr, 1seen?, 1acq?, 1insp?, 1eq? 100 100 -- maxhp, curhp- none none none -- stats, route, feat- none none none none -- wear, impl (n,i,w)+ none none -- route, feat none -- faction noneM -- on 1 sight noneM -- on sight@@ -245,6 +259,8 @@ noneM -- on 1 eq noneM -- on eq noneM -- on uneq+ noneM -- on die+ noneM -- on take damage return o -- | Remove an object from the current room and return its state.@@ -306,11 +322,12 @@ addObjectAttr t = modifyObjectState $ \s -> s{objectAttributesOf=t:objectAttributesOf s} -- | Create a new player using the player monad-subscribePlayer :: (MonadDungeon (t m),MonadTrans t,MonadCounter (t m),Monad m) => PlayerT m a -> t m ()+subscribePlayer :: (MonadDungeon m,MonadCounter m) => PlayerT m a -> m () subscribePlayer m = do s <- getDungeonState- i <- countOn- (_,a) <- lift $ runPlayerT m $ PlayerState (PlayerId i) (rootNode $ roomsOf s) 100 100 none none none none none+ i <- liftM PlayerId countOn+ let r = rootNode $ roomsOf s+ (_,a) <- runPlayerT m $ PlayerState i r 100 none none none none none (avlInsert (Health,100) none) none none putDungeonState s{playersOf=anyBstInsert a $ playersOf s} -- | Move the current player to the given room, but don't trigger anything.@@ -338,19 +355,19 @@ a False = avlRemove Acquirable -- | Schedule an event for a given time offset (in milliseconds).-schedule :: (MonadDungeon m,MonadClock m) => Integer -> Trigger -> m ()+schedule :: (MonadDungeon m,MonadClock m) => Integer -> Handler -> m () schedule ms t = do now <- mgetstamp let t' = now + (realToFrac ms / 1000) s <- getDungeonState- putDungeonState s{timeTriggersOf=avlInsert (t',TriggerBox t) $ timeTriggersOf s}+ putDungeonState s{timeTriggersOf=avlInsert (t',Handler t) $ timeTriggersOf s} -- | Set the current mob's route setMobRoute :: MonadObject m => [NodeId] -> m () setMobRoute rs = modifyObjectState $ \s -> s{objectRouteOf=rs} -- | The given object may continue its route-continueMobRoute :: ObjectId -> Trigger+continueMobRoute :: ObjectId -> Handler continueMobRoute i = do rs <- roomOfObject i case rs of@@ -394,30 +411,22 @@ 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 an object feature to the current object+addFeature :: MonadObject m => Feature -> m ()+addFeature f = modifyObjectState $ \s -> s{objectFeaturesOf=avlInsert f $ objectFeaturesOf s} -- | 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+ addFeature $ Described 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+ o <- constructObject m Nothing putAtom a o return a @@ -432,17 +441,19 @@ -- | Equip the given object at a given key equipObjectAt :: (MonadPlayer m,MonadError SplErr m) => EquipKey -> ObjectState -> m (Maybe ObjectState) equipObjectAt k o- | isJust (avlLookup k $ objectWearableAtOf o) = do+ | isJust (avlLookup (Equipable k) $ objectFeaturesOf o) = do p <- getPlayerState let o1 = avlLookup k $ playerEquipOf p- putPlayerState p{playerEquipOf=avlInsert (k,o) $ playerEquipOf p}+ putPlayerState p{playerEquipOf=avlInsert (k,o) $ playerEquipOf p, playerInventoryOf=avlRemove (indexOf o) $ playerInventoryOf p} return o1 | otherwise = throwError CantEquipThatThereError -- | Equip the given object somewhere equipObject :: (MonadPlayer m,MonadError SplErr m) => ObjectState -> m (Maybe ObjectState) equipObject o =- case avlInorder $ objectWearableAtOf o of+ let equ (Equipable k) = [k]+ equ _ = none+ in case concatMap equ $ avlInorder $ objectFeaturesOf o of [] -> throwError CantEquipThatError [k] -> equipObjectAt k o ks -> do@@ -452,3 +463,116 @@ [k] -> equipObjectAt k o _ -> throwError WhereToEquipError +-- | Get equipped object+getEquipment :: MonadPlayer m => EquipKey -> m (Maybe ObjectState)+getEquipment k = liftM (avlLookup k.playerEquipOf) getPlayerState++-- | Add equippable slot+addEquipSlot :: MonadObject m => EquipKey -> m ()+addEquipSlot = addFeature . Equipable++-- | Set/unset cooldown+setCooldown :: MonadPlayer m => CooldownId -> Bool -> m ()+setCooldown c b = modifyPlayerState $ \p -> p{playerCooldownsOf=(if b then avlInsert else avlRemove) c $ playerCooldownsOf p}++-- | Get cooldown state+getCooldown :: MonadPlayer m => CooldownId -> m Bool+getCooldown c = liftM (isJust . avlLookup c . playerCooldownsOf) getPlayerState++-- | Get currency state+getCurrency :: MonadPlayer m => CurrencyId -> m Int+getCurrency c = liftM (joinMaybe . avlLookup c . playerCurrenciesOf) getPlayerState++-- | Modify currency state+modifyCurrency :: MonadPlayer m => CurrencyId -> (Int -> Int) -> m ()+modifyCurrency c f = modifyPlayerState $ \p ->+ let c1 = joinMaybe $ avlLookup c $ playerCurrenciesOf p+ in p{playerCurrenciesOf=avlInsert (c,f c1) $ playerCurrenciesOf p}++-- | Run a function in the context of a given player+withPlayer :: MonadDungeon m => PlayerId -> PlayerT (RoomT m) a -> m a+withPlayer i m = do+ d <- getDungeonState+ case anyBstLookup i $ playersOf d of+ Just p -> do+ (a,p') <- withRoom (playerRoomOf p) $ runPlayerT m p+ d <- getDungeonState+ putDungeonState d{playersOf=anyBstInsert p' $ playersOf d}+ return a++-- | Run a function in the context of a given object+withObject :: MonadDungeon m => ObjectId -> ObjectT (RoomT m) a -> m a+withObject i m = do+ rs <- roomOfObject i+ case rs of+ [r] -> withRoom r $ do+ rs <- getRoomState+ case anyBstLookup i $ roomObjectsOf rs of+ Just o -> do+ (a,o') <- runObjectT m o+ modifyRoomState $ \r -> r{roomObjectsOf=anyBstInsert o' $ roomObjectsOf r}+ return a++-- | Damage a target (no matter whether player or mob) without setting focus+damage :: MonadDungeon m => DamageTarget -> Int -> m ()+damage (TargetPlayer p) v = withPlayer p $ modifyCurrency Health $ subtract v+damage (TargetObject o) v = withObject o $ modifyObjectState $ \o -> o{objectCurHealthOf=objectCurHealthOf o - v}++-- | Focus an opponent+focusOpponent :: MonadPlayer m => ObjectId -> m ()+focusOpponent o = modifyPlayerState $ \p -> p{playerOpponentOf=o}++-- | Deal damage to an opponent. Real damage is influenced by random.+dealDamage :: (MonadRandom m,MonadDungeon m) => Int -> m ()+dealDamage d = do+ let dmin = truncate (fromIntegral d * 0.8)+ dmax = truncate (fromIntegral d * 1.2)+ r <- mrandomR (dmin,dmax)+ o <- liftM playerOpponentOf getPlayerState+ damage (TargetObject o) r+++instance MonadExpand m => MonadExpand (DungeonT m) where+ expand = lift . expand <=< expandDun++expandDun [] = return []+expandDun ('#':'?':'{':ss) =+ let nm = takeBrace 0 ss+ rm = drop (length nm + 1) ss+ takeBrace 0 ('}':ss) = ""+ takeBrace n ('}':ss) = '}' : takeBrace (n-1) ss+ takeBrace n ('{':ss) = '{' : takeBrace (n+1) ss+ takeBrace n (s:ss) = s : takeBrace n ss+ in do+ o <- liftM playerOpponentOf getPlayerState+ case o of+ FalseObject -> expandDun rm+ _ -> do+ r <- expandDun nm+ s <- expandDun rm+ return (r ++ s)+expandDun ('#':'{':ss) =+ let (nm,rm) = (takeWhile (/='}') &&& tail.dropWhile (/='}')) ss+ replace "health" = liftM (show . joinMaybe . avlLookup Health . playerCurrenciesOf) getPlayerState+ replace "ohealth" = do+ i <- liftM playerOpponentOf getPlayerState+ o <- withObject i getObjectState+ return $ show $ objectCurHealthOf o+ replace "otitle" = do+ i <- liftM playerOpponentOf getPlayerState+ o <- withObject i getObjectState+ return $ show $ objectTitleOf o+ replace s = do+ cs <- liftM (avlInorder . currenciesOf) getDungeonState+ case filter ((==s).currencyNameOf) cs of+ [] -> return []+ [c] -> liftM (show . joinMaybe . avlLookup (currencyIdOf c) . playerCurrenciesOf) getPlayerState+ in do+ r <- replace nm+ s <- expandDun rm+ return (r ++ s)+expandDun ('#':ss) =+ let (nm,rm) = (takeWhile isAnum &&& dropWhile isAnum) ss+ isAnum = flip elem (['A'..'Z']++['a'..'z']++['0'..'9'])+ in expandDun ("#{"++nm++"}"++rm)+expandDun (s:ss) = return . (s:) =<< expandDun ss
src/Game/Antisplice/SingleUser.hs view
@@ -25,6 +25,8 @@ import Text.Chatty.Finalizer import Text.Chatty.Interactor import Text.Chatty.Expansion+import Text.Chatty.Expansion.Vars+import Text.Chatty.Expansion.History import Text.Chatty.Extended.Printer import Text.Chatty.Extended.ANSI import Game.Antisplice.Monad.Dungeon@@ -43,16 +45,19 @@ import Control.Monad import Control.Monad.IO.Class -singleUser :: DungeonT (FailT SplErr (VocabT (AtomStoreT (CounterT (AnsiPrinterT (ExpanderT (HandleCloserT IO))))))) () -> IO ()+singleUser :: DungeonT (FailT SplErr (VocabT (AtomStoreT (CounterT (AnsiPrinterT (HistoryT (ExpanderT (NullExpanderT (HandleCloserT IO))))))))) () -> IO () singleUser init = void $ withLazyIO $+ withExpansion $ localEnvironment $+ flip runHistoryT [] $ flip runAnsiPrinterT (Dull White) $ withCounter $ flip runAtomStoreT none $ flip runVocabT defVocab $ do+ mputv "prompt" $ Literal "$user #{health}H#?{ #{otitle} #{ohealth}H}> " r <- runFailT $ flip runDungeonT none $ do init reenterCurrentRoom
+ src/Game/Antisplice/Skills.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE RankNTypes, FlexibleContexts, FlexibleInstances #-}++{-+ This module is part of Antisplice.+ Copyleft (c) 2014 Marvin Cohrs++ All wrongs reversed. Sharing is an act of love, not crime.+ Please share Antisplice with everyone you like.++ Antisplice is free software: you can redistribute it and/or modify+ it under the terms of the GNU Affero General Public License as published by+ the Free Software Foundation, either version 3 of the License, or+ (at your option) any later version.++ Antisplice is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU Affero General Public License for more details.++ You should have received a copy of the GNU Affero General Public License+ along with Antisplice. If not, see <http://www.gnu.org/licenses/>.+-}++-- | Provides utility functions for composing skills+module Game.Antisplice.Skills (+ -- * Utility types+ Condition,+ Consumer,+ Skill (..),+ ToConsumer (toConsumer),+ -- * Compositors+ (!+), (>!+), (!+>), (>!+>),+ -- * Skill builders+ skill,+ bareAction,+ bareCondition,+ -- * Sample consumers+ focusDirectC,+ optionallyFocusDirectC,+ -- * Final wrappers+ runSkill,+ wrapSkills+ ) where++import Control.Arrow+import Control.Monad+import Control.Monad.Error.Class+import Data.Monoid+import Game.Antisplice.Action+import Game.Antisplice.Errors+import Game.Antisplice.Monad.Dungeon+import Game.Antisplice.Rooms+import Game.Antisplice.Stats+import Game.Antisplice.Utils.None+import Game.Antisplice.Utils.Counter+import Game.Antisplice.Utils.Atoms++-- | A wrapper type for skill execution preconditions.+newtype Condition = Condition { runCondition :: SkillParam -> Prerequisite }++instance Monoid Condition where+ mempty = Condition $ \_ -> return True+ a `mappend` b = Condition $ \p -> do+ a' <- runCondition a p+ b' <- runCondition b p+ return (a' && b')++instance IsAction Condition where+ p #&& q = Condition $ \x -> do+ a <- runCondition p x+ if a then runCondition q x+ else return False+ p #|| q = Condition $ \x -> do+ a <- runCondition p x+ if a then return True+ else runCondition q x+ p !&& q = p <> q+ p !|| q = Condition $ \x -> do+ a <- runCondition p x+ b <- runCondition q x+ return (a || b)+ +instance None Condition where+ none = mempty++-- | A skill. Build it using the '!+' compositor and the 'skill' function.+data Skill = Skill {+ skillConditionOf :: !Condition,+ skillActionOf :: !(SkillParam -> Handler),+ skillNameOf :: !String+ }++-- | A single consumer. Build it using 'bareAction', 'bareCondition' and monoid concatenation.+data Consumer = Consumer !Condition !(SkillParam -> Handler)++instance Monoid Consumer where+ mempty = Consumer none (const noneM)+ (Consumer c1 a1) `mappend` (Consumer c2 a2) = Consumer (c1 <> c2) (\p -> a1 p >> a2 p)++instance IsAction Consumer where+ (Consumer c1 a1) #&& (Consumer c2 a2) = Consumer (c1 #&& c2) (\p -> a1 p >> a2 p)+ (Consumer c1 a1) #|| (Consumer c2 a2) = Consumer (c1 #|| c2) (\p -> runCondition c1 p >>= \q -> if q then a1 p else a2 p)+ p !&& q = p <> q+ (Consumer c1 a1) !|| (Consumer c2 a2) = Consumer (c1 !|| c2) (\p -> runCondition c1 p >>= \q -> runCondition c2 p >> if q then a1 p else a2 p)++instance None Consumer where+ none = mempty++-- | Focus direct object+focusDirectC :: Consumer+focusDirectC = bareAction (\p -> case p of+ SkillParam (Just o) _ _ -> focusOpponent $ objectIdOf o+ _ -> throwError UnintellegibleError)++-- | Optionally ocus direct object (obligatory if none is focused yet)+optionallyFocusDirectC :: Consumer+optionallyFocusDirectC = bareAction (\p -> case p of+ SkillParam (Just o) _ _ -> focusOpponent $ objectIdOf o+ SkillParam Nothing _ _ -> do+ o <- liftM playerOpponentOf getPlayerState+ case o of+ FalseObject -> throwError UnintellegibleError+ _ -> noneM)++-- | Typeclass for everything that may act as a consumer.+class ToConsumer c where+ toConsumer :: c -> Consumer++instance ToConsumer Consumer where+ toConsumer = id++instance ToConsumer Skill where+ toConsumer (Skill c a n) = Consumer c a++instance ToConsumer HandlerBox where+ toConsumer (Handler t) = Consumer none (const t)++instance ToConsumer (SkillParam -> HandlerBox) where+ toConsumer t = Consumer none (runHandler . t)++instance ToConsumer Condition where+ toConsumer c = Consumer c (const noneM)++instance ToConsumer PrerequisiteBox where+ toConsumer p = Consumer (Condition $ \_ -> runPrerequisite p) (const noneM)++instance ToConsumer Action where+ toConsumer a = Consumer (Condition $ \_ -> askAction a) (\_ -> runAction a)++infixl 5 !++-- | Add a consumer to the skill.+(!+) :: ToConsumer c => Skill -> c -> Skill+s !+ c = s !+! toConsumer c+ where (Skill c a n) !+! (Consumer c1 a1) = Skill (c <> c1) (\p -> a p >> a1 p) n++infixl 5 >!++-- | Add a consumer to the monadic skill+(>!+) :: (ToConsumer c,Monad m) => m Skill -> c -> m Skill+m >!+ c = do+ s <- m+ return (s !+ c)++infixl 5 !+>+-- | Add a monadic consumer to the skill+(!+>) :: (ToConsumer c,Monad m) => Skill -> m c -> m Skill+s !+> m = do+ c <- m+ return (s !+ c)++infixl 5 >!+>+-- | Add a monadic consumer to the monadic skill+(>!+>) :: (ToConsumer c,Monad m) => m Skill -> m c -> m Skill+ms >!+> mc = do+ s <- ms+ c <- mc+ return (s !+ c)++-- | Build a consumer from an action.+bareAction :: (SkillParam -> Handler) -> Consumer+bareAction t = toConsumer $ \p -> Handler (t p)++-- | Build a consumer from a condition.+bareCondition :: (SkillParam -> ChattyDungeonM Bool) -> Consumer+bareCondition = toConsumer.Condition++-- | Build a bogus skill that does nothing but has a name. Use this with '!+' to build powerful skills.+skill :: String -> Skill+skill = Skill none (const noneM)++-- | Wrap the skills into a form that is accepted by stereotypes.+wrapSkills :: [Skill] -> String -> Maybe (SkillParam -> HandlerBox)+wrapSkills sk n =+ case filter ((==n).skillNameOf) sk of+ [] -> Nothing+ sk:_ -> Just $ \p -> Handler (runSkill sk p)+ +-- | Run the given skill+runSkill :: Skill -> SkillParam -> Handler+runSkill (Skill c a _) p = do+ b <- runCondition c p+ unless b $ throwError CantCastThatNowError+ a p
src/Game/Antisplice/Stats.hs view
@@ -1,14 +1,37 @@ {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} +{-+ This module is part of Antisplice.+ Copyleft (c) 2014 Marvin Cohrs++ All wrongs reversed. Sharing is an act of love, not crime.+ Please share Antisplice with everyone you like.++ Antisplice is free software: you can redistribute it and/or modify+ it under the terms of the GNU Affero General Public License as published by+ the Free Software Foundation, either version 3 of the License, or+ (at your option) any later version.++ Antisplice is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU Affero General Public License for more details.++ You should have received a copy of the GNU Affero General Public License+ along with Antisplice. If not, see <http://www.gnu.org/licenses/>.+-}+ -- | Provides utility functions for dealing with stats and stereotypes module Game.Antisplice.Stats where import Control.Monad import Control.Monad.Identity+import Data.Monoid import Game.Antisplice.Monad.Dungeon import Game.Antisplice.Rooms import Game.Antisplice.Utils.AVL import Game.Antisplice.Utils.Atoms+import Game.Antisplice.Utils.None import Text.Chatty.Printer -- | Typeclass for every pure data that saves stats@@ -25,16 +48,6 @@ -- | 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@@ -45,45 +58,36 @@ 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 :: (MonadPlayer m,MonadAtoms m,MonadRoom 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+ let ss k = getStat k p+ stes <- totalStereo+ return $ stereoCalcStatBonus stes ss k + ss k --- | 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+-- | Calculates the total stereotype the player carries+totalStereo :: (MonadAtoms m,MonadPlayer m,MonadRoom m) => m PlayerStereo+totalStereo = do+ p <- getPlayerState+ r <- getRoomState+ let steseg r1 (Stereo r a)+ | r1 == r = [a]+ | otherwise = []+ steseg _ _ = []+ rsegs = concatMap (steseg Near) $ concatMap (avlInorder.objectFeaturesOf) $ avlInorder $ roomObjectsOf r+ isegs = concatMap (steseg Carried) $ concatMap (avlInorder.objectFeaturesOf) $ avlInorder $ playerInventoryOf p+ wsegs = concatMap (steseg Worn) $ concatMap (avlInorder.objectFeaturesOf) $ map snd $ avlInorder $ playerEquipOf p+ stes <- mapM getAtom (rsegs ++ isegs ++ wsegs ++ playerStereosOf p)+ return $ mconcat stes --- | Add the given stereotype to the current player.-addStereo :: MonadPlayer m => Atom PlayerStereo -> m ()-addStereo a = modifyPlayerState $ \p -> p{playerStereosOf=a:playerStereosOf p}+instance Monoid PlayerStereo where+ mempty = PlayerStereo (\_ _ -> 0) (\_ -> Nothing)+ a `mappend` b = PlayerStereo+ (\get k -> stereoCalcStatBonus a (\k -> stereoCalcStatBonus b get k + get k) k + stereoCalcStatBonus b get k)+ (\s -> case stereoSkillBonus a s of+ Nothing -> stereoSkillBonus b s+ Just b -> Just b) --- | 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}+instance None PlayerStereo where+ none = mempty
+ src/Game/Antisplice/Stereos.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, TemplateHaskell #-}++{-+ This module is part of Antisplice.+ Copyleft (c) 2014 Marvin Cohrs++ All wrongs reversed. Sharing is an act of love, not crime.+ Please share Antisplice with everyone you like.++ Antisplice is free software: you can redistribute it and/or modify+ it under the terms of the GNU Affero General Public License as published by+ the Free Software Foundation, either version 3 of the License, or+ (at your option) any later version.++ Antisplice is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU Affero General Public License for more details.++ You should have received a copy of the GNU Affero General Public License+ along with Antisplice. If not, see <http://www.gnu.org/licenses/>.+-}++module Game.Antisplice.Stereos (+ -- * Primitives+ statsStereo,+ skillsStereo,+ skillStereoM,+ -- * Dealing with players+ addStereo,+ replaceStereo,+ -- * Registration+ registerStereo,+ registerStereoM,+ -- * Builder+ StereoBuilderT (..),+ mergeStereo,+ mergeStereoM,+ mergeSkill,+ mergeSkillM,+ -- * Default stereos+ defaultStereo,+ visualStereo,+ manualStereo+ ) where++import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Error.Class+import Control.Arrow+import Data.Monoid+import Game.Antisplice.Action+import Game.Antisplice.Errors+import Game.Antisplice.Monad.Dungeon+import Game.Antisplice.Monad.Vocab+import Game.Antisplice.Rooms+import Game.Antisplice.Skills+import Game.Antisplice.Stats+import Game.Antisplice.Templates+import Game.Antisplice.Utils.Atoms+import Game.Antisplice.Utils.None+import Text.Chatty.Interactor.Templates++-- | 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}++-- | Create a stereotype that carries a stats modifier+statsStereo :: ((StatKey -> Int) -> StatKey -> Int) -> PlayerStereo+statsStereo m = PlayerStereo m (const none)++-- | Create a stereotype that carries skills+skillsStereo :: [Skill] -> PlayerStereo+skillsStereo sk = PlayerStereo (\_ _ -> 0) $ wrapSkills sk++-- | Create a stereotype that carries a skill from a monadic composition+skillStereoM :: Monad m => m Skill -> m PlayerStereo+skillStereoM m = do+ sk <- m+ return $ skillsStereo [sk]++-- | For monadic stereotype construction+newtype StereoBuilderT m a = StereoBuilder { runStereoBuilderT :: PlayerStereo -> m (a,PlayerStereo) }++instance Functor m => Functor (StereoBuilderT m) where+ fmap f a = StereoBuilder $ \s -> fmap (first f) $ runStereoBuilderT a s++instance Monad m => Monad (StereoBuilderT m) where+ return a = StereoBuilder $ \s -> return (a,s)+ m >>= f = StereoBuilder $ \s -> do (a,s') <- runStereoBuilderT m s; runStereoBuilderT (f a) s'++instance MonadTrans StereoBuilderT where+ lift m = StereoBuilder $ \s -> do a <- m; return (a,s)++-- | Merge the given pure stereotype into the built one+mergeStereo :: Monad m => PlayerStereo -> StereoBuilderT m ()+mergeStereo ste = StereoBuilder $ \s -> return ((),s<>ste)++-- | Merge the given monadic stereotype into the built one+mergeStereoM :: Monad m => m PlayerStereo -> StereoBuilderT m ()+mergeStereoM m = do+ ste <- lift m+ mergeStereo ste++-- | Merge the given pure skill into the built stereotype+mergeSkill :: MonadVocab m => Skill -> StereoBuilderT m ()+mergeSkill sk = do+ insertVocab (skillNameOf sk) Skilln+ mergeStereo $ skillsStereo [sk]++-- | Merge the given monadic skill into the built stereotype+mergeSkillM :: MonadVocab m => m Skill -> StereoBuilderT m ()+mergeSkillM m = do+ sk <- lift m+ mergeSkill sk++-- | Process the builder chain and register the resulting stereotype+registerStereoM :: MonadAtoms m => StereoBuilderT m () -> m (Atom PlayerStereo)+registerStereoM m = do+ (_,s) <- runStereoBuilderT m none+ registerStereo s++mkInteractor ''StereoBuilderT mkChatty (mkFail ''SplErr) mkDungeon mkRoom mkVocab mkCounter mkAtoms mkPlayer mkIO mkObject++-- | Default stereotype.+defaultStereo = statsStereo $+ \get k -> case k of+ AttackPower -> get Strength * 2+ CooldownDuration -> (get CooldownDuration ^ 2) `div` (get CooldownDuration + get Haste) - get CooldownDuration+ _ -> 0++visualStereo :: MonadVocab m => m PlayerStereo+visualStereo = liftM snd $ flip runStereoBuilderT none $ do+ mergeSkill $ skill "look" !+ bareAction (\p ->+ case p of+ SkillParam Nothing Nothing Nothing -> roomTriggerOnLookOf =<< getRoomState+ SkillParam Nothing (Just o) Nothing -> objectTriggerOnLookAtOf o+ _ -> throwError UnintellegibleError)+ mergeSkill $ skill "read" !+ bareAction (\p ->+ case p of+ SkillParam (Just o) Nothing Nothing -> objectTriggerOnReadOf o+ _ -> throwError UnintellegibleError)++manualStereo :: MonadVocab m => m PlayerStereo+manualStereo = liftM snd $ flip runStereoBuilderT none $ do+ mergeSkill $ skill "hit" !+ optionallyFocusDirectC !+ dealDamageA (calcStat AttackPower) !+ implyGlobalCooldownA
src/Game/Antisplice/Templates.hs view
@@ -47,7 +47,7 @@ -- | Automatically derive an instance for 'MonadError e' mkFail e s = [d|- instance (MonadError $ex m,Run $sx) => MonadError $ex ($sx m) where+ instance (MonadError $ex m) => MonadError $ex ($sx m) where throwError = lift . throwError catchError = error "catchError not implemented for this type." |]
src/Game/Antisplice/Terminal/Repl.hs view
@@ -28,6 +28,8 @@ import Text.Chatty.Scanner import Text.Chatty.Interactor import Text.Chatty.Expansion+import Text.Chatty.Expansion.Vars+import Text.Chatty.Expansion.History import Text.Chatty.Extended.Printer import System.Chatty.Misc import Game.Antisplice.Monad.Dungeon@@ -49,26 +51,25 @@ import System.Console.Haskeline.History -- | Read Eval Print Loop for Antisplice.-repl :: (ExtendedPrinter m,MonadScanner m,MonadError SplErr m,MonadIO m,MonadExpand m,ExpanderEnv m,MonadDungeon m,MonadAtoms m,MonadRoom m,MonadClock m,MonadVocab m) => m ()+repl :: (ExtendedPrinter m,MonadScanner m,MonadError SplErr m,MonadIO m,MonadExpand m,ExpanderEnv m,MonadDungeon m,MonadAtoms m,MonadRoom m,MonadClock m,MonadVocab m,HistoryEnv m,MonadRandom m) => m () repl = do mv <- liftIO (newEmptyMVar :: IO (MVar (Maybe String)))- cont <- liftIO (newEmptyMVar :: IO (MVar ()))+ cont <- liftIO (newEmptyMVar :: IO (MVar String)) thr <- liftIO $ forkOS $ runInputT defaultSettings{autoAddHistory=True} $ forever $ do- liftIO $ takeMVar cont- rl <- getInputLine "> "- liftIO $ putMVar mv rl- liftIO $ putMVar cont ()+ liftIO . putMVar mv =<< getInputLine =<< liftIO (takeMVar cont)+ liftIO . putMVar cont =<< expand =<< expand "$prompt" forever $ do e <- runFailT $ forever $ do ds <- getDungeonState now <- mgetstamp let ts = takeWhile ((<now).fst) $ avlInorder $ timeTriggersOf ds putDungeonState ds{timeTriggersOf=foldr avlRemove (timeTriggersOf ds) $ map fst ts}- forM_ ts (runTrigger . snd)+ forM_ ts (runHandler . snd) r <- liftIO $ tryTakeMVar mv case r of Just (Just l) -> do l' <- expand l+ mputh l' e <- runFailT (act l') case e of Right _ -> return ()@@ -81,10 +82,13 @@ Left CantEquipThatError -> mprintLn "I can't equip that." Left CantEquipThatThereError -> mprintLn "I can't wear that there. You might want to try some other place?" Left WhereToEquipError -> mprintLn "Where?"+ Left CantCastThatNowError -> mprintLn "Sorry, I can't cast that now. Check your health, mana and cooldowns." Left e -> throwError e throwError DoneError Just Nothing -> liftIO (killThread thr) >> mprintLn "quit" >> throwError QuitError Nothing -> liftIO $ threadDelay 100 case e of- Left DoneError -> liftIO $ putMVar cont ()+ Left DoneError -> do+ pr <- expand =<< expand "$prompt"+ liftIO $ putMVar cont pr Left e -> throwError e
src/Game/Antisplice/Utils/BST.hs view
@@ -47,6 +47,18 @@ indexOf = fst valueOf = snd +instance Ord o => Indexable (o,a,b) o (a,b) where+ type IndexOf (o,a,b) = o+ type ValueOf (o,a,b) = (a,b)+ indexOf (o,_,_) = o+ valueOf (_,a,b) = (a,b)++instance Ord o => Indexable (o,a,b,c) o (a,b,c) where+ type IndexOf (o,a,b,c) = o+ type ValueOf (o,a,b,c) = (a,b,c)+ indexOf (o,_,_,_) = o+ valueOf (_,a,b,c) = (a,b,c)+ -- | Typeclass for all BSTs that store the given Indexable class Indexable i o v => AnyBST t i o v where -- | Insert into the tree
src/Game/Antisplice/Utils/Focus.hs view
@@ -34,7 +34,7 @@ none = Focus none instance Indexable i o v => AnyBST Focus i o v where- anyBstInsert i t = Focus $ focusInsert' i $ runFocus t+ anyBstInsert i t = Focus $ bstInsert i $ runFocus t anyBstRemove o t = Focus $ bstRemove o $ runFocus t anyBstMax t = bstMax $ runFocus t anyBstMin t = bstMin $ runFocus t
src/Game/Antisplice/Utils/Graph.hs view
@@ -32,13 +32,13 @@ newtype NodeId = NodeId Int deriving (Eq,Show,Ord) -- | A general graph-data Graph a b = Graph { nodes :: AVL (Node a), edges :: [Edge b], nextId :: NodeId }+data Graph a b c = Graph { nodes :: AVL (Node a), edges :: [Edge b c], nextId :: NodeId } -- | A node for the graph data Node a = Node { nodeMarked :: Bool, nodeContent :: a, nodeId :: NodeId } -- | An edge for the graph-data Edge b = Edge { fromNode :: NodeId, toNode :: NodeId, weight :: Int, label :: b }+data Edge b c = Edge { fromNode :: NodeId, toNode :: NodeId, weight :: Int, label :: b, content :: c } instance Indexable (Node a) NodeId (Node a) where type IndexOf (Node a) = NodeId@@ -52,95 +52,101 @@ instance (Show a) => Show (Node a) where show (Node _ c i) = concat [show i, ": ", show c] -instance (Show b) => Show (Edge b) where- show (Edge f t w l) = concat [show f, " --", show l, "-> ", show t, " [", show w, "]"]+instance (Show b) => Show (Edge b c) where+ show (Edge f t w l _) = concat [show f, " --", show l, "-> ", show t, " [", show w, "]"] -- | Increment a NodeId incId :: NodeId -> NodeId incId (NodeId i) = NodeId (i+1) -- | An empty graph-emptyGraph :: Graph a b+emptyGraph :: Graph a b c emptyGraph = Graph EmptyAVL [] (NodeId 0) -instance None (Graph a b) where+instance None (Graph a b c) where none = emptyGraph -- | Add a node to the graph-addNode :: a -> Graph a b -> Graph a b+addNode :: a -> Graph a b c -> Graph a b c addNode x = snd . addNode' x -- | Add a node to the graph and also return its ID-addNode' :: a -> Graph a b -> (NodeId,Graph a b)+addNode' :: a -> Graph a b c -> (NodeId,Graph a b c) addNode' x (Graph ns es nid) = (nid, Graph (avlInsert (Node False x nid) ns) es (incId nid)) -- | Add a bunch of nodes-addNodes :: [a] -> Graph a b -> Graph a b+addNodes :: [a] -> Graph a b c -> Graph a b c addNodes xs = snd . addNodes' xs -- | Add a bunch of nodes and also return their IDs-addNodes' :: [a] -> Graph a b -> ([NodeId],Graph a b)+addNodes' :: [a] -> Graph a b c -> ([NodeId],Graph a b c) addNodes' [] g = ([],g) addNodes' (p:ps) g = let (ls, g'') = addNodes' ps g' (l, g') = addNode' p g in (l:ls, g'') -- | Return all nodes-allNodes :: Graph a b -> [Node a]+allNodes :: Graph a b c -> [Node a] allNodes = avlInorder . nodes -- | Return the node in the AVL tree's root-rootNode :: Graph a b -> NodeId+rootNode :: Graph a b c -> NodeId rootNode = nodeId . avlRoot . nodes -- | Add a unidirectional edge to the graph (provide both nodes, a weight and a label)-addEdge :: NodeId -> NodeId -> Int -> b -> Graph a b -> Graph a b-addEdge f t w l = addEdge' (Edge f t w l)+addEdge :: NodeId -> NodeId -> Int -> b -> c -> Graph a b c -> Graph a b c+addEdge f t w l c = addEdge' (Edge f t w l c) -- | Add a unidirectional edge to the graph (provide the 'Edge')-addEdge' :: Edge b -> Graph a b -> Graph a b+addEdge' :: Edge b c -> Graph a b c -> Graph a b c addEdge' e g = g{edges=e:edges g} -- | Add a bidirectional edge to the graph (provide both nodes, a weight and a label)-addMutualEdge :: NodeId -> NodeId -> Int -> b -> Graph a b -> Graph a b-addMutualEdge f t w l = addEdge f t w l . addEdge t f w l+addMutualEdge :: NodeId -> NodeId -> Int -> b -> c -> Graph a b c -> Graph a b c+addMutualEdge f t w l c = addEdge f t w l c . addEdge t f w l c -- | Add a bunch of edges unidirectionally (provide both nodes, a weight and a label)-addEdges :: [(NodeId,NodeId,Int,b)] -> Graph a b -> Graph a b-addEdges es g = foldr (addEdge' . (\(f,t,w,l) -> Edge f t w l)) g es+addEdges :: [(NodeId,NodeId,Int,b,c)] -> Graph a b c -> Graph a b c+addEdges es g = foldr (addEdge' . (\(f,t,w,l,c) -> Edge f t w l c)) g es -- | Add a bunch of edges unidirectionally (provide the 'Edge's)-addEdges' :: [Edge b] -> Graph a b -> Graph a b+addEdges' :: [Edge b c] -> Graph a b c -> Graph a b c addEdges' = flip $ foldr addEdge' -- | Add a bunch of edges bidirectionally (provide both nodes, a weight and a label)-addMutualEdges :: [(NodeId,NodeId,Int,b)] -> Graph a b -> Graph a b-addMutualEdges es = addEdges es . addEdges (map (\(f,t,w,l) -> (t,f,w,l)) es)+addMutualEdges :: [(NodeId,NodeId,Int,b,c)] -> Graph a b c -> Graph a b c+addMutualEdges es = addEdges es . addEdges (map (\(f,t,w,l,c) -> (t,f,w,l,c)) es) -- | Get the node's content from its ID-getNode :: NodeId -> Graph a b -> a+getNode :: NodeId -> Graph a b c -> a getNode n = nodeContent . getNode' n -- | Get the 'Node' object from its ID-getNode' :: NodeId -> Graph a b -> Node a+getNode' :: NodeId -> Graph a b c -> Node a getNode' n = (\(Just x) -> x) . avlLookup n . nodes -- | Set the node's content by its ID-setNode :: NodeId -> a -> Graph a b -> Graph a b+setNode :: NodeId -> a -> Graph a b c -> Graph a b c setNode n a g@(Graph ns _ _) = g{nodes=fmap setNode' ns} where setNode' (Node m c i) = if i == n then Node m a i else Node m c i -- | Mark a node by its ID-markNode :: NodeId -> Graph a b -> Graph a b+markNode :: NodeId -> Graph a b c -> Graph a b c markNode n g@(Graph ns _ _) = g{nodes=fmap markNode' ns} where markNode' (Node m c i) = if i == n then Node True c i else Node m c i -- | Follow an edge by its source node and label-followEdge :: Eq b => NodeId -> b -> Graph a b -> Maybe NodeId+followEdge :: Eq b => NodeId -> b -> Graph a b c -> Maybe NodeId followEdge n l g = case filter ((==l).label) $ filter ((==n).fromNode) $ edges g of [] -> Nothing (x:_) -> Just (toNode x) +-- | Query an edge's content+queryEdge :: Eq b => NodeId -> b -> Graph a b c -> Maybe c+queryEdge n l g = case filter ((==l).label) $ filter ((==n).fromNode) $ edges g of+ [] -> Nothing+ (x:_) -> Just (content x)+ -- | List all edges from the given node-listEdges :: NodeId -> Graph a b -> [(b,NodeId)]-listEdges n g = fmap (\(Edge _ t _ l) -> (l,t)) $ filter ((==n).fromNode) $ edges g+listEdges :: NodeId -> Graph a b c -> [(b,c,NodeId)]+listEdges n g = fmap (\(Edge _ t _ l c) -> (l,c,t)) $ filter ((==n).fromNode) $ edges g
src/Game/Antisplice/Utils/None.hs view
@@ -49,6 +49,15 @@ instance Monad m => None (a -> m a) where none = return +instance None Int where+ none = 0++instance None Integer where+ none = 0++instance None Bool where+ none = False+ -- | Wrap the void into a monad. noneM :: (Monad m,None n) => m n noneM = return none