set-cover 0.0.4 → 0.0.5
raw patch · 15 files changed
+1043/−114 lines, 15 filesdep +hahadep +pooled-iodep +randomdep ~arraydep ~basedep ~containersnew-component:exe:lonpos-pyramidnew-component:exe:mastermindnew-component:exe:nonogramnew-component:exe:pangram
Dependencies added: haha, pooled-io, random, unicode
Dependency ranges changed: array, base, containers, transformers, utility-ht
Files
- example/Alphametics.hs +2/−0
- example/Baumeister.hs +3/−0
- example/Domino.hs +30/−50
- example/LCube.hs +5/−2
- example/LonposPyramid.hs +309/−0
- example/Mastermind.hs +160/−0
- example/Nonogram.hs +237/−0
- example/Pangram.hs +63/−0
- example/Parallelism.hs +0/−34
- example/Queen8.hs +35/−0
- example/Soma.hs +10/−0
- example/Sudoku.hs +3/−0
- example/TetrisCube.hs +19/−13
- set-cover.cabal +74/−14
- src/Math/SetCover/Exact.hs +93/−1
example/Alphametics.hs view
@@ -1,4 +1,6 @@ {- |+<https://en.wikipedia.org/wiki/Alphametics>+ Solve the following verbal arithmetics puzzle: > SEND
example/Baumeister.hs view
@@ -1,6 +1,9 @@ {- | Logika's Baumeister puzzle +Like Soma cube but with different bricks+and non-box shapes to fill.+ <http://www.mathe-kaenguru.de/wettbewerb/baumeister/> -} module Main where
example/Domino.hs view
@@ -1,33 +1,41 @@-{-+{- |+Given a field of numbers+find a matching arrangement of Domino bricks.++<http://en.wikipedia.org/wiki/Domino_tiling>++ Juergen Goering Labyrinth der Denkspiele, Seite 127 Zerlege folgende Felder in Dominosteine: -3134205-3110266-3550426-6321201-5045254-3660301-5451243-6264410+> 3134205+> 3110266+> 3550426+> 6321201+> 5045254+> 3660301+> 5451243+> 6264410 -25114225-25304365-11305361-24465661-23560204-63540204-60043311+> 25114225+> 25304365+> 11305361+> 24465661+> 23560204+> 63540204+> 60043311 -} module Main where import qualified Math.SetCover.Exact as ESC +import qualified Data.Char.Frame as Frame import qualified Data.List.HT as ListHT import qualified Data.Set as Set+import Control.Applicative (pure) import Data.Set (Set) import Data.Monoid (Monoid, mempty, mappend, mconcat) @@ -42,8 +50,6 @@ type Position = (Int, Int) -data Corner = Corner (Bool, Bool) (Bool, Bool) deriving (Eq)- data Borders = Borders { vertical, horizontal :: Set Position@@ -108,43 +114,17 @@ [brick b0 b1, uncurry Position p0, uncurry Position p1])) ps -formatBar :: Corner -> Char-formatBar set =- case set of- Corner (False, False) (False, False) -> ' '- Corner (False, False) (True, True ) -> '\x2500'- Corner (True, True ) (False, False) -> '\x2502'- Corner (True, True ) (True, True ) -> '\x253C' - Corner (False, False) (False, True ) -> '\x2574'- Corner (False, False) (True , False) -> '\x2576'- Corner (False, True ) (False, False) -> '\x2577'- Corner (True, False) (False, False) -> '\x2575'-- Corner (False, True ) (False, True ) -> '\x250C'- Corner (False, True ) (True, False) -> '\x2510'- Corner (True, False) (False, True ) -> '\x2514'- Corner (True, False) (True, False) -> '\x2518'-- Corner (True, True ) (False, True ) -> '\x251C'- Corner (True, True ) (True, False) -> '\x2524'- Corner (False, True ) (True, True ) -> '\x252C'- Corner (True, False) (True, True ) -> '\x2534'---double :: a -> (a,a)-double a = (a,a)- formatCorner, formatHorizontal, formatVertical :: Borders -> Position -> Char formatCorner m p =- formatBar $- Corner- (Set.member (above p) (vertical m), Set.member p (vertical m))- (Set.member (left p) (horizontal m), Set.member p (horizontal m))+ Frame.simple $+ Frame.Parts+ (fmap (flip Set.member (vertical m)) $ Frame.Vertical (above p) p)+ (fmap (flip Set.member (horizontal m)) $ Frame.Horizontal (left p) p) formatHorizontal m p =- formatBar (Corner (False,False) (double $ Set.member p (horizontal m)))+ Frame.simple (Frame.Parts (pure False) (pure $ Set.member p (horizontal m))) formatVertical m p =- formatBar (Corner (double $ Set.member p (vertical m)) (False,False))+ Frame.simple (Frame.Parts (pure $ Set.member p (vertical m)) (pure False)) {- | @mapIntersperse f g [a,b,c]@
example/LCube.hs view
@@ -1,3 +1,6 @@+{-+This puzzle is like Soma cube but with only L shaped bricks in a 5x5x5 box.+-} module Main where import qualified Math.SetCover.Exact as ESC@@ -8,9 +11,9 @@ allPositions, allOrientations, packCoords, unpackCoords, dz, normalForm) +import qualified Control.Concurrent.PooledIO.Independent as Pool import qualified System.IO as IO import Text.Printf (printf)-import Parallelism (parallel) import Utility (hPutStrLnImmediate) import qualified Data.Map as Map@@ -109,7 +112,7 @@ print $ length lsg mainParallel =- parallel $+ Pool.runUnlimited $ (\f -> zipWith f [0..] initStates) $ \n initState -> IO.withFile (printf "lcube%02d.txt" (n::Int)) IO.WriteMode $ \h -> mapM_ (hPutStrLnImmediate h . format) $
+ example/LonposPyramid.hs view
@@ -0,0 +1,309 @@+{- |+Lonpos pyramid 101 puzzle++Like Soma cube but with exclusively flat bricks made from balls+that allow to stack the bricks in a diagonal fashion.++There are two problems to solve:++* arrange all bricks in a flat 5x11 rectangle++* arrange all bricks in a square pyramid with a 5x5 base.++<https://www.youtube.com/watch?v=5lwryXvqXBU>+-}+module Main where++import qualified Math.SetCover.Exact as ESC+import qualified Math.SetCover.BitSet as BitSet+import qualified Math.SetCover.Bit as Bit+import qualified Math.SetCover.Cuboid as Cuboid+import Math.SetCover.Cuboid (PackedCoords(PackedCoords), Coords(Coords), Size)++import Control.Applicative (liftA2)++import qualified Data.Map as Map+import qualified Data.Set as Set++import Data.Foldable (forM_, foldMap)+import Data.List (intercalate)+import Data.Maybe (mapMaybe)+import Data.Char (ord, chr)+import Data.Word (Word16, Word64)++import qualified System.IO as IO+import Utility (hPutStrLnImmediate)+import Text.Printf (printf)+++shapes :: [[String]]+shapes =+ (+ ".." :+ " ." :+ [])+ :+ (+ "...." :+ [])+ :+ (+ "..." :+ " ." :+ [])+ :+ (+ ".." :+ ".." :+ [])+ :+ (+ ".. " :+ " .." :+ " ." :+ [])+ :+ (+ "... " :+ " .." :+ [])+ :+ (+ "...." :+ " ." :+ [])+ :+ (+ "...." :+ " . " :+ [])+ :+ (+ "..." :+ ". ." :+ [])+ :+ (+ ".. " :+ "..." :+ [])+ :+ (+ "..." :+ " ." :+ " ." :+ [])+ :+ (+ " . " :+ "..." :+ " . " :+ [])+ :+ []+++propNumberOfAtoms :: Bool+propNumberOfAtoms = Cuboid.numberOf2LayerAtoms shapes == 5*11+++targetBase, targetPyramid :: [[String]]+targetBase =+ let line = replicate 11 '.'+ in [replicate 5 line]++targetPyramid =+ map (\n -> replicate n $ replicate n '.') [5,4,3,2,1]++++newtype Brick = Brick Int deriving (Eq, Ord)++showBall :: Brick -> String+showBall (Brick n) =+ if n<10 then show n else [chr $ ord 'A' + n-10]++type Mask = Set.Set (Either Brick PackedCoords)++type Assign = ESC.Assign (Map.Map PackedCoords Brick) Mask++{-+a = sqrt 2++A^T -> B^T:+(1, 1, 0) -> ( 1, 1, 0)+(1,-1, 0) -> ( 0, 0, a)+(0, 0, a) -> (-1, 1, 0)++B = M·A++rotation around vector (1,1,0) by 90°+M =+0.5 ·+ ( 1 1 a)+ ( 1 1 -a)+ (-a a 0)++scale z such that roots vanish+S = diag (1,1,a)++shear+U = 0.5 ·+ (2 -1)+ ( 2 -1)+ ( 2)++U·S·M·S^-1·U^-1 =+ ( 1 0 1)+ ( 1 0 0)+ (-1 1 0)+-}+diagRot0 :: Num a => Coords a -> Coords a+diagRot0 (Coords z y x) = Coords (y-x) x (x+z)++{-+rotation around vector (1,-1,0) by 90°++M =+0.5 *+ ( 1 -1 a)+ (-1 1 a)+ (-a -a 0)++U·S·M·S^-1·U^-1 =+ ( 1 0 1)+ ( 0 1 1)+ (-1 -1 -1)+-}+diagRot1 :: Num a => Coords a -> Coords a+diagRot1 (Coords z y x) = Coords (-x-y-z) (y+z) (x+z)++{-+R =+ ( 0 1 0)+ (-1 0 0)+ ( 0 0 1)++U·R·U^-1 =+ ( 0 1 0)+ (-1 0 -1)+ ( 0 0 1)+-}+vertRot :: Num a => Coords a -> Coords a+vertRot (Coords z y x) = Coords z (-x-z) y++{-+Q = 0.5 ·+ (a -a 0)+ (a a 0)+ (0 0 2)++U·S·Q = 0.5 · a ·+ (1 -1 -1)+ (1 1 -1)+ (0 0 2)++With this matrix we could transform the coordinates+such that we could use 'Cuboid.allOrientations' instead of 'rotations'.+However, this would require a final division by 2.+-}++rotations :: Num a => [Coords a -> Coords a]+rotations =+ liftA2 (.)+ [id, vertRot, vertRot.vertRot, vertRot.vertRot.vertRot]+ [id, diagRot0, diagRot0.diagRot0, diagRot0.diagRot0.diagRot0,+ diagRot1, diagRot1.diagRot1.diagRot1]++transformedBrickAssign :: Size -> Brick -> [String] -> [Assign]+transformedBrickAssign size k =+ map (brickAssign size k) . concatMap (Cuboid.allPositions size) .+ Set.toList . Set.fromList .+ (\ts -> map (Cuboid.normalForm . flip map ts) rotations) .+ map (\(Coords y x z) -> Coords z y x) .+ Cuboid.coordsFrom2LayerString++brickAssign :: Size -> Brick -> [Coords Int] -> Assign+brickAssign size k ts =+ let xs = map (Cuboid.packCoords size) ts+ in ESC.assign (Map.fromList $ map (flip (,) k) xs) $+ Set.fromList $ Left k : map Right xs++allAssigns :: Size -> [Assign]+allAssigns size =+ concat $ zipWith (transformedBrickAssign size) (map Brick [0 ..]) shapes++initState ::+ Size -> [Coords Int] -> ESC.State (Map.Map PackedCoords Brick) Mask+initState size target =+ let targetSet = Set.fromList $ map (Cuboid.packCoords size) target+ keepRights =+ Set.fromList . mapMaybe (either (const Nothing) Just) . Set.toList+ in ESC.initState $+ filter (flip Set.isSubsetOf targetSet . keepRights . ESC.labeledSet) $+ allAssigns size+++format :: Size -> [Map.Map PackedCoords Brick] -> String+format size v =+ let filled = Map.unions v+ toppleSize (Coords x y z) = Coords z x y+ topple (Coords z x y) = Coords x y z+ in Cuboid.forNestedCoords+ unlines (intercalate " | ") (intercalate " ")+ (\c ->+ maybe "." showBall $+ Map.lookup (Cuboid.packCoords size $ topple c) filled)+ (toppleSize size)++printMask :: Size -> [Map.Map PackedCoords Brick] -> IO ()+printMask size =+ hPutStrLnImmediate IO.stdout . format size+++type BitMask = BitSet.Set (Bit.Sum Word16 Word64)++packMask :: (PackedCoords -> Int) -> Mask -> BitMask+packMask f =+ foldMap+ (\c ->+ BitSet.Set $+ case c of+ Left (Brick k) -> Bit.bitLeft k+ Right k -> Bit.bitRight $ f k)++packFlat :: Size -> PackedCoords -> Int+packFlat _size (PackedCoords k) = k++packPyramid :: Size -> PackedCoords -> Int+packPyramid size@(Coords sizez _ _) p =+ case Cuboid.unpackCoords size p of+ Cuboid.Coords nz y x ->+ let z = sizez-1-nz+ in div (z*(z+1)*(2*z+1)) 6 + (z+1)*y + x+++main, mainBase, mainBits :: IO ()++-- 14 min for pyramid solutions+mainBase =+ forM_ [targetPyramid, targetBase] $+ \targetString -> do+ let target = Cuboid.coordsFromString targetString+ size = Cuboid.size target+ sol = ESC.search $ initState size target+ printMask size $ head sol++-- 2 min for pyramid solutions+mainBits =+ forM_ [(targetPyramid, packPyramid), (targetBase, packFlat)] $+ \(targetString, pack) -> do+ let target = Cuboid.coordsFromString targetString+ size = Cuboid.size target+ sol = ESC.search $ fmap (packMask (pack size)) $ initState size target+ if True+ then mapM_ (printMask size) sol+ else printMask size $ head sol+ printf "total number of solutions: %d\n\n" $ length sol++main = mainBits
+ example/Mastermind.hs view
@@ -0,0 +1,160 @@+{- |+https://en.wikipedia.org/wiki/Mastermind_(board_game)++Given a list of guesses and according evaluations,+the solver computes a list of all possible codes+that match the obtained evaluations.++See also the @board-games@ package.+-}+module Main where++import qualified Math.SetCover.Exact as ESC++import qualified System.IO as IO+import System.Random (StdGen, getStdGen, randomR, )++import qualified Control.Monad.Trans.State as MS+import Control.Monad (liftM2, replicateM, when, )++import qualified Data.Set as Set; import Data.Set (Set, )+import qualified Data.Array as Array+import qualified Data.List.Match as Match+import qualified Data.List.HT as ListHT+import Data.Tuple.HT (mapSnd, )+import Data.List.HT (tails, viewL, viewR, )+import Data.Maybe (mapMaybe, )+++-- cf. htam:Combinatorics.tuples+choose :: Int -> [a] -> [[a]]+choose n xs =+ flip MS.evalStateT xs $ replicateM n $+ MS.StateT $ mapMaybe viewL . tails+++data X = Pos Int | Eval Eval Int Int | EvalRow Eval Int+ deriving (Eq, Ord, Show)++data Eval = CorrectPlace | CorrectSymbol+ deriving (Eq, Ord, Show)++type Assign a = ESC.Assign [(Int, a)] (Set X)++assignsFromGuesses ::+ (Ord a) =>+ Int -> [a] -> [([a], (Int,Int))] -> [Assign a]+assignsFromGuesses width set guesses =+ liftM2+ (\pat a ->+ let ks = map fst $ filter snd $ zip [0..] pat+ in ESC.assign (map (flip (,) a) ks) $ Set.unions $+ Set.fromList (map Pos ks) :+ zipWith+ (\row (guess,_) ->+ Set.fromList $+ let (correctlyPlaced, remGuess) =+ ListHT.partition (\(_k, (used,equ)) -> used && equ) $+ zip [0..] $ zip pat $ map (a==) guess+ in map (Eval CorrectPlace row . fst) correctlyPlaced+ +++ map (Eval CorrectSymbol row . fst)+ (Match.take+ (filter (fst . snd) remGuess)+ (filter (snd . snd) remGuess)))+ [0..] guesses)+ (tail $ replicateM width [False, True]) set+ +++ concat+ (zipWith+ (\row (_, (correctPlaces,correctSymbols)) ->+ let fill eval k =+ map (ESC.assign [] . Set.fromList . (EvalRow eval row :)) $+ choose (width - k) $+ map (Eval eval row) $ take width [0..]+ in fill CorrectPlace correctPlaces+ +++ fill CorrectSymbol correctSymbols)+ [0..] guesses)+++codeFromLabels :: [[(Int, a)]] -> [a]+codeFromLabels mxs =+ case concat mxs of+ xs -> Array.elems $ Array.array (0, length xs - 1) xs+++unique :: (Ord a) => [a] -> Bool+unique xs = Set.size (Set.fromList xs) == length xs++newGuess ::+ (Ord a) =>+ Int -> [a] -> [([a], (Int,Int))] -> MS.State StdGen (Maybe [a])+newGuess width alphabet oldGuesses = do+ n <- MS.state $ randomR (1,1000)+ return $ fmap snd $ viewR $ take n $+-- filter unique $+ map codeFromLabels $ ESC.partitions $+ assignsFromGuesses width alphabet oldGuesses++countEval :: String -> ((Int, Int), String)+countEval eval0 =+ let (correctPlaces, eval1) = ListHT.partition ('x' ==) eval0+ (correctSymbols, eval2) = ListHT.partition ('o' ==) eval1+ in ((length correctPlaces, length correctSymbols), eval2)++{- |+In every round the computer player selects randomly one of the first 1000 codes+that are coherent with the known evaluations.+This strategy prevents stupid guesses like "aaaaa",+but it does not minimize the number of guesses.+When the game approaches the end+there is often only one unknown letter left+and the algorithm makes a guess for ruling out every single candidate.+It would be more efficient to use non-coherent guesses in this situation+in order to rule out a whole bunch of candidates at once.+-}+interaction :: Int -> [Char] -> IO ()+interaction width alphabet =+ let go guesses g0 =+ case MS.runState (newGuess width alphabet guesses) g0 of+ (Nothing, _) -> putStrLn "contradicting evaluations"+ (Just attempt, g1) -> do+ putStr $ show attempt ++ " "+ IO.hFlush IO.stdout+ eval0 <- getLine+ let ((numPlaces, numSymbols), evalRem) = countEval eval0+ when (not $ null evalRem) (putStrLn $ "ignoring: " ++ evalRem)+ if numPlaces >= width+ then putStrLn "Code found!"+ else go ((attempt, (numPlaces, numSymbols)) : guesses) g1+ in go [] =<< getStdGen++testGuesses :: [(String, (Int, Int))]+testGuesses =+ map (mapSnd (fst . countEval)) $+ ("aaaayw", "x") :+ ("bbbdcw", "") :+ ("eefeym", "oo") :+ ("iuzamf", "oo") :+ ("gvarfe", "ooo") :+ ("paqfes", "xxo") :+ ("vamsej", "ooxx") :+ ("amgses", "ooox") :+ ("majgep", "xxx") :+ []++testSolve :: IO ()+testSolve =+ mapM_ (print . codeFromLabels) $ ESC.partitions $+ assignsFromGuesses 6 ['a'..'z'] testGuesses+++main :: IO ()+main = do+ let n = 5+ putStrLn $+ "Come up with a word consisting of " ++ show n +++ " letters and evaluate my guesses."+ putStrLn "Enter 'x's for correct places and 'o's for correct symbols in any order."+ interaction n ['a'..'z']
+ example/Nonogram.hs view
@@ -0,0 +1,237 @@+{-+* <https://en.wikipedia.org/wiki/Nonogram>+* <https://de.wikipedia.org/wiki/Datei:Paint_by_numbers_Animation.gif>++The solver works but is pretty slow.+I assume that a faster solution can be achieved+if we succeed in splitting bricks into single squares.+-}+module Main where++import qualified Math.SetCover.Exact as ESC++import Control.Monad (liftM2)++import qualified Data.Set as Set+import qualified Data.List.Match as Match+import qualified Data.List.HT as ListHT+import qualified Data.List as List+import Data.Foldable (foldMap)+import Data.Char (isSpace)+import Data.Set (Set)+++data X = X Orientation Int Item+ deriving (Eq, Ord, Show)++data Item = Brick Int | Position Int | Reserve Int Int+ deriving (Eq, Ord, Show)++data Orientation = Horizontal | Vertical+ deriving (Eq, Ord, Show)+++type Assign = ESC.Assign (Set (Int, Int)) (Set X)++assignsFromBrick ::+ Orientation -> Int -> Int ->+ Maybe Int -> Int -> Maybe Int -> Int -> [Assign]+assignsFromBrick orient width line prevBrick thisBrick maybeThisBrick size =+ flip map [0 .. width-size] $ \col ->+ ESC.assign+ (case orient of+ Horizontal -> Set.fromList $ take size $ map ((,) line) [col ..]+ Vertical -> Set.empty) $+ Set.fromList $ map (X orient line) $+ Brick thisBrick+ :+ (map Position $ take size [col ..])+ +++ maybe []+ (\brick -> map (Reserve brick) [col .. pred width])+ prevBrick+ +++ maybe []+ (\brick -> map (Reserve brick) [0 .. min (pred width) (col+size)])+ maybeThisBrick++assignsFromLine ::+ Orientation -> Int -> Int -> [Int] -> [Assign]+assignsFromLine orient width line xs =+-- let bricks = Match.take (ListHT.laxTail xs) [0..]+ let bricks = Match.take (drop 1 xs) [0..]+ in concat+ (List.zipWith4+ (assignsFromBrick orient width line)+ (Nothing : map Just bricks) [0..] (map Just bricks ++ [Nothing]) xs)+ +++ liftM2+ (\brick c ->+ ESC.assign Set.empty $ Set.singleton $+ X orient line (Reserve brick c))+ bricks [0 .. width-1]++assignsFromLines :: [[Int]] -> [[Int]] -> [Assign]+assignsFromLines rows columns =+ concat (zipWith (assignsFromLine Horizontal (length columns)) [0..] rows)+ +++ concat (zipWith (assignsFromLine Vertical (length rows)) [0..] columns)+ +++ liftM2+ (\r c ->+ ESC.assign Set.empty $+ Set.fromList+ [X Horizontal r (Position c),+ X Vertical c (Position r)])+ (Match.take rows [0..])+ (Match.take columns [0..])++decode :: [[Int]] -> [[Int]] -> [Set (Int, Int)]+decode rows columns =+ map Set.unions $ ESC.partitions $ assignsFromLines rows columns++encodeLines :: [String] -> [[Int]]+encodeLines =+ map (filter (>0) . map length . ListHT.chop isSpace)++encodeStrings :: [String] -> ([[Int]], [[Int]])+encodeStrings xs =+ (encodeLines xs, encodeLines $ List.transpose xs)+++testRows, testColumns :: [[Int]]+testRows =+ [1,1] :+ [1] :+ [1,1] :+ []++testColumns =+ [1,1] :+ [1] :+ [1,1] :+ []++testRhombus, testCircle, testP, testBigCircle :: [String]+testRhombus =+ " X " :+ " X X " :+ "X X" :+ " X X " :+ " X " :+ []++testCircle =+ " XXX " :+ "XX XX" :+ "X X" :+ "XX XX" :+ " XXX " :+ []++testP =+ "XXXX " :+ "XXXXXX" :+ "XX XX" :+ "XX XX" :+ "XXXXXX" :+ "XXXX " :+ "XX " :+ "XX " :+ "XX " :+ []++-- cannot solve this one within 30 minutes+testBigCircle =+ " XXXXX " :+ " XXX XXX " :+ " X X " :+ "XX XX" :+ "X X" :+ "X X" :+ "X X" :+ "XX XX" :+ " X X " :+ " XXX XXX " :+ " XXXXX " :+ []++soccerRows, soccerColumns :: [[Int]]+soccerRows =+ [3] :+ [5] :+ [3, 1] :+ [2, 1] :+ [3, 3, 4] :+ [2, 2, 7] :+ [6, 1, 1] :+ [4, 2, 2] :+ [1, 1] :+ [3, 1] :+ [6] :+ [2, 7] :+ [6, 3, 1] :+ [1, 2, 2, 1, 1] :+ [4, 1, 1, 3] :+ [4, 2, 2] :+ [3, 3, 1] :+ [3, 3] :+ [3] :+ [2, 1] :+ []++soccerColumns =+ [2] :+ [1, 2] :+ [2, 3] :+ [2, 3] :+ [3, 1, 1] :+ [2, 1, 1] :+ [1, 1, 1, 2, 2] :+ [1, 1, 3, 1, 3] :+ [2, 6, 4] :+ [3, 3, 9, 1] :+ [5, 3, 2] :+ [3, 1, 2, 2] :+ [2, 1, 7] :+ [3, 3, 2] :+ [2, 4] :+ [2, 1, 2] :+ [2, 2, 1] :+ [2, 2] :+ [1] :+ [1] :+ []+++format :: Int -> Int -> Set (Int, Int) -> String+format rows columns set =+ unlines $+ ListHT.outerProduct+ (\r c -> if Set.member (r,c) set then 'X' else '.')+ (take rows [0..])+ (take columns [0..])++testSimple :: IO ()+testSimple = do+ let assigns = assignsFromLines testRows testColumns+ mapM_ (print . ESC.labeledSet) assigns+ putStrLn "set union:"+ print $ foldMap ESC.labeledSet assigns+ mapM_+ (putStrLn .+ format (length testRows) (length testColumns) .+ Set.unions) $+ ESC.partitions assigns++testImage :: IO ()+testImage =+ let (rows, columns) = encodeStrings testP+ in mapM_ (putStrLn . format (length rows) (length columns)) $+ decode rows columns++-- too slow to complete+main :: IO ()+main =+ mapM_ (putStrLn . format (length soccerRows) (length soccerColumns)) $+ decode soccerRows soccerColumns
+ example/Pangram.hs view
@@ -0,0 +1,63 @@+{- |+Choose a set of words so that each alphabet is contained exactly once.++<https://en.wikipedia.org/wiki/Pangram>++This example illustrates the mose.++Contributed by Takayuki Muranushi.+-}+module Main where++import qualified Math.SetCover.Exact as ESC+import qualified Data.Set as Set+import Data.Set (Set, )+++{- |+Define the customized 'Assign' type synonym,+that contains the problem-specific label type+and the representation of the set chosen for this problem.+-}+type Assign = ESC.Assign String (Set Char)++{- |+Helper function that creates a value of type 'Assign'.+-}+assign :: String -> Assign+assign str = ESC.assign str $ Set.fromList str++{- |+List of candidate subsets.+The set to be covered is implicitly given as the union of all assigns.+-}+assigns :: [Assign]+assigns = map assign+ ["a", "quick", "brown", "fox", "jumps", "over", "the", "lazy", "dog",+ "cwm", "fjord", "bank", "glyphs", "vext", "quiz", "veg", "balks", "nth", "pyx"]++{- |+Pretty printer function for a solution.+-}+pprint :: [String] -> IO ()+pprint strs = putStrLn $ unwords strs++{- |+The function @partitions :: [Assign] -> [[label]]@+takes the list of the subsets, and returns all solutions.+-}+main :: IO ()+main = mapM_ pprint $ ESC.partitions assigns+++{-+$ runhaskell example/Pangram.hs+vext glyphs bank fjord quiz cwm+pyx nth veg balks fjord quiz cwm++Note that 'partitions' searches for the exact subsets,+while the famous "quick brown fox ..." sentence contains many duplicate alphabets.++Prelude> sort "a quick brown fox jumps over the lazy dog"+" aabcdeefghijklmnoooopqrrstuuvwxyz"+-}
− example/Parallelism.hs
@@ -1,34 +0,0 @@-module Parallelism where--import qualified Control.Concurrent.MVar as MVar-import Control.Concurrent (forkIO, getNumCapabilities)-import Control.Exception (finally)--import Control.Functor.HT (void)-import Data.Foldable (forM_)---schedule :: [IO ()] -> IO ()-schedule acts = do- n <- getNumCapabilities- let (start, queue) = splitAt n acts- mvar <- MVar.newEmptyMVar- let newJob act = void $ forkIO $ finally act $ MVar.putMVar mvar ()- mapM_ newJob start- let loop [] = return ()- loop (act:remain) = do- MVar.takeMVar mvar- newJob act- loop remain- loop queue- forM_ start $ const $ MVar.takeMVar mvar--parallel :: [IO ()] -> IO ()-parallel acts =- mapM_ MVar.takeMVar =<< mapM fork acts--fork :: IO () -> IO (MVar.MVar ())-fork act = do- mvar <- MVar.newEmptyMVar- void $ forkIO $ finally act $ MVar.putMVar mvar ()- return mvar
example/Queen8.hs view
@@ -1,3 +1,13 @@+{- |+Place 8 queens on a chessboard+such that no queen threatens another one.++<http://en.wikipedia.org/wiki/Eight_queens_puzzle>++The solutions could be found pretty simply by an exhaustive search.+Nonetheless I like to use this as a simple example+for demonstrating how to use the @set-cover@ library.+-} module Main where import qualified Math.SetCover.Exact as ESC@@ -25,11 +35,36 @@ type Assign = ESC.Assign (Maybe (Int, Int)) (Set X) +{- |+'assign' represents a queen at a particular position.++Every queen blocks a row, a column and two diagonals.+Conversely, every row and every column must contain a queen.+This is expressed by the fact that the set partition must contain every element+that is contained in any of the sets we pass to ESC.partitions.+This way we ensure that exactly 8 queens are placed.++Since the search algorithm treats every element the same way,+the generic algorithm chooses in every step+a row, a column or a diagonal+where there the least possibilities to place a queen.+-} assign :: Int -> Int -> Assign assign i j = ESC.assign (Just (i,j)) $ Set.fromList [Row i, Column j, Diag (i+j), Gaid (i-j)] +{- |+'fill' represents a diagonal without a queen.++The rationale is this:+Every queen blocks a row and a column+and conversely in each row and in each column there is a queen.+This is not true for diagonals.+There are 15 diagonals in up-right direction, but only 8 queens.+Thus we fill empty diagonals with auxiliary singleton sets,+where each such set addresses one diagonal.+-} fill :: X -> Assign fill = ESC.assign Nothing . Set.singleton
example/Soma.hs view
@@ -1,3 +1,13 @@+{-+<https://en.wikipedia.org/wiki/Soma_cube>++Algorithm by Helmut Podhaisky:+It is a depth-first search where in each stage we choose a position+where as few as possible bricks match+or a brick with as few as possible admissible positions. (see 'ew')+The function 'ESC.step' is a slightly more efficient version+that permanently manages the set of available bricks.+-} module Main where import qualified Math.SetCover.Exact as ESC
example/Sudoku.hs view
@@ -1,3 +1,6 @@+{-+<https://en.wikipedia.org/wiki/Sudoku>+-} module Main where import qualified Math.SetCover.BitSet as BitSet
example/TetrisCube.hs view
@@ -1,4 +1,10 @@ {-+This puzzle is like Soma cube but with different bricks in a 4x4x4 box.+It is even more similar to the+<https://en.wikipedia.org/wiki/Bedlam_cube>+but the set of bricks differ.++ One solution: 0 0 0 1 | 0 7 1 1 | 0 4 1 5 | 4 4 1 2 7 B 0 8 | 7 7 5 5 | 7 3 6 5 | 4 3 2 2@@ -12,12 +18,6 @@ [33m0[m [34m2[m [34m2[m [34m2[m | [31m3[m [33m3[m [34m2[m [34m1[m | [31m3[m [31m3[m [31m3[m [31m2[m | [31m1[m [31m3[m [31m2[m [31m2[m -Algorithm by Helmut Podhaisky:-It is a depth-first search where in each stage we choose a position-where as few as possible bricks match. (see 'ew')-The function 'ESC.step' is a slightly more efficient version-that permanently manages the set of available bricks.- dist/build/tetris-cube/tetris-cube +RTS -N4 -M500m -} module Main where@@ -28,7 +28,9 @@ import qualified Math.SetCover.Cuboid as Cuboid import Math.SetCover.Cuboid (PackedCoords(PackedCoords), Coords, Size) -import Parallelism (schedule)+import qualified Control.Concurrent.PooledIO.Independent as Pool+-- alternative: ansi-terminal+import qualified Graphics.Ascii.Haha.Terminal as ANSI import qualified Data.Map as Map import qualified Data.Set as Set@@ -168,16 +170,20 @@ writeMasks = writeFile "tetriscube.txt" $ show allMasks +ansiColor :: ANSI.Color -> String+ansiColor c = ANSI.clr (ANSI.fg c)+ formatBrickId :: BrickId -> String formatBrickId (color, num) =- case color of- Red -> "\ESC[31m"- Yellow -> "\ESC[33m"- Blue -> "\ESC[34m"+ ansiColor+ (case color of+ Red -> ANSI.Red+ Yellow -> ANSI.Yellow+ Blue -> ANSI.Blue) ++ show num ++- "\ESC[m"+ ansiColor ANSI.Reset format :: [Map.Map PackedCoords BrickId] -> String@@ -232,7 +238,7 @@ print $ length lsg mainParallel =- schedule $ map snd $+ Pool.run $ map snd $ sortBy (flip Match.compareLength `on` fst) $ let attempts = ESC.step $ ESC.initState $ map (fmap packMask) allAssigns
set-cover.cabal view
@@ -1,25 +1,28 @@ Name: set-cover-Version: 0.0.4+Version: 0.0.5 License: BSD3 License-File: LICENSE Author: Henning Thielemann, Helmut Podhaisky Maintainer: Henning Thielemann <haskell@henning-thielemann.de>-Homepage: http://code.haskell.org/~thielema/set-cover/+Homepage: http://hub.darcs.net/thielema/set-cover/ Category: Math, Algorithms Synopsis: Solve exact set cover problems like Sudoku, 8 Queens, Soma Cube, Tetris Cube Description: Solver for exact set cover problems. Included examples:- Sudoku, 8 Queens,+ Sudoku, Nonogram, 8 Queens, Domino tiling, Mastermind, Soma Cube, Tetris Cube, Cube of L's, Logika's Baumeister puzzle.- Generic algorithm allows to choose between+ The generic algorithm allows to choose between slow but flexible @Set@ from @containers@ package and fast but cumbersome bitvectors. .+ For getting familiar with the package+ I propose to study the Queen8 example along with "Math.SetCover.Exact".+ . Build examples with @cabal install -fbuildExamples@. . The package needs only Haskell 98.-Tested-With: GHC==7.4.2, GHC==7.6.3+Tested-With: GHC==7.4.2, GHC==7.6.3, GHC==7.8.2 Cabal-Version: >=1.8 Build-Type: Simple @@ -28,13 +31,13 @@ default: False Source-Repository this- Tag: 0.0.4+ Tag: 0.0.5 Type: darcs- Location: http://code.haskell.org/~thielema/set-cover/+ Location: http://hub.darcs.net/thielema/set-cover/ Source-Repository head Type: darcs- Location: http://code.haskell.org/~thielema/set-cover/+ Location: http://hub.darcs.net/thielema/set-cover/ Library Build-Depends:@@ -54,6 +57,8 @@ Executable tetris-cube If flag(buildExamples) Build-Depends:+ haha >=0.3.1 && <0.4,+ pooled-io >=0.0 && <0.1, set-cover, containers, utility-ht,@@ -64,7 +69,6 @@ Hs-Source-Dirs: example Main-Is: TetrisCube.hs Other-Modules:- Parallelism Utility Executable soma-cube@@ -85,7 +89,7 @@ Build-Depends: set-cover, containers,- array >=0.1 && <0.5,+ array >=0.1 && <0.6, utility-ht, base Else@@ -99,7 +103,7 @@ Build-Depends: set-cover, containers,- array >=0.1 && <0.5,+ array >=0.1 && <0.6, utility-ht, base Else@@ -112,6 +116,7 @@ If flag(buildExamples) Build-Depends: set-cover,+ pooled-io >=0.0 && <0.1, containers, utility-ht, base@@ -121,7 +126,6 @@ Hs-Source-Dirs: example Main-Is: LCube.hs Other-Modules:- Parallelism Utility Executable baumeister@@ -137,14 +141,28 @@ Hs-Source-Dirs: example Main-Is: Baumeister.hs Other-Modules:- Parallelism Utility +Executable lonpos-pyramid+ If flag(buildExamples)+ Build-Depends:+ set-cover,+ containers,+ utility-ht,+ base+ Else+ Buildable: False+ GHC-Options: -Wall -rtsopts -threaded+ Hs-Source-Dirs: example+ Main-Is: LonposPyramid.hs+ Other-Modules:+ Utility+ Executable alphametics If flag(buildExamples) Build-Depends: set-cover,- transformers,+ transformers >=0.2 && <0.5, containers, utility-ht, base@@ -158,6 +176,7 @@ If flag(buildExamples) Build-Depends: set-cover,+ unicode >=0.0 && <0.1, containers, utility-ht, base@@ -166,3 +185,44 @@ GHC-Options: -Wall -rtsopts -threaded Hs-Source-Dirs: example Main-Is: Domino.hs++Executable nonogram+ If flag(buildExamples)+ Build-Depends:+ set-cover,+ containers,+ utility-ht,+ base+ Else+ Buildable: False+ GHC-Options: -Wall+ Hs-Source-Dirs: example+ Main-Is: Nonogram.hs++Executable mastermind+ If flag(buildExamples)+ Build-Depends:+ set-cover,+ random >=1.0 && <1.1,+ transformers >=0.2 && <0.5,+ containers,+ array >=0.1 && <0.6,+ utility-ht,+ base+ Else+ Buildable: False+ GHC-Options: -Wall+ Hs-Source-Dirs: example+ Main-Is: Mastermind.hs++Executable pangram+ If flag(buildExamples)+ Build-Depends:+ set-cover,+ containers,+ base+ Else+ Buildable: False+ GHC-Options: -Wall+ Hs-Source-Dirs: example+ Main-Is: Pangram.hs
src/Math/SetCover/Exact.hs view
@@ -1,4 +1,13 @@-module Math.SetCover.Exact where+{- |+This module provides a solver for exact set cover problems.+<http://en.wikipedia.org/wiki/Exact_cover>+-}+module Math.SetCover.Exact (+ Assign(..), assign,+ partitions, search, step,+ State(..), initState, updateState,+ Set(..),+ ) where import qualified Math.SetCover.BitMap as BitMap import qualified Math.SetCover.BitSet as BitSet@@ -13,6 +22,11 @@ import Prelude hiding (null) +{- |+This class provides all operations needed for the set cover algorithm.+It allows to use the same algorithm+both for @containers@' 'Set' and for sets represented by bit vectors.+-} class Set set where null :: set -> Bool disjoint :: set -> set -> Bool@@ -42,16 +56,44 @@ in filter (not . BitSet.disjoint singleMin . labeledSet) available +{- |+'Assign' allows to associate a set with a label.+If a particular set is chosen for a set cover,+then its label is included in the output of 'partitions'.++I have decided to separate sets and labels this way,+since it is the easiest way to assign a meaning to a set.+If you really want to know the sets in a partition,+then you can fill the 'label' field with the set.+-} data Assign label set = Assign { label :: label, labeledSet :: set } +{- |+Construction of a labeled set.+-} assign :: label -> set -> Assign label set assign = Assign +{- |+The state of the search.+@usedSubsets@ contains the partial partition built up so far.+@availableSubsets@ is the list of sets we can still try to put into a partition.+The lists @usedSubsets@ and @availableSubsets@ are disjoint,+but their union is not necessarily equal to the list of initially given sets.+There are sets not contained in the partial partition+that overlap with the partial partition.+Those sets are not available for extending the partition.++@freeElements@ contains the elements that are not covered+by the partial partition in @usedSubsets@.+@unions usedSubset@ and @freeElements@ are disjoint+and their union is the set of all elements.+-} data State label set = State { availableSubsets :: [Assign label set],@@ -86,6 +128,33 @@ } +{- |+This is the key of the search algorithm.+The search algorithm tries to build partitions+by adding sets to a partition list successively.+A step starts on a partial partition+and looks for new sets that could be added.+The goal is to avoid to check a set again down in a search branch+and to quickly determine search directions that lead to a dead end.+To this end a search step selects a certain set element+and tries all sets that contain that element+and that do not overlap with the partial partition.+Practically, 'step' selects an element with the minimal number+of non-overlapping sets it is contained in.+If this number is zero, then the search can be aborted in this branch.++Most oftenly the power of the algorithm+originates from the formulation of a problem as a set-cover problem+and from the equal treatment of all elements.+E.g. in the Soma cube example+the algorithm chooses whether to do a case analysis on all bricks+that cover a certain position,+or to do a case analysis on all positions that are possible for a certain brick.++The algorithm might not be extraordinarily fast,+but in all cases it consumes only little memory+since it only has to maintain the current state of search.+-} {-# INLINE step #-} step :: Set set => State label set -> [State label set] step s =@@ -95,6 +164,13 @@ map (flip updateState s) $ minimize (freeElements s) (availableSubsets s) +{- |+Start the search for partitions on a certain search state.+This can be an 'initState' or the result of performing some search 'step's.+In the examples we use this for parallelization:+We perform some steps manually+and then run 'search' on the results in parallel.+-} {-# INLINE search #-} search :: Set set => State label set -> [[label]] search s =@@ -102,6 +178,22 @@ then [map label $ usedSubsets s] else step s >>= search +{- |+@partitions [assign '0' set0, assign '1' set1, assign '2' set2]@+computes @unions [set0, set1, set2]@ and tries to partition the union set+using the sets @set0@, @set1@, @set2@.+'partitions' returns all such partitions.+If a set is chosen for a partition,+then its label is included in the output.+E.g. @set0 = Set.fromList [0,1], set1 = Set.fromList [2], set2 = Set.fromList [0,1,2]@,+then 'partitions' returns @["01", "2"]@.++The order of partitions and the order of labels+depends on the implementation+and you must not rely on them.++You may use 'listToMaybe' in order to select only the first solution.+-} {-# INLINE partitions #-} partitions :: Set set => [Assign label set] -> [[label]] partitions = search . initState