packages feed

set-cover 0.0.7 → 0.0.8

raw patch · 16 files changed

+702/−29 lines, 16 filesdep +enummapsetdep +psqueuesdep ~utility-ht

Dependencies added: enummapset, psqueues

Dependency ranges changed: utility-ht

Files

+ Changes.md view
@@ -0,0 +1,23 @@+# Change log for the `set-cover` package++## 0.0.8++ * `SetCover.Exact.Priority` implements the Algorithm X+   using a priority queue that registers the sets+   each element is contained in.+   This allows for drastic speedup of the `Nonogram` example.++## 0.0.7++ * `ESC.bitVectorFromSetAssigns` allows to turn sets+   into bit vectors without manual bit position gymnastics.++ * Use it in `Sudoku` and `Nonogram` examples.++## 0.0.6++ * Add `SetCover.Exact.Set` instances for `Map`, `Integer`, `IntSet`.++## 0.0.5.1++ * `example/Nonogram`: explore different encodings of the problem
example/Nonogram.hs view
@@ -2,8 +2,8 @@ * <https://en.wikipedia.org/wiki/Nonogram> * <https://de.wikipedia.org/wiki/Datei:Paint_by_numbers_Animation.gif> -The solver works but is pretty slow-although the Combinatoric set formulation minimizes the need to guess.+With the Combinatoric encoding and the priority queue based solver+the performance is appropriate but specialized solvers are still faster. -} module Main where @@ -12,14 +12,22 @@ import qualified Nonogram.Encoding.BlackWhite as BlackWhite import qualified Nonogram.Encoding.Plug as Plug import qualified Nonogram.Encoding.Naive as Naive-import Nonogram.Base (Color(White, Black))+import Nonogram.Base (Strip, Color(White, Black)) -import qualified Math.SetCover.Exact as ESC+import qualified Math.SetCover.Exact.Priority as ESC+import qualified Math.SetCover.Exact as ESCS+import qualified Math.SetCover.BitPosition as BitPos+import qualified Math.SetCover.BitSet as BitSet+import qualified Math.SetCover.Queue as Queue +import qualified Data.OrdPSQ as PSQ; import Data.OrdPSQ (OrdPSQ) import qualified Data.Map as Map; import Data.Map (Map) import qualified Data.Set as Set; import Data.Set (Set)+import qualified Data.EnumMap as EnumMap import qualified Data.NonEmpty as NonEmpty import qualified Data.List.HT as ListHT+import Data.IntPSQ (IntPSQ)+import Data.EnumSet (EnumSet) import Data.Foldable (foldMap) import Data.NonEmpty ((!:)) @@ -28,23 +36,40 @@ decode rows columns =    map Set.unions $    case 01::Int of-      00 -> ESC.partitions $+      00 -> ESC.partitions ESC.queueBit $                Combinatoric.bitVectorAssigns (length rows) (length columns) $                Combinatoric.assigns rows columns-      01 -> ESC.partitions $+      01 -> ESC.partitions queueMapBit $                Combinatoric.bitAssigns $ Combinatoric.assigns rows columns-      02 -> ESC.partitions $+      02 -> ESCS.partitions $                Combinatoric.intSetAssigns (length rows) (length columns) $                Combinatoric.assigns rows columns-      03 -> ESC.partitions $ Combinatoric.assigns rows columns-      10 -> ESC.partitions $+      03 -> partitionsSet $ Combinatoric.assigns rows columns+      10 -> ESC.partitions queueMapBit $                BlackWhite.bitAssigns rows columns $                BlackWhite.assigns rows columns-      11 -> ESC.partitions $ BlackWhite.assigns rows columns-      20 -> ESC.partitions $ Plug.assigns rows columns-      _  -> ESC.partitions $ Naive.assigns rows columns+      11 -> partitionsSet $ BlackWhite.assigns rows columns+      20 -> partitionsSet $ Plug.assigns rows columns+      _  -> partitionsSet $ Naive.assigns rows columns +partitionsSet :: (Ord a) => [ESC.Assign label (Map Strip (Set a))] -> [[label]]+partitionsSet = ESC.partitions queueMap +queueMap ::+   (Ord a) =>+   Queue.Methods+      (OrdPSQ Strip Int (OrdPSQ a Int (EnumSet Queue.SetId)))+      (Map Strip (Set a))+queueMap = ESC.queueMap ESC.queueSet++queueMapBit ::+   (BitPos.C bits) =>+   Queue.Methods+      (OrdPSQ Strip Int (IntPSQ Int (EnumSet Queue.SetId)))+      (Map Strip (BitSet.Set bits))+queueMapBit = ESC.queueMap ESC.queueBit++ format :: Int -> Int -> Set (Int, Int) -> String format rows columns set =    unlines $@@ -79,7 +104,7 @@    putStrLn "set union:"    print $ foldMap ESC.labeledSet assigns    mapM_ (putStrLn . format (length rows) (length columns) . Set.unions) $-      ESC.partitions assigns+      partitionsSet assigns  decodeImage :: ([[Int]], [[Int]]) -> IO () decodeImage (rows, columns) =@@ -92,15 +117,14 @@ evolve :: ([[Int]], [[Int]]) -> IO () evolve (rows, columns) =    let formatIntermediate state =-          (show $ length $ ESC.availableSubsets state) ++ '\n' :+          (show $ EnumMap.size $ ESC.availableSubsets state) ++ '\n' :           (formatBW (length rows) (length columns) .            Map.unionsWith (error "conflicting colors") .-           map ESC.label . ESC.usedSubsets $ state)+           ESC.usedSubsets $ state)    in  mapM_ (putStrLn . besidesMany 2 . map formatIntermediate) $-       fst $ ListHT.breakAfter (all (ESC.null . ESC.freeElements)) $-       iterate (concatMap ESC.step)-         [ESC.initState $ Combinatoric.bitAssigns $-          Combinatoric.assignsBW rows columns]+       fst $ ListHT.breakAfter (all (PSQ.null . ESC.queue)) $+       iterate (concatMap (ESC.step queueMap))+         [ESC.initState queueMap $ Combinatoric.assignsBW rows columns]  main :: IO () main = evolve Example.soccerEnc
set-cover.cabal view
@@ -1,5 +1,5 @@ Name:             set-cover-Version:          0.0.7+Version:          0.0.8 License:          BSD3 License-File:     LICENSE Author:           Henning Thielemann, Helmut Podhaisky@@ -25,13 +25,14 @@ Tested-With:      GHC==7.4.2, GHC==7.6.3, GHC==7.8.2 Cabal-Version:    >=1.8 Build-Type:       Simple+Extra-Source-Files: Changes.md  Flag buildExamples   description: Build example executables   default:     False  Source-Repository this-  Tag:         0.0.7+  Tag:         0.0.8   Type:        darcs   Location:    http://hub.darcs.net/thielema/set-cover/ @@ -41,8 +42,10 @@  Library   Build-Depends:+    psqueues >=0.2 && <0.3,+    enummapset >=0.1 && <0.6,     containers >=0.4 && <0.6,-    utility-ht >=0.0.1 && <0.1,+    utility-ht >=0.0.12 && <0.1,     base >=4 && <5    GHC-Options:      -Wall@@ -51,10 +54,19 @@     Math.SetCover.Bit     Math.SetCover.BitMap     Math.SetCover.BitSet+    Math.SetCover.BitPosition+    Math.SetCover.Queue     Math.SetCover.Exact+    Math.SetCover.Exact.Priority     Math.SetCover.Cuboid   Other-Modules:     Math.SetCover.IntSet+    Math.SetCover.BitPriorityQueue+    Math.SetCover.EnumMap+    Math.SetCover.Queue.Set+    Math.SetCover.Queue.Map+    Math.SetCover.Queue.Bit+    Math.SetCover.Queue.BitPriorityQueue  Executable tetris-cube   If flag(buildExamples)@@ -194,6 +206,8 @@     Build-Depends:       set-cover,       non-empty >=0.2 && <0.4,+      psqueues,+      enummapset,       containers,       utility-ht,       base
src/Math/SetCover/Bit.hs view
@@ -13,7 +13,7 @@ This class is similar to the 'Bits' class from the @base@ package but adds 'keepMinimum' and misses the rotation stuff. -}-class Eq bits => C bits where+class Ord bits => C bits where    empty :: bits    complement, keepMinimum :: bits -> bits    xor, (.&.), (.|.) :: bits -> bits -> bits@@ -58,12 +58,15 @@    (.&.) = (Bits..&.)    (.|.) = (Bits..|.) +difference :: C bits => bits -> bits -> bits+difference xs ys = xs .&. complement ys + {- cf. package largeword -} data Sum a b = Sum !a !b-   deriving (Eq, Show)+   deriving (Eq, Ord, Show)  instance (C a, C b) => C (Sum a b) where    empty = Sum empty empty
src/Math/SetCover/BitMap.hs view
@@ -1,10 +1,19 @@-module Math.SetCover.BitMap where+module Math.SetCover.BitMap (+   Map(..),+   fromSet,+   add, inc,+   sub, dec,+   intersectionSet,+   differenceSet,+   minimumSet,+   ) where  import qualified Math.SetCover.BitSet as BitSet import qualified Math.SetCover.Bit as Bit import Math.SetCover.BitSet (Set(Set))-import Math.SetCover.Bit (xor, (.|.), (.&.))+import Math.SetCover.Bit (difference, xor, (.|.), (.&.)) +import qualified Data.List.Reverse.StrictSpine as ListRev import Data.Monoid (Monoid, mempty, mappend)  @@ -34,6 +43,33 @@    let go c [] = if c==Bit.empty then [] else [c]        go c (x:xs) = xor c x : go (c .&. x) xs    in  Map $ go xs0 ys0+++sub :: Bit.C bits => Map bits -> Map bits -> Map bits+sub (Map xs0) (Map ys0) =+   let go c xs [] = normalize $ unMap $ dec (Set c) (Map xs)+       go c [] ys =+          if c==Bit.empty && all (==Bit.empty) ys+            then []+            else error "sub: underflow"+       go c (x:xs) (y:ys) =+          xor c (xor x y) : go (difference (c.|.y) x .|. c.&.y) xs ys+   in  Map $ go Bit.empty xs0 ys0++dec :: Bit.C bits => Set bits -> Map bits -> Map bits+dec (Set xs0) (Map ys0) =+   let go c [] = if c==Bit.empty then [] else error "dec: underflow"+       go c (x:xs) = xor c x : go (difference c x) xs+   in  Map $ go xs0 ys0++intersectionSet :: (Bit.C bits) => Map bits -> Set bits -> Map bits+intersectionSet (Map xs) (Set y) = Map $ normalize $ map (y.&.) xs++differenceSet :: (Bit.C bits) => Map bits -> Set bits -> Map bits+differenceSet (Map xs) (Set y) = Map $ normalize $ map (flip difference y) xs++normalize :: (Bit.C bits) => [bits] -> [bits]+normalize = ListRev.dropWhile (Bit.empty==)   {-
+ src/Math/SetCover/BitPosition.hs view
@@ -0,0 +1,116 @@+module Math.SetCover.BitPosition (C, unpack, singleton, bitPosition) where++import qualified Math.SetCover.BitSet as BitSet+import qualified Math.SetCover.Bit as Bit+import Math.SetCover.Bit ((.&.))++import qualified Data.Bits as Bits+import Data.Bits (Bits, shiftR)+import Data.Word (Word8, Word16, Word32, Word64)++import qualified Data.List.HT as ListHT+import qualified Data.List as List+import Data.Maybe.HT (toMaybe)+++unpackGen :: (C bits) => BitSet.Set bits -> [Int]+unpackGen = map bitPosition . decompose++decompose :: (Bit.C bits) => BitSet.Set bits -> [BitSet.Set bits]+decompose =+   List.unfoldr $ \set ->+      toMaybe (not $ BitSet.null set) $+         let x = BitSet.keepMinimum set+         in  (x, BitSet.difference set x)++{-# INLINE positionMasks #-}+positionMasks :: (Integral bits, Bit.C bits) => [bits]+positionMasks =+   map (Bit.complement . div (-1) . (1+)) $+   takeWhile (/=0) $ iterate (\w -> w*w) 2++{-+Alternative: @bits-extras:Data.Bits.Extras.lowestBitPlus1@+-}+{-# INLINE bitPositionGen #-}+bitPositionGen ::+   (Integral bits, Bits bits, Bit.C bits) => [bits] -> bits -> Int+bitPositionGen masks w =+   foldr+      (\mask acc -> fromEnum (mask .&. w /= Bit.empty) + 2*acc)+      0 masks++class Bit.C bits => C bits where+   bit :: Int -> bits+   bitPositionPlain :: bits -> Int+   unpack :: BitSet.Set bits -> [Int]++instance C Word8 where+   bit = Bits.bit+   bitPositionPlain = bitPositionGen positionMasks+   unpack = unpackGen++instance C Word16 where+   bit = Bits.bit+   bitPositionPlain = bitPositionGen positionMasks+   unpack = unpackGen++instance C Word32 where+   bit = Bits.bit+   bitPositionPlain = bitPositionGen positionMasks+   unpack = unpackGen++instance C Word64 where+   bit = Bits.bit+   bitPositionPlain = bitPositionGen positionMasks+   unpack = unpackGen++instance C Integer where+   bit = Bits.bit+   bitPositionPlain =+      ListHT.switchR+         (error "bitPosition: zero Integer")+         (\_ (offset,x) -> offset + bitPositionPlain (word64 x)) .+      zip [0, 64 ..] . takeWhile (/=0) . iterate (flip shiftR 64)+   unpack =+      concatMap (\(offset,x) -> map (offset+) $ unpack (BitSet.Set x)) .+      zip [0, 64 ..] . map (\w -> word64 $ w .&. fromIntegral (-1 :: Word64)) .+      takeWhile (/=0) . iterate (flip shiftR 64) . (\(BitSet.Set x) -> x)++word64 :: Integer -> Word64+word64 = fromIntegral++{- |+Instantiating @a@ with 'Integer' will end badly because it has no fixed size!+-}+instance (Integral a, C a, C b) => C (Bit.Sum a b) where+   bit = bitSum $ bitSize positionMasks+   bitPositionPlain = bitSumPosition $ bitSize positionMasks+   unpack = bitSumUnpack $ bitSize positionMasks++newtype Size bits = Size Int++bitSize :: C bits => [bits] -> Size bits+bitSize = Size . Bits.bit . length++bitSum :: (C a, C b) => Size a -> Int -> Bit.Sum a b+bitSum (Size offset) pos =+   if pos < offset+     then Bit.Sum (bit pos) Bit.empty+     else Bit.Sum Bit.empty (bit $ pos-offset)++bitSumPosition :: (C a, C b) => Size a -> Bit.Sum a b -> Int+bitSumPosition (Size offset) (Bit.Sum a b) =+   if a == Bit.empty+     then offset + bitPositionPlain b+     else bitPositionPlain a++bitSumUnpack :: (C a, C b) => Size a -> BitSet.Set (Bit.Sum a b) -> [Int]+bitSumUnpack (Size offset) (BitSet.Set (Bit.Sum a b)) =+   unpack (BitSet.Set a) ++ map (offset +) (unpack (BitSet.Set b))++bitPosition :: (C bits) => BitSet.Set bits -> Int+bitPosition (BitSet.Set bits) = bitPositionPlain bits++singleton :: (C bits) => Int -> BitSet.Set bits+singleton = BitSet.Set . bit
+ src/Math/SetCover/BitPriorityQueue.hs view
@@ -0,0 +1,64 @@+module Math.SetCover.BitPriorityQueue where++import qualified Math.SetCover.EnumMap as EnumMapX+import qualified Math.SetCover.BitPosition as BitPos+import qualified Math.SetCover.BitMap as BitMap+import qualified Math.SetCover.BitSet as BitSet+import Math.SetCover.EnumMap (constIntMap)++import qualified Data.EnumSet as EnumSet; import Data.EnumSet (EnumSet)+import qualified Data.IntMap as IntMap; import Data.IntMap (IntMap)+import qualified Data.Foldable as Fold+import Data.EnumMap (EnumMap)+import Data.Monoid (mempty, mconcat)+import Data.Maybe.HT (toMaybe)+++{-+We could generalize @EnumSet e@ to @a@+and pretend that the priorities are independent of the 'EnumSet' sizes.+However, 'difference' makes only sense if the priorities match the set sizes.+-}+data Queue bits e = Queue (BitMap.Map bits) (IntMap (EnumSet e))++null :: Queue bits e -> Bool+null (Queue _ns m) = IntMap.null m++fromSets ::+   (Enum e, BitPos.C bits) => EnumMap e (BitSet.Set bits) -> Queue bits e+fromSets xs =+   Queue+      (Fold.foldl' (flip BitMap.inc) mempty xs)+      (EnumMapX.transposeBitSet xs)++elemUnions :: (Enum e) => Queue t e -> EnumSet e+elemUnions (Queue _ns m) = Fold.fold m++keysBits :: (BitPos.C bits) => Queue bits e -> BitSet.Set bits+keysBits (Queue _ m) =+   mconcat $ map BitPos.singleton $ IntMap.keys m++findMin :: (BitPos.C bits) => Queue bits e -> Maybe (EnumSet e)+findMin q@(Queue ns m) =+   let used = keysBits q+   in  toMaybe (not $ BitSet.null used) $+          IntMap.findWithDefault+             (error "findMin: key with minimal priority must be in IntMap")+             (BitPos.bitPosition $ BitSet.keepMinimum $+              BitMap.minimumSet used ns)+             m++difference ::+   (BitPos.C bits, Enum e) => Queue bits e -> Queue bits e -> Queue bits e+difference q0@(Queue ns0 m0) (Queue ns1 m1) =+   Queue+      (BitMap.sub ns0 $ BitMap.intersectionSet ns1 $ keysBits q0)+      (IntMap.differenceWith ((Just.) . EnumSet.difference) m0 m1)++partition ::+   (BitPos.C bits, Enum e) =>+   Queue bits e -> BitSet.Set bits -> (Queue bits e, Queue bits e)+partition (Queue ns m) s =+   let section = IntMap.intersection m $ constIntMap () s+   in  (Queue (BitMap.intersectionSet ns s) section,+        Queue (BitMap.differenceSet ns s) $ IntMap.difference m section)
src/Math/SetCover/BitSet.hs view
@@ -6,7 +6,7 @@ import Data.Monoid (Monoid, mempty, mappend)  -newtype Set bits = Set bits deriving (Show)+newtype Set bits = Set bits deriving (Eq, Ord, Show)  instance (Bit.C bits) => Monoid (Set bits) where    mempty = empty@@ -25,4 +25,4 @@ disjoint (Set xs) (Set ys)  =  xs.&.ys == Bit.empty  difference :: Bit.C bits => Set bits -> Set bits -> Set bits-difference (Set xs) (Set ys) = Set $ xs .&. Bit.complement ys+difference (Set xs) (Set ys) = Set $ Bit.difference xs ys
+ src/Math/SetCover/EnumMap.hs view
@@ -0,0 +1,54 @@+module Math.SetCover.EnumMap where++import qualified Math.SetCover.BitPosition as BitPos+import qualified Math.SetCover.BitSet as BitSet++import qualified Data.EnumMap as EnumMap; import Data.EnumMap (EnumMap)+import qualified Data.EnumSet as EnumSet; import Data.EnumSet (EnumSet)+import qualified Data.IntMap as IntMap; import Data.IntMap (IntMap)+import qualified Data.Map as Map+import qualified Data.Set as Set++import Prelude hiding (const)+++-- EnumMap.fromSet is available from containers-0.5+const :: (Enum e) => a -> EnumSet e -> EnumMap e a+const a = EnumMap.fromAscList . map (\k -> (k, a)) . EnumSet.toAscList++intersection :: (Enum e) => EnumMap e a -> EnumSet e -> EnumMap e a+intersection m s = EnumMap.intersection m $ const () s++partition ::+   (Enum e) => EnumMap e a -> EnumSet e -> (EnumMap e a, EnumMap e a)+partition m s =+   let section = intersection m s+   in  (section, EnumMap.difference m section)+++-- Map.fromSet is available from containers-0.5+constMap :: (Ord a) => b -> Set.Set a -> Map.Map a b+constMap a = Map.fromAscList . map (\k -> (k, a)) . Set.toAscList++transposeSet ::+   (Enum e, Ord a) => EnumMap e (Set.Set a) -> Map.Map a (EnumSet e)+transposeSet =+   Map.unionsWith EnumSet.union . EnumMap.elems .+   EnumMap.mapWithKey (constMap . EnumSet.singleton)+++transposeMap ::+   (Enum e, Ord a) => EnumMap e (Map.Map a b) -> Map.Map a (EnumMap e b)+transposeMap =+   Map.unionsWith EnumMap.union . EnumMap.elems .+   EnumMap.mapWithKey (fmap . EnumMap.singleton)+++constIntMap :: (BitPos.C bits) => b -> BitSet.Set bits -> IntMap b+constIntMap a = IntMap.fromAscList . map (\k -> (k, a)) . BitPos.unpack++transposeBitSet ::+   (BitPos.C bits, Enum e) => EnumMap e (BitSet.Set bits) -> IntMap (EnumSet e)+transposeBitSet =+   IntMap.unionsWith EnumSet.union . EnumMap.elems .+   EnumMap.mapWithKey (constIntMap . EnumSet.singleton)
+ src/Math/SetCover/Exact/Priority.hs view
@@ -0,0 +1,99 @@+{- |+This implementation uses priority queues+and avoids full scans through available sets.+It can be faster than "Math.SetCover.Exact"+if there is a huge number of sets.+-}+module Math.SetCover.Exact.Priority (+   Assign, ESC.label, ESC.labeledSet, ESC.assign,+   partitions, search, step,+   State(..), initState, updateState,+   SetId, queueMap, queueSet, queueBit, queueBitPQ,+   ) where++import qualified Math.SetCover.Queue.Map as QueueMap+import qualified Math.SetCover.Queue.Set as QueueSet+import qualified Math.SetCover.Queue.Bit as QueueBit+import qualified Math.SetCover.Queue.BitPriorityQueue as QueueBitPQ++import qualified Math.SetCover.BitPosition as BitPos++import qualified Math.SetCover.Queue as Queue+import qualified Math.SetCover.Exact as ESC+import Math.SetCover.Queue (Methods, SetId(SetId))+import Math.SetCover.Exact (Assign(Assign), labeledSet)++import qualified Math.SetCover.EnumMap as EnumMapX+import qualified Data.EnumMap as EnumMap; import Data.EnumMap (EnumMap)+import qualified Data.Foldable as Fold+++data State queue label set =+   State {+      availableSubsets :: EnumMap SetId (Assign label set),+      queue :: queue,+      usedSubsets :: [label]+   }++initState ::+   Methods queue set -> [Assign label set] -> State queue label set+initState dict subsets =+   let numberedSets = EnumMap.fromList $ zip [SetId 0 ..] subsets+   in  State {+         availableSubsets = numberedSets,+         queue = Queue.fromEnumMap dict $ fmap labeledSet numberedSets,+         usedSubsets = []+       }++{-# INLINE updateState #-}+updateState ::+   Methods queue set ->+   Assign label set -> State queue label set -> State queue label set+updateState dict (Assign attemptLabel attemptedSet) s =+   let (attemptElems, remainingQueue) =+         Queue.partition dict (queue s) attemptedSet+       (removed, remaining) =+         EnumMapX.partition (availableSubsets s) attemptElems+   in  State {+         availableSubsets = remaining,+         queue = Queue.difference dict remainingQueue $ fmap labeledSet removed,+         usedSubsets = attemptLabel : usedSubsets s+       }++{-# INLINE step #-}+step :: Methods queue set -> State queue label set -> [State queue label set]+step dict s =+   if EnumMap.null (availableSubsets s)+     then []+     else+         flip Fold.foldMap (Queue.findMin dict (queue s)) $+            map (flip (updateState dict) s) . EnumMap.elems .+            EnumMapX.intersection (availableSubsets s)++{-# INLINE search #-}+search :: Methods queue set -> State queue label set -> [[label]]+search dict =+   let go s =+         if Queue.null dict (queue s)+           then [usedSubsets s]+           else step dict s >>= go+   in  go++{-# INLINE partitions #-}+partitions :: Methods queue set -> [Assign label set] -> [[label]]+partitions dict = search dict . initState dict+++-- * different priority queue implementations++queueMap :: Ord a => Queue.Methods queue set -> QueueMap.Methods a queue set+queueMap = QueueMap.methods++queueSet :: Ord a => QueueSet.Methods a+queueSet = QueueSet.methods++queueBit :: BitPos.C bits => QueueBit.Methods bits+queueBit = QueueBit.methods++queueBitPQ :: BitPos.C bits => QueueBitPQ.Methods bits+queueBitPQ = QueueBitPQ.methods
src/Math/SetCover/IntSet.hs view
@@ -7,7 +7,7 @@   data Set = Set {_complement :: Bool, _set :: IntSet}-   deriving (Eq)+   deriving (Eq, Ord)  fromIntSet :: IntSet -> Set fromIntSet = Set False
+ src/Math/SetCover/Queue.hs view
@@ -0,0 +1,21 @@+module Math.SetCover.Queue (SetId(..), Methods(..)) where++import Data.EnumMap (EnumMap)+import Data.EnumSet (EnumSet)+++newtype SetId = SetId Int++instance Enum SetId where+   fromEnum (SetId n) = n+   toEnum = SetId+++data Methods queue set =+   Methods {+      fromEnumMap :: EnumMap SetId set -> queue,+      partition :: queue -> set -> (EnumSet SetId, queue),+      difference :: queue -> EnumMap SetId set -> queue,+      findMin :: queue -> Maybe (EnumSet SetId),+      null :: queue -> Bool+   }
+ src/Math/SetCover/Queue/Bit.hs view
@@ -0,0 +1,67 @@+{- |+Alternative to "Math.SetCover.Queue.Set"+that represents sets by bit masks and uses the faster Int priority queue.+-}+module Math.SetCover.Queue.Bit (Methods, methods) where++import qualified Math.SetCover.Queue as Queue+import Math.SetCover.Queue (SetId)++import qualified Math.SetCover.EnumMap as EnumMapX+import qualified Math.SetCover.BitPosition as BitPos+import qualified Math.SetCover.BitSet as BitSet++import qualified Data.IntPSQ as PSQ+import qualified Data.EnumSet as EnumSet; import Data.EnumSet (EnumSet)+import qualified Data.IntMap as IntMap+import qualified Data.List as List+import Data.Tuple.HT (swap, mapFst, thd3)+++type+   Methods bits =+      Queue.Methods (PSQ.IntPSQ Int (EnumSet SetId)) (BitSet.Set bits)++methods :: BitPos.C bits => Methods bits+methods =+   Queue.Methods {+      Queue.fromEnumMap =+         PSQ.fromList . map (\(elm, ns) -> (elm, EnumSet.size ns, ns)) .+         IntMap.toList . EnumMapX.transposeBitSet,+      Queue.partition =+         \q -> mapFst EnumSet.unions . partitionPSQ q . BitPos.unpack,+      Queue.difference = \q ->+         foldl (flip deleteSetFromPSQ) q .+         IntMap.toList . EnumMapX.transposeBitSet,+      Queue.findMin = fmap thd3 . PSQ.findMin,+      Queue.null = PSQ.null+   }+++{- |+The list of keys must be a subset of the queue keys.+-}+partitionPSQ :: (Ord p) => PSQ.IntPSQ p v -> [Int] -> ([v], PSQ.IntPSQ p v)+partitionPSQ =+   (swap .) .+   List.mapAccumL+      (\q0 k ->+         maybe+            (error "partitionPSQ: key not contained in queue's key set")+            (\(_p,v,q1) -> (q1, v)) $+         PSQ.deleteView k q0)++deleteSetFromPSQ ::+   (Int, EnumSet e) -> PSQ.IntPSQ Int (EnumSet e) ->+   PSQ.IntPSQ Int (EnumSet e)+deleteSetFromPSQ (elm, ns) =+   updatePSQ (flip differenceSizedSet ns) elm++differenceSizedSet :: (Int, EnumSet e) -> EnumSet e -> (Int, EnumSet e)+differenceSizedSet (size, a) b =+   let section = EnumSet.intersection a b+   in  (size - EnumSet.size section, EnumSet.difference a section)++updatePSQ ::+   (Ord p) => ((p, v) -> (p, v)) -> Int -> PSQ.IntPSQ p v -> PSQ.IntPSQ p v+updatePSQ f k = snd . PSQ.alter ((,) () . fmap f) k
+ src/Math/SetCover/Queue/BitPriorityQueue.hs view
@@ -0,0 +1,27 @@+{- |+Alternative to "Math.SetCover.Queue.Set"+that represents sets by bit masks and uses a bitset-based Int priority queue.+-}+module Math.SetCover.Queue.BitPriorityQueue (Methods, methods) where++import qualified Math.SetCover.Queue as Queue+import Math.SetCover.Queue (SetId)++import qualified Math.SetCover.BitPriorityQueue as BitPQ+import qualified Math.SetCover.BitPosition as BitPos+import qualified Math.SetCover.BitSet as BitSet++import Data.Tuple.HT (mapFst)+++type Methods bits = Queue.Methods (BitPQ.Queue bits SetId) (BitSet.Set bits)++methods :: BitPos.C bits => Methods bits+methods =+   Queue.Methods {+      Queue.fromEnumMap = BitPQ.fromSets,+      Queue.partition = (mapFst BitPQ.elemUnions.) . BitPQ.partition,+      Queue.difference = \q -> BitPQ.difference q . BitPQ.fromSets,+      Queue.findMin = BitPQ.findMin,+      Queue.null = BitPQ.null+   }
+ src/Math/SetCover/Queue/Map.hs view
@@ -0,0 +1,61 @@+module Math.SetCover.Queue.Map (Methods, methods) where++import qualified Math.SetCover.Queue as Queue++import qualified Math.SetCover.EnumMap as EnumMapX+import qualified Data.OrdPSQ as PSQ+import qualified Data.EnumSet as EnumSet+import qualified Data.Map as Map; import Data.Map (Map)+import Control.Monad.HT ((<=<))+import Control.Applicative ((<$>))+import Data.Monoid (Monoid, mempty, mappend)+import Data.Maybe (mapMaybe)+import Data.Tuple.HT (mapFst, mapSnd, thd3)+++type Methods a queue set = Queue.Methods (PSQ.OrdPSQ a Int queue) (Map a set)++methods :: Ord a => Queue.Methods queue set -> Methods a queue set+methods m =+   Queue.Methods {+      Queue.fromEnumMap =+         PSQ.fromList .+         mapMaybe+            (\(elm, sets) ->+               (\(minSize, ns) -> (elm, minSize, ns)) <$>+               (addMinSize m $ Queue.fromEnumMap m sets)) .+         Map.toList . EnumMapX.transposeMap,+      Queue.partition =+         applyWriter ((mapSnd (addMinSize m) .) . Queue.partition m),+      Queue.difference = \q s ->+         apply ((addMinSize m .) . Queue.difference m)+            q (EnumMapX.transposeMap s),+      Queue.findMin = Queue.findMin m . thd3 <=< PSQ.findMin,+      Queue.null = PSQ.null+   }++addMinSize :: Queue.Methods queue set -> queue -> Maybe (Int, queue)+addMinSize m q = flip (,) q . EnumSet.size <$> Queue.findMin m q++applyWriter ::+   (Ord p, Ord k, Monoid c) =>+   (v -> b -> (c, Maybe (p, v))) ->+   PSQ.OrdPSQ k p v -> Map k b -> (c, PSQ.OrdPSQ k p v)+applyWriter f q =+   Map.foldlWithKey+      (\(sis, qi) a ss ->+         mapFst (mappend sis) $+         PSQ.alter (maybe (mempty, Nothing) $ \(_p,subq) -> f subq ss) a qi)+      (mempty,q)++apply ::+   (Ord k, Ord p) =>+   (a -> b -> Maybe (p, a)) ->+   PSQ.OrdPSQ k p a -> Map k b -> PSQ.OrdPSQ k p a+apply f =+   Map.foldlWithKey (\qi a ss -> updatePSQ (\(_p,subq) -> f subq ss) a qi)++updatePSQ ::+   (Ord p, Ord k) =>+   ((p, v) -> Maybe (p, v)) -> k -> PSQ.OrdPSQ k p v -> PSQ.OrdPSQ k p v+updatePSQ f k = snd . PSQ.alter ((,) () . (f=<<)) k
+ src/Math/SetCover/Queue/Set.hs view
@@ -0,0 +1,64 @@+{- |+Alternative to "Math.SetCover.Exact" that uses a priority queue+and avoids full scans through available sets.+-}+module Math.SetCover.Queue.Set (Methods, methods) where++import qualified Math.SetCover.Queue as Queue+import Math.SetCover.Queue (SetId)++import qualified Math.SetCover.EnumMap as EnumMapX+import qualified Data.OrdPSQ as PSQ+import qualified Data.EnumSet as EnumSet; import Data.EnumSet (EnumSet)+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.List as List+import Data.Tuple.HT (swap, mapFst, thd3)+++type Methods a = Queue.Methods (PSQ.OrdPSQ a Int (EnumSet SetId)) (Set.Set a)++methods :: Ord a => Methods a+methods =+   Queue.Methods {+      Queue.fromEnumMap =+         PSQ.fromList . map (\(elm, ns) -> (elm, EnumSet.size ns, ns)) .+         Map.toList . EnumMapX.transposeSet,+      Queue.partition =+         \q -> mapFst EnumSet.unions . partitionPSQ q . Set.toList,+      Queue.difference = \q ->+         foldl (flip deleteSetFromPSQ) q . Map.toList . EnumMapX.transposeSet,+      Queue.findMin = fmap thd3 . PSQ.findMin,+      Queue.null = PSQ.null+   }++{- |+The list of keys must be a subset of the queue keys.+-}+partitionPSQ ::+   (Ord k, Ord p) => PSQ.OrdPSQ k p v -> [k] -> ([v], PSQ.OrdPSQ k p v)+partitionPSQ =+   (swap .) .+   List.mapAccumL+      (\q0 k ->+         maybe+            (error "partitionPSQ: key not contained in queue's key set")+            (\(_p,v,q1) -> (q1, v)) $+         PSQ.deleteView k q0)++deleteSetFromPSQ ::+   (Ord k) =>+   (k, EnumSet e) -> PSQ.OrdPSQ k Int (EnumSet e) ->+   PSQ.OrdPSQ k Int (EnumSet e)+deleteSetFromPSQ (elm, ns) =+   updatePSQ (flip differenceSizedSet ns) elm++differenceSizedSet :: (Int, EnumSet e) -> EnumSet e -> (Int, EnumSet e)+differenceSizedSet (size, a) b =+   let section = EnumSet.intersection a b+   in  (size - EnumSet.size section, EnumSet.difference a section)++updatePSQ ::+   (Ord p, Ord k) =>+   ((p, v) -> (p, v)) -> k -> PSQ.OrdPSQ k p v -> PSQ.OrdPSQ k p v+updatePSQ f k = snd . PSQ.alter ((,) () . fmap f) k