{-# LANGUAGE ScopedTypeVariables #-}

module Dovin.Helpers where

import Dovin.Types
import Dovin.Prelude
import Dovin.Matchers
import Dovin.Effects (resolveEffects)

import Data.List (sort)
import qualified Data.HashMap.Strict as M
import qualified Data.Set as S
import Control.Lens (ASetter, _Just)
import Control.Monad.Reader (ask)

import Text.Parsec

hasAttribute :: CardAttribute -> Card -> Bool
hasAttribute CardAttribute
attr = CardAttribute -> Set CardAttribute -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member CardAttribute
attr (Set CardAttribute -> Bool)
-> (Card -> Set CardAttribute) -> Card -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Set CardAttribute) Card (Set CardAttribute)
-> Card -> Set CardAttribute
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Set CardAttribute) Card (Set CardAttribute)
Lens' Card (Set CardAttribute)
cardAttributes

manaSpec :: ParsecT CardAttribute u Identity CardAttribute
manaSpec = [CardAttribute] -> CardAttribute
forall a. Monoid a => [a] -> a
mconcat ([CardAttribute] -> CardAttribute)
-> ParsecT CardAttribute u Identity [CardAttribute]
-> ParsecT CardAttribute u Identity CardAttribute
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT CardAttribute u Identity CardAttribute
-> ParsecT CardAttribute u Identity [CardAttribute]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (ParsecT CardAttribute u Identity CardAttribute
forall u. ParsecT CardAttribute u Identity CardAttribute
colorless ParsecT CardAttribute u Identity CardAttribute
-> ParsecT CardAttribute u Identity CardAttribute
-> ParsecT CardAttribute u Identity CardAttribute
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT CardAttribute u Identity CardAttribute
forall u. ParsecT CardAttribute u Identity CardAttribute
colored)
  where
    colorless :: ParsecT CardAttribute u Identity CardAttribute
colorless = do
      Int
n <- CardAttribute -> Int
forall a. Read a => CardAttribute -> a
read (CardAttribute -> Int)
-> ParsecT CardAttribute u Identity CardAttribute
-> ParsecT CardAttribute u Identity Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT CardAttribute u Identity Char
-> ParsecT CardAttribute u Identity CardAttribute
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT CardAttribute u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit

      CardAttribute -> ParsecT CardAttribute u Identity CardAttribute
forall (m :: * -> *) a. Monad m => a -> m a
return (CardAttribute -> ParsecT CardAttribute u Identity CardAttribute)
-> CardAttribute -> ParsecT CardAttribute u Identity CardAttribute
forall a b. (a -> b) -> a -> b
$ Int -> Char -> CardAttribute
forall a. Int -> a -> [a]
replicate Int
n Char
'X'
    colored :: ParsecT CardAttribute u Identity CardAttribute
colored = ParsecT CardAttribute u Identity Char
-> ParsecT CardAttribute u Identity CardAttribute
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (CardAttribute -> ParsecT CardAttribute u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
CardAttribute -> ParsecT s u m Char
oneOf CardAttribute
"RUGBW")

parseMana :: String -> ManaPool
-- sort puts the Xs at the back
parseMana :: CardAttribute -> CardAttribute
parseMana CardAttribute
pool =
  case Parsec CardAttribute () CardAttribute
-> CardAttribute
-> CardAttribute
-> Either ParseError CardAttribute
forall s t a.
Stream s Identity t =>
Parsec s () a -> CardAttribute -> s -> Either ParseError a
parse Parsec CardAttribute () CardAttribute
forall u. ParsecT CardAttribute u Identity CardAttribute
manaSpec CardAttribute
"mana" CardAttribute
pool of
    Left ParseError
err -> CardAttribute
forall a. Monoid a => a
mempty
    Right CardAttribute
x -> CardAttribute -> CardAttribute
forall a. Ord a => [a] -> [a]
sort CardAttribute
x

requireCard :: CardName -> CardMatcher -> GameMonad Card
requireCard :: CardAttribute -> CardMatcher -> GameMonad Card
requireCard CardAttribute
name CardMatcher
f = do
  Maybe Card
maybeCard <- Getting (Maybe Card) Board (Maybe Card)
-> ExceptT
     CardAttribute
     (ReaderT Env (StateT Board (WriterT [Step] Identity)))
     (Maybe Card)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Getting (Maybe Card) Board (Maybe Card)
 -> ExceptT
      CardAttribute
      (ReaderT Env (StateT Board (WriterT [Step] Identity)))
      (Maybe Card))
-> Getting (Maybe Card) Board (Maybe Card)
-> ExceptT
     CardAttribute
     (ReaderT Env (StateT Board (WriterT [Step] Identity)))
     (Maybe Card)
forall a b. (a -> b) -> a -> b
$ (HashMap CardAttribute Card
 -> Const (Maybe Card) (HashMap CardAttribute Card))
-> Board -> Const (Maybe Card) Board
Lens' Board (HashMap CardAttribute Card)
resolvedCards ((HashMap CardAttribute Card
  -> Const (Maybe Card) (HashMap CardAttribute Card))
 -> Board -> Const (Maybe Card) Board)
-> ((Maybe Card -> Const (Maybe Card) (Maybe Card))
    -> HashMap CardAttribute Card
    -> Const (Maybe Card) (HashMap CardAttribute Card))
-> Getting (Maybe Card) Board (Maybe Card)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap CardAttribute Card)
-> Lens'
     (HashMap CardAttribute Card)
     (Maybe (IxValue (HashMap CardAttribute Card)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at CardAttribute
Index (HashMap CardAttribute Card)
name

  case Maybe Card
maybeCard of
    Maybe Card
Nothing -> CardAttribute -> GameMonad Card
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CardAttribute -> GameMonad Card)
-> CardAttribute -> GameMonad Card
forall a b. (a -> b) -> a -> b
$ CardAttribute
"Card does not exist: " CardAttribute -> CardAttribute -> CardAttribute
forall a. Semigroup a => a -> a -> a
<> CardAttribute
name
    Just Card
card ->
      case CardMatcher -> Card -> Either CardAttribute ()
applyMatcherWithDesc CardMatcher
f Card
card of
        Right () -> Card -> GameMonad Card
forall (m :: * -> *) a. Monad m => a -> m a
return Card
card
        Left CardAttribute
msg ->
          CardAttribute -> GameMonad Card
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CardAttribute -> GameMonad Card)
-> CardAttribute -> GameMonad Card
forall a b. (a -> b) -> a -> b
$ CardAttribute
name CardAttribute -> CardAttribute -> CardAttribute
forall a. Semigroup a => a -> a -> a
<> CardAttribute
" does not match requirements: " CardAttribute -> CardAttribute -> CardAttribute
forall a. Semigroup a => a -> a -> a
<> CardAttribute
msg

allCards :: GameMonad [Card]
allCards :: GameMonad [Card]
allCards = HashMap CardAttribute Card -> [Card]
forall k v. HashMap k v -> [v]
M.elems (HashMap CardAttribute Card -> [Card])
-> ExceptT
     CardAttribute
     (ReaderT Env (StateT Board (WriterT [Step] Identity)))
     (HashMap CardAttribute Card)
-> GameMonad [Card]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting
  (HashMap CardAttribute Card) Board (HashMap CardAttribute Card)
-> ExceptT
     CardAttribute
     (ReaderT Env (StateT Board (WriterT [Step] Identity)))
     (HashMap CardAttribute Card)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
  (HashMap CardAttribute Card) Board (HashMap CardAttribute Card)
Lens' Board (HashMap CardAttribute Card)
resolvedCards

modifyCardDeprecated :: CardName -> ASetter Card Card a b -> (a -> b) -> GameMonad ()
modifyCardDeprecated :: CardAttribute -> ASetter Card Card a b -> (a -> b) -> GameMonad ()
modifyCardDeprecated CardAttribute
name ASetter Card Card a b
lens a -> b
f = do
  ASetter Board Board BaseCard BaseCard
-> (BaseCard -> BaseCard) -> GameMonad ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying
    ((HashMap CardAttribute BaseCard
 -> Identity (HashMap CardAttribute BaseCard))
-> Board -> Identity Board
Lens' Board (HashMap CardAttribute BaseCard)
cards ((HashMap CardAttribute BaseCard
  -> Identity (HashMap CardAttribute BaseCard))
 -> Board -> Identity Board)
-> ((BaseCard -> Identity BaseCard)
    -> HashMap CardAttribute BaseCard
    -> Identity (HashMap CardAttribute BaseCard))
-> ASetter Board Board BaseCard BaseCard
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap CardAttribute BaseCard)
-> Lens'
     (HashMap CardAttribute BaseCard)
     (Maybe (IxValue (HashMap CardAttribute BaseCard)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at CardAttribute
Index (HashMap CardAttribute BaseCard)
name ((Maybe BaseCard -> Identity (Maybe BaseCard))
 -> HashMap CardAttribute BaseCard
 -> Identity (HashMap CardAttribute BaseCard))
-> ((BaseCard -> Identity BaseCard)
    -> Maybe BaseCard -> Identity (Maybe BaseCard))
-> (BaseCard -> Identity BaseCard)
-> HashMap CardAttribute BaseCard
-> Identity (HashMap CardAttribute BaseCard)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BaseCard -> Identity BaseCard)
-> Maybe BaseCard -> Identity (Maybe BaseCard)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just)
    (\(BaseCard Card
c) -> Card -> BaseCard
BaseCard (Card -> BaseCard) -> Card -> BaseCard
forall a b. (a -> b) -> a -> b
$ ASetter Card Card a b -> (a -> b) -> Card -> Card
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Card Card a b
lens a -> b
f Card
c)

  Card
card <- CardAttribute -> CardMatcher -> GameMonad Card
requireCard CardAttribute
name CardMatcher
forall a. Monoid a => a
mempty

  -- This isn't a SBA, it needs to be post-condition here to make sure no funny
  -- business is happening.
  Bool -> GameMonad () -> GameMonad ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Getting Int Card Int -> Card -> Int
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Int Card Int
Lens' Card Int
cardPlusOneCounters Card
card Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0) (GameMonad () -> GameMonad ()) -> GameMonad () -> GameMonad ()
forall a b. (a -> b) -> a -> b
$
    CardAttribute -> GameMonad ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError CardAttribute
"Cannot reduce +1/+1 counters to less than 0"

  GameMonad ()
resolveEffects

modifyCard :: ASetter Card Card a b -> (a -> b) -> CardName -> GameMonad ()
modifyCard :: ASetter Card Card a b -> (a -> b) -> CardAttribute -> GameMonad ()
modifyCard ASetter Card Card a b
lens a -> b
f CardAttribute
name = CardAttribute -> ASetter Card Card a b -> (a -> b) -> GameMonad ()
forall a b.
CardAttribute -> ASetter Card Card a b -> (a -> b) -> GameMonad ()
modifyCardDeprecated CardAttribute
name ASetter Card Card a b
lens a -> b
f

loseAttribute :: CardAttribute -> CardAttribute -> GameMonad ()
loseAttribute CardAttribute
attr CardAttribute
cn = do
  Card
c <- CardAttribute -> CardMatcher -> GameMonad Card
requireCard CardAttribute
cn CardMatcher
forall a. Monoid a => a
mempty

  CardAttribute
-> ASetter Card Card Card Card -> (Card -> Card) -> GameMonad ()
forall a b.
CardAttribute -> ASetter Card Card a b -> (a -> b) -> GameMonad ()
modifyCardDeprecated CardAttribute
cn ASetter Card Card Card Card
forall a. a -> a
id (CardAttribute -> Card -> Card
removeAttribute CardAttribute
attr)

removeAttribute :: CardAttribute -> Card -> Card
removeAttribute :: CardAttribute -> Card -> Card
removeAttribute CardAttribute
attr = ASetter Card Card (Set CardAttribute) (Set CardAttribute)
-> (Set CardAttribute -> Set CardAttribute) -> Card -> Card
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Card Card (Set CardAttribute) (Set CardAttribute)
Lens' Card (Set CardAttribute)
cardAttributes (CardAttribute -> Set CardAttribute -> Set CardAttribute
forall a. Ord a => a -> Set a -> Set a
S.delete CardAttribute
attr)

gainAttribute :: CardAttribute -> CardAttribute -> GameMonad ()
gainAttribute CardAttribute
attr CardAttribute
cn = do
  Card
c <- CardAttribute -> CardMatcher -> GameMonad Card
requireCard CardAttribute
cn CardMatcher
forall a. Monoid a => a
mempty

  CardAttribute
-> ASetter Card Card Card Card -> (Card -> Card) -> GameMonad ()
forall a b.
CardAttribute -> ASetter Card Card a b -> (a -> b) -> GameMonad ()
modifyCardDeprecated CardAttribute
cn ASetter Card Card Card Card
forall a. a -> a
id (CardAttribute -> Card -> Card
setAttribute CardAttribute
attr)

setAttribute :: CardAttribute -> Card -> Card
setAttribute :: CardAttribute -> Card -> Card
setAttribute CardAttribute
attr = ASetter Card Card (Set CardAttribute) (Set CardAttribute)
-> (Set CardAttribute -> Set CardAttribute) -> Card -> Card
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Card Card (Set CardAttribute) (Set CardAttribute)
Lens' Card (Set CardAttribute)
cardAttributes (CardAttribute -> Set CardAttribute -> Set CardAttribute
forall a. Ord a => a -> Set a -> Set a
S.insert CardAttribute
attr)

forCards :: CardMatcher -> (CardName -> GameMonad ()) -> GameMonad ()
forCards :: CardMatcher -> (CardAttribute -> GameMonad ()) -> GameMonad ()
forCards CardMatcher
matcher CardAttribute -> GameMonad ()
f = do
  [Card]
cs <- GameMonad [Card]
allCards

  let matchingCs :: [Card]
matchingCs = (Card -> Bool) -> [Card] -> [Card]
forall a. (a -> Bool) -> [a] -> [a]
filter (CardMatcher -> Card -> Bool
applyMatcher CardMatcher
matcher) [Card]
cs

  [CardAttribute] -> (CardAttribute -> GameMonad ()) -> GameMonad ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((Card -> CardAttribute) -> [Card] -> [CardAttribute]
forall a b. (a -> b) -> [a] -> [b]
map (Getting CardAttribute Card CardAttribute -> Card -> CardAttribute
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting CardAttribute Card CardAttribute
Lens' Card CardAttribute
cardName) [Card]
matchingCs) CardAttribute -> GameMonad ()
f

gameFinished :: GameMonad Bool
gameFinished :: GameMonad Bool
gameFinished = do
  Phase
state <- Getting Phase Board Phase
-> ExceptT
     CardAttribute
     (ReaderT Env (StateT Board (WriterT [Step] Identity)))
     Phase
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Phase Board Phase
Lens' Board Phase
phase

  Bool -> GameMonad Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> GameMonad Bool) -> Bool -> GameMonad Bool
forall a b. (a -> b) -> a -> b
$ case Phase
state of
             Won Player
_ -> Bool
True
             Phase
_     -> Bool
False

getTimestamp :: GameMonad Timestamp
getTimestamp :: GameMonad Timestamp
getTimestamp = Getting Timestamp Board Timestamp -> GameMonad Timestamp
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Timestamp Board Timestamp
Lens' Board Timestamp
currentTime