diff --git a/example/Baumeister.hs b/example/Baumeister.hs new file mode 100644 --- /dev/null +++ b/example/Baumeister.hs @@ -0,0 +1,154 @@ +{- | +Logika's Baumeister puzzle +-} +module Main where + +import qualified Math.SetCover.Exact as ESC +import qualified Math.SetCover.Cuboid as Cuboid +import Math.SetCover.Cuboid (PackedCoords, Coords, Size) + +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Data.Foldable (forM_) +import Data.List (intercalate) +import Data.Maybe (mapMaybe) + +import qualified System.IO as IO +import Utility (hPutStrLnImmediate) +import Text.Printf (printf) + + +shapes, flatShapes, spaceShapes :: [[String]] +shapes = flatShapes ++ spaceShapes + +flatShapes = + ( + "..." : + []) + : + ( + "..." : + ". " : + []) + : + ( + ".. " : + " .." : + []) + : + ( + ".." : + ". " : + []) + : + ( + "..." : + " . " : + []) + : + [] + + +spaceShapes = + ( + ".." : + ": " : + []) + : + ( + ".." : + " :" : + []) + : + ( + ".:" : + " ." : + []) + : + [] + + +propNumberOfAtoms :: Bool +propNumberOfAtoms = Cuboid.numberOf2LayerAtoms shapes == 30 + + +targetBase, targetE, targetPyramid :: [[String]] +targetBase = + let line = replicate 5 '.' + in [replicate 5 line, ["", "", line, "", ""]] + +targetE = + replicate 3 $ + "..." : + "." : + ".." : + "." : + "..." : + [] + +targetPyramid = + map (\n -> replicate n $ replicate n '.') [4,3,2,1] + + + +newtype Brick = Brick Int deriving (Eq, Ord) + +type Mask = Set.Set (Either Brick PackedCoords) + +type Assign = ESC.Assign (Map.Map PackedCoords Brick) Mask + +transformedBrickAssign :: Size -> Brick -> [String] -> [Assign] +transformedBrickAssign size k = + map (brickAssign size k) . concatMap (Cuboid.allPositions size) . + Cuboid.allOrientations . 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 wuerfelx = Map.unions v + in Cuboid.forNestedCoords + unlines (intercalate " | ") (intercalate " ") + (\c -> + maybe "." (\(Brick n) -> show n) $ + Map.lookup (Cuboid.packCoords size c) wuerfelx) + size + +printMask :: Size -> [Map.Map PackedCoords Brick] -> IO () +printMask size = + hPutStrLnImmediate IO.stdout . format size + + +main, mainBase :: IO () + +mainBase = + forM_ [targetBase, targetE, targetPyramid] $ \targetString -> do + let target = Cuboid.coordsFromString targetString + size = Cuboid.size target + lsg = ESC.search $ initState size target + if False + then mapM_ (printMask size) lsg + else printMask size $ head lsg + printf "total number of solutions: %d\n\n" $ length lsg + +main = mainBase diff --git a/example/TetrisCube.hs b/example/TetrisCube.hs --- a/example/TetrisCube.hs +++ b/example/TetrisCube.hs @@ -25,16 +25,14 @@ import qualified Math.SetCover.Exact as ESC import qualified Math.SetCover.BitSet as BitSet import qualified Math.SetCover.Bit as Bit -import Math.SetCover.Cuboid - (PackedCoords(PackedCoords), Coords(Coords), Size, forNestedCoords, - allPositions, allOrientations, packCoords) +import qualified Math.SetCover.Cuboid as Cuboid +import Math.SetCover.Cuboid (PackedCoords(PackedCoords), Coords, Size) import Parallelism (schedule) import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.List.Match as Match -import qualified Data.Foldable as Fold import Control.Applicative (pure) import Data.Function (on) @@ -127,30 +125,8 @@ [] -numberOfAtoms :: Int -numberOfAtoms = - Fold.sum $ - Map.intersectionWith (*) - (Map.fromList [('.', 1), ('\'', 1), (':', 2)]) $ - Map.fromListWith (+) $ - map (flip (,) 1) $ - concat $ concat shapes - propNumberOfAtoms :: Bool -propNumberOfAtoms = numberOfAtoms == 64 - - -coordsFromString :: [String] -> [Coords Int] -coordsFromString ss = do - (rowN,row) <- zip [0..] ss - (colN,c) <- zip [0..] row - fmap (Coords rowN colN) $ - case c of - ' ' -> [] - '.' -> [0] - '\'' -> [1] - ':' -> [0, 1] - _ -> error "forbidden character" +propNumberOfAtoms = Cuboid.numberOf2LayerAtoms shapes == 64 size :: Size @@ -167,12 +143,13 @@ transformedBrickAssign :: BrickId -> [String] -> [Assign] transformedBrickAssign k = - map (brickAssign k) . concatMap (allPositions size) . - (if k==(Blue,0) then (:[]) else allOrientations) . coordsFromString + map (brickAssign k) . concatMap (Cuboid.allPositions size) . + (if k==(Blue,0) then (:[]) else Cuboid.allOrientations) . + Cuboid.coordsFrom2LayerString brickAssign :: BrickId -> [Coords Int] -> Assign brickAssign k ts = - let xs = map (packCoords size) ts + let xs = map (Cuboid.packCoords size) ts in ESC.assign (Map.fromList $ map (flip (,) k) xs) $ Set.fromList $ Left k : map Right xs @@ -206,11 +183,11 @@ format :: [Map.Map PackedCoords BrickId] -> String format v = let wuerfelx = Map.unions v - in forNestedCoords + in Cuboid.forNestedCoords unlines (intercalate " | ") (intercalate " ") (\c -> maybe "." formatBrickId $ - Map.lookup (packCoords size c) wuerfelx) + Map.lookup (Cuboid.packCoords size c) wuerfelx) size printMask :: [Map.Map PackedCoords BrickId] -> IO () 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.1 +Version: 0.0.2 License: BSD3 License-File: LICENSE Author: Henning Thielemann, Helmut Podhaisky @@ -10,7 +10,8 @@ Description: Solver for exact set cover problems. Included examples: - Sudoku, 8 Queens, Soma Cube, Tetris Cube, Cube of L's. + Sudoku, 8 Queens, + Soma Cube, Tetris Cube, Cube of L's, Logika's Baumeister puzzle. Generic algorithm allows to choose between slow but flexible @Set@ from @containers@ package and fast but cumbersome bitvectors. @@ -18,7 +19,7 @@ Build examples with @cabal install -fbuildExamples@. . The package needs only Haskell 98. -Tested-With: GHC==7.4.2 +Tested-With: GHC==7.4.2, GHC==7.6.3 Cabal-Version: >=1.8 Build-Type: Simple @@ -27,7 +28,7 @@ default: False Source-Repository this - Tag: 0.0.1 + Tag: 0.0.2 Type: darcs Location: http://code.haskell.org/~thielema/set-cover/ @@ -119,6 +120,22 @@ GHC-Options: -Wall -rtsopts -threaded Hs-Source-Dirs: example Main-Is: LCube.hs + Other-Modules: + Parallelism + Utility + +Executable baumeister + 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: Baumeister.hs Other-Modules: Parallelism Utility diff --git a/src/Math/SetCover/Cuboid.hs b/src/Math/SetCover/Cuboid.hs --- a/src/Math/SetCover/Cuboid.hs +++ b/src/Math/SetCover/Cuboid.hs @@ -1,5 +1,6 @@ module Math.SetCover.Cuboid where +import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Traversable as Trav @@ -25,6 +26,38 @@ traverse f (Coords x y z) = liftA3 Coords (f x) (f y) (f z) +coordsFromString :: [[String]] -> [Coords Int] +coordsFromString ss = do + (planeN,plane) <- zip [0..] ss + (rowN,row) <- zip [0..] plane + (colN,c) <- zip [0..] row + case c of + ' ' -> [] + '.' -> [Coords planeN rowN colN] + _ -> error "forbidden character" + +coordsFrom2LayerString :: [String] -> [Coords Int] +coordsFrom2LayerString ss = do + (rowN,row) <- zip [0..] ss + (colN,c) <- zip [0..] row + fmap (Coords rowN colN) $ + case c of + ' ' -> [] + '.' -> [0] + '\'' -> [1] + ':' -> [0, 1] + _ -> error "forbidden character" + +numberOf2LayerAtoms :: [[String]] -> Int +numberOf2LayerAtoms = + Fold.sum . + Map.intersectionWith (*) + (Map.fromList [('.', 1), ('\'', 1), (':', 2)]) . + Map.fromListWith (+) . + map (flip (,) 1) . + concat . concat + + forNestedCoords :: (Enum a, Num a) => ([z] -> b) -> @@ -32,8 +65,8 @@ ([x] -> y) -> (Coords a -> x) -> Coords a -> b -forNestedCoords fz fy fx f size = - case fmap (\k -> [0 .. k-1]) size of +forNestedCoords fz fy fx f sz = + case fmap (\k -> [0 .. k-1]) sz of Coords rx ry rz -> fz $ flip map rz $ \z -> fy $ flip map ry $ \y -> @@ -60,24 +93,30 @@ type Size = Coords Int unpackCoords :: Size -> PackedCoords -> Coords Int -unpackCoords size (PackedCoords n) = - snd $ Trav.mapAccumL divMod n size +unpackCoords sz (PackedCoords n) = + snd $ Trav.mapAccumL divMod n sz packCoords :: Size -> Coords Int -> PackedCoords -packCoords size = - PackedCoords . Fold.foldr (\(k,x) s -> k*s+x) 0 . liftA2 (,) size +packCoords sz = + PackedCoords . Fold.foldr (\(k,x) s -> k*s+x) 0 . liftA2 (,) sz normalForm :: (Ord a, Num a) => [Coords a] -> [Coords a] normalForm ts = sort $ map (liftA2 subtract xyzm) ts where xyzm = foldl1 (liftA2 min) ts +{- | +Object must be in 'normalForm'. +-} +size :: [Coords Int] -> Coords Int +size = fmap succ . foldl1 (liftA2 max) + allPositions :: Size -> [Coords Int] -> [[Coords Int]] -allPositions size ts = +allPositions sz ts = map (\displacement -> map (liftA2 (+) displacement) ts) $ Trav.sequence $ liftA2 (\k r -> [0 .. k-1-r]) - size + sz (foldl1 (liftA2 max) ts) allOrientations :: (Num a, Ord a) => [Coords a] -> [[Coords a]]