{- | module: Main description: Solving simple games license: MIT maintainer: Joe Leslie-Hurd stability: provisional portability: portable -} module Main -- ( main ) where import qualified Data.List as List import qualified Data.Map.Strict as Map import qualified Data.Set as Set import Data.Maybe (mapMaybe) import Numeric (showFFloat) import qualified System.Environment as Environment import System.FilePath ((),(<.>)) import System.IO (IOMode(..),hPutStrLn,withFile) import qualified Solve.FoxHounds as FH import Solve.Game (Eval(..),Event(..),Max(..),Moves,Player(..)) import qualified Solve.Game as Game import qualified Solve.NoughtsCrosses as NC import qualified Solve.QueenPawns as QP import Solve.Strategy (Strategy,StrategyFail) import qualified Solve.Strategy as Strategy import Solve.Util ------------------------------------------------------------------------------- -- Noughts & Crosses ------------------------------------------------------------------------------- dimNC :: String dimNC = let n = show NC.boardSize in n ++ "x" ++ n reachableNC :: Int reachableNC = Game.reachable NC.solution ppBestStudyNC :: Player -> String ppBestStudyNC pl = case Game.bestStudies stdy of [] -> "No good " ++ spl ++ " studies" ((_,p) : _) -> spl ++ " to move and win:\n\n" ++ Game.ppPlay (Game.criticalPath NC.game stdy pl p) where stdy = NC.study pl spl = NC.ppPlayer pl analyzeNC :: IO () analyzeNC = do putStrLn \$ "Board size: " ++ dimNC putStrLn \$ "Reachable positions: " ++ ppInteger reachableNC putStrLn \$ "Possible games: " ++ ppHugeInteger NC.gamesInitial putStrLn "" putStrLn \$ "Perfect game (" ++ NC.ppEval (NC.evalInitial NC.solution) ++ "):\n" putStr \$ Game.ppPlay (NC.perfectPlay Player1 NC.initial) putStrLn "" putStr \$ ppBestStudyNC Player1 putStrLn "" putStr \$ ppBestStudyNC Player2 ------------------------------------------------------------------------------- -- Fox & Hounds ------------------------------------------------------------------------------- type RowFH = (FH.Idx, (Bool,Int), Event, Max Event, [(FH.Idx,Integer)]) dimFH :: String dimFH = let n = show FH.boardSize in n ++ "x" ++ n dbFH :: FilePath dbFH = "doc" ("fox-hounds-" ++ dimFH) <.> "sql" reachableFH :: Int reachableFH = Game.reachable FH.solution solutionFH :: Eval solutionFH = FH.evalInitial FH.solution winnerFH :: Player winnerFH = case solutionFH of Win pl _ -> pl _ -> error "no winner" depthFH :: Moves depthFH = case solutionFH of Win _ n -> n _ -> error "no winner" reachableIdxFH :: (FH.Idx,FH.Idx) reachableIdxFH = (a,b) where a = minimum l b = maximum l l = map (FH.posToIdx . snd . fst) \$ Map.toList FH.solution incorrectPositionEvaluationsFH :: [(Player,FH.Pos,Eval,Eval)] incorrectPositionEvaluationsFH = mapMaybe diff \$ Map.toList FH.solution where diff ((pl,p),ev) = if Game.sameResult ev ev' then Nothing else Just (pl,p,ev,ev') where ev' = Game.evalUnsafe solution pl p solution = Game.solve game Player1 FH.initial game pl p = if null ps then Left (Game.winEval (Game.turn pl)) else Right ps where ps = FH.move pl p showIncorrectPositionEvaluationsFH :: [(Player,FH.Pos,Eval,Eval)] -> String showIncorrectPositionEvaluationsFH ds = show (length ds) ++ concatMap showDiff ds where showDiff (pl,p,e,e') = "\n\n" ++ Game.ppPlayerPosition pl p ++ "Incorrect position evaluation: " ++ FH.ppEval e ++ "\n" ++ "Correct position evaluation: " ++ FH.ppEval e' infiniteMaxFoxBoxFH :: [(Player,FH.Pos)] infiniteMaxFoxBoxFH = map fst \$ filter f \$ Map.toList FH.maxFoxBox where f ((pl,p), Max n _) = (n == Never) /= FH.winningForFox pl p showInfiniteMaxFoxBoxFH :: [(Player,FH.Pos)] -> String showInfiniteMaxFoxBoxFH ps = show (length ps) ++ concatMap showPos ps where showPos (pl,p) = "\n\n" ++ Game.ppPlayerPosition pl p ++ "Position evaluation: " ++ FH.ppEval ev ++ "\n" ++ "Maximum FoxBox: " ++ show fb where ev = Game.evalUnsafe FH.solution pl p fb = Game.evalUnsafe FH.maxFoxBox pl p foxBoxStrategyFailFH :: StrategyFail FH.Pos foxBoxStrategyFailFH = FH.validateStrategy Player2 (Strategy.tryStrategy (FH.foxBoxStrategy 1)) showStrategyFailFH :: StrategyFail FH.Pos -> String showStrategyFailFH ps = show n ++ (if n == 0 then "" else "\n" ++ tableFails) where n = Set.size ps showPos (p,e) = tail (show p) ++ FH.ppEval e rowsFail (a,b,c) = [] : zipWith3 tripleton (linesPos a) (linesPos b) (linesPos c) where linesPos = lines . showPos header = ["Position","Strategy move","Better move"] tableFails = ppTable ([] : header : concat (map rowsFail (Set.toList ps)) ++ [[]]) houndsStopLossFH :: Int -> Strategy FH.Pos houndsStopLossFH n = Strategy.tryStrategy (FH.stopLossStrategy Player2 n) houndsStopLossFoxBox1FH :: Int -> Strategy FH.Pos houndsStopLossFoxBox1FH n = Strategy.thenStrategy (Strategy.tryStrategy (FH.stopLossStrategy Player2 n)) (Strategy.tryStrategy (FH.foxBoxStrategy 1)) houndsVictoryFH :: (Player,FH.Pos) houndsVictoryFH = FH.typical f where f pl p = Game.evalUnsafe FH.solution pl p == Win Player2 0 foxEscapedFH :: (Player,FH.Pos) foxEscapedFH = FH.typical (const FH.foxEscaped) foxVictoryWithoutEscapeFH :: (Player,FH.Pos) foxVictoryWithoutEscapeFH = FH.typical f where f pl p = Game.evalUnsafe FH.solution pl p == Win Player1 0 && not (FH.foxEscaped p) typicalFoxBoxFH :: (Player,FH.Pos) typicalFoxBoxFH = FH.typical f where f pl p = pl == Player1 && FH.isFoxBox p && case Game.evalUnsafe FH.maxFoxBox pl p of Max (In n) _ -> n > 0 Max Never _ -> True getPositionFH :: String -> (Player,FH.Pos) getPositionFH "initial" = (Player1,FH.initial) getPositionFH "opposite" = FH.opposite getPositionFH "hounds victory" = houndsVictoryFH getPositionFH "fox escaped" = foxEscapedFH getPositionFH "fox victory without escape" = foxVictoryWithoutEscapeFH getPositionFH "typical FoxBox" = typicalFoxBoxFH getPositionFH _ = error "unknown position" initialPositionsFH :: (String,String) initialPositionsFH = case winnerFH of Player1 -> ("opposite","initial") Player2 -> ("initial","opposite") ppPositionFH :: String -> String ppPositionFH s = sp ++ ":\n" ++ FH.ppPlayer pl ++ " to move" ++ show p ++ "Evaluation: " ++ FH.ppEval ev ++ "\n" ++ "FoxBox: " ++ show fb ++ "\n" ++ "Maximum FoxBox: " ++ show mfb ++ "\n" ++ "Index: " ++ show idx where sp = ucfirst s ++ " position" ev = Game.evalUnsafe FH.solution pl p fb = Game.evalUnsafe FH.foxBox pl p mfb = Game.evalUnsafe FH.maxFoxBox pl p idx = FH.posToIdx p (pl,p) = getPositionFH s ppBestStudyFH :: Player -> String ppBestStudyFH pl = case Game.bestStudies stdy of [] -> "No good " ++ spl ++ " studies" ((_,p) : _) -> spl ++ " to move and win:\n" ++ Game.ppPlay (Game.criticalPath FH.game stdy pl p) ++ "Study position index: " ++ show (FH.posToIdx p) ++ "\n" where stdy = FH.study pl spl = FH.ppPlayer pl probWinFH :: Int -> ((Prob,Prob,Prob),Prob) probWinFH n = ((f1,f2,f3),h1) where f1 = pfw \$ houndsStopLossFH n f2 = pfw \$ houndsStopLossFoxBox1FH n f3 = pfw \$ FH.houndsStrategyN n h1 = phw \$ FH.foxStrategyN n pfw = pw Player1 (getPositionFH (fst initialPositionsFH)) phw = pw Player2 (getPositionFH (snd initialPositionsFH)) pw spl (pl,p) adv = fst \$ Strategy.probWinWith FH.game spl adv Map.empty pl p probDepthFH :: [(Int,((Prob,Prob,Prob),Prob))] probDepthFH = map f [0..depthFH] where f n = (n, probWinFH n) showProbDepthFH :: [(Int,((Prob,Prob,Prob),Prob))] -> String showProbDepthFH ps = ppTable ([] : ["Strategy\ndepth", "Fox wins\nvs\nStopLoss\nfrom\n" ++ ifp ++ "\nposition", "Fox wins\nvs\nStopLoss\n+FoxBox1\nfrom\n" ++ ifp ++ "\nposition", "Fox wins\nvs\nStopLoss\n+ FoxBox\nfrom\n" ++ ifp ++ "\nposition", "Hounds\nwin\nvs\nStopLoss\nfrom\n" ++ ihp ++ "\nposition"] : [] : map row ps ++ [[]]) where (ifp,ihp) = initialPositionsFH row (n,((f1,f2,f3),h1)) = [show n, showProb f1, showProb f2, showProb f3, showProb h1] fuzzTableFH :: (Prob,[(Prob,(Prob,Prob))]) fuzzTableFH = binary [] (0.0, entry 0.0) (1.0, entry 1.0) [] where threshold = 0.00001 target = 0.5 binary ls (lf,lp) (uf,up) us = if uf - lf < threshold then (lf, reverse ls ++ [(lf,lp),(uf,up)] ++ us) else if loser p < target then binary ((lf,lp) : ls) (f,p) (uf,up) us else binary ls (lf,lp) (f,p) ((uf,up) : us) where f = (lf + uf) / 2.0 p = entry f loser = case winnerFH of Player1 -> snd ; Player2 -> fst entry fuzz = (probFox,probHounds) where probFox = prob fuzz Player1 (getPositionFH (fst initialPositionsFH)) probHounds = prob fuzz Player2 (getPositionFH (snd initialPositionsFH)) prob fuzz spl (pl,p) = fst \$ Strategy.probWinWith FH.game spl adv Map.empty pl p where adv = FH.strategy fuzz (Game.turn spl) fuzzFH :: Prob fuzzFH = fst fuzzTableFH showFuzzTableFH :: (Prob,[(Prob,(Prob,Prob))]) -> String showFuzzTableFH (fuzz,rows) = showFuzz fuzz ++ "\n" ++ ppTable ([] : ["Fuzz\nfactor", "Fox wins\nfrom\n" ++ ifp ++ "\nposition", "Hounds\nwin\nfrom\n" ++ ihp ++ "\nposition"] : [] : map showRow rows ++ [[]]) where (ifp,ihp) = initialPositionsFH showRow (f,(pf,ph)) = [showFuzz f, showProb pf, showProb ph] showFuzz p = showFFloat (Just 6) p "" maxIntCdfFH :: Integer maxIntCdfFH = 100000 posEntryFH :: (Player,FH.Pos) -> RowFH posEntryFH (pl,p) = (FH.posToIdx p, w, fb, fbm, moves mvs) where w = (FH.winningForFox pl p, FH.winDepth pl p) fb = Game.evalUnsafe FH.foxBox pl p fbm = Game.evalUnsafe FH.maxFoxBox pl p mvs = FH.moveDist fuzzFH pl p moves = fst . mapLR cdf 0.0 . map snd . List.sort . map posIdx where cdf s (q,pr) = let s' = s + pr in ((q, round (s' * m)), s') posIdx (q,pr) = (FH.coordToSquare (moved q), (FH.posToIdx q, pr)) moved = Set.findMin . Set.difference (pieces p) . pieces pieces q = Set.insert (FH.fox q) (FH.hounds q) m = fromInteger maxIntCdfFH posTableFH :: [RowFH] posTableFH = map posEntryFH \$ Map.keys FH.solution showPosEntryFH :: RowFH -> String showPosEntryFH (pos, (wf,wd), fb, Max fbv fbk, mvs) = "INSERT INTO `foxhounds` VALUES " ++ "(" ++ List.intercalate "," values ++ ");" where values = show pos : showBool wf : show wd : showEvent fb : showEvent fbv : show fbk : show mvn : concat (map showMove mvs) ++ replicate (3 * (8 - mvn)) "NULL" mvn = length mvs showEvent (In k) = show k showEvent Never = "NULL" showMove (pos',cdf) = [show pos', "0", show cdf] showBool True = "'T'" showBool False = "'F'" writePosTableFH :: FilePath -> [RowFH] -> IO () writePosTableFH file entries = withFile file WriteMode \$ \h -> mapM_ (hPutStrLn h . showPosEntryFH) entries analyzeFH :: IO () analyzeFH = do putStrLn \$ "Board size: " ++ dimFH putStrLn \$ "Reachable positions: " ++ ppInteger reachableFH putStrLn \$ "Reachable position index range: " ++ show reachableIdxFH putStrLn \$ "Possible games: " ++ ppHugeInteger FH.gamesInitial putStrLn "" putStrLn \$ ppPositionFH "initial" putStrLn "" putStrLn \$ ppPositionFH "opposite" putStrLn "" putStrLn \$ ppPositionFH "hounds victory" putStrLn "" putStrLn \$ ppPositionFH "fox escaped" putStrLn "" putStrLn \$ ppPositionFH "fox victory without escape" putStrLn "" putStrLn \$ ppPositionFH "typical FoxBox" putStrLn "" putStrLn \$ "Perfect game (" ++ FH.ppEval solutionFH ++ "):" putStr \$ Game.ppPlay (FH.perfectPlay Player1 FH.initial) putStrLn "" putStr \$ ppBestStudyFH Player1 putStrLn "" putStr \$ ppBestStudyFH Player2 putStrLn "" putStrLn \$ "Incorrect position evaluations: " ++ showIncorrectPositionEvaluationsFH incorrectPositionEvaluationsFH putStrLn \$ "FoxBox strategy failure positions: " ++ showStrategyFailFH foxBoxStrategyFailFH putStrLn \$ "Positions violating infinite maximum FoxBox iff winning for Fox: " ++ showInfiniteMaxFoxBoxFH infiniteMaxFoxBoxFH putStrLn "" if FH.boardSize > 8 then return () else do putStrLn \$ "Win probabilities against strategies of different depths:" putStrLn \$ showProbDepthFH probDepthFH putStr \$ "Fairest fuzz factor: " putStrLn \$ showFuzzTableFH fuzzTableFH putStr \$ "Creating game database in " ++ dbFH ++ ":" writePosTableFH dbFH posTableFH putStrLn \$ " " ++ show (length posTableFH) ++ " rows" ------------------------------------------------------------------------------- -- Queen & Pawns ------------------------------------------------------------------------------- dimQP :: String dimQP = let n = show QP.boardSize in n ++ "x" ++ n reachableQP :: Int reachableQP = Game.reachable QP.solution reachableIdxQP :: (QP.Idx,QP.Idx) reachableIdxQP = (QP.unPos a, QP.unPos b) where ((_,a),_) = Map.findMin QP.solution ((_,b),_) = Map.findMax QP.solution getPositionQP :: String -> (Player,QP.Pos) getPositionQP "initial" = (Player1,QP.initial) getPositionQP "opposite" = QP.opposite getPositionQP _ = error "unknown position" ppPositionQP :: String -> String ppPositionQP s = sp ++ ":\n" ++ Game.ppPlayerPosition pl p ++ "Evaluation: " ++ QP.ppEval ev ++ "\n" ++ "Index: " ++ show idx where sp = ucfirst s ++ " position" ev = Game.evalUnsafe QP.solution pl p idx = QP.unPos p (pl,p) = getPositionQP s ppBestStudyQP :: Player -> String ppBestStudyQP pl = case Game.bestStudies stdy of [] -> "No good " ++ spl ++ " studies" ((_,p) : _) -> spl ++ " to move and win:\n" ++ Game.ppPlay (Game.criticalPath QP.game stdy pl p) where stdy = QP.study pl spl = QP.ppPlayer pl analyzeQP :: IO () analyzeQP = do putStrLn \$ "Board size: " ++ dimQP putStrLn \$ "Reachable positions: " ++ ppInteger reachableQP putStrLn \$ "Reachable position index range: " ++ show reachableIdxQP putStrLn \$ "Possible games: " ++ ppHugeInteger QP.gamesInitial putStrLn "" putStrLn \$ ppPositionQP "initial" putStrLn "" putStrLn \$ ppPositionQP "opposite" putStrLn "" putStrLn \$ "Perfect game (" ++ QP.ppEval (QP.evalInitial QP.solution) ++ "):" putStr \$ Game.ppPlay (QP.perfectPlay Player1 QP.initial) putStrLn "" putStr \$ ppBestStudyQP Player1 putStrLn "" putStr \$ ppBestStudyQP Player2 ------------------------------------------------------------------------------- -- Top-level ------------------------------------------------------------------------------- lineLength :: Int lineLength = 75 games :: [(String, String, IO ())] games = [("NC", "Noughts & Crosses", analyzeNC), ("FH", "Fox & Hounds", analyzeFH), ("QP", "Queen & Pawns", analyzeQP)] usage :: String -> a usage err = error \$ err ++ "\n" ++ info where info = "Usage: solve GAME\n" ++ "where GAME is one of the following:" ++ concatMap gameOpt games gameOpt (o,n,_) = "\n " ++ o ++ " : " ++ n main :: IO () main = do args <- Environment.getArgs let opt = case args of [] -> usage "no arguments" [o] -> o _ -> usage "too many arguments" let (name,analyze) = case filter (\(o,_,_) -> o == opt) games of [] -> usage "unknown game" [(_,n,a)] -> (n,a) _ -> error "duplicate game" ___ putStrLn name putStrLn "" analyze ___ return () where ___ = putStrLn \$ replicate lineLength '_'