module Game.Antisplice.Monad.Dungeon (
DungeonM,
ChattyDungeonM,
Handler,
HandlerBox (..),
Prerequisite,
PrerequisiteBox (..),
Predicate,
PredicateBox (..),
IsText (..),
Direction (..),
RoomState (..),
RoomT (..),
MonadRoom (..),
PathState (..),
StatKey (..),
EquipKey (..),
Relation (..),
Feature (..),
ObjectId (..),
KindId (..),
ObjectState (..),
ObjectT (..),
MonadObject (..),
Faction (..),
Attitude (..),
Currency (..),
CurrencyId (..),
DamageTarget (..),
PlayerId (..),
PlayerState (..),
PlayerT (..),
MonadPlayer (..),
PlayerStereo (..),
CooldownId (..),
GetterResponse (..),
Invokable,
InvokableP,
RecipeMethod(..),
DungeonState (..),
currentRoomOf,
playerOf,
DungeonT (..),
MonadDungeon (..)
) where
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 Text.Chatty.Channel.Printer
import Text.Chatty.Channel.Broadcast
import Game.Antisplice.Utils.Graph
import Game.Antisplice.Utils.BST
import Game.Antisplice.Utils.AVL
import Game.Antisplice.Utils.Atoms
import Game.Antisplice.Errors
import Game.Antisplice.Utils.Fail
import Game.Antisplice.Utils.Counter
import Game.Antisplice.Utils.None
import Game.Antisplice.Utils.Focus
import Game.Antisplice.Utils.Hetero
import Game.Antisplice.Monad.Vocab
import Control.Arrow
import Control.Monad.Error
import Control.Monad.Trans.Class
import Data.Text
import Control.Monad
import Data.Time.Clock
import Data.Typeable
import Debug.Trace
type DungeonM a = forall m.(MonadDungeon m,MonadError SplErr 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,Broadcaster PlayerId m) => m a
type Handler = ChattyDungeonM ()
newtype HandlerBox = Handler { runHandler :: Handler }
type Prerequisite = ChattyDungeonM Bool
newtype PrerequisiteBox = Prerequisite { runPrerequisite :: Prerequisite }
type Predicate = ChattyDungeonM (Maybe ReError)
newtype PredicateBox = Predicate { runPredicate :: ChattyDungeonM (Maybe ReError) }
instance None HandlerBox where
none = Handler $ return ()
instance None PrerequisiteBox where
none = Prerequisite $ return True
instance None PredicateBox where
none = Predicate $ return Nothing
data StatKey = Strength
| Agility
| Stamina
| Intelligence
| Spirit
| Armor
| Haste
| CooldownDuration
| AttackPower
deriving (Ord,Eq)
instance Tuplify StatKey StatKey where
tuplify = id
data EquipKey = MainHand | OffHand | Chest | Feet | Wrists | Waist | Head | Legs | Back | Hands | Neck | Finger1 | Finger2 deriving (Ord,Eq)
instance Tuplify EquipKey EquipKey where
tuplify = id
instance Indexable EquipKey EquipKey EquipKey where
type ValueOf EquipKey = EquipKey
type IndexOf EquipKey = EquipKey
indexOf = id
valueOf = id
data RoomState = RoomState {
roomTitleOf :: !Text,
roomObjectsOf :: AVL ObjectState,
roomTriggerOnFirstEnterOf :: Handler,
roomTriggerOnEachEnterOf :: Handler,
roomTriggerOnLeaveOf :: Handler,
roomTriggerOnLookOf :: Handler,
roomTriggerOnAnnounceOf :: Handler
}
instance Tuplify RoomState RoomState where
tuplify = id
newtype RoomT m a = Room { runRoomT :: RoomState -> m (a,RoomState) }
instance Functor m => Functor (RoomT m) where
fmap f a = Room $ \s -> fmap (first f) $ runRoomT a s
instance Monad m => Monad (RoomT m) where
return a = Room $ \s -> return (a,s)
m >>= f = Room $ \s -> do (a,s') <- runRoomT m s; runRoomT (f a) s'
instance MonadTrans RoomT where
lift m = Room $ \s -> do a <- m; return (a,s)
class Monad m => MonadRoom m where
getRoomState :: m RoomState
putRoomState :: RoomState -> m ()
instance Monad m => MonadRoom (RoomT m) where
getRoomState = Room $ \s -> return (s,s)
putRoomState s = Room $ \_ -> return ((),s)
class IsText t where
toText :: t -> Text
fromText :: Text -> t
instance IsText Text where
toText = id
fromText = id
instance IsText String where
toText = pack
fromText = unpack
data Faction = Faction {
factionName :: !Text,
factionTriggerOnHostileOf :: Handler,
factionTriggerOnFriendlyOf :: Handler,
factionTriggerOnExaltedOf :: Handler
}
instance Tuplify Faction Faction where
tuplify = id
data Attitude = Hostile | Friendly | Exalted deriving (Eq,Ord)
instance Tuplify Attitude Attitude where
tuplify = id
data Relation = Near | Carried | Worn deriving (Ord,Eq)
instance Tuplify Relation Relation where
tuplify = id
data Feature = Damagable
| Acquirable
| Usable
| Drinkable
| Eatable
| Equipable EquipKey
| Redeemable Currency Int
| AutoRedeem Currency Int
| Weighty Int
| Played PlayerId
| Mobile
| Stereo Relation (Atom PlayerStereo)
| Described (Atom String)
deriving (Ord,Eq)
instance Tuplify Feature Feature where
tuplify = id
instance Indexable Feature Feature Feature where
type IndexOf Feature = Feature
type ValueOf Feature = Feature
indexOf = id
valueOf = id
data ObjectId = ObjectId Int | FalseObject deriving (Eq,Ord)
instance Tuplify ObjectId ObjectId where
tuplify = id
data KindId = KindId Int | FalseKind deriving (Eq,Ord)
instance Tuplify KindId KindId where
tuplify = id
instance None ObjectId where
none = FalseObject
instance None KindId where
none = FalseKind
data DamageTarget = TargetPlayer PlayerId | TargetObject ObjectId
data ObjectState = ObjectState {
objectIdOf :: !ObjectId,
objectKindOf :: !KindId,
objectTitleOf :: !Text,
objectDescOf :: !Text,
objectNamesOf :: ![String],
objectAttributesOf :: ![String],
objectOnceSeenOf :: !Bool,
objectOnceAcquiredOf :: !Bool,
objectOnceInspectedOf :: !Bool,
objectOnceEquippedOf :: !Bool,
objectMaxHealthOf :: !Int,
objectCurHealthOf :: !Int,
objectRouteOf :: ![NodeId],
objectFeaturesOf :: AVL Feature,
objectFactionOf :: !(Maybe (Atom Faction)),
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,
objectTriggerOnUseOf :: Handler,
objectTriggerOnEatOf :: Handler,
objectTriggerOnDrinkOf :: Handler
} deriving Typeable
instance Tuplify ObjectState ObjectState where
tuplify = id
instance Indexable ObjectState ObjectId ObjectState where
type IndexOf ObjectState = ObjectId
type ValueOf ObjectState = ObjectState
indexOf = objectIdOf
valueOf = id
newtype ObjectT m a = Object { runObjectT :: ObjectState -> m (a,ObjectState) }
instance Functor m => Functor (ObjectT m) where
fmap f a = Object $ \s -> fmap (first f) $ runObjectT a s
instance Monad m => Monad (ObjectT m) where
return a = Object $ \s -> return (a,s)
m >>= f = Object $ \s -> do (a,s') <- runObjectT m s; runObjectT (f a) s'
instance MonadTrans ObjectT where
lift m = Object $ \s -> do a <- m; return (a,s)
class Monad m => MonadObject m where
getObjectState :: m ObjectState
putObjectState :: ObjectState -> m ()
instance Monad m => MonadObject (ObjectT m) where
getObjectState = Object $ \s -> return (s,s)
putObjectState s = Object $ \_ -> return ((),s)
type Invokable = [String] -> HandlerBox
type InvokableP = [String] -> PredicateBox
data PlayerStereo = PlayerStereo {
stereoCalcStatBonus :: (StatKey -> Int) -> StatKey -> Int,
stereoSkillBonus :: String -> Maybe Invokable,
stereoRecipeBonus :: String -> Maybe (RecipeMethod -> Invokable)
} deriving Typeable
newtype PlayerId = PlayerId Int deriving (Eq,Ord)
instance Tuplify PlayerId PlayerId where
tuplify = id
data CooldownId = GlobalCooldown | CooldownId Int deriving (Eq,Ord)
data CurrencyId = Health | CurrencyId Int deriving (Ord,Eq)
data Currency = Currency {
currencyIdOf :: CurrencyId,
currencyDescOf :: String,
currencyNameOf :: String
} deriving (Ord,Eq)
data RecipeMethod = RecipeMethod Int deriving (Eq,Ord)
data GetterResponse = Found ObjectState | TooMany | NoneFound
instance None GetterResponse where
none = NoneFound
data Quest = Quest {
questTitleOf :: !String,
questDescOf :: !String,
questPreconditionOf :: Prerequisite,
questFinishConditionOf :: Prerequisite,
questTriggerOnFinishOf :: Handler
}
data QuestRel = Completed | InProgress | Locked deriving (Ord,Eq)
data PlayerState = PlayerState {
playerIdOf :: !PlayerId,
playerRoomOf :: !NodeId,
playerMaxHealthOf :: !Int,
playerInventoryOf :: AVL ObjectState,
playerEquipOf :: AVL (EquipKey,ObjectState),
playerBaseStatsOf :: AVL (StatKey,Int),
playerStereosOf :: [Atom PlayerStereo],
playerReputationOf :: AVL (Atom Faction,Int),
playerCurrenciesOf :: AVL (CurrencyId,Int),
playerCooldownsOf :: AVL CooldownId,
playerOpponentOf :: !ObjectId,
playerActiveQuestsOf :: AVL (Atom Quest,QuestRel),
playerAlcoholOf :: Int,
playerSoberingActiveOf :: Bool
}
instance Indexable PlayerState PlayerId PlayerState where
type IndexOf PlayerState = PlayerId
type ValueOf PlayerState = PlayerState
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
newtype PlayerT m a = Player { runPlayerT :: PlayerState -> m (a,PlayerState) }
instance Functor m => Functor (PlayerT m) where
fmap f a = Player $ \s -> fmap (first f) $ runPlayerT a s
instance Monad m => Monad (PlayerT m) where
return a = Player $ \s -> return (a,s)
m >>= f = Player $ \s -> do (a,s') <- runPlayerT m s; runPlayerT (f a) s'
instance MonadTrans PlayerT where
lift m = Player $ \s -> do a <- m; return (a,s)
class Monad m => MonadPlayer m where
getPlayerState :: m PlayerState
putPlayerState :: PlayerState -> m ()
modifyPlayerState :: (PlayerState -> PlayerState) -> m ()
modifyPlayerState f = do
s <- getPlayerState
putPlayerState $ f s
instance Monad m => MonadPlayer (PlayerT m) where
getPlayerState = Player $ \s -> return (s,s)
putPlayerState s = Player $ \_ -> return ((),s)
data PathState = PathState {
pathPrerequisiteOf :: Prerequisite,
pathTriggerBeforeWalkOf :: Handler,
pathTriggerAfterWalkOf :: Handler
}
instance None PathState where
none = PathState (return True) noneM noneM
data Direction = North | NorthEast | East | SouthEast | South | SouthWest | West | NorthWest | Up | Down deriving (Eq,Show)
instance Tuplify Direction Direction where
tuplify = id
data DungeonState = DungeonState {
roomsOf :: Graph RoomState Direction PathState,
playersOf :: Focus PlayerState,
timeTriggersOf :: AVL (NominalDiffTime,HandlerBox),
currenciesOf :: AVL Currency
}
instance None DungeonState where
none = DungeonState none none none none
currentRoomOf = fmap playerRoomOf . playerOf
playerOf = anyBstHead . playersOf
newtype DungeonT m a = Dungeon { runDungeonT :: DungeonState -> m (a,DungeonState) }
instance Functor m => Functor (DungeonT m) where
fmap f a = Dungeon $ \s -> fmap (first f) $ runDungeonT a s
instance Monad m => Monad (DungeonT m) where
return a = Dungeon $ \s -> return (a,s)
m >>= f = Dungeon $ \s -> do (a,s') <- runDungeonT m s; runDungeonT (f a) s'
instance MonadTrans DungeonT where
lift m = Dungeon $ \s -> do a <- m; return (a,s)
instance Monad m => MonadRoom (DungeonT m) where
getRoomState = Dungeon $ \s -> case currentRoomOf s of
Just r -> return (getNode r $ roomsOf s,s)
putRoomState s' = Dungeon $ \s -> case currentRoomOf s of
Just r -> return ((),s{roomsOf=setNode r s' $ roomsOf s})
instance Monad m => MonadPlayer (DungeonT m) where
getPlayerState = Dungeon $ \s -> case playerOf s of
Just p -> return (p,s)
putPlayerState s' = Dungeon $ \s -> return (none,s{playersOf=anyBstInsert s' $ playersOf s})
modifyPlayerState f = Dungeon $ \s -> case playerOf s of
Just p -> return ((),s{playersOf=anyBstInsert (f p) $ playersOf s})
Nothing -> return ((),s)
class (MonadRoom m,MonadPlayer m) => MonadDungeon m where
getDungeonState :: m DungeonState
putDungeonState :: DungeonState -> m ()
lowerDungeon :: DungeonT m a -> m a
lowerDungeon m = do
s <- getDungeonState
(a,s') <- runDungeonT m s
putDungeonState s'
return a
instance Monad m => MonadDungeon (DungeonT m) where
getDungeonState = Dungeon $ \s -> return (s,s)
putDungeonState s = Dungeon $ \_ -> return ((),s)