packages feed

board-games 0.3 → 0.4

raw patch · 19 files changed

+1293/−234 lines, 19 filesdep +boxesdep +combinatorialdep +doctest-exitcode-stdiodep ~containersdep ~criteriondep ~enummapset

Dependencies added: boxes, combinatorial, doctest-exitcode-stdio, doctest-lib, explicit-exception, haha, semigroups, shell-utility

Dependency ranges changed: containers, criterion, enummapset, network-uri, random, transformers

Files

Changes.md view
@@ -1,5 +1,9 @@ # Change log for the `board-games` package +## 0.4++ * `Labyrinth`: New game "Das verrückte Labyrinth".+ ## 0.3   * `Mastermind.CodeSet`:
Makefile view
@@ -1,12 +1,36 @@+FLATPAK = $$FLATPAKBUILD+ ghci: 	ghci -Wall -i:src src/Game/Mastermind.hs -run-test:+run-test:	update-test 	runhaskell Setup configure --user \ 	  --enable-tests --enable-benchmarks -fbuildExamples 	runhaskell Setup build 	runhaskell Setup haddock 	./dist/build/board-games-test/board-games-test +update-test:+	doctest-extract-0.1 -i src/ -i private/ -o test/ --executable-main=Test.hs $$(cat test-module.list)++ criterion.html:	./dist/build/board-games-benchmark/board-games-benchmark 	$< --output=$@ $(patsubst %.html, %.csv, --csv=$@)+++dist-newstyle/cache/plan.json:+	cabal new-build --dry-run --disable-benchmarks --disable-tests++flatpak.json:	flatpak.cabal.json dist-newstyle/cache/plan.json+	cabal-flatpak --cabal-install --arch x86_64 --arch i386 $< $@++repo-%:	flatpak.json+	flatpak-builder --force-clean --arch=$* --repo=$(FLATPAK)/repository \+	  --state-dir=$(FLATPAK)/builder/ $(FLATPAK)/build/games $<+	touch $@++board-games.%.flatpak:	repo-%+	flatpak build-bundle --arch=$* $(FLATPAK)/repository $@ com.github.thielema.board-games \+	  --runtime-repo=https://flathub.org/repo/flathub.flatpakrepo++flatpak-all:	board-games.x86_64.flatpak board-games.i386.flatpak
board-games.cabal view
@@ -1,5 +1,5 @@ Name:             board-games-Version:          0.3+Version:          0.4 License:          GPL License-File:     LICENSE Author:           Henning Thielemann <haskell@henning-thielemann.de>@@ -9,7 +9,8 @@ Synopsis:         Three games for inclusion in a web server Description:   Three games that might run as CGI script in a web server:-  Connect Four, Rows&Columns, Mastermind+  Connect Four, Rows&Columns, Mastermind.+  Additionally there is a CLI-only game: Das verrueckte Labyrinth.   .   Check running versions at   <http://www.henning-thielemann.de/VierGewinnt> and@@ -29,18 +30,21 @@   Currently the games use German texts.   I wanted to use gettext, but this is not thread-safe. Tested-With:       GHC==6.4.1, GHC==6.8.2, GHC==6.12.3+Tested-With:       GHC==8.6.5+Tested-With:       GHC==9.2.5, GHC==9.4.4 Cabal-Version:     1.14 Build-Type:        Simple Extra-Source-Files:   Makefile   Changes.md+  test-module.list  Source-Repository head   type:     darcs   location: http://code.haskell.org/~thielema/games/  Source-Repository this-  tag:      0.3+  tag:      0.4   type:     darcs   location: http://code.haskell.org/~thielema/games/ @@ -53,16 +57,21 @@ Library   Build-Depends:     html >=1.0 && <1.1,+    boxes >=0.1.5 && <0.2,+    haha >=0.3.1 && <0.4,     cgi >=3001.1 && <3002,     non-empty >=0.2 && <0.4,+    explicit-exception >=0.1.7 && <0.3,+    semigroups >=0.18 && <0.21,     utility-ht >=0.0.3 && <0.1,-    transformers >=0.2.2 && <0.6,-    enummapset >=0.1 && <0.7,+    combinatorial >=0.1 && <0.2,+    transformers >=0.2.2 && <0.7,+    enummapset >=0.1 && <0.8,     QuickCheck >2.0 && <3.0   If flag(splitBase)     Build-Depends:       containers >=0.2 && <0.7,-      random >=1.0 && <1.2,+      random >=1.0 && <1.3,       array >=0.1 && <0.6,       base >= 2 && <5   Else@@ -84,6 +93,7 @@     Game.Mastermind.CodeSet.Union     Game.Mastermind.CodeSet.Tree     Game.Mastermind.NonEmptyEnumSet+    Game.Labyrinth   Other-Modules:     Game.Utility @@ -97,9 +107,10 @@     Build-Depends:       board-games,       httpd-shed >=0.4 && <0.5,-      network-uri >=2.6 && <2.7,+      network-uri >=2.6 && <2.8,       html,       cgi,+      shell-utility >=0.0 && <0.2,       non-empty,       utility-ht,       transformers,@@ -117,10 +128,15 @@   Hs-Source-Dirs:   test, private   Main-Is:          Test.hs   Other-Modules:+    Test.Game.Labyrinth+    Test.Game.Utility+    Test.Game.Mastermind     Test.Mastermind     Game.Utility   Build-Depends:     board-games,+    doctest-exitcode-stdio >=0.0 && <0.1,+    doctest-lib >=0.1 && <0.2,     QuickCheck,     non-empty >=0.3.1,     utility-ht,@@ -159,7 +175,7 @@   Main-Is:          MastermindSpeed.hs   Build-Depends:     board-games,-    criterion >=0.6 && <1.6,+    criterion >=0.6 && <1.7,     enummapset,     containers,     non-empty,
demo/Server.hs view
@@ -1,6 +1,7 @@ module Main where  import qualified Server.Option as Option+import qualified Shell.Utility.Verbosity as Verbosity  import qualified Game.ZeilenSpalten.HTML as ZeilenSpalten import qualified Game.VierGewinnt.HTML as VierGewinnt@@ -29,10 +30,11 @@   opt <- Option.get   HTTPd.initServer (Option.port opt) $ \ req -> do     -- FixMe: should check for HTTP method here-    Option.printVerbose opt 1 req+    Option.printVerbose opt Verbosity.verbose req     let uri = HTTPd.reqURI req-    Option.printVerbose opt 2 $ uriQuery uri-    Option.printVerbose opt 2 $ HTTPd.queryToArguments $ uriQuery uri+    Option.printVerbose opt Verbosity.deafening $ uriQuery uri+    Option.printVerbose opt Verbosity.deafening $+       HTTPd.queryToArguments $ uriQuery uri     case uriPath uri of        "/" ->           return $ HTTPd.Response 200 headers $
demo/Server/Option.hs view
@@ -4,18 +4,22 @@    printVerbose,    ) where +import qualified Shell.Utility.Verbosity as Verbosity+import Shell.Utility.Verbosity (Verbosity)+import Shell.Utility.ParseArgument (parseNumber)+import Shell.Utility.Exit (exitFailureMsg)+ 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 System.Exit (exitSuccess, )  import Control.Monad (when, )   data T =    Cons {-      verbosity :: Int,+      verbosity :: Verbosity,       port :: Int    }    deriving (Show)@@ -24,30 +28,13 @@ deflt :: T deflt =    Cons {-      verbosity = 0,+      verbosity = Verbosity.normal,       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 :: (Show a) => T -> Verbosity -> a -> IO () printVerbose opt verb a =    when (verb <= verbosity opt) $ print a @@ -67,8 +54,7 @@       "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)+         fmap (\verb -> flags{verbosity = verb}) $ Verbosity.parse str)       "level of verbosity" :    Option ['p'] ["port"]       (flip ReqArg "NUMBER" $ \str flags ->
private/Game/Utility.hs view
@@ -14,18 +14,16 @@ import qualified Test.QuickCheck as QC  -readMaybe :: (Read a) => String -> Maybe a-readMaybe str =-   case reads str of-      [(a,"")] -> Just a-      _ -> Nothing+{- $setup+>>> import Game.Utility (Choice, mergeChoice, noChoice)+-} + 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)@@ -56,6 +54,11 @@ noChoice = Choice EnumMap.empty 0  -- it is hard to test whether fullEval absorbs+{- |+prop> \a -> a == mergeChoice noChoice (a :: Choice Char)+prop> \a -> a == mergeChoice a (noChoice :: Choice Char)+prop> \a b -> mergeChoice a b == mergeChoice b (a :: Choice Char)+-} mergeChoice :: (Enum a) => Choice a -> Choice a -> Choice a mergeChoice (Choice symbolsA countA) (Choice symbolsB countB) =    Choice@@ -63,3 +66,24 @@       (countA + countB          - min (min countA countB)                (Fold.sum (EnumMap.intersectionWith min symbolsA symbolsB)))++{-+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)
+ src/Game/Labyrinth.hs view
@@ -0,0 +1,948 @@+module Game.Labyrinth where++import qualified System.Random as Rnd+import Game.Utility (randomSelect)++import qualified Graphics.Ascii.Haha.Terminal as ANSI+import qualified Text.PrettyPrint.Boxes as Box+import Text.PrettyPrint.Boxes (Box)+import Text.Printf (printf)++import qualified Test.QuickCheck as QC++import qualified Control.Monad.Exception.Synchronous as ME+import qualified Control.Monad.Trans.State as MS+import qualified Control.Applicative.HT as App+import qualified Control.Functor.HT as FuncHT+import Control.Monad (mfilter)+import Control.Applicative (Applicative, pure, (<*>), (<$>))++import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold+import qualified Data.Monoid.HT as Mn+import qualified Data.NonEmpty.Class as NonEmptyC+import qualified Data.NonEmpty as NonEmpty+import qualified Data.List.Match as Match+import qualified Data.List.HT as ListHT+import qualified Data.List as List+import qualified Data.EnumMap as EnumMap+import qualified Data.EnumSet as EnumSet+import qualified Data.Map as Map+import qualified Data.Sequence as Seq+import qualified Data.Bits as Bits+import qualified Data.Char as Char+import Data.EnumMap (EnumMap)+import Data.EnumSet (EnumSet)+import Data.Map (Map)+import Data.Sequence (Seq)+import Data.Bits ((.&.), (.|.))+import Data.Word (Word64)+import Data.Traversable (Traversable, sequenceA)+import Data.Foldable (Foldable, foldMap)+import Data.NonEmpty ((!:))+import Data.List (zipWith4)+import Data.Monoid (Monoid, mconcat, mappend, mempty)+import Data.Semigroup (Semigroup, (<>))+import Data.Tuple.HT (mapPair, mapFst, mapSnd)+import Data.Ord.HT (comparing)+++{- $setup+>>> import qualified Game.Labyrinth as Labyrinth+-}++newtype Board = Board Word64+   deriving (Eq)++instance Show Board where+   showsPrec p (Board bits) =+      showParen (p>=10) $+         showString "Board " . showString (printf "0x%016x" bits)++instance Semigroup Board where+   Board x <> Board y = Board (x.|.y)++instance Monoid Board where+   mempty = Board 0+   mappend = (<>)++instance QC.Arbitrary Board where+   arbitrary = Board . (boardMask .&.) <$> QC.arbitrary+++data Coord = C0 | C1 | C2 | C3 | C4 | C5 | C6+   deriving (Eq, Ord, Enum, Bounded, Show)++instance QC.Arbitrary Coord where+   arbitrary = QC.arbitraryBoundedEnum++boardIndex :: (Coord,Coord) -> Int+boardIndex (row,column) = fromEnum row * 8 + fromEnum column++isCellFixed :: (Coord,Coord) -> Bool+isCellFixed (row,column) = even (fromEnum row) && even (fromEnum column)++boardGet :: Board -> (Coord,Coord) -> Bool+boardGet (Board bits) pos = Bits.testBit bits $ boardIndex pos++boardSet :: Bool -> (Coord,Coord) -> Board+boardSet b pos = Board $ fromIntegral (fromEnum b) `Bits.shiftL` boardIndex pos++singleCell :: (Coord,Coord) -> Board+singleCell = Board . Bits.bit . boardIndex++listsFromBoard :: Board -> [[Bool]]+listsFromBoard board =+   ListHT.outerProduct (curry $ boardGet board) allEnums allEnums++allEnums :: (Enum a, Bounded a) => [a]+allEnums = [minBound .. maxBound]++rowMask, columnMask, boardMask :: Word64+rowMask = 0x7F+columnMask = 0x1010101010101+boardMask = rowMask*columnMask++rowKMask, columnKMask :: Coord -> Word64+rowKMask pos = rowMask `Bits.shiftL` (8 * fromEnum pos)+columnKMask pos = columnMask `Bits.shiftL` fromEnum pos++infixl 7 .-.++(.-.) :: Bits.Bits a => a -> a -> a+a.-.b = a .&. Bits.complement b++shiftBoardLeft :: Board -> Board+shiftBoardLeft (Board bits) =+   Board $ (bits .-. columnKMask C0) `Bits.shiftR` 1++shiftBoardRight :: Board -> Board+shiftBoardRight (Board bits) =+   Board $ (bits .-. columnKMask C6) `Bits.shiftL` 1++shiftBoardUp :: Board -> Board+shiftBoardUp (Board bits) =+   Board $ (bits .-. rowKMask C0) `Bits.shiftR` 8++shiftBoardDown :: Board -> Board+shiftBoardDown (Board bits) =+   Board $ (bits .-. rowKMask C6) `Bits.shiftL` 8+++splitBoard :: Board -> Board -> (Board,Board)+splitBoard (Board mask) (Board board) =+   (Board (board.&.mask), Board (board.-.mask))++{- |+prop> \k b -> b == Labyrinth.shiftRowLeft k (Labyrinth.shiftRowRight k b)+prop> \k b -> b == Labyrinth.shiftRowRight k (Labyrinth.shiftRowLeft k b)+-}+shiftRowLeft :: Coord -> (Bool, Board) -> (Bool, Board)+shiftRowLeft r (extra,board) =+   let (row, remainder) = splitBoard (Board $ rowKMask r) board+   in (boardGet row (r,C0),+       remainder <> shiftBoardLeft row <> boardSet extra (r,C6))++shiftRowRight :: Coord -> (Bool, Board) -> (Bool, Board)+shiftRowRight r (extra,board) =+   let (row, remainder) = splitBoard (Board $ rowKMask r) board+   in (boardGet row (r,C6),+       remainder <> shiftBoardRight row <> boardSet extra (r,C0))++{- |+prop> \k b -> b == Labyrinth.shiftColumnUp k (Labyrinth.shiftColumnDown k b)+prop> \k b -> b == Labyrinth.shiftColumnDown k (Labyrinth.shiftColumnUp k b)+-}+shiftColumnUp :: Coord -> (Bool, Board) -> (Bool, Board)+shiftColumnUp c (extra,board) =+   let (column, remainder) = splitBoard (Board $ columnKMask c) board+   in (boardGet column (C0,c),+       remainder <> shiftBoardUp column <> boardSet extra (C6,c))++shiftColumnDown :: Coord -> (Bool, Board) -> (Bool, Board)+shiftColumnDown c (extra,board) =+   let (column, remainder) = splitBoard (Board $ columnKMask c) board+   in (boardGet column (C6,c),+       remainder <> shiftBoardDown column <> boardSet extra (C0,c))+++cycleBoardLeft :: Board -> Board+cycleBoardLeft (Board bits) =+   Board $+      (bits .-. columnKMask C0) `Bits.shiftR` 1+      .|.+      (bits .&. columnKMask C0) `Bits.shiftL` 6++cycleBoardRight :: Board -> Board+cycleBoardRight (Board bits) =+   Board $+      (bits .-. columnKMask C6) `Bits.shiftL` 1+      .|.+      (bits .&. columnKMask C6) `Bits.shiftR` 6++cycleBoardUp :: Board -> Board+cycleBoardUp (Board bits) =+   Board $+      (bits .-. rowKMask C0) `Bits.shiftR` 8+      .|.+      (bits .&. rowKMask C0) `Bits.shiftL` (8*6)++cycleBoardDown :: Board -> Board+cycleBoardDown (Board bits) =+   Board $+      (bits .-. rowKMask C6) `Bits.shiftL` 8+      .|.+      (bits .&. rowKMask C6) `Bits.shiftR` (8*6)++cycleGen :: (Board -> Board) -> (Coord -> Word64) -> Coord -> Board -> Board+cycleGen cycleBoard mask coord =+   uncurry mappend . mapFst cycleBoard . splitBoard (Board $ mask coord)++{- |+prop> \k b -> b == Labyrinth.cycleRowLeft k (Labyrinth.cycleRowRight k b)+prop> \k b -> b == Labyrinth.cycleRowRight k (Labyrinth.cycleRowLeft k b)+-}+cycleRowLeft :: Coord -> Board -> Board+cycleRowLeft = cycleGen cycleBoardLeft rowKMask++cycleRowRight :: Coord -> Board -> Board+cycleRowRight = cycleGen cycleBoardRight rowKMask++{- |+prop> \k b -> b == Labyrinth.cycleColumnUp k (Labyrinth.cycleColumnDown k b)+prop> \k b -> b == Labyrinth.cycleColumnDown k (Labyrinth.cycleColumnUp k b)+-}+cycleColumnUp :: Coord -> Board -> Board+cycleColumnUp = cycleGen cycleBoardUp columnKMask++cycleColumnDown :: Coord -> Board -> Board+cycleColumnDown = cycleGen cycleBoardDown columnKMask++cycleStripe :: Border -> Coord -> Board -> Board+cycleStripe b =+   case b of+      West -> cycleRowRight+      East -> cycleRowLeft+      South -> cycleColumnUp+      North -> cycleColumnDown++++rotateMasked ::+   (Directions Board -> Directions Board) ->+   Board -> Directions Board -> Directions Board+rotateMasked rotate mask board =+   case FuncHT.unzip (splitBoard mask <$> board) of+      (masked, remaining) -> rotate masked <> remaining++rotateDir90, rotateDir180 :: Directions a -> Directions a+rotateDir90 (Directions n w s e) = Directions e n w s+rotateDir180 (Directions n w s e) = Directions s e n w++randomRotate ::+   (Rnd.RandomGen g) => Directions Board -> MS.State g (Directions Board)+randomRotate board =+   ($ board) <$>+   App.lift2 (.)+      (rotateMasked rotateDir180 . Board <$> MS.state Rnd.random)+      (rotateMasked rotateDir90  . Board <$> MS.state Rnd.random)+++data Directions a = Directions {north, west, south, east :: a}+   deriving (Eq)++instance Semigroup a => Semigroup (Directions a) where+   (<>) = App.lift2 (<>)++instance Monoid a => Monoid (Directions a) where+   mempty = pure mempty+   mappend = App.lift2 mappend++instance Functor Directions where+   fmap f (Directions n w s e) = Directions (f n) (f w) (f s) (f e)++instance Foldable Directions where+   foldMap f (Directions n w s e) =+      f n `mappend` f w `mappend` f s `mappend` f e++instance Traversable Directions where+   sequenceA (Directions n w s e) = App.lift4 Directions n w s e++instance Applicative Directions where+   pure a = Directions a a a a+   Directions fn fw fs fe <*> Directions n w s e =+      Directions (fn n) (fw w) (fs s) (fe e)++transposeDirections :: Directions [[a]] -> [[Directions a]]+transposeDirections (Directions n w s e) =+   zipWith4 (zipWith4 Directions) n w s e+++boolChar :: Char -> Bool -> Char+boolChar c b = if b then c else ' '++formatBoard :: Board -> String+formatBoard = unlines . map (map (boolChar '*')) . listsFromBoard++wallChar :: Char+wallChar = '\x2588'++wayChar :: Char+wayChar = '.'++selectWallWayChar :: Bool -> Bool -> Char+selectWallWayChar wall connect =+   case (wall, connect) of+      (False, False) -> ' '+      (True,  False) -> wallChar+      (False, True)  -> wayChar+      (True,  True)  -> error "character cannot be both wall and way"++boxTable :: [[Box]] -> Box+boxTable = Box.vcat Box.left . map (Box.hcat Box.top)++formatCell ::+   EnumSet Player -> Directions Bool -> Char -> Directions Bool -> Box+formatCell players connects center walls =+   let plChar p =+         if EnumSet.member p players then playerChar True p else wallChar+   in case App.lift2 selectWallWayChar walls connects of+         Directions n w s e ->+            boxTable $ map (map Box.char) $+            [plChar Player0, n, plChar Player1] :+            [w, center, e] :+            [plChar Player2, s, plChar Player3] :+            []++format :: Directions Board -> Box+format =+   boxTable .+   map (map (formatCell EnumSet.empty (pure False) ' ')) .+   transposeDirections . fmap listsFromBoard++formatWays :: Directions Board -> Board -> Box+formatWays walls reachable =+   boxTable $+   zipWith3+      (zipWith3 (formatCell EnumSet.empty))+      (transposeDirections $ fmap listsFromBoard $+       connectReachable walls reachable)+      (map (map (boolChar wayChar)) $ listsFromBoard reachable)+      (transposeDirections $ fmap listsFromBoard walls)++connectReachable :: Directions Board -> Board -> Directions Board+connectReachable walls reachable =+   let blockWall (Board mask) (Board bits) = Board $ bits.-.mask+       shiftAndBlock block1 shift block0 =+         blockWall+            (block1 walls <> shift (block0 walls))+            (reachable <> shift reachable)+   in Directions {+         north = shiftAndBlock north shiftBoardDown south,+         south = shiftAndBlock south shiftBoardUp north,+         west = shiftAndBlock west shiftBoardRight east,+         east = shiftAndBlock east shiftBoardLeft west+      }++arrows :: Directions Char+arrows =+   Directions {+      north = '\x21D3', west = '\x21D2', south = '\x21D1', east = '\x21D0'+   }++arrowFrame :: Maybe (Border, Coord) -> Box -> Box+arrowFrame forbidden box =+   let rowBox arrow c = Box.text [' ', arrow, c]+       columnBox c0 c1 = Box.alignVert Box.center1 3 $ Box.text [c0, c1]+       makeBoxes =+         Directions {+            north = rowBox, west = flip columnBox,+            south = rowBox, east = columnBox+         }+       horizVert h v = Directions {north = h, south = h, west = v, east = v}+       labels =+         maybe id+            (\(b,c) -> singleBorder b $ Map.insert c)+            forbidden (pure $ const id)+         <*>+         horizVert (Box.emptyBox 1 3) (Box.emptyBox 3 1)+         <*>+         App.lift2 fmap (makeBoxes <*> arrows) shiftCharMap+       labelBoxes =+         horizVert (Box.hsep 3 Box.top) (Box.vsep 3 Box.center1)+         <*>+         ((Box.nullBox :) . Map.elems <$> labels)+       emptyBox = Box.emptyBox 1 2+   in boxTable $+      [emptyBox, north labelBoxes, emptyBox] :+      [west labelBoxes, box, east labelBoxes] :+      [emptyBox, south labelBoxes, emptyBox] :+      []++constMap :: (Ord k) => [k] -> a -> Map k a+constMap keys a = Map.fromList $ map (flip (,) a) keys++shiftCharMap :: Directions (Map Coord Char)+shiftCharMap =+   flip MS.evalState 'A' $ Trav.traverse Trav.sequence $+   pure $ constMap [C1,C3,C5] $ MS.state $ \c -> (c, succ c)++arrowMap :: Map Char (Border,Coord)+arrowMap =+   Fold.fold $+   App.lift2+      (\b -> Map.fromList . map (\(c,char) -> (char,(b,c))) . Map.toList)+      borderSet shiftCharMap+++coordinateFrame :: Box -> Box+coordinateFrame box =+   let row =+         Box.emptyBox 1 1 Box.<>+         (Box.hsep 2 Box.top $ map Box.char $ Map.keys columnMap)+       column =+         Box.emptyBox 1 1 Box.//+         (Box.vsep 2 Box.top $ map Box.char $ Map.keys rowMap)+       emptyBox = Box.emptyBox 1 2+   in boxTable $+      [emptyBox, row, emptyBox] :+      [column Box.<> Box.emptyBox 1 1, box, Box.emptyBox 1 1 Box.<> column] :+      [emptyBox, row, emptyBox] :+      []++rowMap, columnMap :: Map Char Coord+rowMap = Map.fromList $ zip ['A'..] allEnums+columnMap = Map.fromList $ zip ['0'..] allEnums+++data Shape = I | L | T+   deriving (Eq, Ord, Enum, Show)++type InitTile = (Shape, Maybe Char)++data Rotation = R0 | R1 | R2 | R3+   deriving (Eq, Ord, Enum, Bounded)+++dirsFromShape :: Shape -> Directions Bool+dirsFromShape shape =+   case shape of+      I -> (pure True) {north = False, south = False}+      L -> (pure True) {north = False, east = False}+      T -> (pure True) {west = False, east = False, south = False}++defaultBoardDirs :: [[Directions Bool]]+defaultBoardDirs =+   let f :: Rotation -> Shape -> Directions Bool+       f rot =+         (if Bits.testBit (fromEnum rot) 1 then rotateDir180 else id) .+         (if Bits.testBit (fromEnum rot) 0 then rotateDir90 else id) .+         dirsFromShape+       r0 = f R0; r1 = f R1; r2 = f R2; r3 = f R3+   in [r3 L, r0 T, r0 T, r2 L] :+      [r1 T, r1 T, r0 T, r3 T] :+      [r1 T, r2 T, r3 T, r3 T] :+      [r0 L, r2 T, r2 T, r1 L] :+      []++defaultBoard :: Directions Board+defaultBoard =+   let evenCoords = [C0, C2 .. C6]+   in mconcat $+      zipWith+         (\row ->+            mconcat .+            zipWith (\col -> fmap (flip Mn.when (singleCell (row,col))))+               evenCoords)+         evenCoords defaultBoardDirs+++randomChoose :: (Rnd.RandomGen g) => MS.StateT [a] (MS.State g) a+randomChoose = MS.StateT $ randomSelect . ListHT.removeEach++{-+	total	fixed	symbol+		position+I:	 13	  0	  0+T:	 18	 12	 18+L:	 19	  4	 10++symbols: 24	 12+-}+shuffle :: (Rnd.RandomGen g) => MS.State g (InitTile, [InitTile])+shuffle =+   let (symbolsL, symbolsT) = splitAt 6 moveableSymbols+       xs =+         replicate 13 (I, Nothing) +++         map (\s -> (T, Just s)) symbolsT +++         replicate 9 (L, Nothing) +++         map (\s -> (L, Just s)) symbolsL+   in flip MS.evalStateT xs $ App.lift2 (,) randomChoose $+      sequence $ Match.replicate (drop 1 xs) randomChoose++singleCellShape :: (Coord, Coord) -> Shape -> Directions Board+singleCellShape pos shape =+   flip Mn.when (singleCell pos) <$> dirsFromShape shape++grid :: [a] -> [(a,a)]+grid xs = App.lift2 (,) xs xs++layoutMoveableCells :: [InitTile] -> (Directions Board, SymbolMap)+layoutMoveableCells =+   mapPair (Fold.fold . Map.mapWithKey singleCellShape, Map.mapMaybe id) .+   FuncHT.unzip . Map.fromList .+   zip (filter (not . isCellFixed) $ grid allEnums)++randomBoard ::+   (Rnd.RandomGen g) => MS.State g (InitTile, (Directions Board, SymbolMap))+randomBoard = do+   (extra,shapes) <- shuffle+   let (board,symbolMap) = layoutMoveableCells shapes+   moveable <- randomRotate board+   return (extra, (defaultBoard <> moveable, symbolMap))++shuffleTargets :: (Rnd.RandomGen g) => MS.State g [Char]+shuffleTargets =+   let xs = moveableSymbols ++ fixedSymbols+   in flip MS.evalStateT xs $ sequence $ Match.replicate xs randomChoose++associateTargets ::+   NonEmpty.T [] Player -> [Char] ->+   NonEmpty.T Seq (Player, NonEmpty.T [] Char)+associateTargets players =+   NonEmpty.mapTail Seq.fromList .+   NonEmptyC.zipWith+      (\player targets ->+         (player, NonEmpty.snoc targets $ playerChar False player))+      players .+   maybe (error "empty players list") id .+   NonEmpty.fetch . ListHT.sliceHorizontal (1 + length (NonEmpty.tail players))+++bfsStep :: Directions Board -> Board -> Board+bfsStep walls board =+   let blockWall (Board mask) (Board bits) = Board $ bits.-.mask+       shiftAndBlock block1 shift block0 =+         blockWall (block1 walls) (shift (blockWall (block0 walls) board))+   in board+      <>+      shiftAndBlock east  shiftBoardLeft  west+      <>+      shiftAndBlock west  shiftBoardRight east+      <>+      shiftAndBlock north shiftBoardDown  south+      <>+      shiftAndBlock south shiftBoardUp    north++bfs :: Directions Board -> Board -> Board+bfs walls =+   snd . head . dropWhile (not . fst) .+   ListHT.mapAdjacent (\x y -> (x==y, x)) . iterate (bfsStep walls)+++data Player = Player0 | Player1 | Player2 | Player3+   deriving (Eq, Ord, Enum, Bounded, Show)++playerChar :: Bool -> Player -> Char+playerChar b p =+   case p of+      Player0 -> if b then '\x2666' else '\x2662'+      Player1 -> if b then '\x2665' else '\x2661'+      Player2 -> if b then '\x2660' else '\x2664'+      Player3 -> if b then '\x2663' else '\x2667'++playerSymbols, fixedSymbols, moveableSymbols :: [Char]+playerSymbols = map (playerChar False) allEnums+(fixedSymbols, moveableSymbols) = splitAt 12 $ take 24 ['\x2600' ..]++type SymbolMap = Map (Coord,Coord) Char++fixedSymbolMap :: SymbolMap+fixedSymbolMap =+   let corners = Map.fromList $ zip (grid [C0,C6]) playerSymbols+   in Map.union corners $ Map.fromList $+      zip (filter (flip Map.notMember corners) $ grid [C0, C2 .. C6])+         fixedSymbols++randomSymbolMap :: (Rnd.RandomGen g) => MS.State g SymbolMap+randomSymbolMap =+   Map.fromList <$>+   MS.evalStateT+      (mapM (\symbol -> flip (,) symbol <$> randomChoose) moveableSymbols)+      (filter (flip Map.notMember fixedSymbolMap) $ grid [C0 .. C6])++removeFromMap :: (Ord k) => k -> Map k a -> (Maybe a, Map k a)+removeFromMap = Map.updateLookupWithKey (\ _k _a -> Nothing)++insertMaybeMap :: (Ord k) => k -> Maybe a -> Map k a -> Map k a+insertMaybeMap k = maybe id (Map.insert k)++shiftRowLeftMap :: Coord -> (Maybe Char, SymbolMap) -> (Maybe Char, SymbolMap)+shiftRowLeftMap rowPos (extra, m) =+   let (row, remainder) = Map.partitionWithKey (\(r,_c) _ -> r == rowPos) m+       (x,xs) = removeFromMap (rowPos,minBound) row+   in (x,+       remainder <>+         insertMaybeMap (rowPos,maxBound) extra+            (Map.mapKeysMonotonic (\(r,c) -> (r, pred c)) xs))++shiftRowRightMap :: Coord -> (Maybe Char, SymbolMap) -> (Maybe Char, SymbolMap)+shiftRowRightMap rowPos (extra, m) =+   let (row, remainder) = Map.partitionWithKey (\(r,_c) _ -> r == rowPos) m+       (x,xs) = removeFromMap (rowPos,maxBound) row+   in (x,+       remainder <>+         insertMaybeMap (rowPos,minBound) extra+            (Map.mapKeysMonotonic (\(r,c) -> (r, succ c)) xs))++shiftColumnUpMap ::+   Coord -> (Maybe Char, SymbolMap) -> (Maybe Char, SymbolMap)+shiftColumnUpMap columnPos (extra, m) =+   let (column, remainder) =+         Map.partitionWithKey (\(_r,c) _ -> c == columnPos) m+       (x,xs) = removeFromMap (minBound,columnPos) column+   in (x,+       remainder <>+         insertMaybeMap (maxBound,columnPos) extra+            (Map.mapKeysMonotonic (\(r,c) -> (pred r, c)) xs))++shiftColumnDownMap ::+   Coord -> (Maybe Char, SymbolMap) -> (Maybe Char, SymbolMap)+shiftColumnDownMap columnPos (extra, m) =+   let (column, remainder) =+         Map.partitionWithKey (\(_r,c) _ -> c == columnPos) m+       (x,xs) = removeFromMap (maxBound,columnPos) column+   in (x,+       remainder <>+         insertMaybeMap (minBound,columnPos) extra+            (Map.mapKeysMonotonic (\(r,c) -> (succ r, c)) xs))+++formatWithSymbols :: BoardState -> Board -> Box+formatWithSymbols s reachable =+   boxTable $+   zipWith4+      (zipWith4+         (\pos connects reach ->+            formatCell+               (EnumMap.keysSet $ EnumMap.filter (pos==) $ statePlayerMap s)+               connects+               (Map.findWithDefault (boolChar wayChar reach) pos $+                stateSymbolMap s)))+      (ListHT.outerProduct (,) allEnums allEnums)+      (transposeDirections $ fmap listsFromBoard $+       connectReachable (stateBoard s) reachable)+      (listsFromBoard reachable)+      (transposeDirections $ fmap listsFromBoard $ stateBoard s)+++type PlayerMap = EnumMap Player (Coord,Coord)++shiftPlayersGen ::+   Eq a => (b -> a) -> (b -> b) -> a -> EnumMap k b -> EnumMap k b+shiftPlayersGen select update coord =+   EnumMap.map (\pos -> if select pos == coord then update pos else pos)++shiftRowLeftPlayers, shiftRowRightPlayers,+   shiftColumnUpPlayers, shiftColumnDownPlayers ::+      Coord -> PlayerMap -> PlayerMap+shiftRowLeftPlayers    = shiftPlayersGen fst (mapSnd cyclicPred)+shiftRowRightPlayers   = shiftPlayersGen fst (mapSnd cyclicSucc)+shiftColumnUpPlayers   = shiftPlayersGen snd (mapFst cyclicPred)+shiftColumnDownPlayers = shiftPlayersGen snd (mapFst cyclicSucc)+++data BoardState =+   BoardState {+      stateBoard :: Directions Board,+      stateSymbolMap :: SymbolMap,+      statePlayerMap :: PlayerMap+   }++type Tile = (Directions Bool, Maybe Char)++cyclicPred :: (Eq a, Enum a, Bounded a) => a -> a+cyclicPred x = if x==minBound then maxBound else pred x++cyclicSucc :: (Eq a, Enum a, Bounded a) => a -> a+cyclicSucc x = if x==maxBound then minBound else succ x++shiftStateGen ::+   (Coord -> (Bool, Board) -> (Bool, Board)) ->+   (Coord -> (Maybe Char, SymbolMap) -> (Maybe Char, SymbolMap)) ->+   (Coord -> PlayerMap -> PlayerMap) ->+   Coord -> (Tile, BoardState) -> (Tile, BoardState)+shiftStateGen shiftBoard shiftMap shiftPlayers rowPos ((tile,symbol), state) =+   let (newExtra, newSymbolMap) =+         shiftMap rowPos (symbol, stateSymbolMap state)+       (newTile, newBoard) =+         FuncHT.unzip $ fmap (shiftBoard rowPos) $+         App.lift2 (,) tile (stateBoard state)+       newPlayerMap = shiftPlayers rowPos $ statePlayerMap state+   in ((newTile, newExtra),+       BoardState {+         stateBoard = newBoard,+         stateSymbolMap = newSymbolMap,+         statePlayerMap = newPlayerMap+       })++data Border = North | West | South | East+   deriving (Eq, Ord, Enum, Bounded, Show)++borderSet :: Directions Border+borderSet = Directions {north = North, west = West, south = South, east = East}++singleBorder :: Border -> a -> Directions a -> Directions a+singleBorder b a m =+   case b of+      North -> m{north = a}+      South -> m{south = a}+      East  -> m{east = a}+      West  -> m{west = a}++lookupBorder :: Border -> Directions a -> a+lookupBorder b =+   case b of+      North -> north+      South -> south+      East  -> east+      West  -> west++flipBorder :: Border -> Border+flipBorder b =+   case b of+      North -> South+      South -> North+      East -> West+      West -> East++shiftState :: Border -> Coord -> (Tile, BoardState) -> (Tile, BoardState)+shiftState b =+   case b of+      West -> shiftStateGen shiftRowRight shiftRowRightMap shiftRowRightPlayers+      East -> shiftStateGen shiftRowLeft shiftRowLeftMap shiftRowLeftPlayers+      South -> shiftStateGen shiftColumnUp shiftColumnUpMap shiftColumnUpPlayers+      North ->+         shiftStateGen shiftColumnDown shiftColumnDownMap shiftColumnDownPlayers+++reachableFromPlayer :: Player -> BoardState -> Board+reachableFromPlayer player state =+   bfs (stateBoard state) $ singleCell $+   EnumMap.findWithDefault (error "player not in playerMap") player $+   statePlayerMap state++shapeRotations :: Eq a => Directions a -> [(Rotation, Directions a)]+shapeRotations shape =+   zip (if rotateDir180 shape == shape then [R0,R1] else allEnums) $+   iterate rotateDir90 shape++reachable1Single :: Board -> (Border, Coord) -> Tile -> BoardState -> Bool+reachable1Single cloud0 (b,pos) tile state0 =+   let state1 = snd $ shiftState b pos (tile, state0)+       cloud1 = bfs (stateBoard state1) $ cycleStripe b pos cloud0+   in any (boardGet cloud1) $ Map.keys $ stateSymbolMap state1++reachable1 :: (Tile, BoardState) -> [((Border, Coord), ([Rotation], Bool))]+reachable1 ((shape,symbol),state) =+   filter (not . null . fst . snd) $+   flip map (App.lift2 (,) allEnums [C1,C3,C5]) $ \shift ->+      (shift,+       mapPair (map fst, null) $+       ListHT.partition+          (\(_rot,rotShape) ->+             reachable1Single+                (Fold.foldMap singleCell $ statePlayerMap state)+                shift (rotShape,symbol) state) $+       shapeRotations shape)++reachable2Single :: Board -> (Border, Coord) -> Tile -> BoardState -> Int+reachable2Single cloud0 (b,pos) tile state0 =+   let (tile1,state1) = shiftState b pos (tile, state0)+       cloud1 = bfs (stateBoard state1) $ cycleStripe b pos cloud0+   in length $+      filter+         (\shift ->+            reachable1Single cloud1 shift (pure True, snd tile1) state1) $+      filter ((flipBorder b, pos) /=) $+      App.lift2 (,) allEnums [C1,C3,C5]++reachable2 :: (Tile, BoardState) -> [(((Border, Coord), Rotation), Int)]+reachable2 ((shape,symbol),state) =+   map+      (\(shift, (rot,rotShape)) ->+         ((shift, rot),+          reachable2Single+            (Fold.foldMap singleCell $ statePlayerMap state)+            shift (rotShape,symbol) state)) $+   App.lift2 (,)+      (App.lift2 (,) allEnums [C1,C3,C5])+      (shapeRotations shape)+++formatRotation :: Rotation -> String+formatRotation = show . fromEnum++formatShift :: ((Border, Coord), Rotation) -> String+formatShift ((b, pos), rot) =+   Map.findWithDefault (error "forbidden coordinate")+      pos (lookupBorder b shiftCharMap)+   :+   formatRotation rot++formatShifts :: ((Border, Coord), ([Rotation], Bool)) -> String+formatShifts ((b, pos), (rot,complete)) =+   Map.findWithDefault (error "forbidden coordinate")+      pos (lookupBorder b shiftCharMap)+   :+   if complete then "*" else concatMap formatRotation rot++parseShift ::+   Maybe (Border, Coord) -> String ->+   ME.Exceptional String ((Border, Coord), Rotation)+parseShift forbidden input =+   case input of+      [arrowChar, rotation] ->+         App.lift2 (,)+            (do+               pos <-+                  ME.fromMaybe "not an arrow letter" $+                  Map.lookup (Char.toUpper arrowChar) arrowMap+               if Just pos == forbidden+                  then ME.throw "reversing the last shift is forbidden"+                  else return pos)+            (case rotation of+               '0' -> return R0+               '1' -> return R1+               '2' -> return R2+               '3' -> return R3+               _ -> ME.throw "not a rotation number from 0-3")+      _ -> ME.throw "need two input characters"++parsePosition :: Board -> String -> ME.Exceptional String (Coord, Coord)+parsePosition reachable input =+   case input of+      [rowChar, columnChar] -> do+         pos <-+            App.lift2 (,)+               (ME.fromMaybe "row letter out of range" $+                Map.lookup (Char.toUpper rowChar) rowMap)+               (ME.fromMaybe "column number out of range" $+                Map.lookup columnChar columnMap)+         if boardGet reachable pos+            then return pos+            else ME.throw "position unreachable"+      _ -> ME.throw "need two input characters"++inputLoop :: (String -> ME.Exceptional String a) -> IO a+inputLoop parse =+   ME.switch (\msg -> putStrLn msg >> inputLoop parse) return . parse+      =<< getLine++playerCharSet :: EnumSet Char+playerCharSet = EnumSet.fromList $ map (playerChar True) allEnums++inversePlayerChar :: Char -> String+inversePlayerChar c =+   if EnumSet.member c playerCharSet+      then ANSI.esc "" (ANSI.reverse []) "m" ++ c : ANSI.reset+      else [c]++printBox :: Box -> IO ()+printBox = putStr . concatMap inversePlayerChar . Box.render++main :: IO ()+main = do+   let gameLoop forbiddenShift (shape0, msymbol0) state0+            (NonEmpty.Cons (player,targets) remPlayers) = do+         let rotatedShapes =+               EnumMap.fromList $ zip allEnums $ iterate rotateDir90 shape0+         let symbol0 = maybe ' ' id msymbol0+         printBox $ Box.hsep 5 Box.top $+            arrowFrame forbiddenShift (formatWithSymbols state0 mempty)+            :+            (Box.vcat Box.center1 $ Fold.fold $+             EnumMap.mapWithKey+               (\k sh ->+                  [Box.text $ formatRotation k,+                   formatCell EnumSet.empty (pure False) symbol0 sh,+                   Box.emptyBox 1 0])+               rotatedShapes)+            :+            []+         let NonEmpty.Cons target remTargets = targets+         let state0Target =+              state0{+                 stateSymbolMap =+                    Map.filter (target==) $ stateSymbolMap state0,+                 statePlayerMap =+                    EnumMap.intersectionWith const (statePlayerMap state0)+                       (EnumMap.singleton player ())+              }+         let msymbol0Target = mfilter (target==) msymbol0+         let isAllowed (shift,_) = forbiddenShift /= Just shift+         case splitAt 5 $ filter isAllowed $+              reachable1 ((shape0,msymbol0Target),state0Target) of+            ([], _) -> do+               let xs =+                    take 5 $ List.sortBy (flip $ comparing snd) $+                    filter (isAllowed . fst) $+                    reachable2 ((shape0,msymbol0Target),state0Target)+               putStrLn $ "promising: " +++                  List.intercalate ", "+                     (map (\(x,l) -> printf "%s(%d)" (formatShift x) l) xs+                        ++ ["..."])+            (xs, ys) ->+               putStrLn $ "hint: " +++               List.intercalate ", "+                  (map formatShifts xs ++ take 1 (map (const "...") ys))+         let goal = playerChar True player : '\x2192' : target : []+         putStr $ goal ++ " Enter position and rotation of inserted piece: "+         ((border,coord), rotation) <- inputLoop $ parseShift forbiddenShift+         let (shape1,state1) =+               shiftState border coord+                  ((rotatedShapes EnumMap.! rotation, msymbol0), state0)+         let reachable = reachableFromPlayer player state1+         printBox $ coordinateFrame $ formatWithSymbols state1 reachable+         putStrLn ""+         putStr $ goal ++ " Enter coordinates of new player position: "+         pos <- inputLoop $ parsePosition reachable+         mNewPlayers <-+            if Just target /= Map.lookup pos (stateSymbolMap state1)+               then return $ Just $ NonEmpty.snoc remPlayers (player,targets)+               else do+                  putStrLn $ "found target: " ++ target : ""+                  case NonEmpty.fetch remTargets of+                     Nothing -> do+                        putStrLn $ "All targets found!"+                        return $ NonEmpty.fetch remPlayers+                     Just remTargetsNE@(NonEmpty.Cons newTarget _) -> do+                        putStrLn $+                           "new target: " ++ newTarget :+                           ", remaining: " ++ show (length remTargets)+                        return $ Just $+                           NonEmpty.snoc remPlayers (player, remTargetsNE)+         case mNewPlayers of+            Nothing -> putStrLn "All players found all their targets!"+            Just newPlayers ->+               gameLoop (Just (flipBorder border, coord)) shape1+                  state1{statePlayerMap =+                     EnumMap.insert player pos $ statePlayerMap state1}+                  newPlayers++   let (((shape,msymbol),(board,symbolMap)), shuffledTargets) =+         MS.evalState (App.lift2 (,) randomBoard shuffleTargets) $+         Rnd.mkStdGen 42+   let targets = associateTargets (Player1 !: Player2 : []) shuffledTargets+   let playerMap =+         EnumMap.intersectionWith (const id)+            (EnumMap.fromList $ Fold.toList targets) $+         EnumMap.fromList $ zip allEnums $ grid [C0,C6]+   gameLoop Nothing (dirsFromShape shape, msymbol)+      (BoardState board (fixedSymbolMap <> symbolMap) playerMap)+      targets++{-+let board = snd $ MS.evalState randomBoard $ Rnd.mkStdGen 42+printBox $ formatWays board $ bfs board $ singleCell (C1,C6)+-}
src/Game/Mastermind.hs view
@@ -47,15 +47,31 @@ import Control.Monad.IO.Class (liftIO) import Control.Monad (guard, when, replicateM, liftM2, ) +import qualified Combinatorics as Combi+ import qualified System.Random as Rnd import qualified System.IO as IO  +{- $setup+>>> import qualified Test.Mastermind as TestMM+>>> import Test.Mastermind (CodeSetInt, alphabet, Code(Code), CodePair(CodePair), forAllEval)+>>> import qualified Game.Mastermind.CodeSet.Tree as CodeSetTree+>>> import qualified Game.Mastermind.CodeSet as CodeSet+>>> import qualified Game.Mastermind as MM+>>> import qualified Data.EnumSet as EnumSet+>>> import Game.Mastermind (Eval(Eval))+>>> import Control.Monad (replicateM)+>>> import Data.Function.HT (compose2)+-}+ data Eval = Eval Int Int    deriving (Eq, Ord, Show)  {- | Given the code and a guess, compute the evaluation.++prop> \(CodePair secret attempt) -> MM.evaluate secret attempt == MM.evaluate attempt secret -} evaluate :: (Enum a) => [a] -> [a] -> Eval evaluate code attempt =@@ -68,14 +84,7 @@    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 (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"]--} - bagFromList :: (Enum a) => [a] -> EnumMap a Int bagFromList = EnumMap.fromListWith (+) . map (\a -> (a,1)) @@ -106,26 +115,7 @@               then EnumSet.singleton symbol               else EnumSet.delete symbol alphabet)          code) $-   possibleRightPlaces (length code) rightPlaces---- ToDo: import from combinatorial-{- |-Combinatorical \"choose k from n\".--}-possibleRightPlaces :: Int -> Int -> [[Bool]]-possibleRightPlaces n rightPlaces =-   if n < rightPlaces-     then []-     else-       if n==0-         then [[]]-         else-            (guard (rightPlaces>0) >>-               (map (True:) $-                possibleRightPlaces (n-1) (rightPlaces-1)))-            ++-            (map (False:) $-             possibleRightPlaces (n-1) rightPlaces)+   Combi.choose (length code) rightPlaces  {- | Given a code and an according evaluation,@@ -134,6 +124,19 @@ The Game.Mastermind game consists of collecting pairs of codes and their evaluations. The searched code is in the intersection of all corresponding code sets.++>>> filter ((MM.Eval 2 0 ==) . MM.evaluate "aabbb") $ replicateM 5 ['a'..'c']+["aaaaa","aaaac","aaaca","aaacc","aacaa","aacac","aacca","aaccc","acbcc","accbc","acccb","cabcc","cacbc","caccb","ccbbc","ccbcb","cccbb"]+>>> CodeSet.flatten (MM.matching (EnumSet.fromList ['a'..'c']) "aabbb" (Eval 2 0) :: CodeSetTree.T Char)+["aaaaa","aaaac","aaaca","aaacc","aacaa","aacac","aacca","aaccc","acbcc","accbc","acccb","cabcc","cacbc","caccb","ccbbc","ccbcb","cccbb"]++prop> \(CodePair secret attempt) -> CodeSetTree.member secret $ MM.matching alphabet attempt (MM.evaluate secret attempt)+prop> \(CodePair secret attempt) -> forAllEval secret $ \eval -> (eval == MM.evaluate secret attempt) == CodeSetTree.member secret (MM.matching alphabet attempt eval)+prop> \(Code attempt) -> forAllEval attempt $ \eval0 -> forAllEval attempt $ \eval1 -> eval0 == eval1 || CodeSetTree.null (compose2 CodeSetTree.intersection (MM.matching alphabet attempt) eval0 eval1)+prop> \(Code attempt) -> forAllEval attempt $ \eval -> all ((eval ==) . MM.evaluate attempt) $ take 100 $ CodeSet.flatten $ (MM.matching alphabet attempt eval :: CodeSetInt)+prop> \(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)+prop> TestMM.intersections+prop> TestMM.solve -} matching :: (CodeSet.C set, Enum a) => EnumSet a -> [a] -> Eval -> set a matching alphabet =@@ -164,9 +167,18 @@              let patternCode = zip pattern code              in  findCodes patternCode rightSymbols $                  bagFromList $ map snd $ filter (not . fst) patternCode) $-       possibleRightPlaces (length code) rightPlaces+       Combi.choose (length code) rightPlaces  +{- |+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.++prop> \(Code attempt) -> fromIntegral (EnumSet.size alphabet) ^ length attempt == sum (map snd (MM.partitionSizes alphabet attempt))+-} partitionSizes :: (Enum a) => EnumSet a -> [a] -> [(Eval, Integer)] partitionSizes alphabet code =    map (\eval -> (eval, CodeSetTree.size $ matching alphabet code eval)) $@@ -234,6 +246,9 @@    in  EnumSet.union symbols $ EnumSet.fromList $ take 1 $ EnumSet.toList $        EnumSet.difference alphabet symbols +{- |+prop> TestMM.bestSeparatingCode+-} bestSeparatingCode ::    (CodeSet.C set, Enum a) => Int -> set a -> NonEmpty.T [] [a] -> [a] bestSeparatingCode n set =@@ -394,16 +409,6 @@                      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 ()
src/Game/Mastermind/CodeSet.hs view
@@ -63,7 +63,7 @@ intersections :: (C set, Enum a) => NonEmpty.T [] (set a) -> set a intersections = NonEmpty.foldl1 intersection . nonEmptySortKey size --- ToDo: import from NonEmptyC+-- cannot be easily generalized for inclusion in non-empty package nonEmptySortKey :: (Ord b) => (a -> b) -> NonEmpty.T [] a -> NonEmpty.T [] a nonEmptySortKey f =    fmap snd . NonEmptyC.sortBy (comparing fst) . fmap (\x -> (f x, x))
src/Game/Mastermind/CodeSet/Tree.hs view
@@ -63,14 +63,13 @@    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 --- FixMe: somehow inefficient, because the sizes of subsets are recomputed several times+-- somehow inefficient, because the sizes of subsets are recomputed several times select :: (Enum a) => T a -> Integer -> [a] select End n =    case compare n 0 of@@ -166,7 +165,6 @@    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
src/Game/Mastermind/HTML.hs view
@@ -9,10 +9,11 @@ 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, )+import Game.Utility (nullToMaybe, randomSelect) -import Text.Html((<<), (+++), concatHtml, toHtml) import qualified Text.Html as Html+import Text.Html((<<), (+++), concatHtml, toHtml)+import Text.Read.HT (maybeRead)  import qualified Network.CGI as CGI @@ -249,9 +250,9 @@ parseQuery :: String -> Maybe (Config, Maybe String) parseQuery query =    let pairs = CGI.formDecode query-   in  do width    <- readMaybe =<< List.lookup "width" pairs+   in  do width    <- maybeRead =<< List.lookup "width" pairs           alphabet <- NonEmpty.fetch =<< List.lookup "alphabet" pairs-          seed     <- readMaybe =<< List.lookup "seed" pairs+          seed     <- maybeRead =<< List.lookup "seed" pairs           mMoves <-              maybe (Just Nothing)                 (fmap Just .@@ -260,15 +261,15 @@                       [code,rightPlacesText,rightSymbolsText] ->                          fmap ((,) code) $                          liftM2 MM.Eval-                            (readMaybe rightPlacesText)-                            (readMaybe rightSymbolsText)+                            (maybeRead rightPlacesText)+                            (maybeRead rightSymbolsText)                       _ -> Nothing)                  .                  words) $              List.lookup "moves" pairs           let mAttempt0 = List.lookup "attempt" pairs-              mRightPlaces = fmap readMaybe $ List.lookup "rightplaces" pairs-              mRightSymbols = fmap readMaybe $ List.lookup "rightsymbols" pairs+              mRightPlaces = fmap maybeRead $ List.lookup "rightplaces" pairs+              mRightSymbols = fmap maybeRead $ List.lookup "rightsymbols" pairs           (moves,mAttempt) <-              case mMoves of                 Nothing -> Just (Nothing, Nothing)
src/Game/VierGewinnt/HTML.hs view
@@ -8,11 +8,12 @@ import Game.VierGewinnt    (Spieler(..), Zug, Spielstand, grundstellung, brettVon, wertung,     anfangundzuege, moeglicheZuege, berechneSpielstand, istMatt, )-import Game.Utility (readMaybe, nullToMaybe, )+import Game.Utility (nullToMaybe) -import Text.Html((<<), (+++), noHtml, spaceHtml, concatHtml, renderHtml, toHtml, ) import qualified Text.Html as Html import qualified Data.List as List+import Text.Html((<<), (+++), noHtml, spaceHtml, concatHtml, renderHtml, toHtml)+import Text.Read.HT (maybeRead) import Data.Array((!))  import qualified Network.CGI as CGI@@ -115,14 +116,14 @@ interpretiereAnfrage anfrage =    let paare = CGI.formDecode anfrage    in  do anfangText <- List.lookup "start" paare-          anfang <- readMaybe anfangText+          anfang <- maybeRead anfangText           zuege <-              case List.lookup "zuege" paare of                 Nothing -> Just []                 Just zuegeText ->                    mapM (\zugText ->                       case zugText of-                         [_] -> readMaybe zugText+                         [_] -> maybeRead zugText                          _ -> Nothing) $                    words zuegeText           return (anfang, zuege)
src/Game/ZeilenSpalten/HTML.hs view
@@ -7,10 +7,11 @@  import Game.ZeilenSpalten hiding (spiel) import qualified Game.Tree as GameTree-import Game.Utility (readMaybe, nullToMaybe, )+import Game.Utility (nullToMaybe) -import Text.Html((<<), (+++), concatHtml, toHtml) import qualified Text.Html as Html+import Text.Html((<<), (+++), concatHtml, toHtml)+import Text.Read.HT (maybeRead)  import qualified Network.CGI as CGI @@ -143,11 +144,11 @@ interpretiereAnfrage :: String -> Maybe Beschreibung interpretiereAnfrage anfrage =    let paare = CGI.formDecode anfrage-   in  do breite   <- readMaybe =<< List.lookup "breite" paare-          hoehe    <- readMaybe =<< List.lookup "hoehe" paare-          saat     <- readMaybe =<< List.lookup "saat" paare-          orient   <- readMaybe =<< List.lookup "orient" paare-          gegenzug <- readMaybe =<< List.lookup "gegenzug" paare+   in  do breite   <- maybeRead =<< List.lookup "breite" paare+          hoehe    <- maybeRead =<< List.lookup "hoehe" paare+          saat     <- maybeRead =<< List.lookup "saat" paare+          orient   <- maybeRead =<< List.lookup "orient" paare+          gegenzug <- maybeRead =<< List.lookup "gegenzug" paare           zuege <-              case List.lookup "zuege" paare of                 Nothing -> Just []@@ -155,7 +156,7 @@                    mapM (\zugText ->                       case zugText of                          _:_:_:_ -> Nothing-                         _ -> readMaybe zugText) $+                         _ -> maybeRead zugText) $                    words zuegeText           return ((breite,hoehe), saat, orient, gegenzug, zuege)
+ test-module.list view
@@ -0,0 +1,3 @@+Game.Labyrinth+Game.Mastermind+Game.Utility
test/Test.hs view
@@ -1,15 +1,14 @@+-- Do not edit! Automatically created with doctest-extract. module Main where -import qualified Test.Mastermind as MM-+import qualified Test.Game.Labyrinth+import qualified Test.Game.Mastermind+import qualified Test.Game.Utility -prefix :: String -> [(String, IO ())] -> [(String, IO ())]-prefix msg =-   map (\(str,test) -> (msg ++ "." ++ str, test))+import qualified Test.DocTest.Driver as DocTest  main :: IO ()-main =-   mapM_ (\(msg,io) -> putStr (msg++": ") >> io) $-   concat $-      prefix "Game.Mastermind" MM.tests :-      []+main = DocTest.run $ do+    Test.Game.Labyrinth.test+    Test.Game.Mastermind.test+    Test.Game.Utility.test
+ test/Test/Game/Labyrinth.hs view
@@ -0,0 +1,52 @@+-- Do not edit! Automatically created with doctest-extract from src/Game/Labyrinth.hs+{-# LINE 50 "src/Game/Labyrinth.hs" #-}++module Test.Game.Labyrinth where++import qualified Test.DocTest.Driver as DocTest++{-# LINE 51 "src/Game/Labyrinth.hs" #-}+import     qualified Game.Labyrinth as Labyrinth++test :: DocTest.T ()+test = do+ DocTest.printPrefix "Game.Labyrinth:137: "+{-# LINE 137 "src/Game/Labyrinth.hs" #-}+ DocTest.property+{-# LINE 137 "src/Game/Labyrinth.hs" #-}+     (\k b -> b == Labyrinth.shiftRowLeft k (Labyrinth.shiftRowRight k b))+ DocTest.printPrefix "Game.Labyrinth:138: "+{-# LINE 138 "src/Game/Labyrinth.hs" #-}+ DocTest.property+{-# LINE 138 "src/Game/Labyrinth.hs" #-}+     (\k b -> b == Labyrinth.shiftRowRight k (Labyrinth.shiftRowLeft k b))+ DocTest.printPrefix "Game.Labyrinth:153: "+{-# LINE 153 "src/Game/Labyrinth.hs" #-}+ DocTest.property+{-# LINE 153 "src/Game/Labyrinth.hs" #-}+     (\k b -> b == Labyrinth.shiftColumnUp k (Labyrinth.shiftColumnDown k b))+ DocTest.printPrefix "Game.Labyrinth:154: "+{-# LINE 154 "src/Game/Labyrinth.hs" #-}+ DocTest.property+{-# LINE 154 "src/Game/Labyrinth.hs" #-}+     (\k b -> b == Labyrinth.shiftColumnDown k (Labyrinth.shiftColumnUp k b))+ DocTest.printPrefix "Game.Labyrinth:202: "+{-# LINE 202 "src/Game/Labyrinth.hs" #-}+ DocTest.property+{-# LINE 202 "src/Game/Labyrinth.hs" #-}+     (\k b -> b == Labyrinth.cycleRowLeft k (Labyrinth.cycleRowRight k b))+ DocTest.printPrefix "Game.Labyrinth:203: "+{-# LINE 203 "src/Game/Labyrinth.hs" #-}+ DocTest.property+{-# LINE 203 "src/Game/Labyrinth.hs" #-}+     (\k b -> b == Labyrinth.cycleRowRight k (Labyrinth.cycleRowLeft k b))+ DocTest.printPrefix "Game.Labyrinth:212: "+{-# LINE 212 "src/Game/Labyrinth.hs" #-}+ DocTest.property+{-# LINE 212 "src/Game/Labyrinth.hs" #-}+     (\k b -> b == Labyrinth.cycleColumnUp k (Labyrinth.cycleColumnDown k b))+ DocTest.printPrefix "Game.Labyrinth:213: "+{-# LINE 213 "src/Game/Labyrinth.hs" #-}+ DocTest.property+{-# LINE 213 "src/Game/Labyrinth.hs" #-}+     (\k b -> b == Labyrinth.cycleColumnDown k (Labyrinth.cycleColumnUp k b))
+ test/Test/Game/Mastermind.hs view
@@ -0,0 +1,83 @@+-- Do not edit! Automatically created with doctest-extract from src/Game/Mastermind.hs+{-# LINE 56 "src/Game/Mastermind.hs" #-}++module Test.Game.Mastermind where++import Test.DocTest.Base+import qualified Test.DocTest.Driver as DocTest++{-# LINE 57 "src/Game/Mastermind.hs" #-}+import     qualified Test.Mastermind as TestMM+import     Test.Mastermind (CodeSetInt, alphabet, Code(Code), CodePair(CodePair), forAllEval)+import     qualified Game.Mastermind.CodeSet.Tree as CodeSetTree+import     qualified Game.Mastermind.CodeSet as CodeSet+import     qualified Game.Mastermind as MM+import     qualified Data.EnumSet as EnumSet+import     Game.Mastermind (Eval(Eval))+import     Control.Monad (replicateM)+import     Data.Function.HT (compose2)++test :: DocTest.T ()+test = do+ DocTest.printPrefix "Game.Mastermind:74: "+{-# LINE 74 "src/Game/Mastermind.hs" #-}+ DocTest.property+{-# LINE 74 "src/Game/Mastermind.hs" #-}+     (\(CodePair secret attempt) -> MM.evaluate secret attempt == MM.evaluate attempt secret)+ DocTest.printPrefix "Game.Mastermind:133: "+{-# LINE 133 "src/Game/Mastermind.hs" #-}+ DocTest.property+{-# LINE 133 "src/Game/Mastermind.hs" #-}+     (\(CodePair secret attempt) -> CodeSetTree.member secret $ MM.matching alphabet attempt (MM.evaluate secret attempt))+ DocTest.printPrefix "Game.Mastermind:134: "+{-# LINE 134 "src/Game/Mastermind.hs" #-}+ DocTest.property+{-# LINE 134 "src/Game/Mastermind.hs" #-}+     (\(CodePair secret attempt) -> forAllEval secret $ \eval -> (eval == MM.evaluate secret attempt) == CodeSetTree.member secret (MM.matching alphabet attempt eval))+ DocTest.printPrefix "Game.Mastermind:135: "+{-# LINE 135 "src/Game/Mastermind.hs" #-}+ DocTest.property+{-# LINE 135 "src/Game/Mastermind.hs" #-}+     (\(Code attempt) -> forAllEval attempt $ \eval0 -> forAllEval attempt $ \eval1 -> eval0 == eval1 || CodeSetTree.null (compose2 CodeSetTree.intersection (MM.matching alphabet attempt) eval0 eval1))+ DocTest.printPrefix "Game.Mastermind:136: "+{-# LINE 136 "src/Game/Mastermind.hs" #-}+ DocTest.property+{-# LINE 136 "src/Game/Mastermind.hs" #-}+     (\(Code attempt) -> forAllEval attempt $ \eval -> all ((eval ==) . MM.evaluate attempt) $ take 100 $ CodeSet.flatten $ (MM.matching alphabet attempt eval :: CodeSetInt))+ DocTest.printPrefix "Game.Mastermind:137: "+{-# LINE 137 "src/Game/Mastermind.hs" #-}+ DocTest.property+{-# LINE 137 "src/Game/Mastermind.hs" #-}+     (\(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))+ DocTest.printPrefix "Game.Mastermind:138: "+{-# LINE 138 "src/Game/Mastermind.hs" #-}+ DocTest.property+{-# LINE 138 "src/Game/Mastermind.hs" #-}+     (TestMM.intersections)+ DocTest.printPrefix "Game.Mastermind:139: "+{-# LINE 139 "src/Game/Mastermind.hs" #-}+ DocTest.property+{-# LINE 139 "src/Game/Mastermind.hs" #-}+     (TestMM.solve)+ DocTest.printPrefix "Game.Mastermind:128: "+{-# LINE 128 "src/Game/Mastermind.hs" #-}+ DocTest.example+{-# LINE 128 "src/Game/Mastermind.hs" #-}+   (filter ((MM.Eval 2 0 ==) . MM.evaluate "aabbb") $ replicateM 5 ['a'..'c'])+  [ExpectedLine [LineChunk "[\"aaaaa\",\"aaaac\",\"aaaca\",\"aaacc\",\"aacaa\",\"aacac\",\"aacca\",\"aaccc\",\"acbcc\",\"accbc\",\"acccb\",\"cabcc\",\"cacbc\",\"caccb\",\"ccbbc\",\"ccbcb\",\"cccbb\"]"]]+ DocTest.printPrefix "Game.Mastermind:130: "+{-# LINE 130 "src/Game/Mastermind.hs" #-}+ DocTest.example+{-# LINE 130 "src/Game/Mastermind.hs" #-}+   (CodeSet.flatten (MM.matching (EnumSet.fromList ['a'..'c']) "aabbb" (Eval 2 0) :: CodeSetTree.T Char))+  [ExpectedLine [LineChunk "[\"aaaaa\",\"aaaac\",\"aaaca\",\"aaacc\",\"aacaa\",\"aacac\",\"aacca\",\"aaccc\",\"acbcc\",\"accbc\",\"acccb\",\"cabcc\",\"cacbc\",\"caccb\",\"ccbbc\",\"ccbcb\",\"cccbb\"]"]]+ DocTest.printPrefix "Game.Mastermind:180: "+{-# LINE 180 "src/Game/Mastermind.hs" #-}+ DocTest.property+{-# LINE 180 "src/Game/Mastermind.hs" #-}+     (\(Code attempt) -> fromIntegral (EnumSet.size alphabet) ^ length attempt == sum (map snd (MM.partitionSizes alphabet attempt)))+ DocTest.printPrefix "Game.Mastermind:250: "+{-# LINE 250 "src/Game/Mastermind.hs" #-}+ DocTest.property+{-# LINE 250 "src/Game/Mastermind.hs" #-}+     (TestMM.bestSeparatingCode)
+ test/Test/Game/Utility.hs view
@@ -0,0 +1,27 @@+-- Do not edit! Automatically created with doctest-extract from private/Game/Utility.hs+{-# LINE 17 "private/Game/Utility.hs" #-}++module Test.Game.Utility where++import qualified Test.DocTest.Driver as DocTest++{-# LINE 18 "private/Game/Utility.hs" #-}+import     Game.Utility (Choice, mergeChoice, noChoice)++test :: DocTest.T ()+test = do+ DocTest.printPrefix "Game.Utility:58: "+{-# LINE 58 "private/Game/Utility.hs" #-}+ DocTest.property+{-# LINE 58 "private/Game/Utility.hs" #-}+     (\a -> a == mergeChoice noChoice (a :: Choice Char))+ DocTest.printPrefix "Game.Utility:59: "+{-# LINE 59 "private/Game/Utility.hs" #-}+ DocTest.property+{-# LINE 59 "private/Game/Utility.hs" #-}+     (\a -> a == mergeChoice a (noChoice :: Choice Char))+ DocTest.printPrefix "Game.Utility:60: "+{-# LINE 60 "private/Game/Utility.hs" #-}+ DocTest.property+{-# LINE 60 "private/Game/Utility.hs" #-}+     (\a b -> mergeChoice a b == mergeChoice b (a :: Choice Char))
test/Test/Mastermind.hs view
@@ -1,24 +1,21 @@-module Test.Mastermind (tests) where+module Test.Mastermind 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.NonEmptyEnumSet as NonEmptySet import qualified Game.Mastermind as MM-import Game.Utility (Choice, mergeChoice, noChoice) -import Control.Monad (liftM2, )-import Control.Applicative ((<$>), )+import Control.Applicative (liftA2, (<$>))  import qualified Data.NonEmpty.Class as NonEmptyC import qualified Data.NonEmpty as NonEmpty import qualified Data.Traversable as Trav-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, (==>), )+import Test.QuickCheck (Property, Arbitrary(arbitrary), (==>), )   alphabet :: EnumSet Int@@ -50,20 +47,14 @@  genCodePair :: Int -> QC.Gen CodePair genCodePair width =-   liftM2-      (\(Code xs) (Code ys) ->-         uncurry CodePair $ unzip $ zip xs ys)+   liftA2+      (\(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]@@ -73,63 +64,10 @@ 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 (EnumSet.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 :: (NonEmptyC.Gen f) => Int -> QC.Gen (f [Int]) genFixedLengthCodes width = NonEmptyC.genOf $ QC.vectorOf width genElement @@ -179,56 +117,3 @@  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) :-   ("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) :-   ("choiceLeftIdentity", quickCheck choiceLeftIdentity) :-   ("choiceRightIdentity", quickCheck choiceRightIdentity) :-   ("choiceCommutative", quickCheck choiceCommutative) :-   -- ("choiceAssociative", quickCheck choiceAssociative) :-   []