diff --git a/example/Alphametics.hs b/example/Alphametics.hs --- a/example/Alphametics.hs +++ b/example/Alphametics.hs @@ -17,7 +17,9 @@ import qualified Data.Map as Map import qualified Data.Set as Set +import qualified Data.NonEmpty as NonEmpty import qualified Data.List.HT as ListHT +import Data.NonEmpty ((!:)) import Data.Maybe (catMaybes) import Data.Map (Map) import Data.Set (Set) @@ -50,10 +52,8 @@ let leadingVars = Set.fromList $ map head rows (var, poss) <- Map.toList $ histogram rows (digit, otherDigits) <- - (if Set.member var leadingVars - then tail - else id) $ - ListHT.removeEach [0..9] + (if Set.member var leadingVars then NonEmpty.tail else NonEmpty.flatten) $ + NonEmpty.removeEach (0!:[1..9]) return $ assign (Just (var, digit)) $ [Variable var, Digit digit] ++ liftM2 diff --git a/example/Baumeister.hs b/example/Baumeister.hs --- a/example/Baumeister.hs +++ b/example/Baumeister.hs @@ -179,25 +179,23 @@ allAssigns size = concat $ zipWith (transformedBrickAssign size) (map Brick [0 ..]) shapes -initState :: - Size -> [Coords Int] -> ESC.State (Map.Map PackedCoords Brick) Mask -initState size target = +fittingAssigns :: Size -> [Coords Int] -> [Assign] +fittingAssigns 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) $ + in filter (flip Set.isSubsetOf targetSet . keepRights . ESC.labeledSet) $ allAssigns size format :: Size -> [Map.Map PackedCoords Brick] -> String format size v = - let wuerfelx = Map.unions v + let filled = Map.unions v in Cuboid.forNestedCoords unlines (intercalate " | ") (intercalate " ") (\c -> maybe "." (\(Brick n) -> show n) $ - Map.lookup (Cuboid.packCoords size c) wuerfelx) + Map.lookup (Cuboid.packCoords size c) filled) size printMask :: Size -> [Map.Map PackedCoords Brick] -> IO () @@ -214,10 +212,10 @@ \targetString -> do let target = Cuboid.coordsFromString targetString size = Cuboid.size target - lsg = ESC.search $ initState size target + sol = ESC.partitions $ fittingAssigns size target if False - then mapM_ (printMask size) lsg - else printMask size $ head lsg - printf "total number of solutions: %d\n\n" $ length lsg + then mapM_ (printMask size) sol + else printMask size $ head sol + printf "total number of solutions: %d\n\n" $ length sol main = mainBase diff --git a/example/LonposPyramid.hs b/example/LonposPyramid.hs --- a/example/LonposPyramid.hs +++ b/example/LonposPyramid.hs @@ -135,11 +135,11 @@ (1,-1, 0) -> ( 0, 0, a) (0, 0, a) -> (-1, 1, 0) -B = M·A +B = M·A -rotation around vector (1,1,0) by 90° +rotation around vector (1,1,0) by 90° M = -0.5 · +0.5 · ( 1 1 a) ( 1 1 -a) (-a a 0) @@ -148,12 +148,12 @@ S = diag (1,1,a) shear -U = 0.5 · +U = 0.5 · (2 -1) ( 2 -1) ( 2) -U·S·M·S^-1·U^-1 = +U·S·M·S^-1·U^-1 = ( 1 0 1) ( 1 0 0) (-1 1 0) @@ -162,7 +162,7 @@ diagRot0 (Coords z y x) = Coords (y-x) x (x+z) {- -rotation around vector (1,-1,0) by 90° +rotation around vector (1,-1,0) by 90° M = 0.5 * @@ -170,7 +170,7 @@ (-1 1 a) (-a -a 0) -U·S·M·S^-1·U^-1 = +U·S·M·S^-1·U^-1 = ( 1 0 1) ( 0 1 1) (-1 -1 -1) @@ -184,7 +184,7 @@ (-1 0 0) ( 0 0 1) -U·R·U^-1 = +U·R·U^-1 = ( 0 1 0) (-1 0 -1) ( 0 0 1) @@ -193,12 +193,12 @@ vertRot (Coords z y x) = Coords z (-x-z) y {- -Q = 0.5 · +Q = 0.5 · (a -a 0) (a a 0) (0 0 2) -U·S·Q = 0.5 · a · +U·S·Q = 0.5 · a · (1 -1 -1) (1 1 -1) (0 0 2) @@ -233,14 +233,12 @@ allAssigns size = concat $ zipWith (transformedBrickAssign size) (map Brick [0 ..]) shapes -initState :: - Size -> [Coords Int] -> ESC.State (Map.Map PackedCoords Brick) Mask -initState size target = +fittingAssigns :: Size -> [Coords Int] -> [Assign] +fittingAssigns 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) $ + in filter (flip Set.isSubsetOf targetSet . keepRights . ESC.labeledSet) $ allAssigns size @@ -291,7 +289,7 @@ \targetString -> do let target = Cuboid.coordsFromString targetString size = Cuboid.size target - sol = ESC.search $ initState size target + sol = ESC.partitions $ fittingAssigns size target printMask size $ head sol -- 2 min for pyramid solutions @@ -300,7 +298,9 @@ \(targetString, pack) -> do let target = Cuboid.coordsFromString targetString size = Cuboid.size target - sol = ESC.search $ fmap (packMask (pack size)) $ initState size target + sol = + ESC.partitions $ map (fmap (packMask (pack size))) $ + fittingAssigns size target if True then mapM_ (printMask size) sol else printMask size $ head sol diff --git a/example/Mastermind.hs b/example/Mastermind.hs --- a/example/Mastermind.hs +++ b/example/Mastermind.hs @@ -97,11 +97,10 @@ 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) +countEval :: MS.State String (Int, Int) +countEval = + let count c = fmap length $ MS.state $ ListHT.partition (c==) + in liftM2 (,) (count 'x') (count 'o') {- | In every round the computer player selects randomly one of the first 1000 codes @@ -123,7 +122,8 @@ putStr $ show attempt ++ " " IO.hFlush IO.stdout eval0 <- getLine - let ((numPlaces, numSymbols), evalRem) = countEval eval0 + let ((numPlaces, numSymbols), evalRem) = + MS.runState countEval eval0 when (not $ null evalRem) (putStrLn $ "ignoring: " ++ evalRem) if numPlaces >= width then putStrLn "Code found!" @@ -132,7 +132,7 @@ testGuesses :: [(String, (Int, Int))] testGuesses = - map (mapSnd (fst . countEval)) $ + map (mapSnd (MS.evalState countEval)) $ ("aaaayw", "x") : ("bbbdcw", "") : ("eefeym", "oo") : diff --git a/example/Nonogram.hs b/example/Nonogram.hs --- a/example/Nonogram.hs +++ b/example/Nonogram.hs @@ -2,206 +2,36 @@ * * -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. +The solver works but is pretty slow +although the Combinatoric set formulation minimizes the need to guess. -} module Main where -import qualified Math.SetCover.Exact as ESC +import qualified Nonogram.Example as Example +import qualified Nonogram.Encoding.Combinatoric as Combinatoric +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 Control.Monad (liftM2) +import qualified Math.SetCover.Exact as ESC -import qualified Data.Set as Set -import qualified Data.List.Match as Match +import qualified Data.Map as Map; import Data.Map (Map) +import qualified Data.Set as Set; import Data.Set (Set) +import qualified Data.NonEmpty as NonEmpty 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) +import Data.NonEmpty ((!:)) -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] : - [] + 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 format :: Int -> Int -> Set (Int, Int) -> String @@ -212,26 +42,53 @@ (take rows [0..]) (take columns [0..]) -testSimple :: IO () -testSimple = do - let assigns = assignsFromLines testRows testColumns +formatBW :: Int -> Int -> Map (Int, Int) Color -> String +formatBW rows columns set = + unlines $ + ListHT.outerProduct + (\r c -> + case Map.lookup (r,c) set of + Nothing -> '_' + Just Black -> 'X' + Just White -> '.') + (take rows [0..]) + (take columns [0..]) + +besidesMany :: Int -> [String] -> String +besidesMany space = + let besides blockL blockR = + let width = NonEmpty.maximum (0 !: map length blockL) + space + in zipWith (\l r -> ListHT.padRight ' ' width l ++ r) blockL blockR + in unlines . foldr1 besides . map lines + +testSimple :: ([[Int]], [[Int]]) -> IO () +testSimple (rows, columns) = do + let assigns = Naive.assigns rows columns mapM_ (print . ESC.labeledSet) assigns putStrLn "set union:" print $ foldMap ESC.labeledSet assigns - mapM_ - (putStrLn . - format (length testRows) (length testColumns) . - Set.unions) $ + mapM_ (putStrLn . format (length rows) (length columns) . Set.unions) $ ESC.partitions assigns +decodeImage :: ([[Int]], [[Int]]) -> IO () +decodeImage (rows, columns) = + mapM_ (putStrLn . format (length rows) (length columns)) $ + decode rows columns + testImage :: IO () -testImage = - let (rows, columns) = encodeStrings testP - in mapM_ (putStrLn . format (length rows) (length columns)) $ - decode rows columns +testImage = decodeImage $ Example.encodeStrings Example.letterP --- too slow to complete +evolve :: ([[Int]], [[Int]]) -> IO () +evolve (rows, columns) = + let formatIntermediate state = + (show $ length $ ESC.availableSubsets state) ++ '\n' : + (formatBW (length rows) (length columns) . + Map.unionsWith (error "conflicting colors") . + map ESC.label . 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.assignsBW rows columns] + main :: IO () -main = - mapM_ (putStrLn . format (length soccerRows) (length soccerColumns)) $ - decode soccerRows soccerColumns +main = evolve Example.soccerEnc diff --git a/example/Nonogram/Base.hs b/example/Nonogram/Base.hs new file mode 100644 --- /dev/null +++ b/example/Nonogram/Base.hs @@ -0,0 +1,71 @@ +module Nonogram.Base where + +import qualified Math.SetCover.Exact as ESC + +import Control.Monad (liftM3) + +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.Monoid.HT as Mn +import Data.Monoid (Monoid, mempty) + + +{- | +Identifies one row or column by its orientation and its position. +-} +data Strip item = Strip Orientation Int item + deriving (Eq, Ord, Show) + +{- | +A brick is a horizontal or vertical stripe of adjacent black squares +delimited by white squares. +We number them per line or column. +-} +newtype BrickId = BrickId Int + deriving (Eq, Ord, Show) + +instance Enum BrickId where + fromEnum (BrickId n) = n + toEnum = BrickId + +data Orientation = Horizontal | Vertical + deriving (Eq, Ord, Show) + +data Color = White | Black + deriving (Eq, Ord, Show) + + +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) + +class Ord item => Position item where + position :: Int -> Color -> item + +{- | +Assert that colors are consistent in slices of both orientations. +-} +assignsFromPositions :: + (Position item) => + (Int -> Int -> Color -> map) -> + [[Int]] -> [[Int]] -> [ESC.Assign map (Set (Strip 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)]) + (Match.take rows [0..]) + (Match.take columns [0..]) + [White, Black] + + +square :: Int -> Int -> Color -> Set (Int,Int) +square r c col = Mn.when (col==Black) $ Set.singleton (r,c) + +squareBW :: Int -> Int -> Color -> Map (Int,Int) Color +squareBW r c = Map.singleton (r,c) diff --git a/example/Nonogram/Encoding/BlackWhite.hs b/example/Nonogram/Encoding/BlackWhite.hs new file mode 100644 --- /dev/null +++ b/example/Nonogram/Encoding/BlackWhite.hs @@ -0,0 +1,117 @@ +{- | +This module improves "Nonogram.Encoding.Naive" in these ways: + +* It provides distinguished elements for black and white squares. + Thus the solver can conclude like so: + \"If there is no possibility to make a square white, it must be black.\" + +* Single squares can be set to black or white. + This is done when synchronizing horizontal and vertical slices + in 'Base.assignsFromPositions'. + +* The search ranges for brick positions are narrowed + to the positions that can really occur. + +* The search ranges for white squares are narrowed accordingly. + +* 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 + +import qualified Nonogram.Base as Base +import Nonogram.Base + (Strip, strip, BrickId(BrickId), + Orientation(Horizontal, Vertical), Color(White, Black), noAssign) + +import qualified Math.SetCover.Exact as ESC + +import qualified Data.Monoid.HT as Mn +import qualified Data.List.Match as Match +import qualified Data.List as List +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) + +{- +For efficiency reasons combine the left-most and right-most brick +with the space to the left and right border, respectively. +-} +assignsFromBrick :: + (Monoid map) => + Orientation -> Int -> Int -> BrickId -> BrickId -> + Int -> Int -> Int -> [Assign map] +assignsFromBrick orient width line lastBrick brick + leftBorder rightBorder size = + flip map [leftBorder .. width-rightBorder] $ \col -> + noAssign $ strip orient line $ + Brick brick + : + (map (flip Position White) $ take size [col ..]) + ++ + (if brick > BrickId 0 + then map (Reserve $ pred brick) (takeWhile ( Orientation -> Int -> Int -> [Int] -> [Assign map] +assignsFromLine orient width line xs = + let bricks = Match.take xs [BrickId 0 ..] + in concat + (List.zipWith4 + (assignsFromBrick orient width line (maximum bricks)) + bricks + (scanl (+) 0 $ map succ xs) + (scanr (+) (-1) $ map succ xs) + xs) + ++ + Mn.when (null xs) + [noAssign . strip orient line . + {- The Reserve item makes sure, that this line of squares is taken + and that it is not assembled from the squares generated by + Base.assignsFromPositions. -} + (Reserve (BrickId 0) 0 :) . + map (flip Position Black) $ + take width [0..]] + ++ + do + (_,brick,left,right) <- + List.zip4 (drop 1 xs) bricks + (drop 1 $ scanl (+) 0 $ map succ xs) + (drop 1 $ scanr (+) 0 $ map succ xs) + c <- [left .. width-right] + return $ noAssign $ + strip orient line [Reserve brick c, Position c Black] + +assignsGen :: + (Monoid map) => + (Int -> Int -> Color -> map) -> [[Int]] -> [[Int]] -> [Assign map] +assignsGen square rows columns = + concat (zipWith (assignsFromLine Horizontal (length columns)) [0..] rows) + ++ + concat (zipWith (assignsFromLine Vertical (length rows)) [0..] columns) + ++ + Base.assignsFromPositions square rows columns + +assigns :: [[Int]] -> [[Int]] -> [Assign (Set (Int,Int))] +assigns = assignsGen Base.square + +assignsBW :: [[Int]] -> [[Int]] -> [Assign (Map (Int,Int) Color)] +assignsBW = assignsGen Base.squareBW diff --git a/example/Nonogram/Encoding/Combinatoric.hs b/example/Nonogram/Encoding/Combinatoric.hs new file mode 100644 --- /dev/null +++ b/example/Nonogram/Encoding/Combinatoric.hs @@ -0,0 +1,92 @@ +{- | +In this module we generate for every line all possible layouts of bricks. +This leads to a big number of sets, +but still allows for the fastest solution +and a minimum number of solution steps. +The solver tends to need very few guesses. +-} +module Nonogram.Encoding.Combinatoric (assigns, assignsBW) where + +import qualified Nonogram.Base as Base +import Nonogram.Base + (Strip, strip, Orientation(Horizontal, Vertical), + Color(White, Black), noAssign) + +import qualified Math.SetCover.Exact as ESC + +import Control.Monad (guard) +import Control.Applicative ((<$>)) + +import qualified Data.NonEmpty as NonEmpty +import Data.Monoid (Monoid) +import Data.Map (Map) +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) + +{- +quickCheck $ \n0 ns0 -> let n = abs n0; ns = map abs ns0 in spread n ns == spreadNaive n ns +-} +spread :: Int -> [Int] -> [(Int, [(Int, Int)])] +spread width0 sizes0 = + case NonEmpty.init $ NonEmpty.scanr (+) (-1) (map succ sizes0) of + [] -> return (width0, []) + minWidth0:sums -> do + remWidth0 <- reverse [minWidth0 .. width0] + let go width [] = guard (width == 0) >> return [] + go width [(_0,size)] = + guard (width>=size) >> return [(size, width-size)] + go width ((minWidth,size):sizes) = do + remWidth <- reverse [minWidth .. width-1] + ((size, width-remWidth):) <$> go (remWidth-size) sizes + chain <- go remWidth0 $ zip (sums++[0]) sizes0 + return (width0-remWidth0, chain) + +_spreadNaive :: Int -> [Int] -> [(Int, [(Int, Int)])] +_spreadNaive width0 sizes0 = do + start <- [0..width0] + let go width [] = guard (width == 0) >> return [] + go width [size] = guard (width>=size) >> return [(size, width-size)] + go width (size:sizes) = do + space <- [1 .. width-size] + ((size,space):) <$> go (width-size-space) sizes + chain <- go (width0-start) sizes0 + return (start, chain) + +assignsFromLine :: + (Monoid map) => Orientation -> Int -> Int -> [Int] -> [Assign map] +assignsFromLine orient width line xs = + map + (noAssign . strip orient line . (Line :) . + zipWith Position [0..] . + (\(start,bricks) -> + replicate start Black ++ + concatMap + (\(size,space) -> replicate size White ++ replicate space Black) + bricks)) $ + spread width xs + +assignsGen :: + (Monoid map) => + (Int -> Int -> Color -> map) -> [[Int]] -> [[Int]] -> [Assign map] +assignsGen square rows columns = + concat (zipWith (assignsFromLine Horizontal (length columns)) [0..] rows) + ++ + concat (zipWith (assignsFromLine Vertical (length rows)) [0..] columns) + ++ + Base.assignsFromPositions square rows columns + +assigns :: [[Int]] -> [[Int]] -> [Assign (Set (Int,Int))] +assigns = assignsGen Base.square + +assignsBW :: [[Int]] -> [[Int]] -> [Assign (Map (Int,Int) Color)] +assignsBW = assignsGen Base.squareBW diff --git a/example/Nonogram/Encoding/Naive.hs b/example/Nonogram/Encoding/Naive.hs new file mode 100644 --- /dev/null +++ b/example/Nonogram/Encoding/Naive.hs @@ -0,0 +1,110 @@ +{- | +The module provides a pretty naive encoding for a nonogram. +Black squares are encoded as elements of bricks by 'assignsFromBrick'. +The board is filled with white squares +when there are no more black squares to set. +This is declared in the 'liftM2' part in 'assigns'. +This part is also responsible for connecting +the horizontally and the vertically sliced view of the board. + +This approach has two main problems: + +* Bricks are only set as a whole. + For an efficient solution it would be necessary + to infer the color of single squares. + +* White is encoded as \"finally not black\". + An efficient solution requires three states for a square: + \"black\", \"white\", \"yet undetermined\". + +The modules "Nonogram.Encoding.BlackWhite" +and "Nonogram.Encoding.Plug" address these problems. +-} +module Nonogram.Encoding.Naive (assigns) where + +import Nonogram.Base + (Strip(Strip), strip, BrickId(BrickId), + Orientation(Horizontal, Vertical), noAssign) + +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 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 +from the left border to its right end, +and @Brick (n+1)@ forbids @Brick n@ to use any squares +from its left start to right border. +Gaps are filled with single 'Reserve' items in 'assignsFromLine'. +-} +data Item = Brick BrickId | Position Int | Reserve BrickId Int + deriving (Eq, Ord, Show) + + +type Assign = ESC.Assign (Set (Int, Int)) (Set X) + +assignsFromBrick :: + Orientation -> Int -> Int -> + Maybe BrickId -> BrickId -> Maybe BrickId -> 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) $ + strip orient line $ + Brick thisBrick + : + (map Position $ take size [col ..]) + ++ + foldMap + (\brick -> map (Reserve brick) [col .. pred width]) + prevBrick + ++ + foldMap + (\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) [BrickId 0 ..] + let bricks = Match.take (drop 1 xs) [BrickId 0 ..] + in concat + (List.zipWith4 + (assignsFromBrick orient width line) + (Nothing : map Just bricks) + [BrickId 0 ..] + (map Just bricks ++ [Nothing]) + xs) + ++ + liftM2 + (\brick c -> + noAssign $ Set.singleton $ + Strip orient line (Reserve brick c)) + bricks [0 .. width-1] + +assigns :: [[Int]] -> [[Int]] -> [Assign] +assigns rows columns = + concat (zipWith (assignsFromLine Horizontal (length columns)) [0..] rows) + ++ + concat (zipWith (assignsFromLine Vertical (length rows)) [0..] columns) + ++ + liftM2 + (\r c -> + noAssign $ + Set.fromList + [Strip Horizontal r (Position c), + Strip Vertical c (Position r)]) + (Match.take rows [0..]) + (Match.take columns [0..]) diff --git a/example/Nonogram/Encoding/Plug.hs b/example/Nonogram/Encoding/Plug.hs new file mode 100644 --- /dev/null +++ b/example/Nonogram/Encoding/Plug.hs @@ -0,0 +1,123 @@ +{- | +This module provides an alternative to "Nonogram.Encoding.BlackWhite" +but is not as efficient. + +We use a different scheme for asserting +that the bricks are ordered from left to right. +For every (horizontal) strip imagine an array of squares, +where the horizontal axis is equal to the width of the board +and the vertical axis counts the bricks interleaved with spaces. +I.e. first row equals the left-most space, +second row to the left-most brick, +third row to the second space, +fourth row to the second brick, and so on. +A white square within the n-th space (zero-based) at position k +is represented by a vertical strip at position k, +where the square at the 2n-th line is moved one place to the right. +The n-th brick is represented by a block +where at the left edge the square in the 2n-1-th line is omitted +and right of the right edge a square is added in the 2n+1-th line. +We can plug together these shapes +which was the inspiration for the module name. +The plugs somehow form a staircase. + +Unfortunately, this encoding does not improve performance of the solver. +I think it makes it more difficult for the solver +to see admissible positions for a brick +after some bricks have been placed. +-} +module Nonogram.Encoding.Plug (assigns) where + +import qualified Nonogram.Base as Base +import Nonogram.Base + (Strip, strip, BrickId(BrickId), + Orientation(Horizontal, Vertical), Color(White, Black), noAssign) + +import qualified Math.SetCover.Exact as ESC + +import Control.Monad (liftM2) + +import qualified Data.Monoid.HT as Mn +import qualified Data.List.Match as Match +import qualified Data.List.HT as ListHT +import qualified Data.List as List +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) + +invertColor :: Color -> Color +invertColor c = + case c of + Black -> White + White -> Black + +square :: (BrickId, Color) -> Int -> [Item] +square cb k = + Position k (invertColor $ snd cb) : + Square cb k : + [] + +assignsFromBrick :: + Orientation -> Int -> Int -> + [(BrickId, Color)] -> BrickId -> Int -> [Assign] +assignsFromBrick orient width line colorBricks thisBrick size = + flip map [0 .. width-size] $ \col -> + noAssign $ + strip orient line $ + Brick thisBrick + : + Mn.when (col>0) (square (thisBrick, White) (pred col)) + ++ + let cols = take size [col ..] + in map (flip Position (invertColor Black)) cols + ++ + liftM2 Square colorBricks cols + ++ + Mn.when (col+size Int -> Int -> [Int] -> [Assign] +assignsFromLine orient width line xs = + let colorBricks = + Match.take (0:xs++xs) $ liftM2 (,) [BrickId 0 ..] [White, Black] + cbsels = ListHT.removeEach colorBricks + in concat + (List.zipWith + (assignsFromBrick orient width line colorBricks) + [BrickId 0 ..] xs) + ++ + map + (\(_cb,cbs) -> + noAssign $ strip orient line $ map (flip Square 0) cbs) + (take 1 cbsels) + ++ + liftM2 + (\(cb,cbs) k -> + noAssign $ + strip orient line $ + square cb k ++ map (flip Square (succ k)) cbs) + (ListHT.sieve 2 cbsels) [0 .. width-2] + ++ + map + (\(cb,_cbs) -> + noAssign $ strip orient line $ square cb (width-1)) + (ListHT.takeRev 1 cbsels) + +assigns :: [[Int]] -> [[Int]] -> [Assign] +assigns rows columns = + concat (zipWith (assignsFromLine Horizontal (length columns)) [0..] rows) + ++ + concat (zipWith (assignsFromLine Vertical (length rows)) [0..] columns) + ++ + Base.assignsFromPositions Base.square rows columns diff --git a/example/Nonogram/Example.hs b/example/Nonogram/Example.hs new file mode 100644 --- /dev/null +++ b/example/Nonogram/Example.hs @@ -0,0 +1,148 @@ +module Nonogram.Example where + +import qualified Data.List.HT as ListHT +import qualified Data.List as List +import Data.Char (isSpace) + + +encodeLines :: [String] -> [[Int]] +encodeLines = + map (filter (>0) . map length . ListHT.chop isSpace) + +encodeStrings :: [String] -> ([[Int]], [[Int]]) +encodeStrings xs = + (encodeLines xs, encodeLines $ List.transpose xs) + + +crossRows, crossColumns :: [[Int]] +crossRows = + [1,1] : + [1] : + [1,1] : + [] + +crossColumns = + [1,1] : + [1] : + [1,1] : + [] + +crossEnc :: ([[Int]], [[Int]]) +crossEnc = (crossRows, crossColumns) + + +rhombus, circle, four, letterP, lambda, bigCircle :: [String] +rhombus = + " X " : + " X X " : + "X X" : + " X X " : + " X " : + [] + +circle = + " XXX " : + "XX XX" : + "X X" : + "XX XX" : + " XXX " : + [] + +four = + "XX XX" : + "XX XX" : + " " : + " " : + "XX XX" : + "XX XX" : + [] + +letterP = + "XXXX " : + "XXXXXX" : + "XX XX" : + "XX XX" : + "XXXXXX" : + "XXXX " : + "XX " : + "XX " : + "XX " : + [] + +bigCircle = + " XXXXX " : + " XXX XXX " : + " X X " : + "XX XX" : + "X X" : + "X X" : + "X X" : + "XX XX" : + " X X " : + " XXX XXX " : + " XXXXX " : + [] + +lambda = + " XXX " : + " X XX " : + " XX " : + " XX " : + " XXX " : + " XX XX " : + " XX XX " : + " XX XX " : + " XX XX " : + "XX XX X" : + "XX XX " : + [] + +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] : + [] + +soccerEnc :: ([[Int]], [[Int]]) +soccerEnc = (soccerRows, soccerColumns) diff --git a/set-cover.cabal b/set-cover.cabal --- a/set-cover.cabal +++ b/set-cover.cabal @@ -1,5 +1,5 @@ Name: set-cover -Version: 0.0.5 +Version: 0.0.5.1 License: BSD3 License-File: LICENSE Author: Henning Thielemann, Helmut Podhaisky @@ -31,7 +31,7 @@ default: False Source-Repository this - Tag: 0.0.5 + Tag: 0.0.5.1 Type: darcs Location: http://hub.darcs.net/thielema/set-cover/ @@ -162,7 +162,8 @@ If flag(buildExamples) Build-Depends: set-cover, - transformers >=0.2 && <0.5, + non-empty >=0.2 && <0.4, + transformers >=0.2 && <0.6, containers, utility-ht, base @@ -190,6 +191,7 @@ If flag(buildExamples) Build-Depends: set-cover, + non-empty >=0.2 && <0.4, containers, utility-ht, base @@ -198,13 +200,20 @@ GHC-Options: -Wall Hs-Source-Dirs: example Main-Is: Nonogram.hs + Other-Modules: + Nonogram.Example + Nonogram.Encoding.Combinatoric + Nonogram.Encoding.BlackWhite + Nonogram.Encoding.Plug + Nonogram.Encoding.Naive + Nonogram.Base Executable mastermind If flag(buildExamples) Build-Depends: set-cover, - random >=1.0 && <1.1, - transformers >=0.2 && <0.5, + random >=1.0 && <1.2, + transformers >=0.2 && <0.6, containers, array >=0.1 && <0.6, utility-ht, diff --git a/src/Math/SetCover/Bit.hs b/src/Math/SetCover/Bit.hs --- a/src/Math/SetCover/Bit.hs +++ b/src/Math/SetCover/Bit.hs @@ -9,6 +9,10 @@ infixl 7 .&. infixl 5 .|. +{- | +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 empty :: bits complement, keepMinimum :: bits -> bits diff --git a/src/Math/SetCover/BitMap.hs b/src/Math/SetCover/BitMap.hs --- a/src/Math/SetCover/BitMap.hs +++ b/src/Math/SetCover/BitMap.hs @@ -26,8 +26,7 @@ let go c xs [] = unMap $ inc (Set c) (Map xs) go c [] ys = unMap $ inc (Set c) (Map ys) go c (x:xs) (y:ys) = - xor c (xor x y) : - go (c.&.x .|. x.&.y .|. y.&.c) xs ys + xor c (xor x y) : go (c.&.(x.|.y) .|. x.&.y) xs ys in Map $ go Bit.empty xs0 ys0 inc :: Bit.C bits => Set bits -> Map bits -> Map bits 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 @@ -32,6 +32,12 @@ disjoint :: set -> set -> Bool unions :: [set] -> set difference :: set -> set -> set + {- | + Unchecked preconditions: + '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. + -} minimize :: set -> [Assign label set] -> [Assign label set] instance (Ord a) => Set (Set.Set a) where @@ -40,9 +46,16 @@ unions = Set.unions difference = Set.difference minimize free = - Fold.minimumBy Match.compareLength . Map.unionsWith (++) . - (Fold.foldMap (flip Map.singleton []) free :) . - map (\a -> Fold.foldMap (flip Map.singleton [a]) $ labeledSet a) + Fold.minimumBy Match.compareLength . + foldr (Map.unionWith (++)) (constMap [] free) . + map (\a -> constMap [a] $ labeledSet a) + +{- +In containers-0.5 we have Map.fromSet +-} +{-# INLINE constMap #-} +constMap :: (Ord a) => b -> Set.Set a -> Map.Map a b +constMap a = Fold.foldMap (flip Map.singleton a) instance (Bit.C a) => Set (BitSet.Set a) where null = BitSet.null