set-cover 0.0.5.1 → 0.0.6
raw patch · 10 files changed
+223/−42 lines, 10 files
Files
- example/Nonogram.hs +18/−6
- example/Nonogram/Base.hs +8/−8
- example/Nonogram/Encoding/BlackWhite.hs +29/−6
- example/Nonogram/Encoding/Combinatoric.hs +61/−6
- example/Nonogram/Encoding/Naive.hs +7/−11
- example/Nonogram/Encoding/Plug.hs +2/−3
- set-cover.cabal +4/−2
- src/Math/SetCover/Bit.hs +8/−0
- src/Math/SetCover/Exact.hs +44/−0
- src/Math/SetCover/IntSet.hs +42/−0
example/Nonogram.hs view
@@ -27,11 +27,22 @@ decode :: [[Int]] -> [[Int]] -> [Set (Int, Int)] decode rows columns = map Set.unions $- case 0::Int of- 0 -> ESC.partitions $ Combinatoric.assigns rows columns- 1 -> ESC.partitions $ BlackWhite.assigns rows columns- 2 -> ESC.partitions $ Plug.assigns rows columns- _ -> ESC.partitions $ Naive.assigns rows columns+ case 01::Int of+ 00 -> ESC.partitions $+ Combinatoric.bitVectorAssigns (length rows) (length columns) $+ Combinatoric.assigns rows columns+ 01 -> ESC.partitions $+ Combinatoric.bitAssigns $ Combinatoric.assigns rows columns+ 02 -> ESC.partitions $+ Combinatoric.intSetAssigns (length rows) (length columns) $+ Combinatoric.assigns rows columns+ 03 -> ESC.partitions $ Combinatoric.assigns rows columns+ 10 -> ESC.partitions $+ 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 format :: Int -> Int -> Set (Int, Int) -> String@@ -88,7 +99,8 @@ in mapM_ (putStrLn . besidesMany 2 . map formatIntermediate) $ fst $ ListHT.breakAfter (all (ESC.null . ESC.freeElements)) $ iterate (concatMap ESC.step)- [ESC.initState $ Combinatoric.assignsBW rows columns]+ [ESC.initState $ Combinatoric.bitAssigns $+ Combinatoric.assignsBW rows columns] main :: IO () main = evolve Example.soccerEnc
example/Nonogram/Base.hs view
@@ -14,7 +14,7 @@ {- | Identifies one row or column by its orientation and its position. -}-data Strip item = Strip Orientation Int item+data Strip = Strip Orientation Int deriving (Eq, Ord, Show) {- |@@ -33,14 +33,14 @@ deriving (Eq, Ord, Show) data Color = White | Black- deriving (Eq, Ord, Show)+ deriving (Eq, Ord, Show, Enum) noAssign :: (Monoid map) => set -> ESC.Assign map set noAssign = ESC.assign mempty -strip :: Ord item => Orientation -> Int -> [item] -> Set (Strip item)-strip orient line = Set.fromList . map (Strip orient line)+strip :: Ord item => Orientation -> Int -> [item] -> Map Strip (Set item)+strip orient line = Map.singleton (Strip orient line) . Set.fromList class Ord item => Position item where position :: Int -> Color -> item@@ -51,14 +51,14 @@ assignsFromPositions :: (Position item) => (Int -> Int -> Color -> map) ->- [[Int]] -> [[Int]] -> [ESC.Assign map (Set (Strip item))]+ [[Int]] -> [[Int]] -> [ESC.Assign map (Map Strip (Set item))] assignsFromPositions squ rows columns = liftM3 (\r c col -> ESC.assign (squ r c col) $- Set.fromList- [Strip Horizontal r (position c col),- Strip Vertical c (position r col)])+ Map.fromList+ [(Strip Horizontal r, Set.singleton (position c col)),+ (Strip Vertical c, Set.singleton (position r col))]) (Match.take rows [0..]) (Match.take columns [0..]) [White, Black]
example/Nonogram/Encoding/BlackWhite.hs view
@@ -17,32 +17,33 @@ * The left-most and the right-most brick in each strip is combined with the space to the left and right border, respectively. -}-module Nonogram.Encoding.BlackWhite (assigns, assignsBW) where+module Nonogram.Encoding.BlackWhite (assigns, assignsBW, bitAssigns) where import qualified Nonogram.Base as Base import Nonogram.Base- (Strip, strip, BrickId(BrickId),+ (Strip(Strip), strip, BrickId(BrickId), Orientation(Horizontal, Vertical), Color(White, Black), noAssign) +import qualified Math.SetCover.BitSet as BitSet import qualified Math.SetCover.Exact as ESC+import Data.Bits (bit) +import qualified Data.Map as Map; import Data.Map (Map) import qualified Data.Monoid.HT as Mn import qualified Data.List.Match as Match import qualified Data.List as List+import Data.Foldable (foldMap) import Data.Monoid (Monoid)-import Data.Map (Map) import Data.Set (Set) -type X = Strip Item- data Item = Brick BrickId | Position Int Color | Reserve BrickId Int deriving (Eq, Ord, Show) instance Base.Position Item where position = Position -type Assign map = ESC.Assign map (Set X)+type Assign map = ESC.Assign map (Map Strip (Set Item)) {- For efficiency reasons combine the left-most and right-most brick@@ -115,3 +116,25 @@ assignsBW :: [[Int]] -> [[Int]] -> [Assign (Map (Int,Int) Color)] assignsBW = assignsGen Base.squareBW+++bitAssigns ::+ [[Int]] -> [[Int]] ->+ [ESC.Assign map (Map Strip (Set Item))] ->+ [ESC.Assign map (Map Strip (BitSet.Set Integer))]+bitAssigns rows columns =+ let m =+ (fmap ((,) (length columns)) $ fmap length $+ Map.fromList $ zip (map (Strip Horizontal) [0..]) rows)+ `Map.union`+ (fmap ((,) (length rows)) $ fmap length $+ Map.fromList $ zip (map (Strip Vertical) [0..]) columns)+ in map (fmap (Map.intersectionWith (foldMap . bitFromItem) m))++bitFromItem :: (Int,Int) -> Item -> BitSet.Set Integer+bitFromItem (width, numBricks) x =+ BitSet.Set $ bit $+ case x of+ Position k color -> 2*k + fromEnum color+ Reserve (BrickId brick) k -> (2+brick)*width + k+ Brick (BrickId brick) -> (2*numBricks)*width + brick
example/Nonogram/Encoding/Combinatoric.hs view
@@ -5,33 +5,37 @@ and a minimum number of solution steps. The solver tends to need very few guesses. -}-module Nonogram.Encoding.Combinatoric (assigns, assignsBW) where+module Nonogram.Encoding.Combinatoric+ (assigns, assignsBW, bitAssigns, intSetAssigns, bitVectorAssigns) where import qualified Nonogram.Base as Base import Nonogram.Base- (Strip, strip, Orientation(Horizontal, Vertical),+ (Strip(Strip), strip, Orientation(Horizontal, Vertical), Color(White, Black), noAssign) +import qualified Math.SetCover.BitSet as BitSet import qualified Math.SetCover.Exact as ESC+import Data.Bits (bit, setBit) import Control.Monad (guard) import Control.Applicative ((<$>)) +import qualified Data.IntSet as IntSet; import Data.IntSet (IntSet)+import qualified Data.Map as Map; import Data.Map (Map) import qualified Data.NonEmpty as NonEmpty+import Data.Foldable (foldMap, fold) import Data.Monoid (Monoid)-import Data.Map (Map)+import Data.Word (Word64) import Data.Set (Set) -type X = Strip Item- data Item = Line | Position Int Color deriving (Eq, Ord, Show) instance Base.Position Item where position = Position -type Assign map = ESC.Assign map (Set X)+type Assign map = ESC.Assign map (Map Strip (Set Item)) {- quickCheck $ \n0 ns0 -> let n = abs n0; ns = map abs ns0 in spread n ns == spreadNaive n ns@@ -90,3 +94,54 @@ assignsBW :: [[Int]] -> [[Int]] -> [Assign (Map (Int,Int) Color)] assignsBW = assignsGen Base.squareBW+++type Mask = BitSet.Set Word64++bitAssigns ::+ [ESC.Assign map (Map Strip (Set Item))] -> [ESC.Assign map (Map Strip Mask)]+bitAssigns = map (fmap (fmap (foldMap (BitSet.Set . bitFromItem))))++bitFromItem :: Item -> Word64+bitFromItem x =+ case x of+ Line -> bit 63+ Position n color ->+ if n<31+ then bit (n + 31 * fromEnum color)+ else error "bitFromItem: position too big"+++intSetAssigns ::+ Int -> Int -> [ESC.Assign map (Map Strip (Set Item))] -> [ESC.Assign map IntSet]+intSetAssigns nr nc =+ map (fmap (fold . Map.mapWithKey (intSetFromItems nr nc)))++intSetFromItems :: Int -> Int -> Strip -> Set Item -> IntSet+intSetFromItems nr nc (Strip orient k) items =+ case orient of+ Horizontal ->+ flip foldMap items $ \item ->+ IntSet.singleton $ intFromItem nr nc k item+ Vertical ->+ flip foldMap items $ \item ->+ IntSet.singleton $ nr + 2*nr*nc + intFromItem nc nr k item++intFromItem :: Int -> Int -> Int -> Item -> Int+intFromItem nr nc k item =+ case item of+ Line -> k+ Position j color -> nr + 2*(nc*k+j) + fromEnum color+++type BitVector = BitSet.Set Integer++bitVectorAssigns ::+ Int -> Int ->+ [ESC.Assign map (Map Strip (Set Item))] -> [ESC.Assign map BitVector]+bitVectorAssigns nr nc =+ map (fmap (fold . Map.mapWithKey (bitVectorFromItems nr nc)))++bitVectorFromItems :: Int -> Int -> Strip -> Set Item -> BitVector+bitVectorFromItems nr nc x =+ BitSet.Set . foldl setBit 0 . IntSet.toList . intSetFromItems nr nc x
example/Nonogram/Encoding/Naive.hs view
@@ -30,15 +30,13 @@ import Control.Monad (liftM2) -import qualified Data.Set as Set+import qualified Data.Map as Map; import Data.Map (Map)+import qualified Data.Set as Set; import Data.Set (Set) import qualified Data.List.Match as Match import qualified Data.List as List import Data.Foldable (foldMap)-import Data.Set (Set) -type X = Strip Item- {- | 'Reserve' ensures that @Brick n@ is left from @Brick (n+1)@. @Brick n@ forbids @Brick (n+1)@ to use any squares@@ -51,7 +49,7 @@ deriving (Eq, Ord, Show) -type Assign = ESC.Assign (Set (Int, Int)) (Set X)+type Assign = ESC.Assign (Set (Int, Int)) (Map Strip (Set Item)) assignsFromBrick :: Orientation -> Int -> Int ->@@ -89,9 +87,7 @@ xs) ++ liftM2- (\brick c ->- noAssign $ Set.singleton $- Strip orient line (Reserve brick c))+ (\brick c -> noAssign $ strip orient line [Reserve brick c]) bricks [0 .. width-1] assigns :: [[Int]] -> [[Int]] -> [Assign]@@ -103,8 +99,8 @@ liftM2 (\r c -> noAssign $- Set.fromList- [Strip Horizontal r (Position c),- Strip Vertical c (Position r)])+ Map.fromList+ [(Strip Horizontal r, Set.singleton (Position c)),+ (Strip Vertical c, Set.singleton (Position r))]) (Match.take rows [0..]) (Match.take columns [0..])
example/Nonogram/Encoding/Plug.hs view
@@ -41,18 +41,17 @@ import qualified Data.List.Match as Match import qualified Data.List.HT as ListHT import qualified Data.List as List+import Data.Map (Map) import Data.Set (Set) -type X = Strip Item- data Item = Brick BrickId | Position Int Color | Square (BrickId, Color) Int deriving (Eq, Ord, Show) instance Base.Position Item where position = Position -type Assign = ESC.Assign (Set (Int, Int)) (Set X)+type Assign = ESC.Assign (Set (Int, Int)) (Map Strip (Set Item)) invertColor :: Color -> Color invertColor c =
set-cover.cabal view
@@ -1,5 +1,5 @@ Name: set-cover-Version: 0.0.5.1+Version: 0.0.6 License: BSD3 License-File: LICENSE Author: Henning Thielemann, Helmut Podhaisky@@ -31,7 +31,7 @@ default: False Source-Repository this- Tag: 0.0.5.1+ Tag: 0.0.6 Type: darcs Location: http://hub.darcs.net/thielema/set-cover/ @@ -53,6 +53,8 @@ Math.SetCover.BitSet Math.SetCover.Exact Math.SetCover.Cuboid+ Other-Modules:+ Math.SetCover.IntSet Executable tetris-cube If flag(buildExamples)
src/Math/SetCover/Bit.hs view
@@ -50,6 +50,14 @@ (.&.) = (Bits..&.) (.|.) = (Bits..|.) +instance C Integer where+ empty = 0+ complement = Bits.complement+ keepMinimum xs = xs .&. (-xs)+ xor = Bits.xor+ (.&.) = (Bits..&.)+ (.|.) = (Bits..|.)+ {- cf. package largeword
src/Math/SetCover/Exact.hs view
@@ -9,15 +9,20 @@ Set(..), ) where +import qualified Math.SetCover.IntSet as IntSetX import qualified Math.SetCover.BitMap as BitMap import qualified Math.SetCover.BitSet as BitSet import qualified Math.SetCover.Bit as Bit +import Control.Applicative ((<$>), (<$))++import qualified Data.IntSet as IntSet import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.List as List import qualified Data.List.Match as Match import qualified Data.Foldable as Fold+import Data.Maybe.HT (toMaybe) import Prelude hiding (null) @@ -37,6 +42,10 @@ 'set' must be a superset of all sets in the assign list. 'set' must be non-empty. The list of assignments must be non-empty.+ The output of assigns must be a subsequence of the input assigns,+ that is, it must be a subset of the input and it must be in the same order.+ This requirement was originally needed by 'minimize' for 'Map.Map',+ but currently it is not utilized anywhere. -} minimize :: set -> [Assign label set] -> [Assign label set] @@ -57,6 +66,28 @@ constMap :: (Ord a) => b -> Set.Set a -> Map.Map a b constMap a = Fold.foldMap (flip Map.singleton a) +{- |+This instance supports Maps of Sets.+This way you can structure your sets hierarchically.+You may also use it to combine several low-level bitsets.+A Map must not contain empty subsets.+-}+instance (Ord k, Set a) => Set (Map.Map k a) where+ null = Map.null+ disjoint x y = Fold.and $ Map.intersectionWith disjoint x y+ unions =+ fmap unions . foldr (Map.unionWith (++)) Map.empty . map (fmap (:[]))+ difference =+ Map.differenceWith+ (\x y -> let z = difference x y in toMaybe (not $ null z) z)+ minimize free asns =+ map label $+ Fold.minimumBy Match.compareLength $+ Map.intersectionWith minimize free $+ foldr (Map.unionWith (++)) ([] <$ free) $+ map (\asn -> (:[]) . assign asn <$> labeledSet asn) asns++ instance (Bit.C a) => Set (BitSet.Set a) where null = BitSet.null disjoint = BitSet.disjoint@@ -67,6 +98,19 @@ BitSet.keepMinimum $ BitMap.minimumSet free $ Fold.foldMap (BitMap.fromSet . labeledSet) available in filter (not . BitSet.disjoint singleMin . labeledSet) available++instance Set IntSet.IntSet where+ null = IntSet.null+ disjoint x y = IntSet.null $ IntSet.intersection x y+ unions = IntSet.unions+ difference = IntSet.difference+ minimize free available =+ let bitset = BitSet.Set . IntSetX.fromIntSet+ singleMin =+ (\(BitSet.Set s) -> IntSetX.findMin s) $+ BitMap.minimumSet (bitset free) $+ Fold.foldMap (BitMap.fromSet . bitset . labeledSet) available+ in filter (IntSet.member singleMin . labeledSet) available {- |
+ src/Math/SetCover/IntSet.hs view
@@ -0,0 +1,42 @@+module Math.SetCover.IntSet (Set, fromIntSet, findMin) where++import qualified Math.SetCover.Bit as Bit++import qualified Data.IntSet as IntSet+import Data.IntSet (IntSet)+++data Set = Set {_complement :: Bool, _set :: IntSet}+ deriving (Eq)++fromIntSet :: IntSet -> Set+fromIntSet = Set False++findMin :: Set -> Int+findMin (Set c s) =+ if c+ then head $ dropWhile (flip IntSet.member s) [0..]+ else IntSet.findMin s++xor :: IntSet -> IntSet -> IntSet+xor x y = IntSet.difference (IntSet.union x y) (IntSet.intersection x y)++instance Bit.C Set where+ empty = fromIntSet IntSet.empty+ keepMinimum = fromIntSet . IntSet.singleton . findMin+ complement (Set c s) = Set (not c) s+ xor (Set c0 s0) (Set c1 s1) = Set (c0/=c1) (xor s0 s1)+ Set c0 s0 .&. Set c1 s1 =+ Set (c0&&c1) $+ case (c0,c1) of+ (False, False) -> IntSet.intersection s0 s1+ (False, True) -> IntSet.difference s0 s1+ (True, False) -> IntSet.difference s1 s0+ (True, True) -> IntSet.union s0 s1+ Set c0 s0 .|. Set c1 s1 =+ Set (c0||c1) $+ case (c0,c1) of+ (False, False) -> IntSet.union s0 s1+ (False, True) -> IntSet.difference s1 s0+ (True, False) -> IntSet.difference s0 s1+ (True, True) -> IntSet.intersection s0 s1