Last active
June 24, 2016 21:30
-
-
Save crdueck/3b96c288cf30094eb5778a6c79b06865 to your computer and use it in GitHub Desktop.
Dominion WIP
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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] |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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])) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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] |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment