set-cover 0.0.5 → 0.0.5.1

raw patch · 15 files changed

+794/−253 lines, 15 filesdep +non-emptydep ~randomdep ~transformersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: non-empty

Dependency ranges changed: random, transformers

API changes (from Hackage documentation)

Files

• example/Alphametics.hs +4/−4
• example/Baumeister.hs +9/−11
• example/LonposPyramid.hs +17/−17
• example/Mastermind.hs +7/−7
• example/Nonogram.hs +61/−204
• example/Nonogram/Base.hs +71/−0
• example/Nonogram/Encoding/BlackWhite.hs +117/−0
• example/Nonogram/Encoding/Combinatoric.hs +92/−0
• example/Nonogram/Encoding/Naive.hs +110/−0
• example/Nonogram/Encoding/Plug.hs +123/−0
• example/Nonogram/Example.hs +148/−0
• set-cover.cabal +14/−5
• src/Math/SetCover/Bit.hs +4/−0
• src/Math/SetCover/BitMap.hs +1/−2
• src/Math/SetCover/Exact.hs +16/−3

@@ -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

@@ -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

@@ -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

@@ -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") :

@@ -2,206 +2,36 @@ * <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.+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

@@ -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)

@@ -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 (<width) [col .. ])+      else map (flip Position Black) (take col [0 ..]))+   +++   (if brick < lastBrick+      then map (Reserve brick) (takeWhile (<width) [0 .. col+size])+           +++           Mn.when (col+size<width) [Position (col+size) Black]+      else map (flip Position Black) (takeWhile (<width) [col+size ..]))++assignsFromLine ::+   (Monoid map) => 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

@@ -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

@@ -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..])

@@ -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<width)+      (map (flip Square (col+size)) $+       List.delete (succ thisBrick, White) colorBricks)++assignsFromLine ::+   Orientation -> 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

@@ -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)

@@ -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,

@@ -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

@@ -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

@@ -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