{-# LANGUAGE RankNTypes, FlexibleContexts, LambdaCase, FlexibleInstances, ConstraintKinds #-}

{-
  This module is part of Antisplice.
  Copyleft (c) 2014,2021 Enum 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 brick-by-brick composition for general actions, which may be used for skills and gates.
module Game.Antisplice.Action where

import Control.Monad
import Data.Monoid
import Data.Maybe
import Game.Antisplice.Monad.Dungeon
import Game.Antisplice.Rooms
import Game.Antisplice.Errors
import Game.Antisplice.Stats
import Data.Chatty.Counter
import Data.Chatty.None
import Data.Chatty.AVL
import Data.Chatty.BST

-- | A typeclass for all action types carrying an execution condition.
class IsAction a where
  -- | Conjunction _with_ short evaluation.
  infixl 5 #&&
  (#&&) :: a -> a -> a
  -- | Disjunction _with_ short evaulation.
  infixl 5 #||
  (#||) :: a -> a -> a
  -- | Conjunction _without_ short evaluation.
  infixl 5 !&&
  (!&&) :: a -> a -> a
  -- | Disjunction _without_ short evaluation.
  infixl 5 !||
  (!||) :: a -> a -> a

instance Semigroup PrerequisiteBox where
  p <> q = Prerequisite $ do
    a <- runPrerequisite p
    b <- runPrerequisite q
    return (a && b)
    
instance Monoid PrerequisiteBox where
  mempty = none

instance IsAction PrerequisiteBox where
  p #&& q = Prerequisite $ do
    a <- runPrerequisite p
    if a then runPrerequisite q
         else return False
  p #|| q = Prerequisite $ do
    a <- runPrerequisite p
    if a then return True
         else runPrerequisite q
  p !&& q = p <> q
  p !|| q = Prerequisite $ do
    a <- runPrerequisite p
    b <- runPrerequisite q
    return (a || b)

instance Semigroup PredicateBox where
  p <> q = Predicate $ do
    a <- runPredicate p
    b <- runPredicate q
    return $ case (a,b) of
      (Just (Unint i s), Just (Unint j _)) | i >= j -> Just $ Unint i s
      (Nothing, k) -> k
      (k, _) -> k

instance Monoid PredicateBox where
  mempty = none

instance IsAction PredicateBox where
  p #&& q = Predicate $
    runPredicate p >>= \case
      Nothing -> runPredicate q
      Just (Unint i s) -> runPredicate q >>= \case
        Nothing -> return $ Just $ Unint i s
        Just (Unint j _) | i >= j -> return $ Just $ Unint i s
        e -> return e
      e -> return e
  p #|| q = Predicate $
    runPredicate p >>= \case
      Nothing -> return Nothing
      Just (Unint i s) -> runPredicate q >>= \case
        Just (Unint j _) | i >= j -> return $ Just $ Unint i s
        e -> return e
      e -> runPredicate q
  p !&& q = p <> q
  p !|| q = Predicate $ do
    a <- runPredicate p
    b <- runPredicate q
    return $ case (a,b) of
      (Nothing, _) -> Nothing
      (Just (Unint i s), Just (Unint j _)) | i >= j -> Just $ Unint i s
      (_, k) -> k

-- | A general action, which may be used for skills and gates.
data Action = Action { askAction :: Predicate, runAction :: Handler }

instance None Action where
  none = Action (return Nothing) noneM

instance Monoid Action where
  mempty = none
  a `mappend` b = Action (runPredicate $ Predicate (askAction a) <> Predicate (askAction b)) (runAction a >> runAction b)

instance Semigroup Action where
  (<>) = mappend

instance IsAction Action where
  a #&& b = Action
    (runPredicate $ Predicate (askAction a) #&& Predicate (askAction b))
    (runAction a >> runAction b)
  a #|| b = Action
    (runPredicate $ Predicate (askAction a) #|| Predicate (askAction b))
    (askAction a >>= \q -> if isNothing q then runAction a else runAction b)
  a !&& b = a <> b
  a !|| b = Action
    (runPredicate $ Predicate (askAction a) !|| Predicate (askAction b))
    (askAction a >>= \q -> askAction b >> if isNothing q then runAction a else runAction b)

-- | An action that is run /after/ a specific event.
newtype ActionAfter = ActionAfter { runActionAfter :: Action }
-- | An action that is run /before/ a specific event.
newtype ActionBefore = ActionBefore { runActionBefore :: Action }

instance None ActionAfter where
  none = ActionAfter none
instance None ActionBefore where
  none = ActionBefore none

instance Monoid ActionAfter where
  mempty = none
  a `mappend` b = ActionAfter $ runActionAfter a <> runActionAfter b
instance Semigroup ActionAfter where
  (<>) = mappend
instance Monoid ActionBefore where
  mempty = none
  a `mappend` b = ActionBefore $ runActionBefore a <> runActionBefore b
instance Semigroup ActionBefore where
  (<>) = mappend

instance IsAction ActionAfter where
  a #&& b = ActionAfter $ runActionAfter a #&& runActionAfter b
  a #|| b = ActionAfter $ runActionAfter a #|| runActionAfter b
  a !&& b = ActionAfter $ runActionAfter a !&& runActionAfter b
  a !|| b = ActionAfter $ runActionAfter a !|| runActionAfter b
instance IsAction ActionBefore where
  a #&& b = ActionBefore $ runActionBefore a #&& runActionBefore b
  a #|| b = ActionBefore $ runActionBefore a #|| runActionBefore b
  a !&& b = ActionBefore $ runActionBefore a !&& runActionBefore b
  a !|| b = ActionBefore $ runActionBefore a !|| runActionBefore b

instance IsAction (Maybe ReError) where
  -- #&&
  Nothing #&& Nothing = Nothing
  Just (Unint i s) #&& Just (Unint j _) | i >= j = Just $ Unint i s
  a #&& Nothing = a
  _ #&& e = e
  -- #||
  Nothing #|| _ = Nothing
  Just (Unint i s) #|| Just (Unint j _) | i >= j = Just $ Unint i s
  _ #|| e = e
  -- !&&, !||
  (!&&) = (#&&)
  (!||) = (#||)

ands :: (None a,IsAction a) => [a] -> a
ands = foldr (!&&) none

andl :: (None a,IsAction a) => [a] -> a
andl = foldr (#&&) none

ors :: (None a,IsAction a) => [a] -> a
ors = foldr (!||) none

orl :: (None a,IsAction a) => [a] -> a
orl = foldr (#||) none

-- | Use for actions that consume a given currency.
consumeCurrencyA :: CurrencyId -> Int -> Action
consumeCurrencyA c h = Action
  (do
      c1 <- getCurrency c
      return (if c1 > h then Nothing else Just $ Uncon "You can't cast that now (check your currencies)"))
  (modifyCurrency c (subtract h))

-- | Use for actions that consume an object of the given kind.
consumeKindA :: KindId -> Int -> Action
consumeKindA k h =
  let getObjs :: ChattyDungeonM [ObjectId]
      getObjs = liftM (map indexOf . filter ((==k) . objectKindOf) . avlInorder . playerInventoryOf) getPlayerState
  in Action
    (do
        objs <- getObjs
        return (if length objs >= h then Nothing else Just $ Uncon "You can't cast that now (check your inventory)"))
    (do
        objs <- getObjs
        modifyPlayerState $ \p -> p{playerInventoryOf=foldr avlRemove (playerInventoryOf p) $ take h objs})

-- | Deal damage to opponent
dealDamageA :: ChattyDungeonM Int -> Action
dealDamageA m = Action (return Nothing) (dealDamage =<< m)

-- | Use for actions that require a cooldown time.
implyCooldownA :: ChCounter m => Integer -> m Action
implyCooldownA ms = do
  cid <- liftM CooldownId countOn
  return (Action
    (liftM (\b -> if not b then Nothing else Just $ Uncon "You can't cast that now (check your cooldowns)") $ getCooldown cid)
    (setCooldown cid True >> schedule ms (setCooldown cid False)))

-- | Use for actions that suffer from global cooldown.
implyGlobalCooldownA :: Action
implyGlobalCooldownA = Action
  (liftM (\b -> if not b then Nothing else Just $ Uncon "You can't cast that now (check your global cooldown)") $ getCooldown GlobalCooldown)
  (do
    setCooldown GlobalCooldown True
    cd <- calcStat CooldownDuration
    schedule (fromIntegral cd) $ setCooldown GlobalCooldown False)