{-
Game representation and AI player for Lost Cities game
Pedro Vasconcelos <pbv@dcc.fc.up.pt>, 2009
-}
module LostCities where
import Prelude hiding (round)
import List
import Maybe
import Data.Map (Map, (!))
import qualified Data.Map as Map
import Control.Monad
import Control.Monad.Error
import Control.Monad.State
import Minimax
import Data.Tree
import Utils
-- expedition colors
data Color = Red | Green | White | Blue | Yellow
deriving (Eq,Ord,Show,Read,Enum,Bounded)
-- card face values: 0=investment; 2..10=value
type Face = Int
-- a card with a color and face
type Card = (Color,Face)
-- a stack cards (of the same color)
type Stack = [Face]
-- projection functions
color :: Card -> Color
color = fst
face :: Card -> Face
face = snd
-- the full playing deck
fullDeck :: [Card]
fullDeck = [(c,f) | c<-colors, f<-faces]
-- all color
colors :: [Color]
colors = [minBound .. maxBound]
-- all faces, including repeated investment cards
faces :: [Face]
faces = 0:0:0:[2..10]
data Playing = Human | Computer deriving (Eq,Read,Show)
-- data relative to one player
-- separate the cards in hand into two parts
-- hidden: cards drawn from deck (unknown to opponent)
-- shown: cards drawn from discard (known to opponent)
data Player
= Player { name :: String
, playing :: Playing -- human or computer
, hidden :: [Card] -- cards hidden in player's hand
, shown :: [Card] -- cards the opponent knows about
, expeditions :: Map Color Stack -- player's expeditions
, accumulated :: Int -- score from previous rounds
}
deriving (Eq,Read,Show)
-- collect all player' hand cards
-- not necessarily in order
playerHand :: Player -> [Card]
playerHand p = shown p ++ hidden p
-- collect all player's expedition cards
expeditionCards :: Player -> [[Card]]
expeditionCards p = [[(c,v)|v<-vs] | (c,vs)<-Map.assocs (expeditions p)]
-- add a card from discard pile to a player
addShown :: Player -> Card -> Player
addShown p c = p { shown=c:shown p }
-- add a card drawn from deck to a player
addHidden :: Player -> Card -> Player
addHidden p c = p { hidden=c:hidden p }
-- withdraw a card from player's hand
-- tricky: removes from known cards if it occurs there
withdraw :: Player -> Card -> Player
withdraw p c | c`elem`shown p = p { shown=delete c (shown p) }
| otherwise = p { hidden=delete c (hidden p) }
-- a game move, split into first and second parts
type Move = (Action1,Action2)
-- first part action
data Action1 = Play Card
| Discard Card
deriving (Eq,Ord,Show,Read)
-- second part action
data Action2 = DrawFromDeck
| DrawFromDiscard Color
deriving (Eq,Ord,Show,Read)
--
-- the full game position, including active player
--
data Position
= Position { active :: Player -- currently active player
, other :: Player -- other player
, discard :: Map Color Stack -- discard piles by color
, drawPile :: [Card] -- draw pile
, leadMove :: Maybe Move -- move leading to this position
, turn :: !Int -- action counter
, sign :: !Int -- maximizing/minimizing (1 or -1)
, round :: !Int -- current round
}
deriving (Eq,Read,Show)
-- end game condition (exausted draw pile)
endGame :: Position -> Bool
endGame = null . drawPile
-- list all possible moves from a game position
moves :: Position -> [Move]
moves g | endGame g = []
| otherwise = [(a1,a2) | a2<-actions2, a1<-actions1, a1`compatible`a2]
where p = active g
cards = nub (playerHand p) -- remove duplicate investment cards
actions1 = ([Play (c,v) | (c,v)<-cards,
let vs=expeditions p!c, v`above`vs] ++
[Discard (c,v) | (c,v)<-cards])
actions2 = (DrawFromDeck :
[DrawFromDiscard c | (c,vs)<-Map.assocs (discard g),
not (null vs)])
-- list all subsequent positions from a position
positions :: Position -> [Position]
positions g
= [g' | m'<-moves g, let g'=snd (runSafePlay (play m') g)]
-- check if the two parts of a move are compatible
compatible :: Action1 -> Action2 -> Bool
compatible (Discard (c,_)) (DrawFromDiscard c') = c/=c'
compatible _ _ = True
-- check if a card face is playable above a stack
above :: Face -> Stack -> Bool
v `above` vs = null vs || v>=head vs
-- expand the game tree from a position
gametree :: Position -> Tree Position
gametree p = Node p (map gametree (positions p))
-- estimate the best move using minimax with alpha-beta prunning
dynamic :: Int -> Int -> Position -> Eval (Maybe Move)
dynamic depth breadth
= minimax_ab (-inf) inf .
prunebreadth breadth .
highfirst .
fmap static_eval .
prunedepth depth .
gametree .
begin
where -- start position for minimaxing
begin :: Position -> Position
begin g = g { leadMove = Nothing
, sign = 1
}
inf = toEval (maxBound :: Int)
-- static evaluation function
static_eval :: Position -> Eval (Maybe Move)
static_eval g
= let est = expectedScore g (active g) - expectedScore g (other g)
in Eval (sign g*est) (leadMove g)
{-
Compute the score estimate expected for a player
For each color:
* if no cards are played in an expedition, score zero
* otherwise, sum cards already player and weighted sum of unplayed cards
Uses fixed point a scaling factor of 10
(i.e. -200 corresponds to -20 pts)
-}
expectedScore :: Position -> Player -> Int
expectedScore g p = sum [expect c vs | (c,vs)<-Map.assocs (expeditions p)]
where
-- number of open expeditions
n = Map.size $ Map.filter (not.null) (expeditions p)
-- expected value in a single expection
expect c [] = 0
expect c vs1@(v':_) = score
where vs2 = [v | (c',v)<-playerHand p, c'==c && v>=v']
vs3 = [v | v<-take 1 (discard g!c),
playing p==playing (active g) && v>=v']
vs4 = [v | (c',v)<-drawPile g, c'==c && v>=v']
-- playable multipliers
mult = 1+length (filter (==0) (vs1++vs2++vs3))
score = mult*(-200
+ 10*sum vs1 -- cards in expedition
+ 8*sum vs2 -- playable cards in hand
+ 7*sum vs3 -- top card in discard
+ w*sum vs4 -- playable cards in deck
)
-- reduce the expected probability of drawing cards
-- when too many expeditions are open
w = if n>3 then 3 else 4
---------------------------------------------------------------
-- a monad for playing games
-- combination of state with error
--------------------------------------------------------------
type Play a = StateT Position (Either String) a
-- execute an action in the game monad
runPlay :: Play a -> Position -> Either String (a, Position)
runPlay = runStateT
evalPlay :: Play a -> Position -> Either String a
evalPlay = evalStateT
-- assumes the play action cannot fail
runSafePlay :: Play a -> Position -> (a, Position)
runSafePlay m g = either error id (runPlay m g)
-- same as above but ignores result value
runSafePlay' :: Play a -> Position -> Position
runSafePlay' m g = snd (runSafePlay m g)
-- create a player
newPlayer :: String -> Playing -> Player
newPlayer n p
= Player { name=n, playing=p, hidden=[], shown=[],
expeditions=Map.empty, accumulated=0
}
-- generate a new game position
-- randomly draws cards for both players
newGame :: String -> String -> IO Position
newGame n1 n2
= newRound (Position { active = newPlayer n1 Human
, other = newPlayer n2 Computer
, discard = Map.empty
, leadMove = Nothing
, drawPile = []
, turn = 0
, sign = 0
, round = 0})
-- reshuffle for a new roundu
newRound :: Position -> IO Position
newRound g
= do deck <- shuffleIO fullDeck
let (hand1,deck') = splitAt ncards deck
let (hand2,deck'')= splitAt ncards deck'
return $ g { active = p1 { hidden=sort hand1, shown=[], expeditions=empty }
, other = p2 { hidden=sort hand2, shown=[], expeditions=empty }
, discard = empty
, drawPile = deck''
, leadMove = Nothing
, turn = 0
, sign = 0
, round = 1 + round g
}
where ncards = 8
p1 = active g
p2 = other g
empty = Map.fromList $ zip colors (repeat [])
-- player's score
score :: Player -> Int
score p = Map.fold (+) 0 (Map.map scoreStack (expeditions p))
-- score a single expedition
scoreStack :: Stack -> Int
scoreStack [] = 0
scoreStack vs = bonus + mult*(sum vs - 20)
where mult = 1 + length (filter (==0) vs)
bonus = if length vs>=8 then 20 else 0
-- perform a move (comprising two actions)
play :: Move -> Play ()
play m@(a1,a2)
= do playAction1 a1
playAction2 a2
appendMove m
switchPlayer
-- perform individual actions
playAction1 :: Action1 -> Play ()
playAction1 (Play (c,v))
= do p<-gets active
let vs = expeditions p ! c
when (not (v`above`vs)) $
throwError "Must play cards in increasing order"
modify $ \g -> g { active = (p`withdraw`(c,v))
{ expeditions=Map.adjust (v:) c (expeditions p) }
, turn = 1+turn g
}
playAction1 (Discard (c,v))
= do p<-gets active
modify $ \g -> g { active = p`withdraw`(c,v)
, discard= Map.adjust (v:) c (discard g)
, turn = 1+turn g
}
-- second action
-- result value is the card drawn
playAction2 :: Action2 -> Play Card
playAction2 DrawFromDeck
= do p<-gets active
cs<-gets drawPile
when (null cs) $ throwError "Draw pile is empty"
modify $ \g -> g { active = addHidden p (head cs)
, drawPile = tail cs
, turn = 1+turn g
}
return (head cs)
playAction2 (DrawFromDiscard c)
= do p<-gets active
d<-gets discard
let vs = d!c
when (null vs) $ throwError "Discard pile is empty"
modify $ \g -> g { active = addShown p (c,head vs)
, discard = Map.adjust tail c (discard g)
, turn = 1+turn g
}
return (c, head vs)
-- switch active player
switchPlayer :: Play ()
switchPlayer
= modify $ \g -> g { active = other g,
other = active g,
sign = negate (sign g) }
-- append another move
appendMove :: Move -> Play ()
appendMove m
= modify $ \g -> g {leadMove = leadMove g `mplus` Just m}
-- "Monte Carlo" AI playing
-- apply minimax starting on alternative positions
-- compatible with the public information and choose the "best" move
bestAverageMove :: Int -> Int -> [Position] -> Move
bestAverageMove depth breadth positions = move
where moves = [fromJust $ fromEval $ dynamic depth breadth g | g<-positions]
assocs = [(a, length l) | l@(a:_) <- group (sort moves)]
move = fst $ maximumBy (\x y -> compare (snd x) (snd y)) assocs
-- obtain a "variant" of a game position
-- shuffles the opponent's hand and deck
variant :: Position -> IO Position
variant g = do cards'<-shuffleIO cards
let (hidden', deck') = splitAt n cards'
return $ g {drawPile=deck', other= (other g) {hidden=hidden'}}
where cards = hidden (other g) ++ drawPile g
n = length (hidden (other g))
-- AI players
-- increase minimax depth towards the end game
-- and reduce the number of statistic variants
strongAI, fastAI :: Position -> IO Move
strongAI g
= do gs <- sequence [variant g | _<-[1..nvars]]
return (bestAverageMove depth breadth gs)
where
ncards = length (drawPile g) -- number of cards left
nvars = min 1 (2*ncards)
breadth = 3
depth | ncards<15 = 8
| ncards<30 = 6
| otherwise = 4
-- faster AI, for slower machines
fastAI g
= do gs <- sequence [variant g | _<-[1..nvars]]
return (bestAverageMove depth breadth gs)
where
ncards = length (drawPile g) -- number of cards left
nvars = min 1 (2*ncards)
breadth = 3
depth | ncards<15 = 6
| otherwise = 4
defaultAI = strongAI