set-cover 0.0.6 → 0.0.7
raw patch · 4 files changed
+62/−18 lines, 4 files
Files
- example/Nonogram/Encoding/BlackWhite.hs +14/−5
- example/Sudoku.hs +24/−10
- set-cover.cabal +2/−2
- src/Math/SetCover/Exact.hs +22/−1
example/Nonogram/Encoding/BlackWhite.hs view
@@ -17,7 +17,8 @@ * 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, bitAssigns) where+module Nonogram.Encoding.BlackWhite+ (assigns, assignsBW, bitAssigns, bitVectorAssigns) where import qualified Nonogram.Base as Base import Nonogram.Base@@ -29,12 +30,12 @@ import Data.Bits (bit) import qualified Data.Map as Map; import Data.Map (Map)+import qualified Data.Set as Set; import Data.Set (Set) 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.Foldable (foldMap, fold) import Data.Monoid (Monoid)-import Data.Set (Set) data Item = Brick BrickId | Position Int Color | Reserve BrickId Int@@ -118,10 +119,12 @@ assignsBW = assignsGen Base.squareBW +type BitVector = BitSet.Set Integer+ bitAssigns :: [[Int]] -> [[Int]] -> [ESC.Assign map (Map Strip (Set Item))] ->- [ESC.Assign map (Map Strip (BitSet.Set Integer))]+ [ESC.Assign map (Map Strip BitVector)] bitAssigns rows columns = let m = (fmap ((,) (length columns)) $ fmap length $@@ -131,10 +134,16 @@ Map.fromList $ zip (map (Strip Vertical) [0..]) columns) in map (fmap (Map.intersectionWith (foldMap . bitFromItem) m)) -bitFromItem :: (Int,Int) -> Item -> BitSet.Set Integer+bitFromItem :: (Int,Int) -> Item -> BitVector 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++bitVectorAssigns ::+ [ESC.Assign map (Map Strip (Set Item))] -> [ESC.Assign map BitVector]+bitVectorAssigns =+ ESC.bitVectorFromSetAssigns .+ map (fmap (fold . Map.mapWithKey (\str -> Set.map ((,) str))))
example/Sudoku.hs view
@@ -12,7 +12,9 @@ import Control.Monad (liftM3, guard) import qualified Data.Array as Array+import qualified Data.Map as Map import qualified Data.Set as Set+import Data.Foldable (foldMap) import Data.Array (array) import Data.Set (Set) import Data.List.HT (sliceVertical)@@ -59,6 +61,12 @@ bitAssigns = liftM3 bitAssign [1..9] [0..8] [0..8] +type BitVector = BitSet.Set Integer++bitVectorAssigns :: [Assign BitVector]+bitVectorAssigns = ESC.bitVectorFromSetAssigns assigns++ format :: [((Int, Int), Int)] -> String format = unlines . map (intersperse ' ') . sliceVertical 9 . Array.elems .@@ -81,27 +89,33 @@ stateFromString :: (ESC.Set set) =>- [Assign set] ->- (Int -> Int -> Int -> Assign set) ->- [String] -> ESC.State ((Int, Int), Int) set-stateFromString asgns asgn css =+ [Assign set] -> [String] -> ESC.State ((Int, Int), Int) set+stateFromString asgns css = foldl (flip ESC.updateState) (ESC.initState asgns) $- do (i,cs) <- zip [0..] css+ do let asnMap = foldMap (\asn -> Map.singleton (ESC.label asn) asn) asgns+ (i,cs) <- zip [0..] css (j,c) <- zip [0..] cs guard $ c/=' '- return $ asgn (fromEnum c - fromEnum '0') i j+ return $+ Map.findWithDefault+ (error "coordinates not available")+ ((i,j), fromEnum c - fromEnum '0') asnMap -main, mainAll, mainSolve, mainBit :: IO ()+main, mainAll, mainSolve, mainBit, mainBitVector :: IO () mainAll = mapM_ (putStrLn . format) $ ESC.partitions bitAssigns mainSolve = mapM_ (putStrLn . format) $ ESC.search $- stateFromString assigns assign exampleHawiki1+ stateFromString assigns exampleHawiki1 mainBit = mapM_ (putStrLn . format) $ ESC.search $- stateFromString bitAssigns bitAssign exampleHawiki1+ stateFromString bitAssigns exampleHawiki1 -main = mainBit+mainBitVector =+ mapM_ (putStrLn . format) $ ESC.search $+ stateFromString bitVectorAssigns exampleHawiki1++main = mainBitVector
set-cover.cabal view
@@ -1,5 +1,5 @@ Name: set-cover-Version: 0.0.6+Version: 0.0.7 License: BSD3 License-File: LICENSE Author: Henning Thielemann, Helmut Podhaisky@@ -31,7 +31,7 @@ default: False Source-Repository this- Tag: 0.0.6+ Tag: 0.0.7 Type: darcs Location: http://hub.darcs.net/thielema/set-cover/
src/Math/SetCover/Exact.hs view
@@ -3,7 +3,7 @@ <http://en.wikipedia.org/wiki/Exact_cover> -} module Math.SetCover.Exact (- Assign(..), assign,+ Assign(..), assign, bitVectorFromSetAssigns, partitions, search, step, State(..), initState, updateState, Set(..),@@ -23,6 +23,7 @@ import qualified Data.List.Match as Match import qualified Data.Foldable as Fold import Data.Maybe.HT (toMaybe)+import Data.Bits (setBit) import Prelude hiding (null) @@ -135,6 +136,26 @@ assign :: label -> set -> Assign label set assign = Assign ++{- |+You may use this to post-process a set of 'Assign's+in order to speedup the solver considerably.+You must process the whole set of 'Assign's at once,+i.e. do not process only parts of the assignment list.+The output of 'bitVectorFromSetAssigns' should go into the solver as is.+-}+bitVectorFromSetAssigns ::+ (Ord a) =>+ [Assign label (Set.Set a)] -> [Assign label (BitSet.Set Integer)]+bitVectorFromSetAssigns asns =+ let mapToInt =+ Map.fromList $ zip (Set.toList $ unions $ map labeledSet asns) [0..]+ err = error "bitVectorFromSetAssigns: element disappeared"+ bitVec =+ Fold.foldl' setBit 0 .+ map (flip (Map.findWithDefault err) mapToInt) .+ Set.toList+ in map (fmap (BitSet.Set . bitVec)) asns {- | The state of the search.