module Game.Antisplice.Monad.Dungeon (
DungeonM,
ChattyDungeonM,
Handler,
HandlerBox (..),
Prerequisite,
PrerequisiteBox (..),
IsText (..),
Direction (..),
RoomState (..),
RoomT (..),
MonadRoom (..),
PathState (..),
StatKey (..),
EquipKey (..),
Relation (..),
Feature (..),
ObjectId (..),
ObjectState (..),
ObjectT (..),
MonadObject (..),
Faction (..),
Attitude (..),
Currency (..),
CurrencyId (..),
DamageTarget (..),
PlayerId (..),
PlayerState (..),
PlayerT (..),
MonadPlayer (..),
PlayerStereo (..),
CooldownId (..),
SkillParam (..),
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.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) => 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 }
instance None HandlerBox where
none = Handler $ return ()
instance None PrerequisiteBox where
none = Prerequisite $ return True
data StatKey = Strength
| Agility
| Stamina
| Intelligence
| Spirit
| Armor
| Haste
| CooldownDuration
| AttackPower
deriving (Ord,Eq)
data EquipKey = MainHand | OffHand | Chest | Feet | Wrists | Waist | Head | Legs | Back | Hands | Neck | Finger1 | Finger2 deriving (Ord,Eq)
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
}
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
}
data Attitude = Hostile | Friendly | Exalted deriving (Eq,Ord)
data Relation = Near | Carried | Worn deriving (Ord,Eq)
data Feature = Damagable
| Acquirable
| Equipable EquipKey
| Redeemable Currency Int
| AutoRedeem Currency Int
| Weighty Int
| Played PlayerId
| Mobile
| Stereo Relation (Atom PlayerStereo)
| Described (Atom String)
deriving (Ord,Eq)
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 None ObjectId where
none = FalseObject
data DamageTarget = TargetPlayer PlayerId | TargetObject ObjectId
data ObjectState = ObjectState {
objectIdOf :: !ObjectId,
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
} deriving Typeable
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)
data PlayerStereo = PlayerStereo {
stereoCalcStatBonus :: (StatKey -> Int) -> StatKey -> Int,
stereoSkillBonus :: String -> Maybe (SkillParam -> HandlerBox)
} deriving Typeable
newtype PlayerId = PlayerId Int deriving (Eq,Ord)
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 SkillParam = SkillParam {
paramDirectOf :: Maybe ObjectState,
paramAtOf :: Maybe ObjectState,
paramOnOf :: Maybe ObjectState
}
instance None SkillParam where
none = SkillParam Nothing Nothing Nothing
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)
}
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)
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)