board-games 0.2.1 → 0.3

raw patch · 15 files changed

+731/−360 lines, 15 filesdep +enummapsetdep +paralleldep ~QuickCheckdep ~basedep ~containersPVP ok

version bump matches the API change (PVP)

Dependencies added: enummapset, parallel

Dependency ranges changed: QuickCheck, base, containers, non-empty, random, transformers, utility-ht

API changes (from Hackage documentation)

Files

• Changes.md +13/−0
• Makefile +1/−1
• benchmark/Main.hs +0/−144
• benchmark/MastermindSpeed.hs +145/−0
• benchmark/MastermindStrategy.hs +125/−0
• board-games.cabal +37/−10
• private/Game/Utility.hs +65/−0
• src/Game/Mastermind.hs +191/−105
• src/Game/Mastermind/CodeSet.hs +15/−15
• src/Game/Mastermind/CodeSet/Tree.hs +20/−20
• src/Game/Mastermind/CodeSet/Union.hs +23/−22
• src/Game/Mastermind/HTML.hs +6/−7
• src/Game/Mastermind/NonEmptyEnumSet.hs +40/−0
• src/Game/Utility.hs +0/−29
• test/Test/Mastermind.hs +50/−7

@@ -1,5 +1,18 @@ # Change log for the `board-games` package +## 0.3++ * `Mastermind.CodeSet`:+   Move from `Set` to `EnumSet` since this is three to ten times faster.+   It works best for alphabets with contiguous `fromEnum`-associated `Int`s,+   but even if not it should not be much worse than `Set`.+   If this is still too slow for you, you might consider mapping your alphabet+   to a contiguous set of `Int`s first.+   I tried to maintain both `Set` and `EnumSet` in one interface.+   It is possible even in Haskell 98 using explicit method dictionaries.+   However, it gets complicated and I am afraid+   that the speed advantage is diminished by the generalization overhead.+ ## 0.2.1   * add criterion benchmarks for `Mastermind`

@@ -9,4 +9,4 @@ 	./dist/build/board-games-test/board-games-test  criterion.html:	./dist/build/board-games-benchmark/board-games-benchmark-	$< --output=$@ $(patsubst %.html, %.csv, --summary=$@)+	$< --output=$@ $(patsubst %.html, %.csv, --csv=$@)

@@ -1,144 +0,0 @@-module Main where--import Game.Mastermind (Eval(Eval), matching)--import qualified Game.Mastermind.CodeSet.Tree as CodeSetTree-import qualified Game.Mastermind.CodeSet.Union as CodeSetUnion-import qualified Game.Mastermind.CodeSet as CodeSet--import Criterion.Main (Benchmark, defaultMain, bgroup, bench, whnf)--import qualified Data.NonEmpty as NonEmpty-import qualified Data.Set as Set-import Data.NonEmpty ((!:))-import Data.Set (Set)-import Data.Tuple.HT (mapSnd)---alphabet, digits :: Set Char-alphabet = Set.fromList ['a'..'z']-digits = Set.fromList ['0'..'9']---type List1 = NonEmpty.T []-type List2 = NonEmpty.T List1--gamesWords, gamesNumbers :: [List2 (String, Eval)]-gamesWords =-   [-      ("flq", Eval 0 0) !:-      ("chx", Eval 0 0) !:-      ("sez", Eval 2 0) :-      ("aes", Eval 1 1) :-      ("bde", Eval 0 1) :-      ("gij", Eval 0 0) :-      ("kmn", Eval 0 0) :-      ("opr", Eval 0 0) :-      ("tuv", Eval 0 1) :-      ("set", Eval 3 0) :-      [],--      ("ncqy", Eval 0 1) !:-      ("yxcl", Eval 0 0) !:-      ("ikjn", Eval 0 2) :-      ("dnoj", Eval 0 2) :-      ("jbnz", Eval 1 0) :-      ("ofnk", Eval 1 0) :-      ("adni", Eval 1 2) :-      ("eghm", Eval 0 1) :-      ("gaah", Eval 0 0) :-      ("mind", Eval 4 0) :-      [],--      ("ozdtp", Eval 0 1) !:-      ("cxgkz", Eval 1 1) !:-      ("gbqvz", Eval 0 1) :-      ("ctdng", Eval 0 2) :-      ("dwghk", Eval 1 0) :-      ("sygpc", Eval 2 0) :-      ("gogfm", Eval 2 0) :-      ("ploir", Eval 1 2) :-      ("logic", Eval 5 0) :-      [],--      ("tynrsu", Eval 0 3) !:-      ("msycnl", Eval 1 1) !:-      ("uslher", Eval 2 1) :-      ("pceeyr", Eval 1 1) :-      ("psugen", Eval 1 1) :-      ("kscdur", Eval 1 1) :-      ("zwghob", Eval 0 0) :-      ("masafa", Eval 3 0) :-      ("master", Eval 6 0) :-      []-   ]--gamesNumbers =-   [-      ("092", Eval 1 0) !:-      ("009", Eval 2 0) !:-      ("130", Eval 0 1) :-      ("456", Eval 0 0) :-      ("007", Eval 3 0) :-      [],--      ("7483", Eval 0 0) !:-      ("2066", Eval 2 0) !:-      ("0106", Eval 0 2) :-      ("2501", Eval 1 2) :-      ("2012", Eval 3 0) :-      ("2019", Eval 4 0) :-      [],--      ("04575", Eval 1 1) !:-      ("43465", Eval 0 3) !:-      ("32556", Eval 2 2) :-      ("16553", Eval 1 3) :-      ("58536", Eval 3 1) :-      ("65536", Eval 5 0) :-      [],--      ("899820", Eval 1 1) !:-      ("872456", Eval 2 3) !:-      ("256296", Eval 0 2) :-      ("142857", Eval 5 0) :-      []-   ]--addWidth :: NonEmpty.T f ([a], b) -> (Int, NonEmpty.T f ([a], b))-addWidth xs = (length $ fst $ NonEmpty.head xs, xs)---singleBench ::-   (CodeSet.C set) =>-   (set Char -> Integer) -> Set Char -> (Int, List1 (String, Eval)) -> Benchmark-singleBench setSize symbols (width, xs) =-   bench (show width) $-      whnf (setSize . CodeSet.intersections .-            fmap (uncurry (matching symbols))) xs--benchWordsAndNumbers ::-   (CodeSet.C set) =>-   (set Char -> Integer) ->-   (List2 (String, Eval) -> List1 (String, Eval)) -> [Benchmark]-benchWordsAndNumbers setSize cut =-   bgroup "words"-      (map (singleBench setSize alphabet . mapSnd cut . addWidth) gamesWords) :-   bgroup "numbers"-      (map (singleBench setSize digits . mapSnd cut . addWidth) gamesNumbers) :-   []--benchCodeSets :: (CodeSet.C set) => (set Char -> Integer) -> [Benchmark]-benchCodeSets setSize =-   bgroup "3 evaluations"-      (benchWordsAndNumbers setSize-         (NonEmpty.mapTail (take 2) . NonEmpty.flatten)) :-   bgroup "all but one evaluation"-      (benchWordsAndNumbers setSize NonEmpty.init) :-   []--main :: IO ()-main = defaultMain $-   bgroup "tree" (benchCodeSets CodeSetTree.size) :-   bgroup "union" (benchCodeSets CodeSetUnion.size) :-   []

@@ -0,0 +1,145 @@+module Main where++import Game.Mastermind (Eval(Eval), matching)++import qualified Game.Mastermind.CodeSet.Tree as CodeSetTree+import qualified Game.Mastermind.CodeSet.Union as CodeSetUnion+import qualified Game.Mastermind.CodeSet as CodeSet++import Criterion.Main (Benchmark, defaultMain, bgroup, bench, whnf)++import qualified Data.NonEmpty as NonEmpty+import qualified Data.EnumSet as EnumSet+import Data.NonEmpty ((!:))+import Data.EnumSet (EnumSet)+import Data.Tuple.HT (mapSnd)+++alphabet, digits :: EnumSet Char+alphabet = EnumSet.fromList ['a'..'z']+digits = EnumSet.fromList ['0'..'9']+++type List1 = NonEmpty.T []+type List2 = NonEmpty.T List1++gamesWords, gamesNumbers :: [List2 (String, Eval)]+gamesWords =+   [+      ("flq", Eval 0 0) !:+      ("chx", Eval 0 0) !:+      ("sez", Eval 2 0) :+      ("aes", Eval 1 1) :+      ("bde", Eval 0 1) :+      ("gij", Eval 0 0) :+      ("kmn", Eval 0 0) :+      ("opr", Eval 0 0) :+      ("tuv", Eval 0 1) :+      ("set", Eval 3 0) :+      [],++      ("ncqy", Eval 0 1) !:+      ("yxcl", Eval 0 0) !:+      ("ikjn", Eval 0 2) :+      ("dnoj", Eval 0 2) :+      ("jbnz", Eval 1 0) :+      ("ofnk", Eval 1 0) :+      ("adni", Eval 1 2) :+      ("eghm", Eval 0 1) :+      ("gaah", Eval 0 0) :+      ("mind", Eval 4 0) :+      [],++      ("ozdtp", Eval 0 1) !:+      ("cxgkz", Eval 1 1) !:+      ("gbqvz", Eval 0 1) :+      ("ctdng", Eval 0 2) :+      ("dwghk", Eval 1 0) :+      ("sygpc", Eval 2 0) :+      ("gogfm", Eval 2 0) :+      ("ploir", Eval 1 2) :+      ("logic", Eval 5 0) :+      [],++      ("tynrsu", Eval 0 3) !:+      ("msycnl", Eval 1 1) !:+      ("uslher", Eval 2 1) :+      ("pceeyr", Eval 1 1) :+      ("psugen", Eval 1 1) :+      ("kscdur", Eval 1 1) :+      ("zwghob", Eval 0 0) :+      ("masafa", Eval 3 0) :+      ("master", Eval 6 0) :+      []+   ]++gamesNumbers =+   [+      ("092", Eval 1 0) !:+      ("009", Eval 2 0) !:+      ("130", Eval 0 1) :+      ("456", Eval 0 0) :+      ("007", Eval 3 0) :+      [],++      ("7483", Eval 0 0) !:+      ("2066", Eval 2 0) !:+      ("0106", Eval 0 2) :+      ("2501", Eval 1 2) :+      ("2012", Eval 3 0) :+      ("2019", Eval 4 0) :+      [],++      ("04575", Eval 1 1) !:+      ("43465", Eval 0 3) !:+      ("32556", Eval 2 2) :+      ("16553", Eval 1 3) :+      ("58536", Eval 3 1) :+      ("65536", Eval 5 0) :+      [],++      ("899820", Eval 1 1) !:+      ("872456", Eval 2 3) !:+      ("256296", Eval 0 2) :+      ("142857", Eval 5 0) :+      []+   ]++addWidth :: NonEmpty.T f ([a], b) -> (Int, NonEmpty.T f ([a], b))+addWidth xs = (length $ fst $ NonEmpty.head xs, xs)+++singleBench ::+   (CodeSet.C set) =>+   (set Char -> Integer) -> EnumSet Char ->+   (Int, List1 (String, Eval)) -> Benchmark+singleBench setSize symbols (width, xs) =+   bench (show width) $+      whnf (setSize . CodeSet.intersections .+            fmap (uncurry (matching symbols))) xs++benchWordsAndNumbers ::+   (CodeSet.C set) =>+   (set Char -> Integer) ->+   (List2 (String, Eval) -> List1 (String, Eval)) -> [Benchmark]+benchWordsAndNumbers setSize cut =+   bgroup "words"+      (map (singleBench setSize alphabet . mapSnd cut . addWidth) gamesWords) :+   bgroup "numbers"+      (map (singleBench setSize digits . mapSnd cut . addWidth) gamesNumbers) :+   []++benchCodeSets :: (CodeSet.C set) => (set Char -> Integer) -> [Benchmark]+benchCodeSets setSize =+   bgroup "3 evaluations"+      (benchWordsAndNumbers setSize+         (NonEmpty.mapTail (take 2) . NonEmpty.flatten)) :+   bgroup "all but one evaluation"+      (benchWordsAndNumbers setSize NonEmpty.init) :+   []++main :: IO ()+main = defaultMain $+   bgroup "tree" (benchCodeSets CodeSetTree.size) :+   bgroup "union" (benchCodeSets CodeSetUnion.size) :+   []

@@ -0,0 +1,125 @@+module Main where++import qualified Game.Mastermind as MM+import qualified Game.Mastermind.CodeSet.Tree as CodeSetTree+import qualified Game.Mastermind.CodeSet as CodeSet+import qualified Game.Mastermind.NonEmptyEnumSet as NonEmptySet+import Game.Utility (randomSelect, histogram)++import qualified System.Random as Rnd+import qualified System.IO as IO++import qualified Control.Parallel.Strategies as Strategy++import qualified Control.Monad.Trans.State as MS+import qualified Control.Functor.HT as FuncHT+import Control.Monad (replicateM, liftM2)++import Text.Printf (printf)++import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold+import qualified Data.NonEmpty as NonEmpty+import qualified Data.Empty as Empty+import qualified Data.List as List+import qualified Data.Map as Map+import qualified Data.Zip as Zip+import Data.NonEmpty ((!:))+import Data.Maybe (fromMaybe)+++justState :: MS.State g (Maybe a) -> MS.State g a+justState = fmap $ fromMaybe (error "contradicting evaluation")++play ::+   (Rnd.RandomGen g) =>+   (Int -> [([Char], MM.Eval)] ->+    CodeSetTree.T Char -> MS.State g (Maybe String)) ->+   NonEmptySet.T Char -> String -> MS.State g [String]+play doGuess alphabet code = do+   let width = length code+   let go oldGuesses codeSet = do+         guess <- justState $ doGuess width oldGuesses codeSet+         let eval = MM.evaluate guess code+         let currentGuesses = oldGuesses++[(guess,eval)]+         if eval == MM.Eval width 0+            then return $ fmap fst currentGuesses+            else go currentGuesses $+                  CodeSetTree.intersection codeSet $+                  MM.matching (NonEmptySet.flatten alphabet) guess eval+   go [] $ CodeSet.cube alphabet width+++type Tuple = NonEmpty.T (NonEmpty.T (NonEmpty.T (NonEmpty.T Empty.T)))++playVariants ::+   (Rnd.RandomGen g) =>+   NonEmptySet.T Char -> String -> MS.State g (String, Tuple Int)+playVariants alphabet code = do+   let alphabetFlat = NonEmptySet.flatten alphabet+   guessesColumns <-+      Trav.mapM (\strategy -> play strategy alphabet code) $+         (\width _oldGuesses -> MM.mixedRandomizedAttempt width) !:+         (\width _oldGuesses -> MM.randomizedAttempt width) !:+         (\width oldGuesses ->+            MM.scanningRandomizedAttempt width alphabetFlat oldGuesses) !:+         (\width _oldGuesses ->+            MM.separatingRandomizedAttempt width alphabetFlat) !:+         Empty.Cons+   return (code, fmap length guessesColumns)++playMany ::+   (Rnd.RandomGen g) =>+   NonEmpty.T [] Char -> Int -> g -> [(String, Tuple Int)]+playMany symbols width =+   let alphabet = NonEmptySet.fromList symbols+   in map+         (\code ->+            MS.evalState (playVariants alphabet code) (Rnd.mkStdGen 3141)) .+      MS.evalState+         (replicateM 100 $ replicateM width $+          randomSelect $ NonEmpty.flatten symbols)+++withWriteFile :: FilePath -> (IO.Handle -> IO a) -> IO a+withWriteFile path act =+   IO.withFile path IO.WriteMode $ \h ->+      IO.hSetBuffering h IO.LineBuffering >> act h++run :: IO.Handle -> (String, NonEmpty.T [] Char) -> Int -> IO ()+run averagesHandle (alphabetName,alphabet) width = do+   let pathEnding = printf "-%s-%d.csv" alphabetName width+   let games =+         Strategy.withStrategy+            (Strategy.parList $+             Strategy.parTuple2+                Strategy.rdeepseq (Strategy.parTraversable Strategy.rdeepseq)) $+         playMany alphabet width $ Rnd.mkStdGen 42+   let writeLines path txt = withWriteFile path $ \h -> IO.hPutStr h txt+   let csvLine cells = List.intercalate "," $ Fold.toList cells+   let writeCSV path = writeLines path . unlines . map csvLine+   writeCSV ("game-lengths" ++ pathEnding) $+      map (\(code,lengths) -> ('"':code++'"':"") !: fmap show lengths) games+   let gamesPerStrategy = Zip.transposeClip $ map snd games+   writeCSV ("histogram" ++ pathEnding) $ map (fmap show) $+      FuncHT.outerProduct (Map.findWithDefault 0)+         [1 .. NonEmpty.foldl1Map max maximum gamesPerStrategy]+         (fmap histogram gamesPerStrategy)+   let average :: [Int] -> Double+       average xs = fromIntegral (sum xs) / fromIntegral (length xs)+       sqr x = x^(2::Int)+       averageDeviation xs =+         let mean = average xs+         in [show mean,+             printf "%.4f" $ sqrt (average (map sqr xs) - sqr mean)]+   IO.hPutStrLn averagesHandle $ csvLine $+      alphabetName !: show width !:+         Fold.foldMap averageDeviation gamesPerStrategy++main :: IO ()+main =+   withWriteFile "averages.csv" $ \averageHandle ->+   sequence_ $+   liftM2 (run averageHandle)+      [("numbers", '0'!:['1'..'9']), ("words", 'a'!:['b'..'z'])]+      [3..6]

@@ -1,5 +1,5 @@ Name:             board-games-Version:          0.2.1+Version:          0.3 License:          GPL License-File:     LICENSE Author:           Henning Thielemann <haskell@henning-thielemann.de>@@ -40,7 +40,7 @@   location: http://code.haskell.org/~thielema/games/  Source-Repository this-  tag:      0.2.1+  tag:      0.3   type:     darcs   location: http://code.haskell.org/~thielema/games/ @@ -56,7 +56,9 @@     cgi >=3001.1 && <3002,     non-empty >=0.2 && <0.4,     utility-ht >=0.0.3 && <0.1,-    transformers >=0.2.2 && <0.6+    transformers >=0.2.2 && <0.6,+    enummapset >=0.1 && <0.7,+    QuickCheck >2.0 && <3.0   If flag(splitBase)     Build-Depends:       containers >=0.2 && <0.7,@@ -68,7 +70,7 @@    Default-Language: Haskell2010   GHC-Options:      -Wall-  Hs-Source-Dirs:   src+  Hs-Source-Dirs:   src, private   Exposed-Modules:     Game.Tree     Game.VierGewinnt.HTML@@ -81,6 +83,7 @@     Game.Mastermind.CodeSet     Game.Mastermind.CodeSet.Union     Game.Mastermind.CodeSet.Tree+    Game.Mastermind.NonEmptyEnumSet   Other-Modules:     Game.Utility @@ -111,29 +114,53 @@   Type:             exitcode-stdio-1.0   Default-Language: Haskell2010   GHC-Options:      -Wall-  Hs-Source-Dirs:   test+  Hs-Source-Dirs:   test, private   Main-Is:          Test.hs-  Other-Modules:    Test.Mastermind+  Other-Modules:+    Test.Mastermind+    Game.Utility   Build-Depends:     board-games,-    QuickCheck >1.2 && <3.0,-    non-empty,+    QuickCheck,+    non-empty >=0.3.1,     utility-ht,     transformers,+    enummapset,     containers,     random,     array,     base -Benchmark board-games-benchmark+Benchmark mastermind-strategy   Type:             exitcode-stdio-1.0   Default-Language: Haskell2010+  GHC-Options:      -Wall -fwarn-missing-import-lists -threaded -rtsopts+  Hs-Source-Dirs:   benchmark, private+  Main-Is:          MastermindStrategy.hs+  Other-Modules:+    Game.Utility+  Build-Depends:+    board-games,+    QuickCheck,+    parallel >=3.2.1 && <3.3,+    transformers,+    enummapset,+    containers,+    random,+    non-empty,+    utility-ht,+    base++Benchmark mastermind-benchmark+  Type:             exitcode-stdio-1.0+  Default-Language: Haskell2010   GHC-Options:      -Wall -fwarn-missing-import-lists -threaded   Hs-Source-Dirs:   benchmark-  Main-Is:          Main.hs+  Main-Is:          MastermindSpeed.hs   Build-Depends:     board-games,     criterion >=0.6 && <1.6,+    enummapset,     containers,     non-empty,     utility-ht,

@@ -0,0 +1,65 @@+module Game.Utility where++import qualified System.Random as Rnd++import qualified Control.Monad.Trans.State as MS+import Control.Monad (liftM, liftM2)++import qualified Data.Foldable as Fold+import qualified Data.EnumMap as EnumMap+import qualified Data.Map as Map+import Data.EnumMap (EnumMap)+import Data.Map (Map)++import qualified Test.QuickCheck as QC+++readMaybe :: (Read a) => String -> Maybe a+readMaybe str =+   case reads str of+      [(a,"")] -> Just a+      _ -> Nothing++nullToMaybe :: [a] -> Maybe [a]+nullToMaybe [] = Nothing+nullToMaybe s  = Just s++-- candidate for random-utility, cf. module htam:Election, markov-chain+-- for Sets it would be more efficient to use Set.elemAt+randomSelect :: (Rnd.RandomGen g, Monad m) => [a] -> MS.StateT g m a+randomSelect items =+   liftM (items!!) $ MS.state $ Rnd.randomR (0, length items-1)+++histogram :: (Ord a) => [a] -> Map a Int+histogram = Map.fromListWith (+) . map (\a -> (a,1))+++-- unfortunately it is not a Monoid because mergeChoice is not associative+data Choice a = Choice (EnumMap a Int) Int+   deriving (Eq, Show)++instance (QC.Arbitrary a, Enum a) => QC.Arbitrary (Choice a) where+   arbitrary = do+      bag <-+         fmap EnumMap.fromList $ QC.listOf $+         liftM2 (,) QC.arbitrary (fmap QC.getNonNegative QC.arbitrary)+      count <- QC.choose (0, Fold.sum bag)+      return $ Choice bag count+   shrink (Choice bag count) =+      map (\(xs,c) ->+            let b = fmap abs $ EnumMap.fromList xs+            in Choice b (min c $ Fold.sum b)) $+      QC.shrink (EnumMap.toList bag, count)++noChoice :: (Enum a) => Choice a+noChoice = Choice EnumMap.empty 0++-- it is hard to test whether fullEval absorbs+mergeChoice :: (Enum a) => Choice a -> Choice a -> Choice a+mergeChoice (Choice symbolsA countA) (Choice symbolsB countB) =+   Choice+      (EnumMap.unionWith max symbolsA symbolsB)+      (countA + countB+         - min (min countA countB)+               (Fold.sum (EnumMap.intersectionWith min symbolsA symbolsB)))

@@ -4,7 +4,10 @@    matching,    matchingSimple, +   randomizedAttempt,    mixedRandomizedAttempt,+   scanningRandomizedAttempt,+   separatingRandomizedAttempt,    partitionSizes,     mainSimple,@@ -17,23 +20,32 @@ import qualified Game.Mastermind.CodeSet.Tree as CodeSetTree -- import qualified Game.Mastermind.CodeSet.Union as CodeSetUnion import qualified Game.Mastermind.CodeSet as CodeSet+import qualified Game.Mastermind.NonEmptyEnumSet as NonEmptySet import Game.Mastermind.CodeSet    (intersection, (*&), (#*&), unit, empty, union, unions, cube, )-import Game.Utility (randomSelect, )+import Game.Utility+   (Choice(Choice), mergeChoice, noChoice, randomSelect, histogram) -import qualified Data.NonEmpty.Set as NonEmptySet+import qualified Data.EnumMap as EnumMap+import qualified Data.EnumSet as EnumSet import qualified Data.Map as Map import qualified Data.Set as Set+import Data.EnumMap (EnumMap)+import Data.EnumSet (EnumSet) +import qualified Data.NonEmpty as NonEmpty+import qualified Data.List as List import Data.NonEmpty ((!:)) import Data.List.HT (partition, ) import Data.Tuple.HT (mapPair, ) import Data.Maybe.HT (toMaybe, )-import Data.Maybe (listToMaybe, )-import Control.Monad (guard, when, replicateM, )+import Data.Maybe (listToMaybe, fromMaybe)+import Data.Ord.HT (comparing)+import Data.Eq.HT (equating)  import qualified Control.Monad.Trans.State as MS-import qualified Control.Monad.Trans.Class as MT+import Control.Monad.IO.Class (liftIO)+import Control.Monad (guard, when, replicateM, liftM2, )  import qualified System.Random as Rnd import qualified System.IO as IO@@ -45,52 +57,54 @@ {- | Given the code and a guess, compute the evaluation. -}-evaluate :: (Ord a) => [a] -> [a] -> Eval+evaluate :: (Enum a) => [a] -> [a] -> Eval evaluate code attempt =    uncurry Eval $    mapPair       (length,-       sum . Map.elems .-       uncurry (Map.intersectionWith min) .-       mapPair (histogram,histogram) . unzip) $-   partition (uncurry (==)) $+       sum . EnumMap.elems .+       uncurry (EnumMap.intersectionWith min) .+       mapPair (bagFromList,bagFromList) . unzip) $+   partition (uncurry $ equating fromEnum) $    zip code attempt  {- *Game.Mastermind> filter ((Eval 2 0 ==) . evaluate "aabbb") $ replicateM 5 ['a'..'c'] ["aaaaa","aaaac","aaaca","aaacc","aacaa","aacac","aacca","aaccc","acbcc","accbc","acccb","cabcc","cacbc","caccb","ccbbc","ccbcb","cccbb"]-*Game.Mastermind> CodeSet.flatten $ matching (Set.fromList ['a'..'c']) "aabbb" (Eval 2 0)+*Game.Mastermind> CodeSet.flatten $ matching (EnumSet.fromList ['a'..'c']) "aabbb" (Eval 2 0) ["aaaaa","aaaac","aaaca","aaacc","aacaa","aacac","aacca","aaccc","acbcc","accbc","acccb","cabcc","cacbc","caccb","ccbbc","ccbcb","cccbb"] -}  -histogram :: (Ord a) => [a] -> Map.Map a Int-histogram = Map.fromListWith (+) . map (\a -> (a,1))+bagFromList :: (Enum a) => [a] -> EnumMap a Int+bagFromList = EnumMap.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-{--   Map.toList $-   Map.mapWithKey-      (\a _ -> Map.update (\n -> toMaybe (n>1) (pred n)) a hist) hist--}+selectFromBag, _selectFromBag ::+   (Enum a) => EnumMap a Int -> [(a, EnumMap a Int)]+selectFromBag hist =+   map (\a -> (a, EnumMap.update (\n -> toMaybe (n>1) (pred n)) a hist)) $+   EnumMap.keys hist +_selectFromBag hist =+   EnumMap.toList $+   EnumMap.mapWithKey+      (\a _ -> EnumMap.update (\n -> toMaybe (n>1) (pred n)) a hist) hist++ {- | A variant of the game: It is only possible to specify number of symbols at right places.  The results of 'matching' and 'matchingSimple' cannot be compared. -}-matchingSimple :: Ord a => Set.Set a -> [a] -> Int -> [[Set.Set a]]+matchingSimple :: Enum a => EnumSet a -> [a] -> Int -> [[EnumSet a]] matchingSimple alphabet code rightPlaces =    map       (zipWith          (\symbol right ->             if right-              then Set.singleton symbol-              else Set.delete symbol alphabet)+              then EnumSet.singleton symbol+              else EnumSet.delete symbol alphabet)          code) $    possibleRightPlaces (length code) rightPlaces @@ -121,7 +135,7 @@ of codes and their evaluations. The searched code is in the intersection of all corresponding code sets. -}-matching :: (CodeSet.C set, Ord a) => Set.Set a -> [a] -> Eval -> set a+matching :: (CodeSet.C set, Enum a) => EnumSet a -> [a] -> Eval -> set a matching alphabet =    let findCodes =           foldr@@ -131,13 +145,13 @@                   else                     (unions $ do                         guard (rightSymbols > 0)-                        (src, floating1) <- selectFromHistogram floating0-                        guard (c /= src)+                        (src, floating1) <- selectFromBag floating0+                        guard (not $ equating fromEnum c src)                         return $ src #*& go (rightSymbols-1) floating1)                     `union`-                    (Set.difference-                        (Set.delete c alphabet)-                        (Map.keysSet floating0) *&+                    (EnumSet.difference+                        (EnumSet.delete c alphabet)+                        (EnumMap.keysSet floating0) *&                      go rightSymbols floating0))              (\rightSymbols _floating ->                 if rightSymbols>0@@ -149,11 +163,11 @@           (\pattern ->              let patternCode = zip pattern code              in  findCodes patternCode rightSymbols $-                 histogram $ map snd $ filter (not . fst) patternCode) $+                 bagFromList $ map snd $ filter (not . fst) patternCode) $        possibleRightPlaces (length code) rightPlaces  -partitionSizes :: (Ord a) => Set.Set a -> [a] -> [(Eval, Integer)]+partitionSizes :: (Enum a) => EnumSet a -> [a] -> [(Eval, Integer)] partitionSizes alphabet code =    map (\eval -> (eval, CodeSetTree.size $ matching alphabet code eval)) $    possibleEvaluations (length code)@@ -166,41 +180,44 @@   interaction ::-   (CodeSetTree.T Char -> MS.StateT state Maybe [Char]) ->+   (CodeSetTree.T Char -> MS.State state (Maybe [Char])) ->    state -> NonEmptySet.T Char -> Int -> IO () interaction select initial alphabet n =-   let go state set =-          case MS.runStateT (select set) state of-             Nothing -> putStrLn "contradicting evaluations"-             Just (attempt, newState) -> do-                putStr $ show attempt ++ " " ++-                   show (CodeSet.size set, CodeSet.representationSize set,-                         Set.size (CodeSet.symbols 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)+   let go set = do+          newGuess <- MS.state $ MS.runState $ select set+          case newGuess of+             Nothing -> liftIO $ putStrLn "contradicting evaluations"+             Just attempt -> do+                liftIO $ do+                   putStr $+                      show attempt ++ " " +++                      show (CodeSet.size set, CodeSet.representationSize set,+                            EnumSet.size (CodeSet.symbols set)) ++ " "+                   IO.hFlush IO.stdout+                eval <- liftIO getLine+                let getEval =+                      fmap (fromMaybe 0) . MS.state .+                      EnumMap.updateLookupWithKey (\_ _ -> Nothing)+                let ((rightPlaces,rightSymbols), ignored) =+                      MS.runState (liftM2 (,) (getEval 'x') (getEval 'o')) $+                      bagFromList eval+                when (not $ EnumMap.null ignored) $+                   liftIO $ putStrLn $ "ignoring: " ++ EnumMap.keys ignored                 if rightPlaces >= n-                  then putStrLn "I won!"-                  else go newState $ intersection set $+                  then liftIO $ putStrLn "I won!"+                  else go $ intersection set $                        matching (NonEmptySet.flatten alphabet) attempt $                        Eval rightPlaces rightSymbols-   in  go initial (cube alphabet n)+   in MS.evalStateT (go (cube alphabet n)) initial  mainSimple :: NonEmptySet.T Char -> Int -> IO ()-mainSimple = interaction (MT.lift . listToMaybe . CodeSet.flatten) ()+mainSimple = interaction (return . listToMaybe . CodeSet.flatten) ()  {- | minimum of maximums using alpha-beta-pruning -}-minimax :: (Ord b) => (a -> [b]) -> [a] -> a-minimax _ [] = error "minimax of empty list"-minimax f (a0:rest) =+minimax :: (Ord b) => (a -> [b]) -> NonEmpty.T [] a -> a+minimax f (NonEmpty.Cons a0 rest) =    fst $    foldl       (\old@(_minA, minB) a ->@@ -211,14 +228,14 @@ {- | Remove all but one unused symbols from the alphabet. -}-reduceAlphabet :: (CodeSet.C set, Ord a) => set a -> Set.Set a -> Set.Set a+reduceAlphabet :: (CodeSet.C set, Enum a) => set a -> EnumSet a -> EnumSet a reduceAlphabet set alphabet =    let symbols = CodeSet.symbols set-   in  Set.union symbols $ Set.fromList $ take 1 $ Set.toList $-       Set.difference alphabet symbols+   in  EnumSet.union symbols $ EnumSet.fromList $ take 1 $ EnumSet.toList $+       EnumSet.difference alphabet symbols  bestSeparatingCode ::-   (CodeSet.C set, Ord a) => Int -> set a -> [[a]] -> [a]+   (CodeSet.C set, Enum a) => Int -> set a -> NonEmpty.T [] [a] -> [a] bestSeparatingCode n set =    let alphabet = CodeSet.symbols set    in minimax $ \attempt ->@@ -230,17 +247,17 @@ all matching codes and build a histogram. -} bestSeparatingCodeHistogram ::-   (CodeSet.C set, Ord a) => set a -> [[a]] -> [a]+   (CodeSet.C set, Enum a) => set a -> NonEmpty.T [] [a] -> [a] bestSeparatingCodeHistogram set =    minimax $ \attempt ->       Map.elems $ histogram $ map (evaluate attempt) $ CodeSet.flatten set  propBestSeparatingCode ::-   (CodeSet.C set, Ord a) => Int -> set a -> [[a]] -> Bool+   (CodeSet.C set, Enum a) => Int -> set a -> NonEmpty.T [] [a] -> Bool propBestSeparatingCode n set attempts =-   bestSeparatingCode n set attempts-   ==-   bestSeparatingCodeHistogram set attempts+   equating (map fromEnum)+      (bestSeparatingCode n set attempts)+      (bestSeparatingCodeHistogram set attempts)   {-@@ -250,16 +267,13 @@ from mainSimple and needs more attempts. -} randomizedAttempt ::-   (CodeSet.C set, Rnd.RandomGen g, Ord a) =>-   Int -> set a -> MS.StateT g Maybe [a]+   (CodeSet.C set, Rnd.RandomGen g, Enum a) =>+   Int -> set a -> MS.State g (Maybe [a]) randomizedAttempt n set = do-   randomAttempts <--      replicateM 10 $-      replicateM n $-      randomSelect . Set.toList $-      CodeSet.symbols set-   let possible = CodeSet.flatten set-       somePossible =+   let symbolSet = CodeSet.symbols set+   let randomCode = replicateM n $ randomSelect $ EnumSet.toList symbolSet+   randomAttempts <- liftM2 (!:) randomCode $ replicateM 9 randomCode+   let somePossible =           -- take 10 possible codes           let size = CodeSet.size set               num = 10@@ -268,9 +282,24 @@               take num $               map (flip div (fromIntegral num)) $               iterate (size+) 0-   _ <- MT.lift $ listToMaybe possible-   return $ bestSeparatingCode n set $ somePossible ++ randomAttempts+   return $+      toMaybe (not $ CodeSet.null set) $+      bestSeparatingCode n set $+      NonEmpty.appendLeft somePossible randomAttempts ++withNonEmptyCodeSet ::+   (Monad m, CodeSet.C set, Enum a) =>+   set a ->+   (NonEmpty.T [] [a] -> m (Maybe [a])) ->+   m (Maybe [a])+withNonEmptyCodeSet set f =+   case CodeSet.flatten set of+      [] -> return Nothing+      x:[] -> return $ Just x+      x:_:[] -> return $ Just x+      x:xs -> f $ x!:xs+ {- | In the beginning we choose codes that separate reasonably well, based on heuristics.@@ -283,21 +312,18 @@ without the extra symbol? -} separatingRandomizedAttempt ::-   (CodeSet.C set, Rnd.RandomGen g, Ord a) =>-   Int -> Set.Set a -> set a -> MS.StateT g Maybe [a]-separatingRandomizedAttempt n alphabet0 set = do-   case CodeSet.size set of-      0 -> MT.lift Nothing-      1 -> return $ head $ CodeSet.flatten set-      2 -> return $ head $ CodeSet.flatten set-      size ->-         let alphabet = reduceAlphabet set alphabet0-             alphabetSize = Set.size alphabet-             bigSize = toInteger size-         in  if bigSize * (bigSize + toInteger alphabetSize ^ n) <= 1000000-               then return $ bestSeparatingCodeHistogram set $-                    CodeSet.flatten set ++ replicateM n (Set.toList alphabet)-               else randomizedAttempt n set+   (CodeSet.C set, Rnd.RandomGen g, Enum a) =>+   Int -> EnumSet a -> set a -> MS.State g (Maybe [a])+separatingRandomizedAttempt n alphabet0 set =+   withNonEmptyCodeSet set $ \flattenedSet ->+      let size = CodeSet.size set+          alphabet = reduceAlphabet set alphabet0+          alphabetSize = EnumSet.size alphabet+      in if size * (size + toInteger alphabetSize ^ n) <= 1000000+            then return $ Just $ bestSeparatingCodeHistogram set $+                 NonEmpty.appendRight flattenedSet $+                 replicateM n (EnumSet.toList alphabet)+            else randomizedAttempt n set  {- | In the beginning we simply choose a random code@@ -306,20 +332,80 @@ then we compare different alternatives. -} mixedRandomizedAttempt ::-   (CodeSet.C set, Rnd.RandomGen g, Ord a) =>-   Int -> set a -> MS.StateT g Maybe [a]-mixedRandomizedAttempt n set = do-   case CodeSet.size set of-      0 -> MT.lift Nothing-      1 -> return $ head $ CodeSet.flatten set-      2 -> return $ head $ CodeSet.flatten set-      size ->-         if size <= 100+   (CodeSet.C set, Rnd.RandomGen g, Enum a) =>+   Int -> set a -> MS.State g (Maybe [a])+mixedRandomizedAttempt n set =+   withNonEmptyCodeSet set $ \ _flattenedSet ->+      let size = CodeSet.size set+      in if size <= 100            then randomizedAttempt n set-           else-              fmap (CodeSet.select set) $-              MS.state $ Rnd.randomR (0, size-1)+           else fmap (Just . CodeSet.select set) $+                MS.state $ Rnd.randomR (0, size-1) +{- |+This strategy starts with scanning the alphabet.+That is, we test sets of different symbols we did not try so far.+The idea is to sort out unused symbols early.+This is especially useful when the alphabet is large,+i.e. its size is some multiples of the code width.++We stop scanning when we are sure to have seen+all characters of the secret code.+E.g.:++> vicx+> alsn   o+> mfgt   o+> hjqw+> edpz   oo+> bkru   - we already know, that these cannot be in the secret code++We use the 'Choice' data type+for tracking the number of symbols that we can minimally use+from the ones we have already tried.+The order of applying 'mergeChoice' matters,+but I see no easy way to find a good order+or to make it robust against re-ordering.++If the user tells us that all symbols in a code are used,+then the scanning phase ends immediately.+This happens automatically according to our way of processing 'Choice's.+-}+scanningRandomizedAttempt ::+   (CodeSet.C set, Rnd.RandomGen g, Enum a) =>+   Int -> EnumSet a -> [([a], Eval)] -> set a -> MS.State g (Maybe [a])+scanningRandomizedAttempt n alphabet oldGuesses set = do+   let sumEval (Eval correctPlaces correctSymbols) =+         correctPlaces + correctSymbols+   let (Choice totalBag count) =+         foldl mergeChoice noChoice $+         map (uncurry Choice . mapPair (bagFromList, sumEval)) oldGuesses+   let unusedSymbols = EnumSet.difference alphabet $ EnumMap.keysSet totalBag+   if count>=n+      then randomizedAttempt n set+      else+         if EnumSet.size unusedSymbols <= n+            then mixedRandomizedAttempt n set+            else do+               let nextSymbols = EnumSet.toList unusedSymbols+               keys <-+                  mapM+                     (const $ MS.state $ Rnd.randomR (0,1::Double))+                     nextSymbols+               return $ Just $ map snd $ take n $+                  List.sortBy (comparing fst) $ zip keys nextSymbols+{-+   if count>=n || EnumSet.size unusedSymbols <= n+      then randomizedAttempt n set+      else do+         let nextSymbols = EnumSet.toList unusedSymbols+         keys <-+            mapM (const $ MS.state $ Rnd.randomR (0,1::Double)) nextSymbols+         return $ map snd $ take n $+            List.sortBy (comparing fst) $ zip keys nextSymbols+-}++ mainRandom :: NonEmptySet.T Char -> Int -> IO () mainRandom alphabet n = do    g <- Rnd.getStdGen@@ -347,6 +433,6 @@ contradicting evaluations *Game.Mastermind> map (evaluate "amiga") ["uvqcm","wukjv","lmoci","caoab","mbadi","ombed","lqbia"] [Eval 0 1,Eval 0 0,Eval 1 1,Eval 0 2,Eval 0 3,Eval 1 0,Eval 1 1]-*Game.Mastermind> map (\attempt -> member "amiga" $ matching (Set.fromList $ ['a'..'z']) attempt (evaluate "amiga" attempt)) ["uvqcm","wukjv","lmoci","caoab","mbadi","ombed","lqbia"]+*Game.Mastermind> map (\attempt -> member "amiga" $ matching (EnumSet.fromList $ ['a'..'z']) attempt (evaluate "amiga" attempt)) ["uvqcm","wukjv","lmoci","caoab","mbadi","ombed","lqbia"] [True,True,True,True,False,True,False] -}

@@ -7,10 +7,11 @@    (*&), (#*&),    ) where +import qualified Game.Mastermind.NonEmptyEnumSet as NonEmptySet+ import qualified Data.NonEmpty.Class as NonEmptyC-import qualified Data.NonEmpty.Set as NonEmptySet import qualified Data.NonEmpty as NonEmpty-import qualified Data.Set as Set+import Data.EnumSet (EnumSet) import Data.Function.HT (nest, ) import Data.Ord.HT (comparing, ) @@ -19,23 +20,23 @@  class C set where    empty :: set a-   union, intersection :: (Ord a) => set a -> set a -> set a+   union, intersection :: (Enum a) => set a -> set a -> set a    unit :: set a    leftNonEmptyProduct :: NonEmptySet.T a -> set a -> set a-   flatten :: (Ord a) => set a -> [[a]]-   symbols :: (Ord a) => set a -> Set.Set a+   flatten :: (Enum a) => set a -> [[a]]+   symbols :: (Enum a) => set a -> EnumSet a    null :: set a -> Bool    size :: set a -> Integer-   select :: set a -> Integer -> [a]+   select :: (Enum a) => set a -> Integer -> [a]    representationSize :: set a -> Int    -- | simplify set representation by combining set products where possible-   compress :: (Ord a) => set a -> set a+   compress :: (Enum a) => set a -> set a  cube :: (C set) => NonEmptySet.T a -> Int -> set a cube alphabet n =    nest n (leftNonEmptyProduct alphabet) unit -unions :: (C set, Ord a) => [set a] -> set a+unions :: (C set, Enum a) => [set a] -> set a unions = foldr union empty  @@ -47,7 +48,7 @@ thus the procedure would always insert at the front. This is what 'intersections' does anyway. -}-intersectionsPQ :: (C set, Ord a) => NonEmpty.T [] (set a) -> set a+intersectionsPQ :: (C set, Enum a) => NonEmpty.T [] (set a) -> set a intersectionsPQ =    let go (NonEmpty.Cons (_, set) []) = set        go (NonEmpty.Cons (_,x) ((_,y):rest)) =@@ -59,10 +60,10 @@        NonEmptyC.sortBy (comparing fst) .        fmap (\set -> (representationSize set, set)) -intersections :: (C set, Ord a) => NonEmpty.T [] (set a) -> set a+intersections :: (C set, Enum a) => NonEmpty.T [] (set a) -> set a intersections = NonEmpty.foldl1 intersection . nonEmptySortKey size --- cannot be easily generalized for inclusion in non-empty package+-- ToDo: import from NonEmptyC nonEmptySortKey :: (Ord b) => (a -> b) -> NonEmpty.T [] a -> NonEmpty.T [] a nonEmptySortKey f =    fmap snd . NonEmptyC.sortBy (comparing fst) . fmap (\x -> (f x, x))@@ -73,12 +74,11 @@ {- | Like 'leftNonEmptyProduct' but the left operand can be empty. -}-(*&) :: (C set, Ord a) => Set.Set a -> set a -> set a+(*&) :: (C set, Enum a) => EnumSet a -> set a -> set a c *& set =    case NonEmptySet.fetch c of       Nothing -> empty       Just nec -> leftNonEmptyProduct nec set -(#*&) :: (C set) => a -> set a -> set a-c #*& set =-   leftNonEmptyProduct (NonEmptySet.singleton c) set+(#*&) :: (C set, Enum a) => a -> set a -> set a+c #*& set = leftNonEmptyProduct (NonEmptySet.singleton c) set

@@ -4,14 +4,14 @@    ) where  import qualified Game.Mastermind.CodeSet as CodeSet-import Game.Utility (nonEmptySetToList, )+import qualified Game.Mastermind.NonEmptyEnumSet as NonEmptySet  import Control.Monad (liftM2, mfilter, ) -import qualified Data.NonEmpty.Set as NonEmptySet import qualified Data.NonEmpty as NonEmpty+import qualified Data.EnumSet as EnumSet import qualified Data.Map as Map-import qualified Data.Set as Set+import Data.EnumSet (EnumSet)  import Data.Tuple.HT (mapFst, swap, ) import Data.Ord.HT (comparing, )@@ -48,18 +48,18 @@    compress = compress  -flatten :: (Ord a) => T a -> [[a]]+flatten :: (Enum a) => T a -> [[a]] flatten End = [[]] flatten (Products xs) =    concatMap-      (\(a,b) -> liftM2 (:) (nonEmptySetToList a) (flatten b))+      (\(a,b) -> liftM2 (:) (NonEmptySet.toFlatList a) (flatten b))       (Map.toList xs) -symbols :: (Ord a) => T a -> Set.Set a-symbols End = Set.empty+symbols :: (Enum a) => T a -> EnumSet a+symbols End = EnumSet.empty symbols (Products xps) =-   Set.unions $-   map (\(x,xs) -> Set.union (NonEmptySet.flatten x) (symbols xs)) $+   EnumSet.unions $+   map (\(x,xs) -> EnumSet.union (NonEmptySet.flatten x) (symbols xs)) $    Map.toList xps  @@ -71,7 +71,7 @@    Map.toList xs  -- FixMe: somehow inefficient, because the sizes of subsets are recomputed several times-select :: T a -> Integer -> [a]+select :: (Enum a) => T a -> Integer -> [a] select End n =    case compare n 0 of      LT -> error "CodeSet.select.end: index negative"@@ -93,7 +93,7 @@          [] -> error "CodeSet.select: index too large"          ((x,xs), ((n1,_), xsSize)) : _ ->             let (j,k) = divMod n1 xsSize-            in  (nonEmptySetToList x !! fromInteger j)+            in  (NonEmptySet.toFlatList x !! fromInteger j)                 : select xs k  representationSize :: T a -> Int@@ -107,18 +107,18 @@ We could try to merge set products. I'll first want to see, whether this is needed in a relevant number of cases. -}-union :: (Ord a) => T a -> T a -> T a+union :: (Enum a) => T a -> T a -> T a union End End = End union (Products xs) (Products ys) = Products (Map.unionWith union xs ys) union _ _ = error "CodeSet.union: sets with different tuple size" -intersection :: (Ord a) => T a -> T a -> T a+intersection :: (Enum a) => T a -> T a -> T a intersection End End = End intersection (Products xps) (Products yps) =    Products $ Map.fromListWith union $ normalizeProducts $    liftM2       (\(x,xs) (y,ys) ->-         (Set.intersection (NonEmptySet.flatten x) (NonEmptySet.flatten y),+         (EnumSet.intersection (NonEmptySet.flatten x) (NonEmptySet.flatten y),           intersection xs ys))       (Map.toList xps)       (Map.toList yps)@@ -128,7 +128,7 @@ {- | Remove empty set products. -}-normalizeProducts :: (Ord a) => [(Set.Set a, T a)] -> [(NonEmptySet.T a, T a)]+normalizeProducts :: (Enum a) => [(EnumSet a, T a)] -> [(NonEmptySet.T a, T a)] normalizeProducts =    mapMaybe       (\(x,xs) ->@@ -139,7 +139,7 @@ Comparing for structural equivalence is overly strict, but a lot simpler than comparing for set equivalence. -}-propIntersections :: (Ord a) => NonEmpty.T [] (T a) -> Bool+propIntersections :: (Enum a) => NonEmpty.T [] (T a) -> Bool propIntersections xs =    equating Indexable       (CodeSet.intersections xs)@@ -155,14 +155,14 @@ -} newtype Indexable a = Indexable (T a) -instance (Eq a) => Eq (Indexable a) where+instance (Enum a) => Eq (Indexable a) where    (Indexable x) == (Indexable y) =       case (x,y) of          (End,End) -> True          (Products xs, Products ys) -> equating (fmap Indexable) xs ys          _ -> False -instance (Ord a) => Ord (Indexable a) where+instance (Enum a) => Ord (Indexable a) where    compare (Indexable x) (Indexable y) =       case (x,y) of          (End,End) -> EQ@@ -172,7 +172,7 @@          (Products xs, Products ys) -> comparing (fmap Indexable) xs ys  -compress :: (Ord a) => T a -> T a+compress :: (Enum a) => T a -> T a compress End = End compress (Products xs) =    Products $@@ -182,7 +182,7 @@    map (mapFst Indexable) $ map swap $ Map.toList $    fmap compress xs -member :: (Ord a) => [a] -> T a -> Bool+member :: (Enum a) => [a] -> T a -> Bool member [] End = True member (c:cs) (Products xps) =    any (\(x,xs) -> NonEmptySet.member c x && member cs xs) $

@@ -5,13 +5,14 @@    ) where  import qualified Game.Mastermind.CodeSet as CodeSet-import Game.Utility (nonEmptySetToList, )+import qualified Game.Mastermind.NonEmptyEnumSet as NonEmptySet -import qualified Data.NonEmpty.Set as NonEmptySet import qualified Data.NonEmpty as NonEmpty+import qualified Data.EnumSet as EnumSet import qualified Data.Set as Set import qualified Data.List.HT as ListHT import qualified Data.List as List+import Data.EnumSet (EnumSet) import Data.Maybe (mapMaybe, )  import Control.Monad (liftM2, guard, )@@ -24,7 +25,7 @@ -} newtype T a = Cons [[NonEmptySet.T a]] -instance (Ord a, Show a) => Show (T a) where+instance (Enum a, Show a) => Show (T a) where    showsPrec n cs =       showParen (n>=10) $       showString "CodeSet.fromLists " . shows (toLists cs)@@ -44,17 +45,17 @@    compress = id  -toLists :: (Ord a) => T a -> [[[a]]]-toLists (Cons xs) = map (map nonEmptySetToList) xs+toLists :: (Enum a) => T a -> [[[a]]]+toLists (Cons xs) = map (map NonEmptySet.toFlatList) xs -fromLists :: (Ord a) => [[NonEmpty.T [] a]] -> T a+fromLists :: (Enum a) => [[NonEmpty.T [] a]] -> T a fromLists = Cons . map (map NonEmptySet.fromList) -flatten :: (Ord a) => T a -> [[a]]+flatten :: (Enum a) => T a -> [[a]] flatten = concatMap sequence . toLists -symbols :: (Ord a) => T a -> Set.Set a-symbols = Set.unions . map Set.unions . flattenFactors+symbols :: (Enum a) => T a -> EnumSet a+symbols = EnumSet.unions . map EnumSet.unions . flattenFactors  cube :: Int -> NonEmptySet.T a -> T a cube n alphabet = Cons [replicate n alphabet]@@ -67,7 +68,7 @@ productSizes (Cons x) =    map (product . map (fromIntegral . NonEmptySet.size)) x -select :: T a -> Integer -> [a]+select :: (Enum a) => T a -> Integer -> [a] select set@(Cons xs) n0 =    let sizes = productSizes set    in  if n0<0@@ -87,7 +88,7 @@                               divMod n2                                  (fromIntegral $ NonEmptySet.size componentSet)                       in  (n3,-                           nonEmptySetToList componentSet !! fromInteger i))+                           NonEmptySet.toFlatList componentSet !! fromInteger i))                    n1 prod  representationSize :: T a -> Int@@ -102,33 +103,33 @@ union :: T a -> T a -> T a union (Cons x) (Cons y) = Cons (x++y) -intersection :: (Ord a) => T a -> T a -> T a+intersection :: (Enum a) => T a -> T a -> T a intersection x y =    normalize $-   liftM2 (zipWith Set.intersection) (flattenFactors x) (flattenFactors y)+   liftM2 (zipWith EnumSet.intersection) (flattenFactors x) (flattenFactors y) -member :: (Ord a) => [a] -> T a -> Bool+member :: (Enum a) => [a] -> T a -> Bool member code (Cons xs) =    any (and . zipWith NonEmptySet.member code) xs  {- | Remove empty set products. -}-normalize :: (Ord a) => [[Set.Set a]] -> T a+normalize :: (Enum a) => [[EnumSet a]] -> T a normalize = Cons . mapMaybe (mapM NonEmptySet.fetch) -flattenFactors :: (Ord a) => T a -> [[Set.Set a]]+flattenFactors :: (Enum a) => T a -> [[EnumSet a]] flattenFactors (Cons xs) = map (map NonEmptySet.flatten) xs  -disjointProduct :: (Ord a) => [Set.Set a] -> [Set.Set a] -> Bool+disjointProduct :: (Enum a) => [EnumSet a] -> [EnumSet a] -> Bool disjointProduct prod0 prod1 =-   any Set.null $ zipWith Set.intersection prod0 prod1+   any EnumSet.null $ zipWith EnumSet.intersection prod0 prod1  {- | for debugging: list all pairs of products, that overlap -}-overlappingPairs :: (Ord a) => T a -> [([Set.Set a], [Set.Set a])]+overlappingPairs :: (Enum a) => T a -> [([EnumSet a], [EnumSet a])] overlappingPairs set = do    prod0:rest <- ListHT.tails $ flattenFactors set    prod1 <- rest@@ -138,13 +139,13 @@ {- | for debugging: list all subsets, that are contained in more than one product -}-overlapping :: (Ord a) => T a -> [([Set.Set a], [[Set.Set a]])]+overlapping :: (Enum a) => T a -> [([EnumSet a], [[EnumSet a]])] overlapping set = do    let xs = flattenFactors set    subset <- Set.toList $ Set.fromList $ do       prod0:rest <- ListHT.tails xs       prod1 <- rest-      let sec = zipWith Set.intersection prod0 prod1-      guard $ all (not . Set.null) $ sec+      let sec = zipWith EnumSet.intersection prod0 prod1+      guard $ all (not . EnumSet.null) $ sec       return sec    return (subset, filter (not . disjointProduct subset) xs)

@@ -7,6 +7,7 @@  import qualified Game.Mastermind.CodeSet.Tree as CodeSetTree import qualified Game.Mastermind.CodeSet as CodeSet+import qualified Game.Mastermind.NonEmptyEnumSet as NonEmptySet import qualified Game.Mastermind as MM import Game.Utility (readMaybe, nullToMaybe, randomSelect, ) @@ -17,11 +18,10 @@  import qualified Data.List as List import qualified Data.List.HT as ListHT-import qualified Data.NonEmpty.Set as NonEmptySet import qualified Data.NonEmpty as NonEmpty import Data.Foldable (fold, foldMap) import Data.NonEmpty ((!:))-import Data.Tuple.HT (mapPair, )+import Data.Tuple.HT (mapSnd) import Data.Maybe.HT (toMaybe, )  import qualified Control.Monad.Trans.State as MS@@ -162,11 +162,10 @@                       map (uncurry (MM.matching                               (NonEmptySet.flatten alphabet))) moves                    (attempt,newSeed) =-                      maybe-                         (Nothing, seed)-                         (mapPair (Just, fst . Rnd.random)) $-                      MS.runStateT-                         (MM.mixedRandomizedAttempt width remaining)+                      mapSnd (fst . Rnd.random) $+                      MS.runState+                         (MM.scanningRandomizedAttempt width+                            (NonEmptySet.flatten alphabet) moves remaining)                          (Rnd.mkStdGen seed)                in  state                       (width, symbols, newSeed, Just moves, attempt)

@@ -0,0 +1,40 @@+module Game.Mastermind.NonEmptyEnumSet where++import qualified Data.NonEmpty as NonEmpty+import qualified Data.EnumSet as EnumSet+import Data.EnumSet (EnumSet)+import Data.Maybe.HT (toMaybe)+import Data.Ord.HT (comparing)+import Data.Eq.HT (equating)+++newtype T a = Cons {flatten :: EnumSet a}+   deriving (Show)++instance Eq (T a) where+   (==) = equating (EnumSet.enumSetToIntSet . flatten)++instance Ord (T a) where+   compare = comparing (EnumSet.enumSetToIntSet . flatten)+++size :: T a -> Int+size = EnumSet.size . flatten++member :: (Enum a) => a -> T a -> Bool+member x = EnumSet.member x . flatten++fromList :: (Enum a) => NonEmpty.T [] a -> T a+fromList = Cons . EnumSet.fromList . NonEmpty.flatten++toFlatList :: (Enum a) => T a -> [a]+toFlatList = EnumSet.toList . flatten++fetch :: EnumSet a -> Maybe (T a)+fetch set = toMaybe (not $ EnumSet.null set) (Cons set)++singleton :: (Enum a) => a -> T a+singleton = Cons . EnumSet.singleton++union :: T a -> T a -> T a+union (Cons a) (Cons b) = Cons $ EnumSet.union a b

@@ -1,29 +0,0 @@-module Game.Utility where--import qualified System.Random as Rnd--import qualified Control.Monad.Trans.State as MS-import Control.Monad (liftM, )--import qualified Data.NonEmpty.Set as NonEmptySet-import qualified Data.NonEmpty as NonEmpty---readMaybe :: (Read a) => String -> Maybe a-readMaybe str =-   case reads str of-      [(a,"")] -> Just a-      _ -> Nothing--nullToMaybe :: [a] -> Maybe [a]-nullToMaybe [] = Nothing-nullToMaybe s  = Just s---- candidate for random-utility, cf. module htam:Election, markov-chain--- for Sets it would be more efficient to use Set.elemAt-randomSelect :: (Rnd.RandomGen g, Monad m) => [a] -> MS.StateT g m a-randomSelect items =-   liftM (items!!) $ MS.StateT $ return . Rnd.randomR (0, length items-1)--nonEmptySetToList :: NonEmptySet.T a -> [a]-nonEmptySetToList = NonEmpty.flatten . NonEmptySet.toAscList

@@ -3,21 +3,25 @@ import qualified Game.Mastermind.CodeSet.Tree as CodeSetTree -- import qualified Game.Mastermind.CodeSet.Union as CodeSetUnion import qualified Game.Mastermind.CodeSet as CodeSet+import qualified Game.Mastermind.NonEmptyEnumSet as NonEmptySet import qualified Game.Mastermind as MM+import Game.Utility (Choice, mergeChoice, noChoice)  import Control.Monad (liftM2, ) import Control.Applicative ((<$>), ) -import qualified Data.NonEmpty.Set as NonEmptySet+import qualified Data.NonEmpty.Class as NonEmptyC+import qualified Data.NonEmpty as NonEmpty import qualified Data.Traversable as Trav-import qualified Data.Set as Set+import qualified Data.EnumSet as EnumSet+import Data.EnumSet (EnumSet) import Data.NonEmpty ((!:))  import qualified Test.QuickCheck as QC import Test.QuickCheck (Property, Arbitrary(arbitrary), quickCheck, (==>), )  -alphabet :: Set.Set Int+alphabet :: EnumSet Int alphabet = NonEmptySet.flatten neAlphabet  neAlphabet :: NonEmptySet.T Int@@ -111,7 +115,7 @@ -} partitionSizes :: Code -> Bool partitionSizes (Code attempt) =-   fromIntegral (Set.size alphabet) ^ length attempt+   fromIntegral (EnumSet.size alphabet) ^ length attempt    ==    sum (map snd (MM.partitionSizes alphabet attempt)) @@ -126,8 +130,8 @@        take 100 (CodeSet.flatten set)  -genFixedLengthCodes :: Int -> QC.Gen [[Int]]-genFixedLengthCodes width = QC.listOf1 $ QC.vectorOf width genElement+genFixedLengthCodes :: (NonEmptyC.Gen f) => Int -> QC.Gen (f [Int])+genFixedLengthCodes width = NonEmptyC.genOf $ QC.vectorOf width genElement  bestSeparatingCode :: Property bestSeparatingCode =@@ -140,7 +144,7 @@             (MM.matching alphabet base0 eval0)             (MM.matching alphabet base1 eval1)    not (CodeSet.null set) ==>-      QC.forAll (fmap (take 10) $ genFixedLengthCodes width) $+      QC.forAll (fmap (NonEmpty.mapTail $ take 9) $ genFixedLengthCodes width) $          MM.propBestSeparatingCode width (set :: CodeSetInt)  intersections :: Property@@ -176,6 +180,41 @@ check member against intersection with singleton -} ++choiceLeftIdentity :: Choice Char -> Bool+choiceLeftIdentity a =+   a == mergeChoice noChoice a++choiceRightIdentity :: Choice Char -> Bool+choiceRightIdentity a =+   a == mergeChoice a noChoice++choiceCommutative :: Choice Char -> Choice Char -> Bool+choiceCommutative a b =+   mergeChoice a b == mergeChoice b a++{-+Unfortunately, this does not apply:++*Test.Mastermind EnumMap> let a = Choice (EnumMap.singleton 'x' 1) 1+*Test.Mastermind EnumMap> let b = Choice (EnumMap.singleton 'x' 1) 0+*Test.Mastermind EnumMap> let c = Choice (EnumMap.singleton 'y' 1) 1+*Test.Mastermind EnumMap> mergeChoice (mergeChoice a b) c+Choice (fromList [('x',1),('y',1)]) 2+*Test.Mastermind EnumMap> mergeChoice a (mergeChoice b c)+Choice (fromList [('x',1),('y',1)]) 1+*Test.Mastermind EnumMap> mergeChoice a b+Choice (fromList [('x',1)]) 1+*Test.Mastermind EnumMap> mergeChoice b c+Choice (fromList [('x',1),('y',1)]) 1+-}+_choiceAssociative :: Choice Char -> Choice Char -> Choice Char -> Bool+_choiceAssociative a b c =+   mergeChoice (mergeChoice a b) c+   ==+   mergeChoice a (mergeChoice b c)++ tests :: [(String, IO ())] tests =    ("matchingMember", quickCheck matchingMember) :@@ -188,4 +227,8 @@    ("bestSeparatingCode", quickCheck bestSeparatingCode) :    ("intersections", quickCheck intersections) :    ("solve", quickCheck solve) :+   ("choiceLeftIdentity", quickCheck choiceLeftIdentity) :+   ("choiceRightIdentity", quickCheck choiceRightIdentity) :+   ("choiceCommutative", quickCheck choiceCommutative) :+   -- ("choiceAssociative", quickCheck choiceAssociative) :    []