module Game.Mastermind where
import qualified Game.Mastermind.CodeSet.Tree as CodeSetTree
import qualified Game.Mastermind.CodeSet as CodeSet
import Game.Mastermind.CodeSet
(flatten, intersection, (*&), (#*&), unit, empty, union, unions, cube, )
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.List.HT (partition, )
import Data.Tuple.HT (mapPair, )
import Data.Maybe.HT (toMaybe, )
import Data.Maybe (listToMaybe, )
import Control.Monad (liftM, guard, when, replicateM, )
import qualified Control.Monad.Trans.State as State
import qualified Control.Monad.Trans.Class as Trans
import qualified System.Random as Rnd
import qualified System.IO as IO
data Eval = Eval Int Int
deriving (Eq, Show)
evaluate :: (Ord a) => [a] -> [a] -> Eval
evaluate code attempt =
uncurry Eval $
mapPair
(length,
sum . Map.elems .
uncurry (Map.intersectionWith min) .
mapPair (histogram,histogram) . unzip) $
partition (uncurry (==)) $
zip code attempt
histogram :: (Ord a) => [a] -> Map.Map a Int
histogram =
Map.fromListWith (+) . map (\a -> (a,1))
selectFromHistogram :: (Ord a) => Map.Map a Int -> [(a, Map.Map a Int)]
selectFromHistogram hist =
map (\a -> (a, Map.update (\n -> toMaybe (n>1) (pred n)) a hist)) $
Map.keys hist
remainingSimple :: Ord a => Set.Set a -> [a] -> Int -> [[Set.Set a]]
remainingSimple alphabet code rightPlaces =
map
(zipWith
(\symbol right ->
if right
then Set.singleton symbol
else Set.delete symbol alphabet)
code) $
possibleRightPlaces (length code) rightPlaces
possibleRightPlaces :: Int -> Int -> [[Bool]]
possibleRightPlaces n rightPlaces =
if n < rightPlaces
then []
else
if n==0
then [[]]
else
(guard (rightPlaces>0) >>
(map (True:) $
possibleRightPlaces (n1) (rightPlaces1)))
++
(map (False:) $
possibleRightPlaces (n1) rightPlaces)
remaining ::
(CodeSet.C set, Ord a) =>
Set.Set a -> [a] -> Eval -> set a
remaining alphabet =
let findCodes =
foldr
(\(fixed,c) go rightSymbols floating0 ->
if fixed
then c #*& go rightSymbols floating0
else
(unions $ do
guard (rightSymbols > 0)
(src, floating1) <- selectFromHistogram floating0
guard (c /= src)
return $ src #*& go (rightSymbols1) floating1)
`union`
(Set.difference
(Set.delete c alphabet)
(Map.keysSet floating0) *&
go rightSymbols floating0))
(\rightSymbols _floating ->
if rightSymbols>0
then empty
else unit)
in \code (Eval rightPlaces rightSymbols) ->
unions $
map
(\pattern ->
let patternCode = zip pattern code
in findCodes patternCode rightSymbols $
histogram $ map snd $ filter (not . fst) patternCode) $
possibleRightPlaces (length code) rightPlaces
partitionSizes :: (Ord a) => Set.Set a -> [a] -> [(Eval, Integer)]
partitionSizes alphabet code =
map (\eval ->
(eval,
CodeSet.size $
(id :: CodeSetTree.T a -> CodeSetTree.T a) $
remaining alphabet code eval)) $
possibleEvaluations (length code)
possibleEvaluations :: Int -> [Eval]
possibleEvaluations n = do
rightPlaces <- [0..n]
rightSymbols <- [0..nrightPlaces]
return $ Eval rightPlaces rightSymbols
interaction ::
(CodeSetTree.T Char -> State.StateT state Maybe [Char]) ->
state ->
Set.Set Char -> Int -> IO ()
interaction select initial alphabet n =
let go state set =
case State.runStateT (select set) state of
Nothing -> putStrLn "contradicting evaluations"
Just (attempt, newState) -> do
putStr $ show attempt ++ " " ++
show (CodeSet.size set, CodeSet.representationSize set) ++ " "
IO.hFlush IO.stdout
eval <- getLine
let evalHist = histogram eval
evalHistRem =
Map.keys $ Map.delete 'o' $ Map.delete 'x' evalHist
when (not $ null evalHistRem)
(putStrLn $ "ignoring: " ++ evalHistRem)
let rightPlaces = length (filter ('x' ==) eval)
rightSymbols = length (filter ('o' ==) eval)
if rightPlaces >= n
then putStrLn "I won!"
else go newState $ intersection set $
remaining alphabet attempt $
Eval rightPlaces rightSymbols
in go initial (cube alphabet n)
mainSimple :: Set.Set Char -> Int -> IO ()
mainSimple =
interaction
(Trans.lift . listToMaybe . flatten)
()
randomSelect ::
(Rnd.RandomGen g, Monad m) =>
[a] -> State.StateT g m a
randomSelect items =
liftM (items!!) $ State.StateT $ return . Rnd.randomR (0, length items1)
minimax :: (Ord b) => [(a, [b])] -> a
minimax [] = error "minimax of empty list"
minimax ((a0,bs0):rest) =
fst $
foldl
(\old@(_minA, minB) (a,bs) ->
let (ltMinB, gtMinB) = partition (minB>) bs
in if null gtMinB
then (a, maximum ltMinB)
else old)
(a0, maximum bs0) rest
randomizedAttempt ::
(CodeSet.C set, Rnd.RandomGen g, Ord a) =>
Int -> Set.Set a ->
set a -> State.StateT g Maybe [a]
randomizedAttempt n alphabet set = do
randomAttempts <-
replicateM 10 $
replicateM n $
randomSelect . Set.toList $
CodeSet.symbols set
let possible = flatten set
somePossible =
let size = CodeSet.size set
num = 10
in map (CodeSet.select set) $
Set.toList $ Set.fromList $
take num $
map (flip div (fromIntegral num)) $
iterate (size+) 0
_ <- Trans.lift $ listToMaybe possible
return $ minimax $
map
(\attempt -> (attempt,
map (CodeSet.size . intersection set . remaining alphabet attempt) $
possibleEvaluations n)) $
somePossible ++ randomAttempts
mixedRandomizedAttempt ::
(CodeSet.C set, Rnd.RandomGen g, Ord a) =>
Int -> Set.Set a ->
set a -> State.StateT g Maybe [a]
mixedRandomizedAttempt n alphabet set = do
case CodeSet.size set of
0 -> Trans.lift Nothing
1 -> return $ head $ CodeSet.flatten set
2 -> return $ head $ CodeSet.flatten set
size ->
if size <= 100
then randomizedAttempt n alphabet set
else
fmap (CodeSet.select set) $
State.StateT $ return . Rnd.randomR (0, size1)
mainRandom :: Set.Set Char -> Int -> IO ()
mainRandom alphabet n = do
g <- Rnd.getStdGen
interaction (randomizedAttempt n alphabet) g alphabet n
main :: IO ()
main =
mainRandom (Set.fromList ['a'..'z']) 5