module Game.Antisplice.Monad.Dungeon (
DungeonM,
ChattyDungeonM,
Trigger,
TriggerBox (..),
IsText (..),
Direction (..),
RoomState (..),
RoomT (..),
MonadRoom (..),
StatKey (..),
EquipKey (..),
Implication (..),
Feature (..),
ObjectId (..),
ObjectState (..),
ObjectT (..),
MonadObject (..),
Faction (..),
Attitude (..),
PlayerStereo (..),
PlayerState (..),
PlayerT (..),
MonadPlayer (..),
DungeonState (..),
currentRoomOf,
DungeonT (..),
MonadDungeon (..)
) where
import Text.Chatty.Printer
import Text.Chatty.Scanner
import Text.Chatty.Expansion
import System.Chatty.Misc
import Text.Chatty.Extended.Printer
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.Monad.Vocab
import Control.Arrow
import Control.Monad.Error
import Control.Monad.Trans.Class
import Control.Comonad
import Data.Text
import Control.Monad
import Data.Time.Clock
import Data.Typeable
type DungeonM a = forall m.(MonadDungeon m) => m a
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 Trigger = ChattyDungeonM ()
newtype TriggerBox = TriggerBox { runTrigger :: Trigger }
data StatKey = Strength
| Agility
| Stamina
| Intelligence
| Spirit
| Armor
| AttackPower
deriving (Ord,Eq)
data EquipKey = MainHand | OffHand | Chest | Feet | Wrists | Waist | Head | Legs | Back | Hands | Neck | Finger1 | Finger2 deriving (Ord,Eq)
data RoomState = RoomState {
roomTitleOf :: !Text,
roomObjectsOf :: AVL ObjectState,
roomTriggerOnFirstEnterOf :: Trigger,
roomTriggerOnEachEnterOf :: Trigger,
roomTriggerOnLeaveOf :: Trigger,
roomTriggerOnLookOf :: Trigger,
roomTriggerOnAnnounceOf :: Trigger
}
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 :: Trigger,
factionTriggerOnFriendlyOf :: Trigger,
factionTriggerOnExaltedOf :: Trigger
}
data Attitude = Hostile | Friendly | Exalted deriving (Eq,Ord)
data Implication = DescSeg (Atom String)
| StereoSeg (Atom PlayerStereo)
data Feature = Damagable
| Acquirable
| Equipable EquipKey
| Mobile
deriving (Ord,Eq)
data ObjectId = ObjectId Int | FalseObject deriving (Eq,Ord)
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,
objectStatsOf :: AVL (StatKey,Int),
objectRouteOf :: ![NodeId],
objectFeaturesOf :: AVL (Feature,()),
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
} 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
} deriving Typeable
data PlayerState = PlayerState {
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)
}
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 ()
instance Monad m => MonadPlayer (PlayerT m) where
getPlayerState = Player $ \s -> return (s,s)
putPlayerState s = Player $ \_ -> return ((),s)
data Direction = North | NorthEast | East | SouthEast | South | SouthWest | West | NorthWest | Up | Down deriving (Eq,Show)
data DungeonState = DungeonState {
roomsOf :: Graph RoomState Direction,
playerOf :: Maybe PlayerState,
timeTriggersOf :: AVL (NominalDiffTime,TriggerBox)
}
currentRoomOf = fmap playerRoomOf . playerOf
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 ((),s{playerOf=Just s'})
class (MonadRoom m,MonadPlayer m) => MonadDungeon m where
getDungeonState :: m DungeonState
putDungeonState :: DungeonState -> m ()
instance Monad m => MonadDungeon (DungeonT m) where
getDungeonState = Dungeon $ \s -> return (s,s)
putDungeonState s = Dungeon $ \_ -> return ((),s)