diff --git a/example/LCube.hs b/example/LCube.hs new file mode 100644 --- /dev/null +++ b/example/LCube.hs @@ -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 diff --git a/example/Parallelism.hs b/example/Parallelism.hs --- a/example/Parallelism.hs +++ b/example/Parallelism.hs @@ -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 diff --git a/example/Soma.hs b/example/Soma.hs --- a/example/Soma.hs +++ b/example/Soma.hs @@ -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 = diff --git a/example/TetrisCube.hs b/example/TetrisCube.hs --- a/example/TetrisCube.hs +++ b/example/TetrisCube.hs @@ -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 = diff --git a/example/Utility.hs b/example/Utility.hs new file mode 100644 --- /dev/null +++ b/example/Utility.hs @@ -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 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 +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