{-# LANGUAGE FlexibleContexts #-}
module Dovin.Formatting where

import Dovin.Helpers
import Dovin.Matchers
import Dovin.Monad
import Dovin.Prelude
import Dovin.Types

import Control.Monad.Writer (Writer, execWriter, tell)

import qualified Data.HashMap.Strict as M
import qualified Data.Set as S
import Data.List (intercalate, sort, sortBy, nub)
import Data.Ord (comparing)

type FormatMonad = Writer [(String, GameMonad String)]

blankFormatter :: Formatter
blankFormatter :: Formatter
blankFormatter Board
_ = [Char]
""

attributeFormatter :: FormatMonad () -> Formatter
attributeFormatter :: FormatMonad () -> Formatter
attributeFormatter FormatMonad ()
m =
  [([Char], GameMonad [Char])] -> Formatter
f ([([Char], GameMonad [Char])] -> Formatter)
-> [([Char], GameMonad [Char])] -> Formatter
forall a b. (a -> b) -> a -> b
$ FormatMonad () -> [([Char], GameMonad [Char])]
forall w a. Writer w a -> w
execWriter FormatMonad ()
m
  where
    f :: [(String, GameMonad String)] -> Formatter
    f :: [([Char], GameMonad [Char])] -> Formatter
f [([Char], GameMonad [Char])]
attrs Board
board =
      [Char]
"\n      " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ([Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " ([[Char]] -> [Char])
-> ([([Char], [Char])] -> [[Char]]) -> [([Char], [Char])] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Char], [Char]) -> [Char]) -> [([Char], [Char])] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (\([Char]
x, [Char]
y) -> [Char]
x [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
": " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
y) ([([Char], [Char])] -> [Char]) -> [([Char], [Char])] -> [Char]
forall a b. (a -> b) -> a -> b
$
        (([Char], GameMonad [Char]) -> ([Char], [Char]))
-> [([Char], GameMonad [Char])] -> [([Char], [Char])]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], GameMonad [Char]) -> ([Char], [Char])
formatAttribute [([Char], GameMonad [Char])]
attrs)

      where
        formatAttribute :: (String, GameMonad String) -> (String, String)
        formatAttribute :: ([Char], GameMonad [Char]) -> ([Char], [Char])
formatAttribute ([Char]
label, GameMonad [Char]
m) =
          let Right [Char]
value = Board -> GameMonad [Char] -> Either [Char] [Char]
forall a. Board -> GameMonad a -> Either [Char] a
execMonad Board
board GameMonad [Char]
m in
          ([Char]
label, [Char]
value)

stackFormatter :: Formatter
stackFormatter :: Formatter
stackFormatter Board
board =
  let matchingCs :: [Card]
matchingCs = ([Char] -> Card) -> [[Char]] -> [Card]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Card
lookupCard ([[Char]] -> [Card]) -> [[Char]] -> [Card]
forall a b. (a -> b) -> a -> b
$ Getting [[Char]] Board [[Char]] -> Board -> [[Char]]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [[Char]] Board [[Char]]
Lens' Board [[Char]]
stack Board
board in

  [Char]
"\n      Stack:\n" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Card] -> [Char]
formatCards [Card]
matchingCs

  where
    lookupCard :: [Char] -> Card
lookupCard [Char]
cn =
      let Right Card
value = Board -> GameMonad Card -> Either [Char] Card
forall a. Board -> GameMonad a -> Either [Char] a
execMonad Board
board ([Char] -> CardMatcher -> GameMonad Card
requireCard [Char]
cn CardMatcher
forall a. Monoid a => a
mempty) in Card
value


cardFormatter :: String -> CardMatcher -> Formatter
cardFormatter :: [Char] -> CardMatcher -> Formatter
cardFormatter [Char]
title CardMatcher
matcher Board
board =
  let matchingCs :: [Card]
matchingCs = (Card -> Card -> Ordering) -> [Card] -> [Card]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Card -> [Char]) -> Card -> Card -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ((Card -> [Char]) -> Card -> Card -> Ordering)
-> (Card -> [Char]) -> Card -> Card -> Ordering
forall a b. (a -> b) -> a -> b
$ Getting [Char] Card [Char] -> Card -> [Char]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [Char] Card [Char]
Lens' Card [Char]
cardName) ([Card] -> [Card]) -> ([Card] -> [Card]) -> [Card] -> [Card]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Card -> Bool) -> [Card] -> [Card]
forall a. (a -> Bool) -> [a] -> [a]
filter (CardMatcher -> Card -> Bool
applyMatcher CardMatcher
matcher) ([Card] -> [Card]) -> [Card] -> [Card]
forall a b. (a -> b) -> a -> b
$ [Card]
cs in

    [Char]
"\n      " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
title [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
":\n" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Card] -> [Char]
formatCards [Card]
matchingCs

  where
    cs :: [Card]
cs = let Right [Card]
value = Board -> GameMonad [Card] -> Either [Char] [Card]
forall a. Board -> GameMonad a -> Either [Char] a
execMonad Board
board GameMonad [Card]
allCards in [Card]
value

formatCards :: [Card] -> [Char]
formatCards = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n" ([[Char]] -> [Char]) -> ([Card] -> [[Char]]) -> [Card] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Card -> [Char]) -> [Card] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (([Char]
"      " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>) ([Char] -> [Char]) -> (Card -> [Char]) -> Card -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Card -> [Char]
formatCard)

formatCard :: Card -> [Char]
formatCard Card
c =
  [Char]
"  " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Getting [Char] Card [Char] -> Card -> [Char]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [Char] Card [Char]
Lens' Card [Char]
cardName Card
c [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
  [Char]
" (" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ([Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," ([[Char]] -> [Char])
-> (Set [Char] -> [[Char]]) -> Set [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [[Char]]
forall a. Ord a => [a] -> [a]
sort ([[Char]] -> [[Char]])
-> (Set [Char] -> [[Char]]) -> Set [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set [Char] -> [[Char]]
forall a. Set a -> [a]
S.toList (Set [Char] -> [Char]) -> Set [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Getting (Set [Char]) Card (Set [Char]) -> Card -> Set [Char]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Set [Char]) Card (Set [Char])
Lens' Card (Set [Char])
cardAttributes Card
c) [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
")"
  [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> if [Char] -> Card -> Bool
hasAttribute [Char]
"creature" Card
c then
       [Char]
" ("
         [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show (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
cardPower Card
c)
         [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"/"
         [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show (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
cardToughness Card
c)
         [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> (let n :: Int
n = 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
c in
              if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then
                [Char]
", +" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"/+" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n
              else
                [Char]
forall a. Monoid a => a
mempty)
         [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> (let n :: Int
n = 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
cardMinusOneCounters Card
c in
              if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then
                [Char]
", -" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"/-" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n
              else
                [Char]
forall a. Monoid a => a
mempty)
         [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> (if 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
cardDamage Card
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then
              [Char]
", " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show (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
cardDamage Card
c)
            else
              [Char]
forall a. Monoid a => a
mempty)
         [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
")"
     else if [Char] -> Card -> Bool
hasAttribute [Char]
"planeswalker" Card
c then
       [Char]
" ("
         [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show (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
cardLoyalty Card
c)
         [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
")"
     else
      [Char]
""

boardFormatter :: Formatter
boardFormatter :: Formatter
boardFormatter Board
board =
  let allLocations :: [(Player, Location)]
allLocations = [(Player, Location)] -> [(Player, Location)]
forall a. Eq a => [a] -> [a]
nub ([(Player, Location)] -> [(Player, Location)])
-> ([Card] -> [(Player, Location)])
-> [Card]
-> [(Player, Location)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Player, Location)] -> [(Player, Location)]
forall a. Ord a => [a] -> [a]
sort ([(Player, Location)] -> [(Player, Location)])
-> ([Card] -> [(Player, Location)])
-> [Card]
-> [(Player, Location)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Card -> (Player, Location)) -> [Card] -> [(Player, Location)]
forall a b. (a -> b) -> [a] -> [b]
map (Getting (Player, Location) Card (Player, Location)
-> Card -> (Player, Location)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Player, Location) Card (Player, Location)
Lens' Card (Player, Location)
location) ([Card] -> [(Player, Location)]) -> [Card] -> [(Player, Location)]
forall a b. (a -> b) -> a -> b
$ [Card]
cs in

  let formatters :: [Formatter]
formatters = ((Player, Location) -> Formatter)
-> [(Player, Location)] -> [Formatter]
forall a b. (a -> b) -> [a] -> [b]
map
                     (Player, Location) -> Formatter
formatLocation
                     [(Player, Location)]
allLocations in

  [Formatter] -> Formatter
forall a. Monoid a => [a] -> a
mconcat [Formatter]
formatters Board
board

  where
    cs :: [Card]
cs = let Right [Card]
value = Board -> GameMonad [Card] -> Either [Char] [Card]
forall a. Board -> GameMonad a -> Either [Char] a
execMonad Board
board GameMonad [Card]
allCards in [Card]
value
    formatLocation :: (Player, Location) -> Formatter
formatLocation (Player
Active, Location
Stack) = Formatter
stackFormatter
    formatLocation (Player, Location)
l = [Char] -> CardMatcher -> Formatter
cardFormatter ((Player, Location) -> [Char]
forall a. Show a => a -> [Char]
show (Player, Location)
l) ((Player, Location) -> CardMatcher
matchLocation (Player, Location)
l)

attribute :: Show a => String -> GameMonad a -> FormatMonad ()
attribute :: [Char] -> GameMonad a -> FormatMonad ()
attribute [Char]
label GameMonad a
m = [([Char], GameMonad [Char])] -> FormatMonad ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [([Char]
label, a -> [Char]
forall a. Show a => a -> [Char]
show (a -> [Char]) -> GameMonad a -> GameMonad [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GameMonad a
m)]

countLife :: Player -> GameMonad Int
countLife :: Player -> GameMonad Int
countLife Player
player = Getting Int Board Int -> GameMonad Int
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use ((HashMap Player Int -> Const Int (HashMap Player Int))
-> Board -> Const Int Board
Lens' Board (HashMap Player Int)
life ((HashMap Player Int -> Const Int (HashMap Player Int))
 -> Board -> Const Int Board)
-> ((Int -> Const Int Int)
    -> HashMap Player Int -> Const Int (HashMap Player Int))
-> Getting Int Board Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap Player Int)
-> Lens'
     (HashMap Player Int) (Maybe (IxValue (HashMap Player Int)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (HashMap Player Int)
Player
player ((Maybe Int -> Const Int (Maybe Int))
 -> HashMap Player Int -> Const Int (HashMap Player Int))
-> ((Int -> Const Int Int) -> Maybe Int -> Const Int (Maybe Int))
-> (Int -> Const Int Int)
-> HashMap Player Int
-> Const Int (HashMap Player Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Iso' (Maybe Int) Int
forall a. Eq a => a -> Iso' (Maybe a) a
non Int
0)

countValue :: String -> GameMonad Int
countValue :: [Char] -> GameMonad Int
countValue [Char]
name = Getting Int Board Int -> GameMonad Int
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use ((HashMap [Char] Int -> Const Int (HashMap [Char] Int))
-> Board -> Const Int Board
Lens' Board (HashMap [Char] Int)
counters ((HashMap [Char] Int -> Const Int (HashMap [Char] Int))
 -> Board -> Const Int Board)
-> ((Int -> Const Int Int)
    -> HashMap [Char] Int -> Const Int (HashMap [Char] Int))
-> Getting Int Board Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap [Char] Int)
-> Lens'
     (HashMap [Char] Int) (Maybe (IxValue (HashMap [Char] Int)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at [Char]
Index (HashMap [Char] Int)
name ((Maybe Int -> Const Int (Maybe Int))
 -> HashMap [Char] Int -> Const Int (HashMap [Char] Int))
-> ((Int -> Const Int Int) -> Maybe Int -> Const Int (Maybe Int))
-> (Int -> Const Int Int)
-> HashMap [Char] Int
-> Const Int (HashMap [Char] Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Iso' (Maybe Int) Int
forall a. Eq a => a -> Iso' (Maybe a) a
non Int
0)

countCards :: CardMatcher -> GameMonad Int
countCards :: CardMatcher -> GameMonad Int
countCards CardMatcher
matcher =
  [Card] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Card] -> Int) -> ([Card] -> [Card]) -> [Card] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Card -> Bool) -> [Card] -> [Card]
forall a. (a -> Bool) -> [a] -> [a]
filter (CardMatcher -> Card -> Bool
applyMatcher CardMatcher
matcher) ([Card] -> Int) -> GameMonad [Card] -> GameMonad Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GameMonad [Card]
allCards

countManaPool :: Player -> GameMonad Int
countManaPool :: Player -> GameMonad Int
countManaPool Player
p = [Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Char] -> Int) -> GameMonad [Char] -> GameMonad Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting [Char] Board [Char] -> GameMonad [Char]
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Player -> Getting [Char] Board [Char]
forall (f :: * -> *).
Functor f =>
Player -> ([Char] -> f [Char]) -> Board -> f Board
manaPoolFor Player
p)