diff --git a/Changes.md b/Changes.md
--- a/Changes.md
+++ b/Changes.md
@@ -1,5 +1,33 @@
 # Change log for the `set-cover` package
 
+## 0.1
+
+ * `SetCover.Exact.decisionTree`, `SetCover.Exact.Priority.decisionTree`:
+   Allow the programmer to generate human-friendly solutions.
+
+ * `SetCover.Cuboid`: `dx`, `dy`, `dz` -> `rotX`, `rotY`, `rotZ`
+
+ * `SetCover.Bit`: method `complement` replaced by `difference`.
+   This way, we do not need the cumbersome `SetCover.IntSet` module anymore.
+
+ * `SetCover.BitMap` made private.
+
+ * `SetCover.BitPriorityQueue` made public.
+
+ * `SetCover.Exact.State.usedSubsets`: Only store labels, not assignments.
+   This is consistent with `SetCover.Exact.Priority.State`.
+
+ * `SetCover.Exact.minimize`: allow an empty list of available subsets
+   `SetCover.Exact.step`, `SetCover.Exact.Priority.step`:
+   They do not need to test for an empty `availableSubset` anymore.
+
+ * `SetCover.Exact.step`: Require non-empty set of free elements.
+   This is consistent with `SetCover.Exact.Priority.step`.
+   Until now, `step` returned an empty list if the were no free elements.
+   This is not very helpful
+   since it will throw away already completed solutions.
+   The test is also redundant when `step` is called from `search`.
+
 ## 0.0.8
 
  * `SetCover.Exact.Priority` implements the Algorithm X
diff --git a/Makefile b/Makefile
new file mode 100644
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,9 @@
+run-test:
+	runhaskell Setup configure --user -fbuildExamples --enable-tests
+	runhaskell Setup build
+	runhaskell Setup configure --user -fbuildExamples -fllvm --enable-tests --enable-benchmarks
+	runhaskell Setup build
+	runhaskell Setup haddock
+	dist/build/set-cover-test/set-cover-test
+# more portable, but suppresses live QuickCheck test counter:
+#	runhaskell Setup test --show-details=streaming
diff --git a/example/ConwayPuzzle.hs b/example/ConwayPuzzle.hs
new file mode 100644
--- /dev/null
+++ b/example/ConwayPuzzle.hs
@@ -0,0 +1,182 @@
+{- |
+Conway's puzzle:
+
+Assemble a 5x5x5 cube from the following cuboids:
+ 3x 1x1x3
+29x 1x2x2
+
+https://en.wikipedia.org/wiki/Conway_puzzle
+-}
+module Main where
+
+import qualified Math.SetCover.Cuboid as Cuboid
+import qualified Math.SetCover.Exact as ESC
+import Math.SetCover.Cuboid (Size, Coords(Coords))
+
+import qualified Control.Concurrent.PooledIO.Independent as Pool
+import qualified Control.Monad.Trans.State as MS
+import Control.Applicative (pure, liftA2, liftA3)
+
+import qualified Data.Foldable as Fold
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Data.List as List
+import Data.IntSet (IntSet)
+import Data.Foldable (foldMap)
+
+import qualified System.IO as IO
+import Text.Printf (printf)
+import Utility (hPutStrLnImmediate)
+
+
+size :: Size
+size = pure 5
+
+
+stick :: [Int]
+stick = [0..2]
+
+type Mask = Set.Set (Maybe (Coords Int))
+type FormatMask = Set.Set (Coords Int)
+
+sticksX, sticksY, sticksZ :: [FormatMask]
+sticksX =
+   map Set.fromList $ Cuboid.allPositions size $ map (\x -> Coords x 0 0) stick
+sticksY =
+   map Set.fromList $ Cuboid.allPositions size $ map (\x -> Coords 0 x 0) stick
+sticksZ =
+   map Set.fromList $ Cuboid.allPositions size $ map (\x -> Coords 0 0 x) stick
+
+data Coord = X | Y | Z deriving (Eq, Ord, Show)
+
+count :: FormatMask -> Map.Map (Coord, Int, Int) Int
+count =
+   Map.fromListWith (+) .
+   concatMap (\(Coords x y z) -> [((X,y,z),1), ((Y,x,z),1), ((Z,x,y),1)]) .
+   Set.toList
+
+minimal :: FormatMask -> Bool
+minimal =
+   let center = pure 2
+       transforms =
+         map (\trans -> liftA2 (+) (liftA2 (-) center (trans center)) . trans) $
+         liftA2 (.) [id, fmap negate] Cuboid.rotations
+   in  \mask -> all (\trans -> mask <= Set.map trans mask) transforms
+
+assignsFromSticks ::
+   [(FormatMask, FormatMask, FormatMask)] ->
+   [ESC.Assign [FormatMask] FormatMask]
+assignsFromSticks =
+   map fst .
+   filter (minimal . snd) .
+   filter (Fold.all odd . count . snd) .
+   map
+      (\(x,y,z) ->
+         let u = x `Set.union` y `Set.union` z
+         in  (ESC.assign [x,y,z] u, u))
+
+{-
+Make use of the fact
+that all slices must contain an odd number of elements from 1x1x3 cuboids.
+-}
+threeSticksOrtho :: [ESC.Assign [FormatMask] FormatMask]
+threeSticksOrtho =
+   assignsFromSticks $
+   filter
+      (\(x,y,z) -> ESC.disjoint x y && ESC.disjoint y z && ESC.disjoint z x) $
+   liftA3 (,,) sticksX sticksY sticksZ
+
+
+selectDisjoint :: MS.StateT [FormatMask] [] FormatMask
+selectDisjoint =
+   MS.StateT $ \masks -> do
+      m:ms <- List.tails masks
+      return (m, filter (ESC.disjoint m) ms)
+
+threeSticks :: [ESC.Assign [FormatMask] FormatMask]
+threeSticks =
+   assignsFromSticks $
+   MS.evalStateT
+      (liftA3 (,,) selectDisjoint selectDisjoint selectDisjoint)
+      (sticksX ++ sticksY ++ sticksZ)
+
+
+square :: [(Int,Int)]
+square = liftA2 (,) [0,1] [0,1]
+
+squares :: [FormatMask]
+squares =
+   (map Set.fromList $
+    concatMap (Cuboid.allPositions size)
+      [map (\(x,y) -> Coords 0 x y) square,
+       map (\(x,y) -> Coords x 0 y) square,
+       map (\(x,y) -> Coords x y 0) square])
+
+allAssigns :: [ESC.Assign [FormatMask] Mask]
+allAssigns =
+   map (\mask -> ESC.assign [mask] (Set.map Just mask)) squares
+   ++
+   map (fmap (Set.insert Nothing . Set.map Just)) threeSticks
+
+
+threeSticksCanonical :: ESC.Assign [FormatMask] FormatMask
+threeSticksCanonical =
+   let x = Set.fromList [Coords 0 0 0, Coords 1 0 0, Coords 2 0 0]
+       y = Set.fromList [Coords 3 1 1, Coords 3 2 1, Coords 3 3 1]
+       z = Set.fromList [Coords 4 4 2, Coords 4 4 3, Coords 4 4 4]
+   in  ESC.assign [x,y,z] (x `Set.union` y `Set.union` z)
+
+initState ::
+   ESC.Assign [FormatMask] FormatMask ->
+   ESC.State [FormatMask] IntSet
+initState s3asn =
+   case ESC.intSetFromSetAssigns $
+         s3asn : map (\mask -> ESC.assign [mask] mask) squares of
+      asns@(s3:_) -> ESC.updateState s3 $ ESC.initState asns
+      [] -> error "ESC.bitVectorFromSetAssigns lost first assignment"
+
+
+formatIdent :: Int -> Char
+formatIdent n =
+   toEnum $
+   if n<10
+     then n + fromEnum '0'
+     else n-10 + fromEnum 'A'
+
+format :: [FormatMask] -> String
+format v =
+   let cubex =
+          Map.unions $
+          zipWith (\n -> foldMap (flip Map.singleton n)) [0..] $
+          reverse v
+   in  Cuboid.forNestedCoords
+          unlines (List.intercalate " | ") (List.intercalate " ")
+          (\c -> maybe "." (\n -> [formatIdent n]) $ Map.lookup c cubex)
+          size
+
+printMask :: [FormatMask] -> IO ()
+printMask = hPutStrLnImmediate IO.stdout . format
+
+
+mainSimple, mainCanonical, mainParallel :: IO ()
+mainSimple = do
+   let sol =
+         map concat $ ESC.partitions $ ESC.bitVectorFromSetAssigns allAssigns
+   mapM_ printMask sol
+   print $ length sol
+
+mainCanonical = do
+   let sol = map concat $ ESC.search $ initState threeSticksCanonical
+   mapM_ printMask sol
+   print $ length sol
+
+mainParallel =
+   Pool.run $
+      (\f -> zipWith f [0..] threeSticks) $ \n s3 ->
+         IO.withFile (printf "conway%04d.txt" (n::Int)) IO.WriteMode $ \h ->
+            mapM_ (hPutStrLnImmediate h . format . concat) $
+            ESC.search $ initState s3
+
+
+main :: IO ()
+main = mainCanonical
diff --git a/example/LCube.hs b/example/LCube.hs
--- a/example/LCube.hs
+++ b/example/LCube.hs
@@ -9,7 +9,7 @@
 import Math.SetCover.Cuboid
           (PackedCoords(PackedCoords), Coords, Size, forNestedCoords,
            allPositions, allOrientations, packCoords, unpackCoords,
-           dz, normalForm)
+           rotZ, normalForm)
 
 import qualified Control.Concurrent.PooledIO.Independent as Pool
 import qualified System.IO as IO
@@ -65,12 +65,12 @@
             (brickAssign $ normalForm $
              map rotate $ map (unpackCoords size) shape) $
          ESC.initState allAssigns)
-      [id, dz, dz.dz.dz]
+      [id, rotZ, rotZ.rotZ.rotZ]
 
 
 format :: [Mask] -> String
 format v =
-   let wuerfelx =
+   let cubex =
           Map.unions $
           zipWith (\n -> foldMap (flip Map.singleton n)) [0..] $
           reverse v
@@ -78,7 +78,7 @@
           unlines (intercalate " | ") (intercalate " ")
           (\c ->
              maybe "." (\n -> [toEnum $ n + fromEnum 'A']) $
-             Map.lookup (packCoords size c) wuerfelx)
+             Map.lookup (packCoords size c) cubex)
           size
 
 printMask :: [Mask] -> IO ()
@@ -102,14 +102,14 @@
 testme = mapM_ (printMask . (:[])) allMasks
 
 mainState = do
-   let lsg = concatMap ESC.search initStates
-   mapM_ printMask lsg
-   print $ length lsg
+   let sol = concatMap ESC.search initStates
+   mapM_ printMask sol
+   print $ length sol
 
 mainBits = do
-   let lsg = concatMap ESC.search $ map (fmap packMask) initStates
-   mapM_ printMask lsg
-   print $ length lsg
+   let sol = concatMap ESC.search $ map (fmap packMask) initStates
+   mapM_ printMask sol
+   print $ length sol
 
 mainParallel =
    Pool.runUnlimited $
diff --git a/example/LonposPyramid.hs b/example/LonposPyramid.hs
--- a/example/LonposPyramid.hs
+++ b/example/LonposPyramid.hs
@@ -20,8 +20,6 @@
 import qualified Math.SetCover.Cuboid as Cuboid
 import Math.SetCover.Cuboid (PackedCoords(PackedCoords), Coords(Coords), Size)
 
-import Control.Applicative (liftA2)
-
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 
@@ -204,22 +202,27 @@
  (0  0  2)
 
 With this matrix we could transform the coordinates
-such that we could use 'Cuboid.allOrientations' instead of 'rotations'.
+such that we could use 'Cuboid.allOrientations'.
 However, this would require a final division by 2.
 -}
 
-rotations :: Num a => [Coords a -> Coords a]
-rotations =
-   liftA2 (.)
-      [id, vertRot, vertRot.vertRot, vertRot.vertRot.vertRot]
-      [id, diagRot0, diagRot0.diagRot0, diagRot0.diagRot0.diagRot0,
-       diagRot1, diagRot1.diagRot1.diagRot1]
+primRotations :: Coords (Coords Int -> Coords Int)
+primRotations = Coords vertRot diagRot0 diagRot1
 
 transformedBrickAssign :: Size -> Brick -> [String] -> [Assign]
 transformedBrickAssign size k =
    map (brickAssign size k) . concatMap (Cuboid.allPositions size) .
-   Set.toList . Set.fromList .
-   (\ts -> map (Cuboid.normalForm . flip map ts) rotations) .
+   Cuboid.allOrientationsGen primRotations .
+   map (\(Coords y x z) -> Coords z y x) .
+   Cuboid.coordsFrom2LayerString
+
+brickSize :: Size
+brickSize = Coords 4 4 4
+
+testRotations :: [String] -> [Map.Map PackedCoords Brick]
+testRotations =
+   map (Map.fromList . map (flip (,) (Brick 0) . Cuboid.packCoords brickSize)) .
+   Cuboid.allOrientationsGen primRotations .
    map (\(Coords y x z) -> Coords z y x) .
    Cuboid.coordsFrom2LayerString
 
diff --git a/example/Mastermind.hs b/example/Mastermind.hs
--- a/example/Mastermind.hs
+++ b/example/Mastermind.hs
@@ -9,102 +9,82 @@
 -}
 module Main where
 
+import qualified Mastermind.Example as Example
+import qualified Mastermind.Guess as Guess
+import Mastermind.Distinguish (distinguishingCodesCondensed)
+import Mastermind.Utility (histogram)
+
+import Mastermind.Guess (
+   consistentCodes,
+   evaluate,
+   countEval,
+   codeFromLabels,
+   assignsFromGuesses,
+   defaultAssignFlags,
+   AssignFlags,
+   Eval,
+   EvalSumm(EvalSumm),
+   Row(Row), Column(Column),
+   )
+
+import qualified Math.SetCover.Exact.UArray as ESC_UArray
 import qualified Math.SetCover.Exact as ESC
 
 import qualified System.IO as IO
+import qualified Random as Random
 import System.Random (StdGen, getStdGen, randomR, )
 
+import Text.Printf (printf, )
+
 import qualified Control.Monad.Trans.State as MS
-import Control.Monad (liftM2, replicateM, when, )
+import Control.Monad (replicateM, when, void, )
+import Control.Applicative ((<$>), )
 
+import qualified Data.Map as Map; import Data.Map (Map, )
 import qualified Data.Set as Set; import Data.Set (Set, )
 import qualified Data.Array as Array
+import qualified Data.Foldable as Fold
 import qualified Data.List.Match as Match
 import qualified Data.List.HT as ListHT
-import Data.Tuple.HT (mapSnd, )
-import Data.List.HT (tails, viewL, viewR, )
-import Data.Maybe (mapMaybe, )
-
-
--- cf. htam:Combinatorics.tuples
-choose :: Int -> [a] -> [[a]]
-choose n xs =
-   flip MS.evalStateT xs $ replicateM n $
-   MS.StateT $ mapMaybe viewL . tails
+import qualified Data.List as List
+import Data.Foldable (foldMap, forM_, )
+import Data.List (intercalate, )
+import Data.Maybe (listToMaybe, isNothing, )
 
 
-data X = Pos Int | Eval Eval Int Int | EvalRow Eval Int
-        deriving (Eq, Ord, Show)
-
-data Eval = CorrectPlace | CorrectSymbol
-        deriving (Eq, Ord, Show)
-
-type Assign a = ESC.Assign [(Int, a)] (Set X)
-
-assignsFromGuesses ::
+consistentCodesRnd ::
    (Ord a) =>
-   Int -> [a] -> [([a], (Int,Int))] -> [Assign a]
-assignsFromGuesses width set guesses =
-   liftM2
-      (\pat a ->
-         let ks = map fst $ filter snd $ zip [0..] pat
-         in  ESC.assign (map (flip (,) a) ks) $ Set.unions $
-             Set.fromList (map Pos ks) :
-             zipWith
-                (\row (guess,_) ->
-                   Set.fromList $
-                   let (correctlyPlaced, remGuess) =
-                          ListHT.partition (\(_k, (used,equ)) -> used && equ) $
-                          zip [0..] $ zip pat $ map (a==) guess
-                   in  map (Eval CorrectPlace row . fst) correctlyPlaced
-                       ++
-                       map (Eval CorrectSymbol row . fst)
-                          (Match.take
-                             (filter (fst . snd) remGuess)
-                             (filter (snd . snd) remGuess)))
-                [0..] guesses)
-      (tail $ replicateM width [False, True]) set
-   ++
-   concat
-      (zipWith
-         (\row (_, (correctPlaces,correctSymbols)) ->
-            let fill eval k =
-                   map (ESC.assign [] . Set.fromList . (EvalRow eval row :)) $
-                   choose (width - k) $
-                   map (Eval eval row) $ take width [0..]
-            in  fill CorrectPlace correctPlaces
-                ++
-                fill CorrectSymbol correctSymbols)
-         [0..] guesses)
-
-
-codeFromLabels :: [[(Int, a)]] -> [a]
-codeFromLabels mxs =
-   case concat mxs of
-      xs -> Array.elems $ Array.array (0, length xs - 1) xs
+   AssignFlags -> Int -> [a] -> [([a], EvalSumm)] -> MS.State StdGen [[a]]
+consistentCodesRnd flags width alphabet guesses =
+   return . map codeFromLabels . ESC.partitions
+      =<< Random.intSetFromSetAssigns
+      =<< (Random.shuffle $ assignsFromGuesses flags width alphabet guesses)
 
 
-unique :: (Ord a) => [a] -> Bool
-unique xs = Set.size (Set.fromList xs) == length xs
-
-newGuess ::
+newGuess, newGuessMatching, newGuessRandom ::
    (Ord a) =>
-   Int -> [a] -> [([a], (Int,Int))] -> MS.State StdGen (Maybe [a])
-newGuess width alphabet oldGuesses = do
-   n <- MS.state $ randomR (1,1000)
-   return $ fmap snd $ viewR $ take n $
---      filter unique $
-      map codeFromLabels $ ESC.partitions $
-      assignsFromGuesses width alphabet oldGuesses
+   AssignFlags -> Int -> [a] -> [([a], EvalSumm)] -> MS.State StdGen (Maybe [a])
+newGuess = newGuessRandom
 
-countEval :: MS.State String (Int, Int)
-countEval =
-   let count c = fmap length $ MS.state $ ListHT.partition (c==)
-   in  liftM2 (,) (count 'x') (count 'o')
+{-
+Only guess codes that are consistent with all previously tried codes.
+This can lead to overly long guess sequences like
+@"master", "mastex", "mastey", "mastez"@ at the end of the game.
+-}
+newGuessMatching flags width alphabet oldGuesses =
+   listToMaybe <$> consistentCodesRnd flags width alphabet oldGuesses
 
-{- |
-In every round the computer player selects randomly one of the first 1000 codes
-that are coherent with the known evaluations.
+{-
+Start with random guesses and use matching guesses only at the end of the game.
+In order to make the attempts not obviously stupid
+we rule out elements from attempts with empty evaluations
+and stop searching for elements after an attempt with full evaluation.
+When we have acquired enough information to match the number of possible codes
+or when we reach a full evaluation,
+we switch to guessing consistent codes.
+
+As a consistent guess we use the first solution
+generated from randomly shuffled assignments with a randomly shuffled alphabet.
 This strategy prevents stupid guesses like "aaaaa",
 but it does not minimize the number of guesses.
 When the game approaches the end
@@ -113,48 +93,319 @@
 It would be more efficient to use non-coherent guesses in this situation
 in order to rule out a whole bunch of candidates at once.
 -}
+newGuessRandom flags width alphabet oldGuesses = do
+   let numPossibleEvals = div ((width+1)*(width+2)) 2
+   let numMoves =
+         floor
+           (logBase
+              (fromIntegral numPossibleEvals) (fromIntegral $ length alphabet)
+            * fromIntegral width :: Double)
+   let maybeCompleteEval =
+         List.find
+            ((\(EvalSumm correctPlaces correctSymbols) ->
+               correctPlaces + correctSymbols >= width) . snd) oldGuesses
+   let excluded =
+         foldMap (Set.fromList . fst) $
+         filter ((EvalSumm 0 0 ==) . snd) oldGuesses
+   let restricted =
+         case maybeCompleteEval of
+            Just (code, _) -> Set.toList $ Set.fromList code
+            Nothing -> filter (flip Set.notMember excluded) alphabet
+   if null restricted
+      then return Nothing
+      else
+         if length oldGuesses < numMoves && isNothing maybeCompleteEval
+            then
+               let arr = Array.listArray (0, length restricted - 1) restricted
+               in  fmap Just $ replicateM width $ fmap (arr Array.!) $
+                   MS.state $ randomR $ Array.bounds arr
+            else newGuessMatching flags width restricted oldGuesses
+
+formatEval :: EvalSumm -> String
+formatEval (EvalSumm correctPlaces correctSymbols) =
+   replicate correctPlaces 'x' ++ replicate correctSymbols 'o'
+
+formatEvalGuess :: (Show code) => (code, EvalSumm) -> String
+formatEvalGuess (guess, eval) = show guess ++ ' ' : formatEval eval
+
+
 interaction :: Int -> [Char] -> IO ()
 interaction width alphabet =
-   let go guesses g0 =
-          case MS.runState (newGuess width alphabet guesses) g0 of
-             (Nothing, _) -> putStrLn "contradicting evaluations"
+   let flags = defaultAssignFlags
+       go guesses g0 =
+          case MS.runState (newGuess flags width alphabet guesses) g0 of
+             (Nothing, _) -> do
+                putStrLn "Contradicting evaluations!"
+                putStr "Please enter your secret code "
+                putStrLn "and I will show you the corrected evaluations:"
+                secret <- getLine
+                forM_ (reverse guesses) $ \(guess,eval) ->
+                   let correctEval = evaluate secret guess
+                   in  when (correctEval /= eval) $ putStrLn $
+                       formatEvalGuess (guess, correctEval)
              (Just attempt, g1) -> do
                 putStr $ show attempt ++ " "
                 IO.hFlush IO.stdout
-                eval0 <- getLine
-                let ((numPlaces, numSymbols), evalRem) =
-                      MS.runState countEval eval0
+                (eval@(EvalSumm numPlaces _numSymbols), evalRem)
+                   <- MS.runState countEval <$> getLine
                 when (not $ null evalRem) (putStrLn $ "ignoring: " ++ evalRem)
                 if numPlaces >= width
                   then putStrLn "Code found!"
-                  else go ((attempt, (numPlaces, numSymbols)) : guesses) g1
+                  else go ((attempt, eval) : guesses) g1
    in  go [] =<< getStdGen
 
-testGuesses :: [(String, (Int, Int))]
-testGuesses =
-   map (mapSnd (MS.evalState countEval)) $
-   ("aaaayw", "x") :
-   ("bbbdcw", "") :
-   ("eefeym", "oo") :
-   ("iuzamf", "oo") :
-   ("gvarfe", "ooo") :
-   ("paqfes", "xxo") :
-   ("vamsej", "ooxx") :
-   ("amgses", "ooox") :
-   ("majgep", "xxx") :
-   []
-
-testSolve :: IO ()
-testSolve =
-   mapM_ (print . codeFromLabels) $ ESC.partitions $
-   assignsFromGuesses 6 ['a'..'z'] testGuesses
-
-
-main :: IO ()
-main = do
+mainGame :: IO ()
+mainGame = do
    let n = 5
    putStrLn $
       "Come up with a word consisting of " ++ show n ++
       " letters and evaluate my guesses."
    putStrLn "Enter 'x's for correct places and 'o's for correct symbols in any order."
    interaction n ['a'..'z']
+
+
+testSolve :: IO ()
+testSolve =
+   mapM_ print $ consistentCodes defaultAssignFlags 6 ['a'..'z'] $
+      Example.guesses_ Example.master
+
+
+mainDistinguishing :: IO ()
+mainDistinguishing =
+   let codes =
+         case 4::Int of
+            0 -> ["abcd", "abce", "abcf"]
+            1 -> ["abcdef", "abcdeg", "abcdeh"]
+            2 -> ["master", "puzzle", "bubble", "flight", "people"]
+            3 -> ["iuzamf", "gvarfe", "paqfes", "vamsej", "amgses", "majgep"]
+            _ -> ["hlskoel", "hoskell", "hlskoll", "klosehl"]
+
+   in mapM_ print $ take 10 $
+      distinguishingCodesCondensed defaultAssignFlags
+         (length $ head codes) ['a'..'z'] codes
+
+{-
+mainDistinguishing for ["hlskoel", "hoskell", "hlskoll", "klosehl"]:
+
+("koellhs",[EvalSumm 0 7,EvalSumm 1 6,EvalSumm 0 6,EvalSumm 2 5])
+("kolelhs",[EvalSumm 0 7,EvalSumm 1 6,EvalSumm 0 6,EvalSumm 2 5])
+("eolslhk",[EvalSumm 0 7,EvalSumm 1 6,EvalSumm 0 6,EvalSumm 2 5])
+("kolslhe",[EvalSumm 0 7,EvalSumm 1 6,EvalSumm 0 6,EvalSumm 3 4])
+("kollshe",[EvalSumm 0 7,EvalSumm 1 6,EvalSumm 0 6,EvalSumm 2 5])
+("sklleho",[EvalSumm 0 7,EvalSumm 1 6,EvalSumm 0 6,EvalSumm 2 5])
+("kslleho",[EvalSumm 0 7,EvalSumm 1 6,EvalSumm 0 6,EvalSumm 3 4])
+("khlleso",[EvalSumm 0 7,EvalSumm 1 6,EvalSumm 0 6,EvalSumm 2 5])
+("kslleoh",[EvalSumm 0 7,EvalSumm 1 6,EvalSumm 0 6,EvalSumm 2 5])
+("khlleos",[EvalSumm 0 7,EvalSumm 1 6,EvalSumm 0 6,EvalSumm 2 5])
+-}
+
+
+haskellCodes :: [String]
+haskellCodes =
+   "hoskell" : "hlskoel" : "hlskoll" : "klosehl" :
+   "hpskell" : "hlskpel" : "hlskpll" : "klpsehl" :
+   "haskell" : "hlskael" : "hlskall" : "klasehl" :
+   "heskell" : "hlsksel" : "hlsksll" : "klesehl" :
+   "hsskell" :
+   []
+
+groupSizesByEval :: (Ord a) => [[a]] -> [([a], Int)]
+groupSizesByEval codes =
+   decorate (Fold.maximum . histogram . flip map codes . evaluate) $
+   replicateM (length $ head codes) $
+   Set.toList $ foldMap Set.fromList codes
+
+decorate :: (a -> b) -> [a] -> [(a, b)]
+decorate f = map (\x -> (x, f x))
+
+{- |
+Return all elements that have minimal 'b'.
+-}
+allMinima :: (Ord b) => [(a,b)] -> ([a],b)
+allMinima [] = error "allMinima: empty list"
+allMinima ((a,b):abs_) =
+   let go as0 b0 [] = (reverse as0, b0)
+       go as0 b0 ((a1,b1):abs1) =
+         case compare b1 b0 of
+            LT -> go [a1] b1 abs1
+            EQ -> go (a1:as0) b1 abs1
+            GT -> go as0 b0 abs1
+   in  go [a] b abs_
+
+-- cf. board-games:Mastermind
+mainBestSeparation :: IO ()
+mainBestSeparation = do
+   let codes = haskellCodes
+   let (distCodes, groupSize) = allMinima $ groupSizesByEval codes
+   mapM_ print distCodes
+   let distCode = head distCodes
+   void $ printf "%s, max group size %d\n" distCode groupSize
+   mapM_ (putStrLn . formatEvalGuess) $ decorate (evaluate distCode) codes
+
+
+data Step a b c =
+     Attempt a
+   | Complete b
+   | Fail c
+
+data Choice = None | Unique | Multiple
+
+indentTree ::
+   ESC.Tree label set ->
+   [([Int], Step ((Choice, set), label, [label]) [label] (set, [label]))]
+indentTree =
+   let go numbers labels tree =
+         case tree of
+            ESC.Leaf -> [(numbers, Complete labels)]
+            ESC.Branch set subTrees ->
+               case subTrees of
+                  [(label,subTree)] ->
+                     (numbers, Attempt ((Unique, set), label, label:labels)) :
+                     go numbers (label:labels) subTree
+                  [] -> [(numbers, Fail (set, labels))]
+                  _ ->
+                     concatMap
+                        (\(k, (label,subTree)) ->
+                           (k:numbers,
+                            Attempt ((Multiple, set), label, label:labels)) :
+                           go (k:numbers) (label:labels) subTree) $
+                     zip [1 ..] subTrees
+   in  go [] []
+
+formatElement :: Guess.X Char -> String
+formatElement x =
+   case x of
+      Guess.EvalSymbol (Guess.Pos (Column col)) ->
+         printf "symbol at position %d" col
+      Guess.EvalSymbol (Guess.Eval eval (Row row) (Column col)) ->
+         printf
+            "choice whether a %s marker is at (%d,%d) or elsewhere"
+            (Guess.nameFromEval $ Just eval) row col
+      Guess.EvalSymbol (Guess.Symbol symbol) ->
+         printf "way of placing symbol '%c'" symbol
+      Guess.EvalRow eval (Row row) ->
+         printf "way of placing %s markers in row %d"
+            (Guess.nameFromEval $ Just eval) row
+      Guess.EvalReserve (Row row) (Column col) ->
+         printf
+            ("choice between correct place, " ++
+             "correct symbol or no marker at (%d,%d)")
+            row col
+
+formatReason :: (Choice, Set (Guess.X Char)) -> String
+formatReason (choice, set) =
+   let uniqueStr =
+         case choice of
+            None -> "no possible"
+            Unique -> "unique"
+            Multiple -> "try"
+   in  case Set.toList set of
+         [x] -> uniqueStr ++ " " ++ formatElement x
+         _ -> error "reason set must be a singleton"
+
+formatLabel :: Int -> Guess.Label Char -> String
+formatLabel width label =
+   case label of
+      Left (Row row, eval, pattern) ->
+         printf "pattern %s for %ss in row %d"
+            (Guess.formatPattern eval pattern) (Guess.nameFromEval eval) row
+      Right symbols ->
+         "place symbols " ++ partialCodeFromLabels width [symbols]
+
+evalMapFromLabel :: (Row, Maybe Eval, [Bool]) -> Map (Row,Column) (Maybe Eval)
+evalMapFromLabel (row, eval, pattern) =
+   Map.fromList $ map (\(col,_true) -> ((row,col), eval)) $
+   filter snd $ zip [Column 0 ..] pattern
+
+partialCodeFromLabels :: Int -> [[(Column, Char)]] -> String
+partialCodeFromLabels width xss =
+   Array.elems $
+      Array.listArray (Column 0, Column (width - 1)) (repeat '_')
+      Array.//
+      concat xss
+
+formatPatterns :: [(String, EvalSumm)] -> [Guess.Label Char] -> String
+formatPatterns guesses labels =
+   let (patternLabels, codeLabels) = ListHT.unzipEithers labels
+       m = fmap Guess.charFromEval $ foldMap evalMapFromLabel patternLabels
+       width = maximum $ map (length . fst) guesses
+   in  unlines $
+       zipWith
+         (\row (guess,_eval) ->
+            guess ++ ' ' :
+            (map (\col -> Map.findWithDefault '_' (row,col) m) $
+             Match.take guess [Column 0 ..]))
+         [Row 0 ..] guesses
+       ++
+       ["", partialCodeFromLabels width codeLabels]
+
+
+{-
+   assignsFromMatchingCodes defaultAssignFlags 6 ['a'..'z']
+      ["iuzamf", "gvarfe", "paqfes", "vamsej", "amgses"] -- , "majgep"]
+-}
+
+
+mainIntSet :: IO ()
+mainIntSet = do
+   let example = Example.haskell
+   mapM_ (putStrLn . Guess.codeFromLabels) $ ESC.partitions $
+      ESC.intSetFromSetAssigns $ Example.apply assignsFromGuesses example
+
+mainUArray :: IO ()
+mainUArray = do
+   let example = Example.cover
+   mapM_ (putStrLn . Guess.codeFromLabels) $ ESC_UArray.partitions $
+      Example.apply assignsFromGuesses example
+
+mainConsistent :: IO ()
+mainConsistent = print $ Example.apply consistentCodes Example.cover
+
+mainSolutions :: IO ()
+mainSolutions = do
+   let example = Example.cafe
+   mapM_ (putStrLn . formatPatterns (Example.guesses_ example)) $
+      ESC.partitions $ Example.apply assignsFromGuesses example
+
+mainTree :: IO ()
+mainTree = do
+   let example = Example.cafe
+       width = Example.width_ example
+       guesses = Example.guesses_ example
+       asns = Example.apply assignsFromGuesses example
+
+   forM_ (indentTree $ ESC.decisionTree asns) $ \(numbers, msg) ->
+      putStrLn $
+         (intercalate "." $ map show $ reverse numbers)
+         ++
+         (case msg of
+            Attempt (reason,label,_) ->
+               ": " ++ formatLabel width label ++
+               " - " ++ formatReason reason
+            Complete labels -> "\n\n" ++ formatPatterns guesses labels
+            Fail (reason,_) ->
+               ": failed because " ++ formatReason (None,reason))
+
+mainDetail :: IO ()
+mainDetail = do
+   let example = Example.cafe
+       width = Example.width_ example
+       guesses = Example.guesses_ example
+       asns = Example.apply assignsFromGuesses example
+
+   forM_ (indentTree $ ESC.decisionTree asns) $ \(numbers, msg) ->
+      putStrLn $
+         (intercalate "." $ map show $ reverse numbers)
+         ++
+         (case msg of
+            Attempt (reason,label,labels) ->
+               ": " ++ formatLabel width label ++
+               " - " ++ formatReason reason ++ "\n\n" ++
+               formatPatterns guesses labels
+            Complete _labels -> " - completed\n"
+            Fail (reason,_) ->
+               ": failed because " ++ formatReason (None,reason) ++ "\n")
+
+
+main :: IO ()
+main = mainGame
diff --git a/example/Mastermind/Benchmark.hs b/example/Mastermind/Benchmark.hs
new file mode 100644
--- /dev/null
+++ b/example/Mastermind/Benchmark.hs
@@ -0,0 +1,88 @@
+module Main where
+
+import qualified Mastermind.Test as Test
+
+import qualified Test.QuickCheck as QC
+import System.TimeIt (timeIt)
+
+import Data.Foldable (forM_, )
+
+
+main :: IO ()
+main =
+   forM_ Test.tests $ \(name, (_count, prop)) -> do
+      putStr $ name ++ ": "
+      timeIt $ QC.quickCheckWith (QC.stdArgs {QC.maxSuccess = 1000}) prop
+
+{-
+Shorter times without UseSymbol are a bit misleading,
+because the ten selected consistentCodes may contain duplicates.
+
+let n = 4
+let set = ['a'..'k']
+fromList []
++++ OK, passed 1000 tests.
+CPU time:   7.36s
++++ OK, passed 1000 tests.
+CPU time:  44.06s
+fromList [UseSymbolPos]
++++ OK, passed 1000 tests.
+CPU time:  21.70s
++++ OK, passed 1000 tests.
+CPU time: 134.35s
+fromList [UseSymbol]
++++ OK, passed 1000 tests.
+CPU time:  12.89s
++++ OK, passed 1000 tests.
+CPU time:  38.74s
+fromList [UseSymbol,UseSymbolPos]
++++ OK, passed 1000 tests.
+CPU time:  33.16s
++++ OK, passed 1000 tests.
+CPU time:  81.25s
+
+fromList [UniqueSymbol]
++++ OK, passed 1000 tests.
+CPU time:   0.88s
++++ OK, passed 1000 tests.
+CPU time:  14.94s
+fromList [UniqueSymbol,UseSymbolPos]
++++ OK, passed 1000 tests.
+CPU time:  58.38s
++++ OK, passed 1000 tests.
+CPU time: 266.46s
+fromList [UniqueSymbol,UseSymbol]
++++ OK, passed 1000 tests.
+CPU time:   1.34s
++++ OK, passed 1000 tests.
+CPU time:   9.20s
+fromList [UniqueSymbol,UseSymbol,UseSymbolPos]
++++ OK, passed 1000 tests.
+CPU time:  44.60s
++++ OK, passed 1000 tests.
+CPU time:  66.19s
+-}
+
+{-
+With EvalRow (Maybe Eval) we get:
+fromList []
++++ OK, passed 1000 tests.
+CPU time:   7.89s
++++ OK, passed 1000 tests.
+CPU time:  41.88s
+fromList [UseSymbol]
++++ OK, passed 1000 tests.
+CPU time:  10.57s
++++ OK, passed 1000 tests.
+CPU time:  33.61s
+fromList [UniqueSymbol]
++++ OK, passed 1000 tests.
+CPU time:   0.95s
++++ OK, passed 1000 tests.
+CPU time:  16.23s
+fromList [UniqueSymbol,UseSymbol]
++++ OK, passed 1000 tests.
+CPU time:   1.44s
++++ OK, passed 1000 tests.
+CPU time:   9.08s
+-}
diff --git a/example/Mastermind/Distinguish.hs b/example/Mastermind/Distinguish.hs
new file mode 100644
--- /dev/null
+++ b/example/Mastermind/Distinguish.hs
@@ -0,0 +1,130 @@
+module Mastermind.Distinguish where
+
+import Mastermind.Guess (
+   assignsFromCodeSymbols,
+   Eval(CorrectPlace, CorrectSymbol),
+   Row(Row), Column(Column),
+   AssignFlags,
+   EvalSumm(EvalSumm),
+   EvalSymbol(Eval),
+   )
+
+import qualified Math.SetCover.Exact as ESC
+
+import Control.Monad (replicateM, )
+
+import qualified Data.Set as Set; import Data.Set (Set, )
+import qualified Data.Array as Array
+import qualified Data.List.Match as Match
+import qualified Data.List.HT as ListHT
+import qualified Data.List as List
+import Data.Tuple.HT (mapPair, )
+import Data.Foldable (foldMap, )
+import Data.Ord.HT (comparing, )
+
+
+
+data X a = EvalSymbol (EvalSymbol a) | EvalRow Row | EvalSummary EvalSumm
+   deriving (Eq, Ord, Show)
+
+type Assign a = ESC.Assign (Either [(Column, a)] (Row, EvalSumm)) (Set (X a))
+
+{-
+The solver is pretty slow with these assignments.
+E.g. for the codes @["abw", "abx", "aby", "abz"]@
+there cannot be a distinguishing code,
+so there cannot be one for @["abcw", "abcx", "abcy", "abcz"]@.
+However, the solver cannot draw this conclusion by itself.
+Another example:
+The evaluation summary @EvalSumm (width-1) 1@ is impossible.
+The solver should detect this automatically.
+
+Maybe it is possible to assist the solver with redundant information
+that the evaluations must be pairwise distinct
+and even more must be pairwise and pointwise distinct.
+However, the example above shows that searching for a distinguishing code
+might be of limited utility after all.
+-}
+assignsFromMatchingCodes ::
+   (Ord a) => AssignFlags -> Int -> [a] -> [[a]] -> [Assign a]
+assignsFromMatchingCodes flags width set codes =
+   map
+      (\(ESC.Assign label sym) ->
+         ESC.Assign (Left label) (Set.map EvalSymbol sym))
+      (assignsFromCodeSymbols flags width set codes)
+   ++
+   concat
+      (map
+         (\row ->
+            map
+               (\xs ->
+                  let fill eval =
+                         mapPair
+                            (length,
+                             map (EvalSymbol . Eval eval row . fst)) $
+                         ListHT.partition ((Just eval ==) . snd) $
+                         zip [Column 0 ..] xs
+                      (correctPlaces, remPlaces) = fill CorrectPlace
+                      (correctSymbols, remSymbols) = fill CorrectSymbol
+                      evalSumm = EvalSumm correctPlaces correctSymbols
+                  in  ESC.assign (Right (row, evalSumm)) . Set.fromList $
+                      EvalRow row : EvalSummary evalSumm :
+                      remPlaces ++ remSymbols) $
+            replicateM width [Nothing, Just CorrectPlace, Just CorrectSymbol]) $
+       Match.take codes [Row 0 ..])
+   ++
+   (do correctPlaces <- [0..width]
+       correctSymbols <- [0..width-correctPlaces]
+       return . ESC.assign (Left []) . Set.singleton $
+         EvalSummary $ EvalSumm correctPlaces correctSymbols)
+
+
+{- |
+For a given list of codes,
+find a guess that has different evaluations with respect to all of these codes.
+If we know at a certain point in the game
+that there is only a small number of possible codes left,
+we can use this procedure to find a guess that solves the puzzle immediately.
+E.g. @distinguishingCodes 6 ['a'..'z'] ["master", "puzzle", "bubble"] == [..., "jalbay", ...]@
+because @map (eval "jalbay") ["master", "puzzle", "bubble"] == [Eval 0 1, Eval 1 0, Eval 1 1]@
+
+Problem:
+For 4 6-letter codes the solution takes several seconds,
+for more letters it does not finish within an hour.
+Thus this approach is not practical.
+
+Example:
+There is no distinguishing code for @["abcdew", "abcdex", "abcdey", "abcdez"]@,
+but the solver does not detect that in reasonable time.
+
+If we would not only have a list of codes
+but also a corresponding list of evaluations
+the problem would boil down to the one addressed by 'assignsFromGuesses'.
+-}
+distinguishingCodes ::
+   (Ord a) => AssignFlags -> Int -> [a] -> [[a]] -> [([a], [EvalSumm])]
+distinguishingCodes flags width set codes =
+   map (mapPair (codeFromLabels, map snd . List.sortBy (comparing fst)) .
+        ListHT.unzipEithers) $
+   ESC.partitions $ ESC.intSetFromSetAssigns $
+   assignsFromMatchingCodes flags width set codes
+
+{- |
+Replace all unused symbols by a single one,
+because unused symbols behave the same way with respect to the @codes@.
+This returns a shorter list of codes but is also much faster.
+-}
+distinguishingCodesCondensed ::
+   (Ord a) => AssignFlags -> Int -> [a] -> [[a]] -> [([a], [EvalSumm])]
+distinguishingCodesCondensed flags width set codes =
+   let unused =
+         Set.deleteMin $ Set.difference (Set.fromList set) $
+         foldMap Set.fromList codes
+   in  distinguishingCodes flags width
+         (filter (flip Set.notMember unused) set) codes
+
+
+codeFromLabels :: [[(Column, a)]] -> [a]
+codeFromLabels mxs =
+   case concat mxs of
+      xs -> Array.elems $ Array.array (Column 0, Column (length xs - 1)) xs
diff --git a/example/Mastermind/Example.hs b/example/Mastermind/Example.hs
new file mode 100644
--- /dev/null
+++ b/example/Mastermind/Example.hs
@@ -0,0 +1,118 @@
+module Mastermind.Example where
+
+import Mastermind.Guess (
+   countEval,
+   defaultAssignFlags,
+   AssignFlag(UniqueSymbol),
+   AssignFlags,
+   EvalSumm(EvalSumm),
+   )
+
+
+import qualified Control.Monad.Trans.State as MS
+
+import qualified Data.EnumSet as EnumSet
+import Data.Tuple.HT (mapSnd)
+
+
+data T a =
+   Cons {
+      flags_ :: AssignFlags,
+      width_ :: Int,
+      alphabet_ :: [a],
+      guesses_ :: [([a], EvalSumm)]
+   }
+
+consDup, consUnique :: [a] -> [([a], EvalSumm)] -> T a
+consDup set guesses =
+   let width = maximum $ map (length . fst) guesses
+   in Cons defaultAssignFlags width set guesses
+
+consUnique set guesses =
+   case consDup set guesses of
+      ex -> ex {flags_ = EnumSet.insert UniqueSymbol $ flags_ ex}
+
+apply ::
+   (AssignFlags -> Int -> [a] -> [([a], EvalSumm)] -> b) -> T a -> b
+apply f (Cons flags width set guesses) = f flags width set guesses
+
+
+cover :: T Char
+cover =
+   consDup ['a'..'z'] $
+      ("prxyt", EvalSumm 0 1) :
+      ("smbjy", EvalSumm 0 0) :
+      ("krpcu", EvalSumm 0 2) :
+      ("ccxlz", EvalSumm 1 0) :
+      ("rltxk", EvalSumm 0 1) :
+      ("epakz", EvalSumm 0 1) :
+      ("acivr", EvalSumm 1 2) :
+      ("cqqar", EvalSumm 2 0) :
+      ("cfver", EvalSumm 4 0) :
+      ("wnhgd", EvalSumm 0 0) :
+      []
+
+coverContra :: T Char
+coverContra =
+   cover{
+      guesses_ = ("ocver", EvalSumm 3 0) : guesses_ cover
+   }
+
+cafe :: T Char
+cafe =
+   consUnique ['a'..'f'] $
+      ("cbad", EvalSumm 1 1) :
+      ("fbec", EvalSumm 0 3) :
+      ("beaf", EvalSumm 0 3) :
+      []
+
+master :: T Char
+master =
+   consDup ['a'..'z'] $
+   map (mapSnd (MS.evalState countEval)) $
+   ("aaaayw", "x") :
+   ("bbbdcw", "") :
+   ("eefeym", "oo") :
+   ("iuzamf", "oo") :
+   ("gvarfe", "ooo") :
+   ("paqfes", "xxo") :
+   ("vamsej", "ooxx") :
+   ("amgses", "ooox") :
+   ("majgep", "xxx") :
+   []
+
+haskell :: T Char
+haskell =
+   consDup ['a'..'z'] $
+   map (mapSnd (MS.evalState countEval)) $
+      ("dkryqnx", "o") :
+      ("dcyuyjj", "") :
+      ("bxfbrsf", "o") :
+      ("hgqmihi", "x") :
+      ("itkwkkm", "o") :
+      ("ixzrlkk", "oo") :
+      ("kgslggl", "xxoo") :
+      ("ggglvxw", "o") :
+      ("llskehl", "xxxxoo") :
+      []
+
+no00, no01, no02, no03, no04 :: T Char
+no00 =
+   consDup ['a'..'f'] $
+      ("adab", EvalSumm 0 0) :
+      []
+
+no01 =
+   consDup ['a'..'c'] $
+      ("aaab", EvalSumm 1 1) :
+      []
+
+no02 =
+   consDup ['a'..'f'] $
+      ("ffce", EvalSumm 1 2) :
+      ("dade", EvalSumm 2 0) :
+      ("dcfe", EvalSumm 2 1) :
+      []
+
+no03 = consDup ['a'..'c'] [("ab", EvalSumm 1 0)]
+no04 = consDup ['a'..'c'] [("ab", EvalSumm 1 1)]
diff --git a/example/Mastermind/Guess.hs b/example/Mastermind/Guess.hs
new file mode 100644
--- /dev/null
+++ b/example/Mastermind/Guess.hs
@@ -0,0 +1,244 @@
+module Mastermind.Guess where
+
+import Mastermind.Utility (histogram)
+
+import qualified Math.SetCover.Exact as ESC
+
+import qualified Control.Monad.Trans.State as MS
+import Control.Monad (liftM2, replicateM, guard, )
+
+import qualified Data.EnumSet as EnumSet; import Data.EnumSet (EnumSet, )
+import qualified Data.Map as Map
+import qualified Data.Set as Set; import Data.Set (Set, )
+import qualified Data.Foldable as Fold
+import qualified Data.Array as Array
+import qualified Data.Monoid.HT as Mn
+import qualified Data.List.Match as Match
+import qualified Data.List.HT as ListHT
+import qualified Data.List as List
+import Data.Tuple.HT (mapPair, )
+import Data.Maybe.HT (toMaybe)
+import Data.Traversable (forM, )
+
+
+data EvalSymbol a = Pos Column | Eval Eval Row Column | Symbol a
+        deriving (Eq, Ord, Show)
+
+data Eval = CorrectPlace | CorrectSymbol
+        deriving (Eq, Ord, Show)
+
+
+newtype Row = Row Int deriving (Eq, Ord, Show)
+
+instance Enum Row where
+   toEnum = Row
+   fromEnum (Row k) = k
+
+
+newtype Column = Column Int deriving (Eq, Ord, Show, Array.Ix)
+
+instance Enum Column where
+   toEnum = Column
+   fromEnum (Column k) = k
+
+
+{- |
+* 'UniqueSymbol': Only consider codes where every symbol is unique.
+
+* 'UseSymbol': Avoid duplicates in 'consistentCodes'. See below.
+
+> *Main> consistentCodes EnumSet.empty 2 ['a'..'b'] []
+> ["aa","ab","ba","bb","aa","bb"]
+> *Main> consistentCodes (EnumSet.singleton UseSymbol) 2 ['a'..'b'] []
+> ["ab","ba","aa","bb"]
+-}
+data AssignFlag = UniqueSymbol | UseSymbol
+   deriving (Eq, Ord, Show, Enum)
+
+type AssignFlags = EnumSet AssignFlag
+
+defaultAssignFlags :: AssignFlags
+defaultAssignFlags = EnumSet.fromList [UseSymbol]
+
+allFlagSets :: [AssignFlags]
+allFlagSets = [EnumSet.empty, EnumSet.singleton UseSymbol]
+
+assignsFromCodeSymbols ::
+   (Ord a) =>
+   AssignFlags ->
+   Int -> [a] -> [[a]] -> [ESC.Assign [(Column, a)] (Set (EvalSymbol a))]
+assignsFromCodeSymbols flags width set codes =
+  let uniqueSymbol = EnumSet.member UniqueSymbol flags
+      useSymbol    = EnumSet.member UseSymbol    flags
+  in
+   liftM2
+      (\pat a ->
+         let ks = map fst $ filter snd $ zip [Column 0 ..] pat
+         in  ESC.assign (map (flip (,) a) ks) $ Set.unions $
+             Mn.when useSymbol (Set.singleton (Symbol a)) :
+             Set.fromList (map Pos ks) :
+             zipWith
+                (\row code ->
+                   Set.fromList $
+                   let (correctlyPlaced, remCode) =
+                          ListHT.partition (\(_k, (used,equ)) -> used && equ) $
+                          zip [Column 0 ..] $ zip pat $ map (a==) code
+                   in  map (Eval CorrectPlace row . fst) correctlyPlaced
+                       ++
+                       map (Eval CorrectSymbol row . fst)
+                          (Match.take
+                             (filter (fst . snd) remCode)
+                             (filter (snd . snd) remCode)))
+                [Row 0 ..] codes)
+      ((if useSymbol then id else tail) $
+       if uniqueSymbol
+         then take (width+1) $ map (take width) $
+              scanl (flip (:)) (repeat False) (True : repeat False)
+         else replicateM width [False, True])
+      set
+
+
+{-
+For correctness,
+'X' would not need the 'Symbol' constructor and the type parameter @a@.
+I.e. it would not need any reference to symbols.
+For every symbol, @Set X@ describes its distribution pattern across all guesses.
+-}
+data X a = EvalSymbol (EvalSymbol a) | EvalReserve Row Column | EvalRow Eval Row
+        deriving (Eq, Ord, Show)
+
+type Label a = Either (Row, Maybe Eval, [Bool]) [(Column, a)]
+type Assign a = ESC.Assign (Label a) (Set (X a))
+
+data EvalSumm = EvalSumm Int Int deriving (Eq, Ord, Show)
+
+{-
+For every symbol and every distribution pattern within a code
+@assignsFromCodeSymbols@ computes the resulting evaluation pins
+bound to according positions.
+The second part (@concat@) marks the possible positions
+by filling out the remaining positions with @EvalSymbol (Eval eval row colum)@.
+@EvalReserve@ is used to avoid use of a position
+for both correctly placed and wrongly placed symbols.
+Without this mechanism we get this bug:
+
+> Main> take 10 $ consistentCodes 2 ['a'..'c'] [("ab", EvalSumm 1 1)]
+> ["aa","bb"]
+-}
+assignsFromGuesses ::
+   (Ord a) => AssignFlags -> Int -> [a] -> [([a], EvalSumm)] -> [Assign a]
+assignsFromGuesses flags width set guesses =
+   map
+      (\(ESC.Assign label sym) ->
+         ESC.Assign (Right label) (Set.map EvalSymbol sym))
+      (assignsFromCodeSymbols flags width set $ map fst guesses)
+   ++
+   concat
+      (zipWith
+         (\row (_, EvalSumm correctPlaces correctSymbols) ->
+            let fill eval k =
+                   map
+                      (\pattern ->
+                         ESC.assign (Left (row, Just eval, pattern)) .
+                         Set.fromList . (EvalRow eval row :) .
+                         uncurry (++) .
+                         mapPair
+                            (map (EvalReserve row . fst),
+                             map (EvalSymbol . Eval eval row . fst)) .
+                         ListHT.partition snd . zip [Column 0 ..] $ pattern) $
+                   choose width k
+            in  fill CorrectPlace correctPlaces
+                ++
+                fill CorrectSymbol correctSymbols
+                ++
+                map
+                   (\pattern ->
+                      ESC.assign (Left (row, Nothing, pattern)) .
+                      Set.fromList .
+                      map (EvalReserve row . fst) .
+                      filter snd . zip [Column 0 ..] $ pattern)
+                   (choose width (width-correctPlaces-correctSymbols)))
+         [Row 0 ..] guesses)
+
+nameFromEval :: Maybe Eval -> String
+nameFromEval eval =
+   case eval of
+      Nothing -> "wrong symbol"
+      Just CorrectSymbol -> "correct symbol"
+      Just CorrectPlace -> "correct place"
+
+countEval :: MS.State String EvalSumm
+countEval =
+   let count c = fmap length $ MS.state $ ListHT.partition (c==)
+   in  liftM2 EvalSumm (count 'x') (count 'o')
+
+charFromEval :: Maybe Eval -> Char
+charFromEval eval =
+   case eval of
+      Nothing -> '.'
+      Just CorrectSymbol -> 'o'
+      Just CorrectPlace -> 'x'
+
+formatPattern :: Maybe Eval -> [Bool] -> String
+formatPattern eval =
+   let char = charFromEval eval
+   in  map (\b -> if b then char else '_')
+
+-- cf. combinatorial:Combinatorics.choose
+choose :: Int -> Int -> [[Bool]]
+choose n0 k0 =
+   flip MS.evalStateT k0 $ do
+   bits <-
+      forM [n0,n0-1..1] $ \n ->
+      MS.StateT $ \k ->
+      guard (0<=k && k<=n) >> [(False, k), (True, pred k)]
+   MS.gets (0==) >>= guard
+   return bits
+
+
+codeFromLabels :: [Label a] -> [a]
+codeFromLabels mxs =
+   case concatMap (either (const []) id) mxs of
+      xs -> Array.elems $ Array.array (Column 0, Column (length xs - 1)) xs
+
+
+consistentCodes ::
+   (Ord a) => AssignFlags -> Int -> [a] -> [([a], EvalSumm)] -> [[a]]
+consistentCodes flags width alphabet guesses =
+   map codeFromLabels $ ESC.partitions $ ESC.intSetFromSetAssigns $
+   assignsFromGuesses flags width alphabet guesses
+
+
+-- cf. board-games:Mastermind
+evaluate :: (Ord a) => [a] -> [a] -> EvalSumm
+evaluate code attempt =
+   uncurry EvalSumm $
+   mapPair
+      (length,
+       Fold.sum . uncurry (Map.intersectionWith min) .
+       mapPair (histogram,histogram) . unzip) $
+   ListHT.partition (uncurry (==)) $
+   zip code attempt
+
+
+{-
+These ones need exceptionally much time:
+
+> mapM_ (putStrLn . formatEvalGuess) $ autoPlay ['a'..'z'] "maple"
+> mapM_ (putStrLn . formatEvalGuess) $ autoPlay ['a'..'z'] "wheat"
+
+With the UniqueSymbol flag it becomes fast, again:
+
+> autoPlay (EnumSet.insert UniqueSymbol defaultAssignFlags)
+-}
+autoPlay :: (Ord a) => AssignFlags -> [a] -> [a] -> [([a], EvalSumm)]
+autoPlay flags set secret =
+   List.unfoldr
+      (\guesses ->
+         toMaybe (all ((secret/=) . fst) guesses) $
+         case consistentCodes flags (length secret) set guesses of
+            [] -> error "autoPlay: algorithm went wrong"
+            guess:_ ->
+               let evaluatedGuess = (guess, evaluate secret guess)
+               in  (evaluatedGuess, evaluatedGuess:guesses))
+      []
diff --git a/example/Mastermind/Test.hs b/example/Mastermind/Test.hs
new file mode 100644
--- /dev/null
+++ b/example/Mastermind/Test.hs
@@ -0,0 +1,83 @@
+module Mastermind.Test where
+
+import Mastermind.Guess (
+   autoPlay,
+   consistentCodes,
+   evaluate,
+   AssignFlag(UseSymbol, UniqueSymbol),
+   AssignFlags, allFlagSets,
+   EvalSumm(EvalSumm),
+   )
+
+import qualified Test.QuickCheck as QC
+
+import Control.Monad (liftM2, )
+import Control.Applicative ((<$>), )
+
+import qualified Data.EnumSet as EnumSet
+import qualified Data.List.HT as ListHT
+import Data.Maybe (listToMaybe, )
+
+
+-- cf. board-games:Test.Mastermind
+genEvalSumm :: Int -> QC.Gen EvalSumm
+genEvalSumm width = do
+   total <- QC.frequency $ map (\k -> (k+1, return k)) [1 .. width]
+   rightPlaces <- QC.choose (0,total)
+   return $ EvalSumm rightPlaces (total - rightPlaces)
+
+genGuess :: Int -> [a] -> QC.Gen [a]
+genGuess width set = QC.vectorOf width $ QC.elements set
+
+genGuessUnique :: Int -> [a] -> QC.Gen [a]
+genGuessUnique 0 _ = return []
+genGuessUnique width set = do
+   (x,xs) <- QC.elements $ ListHT.removeEach set
+   (x:) <$> genGuessUnique (width-1) xs
+
+genGuesses :: Int -> [a] -> QC.Gen [([a], EvalSumm)]
+genGuesses width set =
+   fmap (take 2) $ QC.listOf1 $
+   liftM2 (,) (genGuessUnique width set) (genEvalSumm width)
+
+genConsistentCode :: (Ord a) => AssignFlags -> Int -> [a] -> QC.Gen (Maybe [a])
+genConsistentCode flags width set =
+   listToMaybe . consistentCodes flags width set <$> genGuesses width set
+
+
+propConsistency ::
+   (Ord a) => AssignFlags -> Int -> [a] -> [([a], EvalSumm)] -> Bool
+propConsistency flags width set guesses =
+   and $
+   liftM2
+      (\(guess,eval) candidate -> eval == evaluate guess candidate)
+      guesses (take 10 $ consistentCodes flags width set guesses)
+
+propAutoPlay :: (Ord a) => AssignFlags -> [a] -> [a] -> Bool
+propAutoPlay flags set secret =
+   fst (last (autoPlay flags set secret)) == secret
+
+
+tests :: [(String, (Int, QC.Property))]
+tests =
+   let n = 4
+       set = ['a'..'k']
+       forAll count gen = (,) count . QC.forAll gen
+       formatFlags flags =
+         if EnumSet.member UseSymbol flags
+           then "UseSymbol"
+           else "OmitSymbol"
+
+   in (allFlagSets >>= \flags ->
+         ("Duplicate.Consistency." ++ formatFlags flags,
+          forAll 500 (genGuesses n set) (propConsistency flags n set)) :
+         ("Duplicate.AutoPlay." ++ formatFlags flags,
+          forAll 100 (genGuess n set) (propAutoPlay flags set)) :
+         [])
+      ++
+      (map (EnumSet.insert UniqueSymbol) allFlagSets >>= \flags ->
+         ("Unique.Consistency." ++ formatFlags flags,
+          forAll 1000 (genGuesses n set) (propConsistency flags n set)) :
+         ("Unique.AutoPlay." ++ formatFlags flags,
+          forAll 200 (genGuessUnique n set) (propAutoPlay flags set)) :
+         [])
diff --git a/example/Mastermind/Utility.hs b/example/Mastermind/Utility.hs
new file mode 100644
--- /dev/null
+++ b/example/Mastermind/Utility.hs
@@ -0,0 +1,11 @@
+module Mastermind.Utility where
+
+import qualified Data.Map as Map; import Data.Map (Map, )
+
+
+histogram :: (Ord a) => [a] -> Map a Int
+histogram = Map.fromListWith (+) . attach 1
+
+{-# INLINE attach #-}
+attach :: b -> [a] -> [(a, b)]
+attach a = map (flip (,) a)
diff --git a/example/MastermindKnead.hs b/example/MastermindKnead.hs
new file mode 100644
--- /dev/null
+++ b/example/MastermindKnead.hs
@@ -0,0 +1,34 @@
+module Main where
+
+import qualified Mastermind.Example as Example
+import qualified Mastermind.Guess as Guess
+import Mastermind.Guess (assignsFromGuesses)
+
+import qualified Math.SetCover.Exact.Knead.Saturated as ESC_KneadSat
+import qualified Math.SetCover.Exact.Knead as ESC_Knead
+
+import qualified System.IO.Lazy as LazyIO
+
+
+mainKnead :: IO ()
+mainKnead = do
+   let example = Example.haskell
+   mapM_ (putStrLn . Guess.codeFromLabels) $ ESC_Knead.partitions $
+      Example.apply assignsFromGuesses example
+
+mainKneadIO :: IO ()
+mainKneadIO = do
+   let example = Example.master
+   partit <- ESC_Knead.partitionsIO
+   mapM_ (putStrLn . Guess.codeFromLabels) =<<
+      (LazyIO.run $ partit $ Example.apply assignsFromGuesses example)
+
+mainKneadVector :: IO ()
+mainKneadVector = do
+   let example = Example.haskell
+   mapM_ (putStrLn . Guess.codeFromLabels) $ ESC_KneadSat.partitions $
+      Example.apply assignsFromGuesses example
+
+
+main :: IO ()
+main = mainKnead
diff --git a/example/Nonogram.hs b/example/Nonogram.hs
--- a/example/Nonogram.hs
+++ b/example/Nonogram.hs
@@ -12,24 +12,27 @@
 import qualified Nonogram.Encoding.BlackWhite as BlackWhite
 import qualified Nonogram.Encoding.Plug as Plug
 import qualified Nonogram.Encoding.Naive as Naive
-import Nonogram.Base (Strip, Color(White, Black))
+import Nonogram.Base (Strip, Color(White, Black), ColorMap)
 
 import qualified Math.SetCover.Exact.Priority as ESC
 import qualified Math.SetCover.Exact as ESCS
 import qualified Math.SetCover.BitPosition as BitPos
 import qualified Math.SetCover.BitSet as BitSet
+import qualified Math.SetCover.BitPriorityQueue as BitPQ
 import qualified Math.SetCover.Queue as Queue
 
-import qualified Data.OrdPSQ as PSQ; import Data.OrdPSQ (OrdPSQ)
 import qualified Data.Map as Map; import Data.Map (Map)
 import qualified Data.Set as Set; import Data.Set (Set)
 import qualified Data.EnumMap as EnumMap
 import qualified Data.NonEmpty as NonEmpty
 import qualified Data.List.HT as ListHT
+import Data.OrdPSQ (OrdPSQ)
 import Data.IntPSQ (IntPSQ)
 import Data.EnumSet (EnumSet)
+import Data.IntSet (IntSet)
 import Data.Foldable (foldMap)
 import Data.NonEmpty ((!:))
+import Data.Word (Word64)
 
 
 decode :: [[Int]] -> [[Int]] -> [Set (Int, Int)]
@@ -78,7 +81,7 @@
       (take rows [0..])
       (take columns [0..])
 
-formatBW :: Int -> Int -> Map (Int, Int) Color -> String
+formatBW :: Int -> Int -> ColorMap -> String
 formatBW rows columns set =
    unlines $
    ListHT.outerProduct
@@ -114,6 +117,59 @@
 testImage :: IO ()
 testImage = decodeImage $ Example.encodeStrings Example.letterP
 
+
+type Evolve queue set = ([[Int]], [[Int]]) -> [[ESC.State queue ColorMap set]]
+
+evolveGen ::
+   Queue.Methods queue set ->
+   [ESCS.Assign ColorMap set] -> [[ESC.State queue ColorMap set]]
+evolveGen methods assigns =
+   takeWhile (not . null) $
+   iterate
+      (concatMap (ESC.step methods) .
+       filter (not . Queue.null methods . ESC.queue))
+      [ESC.initState methods assigns]
+
+evolveQueueMapBW ::
+   Evolve
+      (OrdPSQ Strip Int (OrdPSQ BlackWhite.Item Int (EnumSet Queue.SetId)))
+      (Map Strip (Set BlackWhite.Item))
+evolveQueueMapBW = evolveGen queueMap . uncurry BlackWhite.assignsBW
+
+evolveQueueMap ::
+   Evolve
+      (OrdPSQ Strip Int (OrdPSQ Combinatoric.Item Int (EnumSet Queue.SetId)))
+      (Map Strip (Set Combinatoric.Item))
+evolveQueueMap = evolveGen queueMap . uncurry Combinatoric.assignsBW
+
+evolveQueueMapBit ::
+   Evolve
+      (OrdPSQ Strip Int (IntPSQ Int (EnumSet Queue.SetId)))
+      (Map Strip (BitSet.Set Word64))
+evolveQueueMapBit =
+   evolveGen queueMapBit .
+   Combinatoric.bitAssigns . uncurry Combinatoric.assignsBW
+
+evolveQueueBitPQ ::
+   Evolve (BitPQ.Queue Integer Queue.SetId) (BitSet.Set Integer)
+evolveQueueBitPQ (rows, columns) =
+   evolveGen ESC.queueBitPQ $
+   Combinatoric.bitVectorAssigns (length rows) (length columns) $
+   Combinatoric.assignsBW rows columns
+
+evolveQueueBit ::
+   Evolve (IntPSQ Int (EnumSet Queue.SetId)) (BitSet.Set Integer)
+evolveQueueBit (rows, columns) =
+   evolveGen ESC.queueBit $
+   Combinatoric.bitVectorAssigns (length rows) (length columns) $
+   Combinatoric.assignsBW rows columns
+
+evolveQueueIntSet :: Evolve (IntPSQ Int (EnumSet Queue.SetId)) IntSet
+evolveQueueIntSet (rows, columns) =
+   evolveGen ESC.queueIntSet $
+   Combinatoric.intSetAssigns (length rows) (length columns) $
+   Combinatoric.assignsBW rows columns
+
 evolve :: ([[Int]], [[Int]]) -> IO ()
 evolve (rows, columns) =
    let formatIntermediate state =
@@ -122,9 +178,7 @@
            Map.unionsWith (error "conflicting colors") .
            ESC.usedSubsets $ state)
    in  mapM_ (putStrLn . besidesMany 2 . map formatIntermediate) $
-       fst $ ListHT.breakAfter (all (PSQ.null . ESC.queue)) $
-       iterate (concatMap (ESC.step queueMap))
-         [ESC.initState queueMap $ Combinatoric.assignsBW rows columns]
+       evolveQueueMap (rows, columns)
 
 main :: IO ()
 main = evolve Example.soccerEnc
diff --git a/example/Nonogram/Base.hs b/example/Nonogram/Base.hs
--- a/example/Nonogram/Base.hs
+++ b/example/Nonogram/Base.hs
@@ -35,7 +35,9 @@
 data Color = White | Black
    deriving (Eq, Ord, Show, Enum)
 
+type ColorMap = Map (Int,Int) Color
 
+
 noAssign :: (Monoid map) => set -> ESC.Assign map set
 noAssign = ESC.assign mempty
 
@@ -67,5 +69,5 @@
 square :: Int -> Int -> Color -> Set (Int,Int)
 square r c col = Mn.when (col==Black) $ Set.singleton (r,c)
 
-squareBW :: Int -> Int -> Color -> Map (Int,Int) Color
+squareBW :: Int -> Int -> Color -> ColorMap
 squareBW r c = Map.singleton (r,c)
diff --git a/example/Nonogram/Encoding/BlackWhite.hs b/example/Nonogram/Encoding/BlackWhite.hs
--- a/example/Nonogram/Encoding/BlackWhite.hs
+++ b/example/Nonogram/Encoding/BlackWhite.hs
@@ -18,12 +18,13 @@
   is combined with the space to the left and right border, respectively.
 -}
 module Nonogram.Encoding.BlackWhite
-         (assigns, assignsBW, bitAssigns, bitVectorAssigns) where
+         (Item, assigns, assignsBW, bitAssigns, bitVectorAssigns) where
 
 import qualified Nonogram.Base as Base
 import Nonogram.Base
          (Strip(Strip), strip, BrickId(BrickId),
-          Orientation(Horizontal, Vertical), Color(White, Black), noAssign)
+          Orientation(Horizontal, Vertical),
+          Color(White, Black), ColorMap, noAssign)
 
 import qualified Math.SetCover.BitSet as BitSet
 import qualified Math.SetCover.Exact as ESC
@@ -115,7 +116,7 @@
 assigns :: [[Int]] -> [[Int]] -> [Assign (Set (Int,Int))]
 assigns = assignsGen Base.square
 
-assignsBW :: [[Int]] -> [[Int]] -> [Assign (Map (Int,Int) Color)]
+assignsBW :: [[Int]] -> [[Int]] -> [Assign ColorMap]
 assignsBW = assignsGen Base.squareBW
 
 
diff --git a/example/Nonogram/Encoding/Combinatoric.hs b/example/Nonogram/Encoding/Combinatoric.hs
--- a/example/Nonogram/Encoding/Combinatoric.hs
+++ b/example/Nonogram/Encoding/Combinatoric.hs
@@ -6,12 +6,12 @@
 The solver tends to need very few guesses.
 -}
 module Nonogram.Encoding.Combinatoric
-         (assigns, assignsBW, bitAssigns, intSetAssigns, bitVectorAssigns) where
+         (Item, assigns, assignsBW, bitAssigns, intSetAssigns, bitVectorAssigns) where
 
 import qualified Nonogram.Base as Base
 import Nonogram.Base
          (Strip(Strip), strip, Orientation(Horizontal, Vertical),
-          Color(White, Black), noAssign)
+          Color(White, Black), ColorMap, noAssign)
 
 import qualified Math.SetCover.BitSet as BitSet
 import qualified Math.SetCover.Exact as ESC
@@ -92,7 +92,7 @@
 assigns :: [[Int]] -> [[Int]] -> [Assign (Set (Int,Int))]
 assigns = assignsGen Base.square
 
-assignsBW :: [[Int]] -> [[Int]] -> [Assign (Map (Int,Int) Color)]
+assignsBW :: [[Int]] -> [[Int]] -> [Assign ColorMap]
 assignsBW = assignsGen Base.squareBW
 
 
@@ -113,7 +113,8 @@
 
 
 intSetAssigns ::
-   Int -> Int -> [ESC.Assign map (Map Strip (Set Item))] -> [ESC.Assign map IntSet]
+   Int -> Int ->
+   [ESC.Assign map (Map Strip (Set Item))] -> [ESC.Assign map IntSet]
 intSetAssigns nr nc =
    map (fmap (fold . Map.mapWithKey (intSetFromItems nr nc)))
 
diff --git a/example/Random.hs b/example/Random.hs
new file mode 100644
--- /dev/null
+++ b/example/Random.hs
@@ -0,0 +1,65 @@
+module Random (intSetFromSetAssigns, shuffle) where
+
+import Mastermind.Utility (attach)
+
+import qualified Math.SetCover.Exact as ESC
+
+import System.Random (StdGen, randomR, )
+
+import qualified Control.Monad.Trans.State as MS
+import Control.Applicative ((<$>), )
+
+import qualified Data.Map as Map
+import qualified Data.IntSet as IntSet
+import qualified Data.Set as Set; import Data.Set (Set, )
+import qualified Data.Sequence as Seq; import Data.Sequence (Seq, )
+import Data.Tuple.HT (mapSnd, )
+import Data.Monoid ((<>), )
+
+
+{- |
+This is a variant of 'ESC.intSetFromSetAssigns'
+that includes shuffling of elements.
+This way, we can make 'consistentCodesRnd' prefer, say, symbol @z@ to @a@.
+-}
+intSetFromSetAssigns ::
+   (Ord a) =>
+   [ESC.Assign label (Set a)] ->
+   MS.State StdGen [ESC.Assign label IntSet.IntSet]
+intSetFromSetAssigns asns = do
+   toMapInt <- mapIntFromSet asns
+   let toIntSet = IntSet.fromList . Map.elems . toMapInt
+   return $ map (fmap toIntSet) asns
+
+-- cf. ESC
+mapIntFromSet ::
+   (Ord a) =>
+   [ESC.Assign label (Set a)] -> MS.State StdGen (Set a -> Map.Map a Int)
+mapIntFromSet asns = do
+   mapToInt <-
+      fmap (Map.fromList . flip zip [0..]) $
+      shuffle $ Set.toList $ ESC.unions $ map ESC.labeledSet asns
+   return $ Map.intersection mapToInt . constMap ()
+
+-- SetCover.EnumMap
+constMap :: (Ord a) => b -> Set.Set a -> Map.Map a b
+constMap a = Map.fromAscList . attach a . Set.toAscList
+
+
+shuffle :: [a] -> MS.State StdGen [a]
+shuffle = shuffleSeq . Seq.fromList
+
+shuffleSeq :: Seq a -> MS.State StdGen [a]
+shuffleSeq xs =
+   if Seq.null xs
+      then return []
+      else do
+         (y, ys) <- select xs
+         (y:) <$> shuffleSeq ys
+
+select :: Seq a -> MS.State StdGen (a, Seq a)
+select xs = do
+   k <- MS.state $ randomR (0, Seq.length xs - 1)
+   case mapSnd Seq.viewl $ Seq.splitAt k xs of
+      (_, Seq.EmptyL) -> error "Seq.size must have been zero"
+      (ys, z Seq.:< zs) -> return (z, ys <> zs)
diff --git a/example/Soma.hs b/example/Soma.hs
--- a/example/Soma.hs
+++ b/example/Soma.hs
@@ -69,12 +69,12 @@
 
 format :: [Map.Map PackedCoords Brick] -> String
 format v =
-   let wuerfelx = Map.unions v
+   let cubex = Map.unions v
    in  forNestedCoords
           unlines (intercalate " | ") (intercalate " ")
           (\c ->
              maybe "." (\(Brick n) -> show n) $
-             Map.lookup (packCoords size c) wuerfelx)
+             Map.lookup (packCoords size c) cubex)
           size
 
 printMask :: [Map.Map PackedCoords Brick] -> IO ()
@@ -121,18 +121,18 @@
 testme1 = testme $ Brick 1
 
 mainBase = do
-   let lsg = map (map ESC.label) $ nest (length shapes) (concatMap ew) [[]]
-   mapM_ printMask lsg
-   print $ length lsg
+   let sol = map (map ESC.label) $ nest (length shapes) (concatMap ew) [[]]
+   mapM_ printMask sol
+   print $ length sol
 
 mainState = do
-   let lsg = ESC.partitions allAssigns
-   mapM_ printMask lsg
-   print $ length lsg
+   let sol = ESC.partitions allAssigns
+   mapM_ printMask sol
+   print $ length sol
 
 mainBits = do
-   let lsg = ESC.partitions $ map (fmap packMask) allAssigns
-   mapM_ printMask lsg
-   print $ length lsg
+   let sol = ESC.partitions $ map (fmap packMask) allAssigns
+   mapM_ printMask sol
+   print $ length sol
 
 main = mainBits
diff --git a/example/Sudoku.hs b/example/Sudoku.hs
--- a/example/Sudoku.hs
+++ b/example/Sudoku.hs
@@ -9,22 +9,32 @@
 
 import Data.Word (Word32, Word64)
 
+import qualified Control.Monad.Trans.State as MS
 import Control.Monad (liftM3, guard)
 
+import qualified Random as Random
+import System.Random (StdGen, getStdGen, )
+
+import qualified Graphics.Ascii.Haha.Terminal as ANSI
+import Text.Printf (printf)
+
 import qualified Data.Array as Array
 import qualified Data.Map as Map
 import qualified Data.Set as Set
-import Data.Foldable (foldMap)
-import Data.Array (array)
+import Data.Foldable (foldMap, forM_)
+import Data.Array (array, listArray)
+import Data.IntSet (IntSet)
 import Data.Set (Set)
 import Data.List.HT (sliceVertical)
-import Data.List (intersperse)
+import Data.List (intersperse, intercalate)
+import Data.Tuple.HT (mapSnd)
 
 
 data X = Pos Int Int | Row Int Int | Column Int Int | Square Int Int Int
          deriving (Eq, Ord, Show)
 
-type Assign = ESC.Assign ((Int, Int), Int)
+type Cell = ((Int, Int), Int)
+type Assign = ESC.Assign Cell
 
 assign :: Int -> Int -> Int -> Assign (Set X)
 assign k i j =
@@ -66,14 +76,58 @@
 bitVectorAssigns :: [Assign BitVector]
 bitVectorAssigns = ESC.bitVectorFromSetAssigns assigns
 
+intSetAssigns :: [Assign IntSet]
+intSetAssigns = ESC.intSetFromSetAssigns assigns
 
-format :: [((Int, Int), Int)] -> String
+
+format :: [Cell] -> String
 format =
    unlines . map (intersperse ' ') . sliceVertical 9 . Array.elems .
    fmap (\n -> toEnum $ n + fromEnum '0') .
    array ((0,0),(8,8))
 
+formatSparse :: [Cell] -> String
+formatSparse =
+   unlines . map (intersperse ' ') . sliceVertical 9 . Array.elems .
+   (listArray ((0,0),(8,8)) (repeat '_') Array.//) .
+   map (mapSnd (\n -> toEnum $ n + fromEnum '0'))
 
+
+fgColor :: ANSI.Color -> String
+fgColor c = ANSI.clr (ANSI.fg c)
+
+highlightBars ::
+   (Array.Ix row, Array.Ix col) =>
+   [(row, (col, col))] ->
+   Array.Array (row, col) [Char] -> Array.Array (row, col) [Char]
+highlightBars bars arr =
+   Array.accum
+      (\str lr ->
+         if lr then ANSI.cyanBg ++ str else str ++ ANSI.resetBg) arr $
+   concatMap
+      (\(row,(left,right)) -> [((row,left),True), ((row,right),False)]) bars
+
+formatColored :: Set X -> Maybe Cell -> [Cell] -> String
+formatColored set current =
+   unlines . map (intercalate " ") . sliceVertical 9 . Array.elems .
+   highlightBars
+      (flip foldMap set $ \x ->
+       case x of
+         Pos _ _ -> []
+         Row _ row -> [(row, (0,8))]
+         Column _ col -> map (\row -> (row, (col,col))) [0..8]
+         Square _ row3 col3 ->
+            map (\row -> (row, (col3*3,col3*3+2))) [row3*3 .. row3*3+2]) .
+   (Array.//
+      maybe []
+         (\(currentPos, currentSym) ->
+            [(currentPos,
+              fgColor ANSI.Blue ++ show currentSym ++ fgColor ANSI.Reset)])
+         current) .
+   (listArray ((0,0),(8,8)) (repeat "_") Array.//) .
+   map (mapSnd show)
+
+
 exampleHawiki1 :: [String]
 exampleHawiki1 =
    "    6  8 " :
@@ -87,9 +141,21 @@
    "       5 " :
    []
 
+exampleRandom :: [String]
+exampleRandom =
+   " 2 8 9  5" :
+   "    2    " :
+   " 9       " :
+   "  19    7" :
+   "8   5   6" :
+   "2 9  8 5 " :
+   "  3      " :
+   " 1    8  " :
+   "    652 1" :
+   []
+
 stateFromString ::
-   (ESC.Set set) =>
-   [Assign set] -> [String] -> ESC.State ((Int, Int), Int) set
+   (ESC.Set set) => [Assign set] -> [String] -> ESC.State Cell set
 stateFromString asgns css =
    foldl (flip ESC.updateState) (ESC.initState asgns) $
    do let asnMap = foldMap (\asn -> Map.singleton (ESC.label asn) asn) asgns
@@ -102,7 +168,84 @@
             ((i,j), fromEnum c - fromEnum '0') asnMap
 
 
-main, mainAll, mainSolve, mainBit, mainBitVector :: IO ()
+data Step a b c =
+     Attempt a
+   | Complete b
+   | Fail c
+
+data Choice = None | Unique | Multiple
+
+indentTree ::
+   ESC.Tree label set ->
+   [([Int], Step ((Choice, set), label, [label]) [label] (set, [label]))]
+indentTree =
+   let go numbers labels tree =
+         case tree of
+            ESC.Leaf -> [(numbers, Complete labels)]
+            ESC.Branch set subTrees ->
+               case subTrees of
+                  [(label,subTree)] ->
+                     (numbers, Attempt ((Unique, set), label, label:labels)) :
+                     go numbers (label:labels) subTree
+                  [] -> [(numbers, Fail (set, labels))]
+                  _ ->
+                     concatMap
+                        (\(k, (label,subTree)) ->
+                           (k:numbers,
+                            Attempt ((Multiple, set), label, label:labels)) :
+                           go (k:numbers) (label:labels) subTree) $
+                     zip [1 ..] subTrees
+   in  go [] []
+
+formatReason :: (Choice, Set X) -> String
+formatReason (choice, set) =
+   let uniqueStr =
+         case choice of
+            None -> "no possible"
+            Unique -> "unique"
+            Multiple -> "try"
+   in  case Set.toList set of
+         [x] ->
+            case x of
+               Pos row col ->
+                  printf "%s number at position (%i,%i)" uniqueStr row col
+               Row k row ->
+                  printf "%s position of %i in row %i" uniqueStr k row
+               Column k col ->
+                  printf "%s position of %i in column %i" uniqueStr k col
+               Square k row3 col3 ->
+                  printf "%s position of %i in square (%i,%i)"
+                     uniqueStr k row3 col3
+         _ -> error "reason set must be a singleton"
+
+
+{- |
+This generates lots of Sudoku puzzles in a random way.
+However, I assume that it will not generate all possible sudokus,
+it may generate duplicates and they will certainly not be equally distributed.
+-}
+randomPuzzles :: MS.State StdGen [[Cell]]
+randomPuzzles =
+   return . ESC.partitions
+      =<< Random.intSetFromSetAssigns
+      =<< Random.shuffle assigns
+
+minimizePuzzle :: [Cell] -> [Cell]
+minimizePuzzle =
+   let asnMap = foldMap (\asn -> Map.singleton (ESC.label asn) asn) bitAssigns
+       lookupAssign =
+         flip (Map.findWithDefault (error "coordinates not available")) asnMap
+       go state xs (y:ys) =
+         case ESC.search $ foldl (flip ESC.updateState) state ys of
+            [_] -> go state xs ys
+            _ -> go (ESC.updateState y state) (ESC.label y : xs) ys
+       go _ xs [] = xs
+   in  go (ESC.initState bitAssigns) [] . map lookupAssign
+
+
+main, mainAll, mainSolve, mainBit, mainBitVector, mainIntSet,
+   mainTree, mainDetail, mainGenerate :: IO ()
+
 mainAll =
    mapM_ (putStrLn . format) $ ESC.partitions bitAssigns
 
@@ -118,4 +261,49 @@
    mapM_ (putStrLn . format) $ ESC.search $
    stateFromString bitVectorAssigns exampleHawiki1
 
-main = mainBitVector
+mainIntSet =
+   mapM_ (putStrLn . format) $ ESC.search $
+   stateFromString intSetAssigns exampleHawiki1
+
+mainTree = do
+   let s0 = stateFromString assigns exampleHawiki1
+   forM_ (indentTree $ ESC.completeTree s0) $ \(numbers, msg) ->
+      putStrLn $
+         (intercalate "." $ map show $ reverse numbers)
+         ++
+         (case msg of
+            Attempt (reason,(pos,k),_) ->
+               ": " ++ show k ++ " at " ++ show pos ++
+               " - " ++ formatReason reason
+            Complete labels -> "\n" ++ format (labels ++ ESC.usedSubsets s0)
+            Fail (reason,_) ->
+               ": failed because " ++ formatReason (None,reason))
+
+mainDetail = do
+   let s0 = stateFromString assigns exampleHawiki1
+   forM_ (indentTree $ ESC.completeTree s0) $ \(numbers, msg) ->
+      putStrLn $
+         (intercalate "." $ map show $ reverse numbers)
+         ++
+         (case msg of
+            Attempt (reason, cell@(pos,k), labels) ->
+               ": " ++ show k ++ " at " ++ show pos ++
+               " - " ++ formatReason reason ++ "\n\n" ++
+               formatColored (snd reason)
+                  (Just cell) (labels ++ ESC.usedSubsets s0)
+            Complete _labels -> ": completed\n"
+            Fail (reason, labels) ->
+               ": failed because " ++ formatReason (None,reason) ++ "\n\n" ++
+               formatColored reason Nothing (labels ++ ESC.usedSubsets s0))
+
+mainGenerate = do
+   gen <- getStdGen
+   case MS.evalState randomPuzzles gen of
+      solution:_ -> do
+         putStrLn $ formatSparse solution
+         let minSolution = minimizePuzzle solution
+         putStrLn $ formatSparse minSolution
+         printf "%d initially filled cells\n\n" $ length minSolution
+      _ -> fail "to few puzzles"
+
+main = mainDetail
diff --git a/example/TetrisCube.hs b/example/TetrisCube.hs
--- a/example/TetrisCube.hs
+++ b/example/TetrisCube.hs
@@ -188,12 +188,12 @@
 
 format :: [Map.Map PackedCoords BrickId] -> String
 format v =
-   let wuerfelx = Map.unions v
+   let cubex = Map.unions v
    in  Cuboid.forNestedCoords
           unlines (intercalate " | ") (intercalate " ")
           (\c ->
              maybe "." formatBrickId $
-             Map.lookup (Cuboid.packCoords size c) wuerfelx)
+             Map.lookup (Cuboid.packCoords size c) cubex)
           size
 
 printMask :: [Map.Map PackedCoords BrickId] -> IO ()
@@ -228,14 +228,14 @@
 testme1 = testme (Blue, 1)
 
 mainState = do
-   let lsg = ESC.partitions allAssigns
-   mapM_ printMask lsg
-   print $ length lsg
+   let sol = ESC.partitions allAssigns
+   mapM_ printMask sol
+   print $ length sol
 
 mainBits = do
-   let lsg = ESC.partitions $ map (fmap packMask) allAssigns
-   mapM_ printMask lsg
-   print $ length lsg
+   let sol = ESC.partitions $ map (fmap packMask) allAssigns
+   mapM_ printMask sol
+   print $ length sol
 
 mainParallel =
    Pool.run $ map snd $
diff --git a/set-cover.cabal b/set-cover.cabal
--- a/set-cover.cabal
+++ b/set-cover.cabal
@@ -1,5 +1,5 @@
 Name:             set-cover
-Version:          0.0.9
+Version:          0.1
 License:          BSD3
 License-File:     LICENSE
 Author:           Henning Thielemann, Helmut Podhaisky
@@ -10,8 +10,9 @@
 Description:
   Solver for exact set cover problems.
   Included examples:
-  Sudoku, Nonogram, 8 Queens, Domino tiling, Mastermind,
-  Soma Cube, Tetris Cube, Cube of L's, Logika's Baumeister puzzle.
+  Sudoku, Nonogram, 8 Queens, Domino tiling, Mastermind, Alphametics,
+  Soma Cube, Tetris Cube, Cube of L's,
+  Logika's Baumeister puzzle, Lonpos pyramid, Conway's puzzle.
   The generic algorithm allows to choose between
   slow but flexible @Set@ from @containers@ package
   and fast but cumbersome bitvectors.
@@ -19,20 +20,32 @@
   For getting familiar with the package
   I propose to study the Queen8 example along with "Math.SetCover.Exact".
   .
+  The Sudoku and Nonogram examples also demonstrate
+  how to interpret the set-cover solution in a human-friendly way.
+  .
   Build examples with @cabal install -fbuildExamples@.
   .
   The package needs only Haskell 98.
+  There is also an experimental implementation using LLVM and @knead@.
+  Do not rely on that interface in released packages.
 Tested-With:      GHC==7.4.2, GHC==7.6.3, GHC==7.8.2
 Cabal-Version:    >=1.8
 Build-Type:       Simple
-Extra-Source-Files: Changes.md
+Extra-Source-Files:
+  Changes.md
+  Makefile
 
 Flag buildExamples
-  description: Build example executables
-  default:     False
+  Description: Build example executables
+  Default:     False
 
+Flag llvm
+  Description: Enable efficient signal processing using LLVM
+  Manual:      True
+  Default:     False
+
 Source-Repository this
-  Tag:         0.0.9
+  Tag:         0.1
   Type:        darcs
   Location:    http://hub.darcs.net/thielema/set-cover/
 
@@ -43,32 +56,79 @@
 Library
   Build-Depends:
     psqueues >=0.2 && <0.3,
-    enummapset >=0.1 && <0.6,
-    containers >=0.4 && <0.6,
+    enummapset >=0.1 && <0.7,
+    transformers >=0.2 && <0.6,
+    array >=0.4 && <0.6,
+    containers >=0.4 && <0.7,
+    non-empty >=0.2 && <0.4,
     semigroups >=0.1 && <1.0,
     utility-ht >=0.0.12 && <0.1,
+    prelude-compat ==0.*,
     base >=4 && <5
 
   GHC-Options:      -Wall
   Hs-Source-Dirs:   src
   Exposed-Modules:
     Math.SetCover.Bit
-    Math.SetCover.BitMap
     Math.SetCover.BitSet
     Math.SetCover.BitPosition
+    Math.SetCover.BitPriorityQueue
     Math.SetCover.Queue
     Math.SetCover.Exact
     Math.SetCover.Exact.Priority
+    Math.SetCover.Exact.UArray
     Math.SetCover.Cuboid
   Other-Modules:
-    Math.SetCover.IntSet
-    Math.SetCover.BitPriorityQueue
+    Math.SetCover.BitMap
     Math.SetCover.EnumMap
     Math.SetCover.Queue.Set
     Math.SetCover.Queue.Map
     Math.SetCover.Queue.Bit
     Math.SetCover.Queue.BitPriorityQueue
+    Math.SetCover.Exact.Block
 
+  If flag(llvm)
+    Build-Depends:
+      knead >=0.4 && <0.5,
+      llvm-extra >=0.8 && <0.9,
+      llvm-tf >=3.1.1 && <3.2,
+      tfp >=1.0 && <1.1,
+      comfort-array >=0.3 && <0.5,
+      storable-endian >=0.2.6 && <0.3,
+      bool8 >=0.0 && <0.1,
+      lazyio >=0.1 && <0.2
+    Exposed-Modules:
+      Math.SetCover.Exact.Knead
+      Math.SetCover.Exact.Knead.Vector
+      Math.SetCover.Exact.Knead.Saturated
+    Other-Modules:
+      Math.SetCover.Exact.Knead.Symbolic
+
+Test-Suite set-cover-test
+  Type: exitcode-stdio-1.0
+  Build-Depends:
+    set-cover,
+    transformers >=0.2 && <0.6,
+    enummapset,
+    containers,
+    array >=0.1 && <0.6,
+    utility-ht,
+    QuickCheck >=2.5 && <3.0,
+    base
+  Main-Is: Test.hs
+  Hs-Source-Dirs: test, example
+  If flag(llvm)
+    Hs-Source-Dirs: test/knead
+  Else
+    Hs-Source-Dirs: test/plain
+  GHC-Options:    -Wall
+  Other-Modules:
+    Mastermind.Test
+    Mastermind.Guess
+    Mastermind.Utility
+    Test.Knead
+    Test.Utility
+
 Executable tetris-cube
   If flag(buildExamples)
     Build-Depends:
@@ -117,6 +177,9 @@
   If flag(buildExamples)
     Build-Depends:
       set-cover,
+      haha >=0.3.1 && <0.4,
+      random >=1.0 && <1.2,
+      transformers >=0.2 && <0.6,
       containers,
       array >=0.1 && <0.6,
       utility-ht,
@@ -126,6 +189,7 @@
   GHC-Options:    -Wall -rtsopts -threaded
   Hs-Source-Dirs: example
   Main-Is: Sudoku.hs
+  Other-Modules: Random, Mastermind.Utility
 
 Executable lcube
   If flag(buildExamples)
@@ -226,12 +290,13 @@
     Nonogram.Encoding.Naive
     Nonogram.Base
 
-Executable mastermind
+Executable mastermind-setcover
   If flag(buildExamples)
     Build-Depends:
       set-cover,
       random >=1.0 && <1.2,
       transformers >=0.2 && <0.6,
+      enummapset,
       containers,
       array >=0.1 && <0.6,
       utility-ht,
@@ -241,7 +306,61 @@
   GHC-Options:    -Wall
   Hs-Source-Dirs: example
   Main-Is: Mastermind.hs
+  Other-Modules:
+    Mastermind.Utility
+    Mastermind.Guess
+    Mastermind.Distinguish
+    Mastermind.Example
+    Random
 
+Executable mastermind-knead
+  If flag(buildExamples) && flag(llvm)
+    GHC-Prof-Options: -rtsopts -auto-all
+    Build-Depends:
+      set-cover,
+      haha >=0.3.1 && <0.4,
+      random >=1.0 && <1.2,
+      lazyio,
+      transformers >=0.2 && <0.6,
+      enummapset,
+      containers,
+      array >=0.1 && <0.6,
+      utility-ht,
+      base
+  Else
+    Buildable: False
+  Extra-Libraries: stdc++
+  GHC-Options:    -Wall
+  Hs-Source-Dirs: example
+  Main-Is: MastermindKnead.hs
+  Other-Modules:
+    Mastermind.Utility
+    Mastermind.Guess
+    Mastermind.Distinguish
+    Mastermind.Example
+    Random
+
+Benchmark mastermind-benchmark
+  Type: exitcode-stdio-1.0
+  Build-Depends:
+    set-cover,
+    timeit,
+    QuickCheck >=2.5 && <3.0,
+    random >=1.0 && <1.2,
+    transformers >=0.2 && <0.6,
+    enummapset,
+    containers,
+    array >=0.1 && <0.6,
+    utility-ht,
+    base
+  GHC-Options:    -Wall
+  Hs-Source-Dirs: example
+  Main-Is: Mastermind/Benchmark.hs
+  Other-Modules:
+    Mastermind.Test
+    Mastermind.Guess
+    Mastermind.Utility
+
 Executable pangram
   If flag(buildExamples)
     Build-Depends:
@@ -253,3 +372,19 @@
   GHC-Options:    -Wall
   Hs-Source-Dirs: example
   Main-Is: Pangram.hs
+
+Executable conway-puzzle
+  If flag(buildExamples)
+    Build-Depends:
+      set-cover,
+      pooled-io >=0.0 && <0.1,
+      transformers,
+      containers,
+      base
+  Else
+    Buildable: False
+  GHC-Options:    -Wall -rtsopts -threaded
+  Hs-Source-Dirs: example
+  Main-Is: ConwayPuzzle.hs
+  Other-Modules:
+    Utility
diff --git a/src/Math/SetCover/Bit.hs b/src/Math/SetCover/Bit.hs
--- a/src/Math/SetCover/Bit.hs
+++ b/src/Math/SetCover/Bit.hs
@@ -1,7 +1,8 @@
 module Math.SetCover.Bit where
 
+import qualified Data.IntSet as IntSet; import Data.IntSet (IntSet)
 import qualified Data.Bits as Bits
-import Data.Bits (Bits)
+import Data.Bits (Bits, complement)
 import Data.Word (Word8, Word16, Word32, Word64)
 import Prelude hiding (null)
 
@@ -15,12 +16,12 @@
 -}
 class Ord bits => C bits where
    empty :: bits
-   complement, keepMinimum :: bits -> bits
-   xor, (.&.), (.|.) :: bits -> bits -> bits
+   keepMinimum :: bits -> bits
+   difference, xor, (.&.), (.|.) :: bits -> bits -> bits
 
 instance C Word8 where
    empty = 0
-   complement = Bits.complement
+   difference xs ys = xs .&. complement ys
    keepMinimum xs = xs .&. (-xs)
    xor = Bits.xor
    (.&.) = (Bits..&.)
@@ -28,7 +29,7 @@
 
 instance C Word16 where
    empty = 0
-   complement = Bits.complement
+   difference xs ys = xs .&. complement ys
    keepMinimum xs = xs .&. (-xs)
    xor = Bits.xor
    (.&.) = (Bits..&.)
@@ -36,7 +37,7 @@
 
 instance C Word32 where
    empty = 0
-   complement = Bits.complement
+   difference xs ys = xs .&. complement ys
    keepMinimum xs = xs .&. (-xs)
    xor = Bits.xor
    (.&.) = (Bits..&.)
@@ -44,7 +45,7 @@
 
 instance C Word64 where
    empty = 0
-   complement = Bits.complement
+   difference xs ys = xs .&. complement ys
    keepMinimum xs = xs .&. (-xs)
    xor = Bits.xor
    (.&.) = (Bits..&.)
@@ -52,14 +53,19 @@
 
 instance C Integer where
    empty = 0
-   complement = Bits.complement
+   difference xs ys = xs .&. complement ys
    keepMinimum xs = xs .&. (-xs)
    xor = Bits.xor
    (.&.) = (Bits..&.)
    (.|.) = (Bits..|.)
 
-difference :: C bits => bits -> bits -> bits
-difference xs ys = xs .&. complement ys
+instance C IntSet where
+   empty = IntSet.empty
+   difference = IntSet.difference
+   keepMinimum = IntSet.singleton . IntSet.findMin
+   xor x y = IntSet.difference (IntSet.union x y) (IntSet.intersection x y)
+   (.&.) = IntSet.intersection
+   (.|.) = IntSet.union
 
 
 {-
@@ -70,7 +76,8 @@
 
 instance (C a, C b) => C (Sum a b) where
    empty = Sum empty empty
-   complement (Sum l h) = Sum (complement l) (complement h)
+   difference (Sum xl xh) (Sum yl yh) =
+      Sum (difference xl yl) (difference xh yh)
    xor (Sum xl xh) (Sum yl yh) = Sum (xor xl yl) (xor xh yh)
    Sum xl xh .&. Sum yl yh = Sum (xl.&.yl) (xh.&.yh)
    Sum xl xh .|. Sum yl yh = Sum (xl.|.yl) (xh.|.yh)
diff --git a/src/Math/SetCover/BitMap.hs b/src/Math/SetCover/BitMap.hs
--- a/src/Math/SetCover/BitMap.hs
+++ b/src/Math/SetCover/BitMap.hs
@@ -14,8 +14,10 @@
 import Math.SetCover.Bit (difference, xor, (.|.), (.&.))
 
 import qualified Data.List.Reverse.StrictSpine as ListRev
+import qualified Data.List as List
 import Data.Monoid (Monoid, mempty, mappend)
 import Data.Semigroup (Semigroup, (<>))
+import Data.Tuple.HT (mapSnd, swap)
 
 
 {-
@@ -44,9 +46,11 @@
 
 inc :: Bit.C bits => Set bits -> Map bits -> Map bits
 inc (Set xs0) (Map ys0) =
-   let go c [] = if c==Bit.empty then [] else [c]
-       go c (x:xs) = xor c x : go (c .&. x) xs
-   in  Map $ go xs0 ys0
+   Map $
+   mapAccumAffix
+      (\c -> if c==Bit.empty then [] else [c])
+      (\c x -> (c .&. x, xor c x))
+      xs0 ys0
 
 
 sub :: Bit.C bits => Map bits -> Map bits -> Map bits
@@ -62,9 +66,22 @@
 
 dec :: Bit.C bits => Set bits -> Map bits -> Map bits
 dec (Set xs0) (Map ys0) =
-   let go c [] = if c==Bit.empty then [] else error "dec: underflow"
-       go c (x:xs) = xor c x : go (difference c x) xs
-   in  Map $ go xs0 ys0
+   Map $
+   mapAccumAffix
+      (\c -> if c==Bit.empty then [] else error "dec: underflow")
+      (\c x -> (difference c x, xor c x))
+      xs0 ys0
+
+{-# INLINE mapAccumAffix #-}
+mapAccumAffix, _mapAccumAffix ::
+   (acc -> [y]) -> (acc -> x -> (acc, y)) -> acc -> [x] -> [y]
+mapAccumAffix affix f =
+   let go acc0 (x:xs) = let (acc1, y) = f acc0 x in  y : go acc1 xs
+       go acc [] = affix acc
+   in  go
+
+_mapAccumAffix affix f acc =
+   uncurry (++) . mapSnd affix . swap . List.mapAccumL f acc
 
 intersectionSet :: (Bit.C bits) => Map bits -> Set bits -> Map bits
 intersectionSet (Map xs) (Set y) = Map $ normalize $ map (y.&.) xs
diff --git a/src/Math/SetCover/BitPosition.hs b/src/Math/SetCover/BitPosition.hs
--- a/src/Math/SetCover/BitPosition.hs
+++ b/src/Math/SetCover/BitPosition.hs
@@ -1,11 +1,13 @@
-module Math.SetCover.BitPosition (C, unpack, singleton, bitPosition) where
+module Math.SetCover.BitPosition
+         (C, Sized, unpack, singleton, bitPosition) where
 
 import qualified Math.SetCover.BitSet as BitSet
 import qualified Math.SetCover.Bit as Bit
 import Math.SetCover.Bit ((.&.))
 
+import qualified Data.IntSet as IntSet; import Data.IntSet (IntSet)
 import qualified Data.Bits as Bits
-import Data.Bits (Bits, shiftR)
+import Data.Bits (Bits, shiftR, complement)
 import Data.Word (Word8, Word16, Word32, Word64)
 
 import qualified Data.List.HT as ListHT
@@ -24,9 +26,9 @@
          in  (x, BitSet.difference set x)
 
 {-# INLINE positionMasks #-}
-positionMasks :: (Integral bits, Bit.C bits) => [bits]
+positionMasks :: (Integral bits, Bits bits, Bit.C bits) => [bits]
 positionMasks =
-   map (Bit.complement . div (-1) . (1+)) $
+   map (complement . div (-1) . (1+)) $
    takeWhile (/=0) $ iterate (\w -> w*w) 2
 
 {-
@@ -74,25 +76,32 @@
       zip [0, 64 ..] . takeWhile (/=0) . iterate (flip shiftR 64)
    unpack =
       concatMap (\(offset,x) -> map (offset+) $ unpack (BitSet.Set x)) .
-      zip [0, 64 ..] . map (\w -> word64 $ w .&. fromIntegral (-1 :: Word64)) .
-      takeWhile (/=0) . iterate (flip shiftR 64) . (\(BitSet.Set x) -> x)
+      zip [0, 64 ..] .
+      map (\w -> word64 $ w .&. fromIntegral (complement 0 :: Word64)) .
+      takeWhile (/=0) . iterate (flip shiftR 64) . BitSet.getBits
 
+instance C IntSet where
+   bit = IntSet.singleton
+   bitPositionPlain = IntSet.findMin
+   unpack = IntSet.toList . BitSet.getBits
+
 word64 :: Integer -> Word64
 word64 = fromIntegral
 
-{- |
-Instantiating @a@ with 'Integer' will end badly because it has no fixed size!
--}
-instance (Integral a, C a, C b) => C (Bit.Sum a b) where
-   bit = bitSum $ bitSize positionMasks
-   bitPositionPlain = bitSumPosition $ bitSize positionMasks
-   unpack = bitSumUnpack $ bitSize positionMasks
 
 newtype Size bits = Size Int
 
-bitSize :: C bits => [bits] -> Size bits
-bitSize = Size . Bits.bit . length
+class C bits => Sized bits where size :: Size bits
+instance Sized Word8  where size = Size 8
+instance Sized Word16 where size = Size 16
+instance Sized Word32 where size = Size 32
+instance Sized Word64 where size = Size 64
 
+instance (Sized a, C b) => C (Bit.Sum a b) where
+   bit = bitSum size
+   bitPositionPlain = bitSumPosition size
+   unpack = bitSumUnpack size
+
 bitSum :: (C a, C b) => Size a -> Int -> Bit.Sum a b
 bitSum (Size offset) pos =
    if pos < offset
@@ -110,7 +119,7 @@
    unpack (BitSet.Set a) ++ map (offset +) (unpack (BitSet.Set b))
 
 bitPosition :: (C bits) => BitSet.Set bits -> Int
-bitPosition (BitSet.Set bits) = bitPositionPlain bits
+bitPosition = bitPositionPlain . BitSet.getBits
 
 singleton :: (C bits) => Int -> BitSet.Set bits
 singleton = BitSet.Set . bit
diff --git a/src/Math/SetCover/BitPriorityQueue.hs b/src/Math/SetCover/BitPriorityQueue.hs
--- a/src/Math/SetCover/BitPriorityQueue.hs
+++ b/src/Math/SetCover/BitPriorityQueue.hs
@@ -1,10 +1,19 @@
-module Math.SetCover.BitPriorityQueue where
+module Math.SetCover.BitPriorityQueue (
+   Queue,
+   null,
+   fromSets,
+   elemUnions,
+   partition,
+   difference,
+   findMin,
+   findMinValue,
+   ) where
 
 import qualified Math.SetCover.EnumMap as EnumMapX
 import qualified Math.SetCover.BitPosition as BitPos
 import qualified Math.SetCover.BitMap as BitMap
 import qualified Math.SetCover.BitSet as BitSet
-import Math.SetCover.EnumMap (constIntMap)
+import Math.SetCover.EnumMap (constIntMapFromBits)
 
 import qualified Data.EnumSet as EnumSet; import Data.EnumSet (EnumSet)
 import qualified Data.IntMap as IntMap; import Data.IntMap (IntMap)
@@ -13,7 +22,9 @@
 import Data.Monoid (mempty, mconcat)
 import Data.Maybe.HT (toMaybe)
 
+import Prelude hiding (null)
 
+
 {-
 We could generalize @EnumSet e@ to @a@
 and pretend that the priorities are independent of the 'EnumSet' sizes.
@@ -39,13 +50,17 @@
    mconcat $ map BitPos.singleton $ IntMap.keys m
 
 findMin :: (BitPos.C bits) => Queue bits e -> Maybe (EnumSet e)
-findMin q@(Queue ns m) =
+findMin = fmap snd . findMinValue
+
+findMinValue ::
+   (BitPos.C bits) => Queue bits e -> Maybe (BitSet.Set bits, EnumSet e)
+findMinValue q@(Queue ns m) =
    let used = keysBits q
-   in  toMaybe (not $ BitSet.null used) $
+       minSet = BitSet.keepMinimum $ BitMap.minimumSet used ns
+   in  toMaybe (not $ BitSet.null used) $ (,) minSet $
           IntMap.findWithDefault
              (error "findMin: key with minimal priority must be in IntMap")
-             (BitPos.bitPosition $ BitSet.keepMinimum $
-              BitMap.minimumSet used ns)
+             (BitPos.bitPosition minSet)
              m
 
 difference ::
@@ -59,6 +74,6 @@
    (BitPos.C bits, Enum e) =>
    Queue bits e -> BitSet.Set bits -> (Queue bits e, Queue bits e)
 partition (Queue ns m) s =
-   let section = IntMap.intersection m $ constIntMap () s
+   let section = IntMap.intersection m $ constIntMapFromBits () s
    in  (Queue (BitMap.intersectionSet ns s) section,
         Queue (BitMap.differenceSet ns s) $ IntMap.difference m section)
diff --git a/src/Math/SetCover/BitSet.hs b/src/Math/SetCover/BitSet.hs
--- a/src/Math/SetCover/BitSet.hs
+++ b/src/Math/SetCover/BitSet.hs
@@ -7,7 +7,7 @@
 import Data.Semigroup (Semigroup, (<>))
 
 
-newtype Set bits = Set bits deriving (Eq, Ord, Show)
+newtype Set bits = Set {getBits :: bits} deriving (Eq, Ord, Show)
 
 instance (Bit.C bits) => Semigroup (Set bits) where
    Set x <> Set y = Set $ x.|.y
diff --git a/src/Math/SetCover/Cuboid.hs b/src/Math/SetCover/Cuboid.hs
--- a/src/Math/SetCover/Cuboid.hs
+++ b/src/Math/SetCover/Cuboid.hs
@@ -51,11 +51,8 @@
 numberOf2LayerAtoms :: [[String]] -> Int
 numberOf2LayerAtoms =
    Fold.sum .
-   Map.intersectionWith (*)
-      (Map.fromList [('.', 1), ('\'', 1), (':', 2)]) .
-   Map.fromListWith (+) .
-   map (flip (,) 1) .
-   concat . concat
+   Map.intersectionWith (*) (Map.fromList [('.', 1), ('\'', 1), (':', 2)]) .
+   Map.fromListWith (+) . map (flip (,) 1) . concat . concat
 
 
 forNestedCoords ::
@@ -78,16 +75,22 @@
    deriving (Eq, Ord, Show)
 
 
-dx, dy, dz :: Num a => Coords a -> Coords a
-dx (Coords x y z) = Coords x (-z) y -- [1 0  0; 0 0 -1; 0 1 0]
-dy (Coords x y z) = Coords (-z) y x -- [0 0 -1; 0 1 0; 1 0 0]
-dz (Coords x y z) = Coords (-y) x z -- [0 -1 0; 1 0 0; 0 0 1]
+rotX, rotY, rotZ :: Num a => Coords a -> Coords a
+rotX (Coords x y z) = Coords x (-z) y -- [1 0  0; 0 0 -1; 0 1 0]
+rotY (Coords x y z) = Coords (-z) y x -- [0 0 -1; 0 1 0; 1 0 0]
+rotZ (Coords x y z) = Coords (-y) x z -- [0 -1 0; 1 0 0; 0 0 1]
 
+primRotations :: Num a => Coords (Coords a -> Coords a)
+primRotations = Coords rotX rotY rotZ
+
 rotations :: Num a => [Coords a -> Coords a]
-rotations =
+rotations = rotationsGen primRotations
+
+rotationsGen :: Num a => Coords (Coords a -> Coords a) -> [Coords a -> Coords a]
+rotationsGen (Coords rx ry rz) =
    liftA2 (.)
-      [id, dx, dx.dx, dx.dx.dx]
-      [id, dz, dz.dz, dz.dz.dz, dy, dy.dy.dy]
+      [id, rx, rx.rx, rx.rx.rx]
+      [id, rz, rz.rz, rz.rz.rz, ry, ry.ry.ry]
 
 
 type Size = Coords Int
@@ -120,6 +123,10 @@
    liftA2 (-) sz (size ts)
 
 allOrientations :: (Num a, Ord a) => [Coords a] -> [[Coords a]]
-allOrientations ts =
+allOrientations = allOrientationsGen primRotations
+
+allOrientationsGen ::
+   (Num a, Ord a) => Coords (Coords a -> Coords a) -> [Coords a] -> [[Coords a]]
+allOrientationsGen pr ts =
    Set.toList $ Set.fromList $
-   map (normalForm . flip map ts) rotations
+   map (normalForm . flip map ts) $ rotationsGen pr
diff --git a/src/Math/SetCover/EnumMap.hs b/src/Math/SetCover/EnumMap.hs
--- a/src/Math/SetCover/EnumMap.hs
+++ b/src/Math/SetCover/EnumMap.hs
@@ -6,6 +6,7 @@
 import qualified Data.EnumMap as EnumMap; import Data.EnumMap (EnumMap)
 import qualified Data.EnumSet as EnumSet; import Data.EnumSet (EnumSet)
 import qualified Data.IntMap as IntMap; import Data.IntMap (IntMap)
+import qualified Data.IntSet as IntSet; import Data.IntSet (IntSet)
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 
@@ -26,9 +27,13 @@
    in  (section, EnumMap.difference m section)
 
 
+{-# INLINE attach #-}
+attach :: b -> [a] -> [(a, b)]
+attach a = map (flip (,) a)
+
 -- Map.fromSet is available from containers-0.5
 constMap :: (Ord a) => b -> Set.Set a -> Map.Map a b
-constMap a = Map.fromAscList . map (\k -> (k, a)) . Set.toAscList
+constMap a = Map.fromAscList . attach a . Set.toAscList
 
 transposeSet ::
    (Enum e, Ord a) => EnumMap e (Set.Set a) -> Map.Map a (EnumSet e)
@@ -44,11 +49,20 @@
    EnumMap.mapWithKey (fmap . EnumMap.singleton)
 
 
-constIntMap :: (BitPos.C bits) => b -> BitSet.Set bits -> IntMap b
-constIntMap a = IntMap.fromAscList . map (\k -> (k, a)) . BitPos.unpack
+constIntMapFromBits :: (BitPos.C bits) => b -> BitSet.Set bits -> IntMap b
+constIntMapFromBits a = IntMap.fromAscList . attach a . BitPos.unpack
 
 transposeBitSet ::
    (BitPos.C bits, Enum e) => EnumMap e (BitSet.Set bits) -> IntMap (EnumSet e)
 transposeBitSet =
+   IntMap.unionsWith EnumSet.union . EnumMap.elems .
+   EnumMap.mapWithKey (constIntMapFromBits . EnumSet.singleton)
+
+
+constIntMap :: b -> IntSet -> IntMap b
+constIntMap a = IntMap.fromAscList . attach a . IntSet.toAscList
+
+transposeIntSet :: (Enum e) => EnumMap e IntSet -> IntMap (EnumSet e)
+transposeIntSet =
    IntMap.unionsWith EnumSet.union . EnumMap.elems .
    EnumMap.mapWithKey (constIntMap . EnumSet.singleton)
diff --git a/src/Math/SetCover/Exact.hs b/src/Math/SetCover/Exact.hs
--- a/src/Math/SetCover/Exact.hs
+++ b/src/Math/SetCover/Exact.hs
@@ -3,26 +3,31 @@
 <http://en.wikipedia.org/wiki/Exact_cover>
 -}
 module Math.SetCover.Exact (
-   Assign(..), assign, bitVectorFromSetAssigns,
+   Assign(..), assign,
+   bitVectorFromSetAssigns, intSetFromSetAssigns,
    partitions, search, step,
    State(..), initState, updateState,
    Set(..),
+   Tree(..), decisionTree, completeTree,
+   Choose(..),
    ) where
 
-import qualified Math.SetCover.IntSet as IntSetX
 import qualified Math.SetCover.BitMap as BitMap
 import qualified Math.SetCover.BitSet as BitSet
 import qualified Math.SetCover.Bit as Bit
+import Math.SetCover.EnumMap (constMap)
 
 import Control.Applicative ((<$>), (<$))
 
 import qualified Data.IntSet as IntSet
 import qualified Data.Map as Map
 import qualified Data.Set as Set
-import qualified Data.List as List
 import qualified Data.List.Match as Match
+import qualified Data.List as List
 import qualified Data.Foldable as Fold
+import Data.Function.HT (compose2)
 import Data.Maybe.HT (toMaybe)
+import Data.Tuple.HT (mapFst, mapSnd)
 import Data.Bits (setBit)
 
 import Prelude hiding (null)
@@ -39,10 +44,17 @@
    unions :: [set] -> set
    difference :: set -> set -> set
    {- |
+   @minimize free assigns@ finds a set element @x@ from @free@
+   that is contained in the least number of sets in @assigns@.
+   Then it returns the assigns where @x@ is contained in the associated set.
+   This formulation allows us not to name @x@
+   and thus we do not need a second type variable for @set@ elements
+   and no type family from @set@ to its element type.
+
    Unchecked preconditions:
-   'set' must be a superset of all sets in the assign list.
-   'set' must be non-empty.
-   The list of assignments must be non-empty.
+   @free@ must be a superset of all sets in the assign list.
+   @free@ must be non-empty.
+   The @assigns@ list may be empty.
    The output of assigns must be a subsequence of the input assigns,
    that is, it must be a subset of the input and it must be in the same order.
    This requirement was originally needed by 'minimize' for 'Map.Map',
@@ -50,30 +62,43 @@
    -}
    minimize :: set -> [Assign label set] -> [Assign label set]
 
+class Set set => Choose set where
+   {-
+   Compute a set containing one element
+   that is contained in a minimal number of assignment sets.
+   -}
+   chooseMinimize :: set -> [Assign label set] -> (set, [Assign label set])
+
 instance (Ord a) => Set (Set.Set a) where
    null = Set.null
    disjoint x y = Set.null $ Set.intersection x y
    unions = Set.unions
    difference = Set.difference
-   minimize free =
-      Fold.minimumBy Match.compareLength .
-      foldr (Map.unionWith (++)) (constMap [] free) .
-      map (\a -> constMap [a] $ labeledSet a)
+   minimize free = Fold.minimumBy Match.compareLength . histogramSet free
 
-{-
-In containers-0.5 we have Map.fromSet
--}
-{-# INLINE constMap #-}
-constMap :: (Ord a) => b -> Set.Set a -> Map.Map a b
-constMap a = Fold.foldMap (flip Map.singleton a)
+instance (Ord a) => Choose (Set.Set a) where
+   chooseMinimize free =
+      mapFst Set.singleton .
+      List.minimumBy (compose2 Match.compareLength snd) .
+      Map.toList . histogramSet free
 
+histogramSet ::
+   Ord k =>
+   Set.Set k ->
+   [Assign label (Set.Set k)] ->
+   Map.Map k [Assign label (Set.Set k)]
+histogramSet free =
+   foldr (Map.unionWith (++)) (constMap [] free) .
+   map (\a -> constMap [a] $ labeledSet a)
+
+
 {- |
 This instance supports Maps of Sets.
 This way you can structure your sets hierarchically.
 You may also use it to combine several low-level bitsets.
 A Map must not contain empty subsets.
 -}
-instance (Ord k, Set a) => Set (Map.Map k a) where
+instance (Ord k, Set set) => Set (Map.Map k set) where
    null = Map.null
    disjoint x y = Fold.and $ Map.intersectionWith disjoint x y
    unions =
@@ -81,39 +106,59 @@
    difference =
       Map.differenceWith
          (\x y -> let z = difference x y in toMaybe (not $ null z) z)
-   minimize free asns =
-      map label $
-      Fold.minimumBy Match.compareLength $
-      Map.intersectionWith minimize free $
-      foldr (Map.unionWith (++)) ([] <$ free) $
-      map (\asn -> (:[]) . assign asn <$> labeledSet asn) asns
+   minimize free =
+      map label . Fold.minimumBy Match.compareLength .
+      Map.intersectionWith minimize free . histogramMap free
 
+instance (Ord k, Choose set) => Choose (Map.Map k set) where
+   chooseMinimize free =
+      (\(k,(minSet,asns)) -> (Map.singleton k minSet, map label asns)) .
+      List.minimumBy (compose2 Match.compareLength (snd.snd)) . Map.toList .
+      Map.intersectionWith chooseMinimize free . histogramMap free
 
+histogramMap ::
+   (Ord k, Set set) =>
+   Map.Map k set ->
+   [Assign label (Map.Map k set)] ->
+   Map.Map k [Assign (Assign label (Map.Map k set)) set]
+histogramMap free =
+   foldr (Map.unionWith (++)) ([] <$ free) .
+   map (\asn -> (:[]) . assign asn <$> labeledSet asn)
+
+
 instance (Bit.C a) => Set (BitSet.Set a) where
    null = BitSet.null
    disjoint = BitSet.disjoint
    unions = Fold.fold
    difference = BitSet.difference
-   minimize free available =
+   minimize free = snd . chooseMinimize free
+
+instance (Bit.C a) => Choose (BitSet.Set a) where
+   chooseMinimize free available =
       let singleMin =
              BitSet.keepMinimum $ BitMap.minimumSet free $
              Fold.foldMap (BitMap.fromSet . labeledSet) available
-      in  filter (not . BitSet.disjoint singleMin . labeledSet) available
+      in  (singleMin,
+           filter (not . BitSet.disjoint singleMin . labeledSet) available)
 
+
 instance Set IntSet.IntSet where
    null = IntSet.null
    disjoint x y = IntSet.null $ IntSet.intersection x y
    unions = IntSet.unions
    difference = IntSet.difference
-   minimize free available =
-      let bitset = BitSet.Set . IntSetX.fromIntSet
-          singleMin =
-             (\(BitSet.Set s) -> IntSetX.findMin s) $
-             BitMap.minimumSet (bitset free) $
-             Fold.foldMap (BitMap.fromSet . bitset . labeledSet) available
-      in  filter (IntSet.member singleMin . labeledSet) available
+   minimize free = snd . chooseMinimize free
 
+instance Choose IntSet.IntSet where
+   chooseMinimize free available =
+      let singleMin =
+            IntSet.findMin $ BitSet.getBits $
+            BitMap.minimumSet (BitSet.Set free) $
+            Fold.foldMap (BitMap.fromSet . BitSet.Set . labeledSet) available
+      in  (IntSet.singleton singleMin,
+           filter (IntSet.member singleMin . labeledSet) available)
 
+
 {- |
 'Assign' allows to associate a set with a label.
 If a particular set is chosen for a set cover,
@@ -148,14 +193,27 @@
    (Ord a) =>
    [Assign label (Set.Set a)] -> [Assign label (BitSet.Set Integer)]
 bitVectorFromSetAssigns asns =
+   let bitVec = Fold.foldl' setBit 0 . mapIntFromSet asns
+   in  map (fmap (BitSet.Set . bitVec)) asns
+
+{- |
+Like 'bitVectorFromSetAssigns' but generates 'IntSet.IntSet'
+instead of 'Integer' bitvectors.
+Since containers-0.5.5 as shipped with GHC-7.8.4,
+'IntSet.IntSet' should usually be more efficient than 'Integer'.
+-}
+intSetFromSetAssigns ::
+   (Ord a) => [Assign label (Set.Set a)] -> [Assign label IntSet.IntSet]
+intSetFromSetAssigns asns =
+   let intSet = IntSet.fromList . Map.elems . mapIntFromSet asns
+   in  map (fmap intSet) asns
+
+mapIntFromSet ::
+   (Ord a) => [Assign label (Set.Set a)] -> Set.Set a -> Map.Map a Int
+mapIntFromSet asns =
    let mapToInt =
          Map.fromList $ zip (Set.toList $ unions $ map labeledSet asns) [0..]
-       err = error "bitVectorFromSetAssigns: element disappeared"
-       bitVec =
-         Fold.foldl' setBit 0 .
-         map (flip (Map.findWithDefault err) mapToInt) .
-         Set.toList
-   in  map (fmap (BitSet.Set . bitVec)) asns
+   in  Map.intersection mapToInt . constMap ()
 
 {- |
 The state of the search.
@@ -176,7 +234,7 @@
    State {
       availableSubsets :: [Assign label set],
       freeElements :: set,
-      usedSubsets :: [Assign label set]
+      usedSubsets :: [label]
    }
 
 instance Functor (Assign label) where
@@ -184,7 +242,7 @@
 
 instance Functor (State label) where
    fmap f (State ab fp pb) =
-      State (map (fmap f) ab) (f fp) (map (fmap f) pb)
+      State (map (fmap f) ab) (f fp) pb
 
 initState :: Set set => [Assign label set] -> State label set
 initState subsets =
@@ -196,13 +254,13 @@
 
 {-# INLINE updateState #-}
 updateState :: Set set => Assign label set -> State label set -> State label set
-updateState attempt@(Assign _ attemptedSet) s =
+updateState (Assign attemptLabel attemptedSet) s =
    State {
       availableSubsets =
          filter (disjoint attemptedSet . labeledSet) $
          availableSubsets s,
       freeElements = difference (freeElements s) attemptedSet,
-      usedSubsets = attempt : usedSubsets s
+      usedSubsets = attemptLabel : usedSubsets s
    }
 
 
@@ -232,15 +290,13 @@
 The algorithm might not be extraordinarily fast,
 but in all cases it consumes only little memory
 since it only has to maintain the current state of search.
+
+Precondition: 'freeElements' of the input state must not be empty.
 -}
 {-# INLINE step #-}
 step :: Set set => State label set -> [State label set]
 step s =
-   if List.null (availableSubsets s) || null (freeElements s)
-     then []
-     else
-        map (flip updateState s) $
-        minimize (freeElements s) (availableSubsets s)
+   map (flip updateState s) $ minimize (freeElements s) (availableSubsets s)
 
 {- |
 Start the search for partitions on a certain search state.
@@ -253,7 +309,7 @@
 search :: Set set => State label set -> [[label]]
 search s =
    if null (freeElements s)
-     then [map label $ usedSubsets s]
+     then [usedSubsets s]
      else step s >>= search
 
 {- |
@@ -270,8 +326,25 @@
 depends on the implementation
 and you must not rely on them.
 
-You may use 'listToMaybe' in order to select only the first solution.
+You may use 'Data.Maybe.listToMaybe' in order to select only the first solution.
 -}
 {-# INLINE partitions #-}
 partitions :: Set set => [Assign label set] -> [[label]]
 partitions = search . initState
+
+
+
+data Tree label set = Leaf | Branch set [(label, Tree label set)]
+   deriving (Eq)
+
+completeTree :: Choose set => State label set -> Tree label set
+completeTree s =
+   if null (freeElements s)
+      then Leaf
+      else
+         uncurry Branch $
+         mapSnd (map (\asn -> (label asn, completeTree $ updateState asn s))) $
+         chooseMinimize (freeElements s) (availableSubsets s)
+
+decisionTree :: Choose set => [Assign label set] -> Tree label set
+decisionTree = completeTree . initState
diff --git a/src/Math/SetCover/Exact/Block.hs b/src/Math/SetCover/Exact/Block.hs
new file mode 100644
--- /dev/null
+++ b/src/Math/SetCover/Exact/Block.hs
@@ -0,0 +1,37 @@
+module Math.SetCover.Exact.Block (blocksFromSets) where
+
+import Math.SetCover.EnumMap (constMap)
+
+import qualified Data.List as List
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Data.Monoid.HT as Mn
+import Data.Set (Set)
+import Data.Tuple.HT (swap)
+import Data.Bits (Bits, bitSize, setBit, shiftL, complement)
+
+
+blocksFromSets ::
+   (Ord a, Num block, Bits block) => [Set a] -> ([[block]], [block])
+blocksFromSets sets =
+   let dummyBlock = 0
+       blockSize = bitSize dummyBlock
+       complete = Set.unions sets
+       mapToInt = Map.fromList $ zip (Set.toList complete) [0..]
+       blocks =
+         blocksFromInts blockSize .
+         Map.elems . Map.intersection mapToInt . constMap ()
+   in  (map blocks sets,
+        case divMod (Set.size complete) blockSize of
+            (numBlocks,remd) ->
+               replicate numBlocks (complement 0 `asTypeOf` dummyBlock) ++
+               Mn.when (remd>0) [shiftL 1 remd - 1])
+
+blocksFromInts :: (Num block, Bits block) => Int -> [Int] -> [block]
+blocksFromInts blockSize =
+   zipWith blockFromBits (iterate (blockSize+) 0) . snd .
+   flip (List.mapAccumL (\elems pivot -> swap $ span (<pivot) elems))
+            (iterate (blockSize+) blockSize)
+
+blockFromBits :: (Num block, Bits block) => Int -> [Int] -> block
+blockFromBits offset = List.foldl' setBit 0 . map (subtract offset)
diff --git a/src/Math/SetCover/Exact/Knead.hs b/src/Math/SetCover/Exact/Knead.hs
new file mode 100644
--- /dev/null
+++ b/src/Math/SetCover/Exact/Knead.hs
@@ -0,0 +1,193 @@
+{- |
+This re-implements "Math.SetCover.Exact.UArray" using LLVM.
+-}
+module Math.SetCover.Exact.Knead (
+   partitionsIO, searchIO, stepIO,
+   partitions,
+   State(..), initStateIO, updateStateIO,
+   BitSet(..),
+   SetId, SetDim, BlockId, BlockDim,
+   ) where
+
+import qualified Math.SetCover.Exact as ESC
+import Math.SetCover.Exact.Knead.Symbolic (
+   SetId, SetDim, BlockId, BlockDim, DigitId, DigitDim,
+   Block,
+   BitSet(nullBlock, blocksFromSets, keepMinimumBit),
+   sumBags3,
+   difference,
+   getRow,
+   nullSet,
+   disjoint,
+   differenceWithRow,
+   findIndices,
+   filterDisjointRows,
+   )
+
+import Control.Monad.HT ((<=<))
+import Control.Monad (foldM)
+import Control.Applicative (liftA3, pure, (<$>))
+
+import qualified Data.Array.Knead.Parameterized.Render as Render
+import qualified Data.Array.Knead.Simple.Physical as Phys
+import qualified Data.Array.Knead.Simple.Symbolic as Symb
+import qualified Data.Array.Knead.Simple.Slice as Slice
+import qualified Data.Array.Knead.Shape as Shape
+import qualified Data.Array.Knead.Expression as Expr
+import Data.Array.Knead.Expression ((.|.*))
+
+import qualified Data.Array.Comfort.Shape as ComfortShape
+import qualified Data.Array.Comfort.Boxed as Array
+import Data.Array.Comfort.Boxed (Array)
+
+
+import qualified System.IO.Lazy as LazyIO
+import System.IO.Unsafe (unsafePerformIO)
+
+import qualified Data.List.Match as Match
+import qualified Data.Set as Set
+import qualified Data.Bool8 as Bool8
+import Data.Set (Set)
+import Data.Bool8 (Bool8)
+
+import Prelude2010
+import Prelude ()
+
+
+data State label =
+   State {
+      availableSubsets ::
+         (Array SetDim label, Phys.Array (SetDim,BlockDim) Block),
+      freeElements :: Phys.Array BlockDim Block,
+      usedSubsets :: [label]
+   }
+
+initStateIO :: (Ord a) => [ESC.Assign label (Set a)] -> IO (State label)
+initStateIO assigns = do
+   let neAssigns = filter (not . Set.null . ESC.labeledSet) assigns
+       (avails, freeBlocks) = blocksFromSets $ map ESC.labeledSet neAssigns
+       shSets = Shape.ZeroBased $ fromIntegral $ length neAssigns
+   free <- Phys.vectorFromList freeBlocks
+   avail <-
+      Phys.fromList (shSets, Phys.shape free) $
+      concatMap (Match.take freeBlocks) avails
+   return $
+      State {
+         availableSubsets =
+            (Array.fromList shSets $ map ESC.label neAssigns, avail),
+         freeElements = free,
+         usedSubsets = []
+      }
+
+
+updateStateIO :: IO (SetId -> State label -> LazyIO.T (State label))
+updateStateIO = do
+   filt <- filterDisjointRows
+   diff <- Render.run differenceWithRow
+   return $ \k s ->
+      LazyIO.interleave $
+      liftA3 State
+         (filt k $ availableSubsets s)
+         (diff (freeElements s) k $ snd $ availableSubsets s)
+         (pure (fst (availableSubsets s) Array.! k : usedSubsets s))
+
+
+
+_minimumSet ::
+   IO (Phys.Array BlockDim Block ->
+       Phys.Array (DigitDim, BlockDim) Block -> IO (Phys.Array BlockDim Block))
+_minimumSet = do
+   runNullSet <- Render.run (Expr.bool8FromP . nullSet)
+   runDifferenceWithRow <- Render.run differenceWithRow
+   return $ \baseSet bag ->
+      foldM
+         (\mins k -> do
+            newMins <- runDifferenceWithRow mins k bag
+            isNull <- runNullSet newMins
+            return $ if Bool8.toBool isNull then mins else newMins)
+         baseSet
+         (reverse $ ComfortShape.indices $ fst $ Phys.shape bag)
+
+
+differenceWithRowNull ::
+   IO (Phys.Array BlockDim Block ->
+       DigitId -> Phys.Array (DigitDim, BlockDim) Block ->
+       IO (Bool8, Phys.Array BlockDim Block))
+differenceWithRowNull =
+   Render.run $ \set k bag ->
+   Render.MapAccumLSequence
+      (\acc x -> Expr.zip (acc.|.*x) x)
+      (Expr.bool8FromP . nullBlock)
+      Expr.zero
+      (Symb.zipWith difference set $ getRow k bag)
+
+minimumSet ::
+   IO (Phys.Array BlockDim Block ->
+       Phys.Array (DigitDim, BlockDim) Block -> IO (Phys.Array BlockDim Block))
+minimumSet = do
+   runDifferenceWithRow <- differenceWithRowNull
+   return $ \baseSet bag ->
+      foldM
+         (\mins k -> do
+            (isNull,newMins) <- runDifferenceWithRow mins k bag
+            return $ if Bool8.toBool isNull then mins else newMins)
+         baseSet
+         (reverse $ ComfortShape.indices $ fst $ Phys.shape bag)
+
+
+
+keepMinimum :: IO (Phys.Array BlockDim Block -> IO (BlockId,Block))
+keepMinimum =
+   Render.run $ \xs ->
+      Expr.maybe Expr.zero (Expr.mapSnd keepMinimumBit) $
+      Symb.findAll (Expr.not . nullBlock . Expr.snd) $
+      Symb.zip (Symb.id (Symb.shape xs)) xs
+
+affectedRows ::
+   IO (Phys.Array (SetDim,BlockDim) Block -> (BlockId,Block) -> IO [SetId])
+affectedRows = do
+   affected <-
+      Render.run $ \arr (j,bit) ->
+         findIndices $ Symb.map (Expr.not . disjoint bit) $
+         Slice.apply (Slice.pickSnd j) $ Symb.fix arr
+   return $ \arr bit -> Phys.toList =<< affected arr bit
+
+minimize ::
+   IO (Phys.Array BlockDim Block ->
+       Phys.Array (SetDim,BlockDim) Block -> IO [SetId])
+minimize = do
+   smBags <- sumBags3
+   minSet <- minimumSet
+   keepMin <- keepMinimum
+   affected <- affectedRows
+   return $ \free arr ->
+      affected arr =<< keepMin =<< minSet free =<< smBags arr
+
+stepIO :: IO (State label -> LazyIO.T [State label])
+stepIO = do
+   update <- updateStateIO
+   minim <- minimize
+   return $ \s ->
+      mapM (flip update s) =<<
+      LazyIO.interleave (minim (freeElements s) (snd $ availableSubsets s))
+
+searchIO :: IO (State label -> LazyIO.T [[label]])
+searchIO = do
+   stp <- stepIO
+   nullSt <- Render.run (Expr.bool8FromP . nullSet)
+   let srch s = do
+         isNull <- LazyIO.interleave $ nullSt (freeElements s)
+         if Bool8.toBool isNull
+           then return [usedSubsets s]
+           else concat <$> (mapM srch =<< stp s)
+   return srch
+
+partitionsIO :: (Ord a) => IO ([ESC.Assign label (Set a)] -> LazyIO.T [[label]])
+partitionsIO = do
+   srch <- searchIO
+   return $ srch <=< LazyIO.interleave . initStateIO
+
+partitions :: (Ord a) => [ESC.Assign label (Set a)] -> [[label]]
+partitions =
+   let parts = unsafePerformIO partitionsIO
+   in  unsafePerformIO . LazyIO.run . parts
diff --git a/src/Math/SetCover/Exact/Knead/Saturated.hs b/src/Math/SetCover/Exact/Knead/Saturated.hs
new file mode 100644
--- /dev/null
+++ b/src/Math/SetCover/Exact/Knead/Saturated.hs
@@ -0,0 +1,473 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+module Math.SetCover.Exact.Knead.Saturated (
+   partitionsIO, searchIO, stepIO,
+   partitions,
+   State(..), initStateIO, updateStateIO,
+   ) where
+
+import qualified Math.SetCover.Exact as ESC
+import Math.SetCover.Exact.Knead.Vector (Block)
+import Math.SetCover.Exact.Knead.Symbolic
+         (SetId, SetDim, BlockId, BlockDim, blocksFromSets,
+          nullSet, disjoint, disjointRows, differenceWithRow,
+          findIndices, collectRows)
+
+import qualified Control.Monad.HT as Monad
+import Control.Monad.HT ((<=<))
+import Control.Monad (foldM)
+import Control.Applicative (liftA2, liftA3, pure, (<$>), (<*>))
+
+import qualified Data.Array.Knead.Parameterized.Render as Render
+import qualified Data.Array.Knead.Simple.Physical as Phys
+import qualified Data.Array.Knead.Simple.Symbolic as Symb
+import qualified Data.Array.Knead.Simple.Slice as Slice
+import qualified Data.Array.Knead.Shape as Shape
+import qualified Data.Array.Knead.Expression.Vector as ExprVec
+import qualified Data.Array.Knead.Expression as Expr
+import Data.Array.Knead.Expression (Exp, (/=*), (<*), (.&.*), )
+
+import qualified Data.Array.Comfort.Boxed as Array
+import Data.Array.Comfort.Boxed (Array)
+
+import qualified LLVM.Extra.Extension.X86 as X86
+import qualified LLVM.Extra.Extension as Ext
+import qualified LLVM.Extra.Multi.Vector as MultiVector
+import qualified LLVM.Extra.Multi.Value.Vector as MultiValueVec
+import qualified LLVM.Extra.Multi.Value as MultiValue
+import LLVM.Extra.Multi.Vector.Memory ()
+import LLVM.Extra.Multi.Value (atom)
+
+import qualified LLVM.Core as LLVM
+
+import qualified Type.Data.Num.Decimal as TypeNum
+import Type.Data.Num.Decimal ((:+:))
+
+import qualified System.IO.Lazy as LazyIO
+import System.IO.Unsafe (unsafePerformIO)
+
+import qualified Data.NonEmpty.Class as NonEmptyC
+import qualified Data.List.Match as Match
+import qualified Data.Set as Set
+import qualified Data.Word as Word
+import qualified Data.Int as Int
+import qualified Data.Bool8 as Bool8
+import qualified Data.Bits as Bits
+import Data.Functor.Compose (Compose(Compose,getCompose))
+import Data.Set (Set)
+
+import Prelude2010
+import Prelude ()
+
+
+type NumCounters = TypeNum.D16
+type Counter = Word.Word8
+type Counters = LLVM.Vector NumCounters Counter
+type Subblock = Word.Word8
+type Block16 = LLVM.Vector TypeNum.D8 Word.Word16
+-- type Block128 = LLVM.WordN TypeNum.D128
+
+bitSize :: Int
+bitSize = Bits.bitSize (0::Counter)
+
+numCounters :: Integer
+numCounters =
+   TypeNum.integerFromSingleton
+      (TypeNum.singleton :: TypeNum.Singleton NumCounters)
+
+type CounterId = Int.Int16
+type BitId = Int.Int8
+
+type CounterDim = Shape.ZeroBased CounterId
+type BitDim = Shape.ZeroBased BitId
+
+
+data State label =
+   State {
+      availableSubsets ::
+         (Array SetDim label, Phys.Array (SetDim,BlockDim) Block),
+      freeElements :: Phys.Array BlockDim Block,
+      usedSubsets :: [label]
+   }
+
+initStateIO :: (Ord a) => [ESC.Assign label (Set a)] -> IO (State label)
+initStateIO assigns = do
+   let neAssigns = filter (not . Set.null . ESC.labeledSet) assigns
+       (avails, freeBlocks) = blocksFromSets $ map ESC.labeledSet neAssigns
+       shSets = Shape.ZeroBased $ fromIntegral $ length neAssigns
+   free <- Phys.vectorFromList freeBlocks
+   avail <-
+      Phys.fromList (shSets, Phys.shape free) $
+      concatMap (Match.take freeBlocks) avails
+   return $
+      State {
+         availableSubsets =
+            (Array.fromList shSets $ map ESC.label neAssigns, avail),
+         freeElements = free,
+         usedSubsets = []
+      }
+
+
+repVec :: Counter -> Exp Counters
+repVec = Expr.fromInteger' . toInteger
+
+{- |
+We add bytes with saturation.
+The first operand must consist exclusively of zeros and ones.
+
+With saturation we perform the same as the unoptimized algorithm
+if the element with minimum occurrence is contained in at most 254 sets.
+This is pretty much and should never happen.
+If all elements occur in more than 254 sets
+then we will choose the first one
+which might lead to an unnecessary long case analysis,
+but would still yield correct results.
+-}
+incSat :: Exp Counters -> Exp Counters -> Exp Counters
+incSat x y =
+   let maxBnd = repVec maxBound
+   in  ExprVec.select (ExprVec.cmp LLVM.CmpEQ y maxBnd)
+         maxBnd (Expr.add x y)
+
+incSatGeneric ::
+   LLVM.Value Counters -> LLVM.Value Counters ->
+   LLVM.CodeGenFunction r (LLVM.Value Counters)
+incSatGeneric x y =
+   (\(MultiValue.Cons z) -> getCompose z)
+   <$>
+   Expr.unliftM2 incSat
+      (MultiValue.Cons (Compose x)) (MultiValue.Cons (Compose y))
+
+incSatX86 :: Exp Counters -> Exp Counters -> Exp Counters
+incSatX86 =
+   Expr.liftM2
+      (MultiValue.liftM2
+         (\xc yc ->
+            Compose <$>
+            case (getCompose xc, getCompose yc) of
+               (x,y) ->
+                  Ext.run (incSatGeneric x y)
+                     (X86.paddusb128 <*> pure x <*> pure y)))
+
+sumRows ::
+   Symb.Array (SetDim, blockDim) Counters ->
+   Render.FoldOuterL SetDim blockDim Counters Counters
+sumRows xs =
+   Render.FoldOuterL (flip incSatX86)
+      (Symb.fill (Expr.snd $ Symb.shape xs) Expr.zero) xs
+
+
+extrudeBits :: Slice.T sh (sh, BitDim)
+extrudeBits =
+   Slice.extrudeSnd $ Expr.compose $ Shape.ZeroBased $
+   Expr.fromInteger' $ toInteger bitSize
+
+extrudeCounters :: Slice.T sh (sh, CounterDim)
+extrudeCounters =
+   Slice.extrudeSnd $ Expr.compose $ Shape.ZeroBased $
+   Expr.fromInteger' numCounters
+
+toCounters :: Exp Block -> Exp Counters
+toCounters =
+   Expr.liftM (MultiValue.liftM (fmap Compose . LLVM.bitcast))
+
+_pickBits :: Exp BitId -> Exp Block -> Exp Counters
+_pickBits k block =
+   repVec 1 .&.* Expr.shr (toCounters block) (ExprVec.replicate (bitPos k))
+
+
+word16 :: Exp BitId -> Exp Word.Word16
+word16 = Expr.liftM (MultiValue.liftM LLVM.ext) . bitPos
+
+toBlock16 :: Exp Block -> Exp Block16
+toBlock16 =
+   Expr.liftM (MultiValue.liftM (fmap Compose . LLVM.bitcast))
+
+fromBlock16 :: Exp Block16 -> Exp Counters
+fromBlock16 =
+   Expr.liftM (MultiValue.liftM (fmap Compose . LLVM.bitcast . getCompose))
+
+pickBitsX86 :: Exp BitId -> Exp Block -> Exp Counters
+pickBitsX86 k block =
+   repVec 1 .&.*
+   fromBlock16 (Expr.shr (toBlock16 block) (ExprVec.replicate (word16 k)))
+
+uninterleaveBits ::
+   Symb.Array (SetDim, BlockDim) Block ->
+   Symb.Array (SetDim, (BlockDim, BitDim)) Counters
+uninterleaveBits =
+   Symb.mapWithIndex (\ix block -> pickBitsX86 (Expr.snd (Expr.snd ix)) block) .
+   Slice.apply (Slice.second extrudeBits)
+
+
+filterDisjointRows ::
+   IO (SetId ->
+       (Array SetDim label, Phys.Array (SetDim,BlockDim) Block) ->
+       IO (Array SetDim label, Phys.Array (SetDim,BlockDim) Block))
+filterDisjointRows = do
+   disjRows <- Render.run $ \k -> findIndices . disjointRows k
+   collect <- Render.run collectRows
+   return $ \k0 (labels,sets) -> do
+      perm <- disjRows k0 sets
+      liftA2 (,)
+         (Array.fromList (Phys.shape perm) . map (labels Array.!)
+            <$> Phys.toList perm)
+         (collect perm sets)
+
+updateStateIO :: IO (SetId -> State label -> LazyIO.T (State label))
+updateStateIO = do
+   filt <- filterDisjointRows
+   diff <- Render.run differenceWithRow
+   return $ \k s ->
+      LazyIO.interleave $
+      liftA3 State
+         (filt k $ availableSubsets s)
+         (diff (freeElements s) k $ snd $ availableSubsets s)
+         (pure (fst (availableSubsets s) Array.! k : usedSubsets s))
+
+
+mvvec :: MultiValue.T (LLVM.Vector n a) -> MultiVector.T n a
+mvvec (MultiValue.Cons x) = MultiVector.Cons x
+
+extract ::
+   (TypeNum.Positive n, MultiVector.C a) =>
+   Exp CounterId -> Exp (LLVM.Vector n a) -> Exp a
+extract =
+   Expr.liftM2
+      (\(MultiValue.Cons k) v ->
+         flip MultiVector.extract (mvvec v) =<< LLVM.zext k)
+
+extractBlock :: Exp CounterId -> Exp Block -> Exp Subblock
+extractBlock =
+   Expr.liftM2
+      (\(MultiValue.Cons k) (MultiValue.Cons v) ->
+         MultiValue.Cons <$> (LLVM.extractelement v =<< LLVM.zext k))
+
+flattenCounters ::
+   Symb.Array (BlockDim, BitDim) Counters ->
+   Symb.Array ((BlockDim,CounterDim), BitDim) Counter
+flattenCounters =
+   Symb.mapWithIndex (\ix block -> extract (Expr.snd (Expr.fst ix)) block) .
+   Slice.apply (Slice.first extrudeCounters)
+
+
+bitPos :: Exp BitId -> Exp Subblock
+bitPos = Expr.liftM (MultiValue.liftM LLVM.bitcast)
+
+singleBit :: Exp BitId -> Exp Subblock
+singleBit = Expr.shl 1 . bitPos
+
+
+argMin ::
+   (MultiValue.Select x, MultiValue.Select y, MultiValue.Comparison y) =>
+   Exp (x,y) -> Exp (x,y) -> Exp (x,y)
+argMin xy0 xy1 = Expr.select (Expr.snd xy0 <* Expr.snd xy1) xy0 xy1
+
+argMinimum ::
+   (Shape.C sh, Shape.Index sh ~ ix, MultiValue.Select ix) =>
+   Symb.Array sh Counter -> Exp ix
+argMinimum = Expr.fst . Symb.fold1All argMin . Symb.mapWithIndex Expr.zip
+
+_keepMinimum ::
+   IO (Phys.Array (BlockDim, BitDim) Counters ->
+       IO ((BlockId,CounterId),Counter))
+_keepMinimum =
+   Render.run $ Expr.mapSnd singleBit . argMinimum . flattenCounters
+
+
+argMinMasked ::
+   (MultiValue.Select x, MultiValue.Select y, MultiValue.Comparison y) =>
+   Exp (Bool, (x,y)) -> Exp (Bool, (x,y)) -> Exp (Bool, (x,y))
+argMinMasked xy0 xy1 =
+   Expr.select (Expr.fst xy1)
+      (Expr.select (Expr.fst xy0)
+         (Expr.zip Expr.true $ argMin (Expr.snd xy0) (Expr.snd xy1))
+         xy1)
+      xy0
+
+testBlockBit :: Exp CounterId -> Exp BitId -> Exp Block -> Exp Bool
+testBlockBit k j block = Expr.shr (extractBlock k block) (bitPos j) .&.* 1 /=* 0
+
+flattenBlockBits ::
+   Symb.Array BlockDim Block ->
+   Symb.Array ((BlockDim,CounterDim), BitDim) Bool
+flattenBlockBits =
+   Symb.mapWithIndex
+      (Expr.modify2 ((atom,atom),atom) atom $ \((_n,k),j) block ->
+         testBlockBit k j block) .
+   Slice.apply (Slice.compose extrudeCounters extrudeBits)
+
+argMinimumMasked ::
+   Symb.Array BlockDim Block ->
+   Symb.Array ((BlockDim,CounterDim), BitDim) Counter ->
+   Exp ((BlockId,CounterId),BitId)
+argMinimumMasked free =
+   Expr.fst . Expr.snd . Symb.fold1All argMinMasked .
+   Symb.zip (flattenBlockBits free) . Symb.mapWithIndex Expr.zip
+
+_keepMinimumMasked ::
+   IO (Phys.Array BlockDim Block ->
+       Phys.Array (BlockDim,BitDim) Counters ->
+       IO ((BlockId,CounterId),Counter))
+_keepMinimumMasked =
+   Render.run $ \free ->
+      Expr.mapSnd singleBit . argMinimumMasked free . flattenCounters
+
+
+argMinVec ::
+   (TypeNum.Positive n,
+    MultiVector.Select x, MultiVector.Select y, MultiVector.Comparison y) =>
+   Exp (LLVM.Vector n (x,y)) -> Exp (LLVM.Vector n (x,y)) ->
+   Exp (LLVM.Vector n (x,y))
+argMinVec xy0 xy1 =
+   ExprVec.select
+      (ExprVec.cmp LLVM.CmpLT (ExprVec.snd xy0) (ExprVec.snd xy1)) xy0 xy1
+
+argMinMaskedVec ::
+   (TypeNum.Positive n,
+    MultiVector.Select x, MultiVector.Select y, MultiVector.Comparison y) =>
+   Exp (LLVM.Vector n (Bool, (x,y))) -> Exp (LLVM.Vector n (Bool, (x,y))) ->
+   Exp (LLVM.Vector n (Bool, (x,y)))
+argMinMaskedVec xy0 xy1 =
+   ExprVec.select (ExprVec.fst xy1)
+      (ExprVec.select (ExprVec.fst xy0)
+         (ExprVec.zip (ExprVec.replicate Expr.true) $
+          argMinVec (ExprVec.snd xy0) (ExprVec.snd xy1))
+         xy1)
+      xy0
+
+testBlockBitVec ::
+   Exp BitId -> Exp Block -> Exp (LLVM.Vector NumCounters Bool)
+testBlockBitVec j block =
+   ExprVec.cmp LLVM.CmpNE Expr.zero $ pickBitsX86 j block
+
+flattenBlockBitsVec ::
+   Symb.Array BlockDim Block ->
+   Symb.Array (BlockDim,BitDim) (LLVM.Vector NumCounters Bool)
+flattenBlockBitsVec =
+   Symb.mapWithIndex
+      (Expr.modify2 (atom,atom) atom $ \(_n,j) block ->
+         testBlockBitVec j block) .
+   Slice.apply extrudeBits
+
+argMinimumMaskedVec ::
+   Symb.Array BlockDim Block ->
+   Symb.Array (BlockDim, BitDim) Counters ->
+   Exp (LLVM.Vector NumCounters (Bool, ((BlockId, BitId), Counter)))
+argMinimumMaskedVec free =
+   Symb.fold1All argMinMaskedVec .
+   Symb.zipWith ExprVec.zip (flattenBlockBitsVec free) .
+   Symb.mapWithIndex (ExprVec.zip . ExprVec.replicate)
+
+counterIds :: Exp (LLVM.Vector NumCounters CounterId)
+counterIds = ExprVec.cons (LLVM.vector (NonEmptyC.iterate (1+) 0))
+
+_keepMinimumMaskedVector ::
+   Exp (LLVM.Vector NumCounters (Bool, ((BlockId, BitId), Counter))) ->
+   Exp ((BlockId, CounterId), BitId)
+_keepMinimumMaskedVector =
+   Expr.liftM
+      (fmap (MultiValue.fst . MultiValue.snd) .
+       foldM (Expr.unliftM2 argMinMasked)
+         (MultiValue.zip (MultiValue.cons False) MultiValue.undef)
+       <=< MultiValueVec.dissect)
+   .
+   ExprVec.mapSnd
+      (ExprVec.mapFst (ExprVec.mapFst (flip ExprVec.zip counterIds)))
+
+type
+   IxVector n =
+      MultiValue.T (LLVM.Vector n
+         (Bool, (((BlockId, CounterId), BitId), Counter)))
+
+argMinMaskedVecHalf ::
+   (TypeNum.Positive n, TypeNum.Positive n2, (n:+:n) ~ n2,
+    MultiVector.Select x, MultiVector.Select y, MultiVector.Comparison y) =>
+   MultiValue.T (LLVM.Vector n2 (Bool, (x, y))) ->
+   LLVM.CodeGenFunction r (MultiValue.T (LLVM.Vector n (Bool, (x, y))))
+argMinMaskedVecHalf x =
+   Monad.liftJoin2
+      (Expr.unliftM2 argMinMaskedVec)
+      (MultiValueVec.take x)
+      (MultiValueVec.takeRev x)
+
+keepMinimumMaskedCascade ::
+   Exp (LLVM.Vector NumCounters (Bool, ((BlockId, BitId), Counter))) ->
+   Exp ((BlockId, CounterId), BitId)
+keepMinimumMaskedCascade =
+   Expr.fst . Expr.snd
+   .
+   Expr.liftM
+      (\x16 -> do
+         x8 <- argMinMaskedVecHalf x16
+         x4 <- argMinMaskedVecHalf x8
+         x2 <- argMinMaskedVecHalf x4
+         Monad.liftJoin2 (Expr.unliftM2 argMinMasked)
+            (MultiValueVec.extract (LLVM.valueOf 0) (x2 :: IxVector TypeNum.D2))
+            (MultiValueVec.extract (LLVM.valueOf 1) x2))
+   .
+   ExprVec.mapSnd
+      (ExprVec.mapFst (ExprVec.mapFst (flip ExprVec.zip counterIds)))
+
+{- |
+In general this function will choose a different minimal element
+than 'keepMinimumMasked'.
+-}
+keepMinimumMaskedVec ::
+   IO (Phys.Array BlockDim Block ->
+       Phys.Array (BlockDim, BitDim) Counters ->
+       IO ((BlockId,CounterId),Subblock))
+keepMinimumMaskedVec =
+   Render.run $ \free ->
+      Expr.mapSnd singleBit . keepMinimumMaskedCascade .
+      argMinimumMaskedVec free
+
+
+affectedRows ::
+   IO (Phys.Array (SetDim,BlockDim) Block ->
+       ((BlockId,CounterId),Subblock) -> IO [SetId])
+affectedRows = do
+   affected <-
+      Render.run $ \arr ((j,k),bit) ->
+         findIndices $ Symb.map (Expr.not . disjoint bit . extractBlock k) $
+         Slice.apply (Slice.pickSnd j) $ Symb.fix arr
+   return $ \arr bit -> Phys.toList =<< affected arr bit
+
+
+minimize ::
+   IO (Phys.Array BlockDim Block ->
+       Phys.Array (SetDim,BlockDim) Block -> IO [SetId])
+minimize = do
+   smRows <- Render.run (sumRows . uninterleaveBits)
+   affected <- affectedRows
+   keepMin <- keepMinimumMaskedVec
+   return $ \free arr -> affected arr =<< keepMin free =<< smRows arr
+
+stepIO :: IO (State label -> LazyIO.T [State label])
+stepIO = do
+   update <- updateStateIO
+   minim <- minimize
+   return $ \s ->
+      mapM (flip update s) =<<
+      LazyIO.interleave (minim (freeElements s) (snd $ availableSubsets s))
+
+searchIO :: IO (State label -> LazyIO.T [[label]])
+searchIO = do
+   stp <- stepIO
+   nullSt <- Render.run (Expr.bool8FromP . nullSet)
+   let srch s = do
+         isNull <- LazyIO.interleave $ nullSt (freeElements s)
+         if Bool8.toBool isNull
+           then return [usedSubsets s]
+           else concat <$> (mapM srch =<< stp s)
+   return srch
+
+partitionsIO :: (Ord a) => IO ([ESC.Assign label (Set a)] -> LazyIO.T [[label]])
+partitionsIO = do
+   srch <- searchIO
+   return $ srch <=< LazyIO.interleave . initStateIO
+
+partitions :: (Ord a) => [ESC.Assign label (Set a)] -> [[label]]
+partitions =
+   let parts = unsafePerformIO partitionsIO
+   in  unsafePerformIO . LazyIO.run . parts
diff --git a/src/Math/SetCover/Exact/Knead/Symbolic.hs b/src/Math/SetCover/Exact/Knead/Symbolic.hs
new file mode 100644
--- /dev/null
+++ b/src/Math/SetCover/Exact/Knead/Symbolic.hs
@@ -0,0 +1,303 @@
+module Math.SetCover.Exact.Knead.Symbolic (
+   BitSet(..),
+   Block,
+
+   SetId, SetDim, BlockId, BlockDim, DigitId, DigitDim,
+   sumBags3,
+   difference,
+   getRow,
+   nullSet,
+   disjoint,
+   disjointRows,
+   differenceWithRow,
+   findIndices,
+   filterDisjointRows,
+   collectRows,
+   ) where
+
+import qualified Math.SetCover.Exact.Block as Blocks
+
+import Control.Monad.HT ((<=<))
+import Control.Applicative (liftA2, (<$>))
+
+import qualified Data.Array.Knead.Parameterized.Render as Render
+import qualified Data.Array.Knead.Simple.Physical as Phys
+import qualified Data.Array.Knead.Simple.Symbolic as Symb
+import qualified Data.Array.Knead.Simple.Slice as Slice
+import qualified Data.Array.Knead.Shape as Shape
+import qualified Data.Array.Knead.Expression as Expr
+import Data.Array.Knead.Simple.Symbolic ((!))
+import Data.Array.Knead.Expression
+         (Exp, (==*), (<*), xor, (.|.*), (.&.*), )
+
+import qualified Data.Array.Comfort.Shape as ComfortShape
+import qualified Data.Array.Comfort.Storable.Unchecked as ComfortArray
+import qualified Data.Array.Comfort.Boxed as Array
+import Data.Array.Comfort.Boxed (Array)
+
+import qualified LLVM.Extra.Multi.Value as MultiValue
+import LLVM.Extra.Multi.Value (atom)
+
+import qualified Data.Word as Word
+import qualified Data.Int as Int
+import Data.Set (Set)
+
+import Prelude2010
+import Prelude ()
+
+
+
+class (MultiValue.Logic block) => BitSet block where
+   nullBlock :: Exp block -> Exp Bool
+   blocksFromSets :: (Ord a) => [Set a] -> ([[block]], [block])
+   keepMinimumBit :: Exp block -> Exp block
+
+instance BitSet Word.Word8 where
+   nullBlock block = block ==* Expr.zero
+   blocksFromSets sets = Blocks.blocksFromSets sets
+   keepMinimumBit = keepMinimumBitPrim
+
+instance BitSet Word.Word16 where
+   nullBlock block = block ==* Expr.zero
+   blocksFromSets sets = Blocks.blocksFromSets sets
+   keepMinimumBit = keepMinimumBitPrim
+
+instance BitSet Word.Word32 where
+   nullBlock block = block ==* Expr.zero
+   blocksFromSets sets = Blocks.blocksFromSets sets
+   keepMinimumBit = keepMinimumBitPrim
+
+instance BitSet Word.Word64 where
+   nullBlock block = block ==* Expr.zero
+   blocksFromSets sets = Blocks.blocksFromSets sets
+   keepMinimumBit = keepMinimumBitPrim
+
+keepMinimumBitPrim ::
+   (MultiValue.Additive a, MultiValue.Logic a) => Exp a -> Exp a
+keepMinimumBitPrim =
+   Expr.liftM (\x -> MultiValue.and x =<< MultiValue.neg x)
+
+
+
+type Block = Word.Word64
+
+-- SetId must allow negative numbers since it is used for empty plain Arrays
+type SetId = Int.Int32
+type BlockId = Int.Int32
+type DigitId = Word.Word32
+
+type SetDim = Shape.ZeroBased SetId
+type BlockDim = Shape.ZeroBased BlockId
+type DigitDim = Shape.ZeroBased DigitId
+
+
+addLow, addHigh :: MultiValue.Logic a => Exp a -> Exp a -> Exp a -> Exp a
+addLow a b c = a `xor` b `xor` c
+addHigh a b c = c.&.*(a.|.*b) .|.* a.&.*b
+
+add2 ::
+   IO (Phys.Array ((SetDim, BlockDim), DigitDim) Block ->
+       IO (Phys.Array ((SetDim, BlockDim), DigitDim) Block))
+add2 =
+   Render.run $ \xs ->
+   Render.MapAccumLSimple
+      (Expr.modify2 atom (atom,atom) $ \carry (a,b) ->
+         (addHigh a b carry, addLow a b carry))
+      (Symb.fill (Expr.fst (Symb.shape xs)) Expr.zero)
+      (halfBags xs)
+
+
+zbAtom :: Shape.ZeroBased (MultiValue.Atom a)
+zbAtom = Shape.ZeroBased atom
+
+halfBags ::
+   Symb.Array ((SetDim, BlockDim), DigitDim) Block ->
+   Symb.Array ((SetDim, BlockDim), DigitDim) (Block,Block)
+halfBags xs =
+   Symb.map
+      (Expr.modify2 ((zbAtom, atom), zbAtom) ((atom,atom),atom)
+         (\((Shape.ZeroBased numSets, _shBlocks), Shape.ZeroBased numDigits)
+           ((n,j),k) ->
+            elseIfThen Expr.zero (k<*numDigits) $
+            Expr.zip
+               (xs ! Expr.zip (Expr.zip (2*n) j) k)
+               (elseIfThen Expr.zero (2*n+1<*numSets)
+                  (xs ! Expr.zip (Expr.zip (2*n+1) j) k)))
+         (Symb.shape xs)) $
+   Symb.id
+      (Expr.modify ((zbAtom, atom), zbAtom)
+         (\((Shape.ZeroBased numSets, shBlocks), Shape.ZeroBased numDigits) ->
+            ((Shape.ZeroBased (Expr.idiv (numSets+1) 2), shBlocks),
+             Shape.ZeroBased (numDigits+1)))
+         (Symb.shape xs))
+
+elseIfThen :: MultiValue.C a => Exp a -> Exp Bool -> Exp a -> Exp a
+elseIfThen y c x = Expr.ifThenElse c x y
+
+
+removeDimension ::
+   IO (Phys.Array ((SetDim, BlockDim), DigitDim) Block ->
+       IO (Phys.Array (DigitDim, BlockDim) Block))
+removeDimension =
+   Render.run $
+      Symb.fix .
+      Slice.apply
+         (Slice.first (Slice.pickFst Expr.zero)
+          `Slice.compose`
+          Slice.transpose)
+
+sumLoop ::
+   IO (Phys.Array ((SetDim, BlockDim), DigitDim) Block ->
+       IO (Phys.Array (DigitDim, BlockDim) Block))
+sumLoop = do
+   runAdd2 <- add2
+   remDim <- removeDimension
+
+   let go xs =
+         if (ComfortShape.zeroBasedSize $ fst $ fst $ Phys.shape xs) > 1
+           then go =<< runAdd2 xs
+           else remDim xs
+
+   return go
+
+addSingleDim :: Phys.Array sh a -> Phys.Array (sh,DigitDim) a
+addSingleDim = ComfortArray.mapShape (flip (,) (Shape.ZeroBased 1))
+
+{-
+ToDo:
+We could use a carry-save adder that would enable more parallelism.
+Unfortunately, currently we cannot benefit from this opportunity.
+-}
+_sumBags ::
+   IO (Phys.Array (SetDim,BlockDim) Block ->
+       IO (Phys.Array (DigitDim,BlockDim) Block))
+_sumBags = (.addSingleDim) <$> sumLoop
+
+
+{- |
+A faster first addition step.
+In the first addition we do not need to propagate carry.
+We use this fact for reducing the number of rows to a third.
+-}
+_add3 ::
+   IO (Phys.Array (SetDim, BlockDim) Block ->
+       IO (Phys.Array ((SetDim, BlockDim), DigitDim) Block))
+_add3 =
+   Render.run $ \xs ->
+   Symb.mapWithIndex
+      (Expr.modify2 (atom,atom) (atom,atom,atom) $ \(_,k) (a,b,c) ->
+         Expr.ifThenElse (k ==* Expr.zero) (addLow a b c) (addHigh a b c))
+      (Slice.apply (Slice.extrudeSnd digitDim2) $ thirdBags xs)
+
+add3 ::
+   IO (Phys.Array (SetDim, BlockDim) Block ->
+       IO (Phys.Array ((SetDim, BlockDim), DigitDim) Block))
+add3 =
+   Render.run $
+   Render.AddDimension digitDim2
+      (Expr.modify2 atom (atom,atom,atom) $ \k (a,b,c) ->
+         Expr.ifThenElse (k ==* Expr.zero) (addLow a b c) (addHigh a b c))
+   .
+   thirdBags
+
+digitDim2 :: Exp DigitDim
+digitDim2 = Expr.compose $ Shape.ZeroBased $ Expr.fromInteger' 2
+
+thirdBags ::
+   Symb.Array (SetDim, BlockDim) Block ->
+   Symb.Array (SetDim, BlockDim) (Block,Block,Block)
+thirdBags xs =
+   Symb.map
+      (Expr.modify (atom,atom)
+         (\(n,j) ->
+            Expr.zip3
+               (xs ! Expr.zip (3*n) j)
+               (condAccess xs (3*n+1) j)
+               (condAccess xs (3*n+2) j))) $
+   Symb.id
+      (Expr.mapFst
+         (Expr.modify zbAtom
+            (\(Shape.ZeroBased numSets) ->
+               Shape.ZeroBased $ Expr.idiv (numSets+2) 3))
+         (Symb.shape xs))
+
+condAccess ::
+   Symb.Array (SetDim, BlockDim) Block -> Exp SetId -> Exp BlockId -> Exp Block
+condAccess xs n j =
+   Expr.ifThenElse (n <* Shape.zeroBasedSize (Expr.fst (Symb.shape xs)))
+      (xs ! Expr.zip n j) Expr.zero
+
+sumBags3 ::
+   IO (Phys.Array (SetDim,BlockDim) Block ->
+       IO (Phys.Array (DigitDim,BlockDim) Block))
+sumBags3 = liftA2 (<=<) sumLoop add3
+
+
+difference :: (MultiValue.Logic a) => Exp a -> Exp a -> Exp a
+difference x y = x .&.* Expr.complement y
+
+differenceWithRow ::
+   (Shape.C k, MultiValue.Logic block) =>
+   Symb.Array BlockDim block -> Exp (Shape.Index k) ->
+   Symb.Array (k,BlockDim) block -> Symb.Array BlockDim block
+differenceWithRow x k bag =
+   Symb.zipWith difference x (getRow k bag)
+
+
+disjoint :: (BitSet block) => Exp block -> Exp block -> Exp Bool
+disjoint x y  =  nullBlock $ x .&.* y
+
+getRow ::
+   (Shape.C k, MultiValue.C block) =>
+   Exp (Shape.Index k) ->
+   Symb.Array (k, BlockDim) block -> Symb.Array BlockDim block
+getRow k = Slice.apply (Slice.pickFst k)
+
+nullSet :: (BitSet block) => Symb.Array BlockDim block -> Exp Bool
+nullSet =
+   Expr.maybe Expr.true (const Expr.false) . Symb.findAll (Expr.not . nullBlock)
+
+disjointRow ::
+   (BitSet block) =>
+   Exp SetId -> Exp SetId -> Symb.Array (SetDim, BlockDim) block -> Exp Bool
+disjointRow k0 k1 bag =
+   nullSet $ Symb.zipWith (.&.*) (getRow k0 bag) (getRow k1 bag)
+
+disjointRows ::
+   (BitSet block) =>
+   Exp SetId -> Symb.Array (SetDim,BlockDim) block -> Symb.Array SetDim Bool
+disjointRows k0 sets =
+   Symb.map
+      (\k1 -> disjointRow k0 k1 sets)
+      (Symb.id (Expr.fst (Symb.shape sets)))
+
+
+findIndices ::
+   Symb.Array SetDim Bool -> Render.MapFilter SetDim (SetId,Bool) SetId
+findIndices arr =
+   Render.MapFilter Expr.fst Expr.snd
+      (Symb.zip (Symb.id $ Symb.shape arr) arr)
+
+collectRows ::
+   (MultiValue.C block) =>
+   Symb.Array SetDim SetId ->
+   Symb.Array (SetDim,BlockDim) block -> Symb.Array (SetDim,BlockDim) block
+collectRows rows sets =
+   Symb.backpermute
+      (Expr.mapFst (const $ Symb.shape rows) (Symb.shape sets))
+      (Expr.mapFst (rows!))
+      sets
+
+filterDisjointRows ::
+   IO (SetId ->
+       (Array SetDim label, Phys.Array (SetDim,BlockDim) Block) ->
+       IO (Array SetDim label, Phys.Array (SetDim,BlockDim) Block))
+filterDisjointRows = do
+   disjRows <- Render.run $ \k sets -> findIndices $ disjointRows k sets
+   collect <- Render.run collectRows
+   return $ \k (labels,sets) -> do
+      perm <- disjRows k sets
+      liftA2 (,)
+         (Array.fromList (Phys.shape perm) . map (labels Array.!)
+            <$> Phys.toList perm)
+         (collect perm sets)
diff --git a/src/Math/SetCover/Exact/Knead/Vector.hs b/src/Math/SetCover/Exact/Knead/Vector.hs
new file mode 100644
--- /dev/null
+++ b/src/Math/SetCover/Exact/Knead/Vector.hs
@@ -0,0 +1,109 @@
+{-# LANGUAGE TypeFamilies #-}
+module Math.SetCover.Exact.Knead.Vector (
+   ByteVector, Block(..),
+   ) where
+
+import qualified Math.SetCover.Exact.Knead as ESC_Knead
+import qualified Math.SetCover.Exact.Block as Blocks
+import Math.SetCover.Exact.Knead (BitSet)
+
+import Control.Applicative (liftA2)
+
+import qualified Data.Array.Knead.Expression as Expr
+
+import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMem
+import qualified LLVM.Extra.Multi.Value as MultiValue
+import qualified LLVM.Extra.Arithmetic as A
+
+import qualified LLVM.Core as LLVM
+import qualified Type.Data.Num.Decimal as TypeNum
+
+import qualified Foreign.Storable as Store
+import Foreign.Storable (Storable)
+import Foreign.Marshal.Array (advancePtr)
+import Foreign.Ptr (castPtr)
+import Data.Storable.Endian (peekLE, pokeLE)
+
+import qualified Data.NonEmpty.Mixed as NonEmptyM
+import qualified Data.NonEmpty.Class as NonEmptyC
+import qualified Data.NonEmpty as NonEmpty
+import qualified Data.Empty as Empty
+import Data.Word (Word8, Word64)
+import Data.Bits (shiftL, shiftR)
+
+
+type ByteVector = LLVM.Vector TypeNum.D16 Word8
+data Block = Block {block0, block1 :: !Word64}
+
+blockSize :: Int
+blockSize = 2
+
+
+{-# INLINE getByte #-}
+getByte :: Int -> Word64 -> Word8
+getByte k x = fromIntegral $ shiftR x k
+
+{-# INLINE _putByte #-}
+_putByte :: Int -> Word8 -> Word64
+_putByte k x = shiftL (fromIntegral x) k
+
+
+instance Storable Block where
+   sizeOf = (blockSize*) . Store.sizeOf . block0
+   alignment = (blockSize*) . Store.alignment . block0
+   poke ptr (Block x0 x1) = do
+      let ptr64 = castPtr ptr
+      pokeLE ptr64 x0
+      pokeLE (advancePtr ptr64 1) x1
+   peek ptr =
+      let ptr64 = castPtr ptr
+      in  liftA2 Block (peekLE ptr64) (peekLE (advancePtr ptr64 1))
+
+instance MultiValue.C Block where
+   type Repr f Block = f ByteVector
+   cons (Block x0 x1) =
+      MultiValue.consPrimitive $ LLVM.vector $
+      fmap (\k -> if k<8 then getByte k x0 else getByte k x1) $
+      NonEmptyC.iterate (1+) 0
+   undef = MultiValue.undefPrimitive
+   zero = MultiValue.zeroPrimitive
+   phis = MultiValue.phisPrimitive
+   addPhis = MultiValue.addPhisPrimitive
+
+instance MultiValue.Logic Block where
+   and = MultiValue.liftM2 LLVM.and; or = MultiValue.liftM2 LLVM.or
+   xor = MultiValue.liftM2 LLVM.xor; inv = MultiValue.liftM LLVM.inv
+
+instance MultiValueMem.C Block where
+   type Struct Block = ByteVector
+   load = MultiValueMem.loadPrimitive
+   store = MultiValueMem.storePrimitive
+   decompose = MultiValueMem.decomposePrimitive
+   compose = MultiValueMem.composePrimitive
+
+toWord128 ::
+   LLVM.Value ByteVector ->
+   LLVM.CodeGenFunction r (LLVM.Value (LLVM.WordN TypeNum.D128))
+toWord128 = LLVM.bitcast
+
+fromWord128 ::
+   LLVM.Value (LLVM.WordN TypeNum.D128) ->
+   LLVM.CodeGenFunction r (LLVM.Value ByteVector)
+fromWord128 = LLVM.bitcast
+
+instance BitSet Block where
+   nullBlock =
+      Expr.liftM (MultiValue.liftM (\x ->
+         A.cmp LLVM.CmpEQ (LLVM.value LLVM.zero) =<< toWord128 x))
+   blocksFromSets sets =
+      let (avails, free) = Blocks.blocksFromSets sets
+          numBlocks = - div (- length free) blockSize
+          makeBlock (NonEmpty.Cons x0 (NonEmpty.Cons x1 Empty.Cons)) =
+            Block x0 x1
+          sliceRow =
+            take numBlocks . map makeBlock . fst .
+            NonEmptyM.sliceVertical . (++ repeat 0)
+      in  (map sliceRow avails, sliceRow free)
+   keepMinimumBit =
+      Expr.liftM (MultiValue.liftM (\x0 ->
+         do x <- toWord128 x0; fromWord128 =<< A.and x =<< A.neg x))
diff --git a/src/Math/SetCover/Exact/Priority.hs b/src/Math/SetCover/Exact/Priority.hs
--- a/src/Math/SetCover/Exact/Priority.hs
+++ b/src/Math/SetCover/Exact/Priority.hs
@@ -8,7 +8,8 @@
    Assign, ESC.label, ESC.labeledSet, ESC.assign,
    partitions, search, step,
    State(..), initState, updateState,
-   SetId, queueMap, queueSet, queueBit, queueBitPQ,
+   Tree(..), decisionTree, completeTree,
+   SetId, queueMap, queueSet, queueBit, queueBitPQ, queueIntSet,
    ) where
 
 import qualified Math.SetCover.Queue.Map as QueueMap
@@ -21,11 +22,13 @@
 import qualified Math.SetCover.Queue as Queue
 import qualified Math.SetCover.Exact as ESC
 import Math.SetCover.Queue (Methods, SetId(SetId))
-import Math.SetCover.Exact (Assign(Assign), labeledSet)
+import Math.SetCover.Exact (Assign(Assign), labeledSet, Tree(Branch,Leaf))
 
 import qualified Math.SetCover.EnumMap as EnumMapX
 import qualified Data.EnumMap as EnumMap; import Data.EnumMap (EnumMap)
 import qualified Data.Foldable as Fold
+import Data.EnumSet (EnumSet)
+import Data.Tuple.HT (mapSnd)
 
 
 data State queue label set =
@@ -60,23 +63,27 @@
          usedSubsets = attemptLabel : usedSubsets s
        }
 
+{-# INLINE nextStates #-}
+nextStates ::
+   Methods queue set ->
+   State queue label set ->
+   EnumSet SetId -> [State queue label set]
+nextStates dict s =
+   map (flip (updateState dict) s) . EnumMap.elems .
+   EnumMapX.intersection (availableSubsets s)
+
 {-# INLINE step #-}
 step :: Methods queue set -> State queue label set -> [State queue label set]
 step dict s =
-   if EnumMap.null (availableSubsets s)
-     then []
-     else
-         flip Fold.foldMap (Queue.findMin dict (queue s)) $
-            map (flip (updateState dict) s) . EnumMap.elems .
-            EnumMapX.intersection (availableSubsets s)
+   flip Fold.foldMap (Queue.findMin dict (queue s)) $ nextStates dict s
 
 {-# INLINE search #-}
 search :: Methods queue set -> State queue label set -> [[label]]
 search dict =
    let go s =
-         if Queue.null dict (queue s)
-           then [usedSubsets s]
-           else step dict s >>= go
+         case Queue.findMin dict (queue s) of
+            Nothing -> [usedSubsets s]
+            Just setIds -> nextStates dict s setIds >>= go
    in  go
 
 {-# INLINE partitions #-}
@@ -84,6 +91,22 @@
 partitions dict = search dict . initState dict
 
 
+
+completeTree :: Methods queue set -> State queue label set -> Tree label set
+completeTree dict =
+   let go s =
+         case Queue.findMinValue dict (queue s) of
+            Nothing -> Leaf
+            Just mins ->
+               uncurry Branch $ flip mapSnd mins $
+                  map (\asn -> (ESC.label asn, go $ updateState dict asn s)) .
+                  EnumMap.elems . EnumMapX.intersection (availableSubsets s)
+   in  go
+
+decisionTree :: Methods queue set -> [Assign label set] -> Tree label set
+decisionTree dict = completeTree dict . initState dict
+
+
 -- * different priority queue implementations
 
 queueMap :: Ord a => Queue.Methods queue set -> QueueMap.Methods a queue set
@@ -94,6 +117,9 @@
 
 queueBit :: BitPos.C bits => QueueBit.Methods bits
 queueBit = QueueBit.methods
+
+queueIntSet :: QueueBit.MethodsIntSet
+queueIntSet = QueueBit.methodsIntSet
 
 queueBitPQ :: BitPos.C bits => QueueBitPQ.Methods bits
 queueBitPQ = QueueBitPQ.methods
diff --git a/src/Math/SetCover/Exact/UArray.hs b/src/Math/SetCover/Exact/UArray.hs
new file mode 100644
--- /dev/null
+++ b/src/Math/SetCover/Exact/UArray.hs
@@ -0,0 +1,267 @@
+{- |
+This implements "Math.SetCover.Exact" using unboxed arrays of bit vectors.
+It should always be faster than using 'Integer's as bit vectors.
+In contrast to 'IntSet' the set representation here is dense,
+but has a much simpler structure.
+It should be faster than 'IntSet' for most applications.
+-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Math.SetCover.Exact.UArray (
+   partitions, search, step,
+   State(..), initState, updateState,
+   ) where
+
+import qualified Math.SetCover.Exact as ESC
+import qualified Math.SetCover.Bit as Bit
+import Math.SetCover.Exact.Block (blocksFromSets)
+
+import Control.Monad.ST.Strict (ST)
+import Control.Monad (foldM, forM_, when)
+
+import qualified Data.Array.ST as STUArray
+import qualified Data.Array.Unboxed as UArray
+import qualified Data.List.Match as Match
+import qualified Data.Set as Set
+import qualified Data.Word as Word
+import Data.Array.ST (STUArray, runSTUArray, writeArray)
+import Data.Array.Unboxed (UArray)
+import Data.Array.IArray (listArray, bounds, range, (!))
+import Data.Array (Array, Ix)
+import Data.Set (Set)
+import Data.Tuple.HT (mapPair, mapSnd, fst3)
+import Data.Bits (xor, (.&.), (.|.))
+
+
+
+type Block = Word.Word64
+
+newtype SetId = SetId Int deriving (Eq,Ord,Ix,Enum,Show)
+newtype DigitId = DigitId Int deriving (Eq,Ord,Ix,Enum,Show)
+newtype BlockId = BlockId Int deriving (Eq,Ord,Ix,Show)
+
+
+data State label =
+   State {
+      availableSubsets :: (Array SetId label, UArray (SetId,BlockId) Block),
+      freeElements :: UArray BlockId Block,
+      usedSubsets :: [label]
+   }
+
+initState :: (Ord a) => [ESC.Assign label (Set a)] -> State label
+initState assigns =
+   let neAssigns = filter (not . Set.null . ESC.labeledSet) assigns
+       (avails, free) = blocksFromSets $ map ESC.labeledSet neAssigns
+       firstSet = SetId 0; lastSet = SetId $ length neAssigns - 1
+       firstBlock = BlockId 0; lastBlock = BlockId $ length free - 1
+   in State {
+         availableSubsets =
+            (listArray (firstSet,lastSet) $ map ESC.label neAssigns,
+             listArray ((firstSet,firstBlock), (lastSet,lastBlock)) $
+             concatMap (Match.take free) avails),
+         freeElements = listArray (firstBlock,lastBlock) free,
+         usedSubsets = []
+      }
+
+
+type DifferenceWithRow k =
+   UArray BlockId Block -> k ->
+   UArray (k,BlockId) Block -> UArray BlockId Block
+
+{-# SPECIALISE differenceWithRow :: DifferenceWithRow SetId #-}
+{-# SPECIALISE differenceWithRow :: DifferenceWithRow DigitId #-}
+differenceWithRow :: (Ix k) => DifferenceWithRow k
+differenceWithRow x k bag =
+   listArray (bounds x) $
+   map (\j -> Bit.difference (x!j) (bag!(k,j))) (range $ bounds x)
+
+
+disjoint :: Block -> Block -> Bool
+disjoint x y  =  x.&.y == 0
+
+disjointRow :: SetId -> SetId -> UArray (SetId, BlockId) Block -> Bool
+disjointRow k0 k1 sets =
+   all
+      (\j -> disjoint (sets!(k0,j)) (sets!(k1,j)))
+      (range $ mapPair (snd,snd) $ bounds sets)
+
+filterDisjointRows ::
+   SetId ->
+   (Array SetId label, UArray (SetId,BlockId) Block) ->
+   (Array SetId label, UArray (SetId,BlockId) Block)
+filterDisjointRows k0 (labels,sets) =
+   let ((kl,jl), (ku,ju)) = bounds sets
+       rows = filter (\k1 -> disjointRow k0 k1 sets) $ range (kl,ku)
+       firstSet = SetId 0; lastSet = SetId $ length rows - 1
+       rowsArr = listArray (firstSet, lastSet) rows
+       bnds = ((firstSet,jl), (lastSet,ju))
+   in  (UArray.amap (labels!) rowsArr,
+        listArray bnds $ map (\(n,j) -> sets!(rowsArr!n,j)) $ range bnds)
+
+
+{-# INLINE updateState #-}
+updateState :: SetId -> State label -> State label
+updateState k s =
+   State {
+      availableSubsets = filterDisjointRows k $ availableSubsets s,
+      freeElements =
+         differenceWithRow (freeElements s) k $ snd $ availableSubsets s,
+      usedSubsets = fst (availableSubsets s) ! k : usedSubsets s
+   }
+
+
+
+halfBags :: SetId -> SetId -> (SetId, SetId)
+halfBags (SetId firstBag) (SetId lastBag) =
+   (SetId $ div (lastBag-firstBag) 2,
+    SetId $ div (lastBag-firstBag-1) 2)
+
+double :: SetId -> SetId
+double (SetId n) = SetId (2*n)
+
+add2TransposedST ::
+   UArray (SetId, BlockId, DigitId) Block ->
+   ST s (STUArray s (SetId, BlockId, DigitId) Block)
+add2TransposedST xs = do
+   let ((firstBag,firstBlock,firstDigit), (lastBag,lastBlock,lastDigit)) =
+         UArray.bounds xs
+   let newFirstBag = SetId 0
+   let (newLastBag, newLastFullBag) = halfBags firstBag lastBag
+
+   let mostSigNull =
+         all (\(n,j) -> xs!(n,j,lastDigit) == 0) $
+         range ((firstBag,firstBlock), (lastBag,lastBlock))
+   let newLastDigit = if mostSigNull then lastDigit else succ lastDigit
+
+   ys <- STUArray.newArray_
+            ((newFirstBag, firstBlock, firstDigit),
+             (newLastBag, lastBlock, newLastDigit))
+   forM_ (range (newFirstBag,newLastFullBag)) $ \n ->
+      forM_ (range (firstBlock,lastBlock)) $ \j ->
+         writeArray ys (n,j,newLastDigit) =<<
+            foldM
+               (\carry k -> do
+                  let a = xs ! (double n, j, k)
+                  let b = xs ! (succ $ double n, j, k)
+                  writeArray ys (n,j,k) $ xor carry (xor a b)
+                  return $ carry.&.(a.|.b) .|. a.&.b)
+               0 (range (firstDigit, pred newLastDigit))
+   when (newLastFullBag<newLastBag) $ do
+      let n = newLastBag
+      forM_ (range (firstBlock,lastBlock)) $ \j -> do
+         forM_ (range (firstDigit, pred newLastDigit)) $ \k ->
+            writeArray ys (n,j,k) $ xs!(double n,j,k)
+         writeArray ys (n,j,newLastDigit) 0
+   return ys
+
+add2ST ::
+   UArray (SetId, DigitId, BlockId) Block ->
+   ST s (STUArray s (SetId, DigitId, BlockId) Block)
+add2ST xs = do
+   let ((firstBag,firstDigit,firstBlock), (lastBag,lastDigit,lastBlock)) =
+         UArray.bounds xs
+   let newFirstBag = SetId 0
+   let (newLastBag, newLastFullBag) = halfBags firstBag lastBag
+
+   let mostSigNull =
+         all (\(n,j) -> xs!(n,lastDigit,j) == 0) $
+         range ((firstBag,firstBlock), (lastBag,lastBlock))
+   let newLastDigit = if mostSigNull then lastDigit else succ lastDigit
+
+   ys <- STUArray.newArray_
+            ((newFirstBag, firstDigit, firstBlock),
+             (newLastBag, newLastDigit, lastBlock))
+   forM_ (range (newFirstBag,newLastFullBag)) $ \n ->
+      forM_ (range (firstBlock,lastBlock)) $ \j ->
+         writeArray ys (n,newLastDigit,j) =<<
+            foldM
+               (\carry k -> do
+                  let a = xs ! (double n, k, j)
+                  let b = xs ! (succ $ double n, k, j)
+                  writeArray ys (n,k,j) $ xor carry (xor a b)
+                  return $ carry.&.(a.|.b) .|. a.&.b)
+               0 (range (firstDigit, pred newLastDigit))
+   when (newLastFullBag<newLastBag) $ do
+      let n = newLastBag
+      forM_ (range (firstBlock,lastBlock)) $ \j -> do
+         forM_ (range (firstDigit,pred newLastDigit)) $ \k ->
+            writeArray ys (n,k,j) $ xs!(double n,k,j)
+         writeArray ys (n,newLastDigit,j) 0
+   return ys
+
+add2 ::
+   UArray (SetId, DigitId, BlockId) Block ->
+   UArray (SetId, DigitId, BlockId) Block
+add2 xs = runSTUArray (add2ST xs)
+
+sumBags :: UArray (SetId,BlockId) Block -> UArray (DigitId,BlockId) Block
+sumBags arr =
+   let go xs =
+         if (UArray.rangeSize $ mapPair (fst3,fst3) $ bounds xs) > 1
+           then go $ add2 xs
+           else UArray.ixmap
+                  (case bounds xs of
+                     ((_,kl,jl), (_,ku,ju)) -> ((kl,jl), (ku,ju)))
+                  (\(k,j) -> (SetId 0, k, j)) xs
+   in  go $
+       UArray.ixmap
+         (case bounds arr of
+            ((nl,jl), (nu,ju)) -> ((nl, DigitId 0, jl), (nu, DigitId 0, ju)))
+         (\(n,_,j) -> (n,j)) arr
+
+_sumBagsTransposed ::
+   UArray (SetId,BlockId) Block -> UArray (DigitId,BlockId) Block
+_sumBagsTransposed arr =
+   let go xs =
+         if (UArray.rangeSize $ mapPair (fst3,fst3) $ bounds xs) > 1
+           then go $ runSTUArray (add2TransposedST xs)
+           else UArray.ixmap
+                  (case bounds xs of
+                     ((_,jl,kl), (_,ju,ku)) -> ((kl,jl), (ku,ju)))
+                  (\(k,j) -> (SetId 0, j, k)) xs
+   in  go $
+       UArray.ixmap
+         (case bounds arr of
+            ((nl,jl), (nu,ju)) -> ((nl, jl, DigitId 0), (nu, ju, DigitId 0)))
+         (\(n,j,_) -> (n,j)) arr
+
+
+nullSet :: UArray BlockId Block -> Bool
+nullSet = all (0==) . UArray.elems
+
+minimumSet ::
+   UArray BlockId Block ->
+   UArray (DigitId, BlockId) Block -> UArray BlockId Block
+minimumSet baseSet bag =
+   foldr
+      (\k mins ->
+         case differenceWithRow mins k bag of
+            newMins -> if nullSet newMins then mins else newMins)
+      baseSet
+      (range $ mapPair (fst,fst) $ bounds bag)
+
+keepMinimum :: UArray BlockId Block -> (BlockId,Block)
+keepMinimum =
+   mapSnd Bit.keepMinimum . head . dropWhile ((0==) . snd) . UArray.assocs
+
+affectedRows :: (Ix n) => UArray (n,BlockId) Block -> (BlockId,Block) -> [n]
+affectedRows arr (j,bit) =
+   filter (\n -> not $ disjoint bit $ arr!(n,j)) $
+   range $ mapPair (fst,fst) $ bounds arr
+
+minimize :: UArray BlockId Block -> UArray (SetId,BlockId) Block -> [SetId]
+minimize free arr =
+   affectedRows arr . keepMinimum . minimumSet free $ sumBags arr
+
+step :: State label -> [State label]
+step s =
+   map (flip updateState s) $
+   minimize (freeElements s) (snd $ availableSubsets s)
+
+search :: State label -> [[label]]
+search s =
+   if nullSet (freeElements s)
+     then [usedSubsets s]
+     else search =<< step s
+
+partitions :: (Ord a) => [ESC.Assign label (Set a)] -> [[label]]
+partitions = search . initState
diff --git a/src/Math/SetCover/IntSet.hs b/src/Math/SetCover/IntSet.hs
deleted file mode 100644
--- a/src/Math/SetCover/IntSet.hs
+++ /dev/null
@@ -1,42 +0,0 @@
-module Math.SetCover.IntSet (Set, fromIntSet, findMin) where
-
-import qualified Math.SetCover.Bit as Bit
-
-import qualified Data.IntSet as IntSet
-import Data.IntSet (IntSet)
-
-
-data Set = Set {_complement :: Bool, _set :: IntSet}
-   deriving (Eq, Ord)
-
-fromIntSet :: IntSet -> Set
-fromIntSet = Set False
-
-findMin :: Set -> Int
-findMin (Set c s) =
-   if c
-     then head $ dropWhile (flip IntSet.member s) [0..]
-     else IntSet.findMin s
-
-xor :: IntSet -> IntSet -> IntSet
-xor x y = IntSet.difference (IntSet.union x y) (IntSet.intersection x y)
-
-instance Bit.C Set where
-   empty = fromIntSet IntSet.empty
-   keepMinimum = fromIntSet . IntSet.singleton . findMin
-   complement (Set c s) = Set (not c) s
-   xor (Set c0 s0) (Set c1 s1) = Set (c0/=c1) (xor s0 s1)
-   Set c0 s0 .&. Set c1 s1 =
-      Set (c0&&c1) $
-      case (c0,c1) of
-         (False, False) -> IntSet.intersection s0 s1
-         (False, True)  -> IntSet.difference s0 s1
-         (True,  False) -> IntSet.difference s1 s0
-         (True,  True)  -> IntSet.union s0 s1
-   Set c0 s0 .|. Set c1 s1 =
-      Set (c0||c1) $
-      case (c0,c1) of
-         (False, False) -> IntSet.union s0 s1
-         (False, True)  -> IntSet.difference s1 s0
-         (True,  False) -> IntSet.difference s0 s1
-         (True,  True)  -> IntSet.intersection s0 s1
diff --git a/src/Math/SetCover/Queue.hs b/src/Math/SetCover/Queue.hs
--- a/src/Math/SetCover/Queue.hs
+++ b/src/Math/SetCover/Queue.hs
@@ -1,4 +1,4 @@
-module Math.SetCover.Queue (SetId(..), Methods(..)) where
+module Math.SetCover.Queue (SetId(..), Methods(..), findMin) where
 
 import Data.EnumMap (EnumMap)
 import Data.EnumSet (EnumSet)
@@ -16,6 +16,9 @@
       fromEnumMap :: EnumMap SetId set -> queue,
       partition :: queue -> set -> (EnumSet SetId, queue),
       difference :: queue -> EnumMap SetId set -> queue,
-      findMin :: queue -> Maybe (EnumSet SetId),
+      findMinValue :: queue -> Maybe (set, EnumSet SetId),
       null :: queue -> Bool
    }
+
+findMin :: Methods queue set -> queue -> Maybe (EnumSet SetId)
+findMin dict = fmap snd . findMinValue dict
diff --git a/src/Math/SetCover/Queue/Bit.hs b/src/Math/SetCover/Queue/Bit.hs
--- a/src/Math/SetCover/Queue/Bit.hs
+++ b/src/Math/SetCover/Queue/Bit.hs
@@ -2,7 +2,10 @@
 Alternative to "Math.SetCover.Queue.Set"
 that represents sets by bit masks and uses the faster Int priority queue.
 -}
-module Math.SetCover.Queue.Bit (Methods, methods) where
+module Math.SetCover.Queue.Bit (
+   Methods, methods,
+   MethodsIntSet, methodsIntSet,
+   ) where
 
 import qualified Math.SetCover.Queue as Queue
 import Math.SetCover.Queue (SetId)
@@ -14,8 +17,10 @@
 import qualified Data.IntPSQ as PSQ
 import qualified Data.EnumSet as EnumSet; import Data.EnumSet (EnumSet)
 import qualified Data.IntMap as IntMap
+import qualified Data.IntSet as IntSet
 import qualified Data.List as List
-import Data.Tuple.HT (swap, mapFst, thd3)
+import Data.IntSet (IntSet)
+import Data.Tuple.HT (swap, mapFst)
 
 
 type
@@ -33,7 +38,27 @@
       Queue.difference = \q ->
          foldl (flip deleteSetFromPSQ) q .
          IntMap.toList . EnumMapX.transposeBitSet,
-      Queue.findMin = fmap thd3 . PSQ.findMin,
+      Queue.findMinValue =
+         fmap (\(elm, _, ns) -> (BitPos.singleton elm, ns)) . PSQ.findMin,
+      Queue.null = PSQ.null
+   }
+
+
+type MethodsIntSet = Queue.Methods (PSQ.IntPSQ Int (EnumSet SetId)) IntSet
+
+methodsIntSet :: MethodsIntSet
+methodsIntSet =
+   Queue.Methods {
+      Queue.fromEnumMap =
+         PSQ.fromList . map (\(elm, ns) -> (elm, EnumSet.size ns, ns)) .
+         IntMap.toList . EnumMapX.transposeIntSet,
+      Queue.partition =
+         \q -> mapFst EnumSet.unions . partitionPSQ q . IntSet.toList,
+      Queue.difference = \q ->
+         foldl (flip deleteSetFromPSQ) q .
+         IntMap.toList . EnumMapX.transposeIntSet,
+      Queue.findMinValue =
+         fmap (\(elm, _, ns) -> (IntSet.singleton elm, ns)) . PSQ.findMin,
       Queue.null = PSQ.null
    }
 
diff --git a/src/Math/SetCover/Queue/BitPriorityQueue.hs b/src/Math/SetCover/Queue/BitPriorityQueue.hs
--- a/src/Math/SetCover/Queue/BitPriorityQueue.hs
+++ b/src/Math/SetCover/Queue/BitPriorityQueue.hs
@@ -22,6 +22,6 @@
       Queue.fromEnumMap = BitPQ.fromSets,
       Queue.partition = (mapFst BitPQ.elemUnions.) . BitPQ.partition,
       Queue.difference = \q -> BitPQ.difference q . BitPQ.fromSets,
-      Queue.findMin = BitPQ.findMin,
+      Queue.findMinValue = BitPQ.findMinValue,
       Queue.null = BitPQ.null
    }
diff --git a/src/Math/SetCover/Queue/Map.hs b/src/Math/SetCover/Queue/Map.hs
--- a/src/Math/SetCover/Queue/Map.hs
+++ b/src/Math/SetCover/Queue/Map.hs
@@ -6,11 +6,10 @@
 import qualified Data.OrdPSQ as PSQ
 import qualified Data.EnumSet as EnumSet
 import qualified Data.Map as Map; import Data.Map (Map)
-import Control.Monad.HT ((<=<))
 import Control.Applicative ((<$>))
 import Data.Monoid (Monoid, mempty, mappend)
-import Data.Maybe (mapMaybe)
-import Data.Tuple.HT (mapFst, mapSnd, thd3)
+import Data.Maybe (mapMaybe, fromMaybe)
+import Data.Tuple.HT (mapFst, mapSnd)
 
 
 type Methods a queue set = Queue.Methods (PSQ.OrdPSQ a Int queue) (Map a set)
@@ -30,9 +29,17 @@
       Queue.difference = \q s ->
          apply ((addMinSize m .) . Queue.difference m)
             q (EnumMapX.transposeMap s),
-      Queue.findMin = Queue.findMin m . thd3 <=< PSQ.findMin,
+      Queue.findMinValue = \qo -> do
+         (elm,_,qi) <- PSQ.findMin qo
+         let (minSet,ns) =
+               checkSubQueue "findMinValue" $ Queue.findMinValue m qi
+         return (Map.singleton elm minSet, ns),
       Queue.null = PSQ.null
    }
+
+checkSubQueue :: String -> Maybe queue -> queue
+checkSubQueue name =
+   fromMaybe (error ("Queue.Map." ++ name ++ ": empty sub-queue"))
 
 addMinSize :: Queue.Methods queue set -> queue -> Maybe (Int, queue)
 addMinSize m q = flip (,) q . EnumSet.size <$> Queue.findMin m q
diff --git a/src/Math/SetCover/Queue/Set.hs b/src/Math/SetCover/Queue/Set.hs
--- a/src/Math/SetCover/Queue/Set.hs
+++ b/src/Math/SetCover/Queue/Set.hs
@@ -13,7 +13,8 @@
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Data.List as List
-import Data.Tuple.HT (swap, mapFst, thd3)
+import Data.EnumMap (EnumMap)
+import Data.Tuple.HT (swap, mapFst)
 
 
 type Methods a = Queue.Methods (PSQ.OrdPSQ a Int (EnumSet SetId)) (Set.Set a)
@@ -26,9 +27,9 @@
          Map.toList . EnumMapX.transposeSet,
       Queue.partition =
          \q -> mapFst EnumSet.unions . partitionPSQ q . Set.toList,
-      Queue.difference = \q ->
-         foldl (flip deleteSetFromPSQ) q . Map.toList . EnumMapX.transposeSet,
-      Queue.findMin = fmap thd3 . PSQ.findMin,
+      Queue.difference = differencePSQ,
+      Queue.findMinValue =
+         fmap (\(elm, _, ns) -> (Set.singleton elm, ns)) . PSQ.findMin,
       Queue.null = PSQ.null
    }
 
@@ -45,6 +46,16 @@
             (error "partitionPSQ: key not contained in queue's key set")
             (\(_p,v,q1) -> (q1, v)) $
          PSQ.deleteView k q0)
+
+differencePSQ, _differencePSQ ::
+   (Ord k, Enum e) =>
+   PSQ.OrdPSQ k Int (EnumSet e) ->
+   EnumMap e (Set.Set k) -> PSQ.OrdPSQ k Int (EnumSet e)
+differencePSQ q =
+   foldl (flip deleteSetFromPSQ) q . Map.toList . EnumMapX.transposeSet
+
+_differencePSQ q =
+   Map.foldlWithKey (curry . flip deleteSetFromPSQ) q . EnumMapX.transposeSet
 
 deleteSetFromPSQ ::
    (Ord k) =>
diff --git a/test/Test.hs b/test/Test.hs
new file mode 100644
--- /dev/null
+++ b/test/Test.hs
@@ -0,0 +1,314 @@
+module Main where
+
+import qualified Mastermind.Test as Mastermind
+import qualified Test.Knead as TestKnead
+import Test.Utility
+         (normalizeSolution, equivalentSolutions,
+          setAssigns, genWord, genWords,
+          InflatedString, genInflatedWords, forAllShrinkSmall)
+
+import qualified Math.SetCover.Exact.UArray as ESC_UArray
+import qualified Math.SetCover.Exact.Priority as ESCP
+import qualified Math.SetCover.Exact as ESC
+import qualified Math.SetCover.Queue as Queue
+
+import Control.Monad (liftM2)
+import Control.Applicative ((<$>))
+
+import qualified Data.Map as Map; import Data.Map(Map)
+import qualified Data.Set as Set; import Data.Set(Set)
+
+import qualified Data.Foldable as Fold
+import qualified Data.List as List
+import qualified Data.Monoid.HT as Mn
+import Data.Ord.HT (comparing)
+import Data.Eq.HT (equating)
+import Data.Tuple.HT (mapFst, mapSnd)
+
+import qualified Test.QuickCheck as QC
+
+
+distinct :: (QC.Arbitrary a, Eq a) => QC.Gen [a]
+distinct = List.nub <$> QC.arbitrary
+
+singletonAssigns :: [a] -> [ESC.Assign a (Set a)]
+singletonAssigns = map (\x -> ESC.assign x (Set.singleton x))
+
+partitionDistinct :: [Char] -> Bool
+partitionDistinct xs =
+   case ESC.partitions $ singletonAssigns xs of
+      [ys] -> equating List.sort xs ys
+      _ -> False
+
+partitionMultiplicity :: [Char] -> Bool
+partitionMultiplicity xs =
+   (Fold.product $ Map.fromListWith (+) $ map (flip (,) 1) xs)
+   ==
+   (length $ ESC.partitions $ singletonAssigns xs)
+
+
+sortInt :: [(Int, a)] -> [(Int, a)]
+sortInt = List.sortBy (comparing fst)
+
+genShuffled :: QC.Gen ([String], [String])
+genShuffled = do
+   kxs <- take 10 <$> QC.listOf (liftM2 (,) QC.arbitrary genWord)
+   return (snd <$> kxs, snd <$> sortInt kxs)
+
+partitionShuffled :: [String] -> [String] -> Bool
+partitionShuffled xs ys =
+   equivalentSolutions
+      (ESC.partitions $ setAssigns xs)
+      (ESC.partitions $ setAssigns ys)
+
+
+genExtraSet :: QC.Gen (String, [String])
+genExtraSet = do
+   xs <- genWords
+   let es = Fold.foldMap Set.fromList xs
+   x <-
+      if Set.null es
+        then return ""
+        else take 5 <$> (QC.listOf $ QC.elements $ Set.toList es)
+   return (x,xs)
+
+
+{- |
+This function compares two multi-sets represented by sorted lists.
+
+@
+List.sort xs `orderedSublist` List.sort ys
+==>
+Set.fromList xs `Set.isSubsetOf` Set.fromList ys
+@
+
+The converse is not true, because e.g. @xs == "aa", ys == "a"@.
+-}
+orderedSublist :: (Ord a) => [a] -> [a] -> Bool
+orderedSublist xs0 ys0 =
+   foldr
+      (\y go xt ->
+         case xt of
+            [] -> True
+            x:xs ->
+               case compare x y of
+                  LT -> False
+                  GT -> go xt
+                  EQ -> go xs)
+      null ys0 xs0
+
+partitionAddSet :: String -> [String] -> Bool
+partitionAddSet x xs =
+   (normalizeSolution $ ESC.partitions $ setAssigns xs)
+   `orderedSublist`
+   (normalizeSolution $ ESC.partitions $ setAssigns $ x : xs)
+
+
+removeOverlap :: (Ord a) => [Set a] -> [Set a]
+removeOverlap xs =
+   filter (not . Set.null) $ snd $
+   List.mapAccumL
+      (\uni y -> (Set.difference uni y, Set.intersection y uni))
+      (Set.unions xs) xs
+
+removeOverlapList :: (Ord a) => [[a]] -> [[a]]
+removeOverlapList = map Set.toList . removeOverlap . map Set.fromList
+
+genPartition :: QC.Gen ([String], [String])
+genPartition = do
+   xs <- genWords
+   return (removeOverlapList xs, xs)
+
+partitionAddPartition :: [String] -> [String] -> Bool
+partitionAddPartition ys xs =
+   let nys =
+         zipWith (\n y -> ESC.assign (Left n) (Set.fromList y)) [(0::Int) ..] ys
+   in  elem
+         (map ESC.label nys)
+         (map List.sort $ ESC.partitions $
+            nys ++ map (\x -> ESC.assign (Right x) (Set.fromList x)) xs)
+
+
+partitionIntegerBitSet :: [InflatedString] -> Bool
+partitionIntegerBitSet xs =
+   let asns = setAssigns xs
+   in  equivalentSolutions
+         (ESC.partitions asns)
+         (ESC.partitions $ ESC.bitVectorFromSetAssigns asns)
+
+partitionIntSet :: [InflatedString] -> Bool
+partitionIntSet xs =
+   let asns = setAssigns xs
+   in  equivalentSolutions
+         (ESC.partitions asns)
+         (ESC.partitions $ ESC.intSetFromSetAssigns asns)
+
+partitionUArray :: [InflatedString] -> Bool
+partitionUArray xs =
+   let asns = setAssigns xs
+   in  equivalentSolutions
+         (ESC.partitions asns)
+         (ESC_UArray.partitions asns)
+
+
+genPairs :: QC.Gen [[(Char,Char)]]
+genPairs =
+   fmap (take 10) $ QC.listOf $
+   fmap (take 10) $ QC.listOf $
+      liftM2 (,) (QC.choose ('A','C')) (QC.choose ('a','c'))
+
+-- | occasionally add non-overlapping sets such that there are solutions
+genSolvablePairs :: QC.Gen [[(Char,Char)]]
+genSolvablePairs = do
+   pairs <- genPairs
+   b0 <- QC.arbitrary
+   b1 <- QC.arbitrary
+   return $
+      pairs
+       ++ Mn.when b0 (removeOverlapList pairs)
+       ++ Mn.when b1 (removeOverlapList $ reverse pairs)
+
+uncurryMap :: (Ord a, Ord b) => [(a, b)] -> Map a (Set b)
+uncurryMap = Map.fromListWith Set.union . map (mapSnd Set.singleton)
+
+partitionMap :: [[(Char,Char)]] -> Bool
+partitionMap xs =
+   equivalentSolutions
+      (ESC.partitions $ setAssigns xs)
+      (ESC.partitions $ map (\m -> ESC.assign m $ uncurryMap m) xs)
+
+
+partitionQueueGen ::
+   (Ord label, ESC.Set set) =>
+   Queue.Methods queue set -> ([a] -> [ESC.Assign label set]) -> [a] -> Bool
+partitionQueueGen methods makeAssigns xs =
+   let asns = makeAssigns xs
+   in  equivalentSolutions
+         (ESC.partitions asns)
+         (ESCP.partitions methods asns)
+
+partitionQueueSet :: [String] -> Bool
+partitionQueueSet = partitionQueueGen ESCP.queueSet setAssigns
+
+mapAssigns ::
+   [[(Char, Char)]] -> [ESC.Assign [(Char, Char)] (Map Char (Set Char))]
+mapAssigns = map (\m -> ESC.assign m $ uncurryMap m)
+
+partitionQueueMap :: [[(Char,Char)]] -> Bool
+partitionQueueMap =
+   partitionQueueGen (ESCP.queueMap ESCP.queueSet) mapAssigns
+
+partitionQueueBit :: [String] -> Bool
+partitionQueueBit =
+   partitionQueueGen ESCP.queueBit (ESC.bitVectorFromSetAssigns . setAssigns)
+
+partitionQueueBitPQ :: [String] -> Bool
+partitionQueueBitPQ =
+   partitionQueueGen ESCP.queueBitPQ (ESC.bitVectorFromSetAssigns . setAssigns)
+
+partitionQueueIntSet :: [String] -> Bool
+partitionQueueIntSet =
+   partitionQueueGen ESCP.queueIntSet (ESC.intSetFromSetAssigns . setAssigns)
+
+
+flattenTreeForward :: ESC.Tree label set -> [[label]]
+flattenTreeForward =
+   let go ESC.Leaf = [[]]
+       go (ESC.Branch _ xs) =
+         concatMap (\(label, subTree) -> (label:) <$> go subTree) xs
+   in  go
+
+flattenTree :: ESC.Tree label set -> [[label]]
+flattenTree =
+   let go labels tree =
+         case tree of
+            ESC.Leaf -> [labels]
+            ESC.Branch _ xs -> concatMap (uncurry $ go . (:labels)) xs
+   in  go []
+
+partitionTree :: [String] -> Bool
+partitionTree xs =
+   let asns = setAssigns xs
+   in  equivalentSolutions
+         (ESC.partitions asns)
+         (flattenTree $ ESC.decisionTree asns)
+
+
+treeQueueGen ::
+   (Ord label, ESC.Choose set, Eq set) =>
+   Queue.Methods queue set -> ([a] -> [ESC.Assign label set]) -> [a] -> Bool
+treeQueueGen methods makeAssigns xs =
+   let asns = makeAssigns xs
+   in  ESC.decisionTree asns == ESCP.decisionTree methods asns
+
+
+forAll ::
+   (QC.Testable prop, Show a) =>
+   QC.Gen a -> (a -> prop) -> (Int, QC.Property)
+forAll gen = (,) 1000 . QC.forAll gen
+
+forAllShrink ::
+   (QC.Testable prop, Show a, QC.Arbitrary a) =>
+   QC.Gen a -> (a -> prop) -> (Int, QC.Property)
+forAllShrink gen = (,) 1000 . QC.forAllShrink gen QC.shrink
+
+tests :: [(String, (Int, QC.Property))]
+tests =
+   map (mapFst ("Exact."++)) $
+   ("partitionDistinct",
+      forAll (take 10 <$> distinct) partitionDistinct) :
+   ("partitionMultiplicity",
+      forAllShrink (take 10 <$> QC.arbitrary) partitionMultiplicity) :
+   ("partitionShuffled",
+      forAll genShuffled $ uncurry partitionShuffled) :
+   ("partitionAddSet",
+      forAll genExtraSet $ uncurry partitionAddSet) :
+   ("partitionAddPartition",
+      forAll genPartition $ uncurry partitionAddPartition) :
+   ("partitionIntegerBitSet",
+      forAllShrinkSmall genInflatedWords partitionIntegerBitSet) :
+   ("partitionIntSet",
+      forAllShrinkSmall genInflatedWords partitionIntSet) :
+   ("partitionUArray",
+      forAllShrinkSmall genInflatedWords partitionUArray) :
+   TestKnead.tests ++
+   ("partitionMap",
+      forAll genSolvablePairs partitionMap) :
+   ("partitionQueueSet",
+      forAllShrink genWords partitionQueueSet) :
+   ("partitionQueueMap",
+      forAll genSolvablePairs partitionQueueMap) :
+   ("partitionQueueBit",
+      forAllShrink genWords partitionQueueBit) :
+   ("partitionQueueBitPQ",
+      forAllShrink genWords partitionQueueBitPQ) :
+   ("partitionQueueIntSet",
+      forAllShrink genWords partitionQueueIntSet) :
+   ("partitionTree",
+      forAllShrink genWords partitionTree) :
+   ("treeQueueSet",
+      forAllShrink genWords $ treeQueueGen ESCP.queueSet setAssigns) :
+   ("treeQueueMap",
+      forAll genSolvablePairs $
+      treeQueueGen (ESCP.queueMap ESCP.queueSet) mapAssigns) :
+   ("treeQueueBit",
+      forAllShrink genWords $
+      treeQueueGen ESCP.queueBit (ESC.bitVectorFromSetAssigns . setAssigns)) :
+   ("treeQueueBitPQ",
+      forAllShrink genWords $
+      treeQueueGen ESCP.queueBitPQ (ESC.bitVectorFromSetAssigns . setAssigns)) :
+   ("treeQueueIntSet",
+      forAllShrink genWords $
+      treeQueueGen ESCP.queueIntSet (ESC.intSetFromSetAssigns . setAssigns)) :
+   []
+
+
+quickCheck :: (Int, QC.Property) -> IO ()
+quickCheck (count, prop) =
+   QC.quickCheckWith (QC.stdArgs {QC.maxSuccess = count}) prop
+
+main :: IO ()
+main =
+   mapM_ (\(msg,prop) -> putStr (msg++": ") >> quickCheck prop) $
+
+   tests ++ map (mapFst ("Mastermind."++)) Mastermind.tests
diff --git a/test/Test/Utility.hs b/test/Test/Utility.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Utility.hs
@@ -0,0 +1,47 @@
+module Test.Utility where
+
+import qualified Math.SetCover.Exact as ESC
+
+import Control.Applicative ((<$>))
+
+import qualified Data.Set as Set
+import qualified Data.List as List
+import Data.Set(Set)
+import Data.Eq.HT (equating)
+
+import qualified Test.QuickCheck as QC
+
+
+setAssigns :: (Ord a) => [[a]] -> [ESC.Assign [a] (Set a)]
+setAssigns = map (\x -> ESC.assign x (Set.fromList x))
+
+normalizeSolution :: Ord a => [[a]] -> [[a]]
+normalizeSolution = List.sort . map List.sort
+
+equivalentSolutions :: Ord a => [[a]] -> [[a]] -> Bool
+equivalentSolutions = equating normalizeSolution
+
+
+genWord :: QC.Gen String
+genWord = take 5 <$> QC.listOf (QC.choose ('a','e'))
+
+genWords :: QC.Gen [String]
+genWords = take 10 <$> QC.listOf genWord
+
+type InflatedString = [(Char,Int)]
+
+inflate :: String -> InflatedString
+inflate = concatMap (\c -> map ((,) c) [0..49])
+
+{- |
+Make sure that bitset-based implementations
+are forced to use more than one Word64 or one 128 bit vector.
+-}
+genInflatedWords :: QC.Gen [InflatedString]
+genInflatedWords = fmap inflate <$> genWords
+
+
+forAllShrinkSmall ::
+   (QC.Testable prop, Show a, QC.Arbitrary a) =>
+   QC.Gen a -> (a -> prop) -> (Int, QC.Property)
+forAllShrinkSmall gen = (,) 200 . QC.forAllShrink gen QC.shrink
diff --git a/test/knead/Test/Knead.hs b/test/knead/Test/Knead.hs
new file mode 100644
--- /dev/null
+++ b/test/knead/Test/Knead.hs
@@ -0,0 +1,35 @@
+module Test.Knead where
+
+import Test.Utility
+         (InflatedString, setAssigns, equivalentSolutions,
+          forAllShrinkSmall, genInflatedWords)
+
+import qualified Math.SetCover.Exact.Knead.Saturated as ESC_KneadSat
+import qualified Math.SetCover.Exact.Knead as ESC_Knead
+import qualified Math.SetCover.Exact as ESC
+
+import qualified Test.QuickCheck as QC
+
+
+partitionKnead :: [InflatedString] -> Bool
+partitionKnead xs =
+   let asns = setAssigns xs
+   in ESC.partitions asns
+      ==
+      ESC_Knead.partitions asns
+
+partitionKneadVector :: [InflatedString] -> Bool
+partitionKneadVector xs =
+   let asns = setAssigns xs
+   in  equivalentSolutions
+         (ESC.partitions asns)
+         (ESC_KneadSat.partitions asns)
+
+
+tests :: [(String, (Int, QC.Property))]
+tests =
+   ("partitionKnead",
+      forAllShrinkSmall genInflatedWords partitionKnead) :
+   ("partitionKneadVector",
+      forAllShrinkSmall genInflatedWords partitionKneadVector) :
+   []
diff --git a/test/plain/Test/Knead.hs b/test/plain/Test/Knead.hs
new file mode 100644
--- /dev/null
+++ b/test/plain/Test/Knead.hs
@@ -0,0 +1,4 @@
+module Test.Knead where
+
+tests :: [a]
+tests = []