Dungeon.hs

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

{-
  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 (..),
    Predicate,
    PredicateBox (..),
    -- * Utilities
    IsText (..),
    Direction (..),
    -- * Rooms
    RoomState (..),
    RoomT (..),
    MonadRoom (..),
    PathState (..),
    -- * Objects
    StatKey (..),
    EquipKey (..),
    Relation (..),
    Feature (..),
    ObjectId (..),
    KindId (..),
    ObjectState (..),
    ObjectT (..),
    MonadObject (..),
    -- * Factions
    Faction (..),
    Attitude (..),
    -- * Currencies
    Currency (..),
    CurrencyId (..),
    -- * Fight
    DamageTarget (..),
    -- * Players
    PlayerId (..),
    PlayerState (..),
    PlayerT (..),
    MonadPlayer (..),
    -- * Stereotypes
    PlayerStereo (..),
    CooldownId (..),
    GetterResponse (..),
    Invokable,
    InvokableP,
    RecipeMethod(..),
    -- * 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 Data.Chatty.Graph
import Data.Chatty.BST
import Data.Chatty.AVL
import Data.Chatty.Atoms
import Game.Antisplice.Errors
import Data.Chatty.Fail
import Data.Chatty.Counter
import Data.Chatty.None
import Data.Chatty.Focus
import Data.Chatty.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

-- | Matches any 'SomeDungeon' context
type DungeonM a = forall m.SomeDungeon m => m a
-- | Wrap up 'MonadDungeon', 'MonadError' 'SplErr' and 'MonadVocab' to a single constraint.
type SomeDungeon m = (MonadDungeon m,MonadError SplErr m,MonadVocab m)
-- | Matches any 'SomeChattyDungeon' context
type ChattyDungeonM a = forall m.SomeChattyDungeon m => m a
-- | Wrap up 'SomeDungeon', most Chatty classes and some utility classes to a single sonstraint.
type SomeChattyDungeon m = (Functor m,ChExtendedPrinter m,ChExpand m,ChExpanderEnv m,ChAtoms m,ChClock m,SomeDungeon m,ChRandom m,ChBroadcaster PlayerId m)
-- | 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 }
-- | The common type for all predicates.
type Predicate = ChattyDungeonM (Maybe ReError)
-- | A boxed 'Predicate' to avoid ImpredicativeTypes
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

-- | Key for item or player statistics
data StatKey = Strength
             | Agility
             | Stamina
             | Intelligence
             | Spirit
             | Armor
             | Haste
             | CooldownDuration
             | AttackPower
             deriving (Ord,Eq)

instance Tuplify StatKey StatKey where
  tuplify = id

-- | Key for equipment slot
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
  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
  }

instance Tuplify RoomState RoomState where
  tuplify = id

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

instance Tuplify Faction Faction where
  tuplify = id
               
data Attitude = Hostile | Friendly | Exalted deriving (Eq,Ord)

instance Tuplify Attitude Attitude where
  tuplify = id

-- | Relation between the player and the object.
data Relation = Near | Carried | Worn deriving (Ord,Eq)

instance Tuplify Relation Relation where
  tuplify = id

-- | Object features.
data Feature = Damagable  -- ^ May take damage.
             | Acquirable -- ^ May be acquired.
             | Usable -- ^ May be used.
             | Drinkable -- ^ May be drunk.
             | Eatable -- ^ May be eaten. 
             | 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 Tuplify Feature Feature where
  tuplify = id

instance Indexable Feature Feature Feature where
  indexOf = id
  valueOf = id

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

instance Tuplify ObjectId ObjectId where
  tuplify = id

-- | Phantom ID type for object kinds.
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

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

-- | 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] -> PredicateBox

-- | A player stereotype
data PlayerStereo = PlayerStereo {
    stereoCalcStatBonus :: (StatKey -> Int) -> StatKey -> Int,
    stereoSkillBonus :: String -> Maybe Invokable,
    stereoRecipeBonus ::  String -> Maybe (RecipeMethod -> Invokable)
  } deriving Typeable

-- | Phantom ID type for players
newtype PlayerId = PlayerId Int deriving (Eq,Ord)

instance Tuplify PlayerId PlayerId where
  tuplify = id

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

-- | Method of using recipes
data RecipeMethod = RecipeMethod Int deriving (Eq,Ord)

-- | Response of an object getter
data GetterResponse = Found ObjectState | TooMany | NoneFound

instance None GetterResponse where
  none = NoneFound

-- | 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),
    playerAlcoholOf :: Int,
    playerSoberingActiveOf :: Bool
  }

instance Indexable PlayerState PlayerId PlayerState where
  indexOf = playerIdOf
  valueOf = id

instance Indexable CooldownId CooldownId CooldownId where
  indexOf = id
  valueOf = id

instance Indexable Currency CurrencyId Currency where
  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)

instance Tuplify Direction Direction where
  tuplify = id

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