{- 
   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