Dominion WIP

Cards.hs

{-# LANGUAGE GADTs #-}

import Control.Lens
import Control.Monad.Free

data Action
	= Cellar | Chapel | Moat
	| Chancellor | Village | Woodcutter | Workshop
	| Bureaucrat | Feast | Gardens | Militia | Moneylender | Remodel | Smithy | Spy | Thief | ThroneRoom
	| CouncilRoom | Festival | Laboratory | Library | Market | Mine | Witch
	| Adventurer

data Junk = Curse
data Treasure = Copper | Silver | Gold
data Victory = Estate | Duchy | Province

data CardType = Action Action | Junk Junk | Treasure Treasure | Victory Victory

isTreasure :: Card -> Bool
isTreasure (Card _ (Treasure _) _) = True
isTreausre _ = False

data Discard = Any | DownTo Int | UpTo Int | This Card

data CardEffect s where
	= ActionEff   :: Action -> CardEffect ()
	| Bind        :: CardEffect s -> (s -> CardEffect t) -> CardEffect t
	| Choose      :: CardEffect s -> CardEffect s -> CardEffect s
	| Discard     :: Discard -> CardEffect Int
	| DrawUntil   :: ([Card] -> Bool) -> CardEffect ()
	| GainCard    :: Card -> CardEffect ()
	| GainUpTo    :: Cost -> CardEffect ()
	| PlusAction  :: Int -> CardEffect ()
	| PlusBuy     :: Int -> CardEffect ()
	| PlusCard    :: Int -> CardEffect ()
	| PlusMoney   :: Cost -> CardEffect ()
	| Others      :: CardEffect s -> CardEffect s
	| Shelve      :: Card -> CardEffect ()
	| Then        :: CardEffect s -> CardEffect t -> CardEffect t
	| TrashAny    :: CardEffect Cost
	| TrashOne    :: [Card] -> CardEffect Cost
	| TrashThis   :: CardEffect ()
	| TrashUpTo   :: Int -> CardEffect ()
	
data Card = Card
	{ _cost    :: Cost
	, _type    :: CardType
	, _effects :: [CardEffect ()]
	}
	
chapel :: Card
chapel = Card 2 (Action Chapel) [TrashUpTo 4]

cellar :: Card
cellar = Card 2 (Action Cellar) [PlusAction 1, Discard Any `Bind` PlusCard]

witch :: Card
witch = Card 5 (Action Witch) [PlusCard 2, Others (GainCard curse)]

chancellor :: Card
chancellor = Card 3 (Action Chancellor) [PlusMoney 2, ActionEff Chancellor]

workshop :: Card
workshop = Card 3 (Action Workshop) [GainUpTo 4]

bureaucrat :: Card
bureaucrat = Card 4 (Action Bureaucrat) [GainCard silver, Others (Reveal [estate, duchy, province] `Bind` \c -> Discard (This c) `Then` Shelve c)]

councilRoom :: Card
councilRoom = Card 4 (Action CouncilRoom) [PlusCard 4, PlusBuy 1, Others (PlusCard 1)]

feast :: Card
feast = Card 4 (Action Feast) [TrashThis, GainUpTo 5]

militia :: Card
militia = Card 4 (Action Militia) [PlusCard 2, Others (Discard (DownTo 3))]

moneylender :: Card
moneylender = Card 4 (Action Moneylender) [TrashOne [copper] `Then` PlusMoney 3]

remodel :: Card
remodel = Card 4 (Action Remodel) [TrashAny `Bind` \c -> GainUpTo (c+2)]

spy :: Card
spy = Card 4 (Action Spy) [ActionEff Spy]

thief :: Card
thief = Card 4 (Action Thief) [ActionEff Thief]

throneRoom :: Card
throneRoom = Card 4 (Action ThroneRoom) [ActionEff ThroneRoom]

library :: Card
library = Card 5 (Action Library) [ActionEff Library]

mine :: Card
mine = Card 5 (Action Mine) [ActionEff Mine]

adventurer :: Card
adventurer = Card 6 (Action Adventurer) [DrawUntil ((==2) . length . filter isTreasure)]

targeting :: Card -> [Card] -> Card
targeting = const

type Opener = (Card, Card, Card, Card)

data StrategyF x
	= After  Round x x
	| Before Round x x
	| Buys  [Card] x
	| Plays [Card] x
	| Opens Opener x
	| Pass x

badReligion :: Strategy ()
badReligion = do
	opens (chapel, silver, chapel, witch)
	plays [village, witch, chapel `targeting` [curse, estate, copper]]
	buys [province, gold, witch, village, silver] `before` Round 6
	buys [province, gold, duchy, silver, estate]

dominion.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeFamilies #-}

import Control.Lens
import Control.Monad.Free
import Control.Monad.State

import Data.List (sortOn)
import Data.Map (Map)
import qualified Data.Map as M

data GameState = GameState
	{ round   :: Round
	, supply  :: Map CardName (Int, Card)
	, players :: [Players]
	}
	
isEndOfGame :: GameState -> Bool
isEndOfGame gs = False
	
newGameState :: [CardName] -> [Player] -> GameState
newGameState kingdom = GameState supply0
	where supply0 = M.empty

newtype Dominion a = Dominion { runDominion :: StateT GameState Maybe a }

data TurnState = TurnState
	{ hand    :: [Card]
	, actions :: Int
	, buys    :: Int
	, gold    :: Int
	, player  :: Player
	}

newtype Turn a = Turn { runTurn :: StateT TurnState Maybe a }

newTurnState :: Player -> TurnState
newTurnState = TurnState [] 1 1 0

evalTurn :: Player -> Turn () -> Dominion ()
evalTurn p t = case evalStateT (runTurn t) (newTurnState p) of
	Nothing -> return ()
	Just xs -> return ()

newtype VictoryPoints = VP { getVictoryPoints :: Int }
	deriving (Eq, Ord, Show)

data Nat = Z | S Nat

type family :+ (n :: Nat) (m :: Nat) :: Nat where
	n   :+ Z = n
	Z   :+ m = m
	S n :+ m = S (n :+ m)

data Action (n :: Nat) (b :: Nat) where
	Cellar :: Action (S Z) Z
	Chapel :: Action Z Z
	Moat :: Action Z Z

data CardName
	= Cellar | Chapel | Moat
	| Chancellor | Village | Woodcutter | Workshop
	| Bureaucrat | Feast | Gardens | Militia | Moneylender | Remodel | Smithy | Spy | Thief | ThroneRoom
	| CouncilRoom | Festival | Laboratory | Library | Market | Mine | Witch
	| Adventurer
	
data Junk = Curse
data Treasure = Copper | Silver | Gold
data Victory = Estate | Duchy | Province

data CardType = Action Action | Junk Junk | Treasure Treasure | Victory Victory

data Card = Card
	{ cost   :: Word
	, effect :: [CardEffect]
	}
	
data Player (actions :: Nat) (buys :: Nat) = Player
	{ deck     :: [Card]
	, discard  :: [Card]
	, name     :: String
	, strategy :: Strategy
	}
	
newPlayer :: String -> Strategy -> Player
newPlayer = Player (shuffle deck0)
	where deck0 = replicate 7 Copper ++ replicate 3 Estate
	
shuffle :: [a] -> [a]
shuffle = id

setPlayerHand :: [Card] -> TurnState -> TurnState
setPlayerHand xs s = s { hand = xs }

setPlayerDeck :: [Card] -> TurnState -> TurnState
setPlayerDeck xs s = s { player = player s { deck = xs } }

setPlayerDiscard :: [Card] -> TurnState -> TurnState
setPlayerDiscard xs s = s { player = player s { discard = discard ++ xs } }

draw :: Int -> Turn ()
draw n = do
	p <- gets player
	let (as, bs) = splitAt n (deck p)
	modify (setPlayerHand as)
	modify (setPlayerDeck bs)
	
discard :: Turn ()
discard = do
	h <- gets hand
	modify (setPlayerDiscard h)

playerTurn :: Player -> Turn ()
playerTurn p = do
	draw 5
	evalStrategy (strategy p)
	discard

play :: Player (S n) b -> Action n' b' -> Dominion (Player (n :+ n') (b :+ b'))
play = undefined

buy :: Player a (S n) -> Card -> Dominion (Player a n)
buy = undefined

newtype Round = Round Int

data StrategyF x
	= Buys  [CardName] x
	| Plays [CardName] x
	| Before Round x
	
type Strategy = Free StrategyF ()

buys :: [CardName] -> Strategy ()
buys = liftF Buys

plays :: [CardName] -> Strategy ()
plays = liftF Plays

before :: Round -> Strategy ()
before = liftF Before

evalStrategy :: Strategy -> Dominion ()
evalStrategy f = return ()

bigMoney :: Strategy
bigMoney = Buys [Province, Gold, Duchy, Silver, Estate]

bigMoneySmithy :: Strategy
bigMoneySmithy = do
	plays [Smithy]
	buys [Province, Gold, Silver, Smithy] `before` Round 6
	buys [Province, Gold, Duchy, Silver, Estate]

dominion :: Ord a => [Player] -> [(Player, VictoryPoints)]
dominion xs = []

victor :: Ord a => [(Player, a)] -> Player
victor = head . sortOn snd

main = print (victor (dominion [newPlayer "Chris" bigMoneySmithy, newPlayer "Alice" bigMoney]))

ver3.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

import Control.Lens
import Control.Monad.Free
import Control.Monad.RWST

import Data.Map (Map)
import qualified Data.Map as M
import Data.Monoid
import System.Random

shuffle :: StdGen -> [a] -> [a]
shuffle = const id

data Player = Player
	{ _deck     :: [Card]
	, _discard  :: [Card]
	, _name     :: String
	, _strategy :: Strategy ()
	}
	
newPlayer :: String -> Strategy () -> Player
newPlayer = Player [] deck0
	where deck0 = replicate 7 Copper ++ replicate 3 Estate
	
score :: Player -> VictoryPoints
score = sum . map victoryPoints . cards
	where cards p = view deck p ++ view discard p
		  
victoryPoints :: Card -> VictoryPoints
victoryPoints c = 0

data Queue a = Queue { focus :: a, front :: [a], back :: [a] }

fromList :: [a] -> Queue a
fromList []     = error "Queue.fromList: empty list"
fromList (x:xs) = Queue x xs []

cons :: a -> Queue a -> Queue a
cons a (Queue h f b) = Queue a (h : f) b

snoc :: a -> Queue a -> Queue a
snoc a (Queue h f b) = Queue h f (a : b)

head :: Queue a -> a
head (Queue h _ _) = h

rotateL :: Queue a -> Queue a
rotateL (Queue h [] [])    = Queue h [] []
rotateL (Queue h []  b)    = rotateL (Queue h (reverse b) [])
rotateL (Queue h (x:xs) b) = Queue x xs (h : b)

data GameState = GameState
	{ _round   :: Round
	, _supply  :: Map Card Int
	, _trash   :: [Card]
	, _players :: Queue Player
	}
	
isEndOfGame :: GameState -> Bool
isEndOfGame gs = ps || M.size cs >= 3
	where ss = view supply gs
		  cs = M.filter (==0) ss
		  ps = ss M.! province
	
newGameState :: [Card] -> [Player] -> GameState
newGameState kingdom = GameState 0 M.empty [] . Q.fromList

data Config = Config
	{ _iterations :: Int
	, _verbose    :: Bool
	}

type Log = [String]
	
dominion :: [Player] -> GameState
dominion = dominionWith defaultConfig defaultKingdom

defaultConfig :: Config
defaultConfig = Config
	{ iterations = 100
	, verbose    = False
	}

defaultKingdom :: [Card]
defaultKingdom = [chapel, moat, village, remodel, moneylender, market, woodcutter, smithy, witch, militia]

dominionWith :: Config -> [Card] -> [Player] -> GameState
dominionWith cfg dom = fst . execRWS gameLoop cfg . newGameState dom
	where gameLoop = do
			runRound
			finished <- gets isGameFinished
			unless finished runGame
	
newtype Dominion a = Dominion { runDominion :: RWS Config Log GameState a }

data TurnState = TurnState
	{ _prng    :: StdGen
	, _hand    :: [Card]
	, _pile    :: [Card]
	, _actions :: Int
	, _buys    :: Int
	, _money   :: Cost
	, _player  :: Player
	}

newTurnState :: Player -> TurnState
newTurnState = TurnState stg [] [] 1 1 0
	where stg = mkStdGen 8942896132

playerDeck :: Lens' TurnState [Card]
playerDeck = player . deck

playerDiscard :: Lens' TurnState [Card]
playerDiscard = player . discard

playerStrategy :: Lens' TurnState (Strategy ())
playerStrategy = player . strategy

data Update
	= Buying [Card]
	| Giving [Card]
	| Trashing [Card]

type Turn = RWS Round [Update] TurnState

runRound :: Dominion ()
runRound = do
	r  <- round <+= 1
	ps <- use players
	forM_ ps $ \p -> do
		let ts = newTurnState p
			st = p ^. strategy
		case evalRWS (foldFree phi st) r ts of
			(_, w) -> mapM_ apply w
		
apply :: Update -> Dominion ()
apply (Buying cs) = mapM_ (\c -> supply %= M.adjust (-1) c) cs
apply (Giving cs) = over players (discard <>= cs)
apply (Trashing cs) = trash <>= cs

phi :: StrategyF a -> Turn a
phi (After r a b) = do
	n <- ask
	return $ if (r < n)	then a else b
	
phi (Before r a b) = do
	n <- ask
	return $ if (r > n) then a else b
	
phi (Buys cs a) = do
	m <- use money
	let bs = purchase m cs
	when (not (null bs)) $ do
		b <- use buys
		buys -= min b (length bs)
		tell [Buying (take b bs)]
	return a

phi	p@(Plays cs a) = do
	a <- use actions
	if a == 0
	then return a
	else do
		h <- use hand
		case popFirst cs h of
			Nothing -> return a
			Just (c, h') -> do
				hand .= h'
				playCard c
				phi p
	
popFirst :: Eq a => [a] -> [a] -> Maybe (a, [a])
popFirst _ [] = Nothing
popFirst ns hs = go ns
	where go [] = Nothing
		  go (x:xs) = case pop x hs of
			Nothing  -> go xs
			Just hs' -> Just (x, hs')
			
pop :: Eq a => a -> [a] -> Maybe [a]
pop a = go []
	where go z [] = Nothing
		  go z (x:xs) = if a == x then Just (reverse z ++ xs) else go (x:z) xs
		  
playCard :: Card -> Turn ()
playCard c@(Card _ _ eff) = do
	actions -= 1
	pile %= cons c
	mapM_ runEffect eff

runEffect :: CardEffect s -> Turn s
runEffect (GainUpTo   n) = 
runEffect (Give       c) = tell [Giving [c]]
runEffect (PlusAction n) = actions += n
runEffect (PlusBuy    n) = buys += n
runEffect (PlusCard   n) = draw n
runEffect (PlusMoney  n) = money += n
runEffect (Trash      n) =
runEffect (TrashAny  cs) =
runEffect (TrashOne   c) = tell [Trashing [c]]
runEffect (Others   eff) = 
runEffect (Then     e f) = runEffect e >> runEffect f
runEffect (Bind     e f) = runEffect e >>= runEffect . f

purchase :: Cost -> [Card] -> [Card]
purchase c = takeWhileAccum1 (<=c) (view cost)

takeWhileAccum1 :: Monoid b => (b -> Bool) -> (a -> b) -> [a] -> [a]
takeWhileAccum1 p f = go mempty
	where go _ []     = []
		  go z (x:xs) = let z' = z <> f x in
					    if p z' then x : go z' xs else []

turn :: Turn ()
turn = do
	draw 5
	uses playerStrategy runStrategy
	discard
	
draw :: Int -> Turn ()
draw n = do
	d0 <- use playerDeck
	when (length d0 < n) reshuffle
	d1 <- use playerDeck
	let (as, bs) = splitAt n d1
	hand <>= as
	playerDeck .= bs

reshuffle :: Turn ()
reshuffle = do
	d <- playerDiscard <<.= []
	playerDeck <>= shuffle d

discard :: Turn ()
discard = do
	h <- hand <<.= []
	p <- pile <<.= []
	playerDiscard <>= h
	playerDiscard <>= p

newtype Cost = Cost (Sum Int)
	deriving (Eq, Ord, Num, Show)

newtype Round = Round (Sum Int)
	deriving (Eq, Ord, Num, Show)

newtype VictoryPoints = VictoryPoints (Sum Int)
	deriving (Eq, Ord, Num, Show)

data Action
	= Cellar | Chapel | Moat
	| Chancellor | Village | Woodcutter | Workshop
	| Bureaucrat | Feast | Gardens | Militia | Moneylender | Remodel | Smithy | Spy | Thief | ThroneRoom
	| CouncilRoom | Festival | Laboratory | Library | Market | Mine | Witch
	| Adventurer

data Junk = Curse
data Treasure = Copper | Silver | Gold
data Victory = Estate | Duchy | Province

data CardType = Action Action | Junk Junk | Treasure Treasure | Victory Victory

data CardEffect s where
	= Discard    :: [Card] -> Int  -> CardEffect Int
	| Gain       :: [Card] -> CardEffect ()
	| GainUpTo   :: Cost -> CardEffect ()
	| PlusAction :: Int -> CardEffect ()
	| PlusBuy    :: Int -> CardEffect ()
	| PlusCard   :: Int -> CardEffect ()
	| PlusMoney  :: Int -> CardEffect ()
	| Targeting  :: Card -> [Card] -> CardEffect ()
	| TrashAny   :: [Card] -> CardEffect Cost
	| Trash      :: Int -> CardEffect Cost
	| TrashThis  :: CardEffect ()
	| Others     :: CardEffect s -> CardEffect s
	| Then       :: CardEffect s -> CardEffect t -> CardEffect t
	| Bind       :: CardEffect s -> (s -> CardEffect t) -> CardEffect t

data Card = Card
	{ _cost    :: Cost
	, _type    :: CardType
	, _effects :: [CardEffect ()]
	}
	
badReligion :: Strategy ()
badReligion = do
	plays [village, chapel `targeting` [copper, estate, curse], witch]
	buys [witch, silver, chapel] `before` Round 2
	buys [province, gold, witch, village, silver] `before` Round 6
	buys [province, gold, duchy, silver, estate]