diff --git a/board-games.cabal b/board-games.cabal --- a/board-games.cabal +++ b/board-games.cabal @@ -1,5 +1,5 @@ Name: board-games -Version: 0.1 +Version: 0.1.0.1 License: GPL License-File: LICENSE Author: Henning Thielemann @@ -46,12 +46,12 @@ html >=1.0 && <1.1, cgi >=3001.1 && <3001.2, utility-ht >=0.0.3 && <0.1, - transformers >=0.2.2 && <0.3 + transformers >=0.2.2 && <0.4 If flag(splitBase) Build-Depends: containers >=0.2 && <0.5, random >=1.0 && <1.1, - array >=0.1 && <0.4, + array >=0.1 && <0.5, base >= 2 && <5 Else Build-Depends: base >= 1.0 && < 2 @@ -86,10 +86,10 @@ html >=1.0 && <1.1, cgi >=3001.1 && <3001.2, utility-ht >=0.0.3 && <0.1, - transformers >=0.2.2 && <0.3, + transformers >=0.2.2 && <0.4, containers >=0.2 && <0.5, random >=1.0 && <1.1, - array >=0.1 && <0.4, + array >=0.1 && <0.5, base >= 2 && <5 Else Buildable: False @@ -104,8 +104,8 @@ Build-Depends: QuickCheck >1.2 && <3.0, utility-ht >=0.0.3 && <0.1, - transformers >=0.2.2 && <0.3, + transformers >=0.2.2 && <0.4, containers >=0.2 && <0.5, random >=1.0 && <1.1, - array >=0.1 && <0.4, + array >=0.1 && <0.5, base >= 2 && <5 diff --git a/src/Game/Mastermind.hs b/src/Game/Mastermind.hs --- a/src/Game/Mastermind.hs +++ b/src/Game/Mastermind.hs @@ -9,7 +9,7 @@ import qualified Data.Map as Map import qualified Data.Set as Set -import Data.List.HT (partitionMaybe, partition, ) +import Data.List.HT (partition, ) import Data.Tuple.HT (mapPair, ) import Data.Maybe.HT (toMaybe, ) import Data.Maybe (listToMaybe, ) @@ -36,7 +36,7 @@ sum . Map.elems . uncurry (Map.intersectionWith min) . mapPair (histogram,histogram) . unzip) $ - partitionMaybe (\(x,y) -> toMaybe (x==y) ()) $ + partition (uncurry (==)) $ zip code attempt {- diff --git a/src/Game/Server.hs b/src/Game/Server.hs --- a/src/Game/Server.hs +++ b/src/Game/Server.hs @@ -27,6 +27,7 @@ main = do opt <- Option.get HTTPd.initServer (Option.port opt) $ \ req -> do + -- should check for HTTP method here Option.printVerbose opt 1 req let uri = HTTPd.reqURI req Option.printVerbose opt 2 $ uriQuery uri diff --git a/src/Game/Test.hs b/src/Game/Test.hs new file mode 100644 --- /dev/null +++ b/src/Game/Test.hs @@ -0,0 +1,15 @@ +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 : + [] diff --git a/src/Game/Test/Mastermind.hs b/src/Game/Test/Mastermind.hs new file mode 100644 --- /dev/null +++ b/src/Game/Test/Mastermind.hs @@ -0,0 +1,144 @@ +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 qualified Data.Set as Set +import Control.Monad (liftM2, ) + +import Test.QuickCheck (Arbitrary(arbitrary), quickCheck, ) + + +alphabet :: Set.Set Int +alphabet = Set.fromList [0..9] + + +newtype Code = Code [Int] + deriving (Show) + +-- can we get it working with empty lists, too? +instance Arbitrary Code where + arbitrary = + fmap (Code . take 5 . map (flip mod 10)) $ + liftM2 (:) arbitrary arbitrary +-- fmap (Code . take 5 . map (flip mod 10)) arbitrary + + +data CodePair = CodePair [Int] [Int] + deriving (Show) + +instance Arbitrary CodePair where + arbitrary = + liftM2 + (\(Code xs) (Code ys) -> + uncurry CodePair $ unzip $ zip xs ys) + arbitrary arbitrary + + +remainingMember :: CodePair -> Bool +remainingMember (CodePair secret attempt) = + CodeSetTree.member secret $ + MM.remaining alphabet attempt (MM.evaluate secret attempt) + +evalFromInt :: Int -> Int -> MM.Eval +evalFromInt size ident = + let (rem0, x) = divMod ident size + y = mod rem0 size + rightPlaces = min x y + rightSymbols = max x y - rightPlaces + in MM.Eval rightPlaces rightSymbols + +remainingNotMember :: Int -> CodePair -> Bool +remainingNotMember evalIdent (CodePair secret attempt) = + let eval = evalFromInt (length secret) evalIdent + in (eval == MM.evaluate secret attempt) + == + (CodeSetTree.member secret $ + MM.remaining alphabet attempt eval) + +remainingDisjoint :: Int -> Int -> Code -> Bool +remainingDisjoint evalIdent0 evalIdent1 (Code attempt) = + let eval0 = evalFromInt (length attempt) evalIdent0 + eval1 = evalFromInt (length attempt) evalIdent1 + remaining0 = MM.remaining alphabet attempt eval0 + remaining1 = MM.remaining alphabet attempt eval1 + in eval0 == eval1 || + CodeSetTree.null + (CodeSetTree.intersection remaining0 remaining1) + +evaluateCommutative :: CodePair -> Bool +evaluateCommutative (CodePair secret attempt) = + MM.evaluate secret attempt + == + MM.evaluate attempt secret + +evaluateRemaining :: Int -> Code -> Bool +evaluateRemaining evalIdent (Code attempt) = + let eval = evalFromInt (length attempt) evalIdent + in all ((eval ==) . MM.evaluate attempt) $ + take 100 $ + CodeSet.flatten $ + (MM.remaining 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 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 :: Int -> Code -> Bool +selectFlatten evalIdent (Code attempt) = + let eval = evalFromInt (length attempt) evalIdent + set :: CodeSetTree.T Int + set = MM.remaining alphabet attempt eval + in map (CodeSet.select set) [0 .. min 100 (CodeSet.size set) - 1] + == + take 100 (CodeSet.flatten set) + + +-- should also work, when selecting any code from the set of remaining possibilities +solve :: Code -> Bool +solve (Code secret) = + let recourse remain = + case CodeSet.flatten remain of + [] -> False + [attempt] -> secret == attempt + attempt:_ -> + recourse $ CodeSet.intersection remain $ + MM.remaining alphabet attempt $ MM.evaluate secret attempt + in recourse $ + (CodeSet.cube alphabet (length secret) :: CodeSetTree.T Int) + + +{- +Other possible tests: + +the products in a set produced by 'remaining' 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 = + ("remainingMember", quickCheck remainingMember) : + ("remainingNotMember", quickCheck remainingNotMember) : + ("remainingDisjoint", quickCheck remainingDisjoint) : + ("evaluateCommutative", quickCheck evaluateCommutative) : + ("evaluateRemaining", quickCheck evaluateRemaining) : + ("partitionSizes", quickCheck partitionSizes) : + ("selectFlatten", quickCheck selectFlatten) : + ("solve", quickCheck solve) : + []