set-cover-0.1: example/Mastermind.hs
{- |
https://en.wikipedia.org/wiki/Mastermind_(board_game)
Given a list of guesses and according evaluations,
the solver computes a list of all possible codes
that match the obtained evaluations.
See also the @board-games@ package.
-}
module Main where
import qualified Mastermind.Example as Example
import qualified Mastermind.Guess as Guess
import Mastermind.Distinguish (distinguishingCodesCondensed)
import Mastermind.Utility (histogram)
import Mastermind.Guess (
consistentCodes,
evaluate,
countEval,
codeFromLabels,
assignsFromGuesses,
defaultAssignFlags,
AssignFlags,
Eval,
EvalSumm(EvalSumm),
Row(Row), Column(Column),
)
import qualified Math.SetCover.Exact.UArray as ESC_UArray
import qualified Math.SetCover.Exact as ESC
import qualified System.IO as IO
import qualified Random as Random
import System.Random (StdGen, getStdGen, randomR, )
import Text.Printf (printf, )
import qualified Control.Monad.Trans.State as MS
import Control.Monad (replicateM, when, void, )
import Control.Applicative ((<$>), )
import qualified Data.Map as Map; import Data.Map (Map, )
import qualified Data.Set as Set; import Data.Set (Set, )
import qualified Data.Array as Array
import qualified Data.Foldable as Fold
import qualified Data.List.Match as Match
import qualified Data.List.HT as ListHT
import qualified Data.List as List
import Data.Foldable (foldMap, forM_, )
import Data.List (intercalate, )
import Data.Maybe (listToMaybe, isNothing, )
consistentCodesRnd ::
(Ord a) =>
AssignFlags -> Int -> [a] -> [([a], EvalSumm)] -> MS.State StdGen [[a]]
consistentCodesRnd flags width alphabet guesses =
return . map codeFromLabels . ESC.partitions
=<< Random.intSetFromSetAssigns
=<< (Random.shuffle $ assignsFromGuesses flags width alphabet guesses)
newGuess, newGuessMatching, newGuessRandom ::
(Ord a) =>
AssignFlags -> Int -> [a] -> [([a], EvalSumm)] -> MS.State StdGen (Maybe [a])
newGuess = newGuessRandom
{-
Only guess codes that are consistent with all previously tried codes.
This can lead to overly long guess sequences like
@"master", "mastex", "mastey", "mastez"@ at the end of the game.
-}
newGuessMatching flags width alphabet oldGuesses =
listToMaybe <$> consistentCodesRnd flags width alphabet oldGuesses
{-
Start with random guesses and use matching guesses only at the end of the game.
In order to make the attempts not obviously stupid
we rule out elements from attempts with empty evaluations
and stop searching for elements after an attempt with full evaluation.
When we have acquired enough information to match the number of possible codes
or when we reach a full evaluation,
we switch to guessing consistent codes.
As a consistent guess we use the first solution
generated from randomly shuffled assignments with a randomly shuffled alphabet.
This strategy prevents stupid guesses like "aaaaa",
but it does not minimize the number of guesses.
When the game approaches the end
there is often only one unknown letter left
and the algorithm makes a guess for ruling out every single candidate.
It would be more efficient to use non-coherent guesses in this situation
in order to rule out a whole bunch of candidates at once.
-}
newGuessRandom flags width alphabet oldGuesses = do
let numPossibleEvals = div ((width+1)*(width+2)) 2
let numMoves =
floor
(logBase
(fromIntegral numPossibleEvals) (fromIntegral $ length alphabet)
* fromIntegral width :: Double)
let maybeCompleteEval =
List.find
((\(EvalSumm correctPlaces correctSymbols) ->
correctPlaces + correctSymbols >= width) . snd) oldGuesses
let excluded =
foldMap (Set.fromList . fst) $
filter ((EvalSumm 0 0 ==) . snd) oldGuesses
let restricted =
case maybeCompleteEval of
Just (code, _) -> Set.toList $ Set.fromList code
Nothing -> filter (flip Set.notMember excluded) alphabet
if null restricted
then return Nothing
else
if length oldGuesses < numMoves && isNothing maybeCompleteEval
then
let arr = Array.listArray (0, length restricted - 1) restricted
in fmap Just $ replicateM width $ fmap (arr Array.!) $
MS.state $ randomR $ Array.bounds arr
else newGuessMatching flags width restricted oldGuesses
formatEval :: EvalSumm -> String
formatEval (EvalSumm correctPlaces correctSymbols) =
replicate correctPlaces 'x' ++ replicate correctSymbols 'o'
formatEvalGuess :: (Show code) => (code, EvalSumm) -> String
formatEvalGuess (guess, eval) = show guess ++ ' ' : formatEval eval
interaction :: Int -> [Char] -> IO ()
interaction width alphabet =
let flags = defaultAssignFlags
go guesses g0 =
case MS.runState (newGuess flags width alphabet guesses) g0 of
(Nothing, _) -> do
putStrLn "Contradicting evaluations!"
putStr "Please enter your secret code "
putStrLn "and I will show you the corrected evaluations:"
secret <- getLine
forM_ (reverse guesses) $ \(guess,eval) ->
let correctEval = evaluate secret guess
in when (correctEval /= eval) $ putStrLn $
formatEvalGuess (guess, correctEval)
(Just attempt, g1) -> do
putStr $ show attempt ++ " "
IO.hFlush IO.stdout
(eval@(EvalSumm numPlaces _numSymbols), evalRem)
<- MS.runState countEval <$> getLine
when (not $ null evalRem) (putStrLn $ "ignoring: " ++ evalRem)
if numPlaces >= width
then putStrLn "Code found!"
else go ((attempt, eval) : guesses) g1
in go [] =<< getStdGen
mainGame :: IO ()
mainGame = do
let n = 5
putStrLn $
"Come up with a word consisting of " ++ show n ++
" letters and evaluate my guesses."
putStrLn "Enter 'x's for correct places and 'o's for correct symbols in any order."
interaction n ['a'..'z']
testSolve :: IO ()
testSolve =
mapM_ print $ consistentCodes defaultAssignFlags 6 ['a'..'z'] $
Example.guesses_ Example.master
mainDistinguishing :: IO ()
mainDistinguishing =
let codes =
case 4::Int of
0 -> ["abcd", "abce", "abcf"]
1 -> ["abcdef", "abcdeg", "abcdeh"]
2 -> ["master", "puzzle", "bubble", "flight", "people"]
3 -> ["iuzamf", "gvarfe", "paqfes", "vamsej", "amgses", "majgep"]
_ -> ["hlskoel", "hoskell", "hlskoll", "klosehl"]
in mapM_ print $ take 10 $
distinguishingCodesCondensed defaultAssignFlags
(length $ head codes) ['a'..'z'] codes
{-
mainDistinguishing for ["hlskoel", "hoskell", "hlskoll", "klosehl"]:
("koellhs",[EvalSumm 0 7,EvalSumm 1 6,EvalSumm 0 6,EvalSumm 2 5])
("kolelhs",[EvalSumm 0 7,EvalSumm 1 6,EvalSumm 0 6,EvalSumm 2 5])
("eolslhk",[EvalSumm 0 7,EvalSumm 1 6,EvalSumm 0 6,EvalSumm 2 5])
("kolslhe",[EvalSumm 0 7,EvalSumm 1 6,EvalSumm 0 6,EvalSumm 3 4])
("kollshe",[EvalSumm 0 7,EvalSumm 1 6,EvalSumm 0 6,EvalSumm 2 5])
("sklleho",[EvalSumm 0 7,EvalSumm 1 6,EvalSumm 0 6,EvalSumm 2 5])
("kslleho",[EvalSumm 0 7,EvalSumm 1 6,EvalSumm 0 6,EvalSumm 3 4])
("khlleso",[EvalSumm 0 7,EvalSumm 1 6,EvalSumm 0 6,EvalSumm 2 5])
("kslleoh",[EvalSumm 0 7,EvalSumm 1 6,EvalSumm 0 6,EvalSumm 2 5])
("khlleos",[EvalSumm 0 7,EvalSumm 1 6,EvalSumm 0 6,EvalSumm 2 5])
-}
haskellCodes :: [String]
haskellCodes =
"hoskell" : "hlskoel" : "hlskoll" : "klosehl" :
"hpskell" : "hlskpel" : "hlskpll" : "klpsehl" :
"haskell" : "hlskael" : "hlskall" : "klasehl" :
"heskell" : "hlsksel" : "hlsksll" : "klesehl" :
"hsskell" :
[]
groupSizesByEval :: (Ord a) => [[a]] -> [([a], Int)]
groupSizesByEval codes =
decorate (Fold.maximum . histogram . flip map codes . evaluate) $
replicateM (length $ head codes) $
Set.toList $ foldMap Set.fromList codes
decorate :: (a -> b) -> [a] -> [(a, b)]
decorate f = map (\x -> (x, f x))
{- |
Return all elements that have minimal 'b'.
-}
allMinima :: (Ord b) => [(a,b)] -> ([a],b)
allMinima [] = error "allMinima: empty list"
allMinima ((a,b):abs_) =
let go as0 b0 [] = (reverse as0, b0)
go as0 b0 ((a1,b1):abs1) =
case compare b1 b0 of
LT -> go [a1] b1 abs1
EQ -> go (a1:as0) b1 abs1
GT -> go as0 b0 abs1
in go [a] b abs_
-- cf. board-games:Mastermind
mainBestSeparation :: IO ()
mainBestSeparation = do
let codes = haskellCodes
let (distCodes, groupSize) = allMinima $ groupSizesByEval codes
mapM_ print distCodes
let distCode = head distCodes
void $ printf "%s, max group size %d\n" distCode groupSize
mapM_ (putStrLn . formatEvalGuess) $ decorate (evaluate distCode) codes
data Step a b c =
Attempt a
| Complete b
| Fail c
data Choice = None | Unique | Multiple
indentTree ::
ESC.Tree label set ->
[([Int], Step ((Choice, set), label, [label]) [label] (set, [label]))]
indentTree =
let go numbers labels tree =
case tree of
ESC.Leaf -> [(numbers, Complete labels)]
ESC.Branch set subTrees ->
case subTrees of
[(label,subTree)] ->
(numbers, Attempt ((Unique, set), label, label:labels)) :
go numbers (label:labels) subTree
[] -> [(numbers, Fail (set, labels))]
_ ->
concatMap
(\(k, (label,subTree)) ->
(k:numbers,
Attempt ((Multiple, set), label, label:labels)) :
go (k:numbers) (label:labels) subTree) $
zip [1 ..] subTrees
in go [] []
formatElement :: Guess.X Char -> String
formatElement x =
case x of
Guess.EvalSymbol (Guess.Pos (Column col)) ->
printf "symbol at position %d" col
Guess.EvalSymbol (Guess.Eval eval (Row row) (Column col)) ->
printf
"choice whether a %s marker is at (%d,%d) or elsewhere"
(Guess.nameFromEval $ Just eval) row col
Guess.EvalSymbol (Guess.Symbol symbol) ->
printf "way of placing symbol '%c'" symbol
Guess.EvalRow eval (Row row) ->
printf "way of placing %s markers in row %d"
(Guess.nameFromEval $ Just eval) row
Guess.EvalReserve (Row row) (Column col) ->
printf
("choice between correct place, " ++
"correct symbol or no marker at (%d,%d)")
row col
formatReason :: (Choice, Set (Guess.X Char)) -> String
formatReason (choice, set) =
let uniqueStr =
case choice of
None -> "no possible"
Unique -> "unique"
Multiple -> "try"
in case Set.toList set of
[x] -> uniqueStr ++ " " ++ formatElement x
_ -> error "reason set must be a singleton"
formatLabel :: Int -> Guess.Label Char -> String
formatLabel width label =
case label of
Left (Row row, eval, pattern) ->
printf "pattern %s for %ss in row %d"
(Guess.formatPattern eval pattern) (Guess.nameFromEval eval) row
Right symbols ->
"place symbols " ++ partialCodeFromLabels width [symbols]
evalMapFromLabel :: (Row, Maybe Eval, [Bool]) -> Map (Row,Column) (Maybe Eval)
evalMapFromLabel (row, eval, pattern) =
Map.fromList $ map (\(col,_true) -> ((row,col), eval)) $
filter snd $ zip [Column 0 ..] pattern
partialCodeFromLabels :: Int -> [[(Column, Char)]] -> String
partialCodeFromLabels width xss =
Array.elems $
Array.listArray (Column 0, Column (width - 1)) (repeat '_')
Array.//
concat xss
formatPatterns :: [(String, EvalSumm)] -> [Guess.Label Char] -> String
formatPatterns guesses labels =
let (patternLabels, codeLabels) = ListHT.unzipEithers labels
m = fmap Guess.charFromEval $ foldMap evalMapFromLabel patternLabels
width = maximum $ map (length . fst) guesses
in unlines $
zipWith
(\row (guess,_eval) ->
guess ++ ' ' :
(map (\col -> Map.findWithDefault '_' (row,col) m) $
Match.take guess [Column 0 ..]))
[Row 0 ..] guesses
++
["", partialCodeFromLabels width codeLabels]
{-
assignsFromMatchingCodes defaultAssignFlags 6 ['a'..'z']
["iuzamf", "gvarfe", "paqfes", "vamsej", "amgses"] -- , "majgep"]
-}
mainIntSet :: IO ()
mainIntSet = do
let example = Example.haskell
mapM_ (putStrLn . Guess.codeFromLabels) $ ESC.partitions $
ESC.intSetFromSetAssigns $ Example.apply assignsFromGuesses example
mainUArray :: IO ()
mainUArray = do
let example = Example.cover
mapM_ (putStrLn . Guess.codeFromLabels) $ ESC_UArray.partitions $
Example.apply assignsFromGuesses example
mainConsistent :: IO ()
mainConsistent = print $ Example.apply consistentCodes Example.cover
mainSolutions :: IO ()
mainSolutions = do
let example = Example.cafe
mapM_ (putStrLn . formatPatterns (Example.guesses_ example)) $
ESC.partitions $ Example.apply assignsFromGuesses example
mainTree :: IO ()
mainTree = do
let example = Example.cafe
width = Example.width_ example
guesses = Example.guesses_ example
asns = Example.apply assignsFromGuesses example
forM_ (indentTree $ ESC.decisionTree asns) $ \(numbers, msg) ->
putStrLn $
(intercalate "." $ map show $ reverse numbers)
++
(case msg of
Attempt (reason,label,_) ->
": " ++ formatLabel width label ++
" - " ++ formatReason reason
Complete labels -> "\n\n" ++ formatPatterns guesses labels
Fail (reason,_) ->
": failed because " ++ formatReason (None,reason))
mainDetail :: IO ()
mainDetail = do
let example = Example.cafe
width = Example.width_ example
guesses = Example.guesses_ example
asns = Example.apply assignsFromGuesses example
forM_ (indentTree $ ESC.decisionTree asns) $ \(numbers, msg) ->
putStrLn $
(intercalate "." $ map show $ reverse numbers)
++
(case msg of
Attempt (reason,label,labels) ->
": " ++ formatLabel width label ++
" - " ++ formatReason reason ++ "\n\n" ++
formatPatterns guesses labels
Complete _labels -> " - completed\n"
Fail (reason,_) ->
": failed because " ++ formatReason (None,reason) ++ "\n")
main :: IO ()
main = mainGame