board-games 0.1 → 0.1.0.1

raw patch · 5 files changed

+169/−9 lines, 5 filesdep ~arraydep ~transformers

Dependency ranges changed: array, transformers

Files

board-games.cabal +7/−7
src/Game/Mastermind.hs +2/−2
src/Game/Server.hs +1/−0
src/Game/Test.hs +15/−0
src/Game/Test/Mastermind.hs +144/−0

board-games.cabal view

@@ -1,5 +1,5 @@ Name:             board-games-Version:          0.1+Version:          0.1.0.1 License:          GPL License-File:     LICENSE Author:           Henning Thielemann <haskell@henning-thielemann.de>@@ -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

src/Game/Mastermind.hs view

@@ -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  {-

src/Game/Server.hs view

@@ -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

+ src/Game/Test.hs view

@@ -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 :+      []

+ src/Game/Test/Mastermind.hs view

@@ -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) :+   []