Dungeon.hs

{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, RankNTypes, FlexibleContexts, TypeFamilies, DeriveDataTypeable #-}

{-
  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 the basic data types and monads for Antisplice.
module Game.Antisplice.Monad.Dungeon (
    -- * Context quantifiers
    DungeonM,
    ChattyDungeonM,
    Handler,
    HandlerBox (..),
    Prerequisite,
    PrerequisiteBox (..),
    -- * Utilities
    IsText (..),
    Direction (..),
    -- * Rooms
    RoomState (..),
    RoomT (..),
    MonadRoom (..),
    PathState (..),
    -- * Objects
    StatKey (..),
    EquipKey (..),
    Relation (..),
    Feature (..),
    ObjectId (..),
    ObjectState (..),
    ObjectT (..),
    MonadObject (..),
    -- * Factions
    Faction (..),
    Attitude (..),
    -- * Currencies
    Currency (..),
    CurrencyId (..),
    -- * Fight
    DamageTarget (..),
    -- * Players
    PlayerId (..),
    PlayerState (..),
    PlayerT (..),
    MonadPlayer (..),
    -- * Stereotypes
    PlayerStereo (..),
    CooldownId (..),
    SkillParam (..),
    -- * Dungeons
    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

-- | 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,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.
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
             | Stamina
             | Intelligence
             | Spirit
             | Armor
             | Haste
             | CooldownDuration
             | AttackPower
             deriving (Ord,Eq)
-- | Key for equipment slot
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

-- | State type for RoomT
data RoomState = RoomState {
    roomTitleOf :: !Text,
    roomObjectsOf :: AVL ObjectState,
    roomTriggerOnFirstEnterOf :: Handler,
    roomTriggerOnEachEnterOf :: Handler,
    roomTriggerOnLeaveOf :: Handler,
    roomTriggerOnLookOf :: Handler,
    roomTriggerOnAnnounceOf :: Handler
  }

-- | The room monad. Used to create or modify room data.
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)

-- | Typeclass for all room monads.
class Monad m => MonadRoom m where
  -- | Get the room state
  getRoomState :: m RoomState
  -- | Put the room state
  putRoomState :: RoomState -> m ()

instance Monad m => MonadRoom (RoomT m) where
  getRoomState = Room $ \s -> return (s,s)
  putRoomState s = Room $ \_ -> return ((),s)

-- | Typeclass for all types that are convertible to or from 'Text'
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

-- | A faction
data Faction = Faction {
    factionName :: !Text,
    factionTriggerOnHostileOf :: Handler,
    factionTriggerOnFriendlyOf :: Handler,
    factionTriggerOnExaltedOf :: Handler
  }
data Attitude = Hostile | Friendly | Exalted deriving (Eq,Ord)

-- | 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
  type IndexOf Feature = Feature
  type ValueOf Feature = Feature
  indexOf = id
  valueOf = id

-- | Phantom ID type for objects.
data ObjectId = ObjectId Int | FalseObject deriving (Eq,Ord)

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,
    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

-- | The object monad. Used to create or modify objects.
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)

-- | Typeclass for all object monads
class Monad m => MonadObject m where
  -- | Get the object state
  getObjectState :: m ObjectState
  -- | Put the object state
  putObjectState :: ObjectState -> m ()

instance Monad m => MonadObject (ObjectT m) where
  getObjectState = Object $ \s -> return (s,s)
  putObjectState s = Object $ \_ -> return ((),s)

-- | A player stereotype
data PlayerStereo = PlayerStereo {
    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

-- | A quest type
data Quest = Quest {
    questTitleOf :: !String,
    questDescOf :: !String,
    questPreconditionOf :: Prerequisite,
    questFinishConditionOf :: Prerequisite,
    questTriggerOnFinishOf :: Handler
  }

-- | The player's relation to a quest
data QuestRel = Completed | InProgress | Locked deriving (Ord,Eq)

-- | State type for PlayerT
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

-- | The player monad. Used to create or modify players.
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)

-- | Typeclass for all player monads.
class Monad m => MonadPlayer m where
  -- | Get the player state.
  getPlayerState :: m PlayerState
  -- | Put the player state.
  putPlayerState :: PlayerState -> m ()
  -- | Modify the player state.
  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)

-- | 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 PathState,
    playersOf :: Focus PlayerState,
    timeTriggersOf :: AVL (NominalDiffTime,HandlerBox),
    currenciesOf :: AVL Currency
  }

instance None DungeonState where
  none = DungeonState none none none none

-- | For compatibility. Earlier versions of DungeonT had a field for that.
currentRoomOf = fmap playerRoomOf . playerOf

-- | For compatibility. Earlier versions of DungeonT had a field for that.
playerOf = anyBstHead . playersOf

-- | The dungeon monad. Everything runs inside this.
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)
    
-- | Typeclass for all dungeon monads.
class (MonadRoom m,MonadPlayer m) => MonadDungeon m where
  -- | Get the dungeon state.
  getDungeonState :: m DungeonState
  -- | Put the dungeon state.
  putDungeonState :: DungeonState -> m ()
  -- | Lower a given DungeonT function
  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)