module Solve.FoxHounds
where
import qualified Data.Char as Char
import Data.List (sort)
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Solve.Game (Eval(..),Event,Force,Game,Games,Max(..),Player(..),PlayerState(..),Solve,Study,Val)
import qualified Solve.Game as Game
import Solve.Strategy (Adversaries,ProbWin,Strategy,StrategyFail)
import qualified Solve.Strategy as Strategy
import Solve.Util
packSize :: Int
packSize = 4
boardSize :: Int
boardSize = 2 * packSize
numSquares :: Int
numSquares = packSize * boardSize
type Idx = Int
data Coord =
Coord Int Int
deriving (Eq,Ord)
instance Show Coord where
show (Coord x y) = Char.chr (Char.ord 'a' + x) : show (y + 1)
onBoard :: Coord -> Bool
onBoard (Coord x y) =
0 <= x && x < boardSize &&
0 <= y && y < boardSize &&
(x + y) `mod` 2 == 1
rankAdjacent :: Int -> Int -> [Coord]
rankAdjacent x y = filter onBoard [Coord (x - 1) y, Coord (x + 1) y]
foxAdjacent :: Coord -> [Coord]
foxAdjacent (Coord x y) = rankAdjacent x (y - 1) ++ rankAdjacent x (y + 1)
houndAdjacent :: Coord -> [Coord]
houndAdjacent (Coord x y) = rankAdjacent x (y + 1)
houndsReachable :: Set Coord -> Set Coord
houndsReachable = transitiveClosure houndAdjacent . Set.toList
foxReachable :: Set Coord -> Coord -> Set Coord
foxReachable hs =
transitiveClosure unhounded . singleton
where
unhounded = filter (flip Set.notMember hs) . foxAdjacent
coordParity :: Coord -> Bool
coordParity (Coord _ y) = y `mod` 2 == 1
coordToSquare :: Coord -> Idx
coordToSquare (Coord x y) = packSize * (boardSize - (y + 1)) + x `div` 2
squareToCoord :: Idx -> Coord
squareToCoord i = Coord x y
where
y = (boardSize - 1) - (i `div` packSize)
x = 2 * (i `mod` packSize) + (1 - y `mod` 2)
data Pos =
Pos
{fox :: Coord,
hounds :: Set Coord}
deriving (Eq,Ord)
instance Show Pos where
show p = "\n" ++ side ++ concat (map row (reverse inds)) ++ side
where
side = "+" ++ replicate boardSize '-' ++ "+\n"
inds = [0..(boardSize-1)]
row y = "|" ++ map (entry . flip Coord y) inds ++ "|\n"
entry c =
if c == fox p then 'F'
else if Set.member c (hounds p) then 'H'
else if onBoard c then '*'
else ' '
initial :: Pos
initial =
Pos
{fox = Coord (2 * (n `div` 2)) (boardSize - 1),
hounds = Set.fromList (map (\x -> Coord (2 * x + 1) 0) [0..(n-1)])}
where
n = boardSize `div` 2
occupied :: Pos -> Coord -> Bool
occupied p c = c == fox p || Set.member c (hounds p)
empty :: Pos -> Coord -> Bool
empty p = not . occupied p
isFoxBox :: Pos -> Bool
isFoxBox p = Set.size f == 1 || Set.isSubsetOf f h
where
f = foxReachable (hounds p) (fox p)
h = houndsReachable (hounds p)
posParity :: Pos -> Bool
posParity p = parity $ map coordParity (fox p : Set.toList (hounds p))
posToMove :: Pos -> Player
posToMove =
\p -> if posParity p == ip then Player1 else Player2
where
ip = posParity initial
posToIdx :: Pos -> Idx
posToIdx p = foldl pack 0 (f : hs)
where
pack n c = n * numSquares + c
f = coordToSquare (fox p) + 1
hs = sort $ map coordToSquare $ Set.toList $ hounds p
idxToPos :: Idx -> Pos
idxToPos i =
Pos
{fox = squareToCoord (f - 1),
hounds = Set.fromList (map squareToCoord hs)}
where
unpack n = (n `mod` numSquares, n `div` numSquares)
(hs,f) = unfoldN unpack packSize i
foxMove :: Pos -> [Pos]
foxMove p = map mk cl
where
mk c = p {fox = c}
cl = filter (empty p) (foxAdjacent (fox p))
houndsMove :: Pos -> [Pos]
houndsMove p = map mk (updateSet mv (hounds p))
where
mk hs = p {hounds = hs}
mv h = filter (empty p) (houndAdjacent h)
move :: Player -> Pos -> [Pos]
move Player1 p = foxMove p
move Player2 p = houndsMove p
foxEscaped :: Pos -> Bool
foxEscaped p = safe f && any safe (foxAdjacent f)
where
f = fox p
safe = flip Set.notMember $ houndsReachable (hounds p)
won :: Player -> Pos -> Maybe Player
won pl p | null (move pl p) = Just (Game.turn pl)
won _ p | foxEscaped p = Just Player1
won _ _ | otherwise = Nothing
game :: Game Pos
game pl p =
if null ps then Left (Game.winEval (Game.turn pl))
else if foxEscaped p then Left (Game.winEval Player1)
else Right ps
where
ps = move pl p
gameOver :: Player -> Pos -> Bool
gameOver = Game.gameOver game
evalInitial :: Val Pos v -> v
evalInitial db = Game.evalUnsafe db Player1 initial
bfsInitial :: [(Player,Pos)]
bfsInitial = Game.bfs game Player1 initial
solution :: Solve Pos
solution = Game.solve game Player1 initial
winningFor :: Player -> Player -> Pos -> Bool
winningFor wpl pl p = Game.winning wpl (Game.evalUnsafe solution pl p)
winningForFox :: Player -> Pos -> Bool
winningForFox = winningFor Player1
winningForHounds :: Player -> Pos -> Bool
winningForHounds = winningFor Player2
winDepth :: Player -> Pos -> Int
winDepth pl p =
case Game.evalUnsafe solution pl p of
Win _ d -> d
Draw -> error "draws are not possible in this game"
perfectPlay :: Player -> Pos -> [(Player,Pos)]
perfectPlay = Game.perfectPlay game solution
games :: Games Pos
games = Game.games game Player1 initial
gamesInitial :: Integer
gamesInitial = evalInitial games
study :: Player -> Study Pos
study spl = Game.study game solution spl Player1 initial
foxBox :: Force Pos
foxBox = Game.force game Player2 isWinningFoxBox Player1 initial
where
isWinningFoxBox pl p = winningForHounds pl p && isFoxBox p
maxFoxBox :: Val Pos (Max Event)
maxFoxBox = Game.gameMax game Player1 (Game.evalUnsafe foxBox) Player1 initial
stopLossStrategy :: Player -> Int -> Strategy Pos
stopLossStrategy = Strategy.stopLossStrategy solution
foxBoxStrategy :: Int -> Strategy Pos
foxBoxStrategy = Strategy.forceStrategy foxBox Player2
maxFoxBoxStrategy :: Player -> Strategy Pos
maxFoxBoxStrategy = Strategy.maxStrategy . Game.evalUnsafe maxFoxBox
foxStrategyN :: Int -> Strategy Pos
foxStrategyN n = Strategy.tryStrategy (stopLossStrategy Player1 n)
houndsStrategyN :: Int -> Strategy Pos
houndsStrategyN n =
Strategy.thenStrategy
(Strategy.tryStrategy (stopLossStrategy Player2 n))
(Strategy.tryStrategy (foxBoxStrategy n))
adversaries :: Adversaries Pos
adversaries = PlayerState (mk houndsStrategyN, mk foxStrategyN)
where mk sf = map (flip (,) Map.empty . sf) [0..]
strategy :: Prob -> Player -> Strategy Pos
strategy fuzz pl =
Strategy.mixedStrategy fuzz
Strategy.idStrategy
(Strategy.thenStrategy (Strategy.sameResultStrategy pl pe) str)
where
str [] = []
str pws =
(if Game.winning Player1 (pe $ fst $ head pws)
then Strategy.bestStrategy Player2 pe
else maxFoxBoxStrategy pl') pws
pe = Game.evalUnsafe solution pl'
pl' = Game.turn pl
moveDist :: Prob -> Player -> Pos -> [(Pos,Prob)]
moveDist fuzz pl p = Strategy.moveDistStrategy game (strategy fuzz pl) pl p
validateStrategy :: Player -> Strategy Pos -> StrategyFail Pos
validateStrategy pl str =
Strategy.validateStrategy game solution pl str Player1 initial
probWin :: Player -> Strategy Pos -> ProbWin Pos
probWin pl adv = Strategy.probWin game pl adv Player1 initial
opposite :: (Player,Pos)
opposite =
case filter (opp . ev) bfsInitial of
[] -> error "no opposite positions"
p : _ -> p
where
opp = not . Game.sameResult (evalInitial solution)
ev = uncurry $ Game.evalUnsafe solution
evalOpposite :: Val Pos v -> v
evalOpposite db = uncurry (Game.evalUnsafe db) opposite
typical :: (Player -> Pos -> Bool) -> (Player,Pos)
typical f = middle $ filter (uncurry f) bfsInitial
instance Game.Printable Pos where
ppPosition = tail . show
ppPlayer _ Player1 = "Fox"
ppPlayer _ Player2 = "Hounds"
ppPlayer :: Player -> String
ppPlayer = Game.ppPlayer initial
ppEval :: Eval -> String
ppEval = Game.ppEval initial