Stereos.hs

{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, TemplateHaskell #-}

{-
  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/>.
-}

module Game.Antisplice.Stereos (
    -- * Primitives
    statsStereo,
    skillsStereo,
    skillStereoM,
    -- * Dealing with players
    addStereo,
    replaceStereo,
    -- * Registration
    registerStereo,
    registerStereoM,
    -- * Builder
    StereoBuilderT (..),
    mergeStereo,
    mergeStereoM,
    mergeSkill,
    mergeSkillM,
    -- * Default stereos
    defaultStereo,
    visualStereo,
    manualStereo
  ) where

import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Error.Class
import Control.Arrow
import Data.Monoid
import Game.Antisplice.Action
import Game.Antisplice.Errors
import Game.Antisplice.Monad.Dungeon
import Game.Antisplice.Monad.Vocab
import Game.Antisplice.Rooms
import Game.Antisplice.Skills
import Game.Antisplice.Stats
import Game.Antisplice.Templates
import Game.Antisplice.Utils.Atoms
import Game.Antisplice.Utils.None
import Text.Chatty.Interactor.Templates

-- | Register the given stereotype and return its atom.
registerStereo :: MonadAtoms m => PlayerStereo -> m (Atom PlayerStereo)
registerStereo s = do
  a <- newAtom
  putAtom a s
  return a

-- | Add the given stereotype to the current player.
addStereo :: MonadPlayer m => Atom PlayerStereo -> m ()
addStereo a = modifyPlayerState $ \p -> p{playerStereosOf=a:playerStereosOf p}

-- | Remove one stereotype and add another
replaceStereo :: MonadPlayer m => Atom PlayerStereo -> Atom PlayerStereo -> m ()
replaceStereo rem ins = modifyPlayerState $ \p -> p{playerStereosOf=map (\a -> if a == rem then ins else a) $ playerStereosOf p}

-- | Create a stereotype that carries a stats modifier
statsStereo :: ((StatKey -> Int) -> StatKey -> Int) -> PlayerStereo
statsStereo m = PlayerStereo m (const none)

-- | Create a stereotype that carries skills
skillsStereo :: [Skill] -> PlayerStereo
skillsStereo sk = PlayerStereo (\_ _ -> 0) $ wrapSkills sk

-- | Create a stereotype that carries a skill from a monadic composition
skillStereoM :: Monad m => m Skill -> m PlayerStereo
skillStereoM m = do
  sk <- m
  return $ skillsStereo [sk]

-- | For monadic stereotype construction
newtype StereoBuilderT m a = StereoBuilder { runStereoBuilderT :: PlayerStereo -> m (a,PlayerStereo) }

instance Functor m => Functor (StereoBuilderT m) where
  fmap f a = StereoBuilder $ \s -> fmap (first f) $ runStereoBuilderT a s

instance Monad m => Monad (StereoBuilderT m) where
  return a = StereoBuilder $ \s -> return (a,s)
  m >>= f = StereoBuilder $ \s -> do (a,s') <- runStereoBuilderT m s; runStereoBuilderT (f a) s'

instance MonadTrans StereoBuilderT where
  lift m = StereoBuilder $ \s -> do a <- m; return (a,s)

-- | Merge the given pure stereotype into the built one
mergeStereo :: Monad m => PlayerStereo -> StereoBuilderT m ()
mergeStereo ste = StereoBuilder $ \s -> return ((),s<>ste)

-- | Merge the given monadic stereotype into the built one
mergeStereoM :: Monad m => m PlayerStereo -> StereoBuilderT m ()
mergeStereoM m = do
  ste <- lift m
  mergeStereo ste

-- | Merge the given pure skill into the built stereotype
mergeSkill :: MonadVocab m => Skill -> StereoBuilderT m ()
mergeSkill sk = do
  insertVocab (skillNameOf sk) Skilln
  mergeStereo $ skillsStereo [sk]

-- | Merge the given monadic skill into the built stereotype
mergeSkillM :: MonadVocab m => m Skill -> StereoBuilderT m ()
mergeSkillM m = do
  sk <- lift m
  mergeSkill sk

-- | Process the builder chain and register the resulting stereotype
registerStereoM :: MonadAtoms m => StereoBuilderT m () -> m (Atom PlayerStereo)
registerStereoM m = do
  (_,s) <- runStereoBuilderT m none
  registerStereo s

mkInteractor ''StereoBuilderT mkChatty (mkFail ''SplErr) mkDungeon mkRoom mkVocab mkCounter mkAtoms mkPlayer mkIO mkObject

-- | Default stereotype.
defaultStereo = statsStereo $
  \get k -> case k of
    AttackPower -> get Strength * 2
    CooldownDuration -> (get CooldownDuration ^ 2) `div` (get CooldownDuration + get Haste) - get CooldownDuration
    _ -> 0

visualStereo :: MonadVocab m => m PlayerStereo
visualStereo = liftM snd $ flip runStereoBuilderT none $ do
  mergeSkill $ skill "look" !+ bareAction (\p ->
    case p of
      SkillParam Nothing Nothing Nothing -> roomTriggerOnLookOf =<< getRoomState
      SkillParam Nothing (Just o) Nothing -> objectTriggerOnLookAtOf o
      _ -> throwError UnintellegibleError)
  mergeSkill $ skill "read" !+ bareAction (\p ->
    case p of
      SkillParam (Just o) Nothing Nothing -> objectTriggerOnReadOf o
      _ -> throwError UnintellegibleError)

manualStereo :: MonadVocab m => m PlayerStereo
manualStereo = liftM snd $ flip runStereoBuilderT none $ do
  mergeSkill $ skill "hit" !+ optionallyFocusDirectC !+ dealDamageA (calcStat AttackPower) !+ implyGlobalCooldownA