packages feed

set-cover 0.1.1.1 → 0.1.2

raw patch · 17 files changed

+1074/−85 lines, 17 filesdep +doctest-exitcode-stdiodep +doctest-libdep +enumsetdep ~basedep ~containersdep ~enummapsetnew-component:exe:graph-coloringnew-component:exe:pythagoras-coloring

Dependencies added: doctest-exitcode-stdio, doctest-lib, enumset

Dependency ranges changed: base, containers, enummapset, llvm-dsl, llvm-extra, llvm-tf, non-empty, semigroups, timeit, utility-ht

Files

Makefile view
@@ -1,4 +1,4 @@-run-test:+run-test:	update-test 	runhaskell Setup configure --user -fbuildExamples --enable-tests 	runhaskell Setup build 	runhaskell Setup configure --user -fbuildExamples -fllvm --enable-tests --enable-benchmarks@@ -7,3 +7,9 @@ 	dist/build/set-cover-test/set-cover-test # more portable, but suppresses live QuickCheck test counter: #	runhaskell Setup test --show-details=streaming++update-test:+	doctest-extract-0.1 -i example/ -o test/ \+	  --module-prefix DocTest --library-main=Main --import-tested \+	  GraphColoring.Solve \+	  GraphColoring.CutEnumSet
example/ConwayPuzzle.hs view
@@ -20,7 +20,9 @@ import qualified Data.Foldable as Fold import qualified Data.Map as Map import qualified Data.Set as Set+import qualified Data.NonEmpty as NonEmpty import qualified Data.List as List+import Data.NonEmpty ((!:)) import Data.IntSet (IntSet) import Data.Foldable (foldMap) @@ -131,9 +133,9 @@    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"+         s3asn !: map (\mask -> ESC.assign [mask] mask) squares of+      asns@(NonEmpty.Cons s3 _) ->+         ESC.updateState s3 $ ESC.initState $ NonEmpty.flatten asns   formatIdent :: Int -> Char
+ example/GraphColoring.hs view
@@ -0,0 +1,74 @@+module Main where++import qualified GraphColoring.CutEnumSet as CutEnumSet+import qualified GraphColoring.CutSet as CutSet+import GraphColoring.Solve++import qualified Math.SetCover.Exact as ESC++import qualified Data.Set as Set+import Text.Printf (printf)++import System.TimeIt (timeIt)+++mainCount :: IO ()+mainCount = do+   let example = (['a'..'g'], complete 7)+   printf "plain: %d\n" $+      length $ ESC.search $+      ESC.compressState Set.toList $ initialize assigns example+   printf "cut branch by set: %d\n" $+      length $ CutSet.search $ CutSet.initState $+      ESC.intSetFromSetAssigns $ uncurry assigns example+   printf "cut branch by enumset: %d\n" $+      length $ CutEnumSet.search $ CutEnumSet.initState $+      ESC.intSetFromSetAssigns $ uncurry assignsEdgeColor example++   printf "cut branch by enumset big: %d\n" $+      length $ CutEnumSet.search $ CutEnumSet.initState $+      ESC.intSetFromSetAssigns $+         uncurry assignsEdgeColor (['a'..'z'], complete 30)++mainSolution :: IO ()+mainSolution =+   CutEnumSet.run $ ESC.intSetFromSetAssigns $+   uncurry assignsEdgeColor example5+++{-+The algorithm that cuts away branches+was intended to be more efficient,+but actually needs much more time:++plain:+coloring impossible+CPU time:   8.95s++cut branch:+coloring impossible+CPU time:  61.92s+++Reason:+The improved algorithm actually did not cut away cases,+it only fixes the first color,+and thus is factor n slower than the algorithm that fixes the first two colors.+-}+mainImpossible :: IO ()+mainImpossible = do+   let example = (['a'..'h'], complete 10)+   putStrLn "\nplain:"+   timeIt $ run $ ESC.compressState Set.toList $ initialize assigns example+   putStrLn "\nreserve edge:"+   timeIt $ run $ ESC.compressState Set.toList $+      initialize assignsReserveEdge example+   putStrLn "\ncut branch by set:"+   timeIt $ CutSet.run $ ESC.intSetFromSetAssigns $ uncurry assigns example+   putStrLn "\ncut branch by enumset:"+   timeIt $ CutEnumSet.run $ ESC.intSetFromSetAssigns $+      uncurry assignsEdgeColor example+++main :: IO ()+main = mainSolution
+ example/GraphColoring/CutEnumSet.hs view
@@ -0,0 +1,182 @@+module GraphColoring.CutEnumSet where++import qualified Math.SetCover.Exact as ESC++import qualified Data.EnumBitSet as EnumBitSet+import qualified Data.EnumSet as EnumSet+import qualified Data.List as List+import Data.Monoid (First(First, getFirst))+import Data.EnumSet (EnumSet)+import Data.Ord.HT (comparing)+import Data.Either.HT (maybeRight)+import Data.Maybe.HT (toMaybe)+import Data.Maybe (mapMaybe)+import Data.Word (Word8)+import Text.Printf (printf)++{- $setup+>>> import qualified Math.SetCover.Exact as ESC+>>>+>>> import qualified Data.EnumSet as EnumSet+>>> import qualified Data.List.Key as Key+>>> import Data.Word (Word32)+>>>+>>> import Control.Applicative (liftA2)+>>>+>>> import qualified Test.QuickCheck as QC+>>> import Test.QuickCheck ((===))+-}+++type Label node color = Either (color, color) (node, color)+type Assign node color set = ESC.Assign (Label node color) set++{- |+Re-implementation of SetCover.Exact functions with an extended state,+that also maintains the already used colors in an efficient 'EnumSet'.+-}+data State node color set =+   State {+      stateSetCover :: ESC.State (Label node color) set,+      stateUsedColors :: EnumSet color+   }++initState :: (Enum color, ESC.Set set) =>+   [Assign node color set] -> State node color set+initState asns =+   State {+      stateSetCover = ESC.initState asns,+      stateUsedColors = EnumSet.empty+   }++{-# INLINE updateState #-}+updateState :: (Enum color, ESC.Set set) =>+   Assign node color set ->+   State node color set -> State node color set+updateState asn s =+   State {+      stateSetCover = ESC.updateState asn $ stateSetCover s,+      stateUsedColors =+         stateUsedColors s <>+         case ESC.label asn of+            Right (_,color) -> EnumSet.singleton color+            Left (color0,color1) ->+               EnumSet.singleton color0 <> EnumSet.singleton color1+   }++{- |+Without loss of generality, when new colors are choosen,+only try the lexicographically lowest single color or color pair.+-}+uniqueNewColors :: (Enum color) =>+   EnumSet color -> [Assign node color set] -> [Assign node color set]+uniqueNewColors alreadyUsedColors =+   (\(ordinaryAttempts,+         tryNewColors0, tryNewColors1, tryNewColors2, tryNewColors3) ->+      ordinaryAttempts +++      mapMaybe getFirst+         [tryNewColors0, tryNewColors1, tryNewColors2, tryNewColors3])+   .+   foldMap+      (\asn ->+         let single = First . Just in+         case ESC.label asn of+            Left (color0,color1) ->+               case (EnumSet.member color0 alreadyUsedColors,+                     EnumSet.member color1 alreadyUsedColors) of+                  (True, True) -> ([asn], mempty, mempty, mempty, mempty)+                  (False, False) ->+                     (mempty, mempty, single asn, mempty, mempty)+                  (False, True) ->+                     (mempty, mempty, mempty, single asn, mempty)+                  (True, False) ->+                     (mempty, mempty, mempty, mempty, single asn)+            Right (_node,color) ->+               if EnumSet.member color alreadyUsedColors+                  then ([asn], mempty, mempty, mempty, mempty)+                  else (mempty, single asn, mempty, mempty, mempty))++++data UsagePattern = NewNode | NewEdge0 | NewEdge1 | NewEdge01+   deriving (Eq, Ord, Enum, Show)++{- |+This is the same as uniqueNewColors+but performs a single scan through the list+and bookkeeps already seen patterns of new colors.+Order of assignments is maintained.+++prop> :{+   QC.forAll (fmap (\n -> take (1 + mod n 5) ['a'..]) QC.arbitrary) $ \set ->+   QC.forAll (QC.sublistOf set) $ \used ->+   let usedSet = EnumSet.fromList used in+   let genLabel =+         QC.oneof+            [fmap Left $ liftA2 (,) (QC.elements set) (QC.elements set),+             fmap Right $+               liftA2 (,) (QC.arbitrary :: QC.Gen Integer) (QC.elements set)]+       genAssignSet :: QC.Gen Word32+       genAssignSet = QC.arbitrary+   in+   QC.forAll (QC.listOf (liftA2 ESC.assign genLabel genAssignSet)) $ \assigns ->+   let normalize =+         Key.sort fst . map (\(ESC.Assign label aset) -> (label,aset)) in++   normalize (uniqueNewColors usedSet assigns)+   ===+   normalize (uniqueNewColorsStable usedSet assigns)+:}+-}+uniqueNewColorsStable :: (Enum color) =>+   EnumSet color -> [Assign node color set] -> [Assign node color set]+uniqueNewColorsStable alreadyUsedColors asns =+   map fst $ filter snd $ zip asns $+   snd $+   List.mapAccumL+      (\seen mpat ->+         case mpat of+            Nothing -> (seen, True)+            Just pat ->+               (EnumBitSet.set pat seen, not (EnumBitSet.get pat seen)))+      (EnumBitSet.empty :: EnumBitSet.T Word8 UsagePattern)+   $+   flip map asns+      (\asn ->+         case ESC.label asn of+            Left (color0,color1) ->+               case (EnumSet.member color0 alreadyUsedColors,+                     EnumSet.member color1 alreadyUsedColors) of+                  (True, True) -> Nothing+                  (False, False) -> Just NewEdge01+                  (False, True) -> Just NewEdge0+                  (True, False) -> Just NewEdge1+            Right (_node,color) ->+               toMaybe (EnumSet.notMember color alreadyUsedColors) NewNode)++{-# INLINE step #-}+step :: (Enum color, ESC.Set set) =>+   State node color set -> [State node color set]+step s =+   map (flip updateState s) $+   uniqueNewColorsStable (stateUsedColors s) $+   let se = stateSetCover s in+   ESC.minimize (ESC.freeElements se) (ESC.availableSubsets se)++{-# INLINE search #-}+search :: (Enum color, ESC.Set set) =>+   State node color set -> [[Label node color]]+search s =+   let se = stateSetCover s in+   if ESC.null (ESC.freeElements se)+     then [ESC.usedSubsets se]+     else step s >>= search++run :: (ESC.Set set) => [Assign Int Char set] -> IO ()+run asns =+   case search $ initState asns of+      [] -> putStrLn "coloring impossible"+      solution:_ ->+         mapM_ (\(node,color) -> printf "Node %d: %c\n" node color) $+         List.sortBy (comparing fst) $ mapMaybe maybeRight solution
+ example/GraphColoring/CutSet.hs view
@@ -0,0 +1,104 @@+module GraphColoring.CutSet where++import qualified Math.SetCover.Exact as ESC++import qualified Data.Set as Set+import qualified Data.List as List+import Data.Set (Set)+import Data.Ord.HT (comparing)+import Data.Maybe (catMaybes)+import Text.Printf (printf)+++type Label node color = Maybe (node, color)++{- |+Re-implementation of SetCover.Exact functions with an extended state,+that also maintains the already used colors in an efficient 'Set'.+-}+data State node color set =+   State {+      stateSetCover :: ESC.State (Label node color) set,+      stateUsedColors :: Set color+   }++initState :: (Ord color, ESC.Set set) =>+   [ESC.Assign (Label node color) set] -> State node color set+initState asns =+   State {+      stateSetCover = ESC.initState asns,+      stateUsedColors = Set.empty+   }++{-# INLINE updateState #-}+updateState :: (Ord color, ESC.Set set) =>+   ESC.Assign (Label node color) set ->+   State node color set -> State node color set+updateState asn s =+   State {+      stateSetCover = ESC.updateState asn $ stateSetCover s,+      stateUsedColors =+         stateUsedColors s <> foldMap (Set.singleton . snd) (ESC.label asn)+   }++{- |+Without loss of generality, when new colors are choosen,+only try the lowest free color.+This is a bit simplistic, because it only respects colors introduced by nodes,+but not colors or color pairs introduced by edges.+Effectively this only chooses a unique first color+and then all other colors are still fully permuted,+because they are all introduced by edges.+See 'CutEnumSet' for a better solution.+-}+{-# INLINE step #-}+step :: (Ord color, ESC.Set set) =>+   State node color set -> [State node color set]+step s =+   map (flip updateState s) $+   (\(ordinaryAttempts, tryNewColors) ->+      ordinaryAttempts ++ take 1 tryNewColors) $+   List.partition+      (\asn ->+         case ESC.label asn of+            Nothing -> True+            Just (_node,color) -> Set.member color $ stateUsedColors s) $+   let se = stateSetCover s in+   ESC.minimize (ESC.freeElements se) (ESC.availableSubsets se)++{-+This is faster, but excludes possible solutions.+In other words, it is fundamentally broken.+-}+{-# INLINE stepPreFilter #-}+stepPreFilter :: (Ord color, ESC.Set set) =>+   State node color set -> [State node color set]+stepPreFilter s =+   map (flip updateState s) $+   let se = stateSetCover s in+   ESC.minimize (ESC.freeElements se) $+   (\(ordinaryAttempts, tryNewColors) ->+      ordinaryAttempts ++ take 1 tryNewColors) $+   List.partition+      (\asn ->+         case ESC.label asn of+            Nothing -> True+            Just (_node,color) -> Set.member color $ stateUsedColors s)+      (ESC.availableSubsets se)++{-# INLINE search #-}+search :: (Ord color, ESC.Set set) =>+   State node color set -> [[Label node color]]+search s =+   let se = stateSetCover s in+   if ESC.null (ESC.freeElements se)+     then [ESC.usedSubsets se]+     else step s >>= search++run :: (ESC.Set set) => [ESC.Assign (Label Int Char) set] -> IO ()+run asns =+   case search $ initState asns of+      [] -> putStrLn "coloring impossible"+      solution:_ ->+         mapM_ (\(node,color) -> printf "Node %d: %c\n" node color) $+         List.sortBy (comparing fst) $ catMaybes solution
+ example/GraphColoring/Solve.hs view
@@ -0,0 +1,276 @@+module GraphColoring.Solve where++import qualified Math.SetCover.Exact as ESC++import Control.Monad (guard)+import Control.Applicative (liftA2)++import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.List as List+import Data.Set (Set)+import Data.Ord.HT (comparing)+import Data.Maybe (catMaybes)+import Text.Printf (printf)++{- $setup+>>> import qualified GraphColoring.CutEnumSet as CutEnumSet+>>> import qualified Math.SetCover.Exact as ESC+>>>+>>> import qualified Data.Set as Set+>>> import qualified Data.List.Key as Key+>>> import Data.Either.HT (maybeRight)+>>> import Data.Maybe (catMaybes, mapMaybe)+>>>+>>> import qualified Test.QuickCheck as QC+>>> import Test.QuickCheck ((===))+>>>+>>> solve :: ([Char], [Edge Int]) -> [[(Int, Char)]]+>>> solve =+>>>    map (Key.sort fst . catMaybes) . ESC.search .+>>>    ESC.compressState Set.toList . initialize assigns+-}+++type Edge node = (node,node)++data X node color =+      Node node | Edge node node | ColorEdge node node color |+      EdgeColor node node color+         deriving (Eq, Ord, Show)++type Label node color = Maybe (node, color)+type ExtLabel node color = Either (color,color) (node, color)+type Assign node color = ESC.Assign (Label node color) (Set (X node color))+++{- |+For every node, block all but one color at outgoing edges.++Specify every edge only once, freely choose a direction.+Strange things might happend if you specify an edge in both directions.+-}+assignNodeColors ::+   (Ord color, Ord node) =>+   ((node, color) -> lab) ->+   [color] -> [Edge node] -> [ESC.Assign lab (Set (X node color))]+assignNodeColors lab colors edges =+   liftA2+      (\color (node,connected) ->+         ESC.assign (lab (node,color))+            (Set.fromList $+               Node node :+               liftA2 (ColorEdge node)+                  (Set.toList connected)+                  (List.delete color colors)))+      colors+      (Map.toList $ Map.fromListWith Set.union $+       edges >>=+         \(from,to) -> [(from, Set.singleton to), (to, Set.singleton from)])++{- FixMe:+Solver always succeeds when only one color is allowed.+When there is only one color, we do not generate edges, at all,+because we only generate edges with different colors at either ends.+-}+assigns ::+   (Ord color, Ord node) => [color] -> [Edge node] -> [Assign node color]+assigns colors edges =+   assignNodeColors Just colors edges+   +++   (do+      (from,to) <- edges+      fromColor <- colors+      toColor <- colors+      guard $ fromColor /= toColor+      return $ ESC.assign Nothing $+         Set.fromList [ColorEdge from to fromColor, ColorEdge to from toColor])++{- |+Register every used edge.+This is redundant but may speedup search.+Actually, it slows down the search.+-}+assignsReserveEdge ::+   (Ord color, Ord node) => [color] -> [Edge node] -> [Assign node color]+assignsReserveEdge colors edges =+   assignNodeColors Just colors edges+   +++   (do+      (from,to) <- edges+      fromColor <- colors+      toColor <- colors+      guard $ fromColor /= toColor+      return $ ESC.assign Nothing $+         Set.fromList+            [ColorEdge from to fromColor,+             ColorEdge to from toColor,+             Edge from to])++{- |+For every edge, 'assigns' needs a number of sets+proportional to the square of the number of colors.+'assignsSplitEdge' reduces this to a linear number.+Unfortunately solution becomes slower.+-}+assignsSplitEdge ::+   (Ord color, Ord node) => [color] -> [Edge node] -> [Assign node color]+assignsSplitEdge colors edges =+   assignNodeColors Just colors edges+   +++   (do+      (from,to) <- edges+      color <- colors+      [ESC.assign Nothing $ Set.fromList [EdgeColor from to color],+       ESC.assign Nothing $+         Set.fromList+            [ColorEdge from to color, EdgeColor from to color, Edge from to],+       ESC.assign Nothing $+         Set.fromList+            [ColorEdge to from color, EdgeColor from to color, Edge to from]+         ])+++{- |+Same rules as 'assign' but also gives labels for edge colors.+-}+assignsEdgeColor ::+   (Ord color, Ord node) =>+   [color] -> [Edge node] ->+   [ESC.Assign (ExtLabel node color) (Set (X node color))]+assignsEdgeColor colors edges =+   assignNodeColors Right colors edges+   +++   (do+      (from,to) <- edges+      fromColor <- colors+      toColor <- colors+      guard $ fromColor /= toColor+      return $ ESC.assign (Left (fromColor, toColor)) $+         Set.fromList [ColorEdge from to fromColor, ColorEdge to from toColor])++++{- |+>>> solve example0+[[(0,'a'),(1,'b'),(2,'a'),(3,'b'),(4,'a'),(5,'b')]]+-}+example0 :: ([Char], [Edge Int])+example0 = (['a'..'b'], [(0,1),(1,2),(2,3),(3,4),(4,5)])++{- |+>>> minimum $ solve example1+[(0,'a'),(1,'b'),(2,'a'),(3,'b'),(4,'c')]+-}+example1 :: ([Char], [Edge Int])+example1 = (['a'..'c'], [(0,1),(1,2),(2,3),(3,4),(4,0)])++{- |+>>> solve example2+[[(0,'a'),(1,'b'),(2,'c')]]+-}+example2 :: ([Char], [Edge Int])+example2 = (['a'..'c'], [(0,1),(1,2),(0,2)])++{- |+>>> solve example3+[[(0,'a'),(1,'b'),(2,'c'),(3,'b')]]+-}+example3 :: ([Char], [Edge Int])+example3 = (['a'..'c'], [(0,1),(1,2),(2,3),(3,0),(0,2)])++{- |+>>> solve example4+[]+-}+example4 :: ([Char], [Edge Int])+example4 = (['a'..'c'], [(0,1),(1,2),(2,3),(3,0),(0,2),(1,3)])++-- FixMe: fix cases n<2 or k<2+{- |+>>> length $ ESC.search $ ESC.compressState Set.toList $ ESC.initState $ assigns ['a'..'e'] (complete 5)+120++prop> :{+   QC.forAll (QC.choose (2,5)) $ \n ->+   QC.forAll (QC.choose (2,7)) $ \k ->++   (length $ ESC.search $ ESC.compressState Set.toList $+      ESC.initState $ assigns (take k ['a'..]) (complete n))+   ===+   product (take n [k,(k-1)..])+:}++prop> :{+   QC.forAll (QC.choose (2,5)) $ \n ->+   QC.forAll (QC.choose (2,7)) $ \k ->++   (length $ CutEnumSet.search $ CutEnumSet.initState $+      ESC.intSetFromSetAssigns $ assignsEdgeColor (take k ['a'..]) (complete n))+   ===+   if n<=k then 1 else 0+:}+-}+complete :: Int -> [Edge Int]+complete n = do from <- [1..n]; to <- [from+1 .. n]; [(from,to)]++{- |+>>> :{+   map (Key.sort fst . mapMaybe maybeRight) $+   CutEnumSet.search $ CutEnumSet.initState $+   ESC.intSetFromSetAssigns $ uncurry assignsEdgeColor example5+:}+[[(1,'a'),(2,'b'),(3,'c'),(4,'d'),(5,'e'),(6,'f'),(7,'g'),(8,'h'),(9,'i'),(10,'j')]]+-}+example5 :: ([Char], [Edge Int])+example5 = (['a'..'j'], complete 10)++++{- |+Choose first two colors for the first two connected nodes,+without loss of generality.+This accelerates proof of impossibility.+However, for the following colors still plain color permutations are tried.+We could exclude them by modifying the search algorithm+such that at most one unused color is tried in every search step.+-}+initialize ::+   (Eq node, Eq color, ESC.Set set) =>+   ([color] -> [Edge node] -> [ESC.Assign (Label node color) set]) ->+   ([color], [Edge node]) -> ESC.State (Label node color) set+initialize assigner (colors,edges) =+   let asns = assigner colors edges in+   case (colors,edges) of+      (c0:c1:_, (from,to):_) ->+         foldl (flip ESC.updateState) (ESC.initState asns) $+         filter+            (\asn ->+               ESC.label asn == Just (from,c0) ||+               ESC.label asn == Just (to,c1))+            asns+      _ -> ESC.initState asns++{- |+The algorithm needs a fixed number of colors to choose from.+In some applications the number of colors is not given, but shall be minimal.+In this case you might start with as many colors as nodes,+and scan the results for solutions with less used colors.+You can then restart the algorithm with a smaller reservoir of colors.+You may also perform a bisection on the number of colors+or run solvers for multiple color sets in parallel.+I guess, for large color sets you will get a positive result quickly+and for small color sets you will get a negative answer quickly.++Finding a solution usually happens fast.+Proof of impossibility requires much more time.+For a real application you might consider setting a timeout+or trying to solve with different sets of colors in parallel.+-}+run :: (ESC.Set set) => ESC.State (Maybe (Int, Char)) set -> IO ()+run state =+   case ESC.search state of+      [] -> putStrLn "coloring impossible"+      solution:_ ->+         mapM_ (\(node,color) -> printf "Node %d: %c\n" node color) $+         List.sortBy (comparing fst) $ catMaybes solution
+ example/PythagorasColoring.hs view
@@ -0,0 +1,108 @@+{- |+Assign one of two colors to every natural number+such that there is no uniformly colored Pythagorean triple.++<https://en.wikipedia.org/wiki/Boolean_Pythagorean_triples_problem>+<https://dorfuchs93.github.io/boolean-pythagorean-triples/>+-}+module Main where++import qualified Math.SetCover.Exact as ESC++import qualified Data.Traversable as Trav+import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet+import qualified Data.Set as Set+import Data.IntMap (IntMap)+import Data.IntSet (IntSet)+import Data.Set (Set)+import Data.Maybe (catMaybes)++import Control.Monad (guard)+import Control.Applicative (liftA2)+++data Color = Red | Blue+   deriving (Eq, Ord, Show)++data X =+        Number Int+      | PythagoreanTriple IntSet | PythagoreanColor IntSet Int Color+   deriving (Eq, Ord, Show)++type Assign = ESC.Assign (Maybe (Int, Color)) (Set X)+++colorNumber :: [IntSet] -> Int -> Color -> Assign+colorNumber tuples n c =+   ESC.assign (Just (n,c)) $ Set.fromList $+   Number n+   :+   map (\tuple -> PythagoreanColor tuple n c)+      (filter (IntSet.member n) tuples)++constIntMap :: a -> IntSet -> IntMap a+constIntMap x = IntMap.fromSet (const x)++admissibleTupleColorings :: IntSet -> [IntMap Color]+admissibleTupleColorings xs =+   filter+      (\tuple ->+         tuple /= constIntMap Red xs+         &&+         tuple /= constIntMap Blue xs) $+   Trav.sequence $ constIntMap [Red,Blue] xs+++assigns :: [IntSet] -> [Assign]+assigns tuples =+   let omega = IntSet.unions tuples in+   liftA2 (colorNumber tuples) (IntSet.toList omega) [Red, Blue]+   +++   (do+      tuple <- tuples+      tupleColoring <- admissibleTupleColorings tuple+      [ESC.assign Nothing $ Set.fromList $+         PythagoreanTriple tuple :+         IntMap.elems+            (IntMap.mapWithKey (PythagoreanColor tuple) tupleColoring)])+++intMapFromLabels :: [Maybe (Int, Color)] -> IntMap Color+intMapFromLabels = IntMap.fromList . catMaybes++pythagoreanTriples :: [IntSet]+pythagoreanTriples =+   IntSet.fromList [3,4,5] :+   IntSet.fromList [5,12,13] :+   IntSet.fromList [9,12,15] :+   IntSet.fromList [12,16,20] :+   []+++sqr :: Num a => a -> a+sqr a = a*a++{-+Alternatively we could use Euclidean's formula.+-}+pythagoreanTriplesUpTo :: Int -> [IntSet]+pythagoreanTriplesUpTo n = do+   a <- [1..n]+   b <- [a+1..n]+   let a2b2 = sqr a + sqr b+   let c = round $ sqrt (fromIntegral a2b2 :: Double)+   guard $ c<=n && a2b2 == sqr c+   return $ IntSet.fromList [a,b,c]+++mainAll :: IO ()+mainAll =+   mapM_ (print . intMapFromLabels) $+   ESC.partitions $ assigns pythagoreanTriples++main :: IO ()+main =+   mapM_ (print . intMapFromLabels) $ take 1 $+   ESC.partitions $ ESC.intSetFromSetAssigns $+   assigns $ pythagoreanTriplesUpTo 1500
set-cover.cabal view
@@ -1,6 +1,6 @@ Cabal-Version:    2.2 Name:             set-cover-Version:          0.1.1.1+Version:          0.1.2 License:          BSD-3-Clause License-File:     LICENSE Author:           Henning Thielemann, Helmut Podhaisky@@ -11,7 +11,8 @@ Description:   Solver for exact set cover problems.   Included examples:-  Sudoku, Nonogram, 8 Queens, Domino tiling, Mastermind, Alphametics,+  Sudoku, Nonogram, 8 Queens, Domino tiling, Mastermind,+  Alphametics, Graph coloring,   Soma Cube, Tetris Cube, Cube of L's,   Logika's Baumeister puzzle, Lonpos pyramid, Conway's puzzle.   The generic algorithm allows to choose between@@ -32,9 +33,11 @@ Tested-With:      GHC==7.4.2, GHC==7.6.3, GHC==7.8.2 Build-Type:       Simple Extra-Source-Files:-  Changes.md   Makefile +Extra-Doc-Files:+  Changes.md+ Flag buildExamples   Description: Build example executables   Default:     False@@ -45,7 +48,7 @@   Default:     False  Source-Repository this-  Tag:         0.1.1.1+  Tag:         0.1.2   Type:        darcs   Location:    https://hub.darcs.net/thielema/set-cover/ @@ -59,9 +62,9 @@     enummapset >=0.1 && <0.8,     transformers >=0.2 && <0.7,     array >=0.4 && <0.6,-    containers >=0.4 && <0.8,+    containers >=0.4 && <0.9,     non-empty >=0.2 && <0.4,-    semigroups >=0.1 && <1.0,+    semigroups >=0.1 && <1,     utility-ht >=0.0.12 && <0.1,     prelude-compat ==0.*,     base >=4 && <5@@ -91,9 +94,9 @@   If flag(llvm)     Build-Depends:       knead >=1.0 && <1.1,-      llvm-dsl >=0.1 && <0.2,-      llvm-extra >=0.11 && <0.12,-      llvm-tf >=9.2 && <17.1,+      llvm-dsl >=0.2 && <0.3,+      llvm-extra >=0.12.1 && <0.14,+      llvm-tf >=9.2 && <21.1,       tfp >=1.0 && <1.1,       comfort-array >=0.3 && <0.6,       storable-record >=0.0.5 && <0.1,@@ -113,9 +116,12 @@     set-cover,     transformers >=0.2 && <0.7,     enummapset,+    enumset,     containers,     array >=0.1 && <0.6,     utility-ht,+    doctest-exitcode-stdio >=0.0 && <0.1,+    doctest-lib >=0.1.1 && <0.2,     QuickCheck >=2.5 && <3.0,     base   Main-Is: Test.hs@@ -130,6 +136,9 @@     Mastermind.Test     Mastermind.Guess     Mastermind.Utility+    DocTest.GraphColoring.CutEnumSet, GraphColoring.CutEnumSet+    DocTest.GraphColoring.Solve, GraphColoring.Solve+    DocTest.Main     Test.Knead     Test.Utility @@ -182,7 +191,7 @@   If flag(buildExamples)     Build-Depends:       haha >=0.3.1 && <0.4,-      random >=1.0 && <1.3,+      random >=1.0 && <1.4,       transformers >=0.2 && <0.7,       array >=0.1 && <0.6,       containers@@ -276,7 +285,7 @@   Import: example   If flag(buildExamples)     Build-Depends:-      random >=1.0 && <1.3,+      random >=1.0 && <1.4,       transformers >=0.2 && <0.7,       array >=0.1 && <0.6,       enummapset,@@ -297,7 +306,7 @@     GHC-Prof-Options: -rtsopts -auto-all     Build-Depends:       haha >=0.3.1 && <0.4,-      random >=1.0 && <1.3,+      random >=1.0 && <1.4,       lazyio,       transformers >=0.2 && <0.7,       array >=0.1 && <0.6,@@ -320,7 +329,7 @@   Build-Depends:     timeit,     QuickCheck >=2.5 && <3.0,-    random >=1.0 && <1.3,+    random >=1.0 && <1.4,     transformers >=0.2 && <0.7,     array >=0.1 && <0.6,     enummapset,@@ -346,6 +355,7 @@     Build-Depends:       pooled-io >=0.0 && <0.1,       transformers,+      non-empty,       containers   Else     Buildable: False@@ -353,3 +363,28 @@   Main-Is: ConwayPuzzle.hs   Other-Modules:     Utility++Executable graph-coloring+  Import: example+  If flag(buildExamples)+    Build-Depends:+      timeit >=0.9 && <3,+      enumset >=0.1 && <0.2,+      enummapset,+      containers+  Else+    Buildable: False+  Main-Is: GraphColoring.hs+  Other-Modules:+    GraphColoring.Solve+    GraphColoring.CutSet+    GraphColoring.CutEnumSet++Executable pythagoras-coloring+  Import: example+  If flag(buildExamples)+    Build-Depends:+      containers+  Else+    Buildable: False+  Main-Is: PythagorasColoring.hs
src/Math/SetCover/Exact.hs view
@@ -6,7 +6,7 @@    Assign(..), assign,    bitVectorFromSetAssigns, intSetFromSetAssigns,    partitions, search, step,-   State(..), initState, updateState,+   State(..), initState, updateState, compressState,    Set(..),    Tree(..), decisionTree, completeTree,    Choose(..),@@ -25,6 +25,7 @@ import qualified Data.List.Match as Match import qualified Data.List as List import qualified Data.Foldable as Fold+import Data.Traversable (Traversable) import Data.Function.HT (compose2) import Data.Maybe.HT (toMaybe) import Data.Tuple.HT (mapFst, mapSnd)@@ -174,6 +175,7 @@       label :: label,       labeledSet :: set    }+   deriving (Show)  {- | Construction of a labeled set.@@ -190,11 +192,11 @@ The output of 'bitVectorFromSetAssigns' should go into the solver as is. -} bitVectorFromSetAssigns ::-   (Ord a) =>-   [Assign label (Set.Set a)] -> [Assign label (BitSet.Set Integer)]+   (Traversable f, Ord a) =>+   f (Assign label (Set.Set a)) -> f (Assign label (BitSet.Set Integer)) bitVectorFromSetAssigns asns =    let bitVec = Fold.foldl' setBit 0 . mapIntFromSet asns-   in  map (fmap (BitSet.Set . bitVec)) asns+   in  fmap (fmap (BitSet.Set . bitVec)) asns  {- | Like 'bitVectorFromSetAssigns' but generates 'IntSet.IntSet'@@ -203,16 +205,19 @@ 'IntSet.IntSet' should usually be more efficient than 'Integer'. -} intSetFromSetAssigns ::-   (Ord a) => [Assign label (Set.Set a)] -> [Assign label IntSet.IntSet]+   (Traversable f, Ord a) =>+   f (Assign label (Set.Set a)) -> f (Assign label IntSet.IntSet) intSetFromSetAssigns asns =    let intSet = IntSet.fromList . Map.elems . mapIntFromSet asns-   in  map (fmap intSet) asns+   in  fmap (fmap intSet) asns  mapIntFromSet ::-   (Ord a) => [Assign label (Set.Set a)] -> Set.Set a -> Map.Map a Int+   (Foldable f, Ord a) =>+   f (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..]+         Map.fromList $+         zip (Set.toList $ unions $ map labeledSet $ Fold.toList asns) [0..]    in  Map.intersection mapToInt . constMap ()  {- |@@ -261,6 +266,33 @@          availableSubsets s,       freeElements = difference (freeElements s) attemptedSet,       usedSubsets = attemptLabel : usedSubsets s+   }+++{- |+This is an optional low-level optimization.+It turns 'freeElements' into a contiguous 'IntSet' starting at 0.+In sparse sets this might reduce memory consumption+and number of logical operations.++The functional parameter enables you to choose the type of the source set.+If it is already an 'IntSet',+you would call @compressState IntSet.toList state@.+-}+compressState :: (Ord a) =>+   (set -> [a]) -> State label set -> State label IntSet.IntSet+compressState listFromSet state =+   let mapToInt =+         Map.fromList $ flip zip [0..] $ listFromSet $ freeElements state in+   State {+      availableSubsets =+         -- ToDo: could also be done with Map.intersection+         map (\(Assign lab set) ->+            Assign lab $+               IntSet.fromList $ map (mapToInt Map.!) $ listFromSet set) $+         availableSubsets state,+      freeElements = IntSet.fromList $ Map.elems mapToInt,+      usedSubsets = usedSubsets state    }
src/Math/SetCover/Exact/Knead.hs view
@@ -33,8 +33,8 @@ import qualified Data.Array.Knead.Symbolic as Symb import qualified Data.Array.Knead.Symbolic.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 LLVM.DSL.Expression as Expr+import LLVM.DSL.Expression ((.|.*))  import qualified Data.Array.Comfort.Shape as ComfortShape import qualified Data.Array.Comfort.Boxed as Array
src/Math/SetCover/Exact/Knead/Saturated.hs view
@@ -30,10 +30,10 @@ import qualified Data.Array.Comfort.Boxed as Array import Data.Array.Comfort.Boxed (Array) -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.Value (atom)+import qualified LLVM.Extra.Nice.Vector as NiceVector+import qualified LLVM.Extra.Nice.Value.Vector as NiceValueVec+import qualified LLVM.Extra.Nice.Value as NiceValue+import LLVM.Extra.Nice.Value (atom)  import qualified LLVM.Util.Intrinsic as Intr import qualified LLVM.Core as LLVM@@ -131,9 +131,9 @@    LLVM.Value Counters -> LLVM.Value Counters ->    LLVM.CodeGenFunction r (LLVM.Value Counters) incSatGeneric x y =-   (\(MultiValue.Cons z) -> z)+   (\(NiceValue.Cons z) -> z)    <$>-   Expr.unliftM2 incSat (MultiValue.Cons x) (MultiValue.Cons y)+   Expr.unliftM2 incSat (NiceValue.Cons x) (NiceValue.Cons y)  incSatX86 :: Exp Counters -> Exp Counters -> Exp Counters incSatX86 =@@ -199,16 +199,16 @@          (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+nvvec :: NiceValue.T (LLVM.Vector n a) -> NiceVector.T n a+nvvec (NiceValue.Cons x) = NiceVector.Cons x  extract ::-   (TypeNum.Positive n, MultiVector.C a) =>+   (TypeNum.Positive n, NiceVector.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)+      (\(NiceValue.Cons k) v ->+         flip NiceVector.extract (nvvec v) =<< LLVM.zext k)  extractBlock :: Exp CounterId -> Exp Block -> Exp Subblock extractBlock =@@ -230,12 +230,12 @@   argMin ::-   (MultiValue.Select x, MultiValue.Select y, MultiValue.Comparison y) =>+   (NiceValue.Select x, NiceValue.Select y, NiceValue.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) =>+   (Shape.C sh, Shape.Index sh ~ ix, NiceValue.Select ix) =>    Symb.Array sh Counter -> Exp ix argMinimum = Expr.fst . Symb.fold1All argMin . Symb.mapWithIndex Expr.zip @@ -248,7 +248,7 @@   argMinMasked ::-   (MultiValue.Select x, MultiValue.Select y, MultiValue.Comparison y) =>+   (NiceValue.Select x, NiceValue.Select y, NiceValue.Comparison y) =>    Exp (Bool, (x,y)) -> Exp (Bool, (x,y)) -> Exp (Bool, (x,y)) argMinMasked xy0 xy1 =    Expr.select (Expr.fst xy1)@@ -289,7 +289,7 @@  argMinVec ::    (TypeNum.Positive n,-    MultiVector.Select x, MultiVector.Select y, MultiVector.Comparison y) =>+    NiceVector.Select x, NiceVector.Select y, NiceVector.Comparison y) =>    Exp (LLVM.Vector n (x,y)) -> Exp (LLVM.Vector n (x,y)) ->    Exp (LLVM.Vector n (x,y)) argMinVec xy0 xy1 =@@ -298,7 +298,7 @@  argMinMaskedVec ::    (TypeNum.Positive n,-    MultiVector.Select x, MultiVector.Select y, MultiVector.Comparison y) =>+    NiceVector.Select x, NiceVector.Select y, NiceVector.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 =@@ -340,29 +340,29 @@    Exp ((BlockId, CounterId), BitId) _keepMinimumMaskedVector =    Expr.liftM-      (fmap (MultiValue.fst . MultiValue.snd) .+      (fmap (NiceValue.fst . NiceValue.snd) .        foldM (Expr.unliftM2 argMinMasked)-         (MultiValue.zip (MultiValue.cons False) MultiValue.undef)-       <=< MultiValueVec.dissect)+         (NiceValue.zip (NiceValue.cons False) NiceValue.undef)+       <=< NiceValueVec.dissect)    .    ExprVec.mapSnd       (ExprVec.mapFst (ExprVec.mapFst (flip ExprVec.zip counterIds)))  type    IxVector n =-      MultiValue.T (LLVM.Vector n+      NiceValue.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))))+    NiceVector.Select x, NiceVector.Select y, NiceVector.Comparison y) =>+   NiceValue.T (LLVM.Vector n2 (Bool, (x, y))) ->+   LLVM.CodeGenFunction r (NiceValue.T (LLVM.Vector n (Bool, (x, y)))) argMinMaskedVecHalf x =    Monad.liftJoin2       (Expr.unliftM2 argMinMaskedVec)-      (MultiValueVec.take x)-      (MultiValueVec.takeRev x)+      (NiceValueVec.take x)+      (NiceValueVec.takeRev x)  keepMinimumMaskedCascade ::    Exp (LLVM.Vector NumCounters (Bool, ((BlockId, BitId), Counter))) ->@@ -376,8 +376,8 @@          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))+            (NiceValueVec.extract (LLVM.valueOf 0) (x2 :: IxVector TypeNum.D2))+            (NiceValueVec.extract (LLVM.valueOf 1) x2))    .    ExprVec.mapSnd       (ExprVec.mapFst (ExprVec.mapFst (flip ExprVec.zip counterIds)))
src/Math/SetCover/Exact/Knead/Symbolic.hs view
@@ -33,9 +33,9 @@ import qualified Data.Array.Comfort.Boxed as Array import Data.Array.Comfort.Boxed (Array) -import qualified LLVM.Extra.Multi.Value.Storable as Storable-import qualified LLVM.Extra.Multi.Value as MultiValue-import LLVM.Extra.Multi.Value (atom)+import qualified LLVM.Extra.Nice.Value.Storable as Storable+import qualified LLVM.Extra.Nice.Value as NiceValue+import LLVM.Extra.Nice.Value (atom)  import qualified Data.Word as Word import qualified Data.Int as Int@@ -48,7 +48,7 @@   -class (MultiValue.Logic block) => BitSet block where+class (NiceValue.Logic block) => BitSet block where    nullBlock :: Exp block -> Exp Bool    blocksFromSets :: (Ord a) => [Set a] -> ([[block]], [block])    keepMinimumBit :: Exp block -> Exp block@@ -74,9 +74,9 @@    keepMinimumBit = keepMinimumBitPrim  keepMinimumBitPrim ::-   (MultiValue.Additive a, MultiValue.Logic a) => Exp a -> Exp a+   (NiceValue.Additive a, NiceValue.Logic a) => Exp a -> Exp a keepMinimumBitPrim =-   Expr.liftM (\x -> MultiValue.and x =<< MultiValue.neg x)+   Expr.liftM (\x -> NiceValue.and x =<< NiceValue.neg x)   @@ -92,7 +92,7 @@ type DigitDim = Shape.ZeroBased DigitId  -addLow, addHigh :: MultiValue.Logic a => Exp a -> Exp a -> Exp a -> Exp a+addLow, addHigh :: NiceValue.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 @@ -108,7 +108,7 @@       (Symb.map Expr.tuple $ halfBags xs)  -zbAtom :: Shape.ZeroBased (MultiValue.Atom a)+zbAtom :: Shape.ZeroBased (NiceValue.Atom a) zbAtom = Shape.ZeroBased atom  halfBags ::@@ -132,7 +132,7 @@              Shape.ZeroBased (numDigits+1)))          (Symb.shape xs)) -elseIfThen :: MultiValue.C a => Exp a -> Exp Bool -> Exp a -> Exp a+elseIfThen :: NiceValue.C a => Exp a -> Exp Bool -> Exp a -> Exp a elseIfThen y c x = Expr.ifThenElse c x y  @@ -234,11 +234,11 @@ sumBags3 = liftA2 (<=<) sumLoop add3  -difference :: (MultiValue.Logic a) => Exp a -> Exp a -> Exp a+difference :: (NiceValue.Logic a) => Exp a -> Exp a -> Exp a difference x y = x .&.* Expr.complement y  differenceWithRow ::-   (Shape.C k, MultiValue.Logic block) =>+   (Shape.C k, NiceValue.Logic block) =>    Symb.Array BlockDim block -> Exp (Shape.Index k) ->    Symb.Array (k,BlockDim) block -> Symb.Array BlockDim block differenceWithRow x k bag =@@ -249,7 +249,7 @@ disjoint x y  =  nullBlock $ x .&.* y  getRow ::-   (Shape.C k, MultiValue.C block) =>+   (Shape.C k, NiceValue.C block) =>    Exp (Shape.Index k) ->    Symb.Array (k, BlockDim) block -> Symb.Array BlockDim block getRow k = Slice.apply (Slice.pickFst k)@@ -288,7 +288,7 @@    Render.run $ \k -> findIndices . disjointRows k  collectRows ::-   (MultiValue.C block) =>+   (NiceValue.C block) =>    Symb.Array SetDim SetId ->    Symb.Array (SetDim,BlockDim) block -> Symb.Array (SetDim,BlockDim) block collectRows rows sets =
src/Math/SetCover/Exact/Knead/Vector.hs view
@@ -12,8 +12,8 @@  import qualified LLVM.DSL.Expression as Expr -import qualified LLVM.Extra.Multi.Value.Storable as Storable-import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Nice.Value.Storable as Storable+import qualified LLVM.Extra.Nice.Value as NiceValue import qualified LLVM.Extra.Arithmetic as A  import qualified LLVM.Core as LLVM@@ -60,13 +60,13 @@       let ptr64 = castPtr ptr       in  liftA2 Block (peekLE ptr64) (peekLE (advancePtr ptr64 1)) -instance MultiValue.C Block where+instance NiceValue.C Block where    type Repr Block = LLVM.Value ByteVector-   cons = MultiValue.consPrimitive . blockVector-   undef = MultiValue.undefPrimitive-   zero = MultiValue.zeroPrimitive-   phi = MultiValue.phiPrimitive-   addPhi = MultiValue.addPhiPrimitive+   cons = NiceValue.consPrimitive . blockVector+   undef = NiceValue.undefPrimitive+   zero = NiceValue.zeroPrimitive+   phi = NiceValue.phiPrimitive+   addPhi = NiceValue.addPhiPrimitive  blockVector :: Block -> ByteVector blockVector (Block x0 x1) =@@ -77,13 +77,13 @@          in if k<split then getByte k x0 else getByte (k-split) x1) $    NonEmptyC.iterate (1+) 0 -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 NiceValue.Logic Block where+   and = NiceValue.liftM2 LLVM.and; or = NiceValue.liftM2 LLVM.or+   xor = NiceValue.liftM2 LLVM.xor; inv = NiceValue.liftM LLVM.inv  instance Storable.C Block where-   load = fmap MultiValue.cast . Storable.load <=< castBlockPtr-   store b = Storable.store (MultiValue.cast b) <=< castBlockPtr+   load = fmap NiceValue.cast . Storable.load <=< castBlockPtr+   store b = Storable.store (NiceValue.cast b) <=< castBlockPtr  castBlockPtr ::    LLVM.Value (Ptr Block) ->
+ test/DocTest/GraphColoring/CutEnumSet.hs view
@@ -0,0 +1,46 @@+-- Do not edit! Automatically created with doctest-extract from example/GraphColoring/CutEnumSet.hs+{-# LINE 17 "example/GraphColoring/CutEnumSet.hs" #-}++module DocTest.GraphColoring.CutEnumSet where++import GraphColoring.CutEnumSet+import qualified Test.DocTest.Driver as DocTest++{-# LINE 18 "example/GraphColoring/CutEnumSet.hs" #-}+import     qualified Math.SetCover.Exact as ESC++import     qualified Data.EnumSet as EnumSet+import     qualified Data.List.Key as Key+import     Data.Word (Word32)++import     Control.Applicative (liftA2)++import     qualified Test.QuickCheck as QC+import     Test.QuickCheck ((===))++test :: DocTest.T ()+test = do+ DocTest.printPrefix "GraphColoring.CutEnumSet:111: "+{-# LINE 111 "example/GraphColoring/CutEnumSet.hs" #-}+ DocTest.property(+{-# LINE 111 "example/GraphColoring/CutEnumSet.hs" #-}+        +   QC.forAll (fmap (\n -> take (1 + mod n 5) ['a'..]) QC.arbitrary) $ \set ->+   QC.forAll (QC.sublistOf set) $ \used ->+   let usedSet = EnumSet.fromList used in+   let genLabel =+         QC.oneof+            [fmap Left $ liftA2 (,) (QC.elements set) (QC.elements set),+             fmap Right $+               liftA2 (,) (QC.arbitrary :: QC.Gen Integer) (QC.elements set)]+       genAssignSet :: QC.Gen Word32+       genAssignSet = QC.arbitrary+   in+   QC.forAll (QC.listOf (liftA2 ESC.assign genLabel genAssignSet)) $ \assigns ->+   let normalize =+         Key.sort fst . map (\(ESC.Assign label aset) -> (label,aset)) in++   normalize (uniqueNewColors usedSet assigns)+   ===+   normalize (uniqueNewColorsStable usedSet assigns)+  )
+ test/DocTest/GraphColoring/Solve.hs view
@@ -0,0 +1,106 @@+-- Do not edit! Automatically created with doctest-extract from example/GraphColoring/Solve.hs+{-# LINE 16 "example/GraphColoring/Solve.hs" #-}++module DocTest.GraphColoring.Solve where++import GraphColoring.Solve+import Test.DocTest.Base+import qualified Test.DocTest.Driver as DocTest++{-# LINE 17 "example/GraphColoring/Solve.hs" #-}+import     qualified GraphColoring.CutEnumSet as CutEnumSet+import     qualified Math.SetCover.Exact as ESC++import     qualified Data.Set as Set+import     qualified Data.List.Key as Key+import     Data.Either.HT (maybeRight)+import     Data.Maybe (catMaybes, mapMaybe)++import     qualified Test.QuickCheck as QC+import     Test.QuickCheck ((===))++solve     :: ([Char], [Edge Int]) -> [[(Int, Char)]]+solve     =+       map (Key.sort fst . catMaybes) . ESC.search .+       ESC.compressState Set.toList . initialize assigns++test :: DocTest.T ()+test = do+ DocTest.printPrefix "GraphColoring.Solve:155: "+{-# LINE 155 "example/GraphColoring/Solve.hs" #-}+ DocTest.example(+{-# LINE 155 "example/GraphColoring/Solve.hs" #-}+    solve example0+  )+  [ExpectedLine [LineChunk "[[(0,'a'),(1,'b'),(2,'a'),(3,'b'),(4,'a'),(5,'b')]]"]]+ DocTest.printPrefix "GraphColoring.Solve:162: "+{-# LINE 162 "example/GraphColoring/Solve.hs" #-}+ DocTest.example(+{-# LINE 162 "example/GraphColoring/Solve.hs" #-}+    minimum $ solve example1+  )+  [ExpectedLine [LineChunk "[(0,'a'),(1,'b'),(2,'a'),(3,'b'),(4,'c')]"]]+ DocTest.printPrefix "GraphColoring.Solve:169: "+{-# LINE 169 "example/GraphColoring/Solve.hs" #-}+ DocTest.example(+{-# LINE 169 "example/GraphColoring/Solve.hs" #-}+    solve example2+  )+  [ExpectedLine [LineChunk "[[(0,'a'),(1,'b'),(2,'c')]]"]]+ DocTest.printPrefix "GraphColoring.Solve:176: "+{-# LINE 176 "example/GraphColoring/Solve.hs" #-}+ DocTest.example(+{-# LINE 176 "example/GraphColoring/Solve.hs" #-}+    solve example3+  )+  [ExpectedLine [LineChunk "[[(0,'a'),(1,'b'),(2,'c'),(3,'b')]]"]]+ DocTest.printPrefix "GraphColoring.Solve:183: "+{-# LINE 183 "example/GraphColoring/Solve.hs" #-}+ DocTest.example(+{-# LINE 183 "example/GraphColoring/Solve.hs" #-}+    solve example4+  )+  [ExpectedLine [LineChunk "[]"]]+ DocTest.printPrefix "GraphColoring.Solve:191: "+{-# LINE 191 "example/GraphColoring/Solve.hs" #-}+ DocTest.example(+{-# LINE 191 "example/GraphColoring/Solve.hs" #-}+    length $ ESC.search $ ESC.compressState Set.toList $ ESC.initState $ assigns ['a'..'e'] (complete 5)+  )+  [ExpectedLine [LineChunk "120"]]+ DocTest.printPrefix "GraphColoring.Solve:194: "+{-# LINE 194 "example/GraphColoring/Solve.hs" #-}+ DocTest.property(+{-# LINE 194 "example/GraphColoring/Solve.hs" #-}+        +   QC.forAll (QC.choose (2,5)) $ \n ->+   QC.forAll (QC.choose (2,7)) $ \k ->++   (length $ ESC.search $ ESC.compressState Set.toList $+      ESC.initState $ assigns (take k ['a'..]) (complete n))+   ===+   product (take n [k,(k-1)..])+  )+ DocTest.printPrefix "GraphColoring.Solve:204: "+{-# LINE 204 "example/GraphColoring/Solve.hs" #-}+ DocTest.property(+{-# LINE 204 "example/GraphColoring/Solve.hs" #-}+        +   QC.forAll (QC.choose (2,5)) $ \n ->+   QC.forAll (QC.choose (2,7)) $ \k ->++   (length $ CutEnumSet.search $ CutEnumSet.initState $+      ESC.intSetFromSetAssigns $ assignsEdgeColor (take k ['a'..]) (complete n))+   ===+   if n<=k then 1 else 0+  )+ DocTest.printPrefix "GraphColoring.Solve:218: "+{-# LINE 218 "example/GraphColoring/Solve.hs" #-}+ DocTest.example(+{-# LINE 218 "example/GraphColoring/Solve.hs" #-}+      +   map (Key.sort fst . mapMaybe maybeRight) $+   CutEnumSet.search $ CutEnumSet.initState $+   ESC.intSetFromSetAssigns $ uncurry assignsEdgeColor example5+  )+  [ExpectedLine [LineChunk "[[(1,'a'),(2,'b'),(3,'c'),(4,'d'),(5,'e'),(6,'f'),(7,'g'),(8,'h'),(9,'i'),(10,'j')]]"]]
+ test/DocTest/Main.hs view
@@ -0,0 +1,12 @@+-- Do not edit! Automatically created with doctest-extract.+module DocTest.Main where++import qualified DocTest.GraphColoring.Solve+import qualified DocTest.GraphColoring.CutEnumSet++import qualified Test.DocTest.Driver as DocTest++main :: DocTest.T ()+main = do+    DocTest.GraphColoring.Solve.test+    DocTest.GraphColoring.CutEnumSet.test
test/Test.hs view
@@ -1,5 +1,6 @@ module Main where +import qualified DocTest.Main as DocTest import qualified Mastermind.Test as Mastermind import qualified Test.Knead as TestKnead import Test.Utility@@ -12,6 +13,9 @@ import qualified Math.SetCover.Exact as ESC import qualified Math.SetCover.Queue as Queue +import qualified Control.Monad.Trans.Class as MT+import qualified Control.Monad.Trans.Reader as MR+import Control.Monad.IO.Class (liftIO) import Control.Monad (liftM2) import Control.Applicative ((<$>)) @@ -25,6 +29,7 @@ import Data.Eq.HT (equating) import Data.Tuple.HT (mapFst, mapSnd) +import qualified Test.DocTest.Driver as DocTest import qualified Test.QuickCheck as QC  @@ -303,12 +308,13 @@    []  -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) $+   DocTest.run $ (>> DocTest.main) $ MT.lift $+   mapM_ (\(msg, (count, prop)) -> do+      liftIO $ putStr (msg++": ")+      MR.runReaderT+         (DocTest.property prop)+         (QC.stdArgs {QC.maxSuccess = count, QC.chatty=True})) $     tests ++ map (mapFst ("Mastermind."++)) Mastermind.tests