diff --git a/Changes.md b/Changes.md
--- a/Changes.md
+++ b/Changes.md
@@ -1,5 +1,9 @@
 # Change log for the `board-games` package
 
+## 0.4
+
+ * `Labyrinth`: New game "Das verrückte Labyrinth".
+
 ## 0.3
 
  * `Mastermind.CodeSet`:
diff --git a/Makefile b/Makefile
--- a/Makefile
+++ b/Makefile
@@ -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
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.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,
diff --git a/demo/Server.hs b/demo/Server.hs
--- a/demo/Server.hs
+++ b/demo/Server.hs
@@ -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 $
diff --git a/demo/Server/Option.hs b/demo/Server/Option.hs
--- a/demo/Server/Option.hs
+++ b/demo/Server/Option.hs
@@ -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 ->
diff --git a/private/Game/Utility.hs b/private/Game/Utility.hs
--- a/private/Game/Utility.hs
+++ b/private/Game/Utility.hs
@@ -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)
diff --git a/src/Game/Labyrinth.hs b/src/Game/Labyrinth.hs
new file mode 100644
--- /dev/null
+++ b/src/Game/Labyrinth.hs
@@ -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)
+-}
diff --git a/src/Game/Mastermind.hs b/src/Game/Mastermind.hs
--- a/src/Game/Mastermind.hs
+++ b/src/Game/Mastermind.hs
@@ -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 ()
diff --git a/src/Game/Mastermind/CodeSet.hs b/src/Game/Mastermind/CodeSet.hs
--- a/src/Game/Mastermind/CodeSet.hs
+++ b/src/Game/Mastermind/CodeSet.hs
@@ -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))
diff --git a/src/Game/Mastermind/CodeSet/Tree.hs b/src/Game/Mastermind/CodeSet/Tree.hs
--- a/src/Game/Mastermind/CodeSet/Tree.hs
+++ b/src/Game/Mastermind/CodeSet/Tree.hs
@@ -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
diff --git a/src/Game/Mastermind/HTML.hs b/src/Game/Mastermind/HTML.hs
--- a/src/Game/Mastermind/HTML.hs
+++ b/src/Game/Mastermind/HTML.hs
@@ -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)
diff --git a/src/Game/VierGewinnt/HTML.hs b/src/Game/VierGewinnt/HTML.hs
--- a/src/Game/VierGewinnt/HTML.hs
+++ b/src/Game/VierGewinnt/HTML.hs
@@ -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)
diff --git a/src/Game/ZeilenSpalten/HTML.hs b/src/Game/ZeilenSpalten/HTML.hs
--- a/src/Game/ZeilenSpalten/HTML.hs
+++ b/src/Game/ZeilenSpalten/HTML.hs
@@ -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)
 
diff --git a/test-module.list b/test-module.list
new file mode 100644
--- /dev/null
+++ b/test-module.list
@@ -0,0 +1,3 @@
+Game.Labyrinth
+Game.Mastermind
+Game.Utility
diff --git a/test/Test.hs b/test/Test.hs
--- a/test/Test.hs
+++ b/test/Test.hs
@@ -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
diff --git a/test/Test/Game/Labyrinth.hs b/test/Test/Game/Labyrinth.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Game/Labyrinth.hs
@@ -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))
diff --git a/test/Test/Game/Mastermind.hs b/test/Test/Game/Mastermind.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Game/Mastermind.hs
@@ -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)
diff --git a/test/Test/Game/Utility.hs b/test/Test/Game/Utility.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Game/Utility.hs
@@ -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))
diff --git a/test/Test/Mastermind.hs b/test/Test/Mastermind.hs
--- a/test/Test/Mastermind.hs
+++ b/test/Test/Mastermind.hs
@@ -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) :
-   []