packages feed

set-cover 0.0.1 → 0.0.2

raw patch · 4 files changed

+231/−44 lines, 4 filesdep ~basedep ~containersdep ~utility-htnew-component:exe:baumeister

Dependency ranges changed: base, containers, utility-ht

Files

+ example/Baumeister.hs view
@@ -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
example/TetrisCube.hs view
@@ -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 ()
set-cover.cabal view
@@ -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
src/Math/SetCover/Cuboid.hs view
@@ -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]]