antisplice 0.14.0.3 → 0.15.0.1
raw patch · 12 files changed
+643/−327 lines, 12 files
Files
- antisplice.cabal +4/−2
- src/Game/Antisplice.hs +2/−0
- src/Game/Antisplice/Action.hs +15/−0
- src/Game/Antisplice/Call.hs +288/−0
- src/Game/Antisplice/Errors.hs +1/−0
- src/Game/Antisplice/Lang.hs +100/−187
- src/Game/Antisplice/Monad/Dungeon.hs +14/−22
- src/Game/Antisplice/Monad/Vocab.hs +1/−1
- src/Game/Antisplice/Rooms.hs +31/−13
- src/Game/Antisplice/Skills.hs +149/−78
- src/Game/Antisplice/Stats.hs +4/−1
- src/Game/Antisplice/Stereos.hs +34/−23
antisplice.cabal view
@@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.14.0.3+version: 0.15.0.1 -- 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, Game.Antisplice.Skills, Game.Antisplice.Stereos, Game.Antisplice.Paths, Game.Antisplice.Action, Game.Antisplice.Utils.ListBuilder+ 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, Game.Antisplice.Utils.ListBuilder, Game.Antisplice.Call -- Modules included in this library but not exported. -- other-modules: @@ -64,4 +64,6 @@ -- Base language which the package is written in. default-language: Haskell2010++ ghc-options: -fprof-auto
src/Game/Antisplice.hs view
@@ -26,6 +26,7 @@ module Game.Antisplice ( -- * Reexported modules module Game.Antisplice.Monad,+ module Game.Antisplice.Call, module Game.Antisplice.Monad.Dungeon, module Game.Antisplice.Monad.Vocab, module Game.Antisplice.Utils.Fail,@@ -72,6 +73,7 @@ import Game.Antisplice.Events import Game.Antisplice.Action import Game.Antisplice.Paths+import Game.Antisplice.Call import Control.Monad.Error.Class -- | A dungeon constructor function
src/Game/Antisplice/Action.hs view
@@ -31,6 +31,8 @@ import Game.Antisplice.Stats import Game.Antisplice.Utils.Counter import Game.Antisplice.Utils.None+import Game.Antisplice.Utils.AVL+import Game.Antisplice.Utils.BST -- | A typeclass for all action types carrying an execution condition. class IsAction a where@@ -126,6 +128,19 @@ c1 <- getCurrency c return (c1 > h)) (modifyCurrency c (subtract h))++-- | Use for actions that consume an object of the given kind.+consumeKindA :: KindId -> Int -> Action+consumeKindA k h =+ let getObjs :: ChattyDungeonM [ObjectId]+ getObjs = liftM (map indexOf . filter ((==k) . objectKindOf) . avlInorder . playerInventoryOf) getPlayerState+ in Action+ (do+ objs <- getObjs+ return (length objs >= h))+ (do+ objs <- getObjs+ modifyPlayerState $ \p -> p{playerInventoryOf=foldr avlRemove (playerInventoryOf p) $ take h objs}) -- | Deal damage to opponent dealDamageA :: ChattyDungeonM Int -> Action
+ src/Game/Antisplice/Call.hs view
@@ -0,0 +1,288 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances, 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 a powerful language for user input evaluation+module Game.Antisplice.Call (+ -- * Heterogenous list+ Cons (..),+ Nil (..),+ Append (..),+ Tuplify (..),+ -- * Using call masks+ processMask,+ tryMask,+ -- * Call mask segments+ CallMask (..),+ EnsureLineEnd (..),+ CatchByType (..),+ CatchToken (..),+ CatchOrd (..),+ Remaining (..),+ CatchObj (..),+ ) where++import Control.Monad+import Control.Monad.State+import Control.Monad.Identity+import Control.Monad.Error.Class+import Data.Maybe+import Game.Antisplice.Errors+import Game.Antisplice.Monad.Dungeon+import Game.Antisplice.Monad.Vocab+import Game.Antisplice.Utils.AVL++infixr 8 :-:+-- | The Cons type for a heterogenous list+data Cons a b = (:-:) a b+-- | The empty list+data Nil = Nil++-- | Typeclass for appending one heterogenous list to another one+class Append a b ab | a b -> ab where+ tappend :: a -> b -> ab+instance Append Nil b b where+ tappend Nil b = b+instance Append b c bc => Append (Cons a b) c (Cons a bc) where+ tappend (a :-: b) c = a :-: tappend b c++-- | Typeclass for use input masks (either single modules or lists of modules)+class CallMask cm l | cm -> l where+ usemask :: (MonadRoom m,MonadPlayer m) => cm -> StateT [(String,Token)] m (Maybe l)++-- | Ensures that the end of the input is reached+data EnsureLineEnd = EnsureLineEnd+-- | Catches the string of a token matching the given token type+data CatchByType = CatchVerb | CatchPrep | CatchNoun | CatchAdj | CatchOrdn Int | CatchFixe | CatchSkilln | CatchUnint | CatchAny+-- | Catches an entire token+data CatchToken = CatchToken | CatchNounc+-- | Catches the number of an Ordn token+data CatchOrd = CatchOrd+-- | Catches the remaining part of the line+data Remaining = Remaining+-- | Catches an available, carried or seen object+data CatchObj = AvailableObject | SeenObject | CarriedObject++instance CallMask Token Nil where+ usemask t = do+ ss <- get+ if null ss then return Nothing+ else let (s:_) = ss in do+ modify tail+ return $ if snd s == t then Just Nil else Nothing++instance CallMask String Nil where+ usemask t = do+ ss <- get+ if null ss then return Nothing+ else let (s:_) =ss in do+ modify tail+ return $ if fst s == t then Just Nil else Nothing+ +instance CallMask EnsureLineEnd Nil where+ usemask EnsureLineEnd = do+ s <- get+ return $ if null s then Just Nil else Nothing+ +instance CallMask CatchByType (Cons String Nil) where+ usemask ct = do+ ss <- get+ if null ss then return Nothing+ else let (s:_) = ss in do + modify tail+ return $ case (ct,snd s) of+ (CatchVerb, Verb t) -> Just (t :-: Nil)+ (CatchAny, Verb t) -> Just (t :-: Nil)+ (CatchPrep, Prep t) -> Just (t :-: Nil)+ (CatchAny, Prep t) -> Just (t :-: Nil)+ (CatchNoun, Noun t) -> Just (t :-: Nil)+ (CatchAny, Noun t) -> Just (t :-: Nil)+ (CatchAdj, Adj t) -> Just (t :-: Nil)+ (CatchAny, Adj t) -> Just (t :-: Nil)+ (CatchOrdn i, Ordn j t) -> if i == j then Just (t :-: Nil) else Nothing+ (CatchAny, Ordn _ t) -> Just (t :-: Nil)+ (CatchFixe, Fixe t) -> Just (t :-: Nil)+ (CatchAny, Fixe t) -> Just (t :-: Nil)+ (CatchSkilln, Skilln t) -> Just (t :-: Nil)+ (CatchAny, Skilln t) -> Just (t :-: Nil)+ (CatchUnint, Unintellegible t) -> Just (t :-: Nil)+ (CatchAny, Unintellegible t) -> Just (t :-: Nil)+ _ -> Nothing+ +instance CallMask CatchOrd (Cons Int Nil) where+ usemask CatchOrd = do+ ss <- get+ if null ss then return Nothing+ else let (s:_) = ss in do + modify tail+ case snd s of+ Ordn i _ -> return $ Just (i :-: Nil)+ _ -> return Nothing++instance CallMask CatchToken (Cons Token Nil) where+ usemask CatchToken = do+ ss <- get+ if null ss then return Nothing+ else modify tail >> return (Just (snd (head ss) :-: Nil))+ usemask CatchNounc = do+ ss <- get+ case mergeNoun ss of+ Nothing -> return Nothing+ Just (t,xs) -> do put xs; return $ Just (t :-: Nil)++instance CallMask CatchObj (Cons ObjectState Nil) where+ usemask k = do+ ss <- get+ as <- lift $ case k of+ AvailableObject -> availableObjects+ SeenObject -> seenObjects+ CarriedObject -> carriedObjects+ case mergeNoun ss of+ Nothing -> return Nothing+ Just (t,xs) -> do+ put xs+ case getObject' as t of+ Found x -> return $ Just (x :-: Nil)+ _ -> return Nothing++instance CallMask Remaining (Cons [String] Nil) where+ usemask Remaining = do+ ss <- get+ put []+ return $ Just (map fst ss :-: Nil)++instance CallMask Nil Nil where+ usemask Nil = return $ Just Nil+ +instance (CallMask x r,CallMask xs rs,Append r rs rx) => CallMask (Cons x xs) rx where+ usemask (x :-: xs) = do+ l1 <- usemask x+ case l1 of+ Nothing -> return Nothing+ Just l1 -> do+ l2 <- usemask xs+ case l2 of+ Nothing -> return Nothing+ Just l2 -> return $ Just $ tappend l1 l2++-- | Typeclass for everything that may be converted to a tuple+class Tuplify l t | l -> t where+ tuplify :: l -> t++instance Tuplify Nil () where+ tuplify Nil = ()++instance Tuplify (Cons a Nil) a where+ tuplify (a :-: Nil) = a++instance Tuplify (Cons a (Cons b Nil)) (a,b) where+ tuplify (a :-: b :-: Nil) = (a,b)++instance Tuplify (Cons a (Cons b (Cons c Nil))) (a,b,c) where+ tuplify (a :-: b :-: c :-: Nil) = (a,b,c)++instance Tuplify (Cons a (Cons b (Cons c (Cons d Nil)))) (a,b,c,d) where+ tuplify (a :-: b :-: c :-: d :-: Nil) = (a,b,c,d)++instance Tuplify (Cons a (Cons b (Cons c (Cons d (Cons e Nil))))) (a,b,c,d,e) where+ tuplify (a :-: b :-: c :-: d :-: e :-: Nil) = (a,b,c,d,e)++instance Tuplify (Cons a (Cons b (Cons c (Cons d (Cons e (Cons f Nil)))))) (a,b,c,d,e,f) where+ tuplify (a :-: b :-: c :-: d :-: e :-: f :-: Nil) = (a,b,c,d,e,f)++instance Tuplify ObjectState ObjectState where+ tuplify = id++instance Tuplify Int Int where+ tuplify = id++instance Tuplify String String where+ tuplify = id++-- | Use a mask on a list of tokens+processMask' :: CallMask m r => m -> [(String,Token)] -> DungeonM (Maybe r)+processMask' m s = evalStateT (usemask m) s++-- | Use a mask on a list of tokens and tuplify the result. Dispatch errors to the underlying monad.+processMask :: (CallMask m r, Append r Nil r, Tuplify r t) => m -> [String] -> DungeonM t+processMask m s = do+ ss <- mapM lookupVocab s+ mr <- processMask' (m :-: EnsureLineEnd :-: Nil) $ zip s ss+ case mr of+ Nothing -> throwError UnintellegibleError+ Just r -> return $ tuplify r++-- | Try to use a mask on a list of tokens. Only return whether it succeeded.+tryMask :: (Append r Nil r, CallMask m r) => m -> [String] -> DungeonM Bool+tryMask m s = do+ ss <- mapM lookupVocab s+ mr <- processMask' (m :-: EnsureLineEnd :-: Nil) $ zip s ss+ return $ isJust mr++-- | Token is adjective?+isAdj (Adj _) = True+isAdj _ = False++-- | Token is noun?+isNoun (Noun _) = True+isNoun _ = False++-- | Merge nouns and adjectives to a complex noun+mergeNoun :: [(String,Token)] -> Maybe (Token,[(String,Token)])+mergeNoun [] = Nothing+mergeNoun ts@((_,Noun s):_) =+ let as = takeWhile (\(_,t) -> isAdj t || isNoun t) ts+ in Just (Nounc (map fst $ init as) Nothing (fst $ last as), drop (length as) ts)+mergeNoun ts@((_,Adj s):_) =+ let as = takeWhile (\(_,t) -> isAdj t || isNoun t) ts+ in Just (Nounc (map fst $ init as) Nothing (fst $ last as), drop (length as) ts)+mergeNoun (o@(_,Ordn i _):ts) =+ let as = takeWhile (\(_,t) -> isAdj t || isNoun t) ts+ in case as of+ [] -> Nothing+ _ -> Just (Nounc (map fst $ init as) (Just i) (fst $ last as), drop (length as) ts)+mergeNoun _ = Nothing++getObject' :: [ObjectState] -> Token -> GetterResponse+getObject' os (Nounc as i n) =+ let ns1 = filter (elem n . objectNamesOf) os+ ns2 = foldr (\a ns -> filter (elem a . objectAttributesOf) ns) ns1 as+ in case ns2 of+ [] -> NoneFound+ xs -> case i of+ Nothing -> case xs of+ [x] -> Found x+ _ -> TooMany+ Just idx -> if idx > length xs then NoneFound+ else Found (xs !! (idx-1))+ +availableObjects :: (MonadRoom m,MonadPlayer m) => m [ObjectState]+availableObjects = do+ rs <- getRoomState+ ps <- getPlayerState+ return (avlInorder (roomObjectsOf rs) ++ avlInorder (playerInventoryOf ps))+ +carriedObjects :: MonadPlayer m => m [ObjectState]+carriedObjects = liftM (avlInorder.playerInventoryOf) getPlayerState++seenObjects :: MonadRoom m => m [ObjectState]+seenObjects = liftM (avlInorder.roomObjectsOf) getRoomState
src/Game/Antisplice/Errors.hs view
@@ -40,6 +40,7 @@ | CantWalkThereError -- ^ "I can't walk there." | CantAcquireThatError -- ^ "I can't take that." | WontHitThatError -- ^ "I won't hit that."+ | WrongMethodError -- ^ "Wrong method for creating that." deriving Show -- | Alias for 'FailT' 'SplErr'
src/Game/Antisplice/Lang.hs view
@@ -39,6 +39,9 @@ import Game.Antisplice.Utils.ListBuilder import Game.Antisplice.Rooms import Game.Antisplice.Stats+import Game.Antisplice.Skills+import Game.Antisplice.Call+import Game.Antisplice.Action import Control.Arrow import Control.Monad.Error import Text.Printf@@ -94,6 +97,8 @@ lit "southwest" Fixe lit "at" Prep lit "on" Prep+ lit "for" Prep+ lit "of" Prep lit "enter" Verb lit "list" Verb lit "exits" Fixe@@ -124,195 +129,103 @@ [] -> x (a:_) -> snd a -isIntellegible :: Token -> Bool-isIntellegible (Unintellegible _) = False-isIntellegible _ = True--isNoun :: Token -> Bool-isNoun (Noun _) = True-isNoun _ = False--isAdj :: Token -> Bool-isAdj (Adj _) = True-isAdj _ = False--mergeNouns :: [Token] -> [Token]-mergeNouns [] = []-mergeNouns (Noun s:ts) = Nounc [] Nothing s : mergeNouns ts-mergeNouns ts@(Adj _:_) =- let as = takeWhile isAdj ts- ns = dropWhile isAdj ts- in case ns of- (n:nx) -> Nounc (map (\(Adj a) -> a) as) Nothing ((\(Noun n) -> n) n) : mergeNouns nx- _ -> as-mergeNouns (o@(Ordn i _):ts) =- let as = takeWhile isAdj ts- ns = dropWhile isAdj ts- in case ns of- (n:nx) -> Nounc (map (\(Adj a) -> a) as) (Just i) ((\(Noun n) -> n) n) : mergeNouns nx- _ -> o:as-mergeNouns (t:ts) = t : mergeNouns ts- -- | Run a given input line. act :: String -> ChattyDungeonM () act s = do- ts <- mapM lookupVocab $ replaceAliases $ words $ map toLower s- let ss = mergeNouns ts- unless (all isIntellegible ss) $ throwError UnintellegibleError- case ss of- [] -> return ()- (Verb v:_) -> act' ss- (Skilln n:ps) -> do- ste <- totalStereo- case stereoSkillBonus ste n of- Nothing -> throwError CantCastThatNowError- Just t -> runHandler . t =<< do- gao <- liftM getObject' availableObjects- gco <- liftM getObject' carriedObjects- gso <- liftM getObject' seenObjects- let getters = Getters gao gco gso- tmplt = none{paramGettersOf=getters}- case ps of- [] -> return tmplt- [n@Nounc{}] -> return tmplt{paramDirectOf=Just n}- [Prep "at",n@Nounc{}] -> return tmplt{paramAtOf=Just n}- [n1@Nounc{},Prep "at",n2@Nounc{}] -> return tmplt{paramDirectOf=Just n1,paramAtOf=Just n2}- [Prep "on",n@Nounc{}] -> return tmplt{paramOnOf=Just n}- [n1@Nounc{},Prep "on",n2@Nounc{}] -> return tmplt{paramDirectOf=Just n1,paramOnOf=Just n2}- _ -> throwError UnintellegibleError- _ -> throwError VerbMustFirstError+ let sp = replaceAliases $ words $ map toLower s+ ts <- mapM lookupVocab sp+ unless (null sp) $ do+ v1 <- lookupVocab (head sp)+ case v1 of+ Verb v -> runHandler $ runConsumer react sp+ Skilln n -> do+ ste <- totalStereo+ case stereoSkillBonus ste n of+ Nothing -> throwError CantCastThatNowError+ Just t -> runHandler $ t $ tail sp+ _ -> throwError VerbMustFirstError return () -act' (Verb "quit":[]) = throwError QuitError-act' (Verb "commit":Nounc _ _ "suicide":[]) = do- eprintLn (Vivid Red) "You stab yourself in the chest, finally dying."- throwError QuitError-act' (Verb "enter":n@Nounc{}:[]) = getAvailableObject_ n >>= objectTriggerOnEnterOf-act' (Verb "ascend":[]) = changeRoom Up-act' (Verb "descend":[]) = changeRoom Down-act' (Verb "go":Fixe d:[]) =- changeRoom $ case d of- "north" -> North- "south" -> South- "east" -> East- "west" -> West- "northeast" -> NorthEast- "northwest" -> NorthWest- "southeast" -> SouthEast- "southwest" -> SouthWest- "up" -> Up- "down" -> Down-act' (Verb "list":Fixe "exits":[]) = do- s <- getDungeonState- let (Just r) = currentRoomOf s- forM_ (listEdges r $ roomsOf s) $ \(l,c,n) -> do- b <- pathPrerequisiteOf c- mprint " " >> mprint (show l) >> mprint " -> "- mprint =<< withRoom n getRoomTitle- if not b then mprintLn " (locked)"- else mprintLn ""-act' (Verb "list":Fixe "inventory":[]) = do- ps <- getPlayerState- mprintLn "Your inventory:"- forM_ (avlInorder $ playerInventoryOf ps) $ \os -> mprintLn $ printf " %s" $ unpack $ objectTitleOf os-act' (Verb "list":Fixe "score":[]) = do- [str, agi, sta, int, spi, arm, akp] <- mapM calcStat [Strength, Agility, Stamina, Intelligence, Spirit, Armor, AttackPower]- [hst, gcd] <- mapM calcStat [Haste, CooldownDuration]- mprintLn $ printf "Strength: %5i Agility: %5i" str agi- mprintLn $ printf "Intelligence: %5i Spirit: %5i" int spi- mprintLn $ printf "Stamina: %5i Armor: %5i" sta arm- mprintLn $ printf "Attack power: %5i Haste: %5i" akp hst- mprintLn $ printf "Global cooldown: %5i" gcd-act' (Verb "equip":n@Nounc{}:[]) = do- o <- getCarriedObject_ n >>= equipObject- case o of- Nothing -> noneM- Just o -> modifyPlayerState $ \s -> s{playerInventoryOf=avlInsert o $ playerInventoryOf s}-act' (Verb "equip":n@Nounc{}:Prep "at":ps) = do- k <- case ps of- [Fixe "main",Fixe "hand"] -> return MainHand- [Fixe "off",Fixe "hand"] -> return OffHand- [Fixe "chest"] -> return Chest- [Fixe "feet"] -> return Feet- [Fixe "wrists"] -> return Wrists- [Fixe "waist"] -> return Waist- [Fixe "head"] -> return Head- [Fixe "legs"] -> return Legs- [Fixe "back"] -> return Back- [Fixe "hands"] -> return Hands- [Fixe "neck"] -> return Neck- [Fixe "right",Fixe "finger"] -> return Finger1- [Fixe "left",Fixe "finger"] -> return Finger2- _ -> throwError UnintellegibleError- o <- getCarriedObject_ n >>= equipObjectAt k- case o of- Nothing -> noneM- Just o -> modifyPlayerState $ \s -> s{playerInventoryOf=avlInsert o $ playerInventoryOf s}-act' (Verb "list":Fixe "equipment":[]) = - let pr (Just k) s = mprintLn $ printf "%-15s%s" s $ unpack $ objectTitleOf k- pr Nothing _ = noneM- firstM = runKleisli . first . Kleisli- in mapM_ (firstM getEquipment >=> uncurry pr) $ lazyBuild $ do- lit MainHand "Main hand:"- lit OffHand "Off hand:"- lit Chest "Chest:"- lit Feet "Feet:"- lit Wrists "Wrists:"- lit Waist "Waist:"- lit Head "Head:"- lit Legs "Legs:"- lit Back "Back:"- lit Hands "Hands:"- lit Neck "Neck:"- lit Finger1 "Right finger:"- lit Finger2 "Left finger:"-act' (Verb "acquire":n@Nounc{}:[]) = getSeenObject_ n >>= (acquireObject . objectIdOf)-act' (Verb "drop":n@Nounc{}:[]) = getCarriedObject_ n >>= (dropObject . objectIdOf)-act' _ = throwError UnintellegibleError--getObject :: (MonadError SplErr m) => Token -> [ObjectState] -> SplErr -> m ObjectState-getObject n os err =- case getObject' os n of- NoneFound -> throwError err- TooMany -> throwError WhichOneError- Found x -> return x--getObject' :: [ObjectState] -> Token -> GetterResponse-getObject' os (Nounc as i n) =- let ns1 = filter (elem n . objectNamesOf) os- ns2 = foldr (\a ns -> filter (elem a . objectAttributesOf) ns) ns1 as- in case ns2 of- [] -> NoneFound- xs -> case i of- Nothing -> case xs of- [x] -> Found x- _ -> TooMany- Just idx -> if idx > length xs then NoneFound- else Found (xs !! (idx-1))--availableObjects :: (MonadRoom m,MonadPlayer m) => m [ObjectState]-availableObjects = do- rs <- getRoomState- ps <- getPlayerState- return (avlInorder (roomObjectsOf rs) ++ avlInorder (playerInventoryOf ps))- -getAvailableObject_ :: (MonadRoom m, MonadError SplErr m, MonadPlayer m) => Token -> m ObjectState-getAvailableObject_ n = do- os <- availableObjects- getObject n os CantSeeOneError--carriedObjects :: MonadPlayer m => m [ObjectState]-carriedObjects = liftM (avlInorder.playerInventoryOf) getPlayerState--getCarriedObject_ :: (MonadPlayer m, MonadError SplErr m) => Token -> m ObjectState-getCarriedObject_ n = do- os <- carriedObjects- getObject n os DontCarryOneError--seenObjects :: MonadRoom m => m [ObjectState]-seenObjects = liftM (avlInorder.roomObjectsOf) getRoomState--getSeenObject_ :: (MonadRoom m, MonadError SplErr m) => Token -> m ObjectState-getSeenObject_ n = do- os <- seenObjects- getObject n os CantSeeOneError+react :: Consumer+react = Nil #->> noneM+ #|| Verb "quit" #->> throwError QuitError+ #|| Verb "commit" :-: Noun "suicide" :-: Nil #->> (do+ eprintLn (Vivid Red) "You stab yourself in the chest, finally dying."+ throwError QuitError)+ #|| Verb "enter" :-: AvailableObject :-: Nil #-> objectTriggerOnEnterOf+ #|| Verb "ascend" #->> changeRoom Up+ #|| Verb "descend" #->> changeRoom Down+ #|| Verb "go" :-: CatchFixe :-: Nil #-> (\d -> changeRoom $ case d of+ "north" -> North+ "south" -> South+ "east" -> East+ "west" -> West+ "northeast" -> NorthEast+ "northwest" -> NorthWest+ "southeast" -> SouthEast+ "southwest" -> SouthWest+ "up" -> Up+ "down" -> Down)+ #|| Verb "list" :-: Fixe "exits" :-: Nil #->> (do+ s <- getDungeonState+ let (Just r) = currentRoomOf s+ forM_ (listEdges r $ roomsOf s) $ \(l,c,n) -> do+ b <- pathPrerequisiteOf c+ mprint " " >> mprint (show l) >> mprint " -> "+ mprint =<< withRoom n getRoomTitle+ if not b then mprintLn " (locked)"+ else mprintLn "")+ #|| Verb "list" :-: Fixe "inventory" :-: Nil #->> (do+ ps <- getPlayerState+ mprintLn "Your inventory:"+ forM_ (avlInorder $ playerInventoryOf ps) $ \os -> mprintLn $ printf " %s" $ unpack $ objectTitleOf os)+ #|| Verb "list" :-: Fixe "score" :-: Nil #->> (do+ [str, agi, sta, int, spi, arm, akp] <- mapM calcStat [Strength, Agility, Stamina, Intelligence, Spirit, Armor, AttackPower]+ [hst, gcd] <- mapM calcStat [Haste, CooldownDuration]+ mprintLn $ printf "Strength: %5i Agility: %5i" str agi+ mprintLn $ printf "Intelligence: %5i Spirit: %5i" int spi+ mprintLn $ printf "Stamina: %5i Armor: %5i" sta arm+ mprintLn $ printf "Attack power: %5i Haste: %5i" akp hst+ mprintLn $ printf "Global cooldown: %5i" gcd)+ #|| Verb "equip" :-: CarriedObject :-: Nil #-> (equipObject >=> \o -> case o of+ Nothing -> noneM+ Just o -> modifyPlayerState $ \s -> s{playerInventoryOf=avlInsert o $ playerInventoryOf s})+ #|| Verb "equip" :-: CarriedObject :-: Prep "at" :-: Remaining :-: Nil #-> (\(o,ps) -> do+ k <- case ps of+ ["main","hand"] -> return MainHand+ ["off","hand"] -> return OffHand+ ["chest"] -> return Chest+ ["feet"] -> return Feet+ ["wrists"] -> return Wrists+ ["waist"] -> return Waist+ ["head"] -> return Head+ ["legs"] -> return Legs+ ["back"] -> return Back+ ["hands"] -> return Hands+ ["neck"] -> return Neck+ ["right","finger"] -> return Finger1+ ["left","finger"] -> return Finger2+ _ -> throwError UnintellegibleError+ equipObjectAt k o >>= \o -> case o of+ Nothing -> noneM+ Just o -> modifyPlayerState $ \s -> s{playerInventoryOf=avlInsert o $ playerInventoryOf s})+ #|| Verb "list" :-: Fixe "equipment" :-: Nil #->> (+ 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:")+ #|| Verb "acquire" :-: SeenObject :-: Nil #-> acquireObject . objectIdOf+ #|| Verb "drop" :-: CarriedObject :-: Nil #-> dropObject . objectIdOf
src/Game/Antisplice/Monad/Dungeon.hs view
@@ -64,9 +64,10 @@ -- * Stereotypes PlayerStereo (..), CooldownId (..),- SkillParam (..), GetterResponse (..),- Getters(..),+ Invokable,+ InvokableP,+ RecipeMethod(..), -- * Dungeons DungeonState (..), currentRoomOf,@@ -103,7 +104,7 @@ import Debug.Trace -- | Matches any 'MonadDungeon' context-type DungeonM a = forall m.(MonadDungeon m) => m a+type DungeonM a = forall m.(MonadDungeon m,MonadError SplErr m,MonadVocab 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,MonadExpand m,ExpanderEnv m,MonadDungeon m,MonadError SplErr m,MonadAtoms m,MonadClock m,MonadVocab m,MonadRandom m,Broadcaster PlayerId m) => m a -- | The common type of all event handlers.@@ -307,10 +308,17 @@ getObjectState = Object $ \s -> return (s,s) putObjectState s = Object $ \_ -> return ((),s) +-- | Some handler that may be invoked by the user+type Invokable = [String] -> HandlerBox++-- | Some prerequisite that may be invoked by the user+type InvokableP = [String] -> PrerequisiteBox+ -- | A player stereotype data PlayerStereo = PlayerStereo { stereoCalcStatBonus :: (StatKey -> Int) -> StatKey -> Int,- stereoSkillBonus :: String -> Maybe (SkillParam -> HandlerBox)+ stereoSkillBonus :: String -> Maybe Invokable,+ stereoRecipeBonus :: String -> Maybe (RecipeMethod -> Invokable) } deriving Typeable -- | Phantom ID type for players@@ -326,28 +334,12 @@ currencyNameOf :: String } deriving (Ord,Eq) --- | Parameter for skill invocation-data SkillParam = SkillParam {- paramGettersOf :: Getters,- paramDirectOf :: Maybe Token,- paramAtOf :: Maybe Token,- paramOnOf :: Maybe Token- }+-- | Method of using recipes+data RecipeMethod = RecipeMethod Int deriving (Eq,Ord) -- | Response of an object getter data GetterResponse = Found ObjectState | TooMany | NoneFound --- | Tuple of object getters-data Getters = Getters {- getAvailableObject :: Token -> GetterResponse,- getCarriedObject :: Token -> GetterResponse,- getSeenObject :: Token -> GetterResponse- }--instance None SkillParam where- none = SkillParam none none none none-instance None Getters where- none = Getters (return none) (return none) (return none) instance None GetterResponse where none = NoneFound
src/Game/Antisplice/Monad/Vocab.hs view
@@ -40,7 +40,7 @@ | Skilln String | Nounc [String] (Maybe Int) String -- ^ Complex noun, with attributes and maybe ordinal index.- deriving Show+ deriving (Eq,Show) -- | The vocab monad. Carries the currently noun vocab as its state. newtype VocabT m a = Vocab { runVocabT :: TST Token -> m (a,TST Token) }
src/Game/Antisplice/Rooms.hs view
@@ -124,6 +124,7 @@ import Data.Text (pack,unpack) import Data.Maybe import Data.List+import Data.Char import Data.Time.Clock import Text.Printf @@ -660,29 +661,46 @@ prnum Nothing Nothing i = show i prnum (Just d) Nothing i = show (i `div` d) prnum Nothing (Just m) i = let exp s l = replicate (l-length s) '0' ++ s in exp (show (i `mod` m)) (length $ show (m-1))- prnum (Just d) (Just m) i = prnum (Just d) Nothing i ++ "." ++ prnum (Just m) Nothing i- replace :: (MonadPrinter m,MonadDungeon m) => String -> Maybe Int -> Maybe Int -> m ()- replace "health" d m = liftM (prnum d m . joinMaybe . avlLookup Health . playerCurrenciesOf) getPlayerState >>= mprint- replace "ohealth" d m = do+ prnum (Just d) (Just m) i = prnum (Just d) Nothing i ++ "." ++ prnum Nothing (Just m) i+ prstr Nothing Nothing s = s+ prstr (Just d) _ s = take d s+ prstr Nothing (Just m) s = drop m s+ numfun (Just "inc") i = i + 1+ numfun (Just "dec") i = i - 1+ numfun Nothing i = i+ numfun _ _ = 0+ strfun (Just "up") s = map toUpper s+ strfun (Just "down") s = map toLower s+ strfun (Just "capital") "" = ""+ strfun (Just "capital") (s:ss) = toUpper s : ss+ strfun Nothing s = s+ strfun _ _ = ""+ replace :: (MonadPrinter m,MonadDungeon m) => String -> Maybe Int -> Maybe Int -> Maybe String -> m ()+ replace "health" d m f = liftM (prnum d m . numfun f . joinMaybe . avlLookup Health . playerCurrenciesOf) getPlayerState >>= mprint+ replace "ohealth" d m f = do i <- liftM playerOpponentOf getPlayerState o <- withObject i getObjectState- mprint $ prnum d m $ objectCurHealthOf o- replace "otitle" _ _ = do+ mprint $ prnum d m $ numfun f $ objectCurHealthOf o+ replace "otitle" d m f = do i <- liftM playerOpponentOf getPlayerState o <- withObject i getObjectState- mprint $ unpack $ objectTitleOf o- replace s d m = do+ mprint $ prstr d m $ strfun f $ unpack $ objectTitleOf o+ replace s d m f = do cs <- liftM (avlInorder . currenciesOf) getDungeonState case filter ((==s).currencyNameOf) cs of [] -> return ()- [c] -> liftM (prnum d m . joinMaybe . avlLookup (currencyIdOf c) . playerCurrenciesOf) getPlayerState >>= mprint+ [c] -> liftM (prnum d m . numfun f . joinMaybe . avlLookup (currencyIdOf c) . playerCurrenciesOf) getPlayerState >>= mprint cs -> mprintLn $ concat $ map currencyNameOf cs+ (cm,nmc)+ | '!' `elem` nm = (Just $ takeWhile (/='!') nm, tail $ dropWhile (/='!') nm)+ | otherwise = (Nothing, nm) (nm1,dm1,mm1)- | '/' `elem` nm = (takeWhile (/='/') nm, Just $ read $ tail $ dropWhile (/='/') nm, Nothing)- | '%' `elem` nm = (takeWhile (/='%') nm, Nothing, Just $ read $ tail $ dropWhile (/='%') nm)- | otherwise = (nm,Nothing,Nothing)+ | '/' `elem` nmc = (takeWhile (/='/') nmc, Just $ read $ tail $ dropWhile (/='/') nmc, Nothing)+ | '%' `elem` nmc = (takeWhile (/='%') nmc, Nothing, Just $ read $ tail $ dropWhile (/='%') nmc)+ | '.' `elem` nmc = let xz = Just $ read $ tail $ dropWhile (/='.') nmc in (takeWhile (/='.') nmc, xz, xz)+ | otherwise = (nmc,Nothing,Nothing) in do- replace nm1 dm1 mm1+ replace nm1 dm1 mm1 cm expandDun rm expandDun ('#':ss) = let (nm,rm) = (takeWhile isAnum &&& dropWhile isAnum) ss
src/Game/Antisplice/Skills.hs view
@@ -24,31 +24,38 @@ -- | Provides utility functions for composing skills module Game.Antisplice.Skills ( -- * Utility types- Condition,- Consumer,+ Condition(..),+ Consumer(..), Skill (..),+ Recipe (..), ToConsumer (toConsumer), -- * Compositors- (!+), (>!+), (!+>), (>!+>),- -- * Skill builders+ Extensible(..),+ (>!+), (!+>), (>!+>),+ -- * Builders skill,- bareAction,- bareCondition,+ recipe,+ validConsumer,+ validCondition,+ (#->),+ (#->>), -- * Sample consumers focusDirectC, optionallyFocusDirectC,+ callRecipe, -- * Final wrappers- runSkill,+ runConsumer, wrapSkills,- -- * Misc- dispget+ wrapRecipes, ) where import Control.Arrow import Control.Monad+import Control.Monad.Identity import Control.Monad.Error.Class import Data.Monoid import Game.Antisplice.Action+import Game.Antisplice.Call import Game.Antisplice.Errors import Game.Antisplice.Monad.Dungeon import Game.Antisplice.Monad.Vocab@@ -59,28 +66,30 @@ import Game.Antisplice.Utils.Atoms -- | A wrapper type for skill execution preconditions.-newtype Condition = Condition { runCondition :: SkillParam -> Prerequisite }+newtype Condition = Condition { runCondition' :: InvokableP }+runCondition :: Condition -> [String] -> ChattyDungeonM Bool+runCondition c ps = runPrerequisite $ runCondition' c ps instance Monoid Condition where- mempty = Condition $ \_ -> return True- a `mappend` b = Condition $ \p -> do- a' <- runCondition a p- b' <- runCondition b p+ mempty = Condition $ \_ -> Prerequisite $ return True+ a `mappend` b = Condition $ \ps -> Prerequisite $ do+ a' <- runCondition a ps+ b' <- runCondition b ps return (a' && b') instance IsAction Condition where- p #&& q = Condition $ \x -> do- a <- runCondition p x- if a then runCondition q x+ p #&& q = Condition $ \ps -> Prerequisite $ do+ a <- runCondition p ps+ if a then runCondition q ps else return False- p #|| q = Condition $ \x -> do- a <- runCondition p x+ p #|| q = Condition $ \ps -> Prerequisite $ do+ a <- runCondition p ps if a then return True- else runCondition q x+ else runCondition q ps p !&& q = p <> q- p !|| q = Condition $ \x -> do- a <- runCondition p x- b <- runCondition q x+ p !|| q = Condition $ \ps -> Prerequisite $ do+ a <- runCondition p ps+ b <- runCondition q ps return (a || b) instance None Condition where@@ -89,41 +98,55 @@ -- | A skill. Build it using the '!+' compositor and the 'skill' function. data Skill = Skill { skillConditionOf :: !Condition,- skillActionOf :: !(SkillParam -> Handler),+ skillActionOf :: !Invokable, skillNameOf :: !String } +-- | A recipe. Build it using the '!+' compositor and the 'recipe' function.+data Recipe = Recipe {+ recipeConditionOf :: !Condition,+ recipeActionOf :: !Invokable,+ recipeMethodOf :: !RecipeMethod,+ recipeNameOf :: !String+ }+ -- | A single consumer. Build it using 'bareAction', 'bareCondition' and monoid concatenation.-data Consumer = Consumer !Condition !(SkillParam -> Handler)+data Consumer = Consumer !Condition !Invokable instance Monoid Consumer where- mempty = Consumer none (const noneM)- (Consumer c1 a1) `mappend` (Consumer c2 a2) = Consumer (c1 <> c2) (\p -> a1 p >> a2 p)+ mempty = Consumer none noneM+ (Consumer c1 a1) `mappend` (Consumer c2 a2) = Consumer (c1 <> c2) (\ps -> Handler (runHandler (a1 ps) >> runHandler (a2 ps))) 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)+ (Consumer c1 a1) #&& (Consumer c2 a2) = Consumer (c1 #&& c2) (\ps -> Handler (runHandler (a1 ps) >> runHandler (a2 ps)))+ (Consumer c1 a1) #|| (Consumer c2 a2) = Consumer (c1 #|| c2) (\ps -> Handler (runCondition c1 ps >>= \q -> if q then runHandler (a1 ps) else runHandler (a2 ps))) 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)+ (Consumer c1 a1) !|| (Consumer c2 a2) = Consumer (c1 !|| c2) (\ps -> Handler (runCondition c1 ps >>= \q -> runCondition c2 ps >> if q then runHandler (a1 ps) else runHandler (a2 ps))) instance None Consumer where none = mempty -- | Focus direct object focusDirectC :: Consumer-focusDirectC = bareAction (\p -> case p of- SkillParam Getters{..} (Just o) _ _ -> focusOpponent =<< return.objectIdOf =<< dispget getSeenObject o- _ -> throwError UnintellegibleError)+{-focusDirectC = bareAction (\p -> case p of+ SkillParam Getters{..} (Just o) _ _ _ _ -> focusOpponent =<< return.objectIdOf =<< dispget getSeenObject o+ _ -> throwError UnintellegibleError)-}+focusDirectC = validConsumer SeenObject $ \o -> focusOpponent $ objectIdOf o -- | Optionally ocus direct object (obligatory if none is focused yet) optionallyFocusDirectC :: Consumer-optionallyFocusDirectC = bareAction (\p -> case p of- SkillParam Getters{..} (Just o) _ _ -> focusOpponent =<< return.objectIdOf =<< dispget getSeenObject o- SkillParam _ Nothing _ _ -> do+{-optionallyFocusDirectC = bareAction (\p -> case p of+ SkillParam Getters{..} (Just o) _ _ _ _ -> focusOpponent =<< return.objectIdOf =<< dispget getSeenObject o+ SkillParam _ Nothing _ _ _ _ -> do o <- liftM playerOpponentOf getPlayerState case o of FalseObject -> throwError UnintellegibleError- _ -> noneM)+ _ -> noneM)-}+optionallyFocusDirectC = focusDirectC #|| validConsumer Nil (\_ -> 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@@ -135,79 +158,127 @@ 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 Recipe where+ toConsumer (Recipe c a m n) = Consumer c a -instance ToConsumer (SkillParam -> HandlerBox) where- toConsumer t = Consumer none (runHandler . t)+instance ToConsumer HandlerBox where+ toConsumer t = Consumer none (\_ -> t) instance ToConsumer Condition where- toConsumer c = Consumer c (const noneM)+ toConsumer c = Consumer c (\_ -> Handler $ return none) instance ToConsumer PrerequisiteBox where- toConsumer p = Consumer (Condition $ \_ -> runPrerequisite p) (const noneM)+ toConsumer p = Consumer (Condition $ \_ -> p) (\_ -> Handler $ return none) instance ToConsumer Action where- toConsumer a = Consumer (Condition $ \_ -> askAction a) (\_ -> runAction a)+ toConsumer a = Consumer (Condition $ \_ -> Prerequisite $ askAction a) (\_ -> Handler $ 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+-- | Typeclass for everything that may be extended by consumers using !++class Extensible e where+ infixl 5 !++ -- | Add a consumer to the skill.+ (!+) :: ToConsumer c => e -> c -> e +instance Extensible Skill where + s !+ c = s !+! toConsumer c+ where (Skill c a n) !+! (Consumer c1 a1) = Skill (c <> c1) (\ps -> Handler (runHandler (a ps) >> runHandler (a1 ps))) n++instance Extensible Recipe where+ s !+ c = s !+! toConsumer c+ where (Recipe c a m n) !+! (Consumer c1 a1) = Recipe (c <> c1) (\ps -> Handler (runHandler (a ps) >> runHandler (a1 ps))) m n++instance Extensible Consumer where+ s !+ c = s <> toConsumer c+ infixl 5 >!+--- | Add a consumer to the monadic skill-(>!+) :: (ToConsumer c,Monad m) => m Skill -> c -> m Skill+-- | Add a consumer to the monadic extensible+(>!+) :: (ToConsumer c,Monad m,Extensible e) => m e -> c -> m e 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+-- | Add a monadic consumer to the extensible+(!+>) :: (ToConsumer c,Monad m,Extensible e) => e -> m c -> m e 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+-- | Add a monadic consumer to the monadic extensible+(>!+>) :: (ToConsumer c,Monad m,Extensible e) => m e -> m c -> m e 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 using new-style input validation+validConsumer :: (Append r Nil r,CallMask m r,Tuplify r t) => m -> (t -> Handler) -> Consumer+validConsumer m h = Consumer+ (Condition $ \ps -> Prerequisite $ tryMask m ps)+ (\ps -> Handler $ do+ t <- processMask m ps+ h t) --- | Build a consumer from a condition.-bareCondition :: (SkillParam -> ChattyDungeonM Bool) -> Consumer-bareCondition = toConsumer.Condition+infixr 7 #->+-- | Infix version of validConsumer+(#->) :: (Append r Nil r, CallMask m r, Tuplify r t) => m -> (t -> Handler) -> Consumer+(#->) = validConsumer +infixr 7 #->>+-- | Infix version of validConsumer, swallowing the empty handler parameter+(#->>) :: CallMask m Nil => m -> Handler -> Consumer+m #->> h = m #-> const h++-- | Build a condition using new-style input validation+validCondition :: (Append r Nil r, CallMask m r, Tuplify r t) => m -> (t -> Prerequisite) -> Condition+validCondition m p =+ Condition (\ps -> Prerequisite $ tryMask m ps) <>+ Condition (\ps -> Prerequisite $ do t <- processMask m ps; p t)++-- | Dispatch the remaining part of the line as a recipe call+callRecipe :: RecipeMethod -> Consumer+{-callRecipe m = Consumer none (\f ps -> Handler $ case ps of+ [] -> throwError UnintellegibleError+ p:ps -> do+ ste <- totalStereo+ case stereoRecipeBonus ste p of+ Nothing -> throwError CantCastThatNowError+ Just r -> runHandler $ r m f ps)-}+callRecipe m = CatchAny :-: Remaining :-: Nil #->+ \(p,ps) -> do+ ste <- totalStereo+ case stereoRecipeBonus ste p of+ Nothing -> throwError CantCastThatNowError+ Just r -> runHandler $ r m ps+ -- | 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)+skill = Skill none noneM +-- | Build a bogus recipe that does nothing has a name and a usage method. Use this with '!+' to build powerful recipes.+recipe :: RecipeMethod -> String -> Recipe+recipe = Recipe none noneM+ -- | Wrap the skills into a form that is accepted by stereotypes.-wrapSkills :: [Skill] -> String -> Maybe (SkillParam -> HandlerBox)+wrapSkills :: [Skill] -> String -> Maybe Invokable 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+ sk:_ -> Just $ runConsumer sk --- | Dispatch the getter to the underlying monad-dispget :: MonadError SplErr m => (Token -> GetterResponse) -> Token -> m ObjectState-dispget f t =- case f t of- NoneFound -> throwError CantSeeOneError- TooMany -> throwError WhichOneError- Found x -> return x+-- | Wrap the recipes into a form that is accepted by stereotypes.+wrapRecipes :: [Recipe] -> String -> Maybe (RecipeMethod -> Invokable)+wrapRecipes sk n =+ case filter ((==n).recipeNameOf) sk of+ [] -> Nothing+ sk:_ -> Just $ \m -> if m == recipeMethodOf sk then runConsumer sk else \_ -> Handler $ throwError WrongMethodError++-- | Run the given consumer+runConsumer :: ToConsumer c => c -> Invokable+runConsumer c = runConsumer' $ toConsumer c+ where runConsumer' :: Consumer -> Invokable+ runConsumer' (Consumer c a) = \ps -> Handler $ do+ b <- runCondition c ps+ unless b $ throwError CantCastThatNowError+ runHandler $ a ps
src/Game/Antisplice/Stats.hs view
@@ -82,11 +82,14 @@ return $ mconcat stes instance Monoid PlayerStereo where- mempty = PlayerStereo (\_ _ -> 0) (\_ -> Nothing)+ mempty = PlayerStereo (\_ _ -> 0) (\_ -> Nothing) (\_ -> 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)+ (\s -> case stereoRecipeBonus a s of+ Nothing -> stereoRecipeBonus b s Just b -> Just b) instance None PlayerStereo where
src/Game/Antisplice/Stereos.hs view
@@ -37,7 +37,9 @@ mergeStereo, mergeStereoM, mergeSkill,+ mergeRecipe, mergeSkillM,+ mergeRecipeM, -- * Default stereos defaultStereo, visualStereo,@@ -51,6 +53,7 @@ import Control.Arrow import Data.Monoid import Game.Antisplice.Action+import Game.Antisplice.Call import Game.Antisplice.Errors import Game.Antisplice.Monad.Dungeon import Game.Antisplice.Monad.Vocab@@ -80,18 +83,28 @@ -- | Create a stereotype that carries a stats modifier statsStereo :: ((StatKey -> Int) -> StatKey -> Int) -> PlayerStereo-statsStereo m = PlayerStereo m (const none)+statsStereo m = PlayerStereo m (const none) (const none) -- | Create a stereotype that carries skills skillsStereo :: [Skill] -> PlayerStereo-skillsStereo sk = PlayerStereo (\_ _ -> 0) $ wrapSkills sk+skillsStereo sk = PlayerStereo (\_ _ -> 0) (wrapSkills sk) (const none) +-- | Create a stereotype that carries recipes+recipesStereo :: [Recipe] -> PlayerStereo+recipesStereo rp = PlayerStereo (\_ _ -> 0) (const none) (wrapRecipes rp)+ -- | 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] +-- | Create a stereotype that carries a skill from a monadic composition+recipeStereoM :: Monad m => m Recipe -> m PlayerStereo+recipeStereoM m = do+ rp <- m+ return $ recipesStereo [rp]+ -- | For monadic stereotype construction newtype StereoBuilderT m a = StereoBuilder { runStereoBuilderT :: PlayerStereo -> m (a,PlayerStereo) } @@ -127,6 +140,18 @@ sk <- lift m mergeSkill sk +-- | Merge the given pure recipe into the built stereotype+mergeRecipe :: MonadVocab m => Recipe -> StereoBuilderT m ()+mergeRecipe rp = do+ insertVocab (recipeNameOf rp) Noun+ mergeStereo $ recipesStereo [rp]++-- | Merge the given monadic recipe into the built stereotype+mergeRecipeM :: MonadVocab m => m Recipe -> StereoBuilderT m ()+mergeRecipeM m = do+ rp <- lift m+ mergeRecipe rp+ -- | Process the builder chain and register the resulting stereotype registerStereoM :: MonadAtoms m => StereoBuilderT m () -> m (Atom PlayerStereo) registerStereoM m = do@@ -143,22 +168,14 @@ AttackPower -> get Strength * 2 CooldownDuration -> (get CooldownDuration ^ 2) `div` (get CooldownDuration + get Haste) - get CooldownDuration _ -> 0- mergeSkill $ skill "use" !+ bareAction (\p ->- case p of- SkillParam Getters{..} (Just o) Nothing Nothing -> objectTriggerOnUseOf =<< dispget getAvailableObject o- _ -> throwError UnintellegibleError)+ mergeSkill $ skill "use" !+ validConsumer AvailableObject objectTriggerOnUseOf visualStereo :: MonadVocab m => m PlayerStereo visualStereo = liftM snd $ flip runStereoBuilderT none $ do- mergeSkill $ skill "look" !+ bareAction (\p ->- case p of- SkillParam Getters{..} Nothing Nothing Nothing -> roomTriggerOnLookOf =<< getRoomState- SkillParam Getters{..} Nothing (Just n) Nothing -> objectTriggerOnLookAtOf =<< dispget getAvailableObject n- _ -> throwError UnintellegibleError)- mergeSkill $ skill "read" !+ bareAction (\p ->- case p of- SkillParam Getters{..} (Just n) Nothing Nothing -> objectTriggerOnReadOf =<< dispget getAvailableObject n- _ -> throwError UnintellegibleError)+ mergeSkill $ skill "look" !++ validConsumer Nil (\_ -> roomTriggerOnLookOf =<< getRoomState) #||+ validConsumer (Prep "at" :-: AvailableObject :-: Nil) objectTriggerOnLookAtOf+ mergeSkill $ skill "read" !+ validConsumer AvailableObject objectTriggerOnReadOf manualStereo :: MonadVocab m => m PlayerStereo manualStereo = liftM snd $ flip runStereoBuilderT none $ do@@ -166,11 +183,5 @@ consumeStereo :: MonadVocab m => m PlayerStereo consumeStereo = liftM snd $ flip runStereoBuilderT none $ do- mergeSkill $ skill "drink" !+ bareAction (\p ->- case p of- SkillParam Getters{..} (Just o) Nothing Nothing -> objectTriggerOnDrinkOf =<< dispget getAvailableObject o- _ -> throwError UnintellegibleError)- mergeSkill $ skill "eat" !+ bareAction (\p ->- case p of- SkillParam Getters{..} (Just o) Nothing Nothing -> objectTriggerOnEatOf =<< dispget getAvailableObject o- _ -> throwError UnintellegibleError)+ mergeSkill $ skill "drink" !+ validConsumer AvailableObject objectTriggerOnDrinkOf+ mergeSkill $ skill "eat" !+ validConsumer AvailableObject objectTriggerOnEatOf