diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -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 diff --git a/example/ConwayPuzzle.hs b/example/ConwayPuzzle.hs --- a/example/ConwayPuzzle.hs +++ b/example/ConwayPuzzle.hs @@ -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 diff --git a/example/GraphColoring.hs b/example/GraphColoring.hs new file mode 100644 --- /dev/null +++ b/example/GraphColoring.hs @@ -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 diff --git a/example/GraphColoring/CutEnumSet.hs b/example/GraphColoring/CutEnumSet.hs new file mode 100644 --- /dev/null +++ b/example/GraphColoring/CutEnumSet.hs @@ -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 diff --git a/example/GraphColoring/CutSet.hs b/example/GraphColoring/CutSet.hs new file mode 100644 --- /dev/null +++ b/example/GraphColoring/CutSet.hs @@ -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 diff --git a/example/GraphColoring/Solve.hs b/example/GraphColoring/Solve.hs new file mode 100644 --- /dev/null +++ b/example/GraphColoring/Solve.hs @@ -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 diff --git a/example/PythagorasColoring.hs b/example/PythagorasColoring.hs new file mode 100644 --- /dev/null +++ b/example/PythagorasColoring.hs @@ -0,0 +1,108 @@ +{- | +Assign one of two colors to every natural number +such that there is no uniformly colored Pythagorean triple. + + + +-} +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 diff --git a/set-cover.cabal b/set-cover.cabal --- a/set-cover.cabal +++ b/set-cover.cabal @@ -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 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 @@ -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 } diff --git a/src/Math/SetCover/Exact/Knead.hs b/src/Math/SetCover/Exact/Knead.hs --- a/src/Math/SetCover/Exact/Knead.hs +++ b/src/Math/SetCover/Exact/Knead.hs @@ -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 diff --git a/src/Math/SetCover/Exact/Knead/Saturated.hs b/src/Math/SetCover/Exact/Knead/Saturated.hs --- a/src/Math/SetCover/Exact/Knead/Saturated.hs +++ b/src/Math/SetCover/Exact/Knead/Saturated.hs @@ -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))) diff --git a/src/Math/SetCover/Exact/Knead/Symbolic.hs b/src/Math/SetCover/Exact/Knead/Symbolic.hs --- a/src/Math/SetCover/Exact/Knead/Symbolic.hs +++ b/src/Math/SetCover/Exact/Knead/Symbolic.hs @@ -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 = diff --git a/src/Math/SetCover/Exact/Knead/Vector.hs b/src/Math/SetCover/Exact/Knead/Vector.hs --- a/src/Math/SetCover/Exact/Knead/Vector.hs +++ b/src/Math/SetCover/Exact/Knead/Vector.hs @@ -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 diff --git a/test/DocTest/GraphColoring/CutEnumSet.hs b/test/DocTest/GraphColoring/CutEnumSet.hs new file mode 100644 --- /dev/null +++ b/test/DocTest/GraphColoring/CutEnumSet.hs @@ -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) + ) diff --git a/test/DocTest/GraphColoring/Solve.hs b/test/DocTest/GraphColoring/Solve.hs new file mode 100644 --- /dev/null +++ b/test/DocTest/GraphColoring/Solve.hs @@ -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')]]"]] diff --git a/test/DocTest/Main.hs b/test/DocTest/Main.hs new file mode 100644 --- /dev/null +++ b/test/DocTest/Main.hs @@ -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 diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -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