board-games 0.2 → 0.2.1
raw patch · 17 files changed
+688/−497 lines, 17 filesdep +board-gamesdep +criteriondep ~basedep ~containersdep ~non-emptyPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: board-games, criterion
Dependency ranges changed: base, containers, non-empty, utility-ht
API changes (from Hackage documentation)
+ Game.Mastermind.CodeSet.Tree: size :: T a -> Integer
+ Game.Mastermind.CodeSet.Union: size :: T a -> Integer
- Game.Mastermind: evaluate :: (Ord a) => [a] -> [a] -> Eval
+ Game.Mastermind: evaluate :: Ord a => [a] -> [a] -> Eval
- Game.Mastermind: partitionSizes :: (Ord a) => Set a -> [a] -> [(Eval, Integer)]
+ Game.Mastermind: partitionSizes :: Ord a => Set a -> [a] -> [(Eval, Integer)]
- Game.Mastermind.CodeSet: (#*&) :: (C set) => a -> set a -> set a
+ Game.Mastermind.CodeSet: (#*&) :: C set => a -> set a -> set a
- Game.Mastermind.CodeSet: compress :: (C set, (Ord a)) => set a -> set a
+ Game.Mastermind.CodeSet: compress :: (C set, Ord a) => set a -> set a
- Game.Mastermind.CodeSet: cube :: (C set) => T a -> Int -> set a
+ Game.Mastermind.CodeSet: cube :: C set => T a -> Int -> set a
- Game.Mastermind.CodeSet: flatten :: (C set, (Ord a)) => set a -> [[a]]
+ Game.Mastermind.CodeSet: flatten :: (C set, Ord a) => set a -> [[a]]
- Game.Mastermind.CodeSet: intersection :: (C set, (Ord a)) => set a -> set a -> set a
+ Game.Mastermind.CodeSet: intersection :: (C set, Ord a) => set a -> set a -> set a
- Game.Mastermind.CodeSet: symbols :: (C set, (Ord a)) => set a -> Set a
+ Game.Mastermind.CodeSet: symbols :: (C set, Ord a) => set a -> Set a
- Game.Mastermind.CodeSet: union :: (C set, (Ord a)) => set a -> set a -> set a
+ Game.Mastermind.CodeSet: union :: (C set, Ord a) => set a -> set a -> set a
- Game.Mastermind.CodeSet.Tree: intersection :: (Ord a) => T a -> T a -> T a
+ Game.Mastermind.CodeSet.Tree: intersection :: Ord a => T a -> T a -> T a
- Game.Mastermind.CodeSet.Tree: member :: (Ord a) => [a] -> T a -> Bool
+ Game.Mastermind.CodeSet.Tree: member :: Ord a => [a] -> T a -> Bool
- Game.Mastermind.CodeSet.Tree: propIntersections :: (Ord a) => T [] (T a) -> Bool
+ Game.Mastermind.CodeSet.Tree: propIntersections :: Ord a => T [] (T a) -> Bool
- Game.Mastermind.CodeSet.Union: fromLists :: (Ord a) => [[T [] a]] -> T a
+ Game.Mastermind.CodeSet.Union: fromLists :: Ord a => [[T [] a]] -> T a
- Game.Mastermind.CodeSet.Union: member :: (Ord a) => [a] -> T a -> Bool
+ Game.Mastermind.CodeSet.Union: member :: Ord a => [a] -> T a -> Bool
- Game.Mastermind.CodeSet.Union: overlapping :: (Ord a) => T a -> [([Set a], [[Set a]])]
+ Game.Mastermind.CodeSet.Union: overlapping :: Ord a => T a -> [([Set a], [[Set a]])]
- Game.Mastermind.CodeSet.Union: overlappingPairs :: (Ord a) => T a -> [([Set a], [Set a])]
+ Game.Mastermind.CodeSet.Union: overlappingPairs :: Ord a => T a -> [([Set a], [Set a])]
- Game.Tree: maximumMove :: (Ord score) => T move score -> move
+ Game.Tree: maximumMove :: Ord score => T move score -> move
- Game.Tree: maximumMoveFast :: (Ord score) => T move score -> move
+ Game.Tree: maximumMoveFast :: Ord score => T move score -> move
- Game.Tree: minimumMove :: (Ord score) => T move score -> move
+ Game.Tree: minimumMove :: Ord score => T move score -> move
- Game.Tree: minimumMoveFast :: (Ord score) => T move score -> move
+ Game.Tree: minimumMoveFast :: Ord score => T move score -> move
- Game.Tree: selectDeepSubTree :: (Eq move) => [move] -> T move state -> T move state
+ Game.Tree: selectDeepSubTree :: Eq move => [move] -> T move state -> T move state
- Game.Tree: selectSubTree :: (Eq move) => move -> T move state -> T move state
+ Game.Tree: selectSubTree :: Eq move => move -> T move state -> T move state
Files
- Changes.md +13/−0
- Makefile +12/−0
- benchmark/Main.hs +144/−0
- board-games.cabal +31/−13
- demo/Server.hs +61/−0
- demo/Server/Option.hs +92/−0
- src/Game/Mastermind.hs +37/−53
- src/Game/Mastermind/CodeSet/Tree.hs +7/−12
- src/Game/Mastermind/CodeSet/Union.hs +2/−2
- src/Game/Mastermind/HTML.hs +82/−62
- src/Game/Server.hs +0/−60
- src/Game/Server/Option.hs +0/−92
- src/Game/Test.hs +0/−15
- src/Game/Test/Mastermind.hs +0/−188
- src/Game/Utility.hs +1/−0
- test/Test.hs +15/−0
- test/Test/Mastermind.hs +191/−0
+ Changes.md view
@@ -0,0 +1,13 @@+# Change log for the `board-games` package++## 0.2.1++ * add criterion benchmarks for `Mastermind`++## 0.2++ * improved game strategy for `Mastermind`++## 0.1++ * hierarchical module names
+ Makefile view
@@ -0,0 +1,12 @@+ghci:+ ghci -Wall -i:src src/Game/Mastermind.hs++run-test:+ runhaskell Setup configure --user \+ --enable-tests --enable-benchmarks -fbuildExamples+ runhaskell Setup build+ runhaskell Setup haddock+ ./dist/build/board-games-test/board-games-test++criterion.html: ./dist/build/board-games-benchmark/board-games-benchmark+ $< --output=$@ $(patsubst %.html, %.csv, --summary=$@)
+ benchmark/Main.hs view
@@ -0,0 +1,144 @@+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) :+ []
board-games.cabal view
@@ -1,5 +1,5 @@ Name: board-games-Version: 0.2+Version: 0.2.1 License: GPL License-File: LICENSE Author: Henning Thielemann <haskell@henning-thielemann.de>@@ -31,12 +31,16 @@ Tested-With: GHC==6.4.1, GHC==6.8.2, GHC==6.12.3 Cabal-Version: 1.14 Build-Type: Simple+Extra-Source-Files:+ Makefile+ Changes.md+ Source-Repository head type: darcs location: http://code.haskell.org/~thielema/games/ Source-Repository this- tag: 0.2+ tag: 0.2.1 type: darcs location: http://code.haskell.org/~thielema/games/ @@ -82,19 +86,19 @@ Executable board-games Default-Language: Haskell2010- Main-Is: Game/Server.hs GHC-Options: -Wall- Hs-Source-Dirs: src- Other-Modules:- Game.Server.Option+ Hs-Source-Dirs: demo+ Main-Is: Server.hs+ Other-Modules: Server.Option If flag(buildExamples) Build-Depends:+ board-games, httpd-shed >=0.4 && <0.5, network-uri >=2.6 && <2.7, html, cgi, non-empty,- utility-ht >=0.0.3 && <0.1,+ utility-ht, transformers, containers, random,@@ -103,20 +107,34 @@ Else Buildable: False -Test-Suite testsuite+Test-Suite board-games-test Type: exitcode-stdio-1.0 Default-Language: Haskell2010- Main-Is: Game/Test.hs GHC-Options: -Wall- Hs-Source-Dirs: src- Other-Modules:- Game.Test.Mastermind+ Hs-Source-Dirs: test+ Main-Is: Test.hs+ Other-Modules: Test.Mastermind Build-Depends:+ board-games, QuickCheck >1.2 && <3.0, non-empty,- utility-ht >=0.0.3 && <0.1,+ utility-ht, transformers, containers, random, array,+ base++Benchmark board-games-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+ Build-Depends:+ board-games,+ criterion >=0.6 && <1.6,+ containers,+ non-empty,+ utility-ht, base
+ demo/Server.hs view
@@ -0,0 +1,61 @@+module Main where++import qualified Server.Option as Option++import qualified Game.ZeilenSpalten.HTML as ZeilenSpalten+import qualified Game.VierGewinnt.HTML as VierGewinnt+import qualified Game.Mastermind.HTML as Mastermind++import qualified Network.Shed.Httpd as HTTPd+import Network.URI (uriQuery, uriPath, )++import Text.Html((<<), (+++), )+import qualified Text.Html as Html+++headers :: [(String, String)]+headers =+ [("Content-Type", "text/html; charset=latin1")]++withQuery :: String -> (Maybe String -> IO HTTPd.Response) -> IO HTTPd.Response+withQuery query action =+ case query of+ '?':str -> print str >> (action $ Just str)+ [] -> action $ Nothing+ _ -> return $ HTTPd.Response 400 [] $ "invalid query: " ++ query++main :: IO ()+main = do+ opt <- Option.get+ HTTPd.initServer (Option.port opt) $ \ req -> do+ -- FixMe: should check for HTTP method here+ Option.printVerbose opt 1 req+ let uri = HTTPd.reqURI req+ Option.printVerbose opt 2 $ uriQuery uri+ Option.printVerbose opt 2 $ HTTPd.queryToArguments $ uriQuery uri+ case uriPath uri of+ "/" ->+ return $ HTTPd.Response 200 headers $+ Html.renderHtml $+ Html.header (Html.thetitle << "Web games") ++++ Html.body (Html.unordList (map+ (\(path,name) -> (Html.anchor << name) Html.! [Html.href path]) $+ ("VierGewinnt", "Vier gewinnt") :+ ("ZeilenSpalten", "Zeilen und Spalten") :+ ("Mastermind", "Mastermind") :+ []))+ "/VierGewinnt" ->+ withQuery (uriQuery uri) $ \query ->+ return $ HTTPd.Response 200 headers $ Html.renderHtml $+ VierGewinnt.komplett $ VierGewinnt.erzeuge query+ "/ZeilenSpalten" ->+ withQuery (uriQuery uri) $ \query ->+ fmap (HTTPd.Response 200 headers . Html.renderHtml .+ ZeilenSpalten.komplett) $ ZeilenSpalten.erzeuge query+ "/Mastermind" ->+ withQuery (uriQuery uri) $ \query ->+ fmap (HTTPd.Response 200 headers . Html.renderHtml .+ Mastermind.complete) $ Mastermind.generate query+ path ->+ return $ HTTPd.Response 404 [] $ "unknown game: " ++ path+ return ()
+ demo/Server/Option.hs view
@@ -0,0 +1,92 @@+module Server.Option (+ T(..),+ get,+ printVerbose,+ ) where++import System.Console.GetOpt+ (getOpt, ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, )+import System.Environment (getArgs, getProgName, )+import System.Exit (exitSuccess, exitFailure, )+import qualified System.IO as IO++import Control.Monad (when, )+++data T =+ Cons {+ verbosity :: Int,+ port :: Int+ }+ deriving (Show)+++deflt :: T+deflt =+ Cons {+ verbosity = 0,+ port = 8080+ -- other options might control maximum values for some dimensions in the games+ }+++exitFailureMsg :: String -> IO a+exitFailureMsg msg =+ IO.hPutStrLn IO.stderr msg >> exitFailure++parseNumber ::+ (Read a) =>+ String -> (a -> Bool) -> String -> String -> IO a+parseNumber name constraint constraintName str =+ case reads str of+ [(n, "")] ->+ if constraint n+ then return n+ else exitFailureMsg $ name ++ " must be " ++ constraintName+ _ ->+ exitFailureMsg $ name ++ " must be a number, but is '" ++ str ++ "'"+++printVerbose :: (Show a) => T -> Int -> a -> IO ()+printVerbose opt verb a =+ when (verb <= verbosity opt) $ print a+++{-+Guide for common Linux/Unix command-line options:+ http://www.faqs.org/docs/artu/ch10s05.html+-}+description :: [OptDescr (T -> IO T)]+description =+ Option ['h'] ["help"]+ (NoArg $ \ _flags -> do+ programName <- getProgName+ putStrLn+ (usageInfo ("Usage: " ++ programName ++ " [OPTIONS]") description)+ exitSuccess)+ "show options" :+ Option ['v'] ["verbose"]+ (flip ReqArg "LEVEL" $ \str flags ->+ fmap (\verb -> flags{verbosity = fromInteger verb}) $+ parseNumber "verbosity" (\n -> 0<=n && n<=2) "from the range from 0 to 2" str)+ "level of verbosity" :+ Option ['p'] ["port"]+ (flip ReqArg "NUMBER" $ \str flags ->+ fmap (\p -> flags{port = fromInteger p}) $+ parseNumber "port" (\n -> 0<n && n<0x10000) "a positive 16-bit number" str)+ "port number" :+ []+++get :: IO T+get = do+ argv <- getArgs+ let (opts, files, errors) = getOpt RequireOrder description argv+ when (not $ null errors) $+ exitFailureMsg (init (concat errors))+ when (not $ null files) $+ exitFailureMsg $+ "Do not know what to do with arguments " ++ show files+ foldl (>>=)+ (return deflt)+ opts
src/Game/Mastermind.hs view
@@ -18,7 +18,7 @@ -- import qualified Game.Mastermind.CodeSet.Union as CodeSetUnion import qualified Game.Mastermind.CodeSet as CodeSet import Game.Mastermind.CodeSet- (flatten, intersection, (*&), (#*&), unit, empty, union, unions, cube, )+ (intersection, (*&), (#*&), unit, empty, union, unions, cube, ) import Game.Utility (randomSelect, ) import qualified Data.NonEmpty.Set as NonEmptySet@@ -32,8 +32,8 @@ import Data.Maybe (listToMaybe, ) import Control.Monad (guard, when, replicateM, ) -import qualified Control.Monad.Trans.State as State-import qualified Control.Monad.Trans.Class as Trans+import qualified Control.Monad.Trans.State as MS+import qualified Control.Monad.Trans.Class as MT import qualified System.Random as Rnd import qualified System.IO as IO@@ -59,19 +59,23 @@ {- *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> flatten $ matching (Set.fromList ['a'..'c']) "aabbb" (Eval 2 0)+*Game.Mastermind> CodeSet.flatten $ matching (Set.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))+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+{-+ Map.toList $+ Map.mapWithKey+ (\a _ -> Map.update (\n -> toMaybe (n>1) (pred n)) a hist) hist+-} {- | A variant of the game:@@ -117,9 +121,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, Ord a) => Set.Set a -> [a] -> Eval -> set a matching alphabet = let findCodes = foldr@@ -153,11 +155,7 @@ partitionSizes :: (Ord a) => Set.Set a -> [a] -> [(Eval, Integer)] partitionSizes alphabet code =- map (\eval ->- (eval,- CodeSet.size $- (id :: CodeSetTree.T a -> CodeSetTree.T a) $- matching alphabet code eval)) $+ map (\eval -> (eval, CodeSetTree.size $ matching alphabet code eval)) $ possibleEvaluations (length code) possibleEvaluations :: Int -> [Eval]@@ -168,12 +166,11 @@ interaction ::- (CodeSetTree.T Char -> State.StateT state Maybe [Char]) ->- state ->- NonEmptySet.T Char -> Int -> IO ()+ (CodeSetTree.T Char -> MS.StateT state Maybe [Char]) ->+ state -> NonEmptySet.T Char -> Int -> IO () interaction select initial alphabet n = let go state set =- case State.runStateT (select set) state of+ case MS.runStateT (select set) state of Nothing -> putStrLn "contradicting evaluations" Just (attempt, newState) -> do putStr $ show attempt ++ " " ++@@ -196,25 +193,20 @@ in go initial (cube alphabet n) mainSimple :: NonEmptySet.T Char -> Int -> IO ()-mainSimple =- interaction- (Trans.lift . listToMaybe . flatten)- ()+mainSimple = interaction (MT.lift . listToMaybe . CodeSet.flatten) () {- | minimum of maximums using alpha-beta-pruning -}-minimax :: (Ord b) => [(a, [b])] -> a-minimax [] = error "minimax of empty list"-minimax ((a0,bs0):rest) =+minimax :: (Ord b) => (a -> [b]) -> [a] -> a+minimax _ [] = error "minimax of empty list"+minimax f (a0: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+ (\old@(_minA, minB) a ->+ let (ltMinB, geMinB) = partition (<minB) $ f a+ in if null geMinB then (a, maximum ltMinB) else old)+ (a0, maximum $ f a0) rest {- | Remove all but one unused symbols from the alphabet.@@ -226,17 +218,12 @@ Set.difference alphabet symbols bestSeparatingCode ::- (CodeSet.C set, Ord a) =>- Int -> set a -> [[a]] -> [a]+ (CodeSet.C set, Ord a) => Int -> set a -> [[a]] -> [a] bestSeparatingCode n set = let alphabet = CodeSet.symbols set- in minimax .- map- (\attempt ->- (attempt,- map (CodeSet.size . intersection set .- matching alphabet attempt) $- possibleEvaluations n))+ in minimax $ \attempt ->+ map (CodeSet.size . intersection set . matching alphabet attempt) $+ possibleEvaluations n {- For small sets of codes it is faster to evaluate@@ -245,11 +232,8 @@ bestSeparatingCodeHistogram :: (CodeSet.C set, Ord a) => set a -> [[a]] -> [a] bestSeparatingCodeHistogram set =- minimax .- map- (\attempt ->- (attempt,- Map.elems $ histogram $ map (evaluate attempt) $ CodeSet.flatten set))+ minimax $ \attempt ->+ Map.elems $ histogram $ map (evaluate attempt) $ CodeSet.flatten set propBestSeparatingCode :: (CodeSet.C set, Ord a) => Int -> set a -> [[a]] -> Bool@@ -267,14 +251,14 @@ -} randomizedAttempt :: (CodeSet.C set, Rnd.RandomGen g, Ord a) =>- Int -> set a -> State.StateT g Maybe [a]+ Int -> set a -> MS.StateT g Maybe [a] randomizedAttempt n set = do randomAttempts <- replicateM 10 $ replicateM n $ randomSelect . Set.toList $ CodeSet.symbols set- let possible = flatten set+ let possible = CodeSet.flatten set somePossible = -- take 10 possible codes let size = CodeSet.size set@@ -284,7 +268,7 @@ take num $ map (flip div (fromIntegral num)) $ iterate (size+) 0- _ <- Trans.lift $ listToMaybe possible+ _ <- MT.lift $ listToMaybe possible return $ bestSeparatingCode n set $ somePossible ++ randomAttempts {- |@@ -300,10 +284,10 @@ -} separatingRandomizedAttempt :: (CodeSet.C set, Rnd.RandomGen g, Ord a) =>- Int -> Set.Set a -> set a -> State.StateT g Maybe [a]+ Int -> Set.Set a -> set a -> MS.StateT g Maybe [a] separatingRandomizedAttempt n alphabet0 set = do case CodeSet.size set of- 0 -> Trans.lift Nothing+ 0 -> MT.lift Nothing 1 -> return $ head $ CodeSet.flatten set 2 -> return $ head $ CodeSet.flatten set size ->@@ -323,10 +307,10 @@ -} mixedRandomizedAttempt :: (CodeSet.C set, Rnd.RandomGen g, Ord a) =>- Int -> set a -> State.StateT g Maybe [a]+ Int -> set a -> MS.StateT g Maybe [a] mixedRandomizedAttempt n set = do case CodeSet.size set of- 0 -> Trans.lift Nothing+ 0 -> MT.lift Nothing 1 -> return $ head $ CodeSet.flatten set 2 -> return $ head $ CodeSet.flatten set size ->@@ -334,7 +318,7 @@ then randomizedAttempt n set else fmap (CodeSet.select set) $- State.StateT $ return . Rnd.randomR (0, size-1)+ MS.state $ Rnd.randomR (0, size-1) mainRandom :: NonEmptySet.T Char -> Int -> IO () mainRandom alphabet n = do
src/Game/Mastermind/CodeSet/Tree.hs view
@@ -1,5 +1,5 @@ module Game.Mastermind.CodeSet.Tree (- T, null, member, intersection,+ T, null, member, intersection, size, propIntersections, ) where @@ -29,13 +29,6 @@ data T a = End | Products (Map.Map (NonEmptySet.T a) (T a)) deriving (Show) -{--instance (Ord a, Show a) => Show (T a) where- showsPrec n cs =- showParen (n>=10) $- showString "CodeSet.fromLists " . shows (toLists cs)--}- instance CodeSet.C T where empty = Products Map.empty union = union@@ -70,13 +63,14 @@ Map.toList xps +-- ToDo: sizeLimitted max - return size only if it is at most 'max' size :: T a -> Integer size End = 1 size (Products xs) = sum $ map (\(a,b) -> fromIntegral (NonEmptySet.size a) * size b) $ Map.toList xs --- somehow inefficient, because the sizes of subsets are recomputed several times+-- FixMe: somehow inefficient, because the sizes of subsets are recomputed several times select :: T a -> Integer -> [a] select End n = case compare n 0 of@@ -115,8 +109,7 @@ -} union :: (Ord a) => T a -> T a -> T a union End End = End-union (Products xs) (Products ys) =- Products (Map.unionWith union xs ys)+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@@ -173,6 +166,7 @@ compare (Indexable x) (Indexable y) = case (x,y) of (End,End) -> EQ+ -- maybe should be even an error (End,Products _) -> LT (Products _,End) -> GT (Products xs, Products ys) -> comparing (fmap Indexable) xs ys@@ -182,7 +176,8 @@ compress End = End compress (Products xs) = Products $- Map.fromListWith union $ map swap $ map (mapFst (\(Indexable set) -> set)) $ Map.toList $+ Map.fromListWith union $ map swap $+ map (mapFst (\(Indexable set) -> set)) $ Map.toList $ Map.fromListWith NonEmptySet.union $ map (mapFst Indexable) $ map swap $ Map.toList $ fmap compress xs
src/Game/Mastermind/CodeSet/Union.hs view
@@ -1,5 +1,5 @@ module Game.Mastermind.CodeSet.Union (- T, member,+ T, member, size, fromLists, cube, overlappingPairs, overlapping, ) where@@ -65,7 +65,7 @@ productSizes :: T a -> [Integer] productSizes (Cons x) =- map (product . map (fromIntegral . NonEmptySet.size)) $ x+ map (product . map (fromIntegral . NonEmptySet.size)) x select :: T a -> Integer -> [a] select set@(Cons xs) n0 =
src/Game/Mastermind/HTML.hs view
@@ -8,7 +8,7 @@ import qualified Game.Mastermind.CodeSet.Tree as CodeSetTree import qualified Game.Mastermind.CodeSet as CodeSet import qualified Game.Mastermind as MM-import Game.Utility (readMaybe, nullToMaybe, randomSelect, nonEmptySetToList, )+import Game.Utility (readMaybe, nullToMaybe, randomSelect, ) import Text.Html((<<), (+++), concatHtml, toHtml) import qualified Text.Html as Html@@ -18,33 +18,39 @@ import qualified Data.List as List import qualified Data.List.HT as ListHT import qualified Data.NonEmpty.Set as NonEmptySet-import qualified Data.Set as Set+import qualified Data.NonEmpty as NonEmpty+import Data.Foldable (fold, foldMap) import Data.NonEmpty ((!:)) import Data.Tuple.HT (mapPair, ) import Data.Maybe.HT (toMaybe, ) -import qualified Control.Monad.Trans.State as State+import qualified Control.Monad.Trans.State as MS import Control.Monad (liftM2, replicateM, ) import qualified System.Random as Rnd labelAnchor :: String -> Html.Html -> Html.Html-labelAnchor ref label =- Html.anchor label Html.! [Html.href ref]+labelAnchor ref label = Html.anchor label Html.! [Html.href ref] +concatMapHtml :: (a -> Html.Html) -> [a] -> Html.Html+concatMapHtml f = concatHtml . map f +maybeSingle :: (a -> b) -> Maybe a -> [b]+maybeSingle f = foldMap (\a -> [f a])++ type Move = (String, MM.Eval)-type Config = (Int, NonEmptySet.T Char, Int, Maybe [Move], Maybe String)+type Config = (Int, NonEmpty.T [] Char, Int, Maybe [Move], Maybe String) evaluation :: MM.Eval -> Html.Html evaluation (MM.Eval rightPlaces rightSymbols) = (Html.table $- Html.tr $ concatHtml $- replicate rightPlaces- ((Html.td << Html.spaceHtml) Html.! [Html.bgcolor Html.black]) ++- replicate rightSymbols- ((Html.td << Html.spaceHtml) Html.! [Html.bgcolor Html.white]))+ Html.tr $+ concatMapHtml+ (\color -> (Html.td << Html.spaceHtml) Html.! [Html.bgcolor color]) $+ replicate rightPlaces Html.black +++ replicate rightSymbols Html.white) Html.! [Html.border 2] state ::@@ -53,45 +59,44 @@ Maybe String -> Html.Html state (width, alphabet, seed, mMoves, mAttempt) mRemaining mCheck =- let moves = maybe [] id mMoves+ let moves = fold mMoves select name options =- (Html.select $ concatHtml $- map (Html.option . toHtml) options)+ (Html.select $ concatMapHtml (Html.option <<) options) Html.! [Html.name name] verify code eval = case mCheck of Nothing -> [] Just check -> let shouldBeEval = MM.evaluate check code- in [if shouldBeEval == eval- then toHtml " "- else toHtml "sollte sein:" +++- Html.spaceHtml +++- evaluation shouldBeEval]+ in if shouldBeEval == eval+ then [toHtml " "]+ else [toHtml "sollte sein: ", evaluation shouldBeEval] won = not (null moves) && case last moves of (_, MM.Eval rightPlaces _) -> rightPlaces == width+ codeTds = map ((Html.! [Html.align "center"]) . Html.td . toHtml) in Html.center $ (Html.! [Html.action "Mastermind"]) $ Html.form $ concatHtml $ [Html.hidden "width" (show width),- Html.hidden "alphabet" (nonEmptySetToList alphabet),+ Html.hidden "alphabet" (NonEmpty.flatten alphabet), Html.hidden "seed" (show seed), Html.hidden "moves" (unwords $ map formatMove moves)] ++- maybe [] (\attempt -> [Html.hidden "attempt" attempt]) mAttempt+ maybeSingle (Html.hidden "attempt") mAttempt ++ [(Html.table $- concatHtml $ map Html.tr $- zipWith (\n row -> Html.th (toHtml (show n ++ ".")) +++ row) [(0::Int)..] $+ concatMapHtml Html.tr $+ zipWith+ (\n row -> (Html.th << (show n ++ ".")) +++ row)+ [(0::Int)..] $ flip map moves (\(code, eval) ->- concatHtml $ map Html.td $- map toHtml code ++- [evaluation eval] ++- verify code eval)+ concatHtml $+ codeTds code +++ map Html.td (evaluation eval : verify code eval)) ++- if won || maybe False (null . CodeSet.flatten) mRemaining+ if won || maybe False CodeSet.null mRemaining then [] else [ maybe@@ -100,15 +105,17 @@ +++ Html.td (Html.submit "" "abschicken")) (\attempt ->- concatHtml $ map Html.td $- map toHtml attempt +++ concatHtml $+ codeTds attempt ++ let numbers = map show [0..width]- in [concatHtml- [select "rightplaces" numbers,+ in [Html.td $ Html.simpleTable [] []+ [[evaluation (MM.Eval 1 0),+ select "rightplaces" numbers, Html.spaceHtml,+ evaluation (MM.Eval 0 1), select "rightsymbols" numbers, Html.spaceHtml,- Html.submit "" "bewerten"]])+ Html.submit "" "bewerten"]]]) mAttempt]) -- Html.! [Html.border 2] ]@@ -137,17 +144,18 @@ (Html.ordList $ take 10 $ CodeSet.flatten remaining)]) ++ (if won- then [Html.br, Html.bold $ Html.toHtml "R\228tsel gel\246st!"]+ then [Html.br, Html.bold << "R\228tsel gel\246st!"] else []) game :: String -> Html.Html game s = case parseQuery s of- Just ((width, alphabet, seed, mMoves, mAttempt), mCheck) ->+ Just ((width, symbols, seed, mMoves, mAttempt), mCheck) -> case (mMoves,mAttempt) of (Just moves, Nothing) ->- let remaining =+ let alphabet = NonEmptySet.fromList symbols+ remaining = CodeSet.compress $ CodeSet.intersections $ CodeSet.cube alphabet width !:@@ -157,44 +165,57 @@ maybe (Nothing, seed) (mapPair (Just, fst . Rnd.random)) $- State.runStateT+ MS.runStateT (MM.mixedRandomizedAttempt width remaining) (Rnd.mkStdGen seed) in state- (width, alphabet, newSeed, Just moves, attempt)+ (width, symbols, newSeed, Just moves, attempt) (Just remaining) mCheck _ -> let code =- State.evalState- (replicateM width- (randomSelect (nonEmptySetToList alphabet)))+ MS.evalState+ (replicateM width $ randomSelect $+ NonEmpty.flatten symbols) (Rnd.mkStdGen seed) in state- (width, alphabet, seed,- Just $ maybe [] id mMoves ++- maybe [] (\attempt -> [(attempt, MM.evaluate code attempt)]) mAttempt,+ (width, symbols, seed,+ Just $+ fold mMoves +++ maybeSingle+ (\attempt -> (attempt, MM.evaluate code attempt))+ mAttempt, Nothing) Nothing mCheck Nothing ->- toHtml $ "Mit dem Spielstand " ++ show s ++ " kann ich nichts anfangen."+ toHtml $+ "Mit dem Spielstand " ++ show s ++ " kann ich nichts anfangen." start :: Int -> Html.Html start seed = toHtml "Es r\228t" +++ Html.simpleTable [] []- (map (\(alphabet,typ) ->- map (\(computerAttempts,player) ->- labelAnchor- ("Mastermind?"++- formatQuery- (4, NonEmptySet.fromList alphabet, seed,- toMaybe computerAttempts [], Nothing))- << ("der "++player++" "++typ++"."))- [(False,"Mensch"),(True,"Computer")])- [('0'!:['1'..'9'], "Zahlen"),('a'!:['b'..'z'], "W\246rter")])- Html.! [Html.border 2]+ (ListHT.outerProduct+ (\(alphabet,typ,widthName) (computerAttempts,player) ->+ toHtml ("der "++player++" "++typ++" mit ")+ ++++ (concatHtml $ List.intersperse (toHtml ", ") $+ map+ (\width ->+ labelAnchor+ ("Mastermind?"+++ formatQuery+ (width, alphabet, seed,+ toMaybe computerAttempts [], Nothing))+ << show width)+ [3..7])+ ++++ toHtml (" "++widthName++"."))+ [('0'!:['1'..'9'], "Zahlen", "Stellen"),+ ('a'!:['b'..'z'], "W\246rter", "Buchstaben")]+ [(False,"Mensch"),(True,"Computer")])+ Html.! [Html.border 2] complete :: Html.Html -> Html.Html@@ -205,15 +226,14 @@ -- need Maybe String in order to distinguish between "?" and "" generate :: Maybe String -> IO Html.Html-generate =- maybe (fmap start Rnd.randomIO) (return . game)+generate = maybe (fmap start Rnd.randomIO) (return . game) formatQuery :: Config -> String formatQuery (width, alphabet, seed, mMoves, mAttempt) = CGI.formEncode $ ("width", show width) :- ("alphabet", nonEmptySetToList alphabet) :+ ("alphabet", NonEmpty.flatten alphabet) : ("seed", show seed) : (case mAttempt of Nothing -> []@@ -231,8 +251,7 @@ parseQuery query = let pairs = CGI.formDecode query in do width <- readMaybe =<< List.lookup "width" pairs- alphabet <-- NonEmptySet.fetch . Set.fromList =<< List.lookup "alphabet" pairs+ alphabet <- NonEmpty.fetch =<< List.lookup "alphabet" pairs seed <- readMaybe =<< List.lookup "seed" pairs mMoves <- maybe (Just Nothing)@@ -258,7 +277,8 @@ case liftM2 (,) mAttempt0 $ liftM2 (,) mRightPlaces mRightSymbols of Just (move, mEval) ->- fmap (\eval -> (Just $ moves0 ++ [(move,eval)], Nothing)) $+ fmap (\eval ->+ (Just $ moves0 ++ [(move,eval)], Nothing)) $ uncurry (liftM2 MM.Eval) mEval Nothing -> Just (Just moves0, mAttempt0) return ((width, alphabet, seed, moves, mAttempt),
− src/Game/Server.hs
@@ -1,60 +0,0 @@-module Main where--import qualified Game.ZeilenSpalten.HTML as ZeilenSpalten-import qualified Game.VierGewinnt.HTML as VierGewinnt-import qualified Game.Mastermind.HTML as Mastermind-import qualified Game.Server.Option as Option--import qualified Network.Shed.Httpd as HTTPd-import Network.URI (uriQuery, uriPath, )--import Text.Html((<<), (+++), )-import qualified Text.Html as Html---headers :: [(String, String)]-headers =- [("Content-Type", "text/html; charset=latin1")]--withQuery :: String -> (Maybe String -> IO HTTPd.Response) -> IO HTTPd.Response-withQuery query action =- case query of- '?':str -> print str >> (action $ Just str)- [] -> action $ Nothing- _ -> return $ HTTPd.Response 400 [] $ "invalid query: " ++ query--main :: IO ()-main = do- opt <- Option.get- HTTPd.initServer (Option.port opt) $ \ req -> do- -- FixMe: should check for HTTP method here- Option.printVerbose opt 1 req- let uri = HTTPd.reqURI req- Option.printVerbose opt 2 $ uriQuery uri- Option.printVerbose opt 2 $ HTTPd.queryToArguments $ uriQuery uri- case uriPath uri of- "/" ->- return $ HTTPd.Response 200 headers $- Html.renderHtml $- Html.header (Html.thetitle << "Web games") +++- Html.body (Html.unordList (map- (\(path,name) -> (Html.anchor << name) Html.! [Html.href path]) $- ("VierGewinnt", "Vier gewinnt") :- ("ZeilenSpalten", "Zeilen und Spalten") :- ("Mastermind", "Mastermind") :- []))- "/VierGewinnt" ->- withQuery (uriQuery uri) $ \query ->- return $ HTTPd.Response 200 headers $ Html.renderHtml $- VierGewinnt.komplett $ VierGewinnt.erzeuge query- "/ZeilenSpalten" ->- withQuery (uriQuery uri) $ \query ->- fmap (HTTPd.Response 200 headers . Html.renderHtml .- ZeilenSpalten.komplett) $ ZeilenSpalten.erzeuge query- "/Mastermind" ->- withQuery (uriQuery uri) $ \query ->- fmap (HTTPd.Response 200 headers . Html.renderHtml .- Mastermind.complete) $ Mastermind.generate query- path ->- return $ HTTPd.Response 404 [] $ "unknown game: " ++ path- return ()
− src/Game/Server/Option.hs
@@ -1,92 +0,0 @@-module Game.Server.Option (- T(..),- get,- printVerbose,- ) where--import System.Console.GetOpt- (getOpt, ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, )-import System.Environment (getArgs, getProgName, )-import System.Exit (exitSuccess, exitFailure, )-import qualified System.IO as IO--import Control.Monad (when, )---data T =- Cons {- verbosity :: Int,- port :: Int- }- deriving (Show)---deflt :: T-deflt =- Cons {- verbosity = 0,- port = 8080- -- other options might control maximum values for some dimensions in the games- }---exitFailureMsg :: String -> IO a-exitFailureMsg msg =- IO.hPutStrLn IO.stderr msg >> exitFailure--parseNumber ::- (Read a) =>- String -> (a -> Bool) -> String -> String -> IO a-parseNumber name constraint constraintName str =- case reads str of- [(n, "")] ->- if constraint n- then return n- else exitFailureMsg $ name ++ " must be " ++ constraintName- _ ->- exitFailureMsg $ name ++ " must be a number, but is '" ++ str ++ "'"---printVerbose :: (Show a) => T -> Int -> a -> IO ()-printVerbose opt verb a =- when (verb <= verbosity opt) $ print a---{--Guide for common Linux/Unix command-line options:- http://www.faqs.org/docs/artu/ch10s05.html--}-description :: [OptDescr (T -> IO T)]-description =- Option ['h'] ["help"]- (NoArg $ \ _flags -> do- programName <- getProgName- putStrLn- (usageInfo ("Usage: " ++ programName ++ " [OPTIONS]") description)- exitSuccess)- "show options" :- Option ['v'] ["verbose"]- (flip ReqArg "LEVEL" $ \str flags ->- fmap (\verb -> flags{verbosity = fromInteger verb}) $- parseNumber "verbosity" (\n -> 0<=n && n<=2) "from the range from 0 to 2" str)- "level of verbosity" :- Option ['p'] ["port"]- (flip ReqArg "NUMBER" $ \str flags ->- fmap (\p -> flags{port = fromInteger p}) $- parseNumber "port" (\n -> 0<n && n<0x10000) "a positive 16-bit number" str)- "port number" :- []---get :: IO T-get = do- argv <- getArgs- let (opts, files, errors) = getOpt RequireOrder description argv- when (not $ null errors) $- exitFailureMsg (init (concat errors))- when (not $ null files) $- exitFailureMsg $- "Do not know what to do with arguments " ++ show files- foldl (>>=)- (return deflt)- opts
− src/Game/Test.hs
@@ -1,15 +0,0 @@-module Main where--import qualified Game.Test.Mastermind as MM---prefix :: String -> [(String, IO ())] -> [(String, IO ())]-prefix msg =- map (\(str,test) -> (msg ++ "." ++ str, test))--main :: IO ()-main =- mapM_ (\(msg,io) -> putStr (msg++": ") >> io) $- concat $- prefix "Game.Mastermind" MM.tests :- []
− src/Game/Test/Mastermind.hs
@@ -1,188 +0,0 @@-module Game.Test.Mastermind (tests, ) where--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 as MM--import Control.Monad (liftM2, )-import Control.Applicative ((<$>), )--import qualified Data.NonEmpty.Set as NonEmptySet-import qualified Data.Traversable as Trav-import qualified Data.Set as Set-import Data.NonEmpty ((!:))--import qualified Test.QuickCheck as QC-import Test.QuickCheck (Property, Arbitrary(arbitrary), quickCheck, (==>), )---alphabet :: Set.Set Int-alphabet = NonEmptySet.flatten neAlphabet--neAlphabet :: NonEmptySet.T Int-neAlphabet = NonEmptySet.fromList $ 0!:[1..9]---newtype Code = Code [Int]- deriving (Show)---genElement :: QC.Gen Int-genElement = QC.choose (0,9)---- can we get it working with empty lists, too?-genCode :: Int -> QC.Gen Code-genCode width =- fmap (Code . take width) $ QC.listOf1 genElement--- fmap (Code . take width) (QC.listOf genElement)--instance Arbitrary Code where- arbitrary = genCode 5---data CodePair = CodePair [Int] [Int]- deriving (Show)--genCodePair :: Int -> QC.Gen CodePair-genCodePair width =- liftM2- (\(Code xs) (Code ys) ->- uncurry CodePair $ unzip $ zip xs ys)- (genCode width) (genCode width)--instance Arbitrary CodePair where- arbitrary = genCodePair 5---matchingMember :: CodePair -> Bool-matchingMember (CodePair secret attempt) =- CodeSetTree.member secret $- MM.matching alphabet attempt (MM.evaluate secret attempt)--genEval :: Int -> QC.Gen MM.Eval-genEval size = do- total <- QC.frequency $ map (\k -> (k+1, return k)) [1 .. size]- rightPlaces <- QC.choose (0,total)- return $ MM.Eval rightPlaces (total - rightPlaces)--forAllEval :: QC.Testable prop => [a] -> (MM.Eval -> prop) -> Property-forAllEval code = QC.forAll (genEval (length code))--matchingNotMember :: CodePair -> Property-matchingNotMember (CodePair secret attempt) =- forAllEval secret $ \eval ->- (eval == MM.evaluate secret attempt)- ==- (CodeSetTree.member secret $ MM.matching alphabet attempt eval)--matchingDisjoint :: Code -> Property-matchingDisjoint (Code attempt) =- forAllEval attempt $ \eval0 ->- forAllEval attempt $ \eval1 ->- let matching0 = MM.matching alphabet attempt eval0- matching1 = MM.matching alphabet attempt eval1- in eval0 == eval1 ||- CodeSetTree.null (CodeSetTree.intersection matching0 matching1)--evaluateCommutative :: CodePair -> Bool-evaluateCommutative (CodePair secret attempt) =- MM.evaluate secret attempt- ==- MM.evaluate attempt secret--evaluateMatching :: Code -> Property-evaluateMatching (Code attempt) =- forAllEval attempt $ \eval ->- all ((eval ==) . MM.evaluate attempt) $- take 100 $- CodeSet.flatten $- (MM.matching alphabet attempt eval :: CodeSetTree.T Int)--{--A more precise test would be to check-that for different numbers of rightPlace and rightSymbol-the codesets are disjoint-and their union is the set of all possible codes.-To this end we need a union with simplification or a subset test.--}-partitionSizes :: Code -> Bool-partitionSizes (Code attempt) =- fromIntegral (Set.size alphabet) ^ length attempt- ==- sum (map snd (MM.partitionSizes alphabet attempt))---selectFlatten :: Code -> Property-selectFlatten (Code attempt) =- forAllEval attempt $ \eval ->- let set :: CodeSetTree.T Int- set = MM.matching alphabet attempt eval- in map (CodeSet.select set) [0 .. min 100 (CodeSet.size set) - 1]- ==- take 100 (CodeSet.flatten set)---genFixedLengthCodes :: Int -> QC.Gen [[Int]]-genFixedLengthCodes width = QC.listOf1 $ QC.vectorOf width genElement--bestSeparatingCode :: Property-bestSeparatingCode =- QC.forAll (genCodePair 4) $ \(CodePair base0 base1) ->- forAllEval base0 $ \eval0 ->- forAllEval base1 $ \eval1 -> do- let width = length base0- set =- CodeSet.intersection- (MM.matching alphabet base0 eval0)- (MM.matching alphabet base1 eval1)- not (CodeSet.null set) ==>- QC.forAll (fmap (take 10) $ genFixedLengthCodes width) $- MM.propBestSeparatingCode width (set :: CodeSetTree.T Int)--intersections :: Property-intersections =- QC.forAll (genCode 4) $ \(Code code) ->- QC.forAll (fmap (take 10) $ genFixedLengthCodes (length code)) $ \codes ->- QC.forAll (Trav.mapM (\x -> (,) x <$> genEval (length code)) (code!:codes)) $- CodeSetTree.propIntersections . fmap (uncurry $ MM.matching alphabet)------ should also work, when selecting any code from the set of matching codes-solve :: Code -> Bool-solve (Code secret) =- let recourse remain =- case CodeSet.flatten remain of- [] -> False- [attempt] -> secret == attempt- attempt:_ ->- recourse $ CodeSet.intersection remain $- MM.matching alphabet attempt $ MM.evaluate secret attempt- in recourse (CodeSet.cube neAlphabet (length secret) :: CodeSetTree.T Int)---{--Other possible tests:--the products in a set produced by 'MM.matching' must be disjoint.--set laws for the two set implementations,- such as distributivity of union and intersection--check member against intersection with singleton--}--tests :: [(String, IO ())]-tests =- ("matchingMember", quickCheck matchingMember) :- ("matchingNotMember", quickCheck matchingNotMember) :- ("matchingDisjoint", quickCheck matchingDisjoint) :- ("evaluateCommutative", quickCheck evaluateCommutative) :- ("evaluateMatching", quickCheck evaluateMatching) :- ("partitionSizes", quickCheck partitionSizes) :- ("selectFlatten", quickCheck selectFlatten) :- ("bestSeparatingCode", quickCheck bestSeparatingCode) :- ("intersections", quickCheck intersections) :- ("solve", quickCheck solve) :- []
src/Game/Utility.hs view
@@ -20,6 +20,7 @@ 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)
+ test/Test.hs view
@@ -0,0 +1,15 @@+module Main where++import qualified Test.Mastermind as MM+++prefix :: String -> [(String, IO ())] -> [(String, IO ())]+prefix msg =+ map (\(str,test) -> (msg ++ "." ++ str, test))++main :: IO ()+main =+ mapM_ (\(msg,io) -> putStr (msg++": ") >> io) $+ concat $+ prefix "Game.Mastermind" MM.tests :+ []
+ test/Test/Mastermind.hs view
@@ -0,0 +1,191 @@+module Test.Mastermind (tests) where++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 as MM++import Control.Monad (liftM2, )+import Control.Applicative ((<$>), )++import qualified Data.NonEmpty.Set as NonEmptySet+import qualified Data.Traversable as Trav+import qualified Data.Set as Set+import Data.NonEmpty ((!:))++import qualified Test.QuickCheck as QC+import Test.QuickCheck (Property, Arbitrary(arbitrary), quickCheck, (==>), )+++alphabet :: Set.Set Int+alphabet = NonEmptySet.flatten neAlphabet++neAlphabet :: NonEmptySet.T Int+neAlphabet = NonEmptySet.fromList $ 0!:[1..9]+++newtype Code = Code [Int]+ deriving (Show)+++genElement :: QC.Gen Int+genElement = QC.choose (0,9)++-- can we get it working with empty lists, too?+genCode :: Int -> QC.Gen Code+genCode width =+ fmap (Code . take width) $ QC.listOf1 genElement+-- fmap (Code . take width) (QC.listOf genElement)++instance Arbitrary Code where+ arbitrary = genCode 5+++data CodePair = CodePair [Int] [Int]+ deriving (Show)++genCodePair :: Int -> QC.Gen CodePair+genCodePair width =+ liftM2+ (\(Code xs) (Code ys) ->+ uncurry CodePair $ unzip $ zip xs ys)+ (genCode width) (genCode width)++instance Arbitrary CodePair where+ arbitrary = genCodePair 5+++matchingMember :: CodePair -> Bool+matchingMember (CodePair secret attempt) =+ CodeSetTree.member secret $+ MM.matching alphabet attempt (MM.evaluate secret attempt)++genEval :: Int -> QC.Gen MM.Eval+genEval size = do+ total <- QC.frequency $ map (\k -> (k+1, return k)) [1 .. size]+ rightPlaces <- QC.choose (0,total)+ return $ MM.Eval rightPlaces (total - rightPlaces)++forAllEval :: QC.Testable prop => [a] -> (MM.Eval -> prop) -> Property+forAllEval code = QC.forAll (genEval (length code))++matchingNotMember :: CodePair -> Property+matchingNotMember (CodePair secret attempt) =+ forAllEval secret $ \eval ->+ (eval == MM.evaluate secret attempt)+ ==+ (CodeSetTree.member secret $ MM.matching alphabet attempt eval)++matchingDisjoint :: Code -> Property+matchingDisjoint (Code attempt) =+ forAllEval attempt $ \eval0 ->+ forAllEval attempt $ \eval1 ->+ let matching0 = MM.matching alphabet attempt eval0+ matching1 = MM.matching alphabet attempt eval1+ in eval0 == eval1 ||+ CodeSetTree.null (CodeSetTree.intersection matching0 matching1)++evaluateCommutative :: CodePair -> Bool+evaluateCommutative (CodePair secret attempt) =+ MM.evaluate secret attempt+ ==+ MM.evaluate attempt secret+++type CodeSetInt = CodeSetTree.T Int++evaluateMatching :: Code -> Property+evaluateMatching (Code attempt) =+ forAllEval attempt $ \eval ->+ all ((eval ==) . MM.evaluate attempt) $+ take 100 $+ CodeSet.flatten $+ (MM.matching alphabet attempt eval :: CodeSetInt)++{-+A more precise test would be to check+that for different numbers of rightPlace and rightSymbol+the codesets are disjoint+and their union is the set of all possible codes.+To this end we need a union with simplification or a subset test.+-}+partitionSizes :: Code -> Bool+partitionSizes (Code attempt) =+ fromIntegral (Set.size alphabet) ^ length attempt+ ==+ sum (map snd (MM.partitionSizes alphabet attempt))+++selectFlatten :: Code -> Property+selectFlatten (Code attempt) =+ forAllEval attempt $ \eval ->+ let set :: CodeSetInt+ set = MM.matching alphabet attempt eval+ in map (CodeSet.select set) [0 .. min 100 (CodeSet.size set) - 1]+ ==+ take 100 (CodeSet.flatten set)+++genFixedLengthCodes :: Int -> QC.Gen [[Int]]+genFixedLengthCodes width = QC.listOf1 $ QC.vectorOf width genElement++bestSeparatingCode :: Property+bestSeparatingCode =+ QC.forAll (genCodePair 4) $ \(CodePair base0 base1) ->+ forAllEval base0 $ \eval0 ->+ forAllEval base1 $ \eval1 -> do+ let width = length base0+ set =+ CodeSet.intersection+ (MM.matching alphabet base0 eval0)+ (MM.matching alphabet base1 eval1)+ not (CodeSet.null set) ==>+ QC.forAll (fmap (take 10) $ genFixedLengthCodes width) $+ MM.propBestSeparatingCode width (set :: CodeSetInt)++intersections :: Property+intersections =+ QC.forAll (genCode 4) $ \(Code code) ->+ QC.forAll (fmap (take 10) $ genFixedLengthCodes (length code)) $ \codes ->+ QC.forAll (Trav.mapM (\x -> (,) x <$> genEval (length code)) (code!:codes)) $+ CodeSetTree.propIntersections . fmap (uncurry $ MM.matching alphabet)++++-- should also work, when selecting any code from the set of matching codes+solve :: Code -> Bool+solve (Code secret) =+ let recourse remain =+ case CodeSet.flatten remain of+ [] -> False+ [attempt] -> secret == attempt+ attempt:_ ->+ recourse $ CodeSet.intersection remain $+ MM.matching alphabet attempt $ MM.evaluate secret attempt+ in recourse (CodeSet.cube neAlphabet (length secret) :: CodeSetInt)+++{-+Other possible tests:++the products in a set produced by 'MM.matching' must be disjoint.++set laws for the two set implementations,+ such as distributivity of union and intersection++check member against intersection with singleton+-}++tests :: [(String, IO ())]+tests =+ ("matchingMember", quickCheck matchingMember) :+ ("matchingNotMember", quickCheck matchingNotMember) :+ ("matchingDisjoint", quickCheck matchingDisjoint) :+ ("evaluateCommutative", quickCheck evaluateCommutative) :+ ("evaluateMatching", quickCheck evaluateMatching) :+ ("partitionSizes", quickCheck partitionSizes) :+ ("selectFlatten", quickCheck selectFlatten) :+ ("bestSeparatingCode", quickCheck bestSeparatingCode) :+ ("intersections", quickCheck intersections) :+ ("solve", quickCheck solve) :+ []