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
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
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
data Eval =
Win Player Moves
| Draw
deriving (Eq,Show)
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
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
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
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
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
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
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
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
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
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}