{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TemplateHaskell, RecordWildCards, UndecidableInstances #-}

{-
  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,
    mergeRecipe,
    mergeSkillM,
    mergeRecipeM,
    -- * Default stereos
    defaultStereo,
    visualStereo,
    manualStereo,
    consumeStereo
  ) where

import Control.Applicative
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.Call
import Game.Antisplice.Errors
import Game.Antisplice.Monad.Dungeon
import Game.Antisplice.Monad.Vocab
import Game.Antisplice.Rooms
import Game.Antisplice.MaskedSkills
import Game.Antisplice.Skills
import Game.Antisplice.Stats
import Game.Antisplice.Templates
import Data.Chatty.Atoms
import Data.Chatty.None
import Data.Chatty.Hetero
import Text.Chatty.Interactor.Templates
import System.IO

-- | Register the given stereotype and return its atom.
registerStereo :: ChAtoms 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) (const none)

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

-- | Create a stereotype that carries recipes
recipesStereo :: [Recipe] -> PlayerStereo
recipesStereo rp = PlayerStereo (\_ _ -> 0) (const none) (wrapRecipes rp)

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

-- | Create a stereotype that carries a skill from a monadic composition
recipeStereoM :: Monad m => m Recipe -> m PlayerStereo
recipeStereoM m = do
  rp <- m
  return $ recipesStereo [rp]

-- | 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 (Functor m, Monad m) => Applicative (StereoBuilderT m) where
  pure = return
  (<*>) = ap

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

-- | Merge the given pure recipe into the built stereotype
mergeRecipe :: MonadVocab m => Recipe -> StereoBuilderT m ()
mergeRecipe rp = do
  insertVocab (recipeNameOf rp) Noun
  mergeStereo $ recipesStereo [rp]

-- | Merge the given monadic recipe into the built stereotype
mergeRecipeM :: MonadVocab m => m Recipe -> StereoBuilderT m ()
mergeRecipeM m = do
  rp <- lift m
  mergeRecipe rp

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

mkInteractor ''StereoBuilderT mkChatty (mkFail ''SplErr) mkDungeon mkRoom mkVocab mkPlayer mkIO mkObject (mkChannelPrinter ''PlayerId)

-- | Default stereotype.
defaultStereo :: MonadVocab m => m PlayerStereo
defaultStereo = liftM snd $ flip runStereoBuilderT none $ do
  mergeStereo $ statsStereo $
    \get k -> case k of
      AttackPower -> get Strength * 2
      CooldownDuration -> (get CooldownDuration ^ 2) `div` (get CooldownDuration + get Haste) - get CooldownDuration
      _ -> 0
  mergeSkill $ skill "use" !+ AvailableObject :-: Nil #-> objectTriggerOnUseOf

visualStereo :: MonadVocab m => m PlayerStereo
visualStereo = liftM snd $ flip runStereoBuilderT none $ do
  mergeSkill (skill "look" !+
    Nil #->> (roomTriggerOnLookOf =<< getRoomState)
    #|| Prep "at" :-: AvailableObject :-: Nil #-> objectTriggerOnLookAtOf)
  mergeSkill (skill "read" !+ AvailableObject :-: Nil #-> objectTriggerOnReadOf)

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

consumeStereo :: MonadVocab m => m PlayerStereo
consumeStereo = liftM snd $ flip runStereoBuilderT none $ do
  mergeSkill $ skill "drink" !+ AvailableObject :-: Nil #- Pass &-> objectTriggerOnDrinkOf +? Drinkable :-: Nil
  mergeSkill $ skill "eat" !+ AvailableObject :-: Nil #- Pass &-> objectTriggerOnEatOf +? Eatable :-: Nil