{- |
module: $Header$
description: Finite two-player games
license: MIT

maintainer: Joe Leslie-Hurd <joe@gilith.com>
stability: provisional
portability: portable
-}

module Solve.Game
where

import Data.Function (on)
import Data.List (intersperse,maximumBy)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe,mapMaybe)

import qualified Solve.Graph as Graph
import Solve.Util

-------------------------------------------------------------------------------
-- Players
-------------------------------------------------------------------------------

--
-- Player1 moves first
--
data Player =
    Player1
  | Player2
  deriving (Eq,Ord,Show,Enum,Bounded)

newtype PlayerState s = PlayerState (s,s)

turn :: Player -> Player
turn Player1 = Player2
turn Player2 = Player1

getPlayerState :: PlayerState s -> Player -> s
getPlayerState (PlayerState (s1,_)) Player1 = s1
getPlayerState (PlayerState (_,s2)) Player2 = s2

updatePlayerState :: (s -> (a,s)) -> PlayerState s -> Player -> (a, PlayerState s)
updatePlayerState f (PlayerState (s1,s2)) Player1 = (x, PlayerState (s1',s2))
  where (x,s1') = f s1
updatePlayerState f (PlayerState (s1,s2)) Player2 = (x, PlayerState (s1,s2'))
  where (x,s2') = f s2

-------------------------------------------------------------------------------
-- Game length
-------------------------------------------------------------------------------

type Moves = Int

data Event =
    In Moves
  | Never
  deriving (Eq,Ord,Show)

now :: Event
now = In 0

delay :: Event -> Event
delay (In n) = In (n + 1)
delay Never = Never

nowOrNever :: Bool -> Event
nowOrNever True = now
nowOrNever False = Never

-------------------------------------------------------------------------------
-- Position evaluations
-------------------------------------------------------------------------------

data Eval =
    Win Player Moves
  | Draw
  deriving (Eq,Show)

--
-- Best result for Player1 compares highest
--
instance Ord Eval where
  compare (Win Player1 n1) (Win Player1 n2) = compare n2 n1
  compare (Win Player1 _) _ = GT
  compare _ (Win Player1 _) = LT
  compare (Win Player2 n1) (Win Player2 n2) = compare n1 n2
  compare (Win Player2 _) _ = LT
  compare _ (Win Player2 _) = GT
  compare Draw Draw = EQ

compareEval :: Player -> Eval -> Eval -> Ordering
compareEval Player1 = compare
compareEval Player2 = flip compare

betterEval :: Player -> Eval -> Eval -> Bool
betterEval pl x y =
    case compareEval pl x y of
      GT -> True
      _ -> False

bestEval :: Player -> [Eval] -> Eval
bestEval = maximumBy . compareEval

winEval :: Player -> Eval
winEval p = Win p 0

delayEval :: Eval -> Eval
delayEval (Win p n) = Win p (n + 1)
delayEval Draw = Draw

turnEval :: Eval -> Eval
turnEval (Win pl n) = Win (turn pl) n
turnEval Draw = Draw

betterResult :: Player -> Eval -> Eval -> Bool
betterResult pl (Win pl1 _) (Win pl2 _) = pl1 == pl && pl2 /= pl
betterResult pl (Win pl1 _) Draw = pl1 == pl
betterResult pl Draw (Win pl2 _) = pl2 /= pl
betterResult _ Draw Draw = False

sameResult :: Eval -> Eval -> Bool
sameResult e1 e2 =
    not (betterResult Player1 e1 e2 || betterResult Player2 e1 e2)

winning :: Player -> Eval -> Bool
winning pl e = betterResult pl e Draw

-------------------------------------------------------------------------------
-- Game definition
-------------------------------------------------------------------------------

--
-- The list of legal moves must not be empty or contain duplicate positions
--
type Game p = Player -> p -> Either Eval [p]

move :: Game p -> Player -> p -> [p]
move game pl p =
    case game pl p of
      Left _ -> []
      Right ps -> ps

gameOver :: Game p -> Player -> p -> Bool
gameOver game pl p =
    case game pl p of
      Left _ -> True
      Right _ -> False

-------------------------------------------------------------------------------
-- Depth-first search
-------------------------------------------------------------------------------

type DfsPre p a v = Player -> Graph.DfsPre p a v

type DfsPost p a v = Player -> Graph.DfsPost p a v

type Val p v = Graph.DfsResult (Player,p) v

dfsWith :: Ord p => DfsPre p a v -> DfsPost p a v ->
           Val p v -> Player -> p -> (v, Val p v)
dfsWith pre post = curry . Graph.dfsWith pre' post'
  where
    pre' (pl,p) =
        case pre pl p of
          Left v -> Left v
          Right aps -> Right (map (addPl (turn pl)) aps)

    post' (pl,p) = post pl p . map delPl

    addPl pl (a,p) = (a,(pl,p))

    delPl ((a,(_,p)),v) = ((a,p),v)

eval :: Ord p => Val p v -> Player -> p -> Maybe v
eval = curry . Graph.eval

evalUnsafe :: Ord p => Val p v -> Player -> p -> v
evalUnsafe = curry . Graph.evalUnsafe

-------------------------------------------------------------------------------
-- Breadth-first search
-------------------------------------------------------------------------------

bfs :: Ord p => Game p -> Player -> p -> [(Player,p)]
bfs game = curry $ Graph.bfs next
  where next (pl,p) = map ((,) (turn pl)) $ move game pl p

-------------------------------------------------------------------------------
-- Game solution
-------------------------------------------------------------------------------

type Solve p = Val p Eval

solveWith :: Ord p => Game p -> Solve p -> Player -> p -> (Eval, Solve p)
solveWith game = dfsWith pre post
  where
    pre pl p =
        case game pl p of
          Left v -> Left v
          Right ps -> Right (map ((,) ()) ps)

    post pl _ = delayEval . bestEval pl . map (fromMaybe Draw . snd)

solve :: Ord p => Game p -> Player -> p -> Solve p
solve game pl p = snd $ solveWith game Map.empty pl p

reachable :: Solve p -> Int
reachable = Map.size

perfectPlay :: Ord p => Game p -> Solve p -> Player -> p -> [(Player,p)]
perfectPlay game soln = go
  where
    go pl p = (pl,p) : (case game pl p of Left _ -> [] ; Right ps -> sel pl ps)
    sel pl ps = go pl' (fst $ maximumBy (compareEval pl `on` snd) (map f ps))
      where
        f p = (p, evalUnsafe soln pl' p)
        pl' = turn pl

-------------------------------------------------------------------------------
-- The number of possible games
-------------------------------------------------------------------------------

type Games p = Val p Integer

gamesWith :: Ord p => Game p -> Games p -> Player -> p -> (Integer, Games p)
gamesWith game = dfsWith pre post
  where
    pre pl p =
        case game pl p of
          Left _ -> Left 1
          Right ps -> Right (map ((,) ()) ps)

    post _ _ = sum . map (acyclic . snd)

    acyclic (Just n) = n
    acyclic Nothing = error "loopy game"

games :: Ord p => Game p -> Player -> p -> Games p
games game pl p = snd $ gamesWith game Map.empty pl p

-------------------------------------------------------------------------------
-- Forcing positions that satisfy a predicate
-------------------------------------------------------------------------------

type Force p = Val p Event

forceWith :: Ord p => Game p -> Player -> (Player -> p -> Bool) ->
             Force p -> Player -> p -> (Event, Force p)
forceWith game fpl isp = dfsWith pre post
  where
    best pl = if pl == fpl then minimum else maximum

    pre pl p =
        case game pl p of
          Left _ -> Left (nowOrNever (isp pl p))
          Right ps -> Right (map ((,) ()) ps)

    post pl p =
        if isp pl p then const now
        else delay . best pl . map (fromMaybe Never . snd)

force :: Ord p => Game p -> Player -> (Player -> p -> Bool) ->
         Player -> p -> Force p
force game fpl isp pl p = snd $ forceWith game fpl isp Map.empty pl p

-------------------------------------------------------------------------------
-- Maximizing a position value over a game
-------------------------------------------------------------------------------

data Max v = Max v Moves
  deriving (Show,Eq)

instance Ord v => Ord (Max v) where
  compare (Max v1 k1) (Max v2 k2) =
      case compare v1 v2 of
        LT -> LT
        EQ -> compare k2 k1
        GT -> GT

gameMaxWith :: (Ord p, Ord v) => Game p -> Player -> (Player -> p -> v) ->
               Val p (Max v) -> Player -> p -> (Max v, Val p (Max v))
gameMaxWith game mpl pv = dfsWith pre post
  where
    pre pl p =
        case game pl p of
          Left _ -> Left (valNow pl p)
          Right ps -> Right (map ((,) ()) ps)

    post pl p = optimize . map valLater . mapMaybe snd
      where
        optimize [] = vk
        optimize vks = max vk ((if pl == mpl then maximum else minimum) vks)
        vk = valNow pl p

    valNow pl p = Max (pv pl p) 0
    valLater (Max v k) = Max v (k + 1)

gameMax :: (Ord p, Ord v) => Game p -> Player -> (Player -> p -> v) ->
           Player -> p -> Val p (Max v)
gameMax game mpl pv pl p = snd $ gameMaxWith game mpl pv Map.empty pl p

-------------------------------------------------------------------------------
-- Finding studies (sequences of only moves to win the game)
-------------------------------------------------------------------------------

type Study p = (Player, Val p Int)

studyWith :: Ord p => Game p -> Solve p ->
             Study p -> Player -> p -> (Int, Study p)
studyWith game soln (spl,sval0) pl0 p0 = (v1, (spl,sval1))
  where
    (v1,sval1) = dfsWith pre post sval0 pl0 p0

    pre pl p =
        case game pl p of
          Left e -> Left (if winning spl e then 1 else 0)
          Right ps -> Right (map ((,) ()) ps)

    post pl p =
        if not (winning spl e) then const 0
        else if pl == spl then uniq . mapMaybe (incWin . snd)
        else maximum . mapMaybe snd
      where
        incWin Nothing = Nothing
        incWin (Just v) = if v == 0 then Nothing else Just (v + 1)
        uniq [v] = v
        uniq _ = 1
        e = evalUnsafe soln pl p

study :: Ord p => Game p -> Solve p -> Player -> Player -> p -> Study p
study game soln spl pl p = snd $ studyWith game soln (spl,Map.empty) pl p

bestStudies :: Study p -> [(Player,p)]
bestStudies (spl,sval) = snd $ Map.foldrWithKey best (2,[]) sval
  where
    best (pl,_) _ bps | pl /= spl = bps
    best p v (b,ps) | otherwise =
        case compare v b of
          LT -> (b,ps)
          EQ -> (b, p : ps)
          GT -> (v, [p])

criticalPath :: Ord p => Game p -> Study p -> Player -> p -> [(Player,p)]
criticalPath game (_,sval) = go
  where
    go pl p = (pl,p) : (case game pl p of Left _ -> [] ; Right ps -> sel pl ps)
    sel pl ps = if v <= 1 then [(pl',p')] else go pl' p'
      where
        (p',v) = maximumBy (compare `on` snd) (map pv ps)
        pv p = (p, evalUnsafe sval pl' p)
        pl' = turn pl

-------------------------------------------------------------------------------
-- Pretty printing
-------------------------------------------------------------------------------

class Printable p where
  ppPosition :: p -> String

  ppPlayer :: p -> Player -> String
  ppPlayer _ pl = show pl

  ppPlayerPosition :: Player -> p -> String
  ppPlayerPosition pl p = ppPlayer p pl ++ " to move\n" ++ ppPosition p

  ppEval :: p -> Eval -> String
  ppEval p (Win pl n) = ppPlayer p pl ++ " win in " ++ show n
  ppEval _ Draw = "Draw"

  ppPlay :: [(Player,p)] -> String
  ppPlay [] = ""
  ppPlay ((pl,p) : ps) = fmtTable fmt (intersperse [] ms)
    where
      ms = groupl 2 (if pl == Player1 then sl else "" : sl)
      sl = map ppPosition (p : map snd ps)
      fmt = Table {borderTable = False, alignLeftTable = True, paddingTable = 3}