set-cover 0.0 → 0.0.1
raw patch · 6 files changed
+164/−12 lines, 6 filesdep ~basedep ~containersdep ~utility-htnew-component:exe:lcube
Dependency ranges changed: base, containers, utility-ht
Files
- example/LCube.hs +118/−0
- example/Parallelism.hs +10/−0
- example/Soma.hs +3/−3
- example/TetrisCube.hs +1/−5
- example/Utility.hs +9/−0
- set-cover.cabal +23/−4
+ example/LCube.hs view
@@ -0,0 +1,118 @@+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 Math.SetCover.Cuboid+ (PackedCoords(PackedCoords), Coords, Size, forNestedCoords,+ allPositions, allOrientations, packCoords, unpackCoords,+ dz, normalForm)++import qualified System.IO as IO+import Text.Printf (printf)+import Parallelism (parallel)+import Utility (hPutStrLnImmediate)++import qualified Data.Map as Map+import qualified Data.Set as Set++import Control.Applicative (pure)+import Data.Foldable (foldMap)+import Data.List (intercalate)+import Data.Word (Word64)+++shape :: [PackedCoords]+shape = map PackedCoords [0,1,2,3,5]++size :: Size+size = pure 5+++type Mask = Set.Set PackedCoords++type Assign = ESC.Assign Mask Mask++transformedBrickAssign :: [PackedCoords] -> [Assign]+transformedBrickAssign =+ map brickAssign . concatMap (allPositions size) .+ allOrientations . map (unpackCoords size)++brickAssign :: [Coords Int] -> Assign+brickAssign ts =+ let xs = Set.fromList $ map (packCoords size) ts+ in ESC.assign xs xs++allAssigns :: [Assign]+allAssigns = transformedBrickAssign shape++allMasks :: [Mask]+allMasks = map ESC.labeledSet allAssigns++writeMasks :: IO ()+writeMasks =+ writeFile "lcube.txt" $ show allMasks+++initStates :: [ESC.State Mask Mask]+initStates =+ map+ (\rotate ->+ ESC.updateState+ (brickAssign $ normalForm $+ map rotate $ map (unpackCoords size) shape) $+ ESC.initState allAssigns)+ [id, dz, dz.dz.dz]+++format :: [Mask] -> String+format v =+ let wuerfelx =+ Map.unions $+ zipWith (\n -> foldMap (flip Map.singleton n)) [0..] $+ reverse v+ in forNestedCoords+ unlines (intercalate " | ") (intercalate " ")+ (\c ->+ maybe "." (\n -> [toEnum $ n + fromEnum 'A']) $+ Map.lookup (packCoords size c) wuerfelx)+ size++printMask :: [Mask] -> IO ()+printMask = putStrLn . format+++type BitMask = BitSet.Set (Bit.Sum Word64 Word64)++packMask :: Mask -> BitMask+packMask =+ foldMap+ (\(PackedCoords x) ->+ BitSet.Set $+ case divMod x 64 of+ (0, k) -> Bit.bitLeft k+ (1, k) -> Bit.bitRight k+ _ -> error "impossible position")+++main, mainState, mainBits, mainParallel, testme :: IO ()+testme = mapM_ (printMask . (:[])) allMasks++mainState = do+ let lsg = concatMap ESC.search initStates+ mapM_ printMask lsg+ print $ length lsg++mainBits = do+ let lsg = concatMap ESC.search $ map (fmap packMask) initStates+ mapM_ printMask lsg+ print $ length lsg++mainParallel =+ parallel $+ (\f -> zipWith f [0..] initStates) $ \n initState ->+ IO.withFile (printf "lcube%02d.txt" (n::Int)) IO.WriteMode $ \h ->+ mapM_ (hPutStrLnImmediate h . format) $+ ESC.search $ fmap packMask initState++main = mainParallel
example/Parallelism.hs view
@@ -22,3 +22,13 @@ 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
example/Soma.hs view
@@ -37,9 +37,9 @@ transformedBrickAssign :: Brick -> [PackedCoords] -> [Assign] transformedBrickAssign k =- map (brickAssign k) . concatMap (allPositions size) .- (if k == Brick 0 then \x->[x] else allOrientations) .- map (unpackCoords size)+ map (brickAssign k) . concatMap (allPositions size) .+ (if k == Brick 0 then \x->[x] else allOrientations) .+ map (unpackCoords size) brickAssign :: Brick -> [Coords Int] -> Assign brickAssign k ts =
example/TetrisCube.hs view
@@ -43,6 +43,7 @@ import Data.Word (Word16, Word64) import qualified System.IO as IO+import Utility (hPutStrLnImmediate) import Text.Printf (printf) @@ -201,11 +202,6 @@ ++ "\ESC[m" --hPutStrLnImmediate :: IO.Handle -> String -> IO ()-hPutStrLnImmediate h str = do- IO.hPutStrLn h str- IO.hFlush h format :: [Map.Map PackedCoords BrickId] -> String format v =
+ example/Utility.hs view
@@ -0,0 +1,9 @@+module Utility where++import qualified System.IO as IO+++hPutStrLnImmediate :: IO.Handle -> String -> IO ()+hPutStrLnImmediate h str = do+ IO.hPutStrLn h str+ IO.hFlush h
set-cover.cabal view
@@ -1,5 +1,5 @@ Name: set-cover-Version: 0.0+Version: 0.0.1 License: BSD3 License-File: LICENSE Author: Henning Thielemann, Helmut Podhaisky@@ -9,7 +9,8 @@ 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, Soma Cube, Tetris Cube.+ Included examples:+ Sudoku, 8 Queens, Soma Cube, Tetris Cube, Cube of L's. Generic algorithm allows to choose between slow but flexible @Set@ from @containers@ package and fast but cumbersome bitvectors.@@ -26,7 +27,7 @@ default: False Source-Repository this- Tag: 0.0+ Tag: 0.0.1 Type: darcs Location: http://code.haskell.org/~thielema/set-cover/ @@ -61,7 +62,9 @@ GHC-Options: -Wall -rtsopts -threaded Hs-Source-Dirs: example Main-Is: TetrisCube.hs- Other-Modules: Parallelism+ Other-Modules:+ Parallelism+ Utility Executable soma-cube If flag(buildExamples)@@ -103,3 +106,19 @@ GHC-Options: -Wall -rtsopts -threaded Hs-Source-Dirs: example Main-Is: Sudoku.hs++Executable lcube+ 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: LCube.hs+ Other-Modules:+ Parallelism+ Utility