diff --git a/example/Alphametics.hs b/example/Alphametics.hs --- a/example/Alphametics.hs +++ b/example/Alphametics.hs @@ -1,4 +1,6 @@ {- | + + Solve the following verbal arithmetics puzzle: > SEND diff --git a/example/Baumeister.hs b/example/Baumeister.hs --- a/example/Baumeister.hs +++ b/example/Baumeister.hs @@ -1,6 +1,9 @@ {- | Logika's Baumeister puzzle +Like Soma cube but with different bricks +and non-box shapes to fill. + -} module Main where diff --git a/example/Domino.hs b/example/Domino.hs --- a/example/Domino.hs +++ b/example/Domino.hs @@ -1,33 +1,41 @@ -{- +{- | +Given a field of numbers +find a matching arrangement of Domino bricks. + + + + 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]@ diff --git a/example/LCube.hs b/example/LCube.hs --- a/example/LCube.hs +++ b/example/LCube.hs @@ -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) $ diff --git a/example/LonposPyramid.hs b/example/LonposPyramid.hs new file mode 100644 --- /dev/null +++ b/example/LonposPyramid.hs @@ -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. + + +-} +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 diff --git a/example/Mastermind.hs b/example/Mastermind.hs new file mode 100644 --- /dev/null +++ b/example/Mastermind.hs @@ -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'] diff --git a/example/Nonogram.hs b/example/Nonogram.hs new file mode 100644 --- /dev/null +++ b/example/Nonogram.hs @@ -0,0 +1,237 @@ +{- +* +* + +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 diff --git a/example/Pangram.hs b/example/Pangram.hs new file mode 100644 --- /dev/null +++ b/example/Pangram.hs @@ -0,0 +1,63 @@ +{- | +Choose a set of words so that each alphabet is contained exactly once. + + + +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" +-} diff --git a/example/Parallelism.hs b/example/Parallelism.hs deleted file mode 100644 --- a/example/Parallelism.hs +++ /dev/null @@ -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 diff --git a/example/Queen8.hs b/example/Queen8.hs --- a/example/Queen8.hs +++ b/example/Queen8.hs @@ -1,3 +1,13 @@ +{- | +Place 8 queens on a chessboard +such that no queen threatens another one. + + + +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 diff --git a/example/Soma.hs b/example/Soma.hs --- a/example/Soma.hs +++ b/example/Soma.hs @@ -1,3 +1,13 @@ +{- + + +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 diff --git a/example/Sudoku.hs b/example/Sudoku.hs --- a/example/Sudoku.hs +++ b/example/Sudoku.hs @@ -1,3 +1,6 @@ +{- + +-} module Main where import qualified Math.SetCover.BitSet as BitSet diff --git a/example/TetrisCube.hs b/example/TetrisCube.hs --- a/example/TetrisCube.hs +++ b/example/TetrisCube.hs @@ -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 + +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 @@ 0 2 2 2 | 3 3 2 1 | 3 3 3 2 | 1 3 2 2 -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 diff --git a/set-cover.cabal b/set-cover.cabal --- a/set-cover.cabal +++ b/set-cover.cabal @@ -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 -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 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 @@ -1,4 +1,13 @@ -module Math.SetCover.Exact where +{- | +This module provides a solver for exact set cover problems. + +-} +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