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,
    Trigger,
    TriggerBox (..),
    -- * Utilities
    IsText (..),
    Direction (..),
    -- * Rooms
    RoomState (..),
    RoomT (..),
    MonadRoom (..),
    -- * Objects
    StatKey (..),
    EquipKey (..),
    Implication (..),
    Feature (..),
    ObjectId (..),
    ObjectState (..),
    ObjectT (..),
    MonadObject (..),
    -- * Factions
    Faction (..),
    Attitude (..),
    -- * Players
    PlayerStereo (..),
    PlayerState (..),
    PlayerT (..),
    MonadPlayer (..),
    -- * Dungeons
    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

-- | 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,MonadScanner m,MonadExpand m,ExpanderEnv m,MonadDungeon m,MonadError SplErr m,MonadAtoms m,MonadClock m,MonadVocab m) => m a
-- | The common type of all event handlers.
type Trigger = ChattyDungeonM ()
-- | A boxed 'Trigger' to avoid ImpredicativeTypes
newtype TriggerBox = TriggerBox { runTrigger :: Trigger }

-- | Key for item or player statistics
data StatKey = Strength
             | Agility
             | Stamina
             | Intelligence
             | Spirit
             | Armor
             | 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)

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

-- | 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 :: Trigger,
    factionTriggerOnFriendlyOf :: Trigger,
    factionTriggerOnExaltedOf :: Trigger
  }
data Attitude = Hostile | Friendly | Exalted deriving (Eq,Ord)

-- | Implications an object infers for its containing room
data Implication = DescSeg (Atom String) -- ^ An additional particle for the room description (e.g. saying that XYZ is there).
                 | StereoSeg (Atom PlayerStereo) -- ^ An additional stereotype for the near/carrying/wearing player

-- | Object features.
data Feature = Damagable  -- ^ May take damage.
             | Acquirable -- ^ May be acquired.
             | Equipable EquipKey  -- ^ May be equipped at the given slot.
             | Mobile  -- ^ May move around.
             deriving (Ord,Eq)

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

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

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

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

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

instance Monad m => MonadPlayer (PlayerT m) where
  getPlayerState = Player $ \s -> return (s,s)
  putPlayerState s = Player $ \_ -> return ((),s)

-- | 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,
    playerOf :: Maybe PlayerState,
    timeTriggersOf :: AVL (NominalDiffTime,TriggerBox)
  }

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

-- | 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 ((),s{playerOf=Just 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 ()

instance Monad m => MonadDungeon (DungeonT m) where
  getDungeonState = Dungeon $ \s -> return (s,s)
  putDungeonState s = Dungeon $ \_ -> return ((),s)