set-cover 0.0.9 → 0.1
raw patch · 47 files changed
+3937/−356 lines, 47 filesdep +QuickCheckdep +bool8dep +comfort-arraydep ~arraydep ~basedep ~containersnew-component:exe:conway-puzzlenew-component:exe:mastermind-kneadnew-component:exe:mastermind-setcover
Dependencies added: QuickCheck, bool8, comfort-array, knead, lazyio, llvm-extra, llvm-tf, prelude-compat, storable-endian, tfp, timeit
Dependency ranges changed: array, base, containers, enummapset, transformers, utility-ht
Files
- Changes.md +28/−0
- Makefile +9/−0
- example/ConwayPuzzle.hs +182/−0
- example/LCube.hs +10/−10
- example/LonposPyramid.hs +14/−11
- example/Mastermind.hs +357/−106
- example/Mastermind/Benchmark.hs +88/−0
- example/Mastermind/Distinguish.hs +130/−0
- example/Mastermind/Example.hs +118/−0
- example/Mastermind/Guess.hs +244/−0
- example/Mastermind/Test.hs +83/−0
- example/Mastermind/Utility.hs +11/−0
- example/MastermindKnead.hs +34/−0
- example/Nonogram.hs +60/−6
- example/Nonogram/Base.hs +3/−1
- example/Nonogram/Encoding/BlackWhite.hs +4/−3
- example/Nonogram/Encoding/Combinatoric.hs +5/−4
- example/Random.hs +65/−0
- example/Soma.hs +11/−11
- example/Sudoku.hs +197/−9
- example/TetrisCube.hs +8/−8
- set-cover.cabal +148/−13
- src/Math/SetCover/Bit.hs +18/−11
- src/Math/SetCover/BitMap.hs +23/−6
- src/Math/SetCover/BitPosition.hs +25/−16
- src/Math/SetCover/BitPriorityQueue.hs +22/−7
- src/Math/SetCover/BitSet.hs +1/−1
- src/Math/SetCover/Cuboid.hs +21/−14
- src/Math/SetCover/EnumMap.hs +17/−3
- src/Math/SetCover/Exact.hs +122/−49
- src/Math/SetCover/Exact/Block.hs +37/−0
- src/Math/SetCover/Exact/Knead.hs +193/−0
- src/Math/SetCover/Exact/Knead/Saturated.hs +473/−0
- src/Math/SetCover/Exact/Knead/Symbolic.hs +303/−0
- src/Math/SetCover/Exact/Knead/Vector.hs +109/−0
- src/Math/SetCover/Exact/Priority.hs +37/−11
- src/Math/SetCover/Exact/UArray.hs +267/−0
- src/Math/SetCover/IntSet.hs +0/−42
- src/Math/SetCover/Queue.hs +5/−2
- src/Math/SetCover/Queue/Bit.hs +28/−3
- src/Math/SetCover/Queue/BitPriorityQueue.hs +1/−1
- src/Math/SetCover/Queue/Map.hs +11/−4
- src/Math/SetCover/Queue/Set.hs +15/−4
- test/Test.hs +314/−0
- test/Test/Utility.hs +47/−0
- test/knead/Test/Knead.hs +35/−0
- test/plain/Test/Knead.hs +4/−0
Changes.md view
@@ -1,5 +1,33 @@ # Change log for the `set-cover` package +## 0.1++ * `SetCover.Exact.decisionTree`, `SetCover.Exact.Priority.decisionTree`:+ Allow the programmer to generate human-friendly solutions.++ * `SetCover.Cuboid`: `dx`, `dy`, `dz` -> `rotX`, `rotY`, `rotZ`++ * `SetCover.Bit`: method `complement` replaced by `difference`.+ This way, we do not need the cumbersome `SetCover.IntSet` module anymore.++ * `SetCover.BitMap` made private.++ * `SetCover.BitPriorityQueue` made public.++ * `SetCover.Exact.State.usedSubsets`: Only store labels, not assignments.+ This is consistent with `SetCover.Exact.Priority.State`.++ * `SetCover.Exact.minimize`: allow an empty list of available subsets+ `SetCover.Exact.step`, `SetCover.Exact.Priority.step`:+ They do not need to test for an empty `availableSubset` anymore.++ * `SetCover.Exact.step`: Require non-empty set of free elements.+ This is consistent with `SetCover.Exact.Priority.step`.+ Until now, `step` returned an empty list if the were no free elements.+ This is not very helpful+ since it will throw away already completed solutions.+ The test is also redundant when `step` is called from `search`.+ ## 0.0.8 * `SetCover.Exact.Priority` implements the Algorithm X
+ Makefile view
@@ -0,0 +1,9 @@+run-test:+ runhaskell Setup configure --user -fbuildExamples --enable-tests+ runhaskell Setup build+ runhaskell Setup configure --user -fbuildExamples -fllvm --enable-tests --enable-benchmarks+ runhaskell Setup build+ runhaskell Setup haddock+ dist/build/set-cover-test/set-cover-test+# more portable, but suppresses live QuickCheck test counter:+# runhaskell Setup test --show-details=streaming
+ example/ConwayPuzzle.hs view
@@ -0,0 +1,182 @@+{- |+Conway's puzzle:++Assemble a 5x5x5 cube from the following cuboids:+ 3x 1x1x3+29x 1x2x2++https://en.wikipedia.org/wiki/Conway_puzzle+-}+module Main where++import qualified Math.SetCover.Cuboid as Cuboid+import qualified Math.SetCover.Exact as ESC+import Math.SetCover.Cuboid (Size, Coords(Coords))++import qualified Control.Concurrent.PooledIO.Independent as Pool+import qualified Control.Monad.Trans.State as MS+import Control.Applicative (pure, liftA2, liftA3)++import qualified Data.Foldable as Fold+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.List as List+import Data.IntSet (IntSet)+import Data.Foldable (foldMap)++import qualified System.IO as IO+import Text.Printf (printf)+import Utility (hPutStrLnImmediate)+++size :: Size+size = pure 5+++stick :: [Int]+stick = [0..2]++type Mask = Set.Set (Maybe (Coords Int))+type FormatMask = Set.Set (Coords Int)++sticksX, sticksY, sticksZ :: [FormatMask]+sticksX =+ map Set.fromList $ Cuboid.allPositions size $ map (\x -> Coords x 0 0) stick+sticksY =+ map Set.fromList $ Cuboid.allPositions size $ map (\x -> Coords 0 x 0) stick+sticksZ =+ map Set.fromList $ Cuboid.allPositions size $ map (\x -> Coords 0 0 x) stick++data Coord = X | Y | Z deriving (Eq, Ord, Show)++count :: FormatMask -> Map.Map (Coord, Int, Int) Int+count =+ Map.fromListWith (+) .+ concatMap (\(Coords x y z) -> [((X,y,z),1), ((Y,x,z),1), ((Z,x,y),1)]) .+ Set.toList++minimal :: FormatMask -> Bool+minimal =+ let center = pure 2+ transforms =+ map (\trans -> liftA2 (+) (liftA2 (-) center (trans center)) . trans) $+ liftA2 (.) [id, fmap negate] Cuboid.rotations+ in \mask -> all (\trans -> mask <= Set.map trans mask) transforms++assignsFromSticks ::+ [(FormatMask, FormatMask, FormatMask)] ->+ [ESC.Assign [FormatMask] FormatMask]+assignsFromSticks =+ map fst .+ filter (minimal . snd) .+ filter (Fold.all odd . count . snd) .+ map+ (\(x,y,z) ->+ let u = x `Set.union` y `Set.union` z+ in (ESC.assign [x,y,z] u, u))++{-+Make use of the fact+that all slices must contain an odd number of elements from 1x1x3 cuboids.+-}+threeSticksOrtho :: [ESC.Assign [FormatMask] FormatMask]+threeSticksOrtho =+ assignsFromSticks $+ filter+ (\(x,y,z) -> ESC.disjoint x y && ESC.disjoint y z && ESC.disjoint z x) $+ liftA3 (,,) sticksX sticksY sticksZ+++selectDisjoint :: MS.StateT [FormatMask] [] FormatMask+selectDisjoint =+ MS.StateT $ \masks -> do+ m:ms <- List.tails masks+ return (m, filter (ESC.disjoint m) ms)++threeSticks :: [ESC.Assign [FormatMask] FormatMask]+threeSticks =+ assignsFromSticks $+ MS.evalStateT+ (liftA3 (,,) selectDisjoint selectDisjoint selectDisjoint)+ (sticksX ++ sticksY ++ sticksZ)+++square :: [(Int,Int)]+square = liftA2 (,) [0,1] [0,1]++squares :: [FormatMask]+squares =+ (map Set.fromList $+ concatMap (Cuboid.allPositions size)+ [map (\(x,y) -> Coords 0 x y) square,+ map (\(x,y) -> Coords x 0 y) square,+ map (\(x,y) -> Coords x y 0) square])++allAssigns :: [ESC.Assign [FormatMask] Mask]+allAssigns =+ map (\mask -> ESC.assign [mask] (Set.map Just mask)) squares+ +++ map (fmap (Set.insert Nothing . Set.map Just)) threeSticks+++threeSticksCanonical :: ESC.Assign [FormatMask] FormatMask+threeSticksCanonical =+ let x = Set.fromList [Coords 0 0 0, Coords 1 0 0, Coords 2 0 0]+ y = Set.fromList [Coords 3 1 1, Coords 3 2 1, Coords 3 3 1]+ z = Set.fromList [Coords 4 4 2, Coords 4 4 3, Coords 4 4 4]+ in ESC.assign [x,y,z] (x `Set.union` y `Set.union` z)++initState ::+ ESC.Assign [FormatMask] FormatMask ->+ ESC.State [FormatMask] IntSet+initState s3asn =+ case ESC.intSetFromSetAssigns $+ s3asn : map (\mask -> ESC.assign [mask] mask) squares of+ asns@(s3:_) -> ESC.updateState s3 $ ESC.initState asns+ [] -> error "ESC.bitVectorFromSetAssigns lost first assignment"+++formatIdent :: Int -> Char+formatIdent n =+ toEnum $+ if n<10+ then n + fromEnum '0'+ else n-10 + fromEnum 'A'++format :: [FormatMask] -> String+format v =+ let cubex =+ Map.unions $+ zipWith (\n -> foldMap (flip Map.singleton n)) [0..] $+ reverse v+ in Cuboid.forNestedCoords+ unlines (List.intercalate " | ") (List.intercalate " ")+ (\c -> maybe "." (\n -> [formatIdent n]) $ Map.lookup c cubex)+ size++printMask :: [FormatMask] -> IO ()+printMask = hPutStrLnImmediate IO.stdout . format+++mainSimple, mainCanonical, mainParallel :: IO ()+mainSimple = do+ let sol =+ map concat $ ESC.partitions $ ESC.bitVectorFromSetAssigns allAssigns+ mapM_ printMask sol+ print $ length sol++mainCanonical = do+ let sol = map concat $ ESC.search $ initState threeSticksCanonical+ mapM_ printMask sol+ print $ length sol++mainParallel =+ Pool.run $+ (\f -> zipWith f [0..] threeSticks) $ \n s3 ->+ IO.withFile (printf "conway%04d.txt" (n::Int)) IO.WriteMode $ \h ->+ mapM_ (hPutStrLnImmediate h . format . concat) $+ ESC.search $ initState s3+++main :: IO ()+main = mainCanonical
example/LCube.hs view
@@ -9,7 +9,7 @@ import Math.SetCover.Cuboid (PackedCoords(PackedCoords), Coords, Size, forNestedCoords, allPositions, allOrientations, packCoords, unpackCoords,- dz, normalForm)+ rotZ, normalForm) import qualified Control.Concurrent.PooledIO.Independent as Pool import qualified System.IO as IO@@ -65,12 +65,12 @@ (brickAssign $ normalForm $ map rotate $ map (unpackCoords size) shape) $ ESC.initState allAssigns)- [id, dz, dz.dz.dz]+ [id, rotZ, rotZ.rotZ.rotZ] format :: [Mask] -> String format v =- let wuerfelx =+ let cubex = Map.unions $ zipWith (\n -> foldMap (flip Map.singleton n)) [0..] $ reverse v@@ -78,7 +78,7 @@ unlines (intercalate " | ") (intercalate " ") (\c -> maybe "." (\n -> [toEnum $ n + fromEnum 'A']) $- Map.lookup (packCoords size c) wuerfelx)+ Map.lookup (packCoords size c) cubex) size printMask :: [Mask] -> IO ()@@ -102,14 +102,14 @@ testme = mapM_ (printMask . (:[])) allMasks mainState = do- let lsg = concatMap ESC.search initStates- mapM_ printMask lsg- print $ length lsg+ let sol = concatMap ESC.search initStates+ mapM_ printMask sol+ print $ length sol mainBits = do- let lsg = concatMap ESC.search $ map (fmap packMask) initStates- mapM_ printMask lsg- print $ length lsg+ let sol = concatMap ESC.search $ map (fmap packMask) initStates+ mapM_ printMask sol+ print $ length sol mainParallel = Pool.runUnlimited $
example/LonposPyramid.hs view
@@ -20,8 +20,6 @@ import qualified Math.SetCover.Cuboid as Cuboid import Math.SetCover.Cuboid (PackedCoords(PackedCoords), Coords(Coords), Size) -import Control.Applicative (liftA2)- import qualified Data.Map as Map import qualified Data.Set as Set @@ -204,22 +202,27 @@ (0 0 2) With this matrix we could transform the coordinates-such that we could use 'Cuboid.allOrientations' instead of 'rotations'.+such that we could use 'Cuboid.allOrientations'. However, this would require a final division by 2. -} -rotations :: Num a => [Coords a -> Coords a]-rotations =- liftA2 (.)- [id, vertRot, vertRot.vertRot, vertRot.vertRot.vertRot]- [id, diagRot0, diagRot0.diagRot0, diagRot0.diagRot0.diagRot0,- diagRot1, diagRot1.diagRot1.diagRot1]+primRotations :: Coords (Coords Int -> Coords Int)+primRotations = Coords vertRot diagRot0 diagRot1 transformedBrickAssign :: Size -> Brick -> [String] -> [Assign] transformedBrickAssign size k = map (brickAssign size k) . concatMap (Cuboid.allPositions size) .- Set.toList . Set.fromList .- (\ts -> map (Cuboid.normalForm . flip map ts) rotations) .+ Cuboid.allOrientationsGen primRotations .+ map (\(Coords y x z) -> Coords z y x) .+ Cuboid.coordsFrom2LayerString++brickSize :: Size+brickSize = Coords 4 4 4++testRotations :: [String] -> [Map.Map PackedCoords Brick]+testRotations =+ map (Map.fromList . map (flip (,) (Brick 0) . Cuboid.packCoords brickSize)) .+ Cuboid.allOrientationsGen primRotations . map (\(Coords y x z) -> Coords z y x) . Cuboid.coordsFrom2LayerString
example/Mastermind.hs view
@@ -9,102 +9,82 @@ -} module Main where +import qualified Mastermind.Example as Example+import qualified Mastermind.Guess as Guess+import Mastermind.Distinguish (distinguishingCodesCondensed)+import Mastermind.Utility (histogram)++import Mastermind.Guess (+ consistentCodes,+ evaluate,+ countEval,+ codeFromLabels,+ assignsFromGuesses,+ defaultAssignFlags,+ AssignFlags,+ Eval,+ EvalSumm(EvalSumm),+ Row(Row), Column(Column),+ )++import qualified Math.SetCover.Exact.UArray as ESC_UArray import qualified Math.SetCover.Exact as ESC import qualified System.IO as IO+import qualified Random as Random import System.Random (StdGen, getStdGen, randomR, ) +import Text.Printf (printf, )+ import qualified Control.Monad.Trans.State as MS-import Control.Monad (liftM2, replicateM, when, )+import Control.Monad (replicateM, when, void, )+import Control.Applicative ((<$>), ) +import qualified Data.Map as Map; import Data.Map (Map, ) import qualified Data.Set as Set; import Data.Set (Set, ) import qualified Data.Array as Array+import qualified Data.Foldable as Fold import qualified Data.List.Match as Match import qualified Data.List.HT as ListHT-import Data.Tuple.HT (mapSnd, )-import Data.List.HT (tails, viewL, viewR, )-import Data.Maybe (mapMaybe, )----- cf. htam:Combinatorics.tuples-choose :: Int -> [a] -> [[a]]-choose n xs =- flip MS.evalStateT xs $ replicateM n $- MS.StateT $ mapMaybe viewL . tails+import qualified Data.List as List+import Data.Foldable (foldMap, forM_, )+import Data.List (intercalate, )+import Data.Maybe (listToMaybe, isNothing, ) -data X = Pos Int | Eval Eval Int Int | EvalRow Eval Int- deriving (Eq, Ord, Show)--data Eval = CorrectPlace | CorrectSymbol- deriving (Eq, Ord, Show)--type Assign a = ESC.Assign [(Int, a)] (Set X)--assignsFromGuesses ::+consistentCodesRnd :: (Ord a) =>- Int -> [a] -> [([a], (Int,Int))] -> [Assign a]-assignsFromGuesses width set guesses =- liftM2- (\pat a ->- let ks = map fst $ filter snd $ zip [0..] pat- in ESC.assign (map (flip (,) a) ks) $ Set.unions $- Set.fromList (map Pos ks) :- zipWith- (\row (guess,_) ->- Set.fromList $- let (correctlyPlaced, remGuess) =- ListHT.partition (\(_k, (used,equ)) -> used && equ) $- zip [0..] $ zip pat $ map (a==) guess- in map (Eval CorrectPlace row . fst) correctlyPlaced- ++- map (Eval CorrectSymbol row . fst)- (Match.take- (filter (fst . snd) remGuess)- (filter (snd . snd) remGuess)))- [0..] guesses)- (tail $ replicateM width [False, True]) set- ++- concat- (zipWith- (\row (_, (correctPlaces,correctSymbols)) ->- let fill eval k =- map (ESC.assign [] . Set.fromList . (EvalRow eval row :)) $- choose (width - k) $- map (Eval eval row) $ take width [0..]- in fill CorrectPlace correctPlaces- ++- fill CorrectSymbol correctSymbols)- [0..] guesses)---codeFromLabels :: [[(Int, a)]] -> [a]-codeFromLabels mxs =- case concat mxs of- xs -> Array.elems $ Array.array (0, length xs - 1) xs+ AssignFlags -> Int -> [a] -> [([a], EvalSumm)] -> MS.State StdGen [[a]]+consistentCodesRnd flags width alphabet guesses =+ return . map codeFromLabels . ESC.partitions+ =<< Random.intSetFromSetAssigns+ =<< (Random.shuffle $ assignsFromGuesses flags width alphabet guesses) -unique :: (Ord a) => [a] -> Bool-unique xs = Set.size (Set.fromList xs) == length xs--newGuess ::+newGuess, newGuessMatching, newGuessRandom :: (Ord a) =>- Int -> [a] -> [([a], (Int,Int))] -> MS.State StdGen (Maybe [a])-newGuess width alphabet oldGuesses = do- n <- MS.state $ randomR (1,1000)- return $ fmap snd $ viewR $ take n $--- filter unique $- map codeFromLabels $ ESC.partitions $- assignsFromGuesses width alphabet oldGuesses+ AssignFlags -> Int -> [a] -> [([a], EvalSumm)] -> MS.State StdGen (Maybe [a])+newGuess = newGuessRandom -countEval :: MS.State String (Int, Int)-countEval =- let count c = fmap length $ MS.state $ ListHT.partition (c==)- in liftM2 (,) (count 'x') (count 'o')+{-+Only guess codes that are consistent with all previously tried codes.+This can lead to overly long guess sequences like+@"master", "mastex", "mastey", "mastez"@ at the end of the game.+-}+newGuessMatching flags width alphabet oldGuesses =+ listToMaybe <$> consistentCodesRnd flags width alphabet oldGuesses -{- |-In every round the computer player selects randomly one of the first 1000 codes-that are coherent with the known evaluations.+{-+Start with random guesses and use matching guesses only at the end of the game.+In order to make the attempts not obviously stupid+we rule out elements from attempts with empty evaluations+and stop searching for elements after an attempt with full evaluation.+When we have acquired enough information to match the number of possible codes+or when we reach a full evaluation,+we switch to guessing consistent codes.++As a consistent guess we use the first solution+generated from randomly shuffled assignments with a randomly shuffled alphabet. This strategy prevents stupid guesses like "aaaaa", but it does not minimize the number of guesses. When the game approaches the end@@ -113,48 +93,319 @@ It would be more efficient to use non-coherent guesses in this situation in order to rule out a whole bunch of candidates at once. -}+newGuessRandom flags width alphabet oldGuesses = do+ let numPossibleEvals = div ((width+1)*(width+2)) 2+ let numMoves =+ floor+ (logBase+ (fromIntegral numPossibleEvals) (fromIntegral $ length alphabet)+ * fromIntegral width :: Double)+ let maybeCompleteEval =+ List.find+ ((\(EvalSumm correctPlaces correctSymbols) ->+ correctPlaces + correctSymbols >= width) . snd) oldGuesses+ let excluded =+ foldMap (Set.fromList . fst) $+ filter ((EvalSumm 0 0 ==) . snd) oldGuesses+ let restricted =+ case maybeCompleteEval of+ Just (code, _) -> Set.toList $ Set.fromList code+ Nothing -> filter (flip Set.notMember excluded) alphabet+ if null restricted+ then return Nothing+ else+ if length oldGuesses < numMoves && isNothing maybeCompleteEval+ then+ let arr = Array.listArray (0, length restricted - 1) restricted+ in fmap Just $ replicateM width $ fmap (arr Array.!) $+ MS.state $ randomR $ Array.bounds arr+ else newGuessMatching flags width restricted oldGuesses++formatEval :: EvalSumm -> String+formatEval (EvalSumm correctPlaces correctSymbols) =+ replicate correctPlaces 'x' ++ replicate correctSymbols 'o'++formatEvalGuess :: (Show code) => (code, EvalSumm) -> String+formatEvalGuess (guess, eval) = show guess ++ ' ' : formatEval eval++ interaction :: Int -> [Char] -> IO () interaction width alphabet =- let go guesses g0 =- case MS.runState (newGuess width alphabet guesses) g0 of- (Nothing, _) -> putStrLn "contradicting evaluations"+ let flags = defaultAssignFlags+ go guesses g0 =+ case MS.runState (newGuess flags width alphabet guesses) g0 of+ (Nothing, _) -> do+ putStrLn "Contradicting evaluations!"+ putStr "Please enter your secret code "+ putStrLn "and I will show you the corrected evaluations:"+ secret <- getLine+ forM_ (reverse guesses) $ \(guess,eval) ->+ let correctEval = evaluate secret guess+ in when (correctEval /= eval) $ putStrLn $+ formatEvalGuess (guess, correctEval) (Just attempt, g1) -> do putStr $ show attempt ++ " " IO.hFlush IO.stdout- eval0 <- getLine- let ((numPlaces, numSymbols), evalRem) =- MS.runState countEval eval0+ (eval@(EvalSumm numPlaces _numSymbols), evalRem)+ <- MS.runState countEval <$> getLine when (not $ null evalRem) (putStrLn $ "ignoring: " ++ evalRem) if numPlaces >= width then putStrLn "Code found!"- else go ((attempt, (numPlaces, numSymbols)) : guesses) g1+ else go ((attempt, eval) : guesses) g1 in go [] =<< getStdGen -testGuesses :: [(String, (Int, Int))]-testGuesses =- map (mapSnd (MS.evalState countEval)) $- ("aaaayw", "x") :- ("bbbdcw", "") :- ("eefeym", "oo") :- ("iuzamf", "oo") :- ("gvarfe", "ooo") :- ("paqfes", "xxo") :- ("vamsej", "ooxx") :- ("amgses", "ooox") :- ("majgep", "xxx") :- []--testSolve :: IO ()-testSolve =- mapM_ (print . codeFromLabels) $ ESC.partitions $- assignsFromGuesses 6 ['a'..'z'] testGuesses---main :: IO ()-main = do+mainGame :: IO ()+mainGame = do let n = 5 putStrLn $ "Come up with a word consisting of " ++ show n ++ " letters and evaluate my guesses." putStrLn "Enter 'x's for correct places and 'o's for correct symbols in any order." interaction n ['a'..'z']+++testSolve :: IO ()+testSolve =+ mapM_ print $ consistentCodes defaultAssignFlags 6 ['a'..'z'] $+ Example.guesses_ Example.master+++mainDistinguishing :: IO ()+mainDistinguishing =+ let codes =+ case 4::Int of+ 0 -> ["abcd", "abce", "abcf"]+ 1 -> ["abcdef", "abcdeg", "abcdeh"]+ 2 -> ["master", "puzzle", "bubble", "flight", "people"]+ 3 -> ["iuzamf", "gvarfe", "paqfes", "vamsej", "amgses", "majgep"]+ _ -> ["hlskoel", "hoskell", "hlskoll", "klosehl"]++ in mapM_ print $ take 10 $+ distinguishingCodesCondensed defaultAssignFlags+ (length $ head codes) ['a'..'z'] codes++{-+mainDistinguishing for ["hlskoel", "hoskell", "hlskoll", "klosehl"]:++("koellhs",[EvalSumm 0 7,EvalSumm 1 6,EvalSumm 0 6,EvalSumm 2 5])+("kolelhs",[EvalSumm 0 7,EvalSumm 1 6,EvalSumm 0 6,EvalSumm 2 5])+("eolslhk",[EvalSumm 0 7,EvalSumm 1 6,EvalSumm 0 6,EvalSumm 2 5])+("kolslhe",[EvalSumm 0 7,EvalSumm 1 6,EvalSumm 0 6,EvalSumm 3 4])+("kollshe",[EvalSumm 0 7,EvalSumm 1 6,EvalSumm 0 6,EvalSumm 2 5])+("sklleho",[EvalSumm 0 7,EvalSumm 1 6,EvalSumm 0 6,EvalSumm 2 5])+("kslleho",[EvalSumm 0 7,EvalSumm 1 6,EvalSumm 0 6,EvalSumm 3 4])+("khlleso",[EvalSumm 0 7,EvalSumm 1 6,EvalSumm 0 6,EvalSumm 2 5])+("kslleoh",[EvalSumm 0 7,EvalSumm 1 6,EvalSumm 0 6,EvalSumm 2 5])+("khlleos",[EvalSumm 0 7,EvalSumm 1 6,EvalSumm 0 6,EvalSumm 2 5])+-}+++haskellCodes :: [String]+haskellCodes =+ "hoskell" : "hlskoel" : "hlskoll" : "klosehl" :+ "hpskell" : "hlskpel" : "hlskpll" : "klpsehl" :+ "haskell" : "hlskael" : "hlskall" : "klasehl" :+ "heskell" : "hlsksel" : "hlsksll" : "klesehl" :+ "hsskell" :+ []++groupSizesByEval :: (Ord a) => [[a]] -> [([a], Int)]+groupSizesByEval codes =+ decorate (Fold.maximum . histogram . flip map codes . evaluate) $+ replicateM (length $ head codes) $+ Set.toList $ foldMap Set.fromList codes++decorate :: (a -> b) -> [a] -> [(a, b)]+decorate f = map (\x -> (x, f x))++{- |+Return all elements that have minimal 'b'.+-}+allMinima :: (Ord b) => [(a,b)] -> ([a],b)+allMinima [] = error "allMinima: empty list"+allMinima ((a,b):abs_) =+ let go as0 b0 [] = (reverse as0, b0)+ go as0 b0 ((a1,b1):abs1) =+ case compare b1 b0 of+ LT -> go [a1] b1 abs1+ EQ -> go (a1:as0) b1 abs1+ GT -> go as0 b0 abs1+ in go [a] b abs_++-- cf. board-games:Mastermind+mainBestSeparation :: IO ()+mainBestSeparation = do+ let codes = haskellCodes+ let (distCodes, groupSize) = allMinima $ groupSizesByEval codes+ mapM_ print distCodes+ let distCode = head distCodes+ void $ printf "%s, max group size %d\n" distCode groupSize+ mapM_ (putStrLn . formatEvalGuess) $ decorate (evaluate distCode) codes+++data Step a b c =+ Attempt a+ | Complete b+ | Fail c++data Choice = None | Unique | Multiple++indentTree ::+ ESC.Tree label set ->+ [([Int], Step ((Choice, set), label, [label]) [label] (set, [label]))]+indentTree =+ let go numbers labels tree =+ case tree of+ ESC.Leaf -> [(numbers, Complete labels)]+ ESC.Branch set subTrees ->+ case subTrees of+ [(label,subTree)] ->+ (numbers, Attempt ((Unique, set), label, label:labels)) :+ go numbers (label:labels) subTree+ [] -> [(numbers, Fail (set, labels))]+ _ ->+ concatMap+ (\(k, (label,subTree)) ->+ (k:numbers,+ Attempt ((Multiple, set), label, label:labels)) :+ go (k:numbers) (label:labels) subTree) $+ zip [1 ..] subTrees+ in go [] []++formatElement :: Guess.X Char -> String+formatElement x =+ case x of+ Guess.EvalSymbol (Guess.Pos (Column col)) ->+ printf "symbol at position %d" col+ Guess.EvalSymbol (Guess.Eval eval (Row row) (Column col)) ->+ printf+ "choice whether a %s marker is at (%d,%d) or elsewhere"+ (Guess.nameFromEval $ Just eval) row col+ Guess.EvalSymbol (Guess.Symbol symbol) ->+ printf "way of placing symbol '%c'" symbol+ Guess.EvalRow eval (Row row) ->+ printf "way of placing %s markers in row %d"+ (Guess.nameFromEval $ Just eval) row+ Guess.EvalReserve (Row row) (Column col) ->+ printf+ ("choice between correct place, " +++ "correct symbol or no marker at (%d,%d)")+ row col++formatReason :: (Choice, Set (Guess.X Char)) -> String+formatReason (choice, set) =+ let uniqueStr =+ case choice of+ None -> "no possible"+ Unique -> "unique"+ Multiple -> "try"+ in case Set.toList set of+ [x] -> uniqueStr ++ " " ++ formatElement x+ _ -> error "reason set must be a singleton"++formatLabel :: Int -> Guess.Label Char -> String+formatLabel width label =+ case label of+ Left (Row row, eval, pattern) ->+ printf "pattern %s for %ss in row %d"+ (Guess.formatPattern eval pattern) (Guess.nameFromEval eval) row+ Right symbols ->+ "place symbols " ++ partialCodeFromLabels width [symbols]++evalMapFromLabel :: (Row, Maybe Eval, [Bool]) -> Map (Row,Column) (Maybe Eval)+evalMapFromLabel (row, eval, pattern) =+ Map.fromList $ map (\(col,_true) -> ((row,col), eval)) $+ filter snd $ zip [Column 0 ..] pattern++partialCodeFromLabels :: Int -> [[(Column, Char)]] -> String+partialCodeFromLabels width xss =+ Array.elems $+ Array.listArray (Column 0, Column (width - 1)) (repeat '_')+ Array.//+ concat xss++formatPatterns :: [(String, EvalSumm)] -> [Guess.Label Char] -> String+formatPatterns guesses labels =+ let (patternLabels, codeLabels) = ListHT.unzipEithers labels+ m = fmap Guess.charFromEval $ foldMap evalMapFromLabel patternLabels+ width = maximum $ map (length . fst) guesses+ in unlines $+ zipWith+ (\row (guess,_eval) ->+ guess ++ ' ' :+ (map (\col -> Map.findWithDefault '_' (row,col) m) $+ Match.take guess [Column 0 ..]))+ [Row 0 ..] guesses+ +++ ["", partialCodeFromLabels width codeLabels]+++{-+ assignsFromMatchingCodes defaultAssignFlags 6 ['a'..'z']+ ["iuzamf", "gvarfe", "paqfes", "vamsej", "amgses"] -- , "majgep"]+-}+++mainIntSet :: IO ()+mainIntSet = do+ let example = Example.haskell+ mapM_ (putStrLn . Guess.codeFromLabels) $ ESC.partitions $+ ESC.intSetFromSetAssigns $ Example.apply assignsFromGuesses example++mainUArray :: IO ()+mainUArray = do+ let example = Example.cover+ mapM_ (putStrLn . Guess.codeFromLabels) $ ESC_UArray.partitions $+ Example.apply assignsFromGuesses example++mainConsistent :: IO ()+mainConsistent = print $ Example.apply consistentCodes Example.cover++mainSolutions :: IO ()+mainSolutions = do+ let example = Example.cafe+ mapM_ (putStrLn . formatPatterns (Example.guesses_ example)) $+ ESC.partitions $ Example.apply assignsFromGuesses example++mainTree :: IO ()+mainTree = do+ let example = Example.cafe+ width = Example.width_ example+ guesses = Example.guesses_ example+ asns = Example.apply assignsFromGuesses example++ forM_ (indentTree $ ESC.decisionTree asns) $ \(numbers, msg) ->+ putStrLn $+ (intercalate "." $ map show $ reverse numbers)+ +++ (case msg of+ Attempt (reason,label,_) ->+ ": " ++ formatLabel width label +++ " - " ++ formatReason reason+ Complete labels -> "\n\n" ++ formatPatterns guesses labels+ Fail (reason,_) ->+ ": failed because " ++ formatReason (None,reason))++mainDetail :: IO ()+mainDetail = do+ let example = Example.cafe+ width = Example.width_ example+ guesses = Example.guesses_ example+ asns = Example.apply assignsFromGuesses example++ forM_ (indentTree $ ESC.decisionTree asns) $ \(numbers, msg) ->+ putStrLn $+ (intercalate "." $ map show $ reverse numbers)+ +++ (case msg of+ Attempt (reason,label,labels) ->+ ": " ++ formatLabel width label +++ " - " ++ formatReason reason ++ "\n\n" +++ formatPatterns guesses labels+ Complete _labels -> " - completed\n"+ Fail (reason,_) ->+ ": failed because " ++ formatReason (None,reason) ++ "\n")+++main :: IO ()+main = mainGame
+ example/Mastermind/Benchmark.hs view
@@ -0,0 +1,88 @@+module Main where++import qualified Mastermind.Test as Test++import qualified Test.QuickCheck as QC+import System.TimeIt (timeIt)++import Data.Foldable (forM_, )+++main :: IO ()+main =+ forM_ Test.tests $ \(name, (_count, prop)) -> do+ putStr $ name ++ ": "+ timeIt $ QC.quickCheckWith (QC.stdArgs {QC.maxSuccess = 1000}) prop++{-+Shorter times without UseSymbol are a bit misleading,+because the ten selected consistentCodes may contain duplicates.++let n = 4+let set = ['a'..'k']+fromList []++++ OK, passed 1000 tests.+CPU time: 7.36s++++ OK, passed 1000 tests.+CPU time: 44.06s+fromList [UseSymbolPos]++++ OK, passed 1000 tests.+CPU time: 21.70s++++ OK, passed 1000 tests.+CPU time: 134.35s+fromList [UseSymbol]++++ OK, passed 1000 tests.+CPU time: 12.89s++++ OK, passed 1000 tests.+CPU time: 38.74s+fromList [UseSymbol,UseSymbolPos]++++ OK, passed 1000 tests.+CPU time: 33.16s++++ OK, passed 1000 tests.+CPU time: 81.25s++fromList [UniqueSymbol]++++ OK, passed 1000 tests.+CPU time: 0.88s++++ OK, passed 1000 tests.+CPU time: 14.94s+fromList [UniqueSymbol,UseSymbolPos]++++ OK, passed 1000 tests.+CPU time: 58.38s++++ OK, passed 1000 tests.+CPU time: 266.46s+fromList [UniqueSymbol,UseSymbol]++++ OK, passed 1000 tests.+CPU time: 1.34s++++ OK, passed 1000 tests.+CPU time: 9.20s+fromList [UniqueSymbol,UseSymbol,UseSymbolPos]++++ OK, passed 1000 tests.+CPU time: 44.60s++++ OK, passed 1000 tests.+CPU time: 66.19s+-}++{-+With EvalRow (Maybe Eval) we get:+fromList []++++ OK, passed 1000 tests.+CPU time: 7.89s++++ OK, passed 1000 tests.+CPU time: 41.88s+fromList [UseSymbol]++++ OK, passed 1000 tests.+CPU time: 10.57s++++ OK, passed 1000 tests.+CPU time: 33.61s+fromList [UniqueSymbol]++++ OK, passed 1000 tests.+CPU time: 0.95s++++ OK, passed 1000 tests.+CPU time: 16.23s+fromList [UniqueSymbol,UseSymbol]++++ OK, passed 1000 tests.+CPU time: 1.44s++++ OK, passed 1000 tests.+CPU time: 9.08s+-}
+ example/Mastermind/Distinguish.hs view
@@ -0,0 +1,130 @@+module Mastermind.Distinguish where++import Mastermind.Guess (+ assignsFromCodeSymbols,+ Eval(CorrectPlace, CorrectSymbol),+ Row(Row), Column(Column),+ AssignFlags,+ EvalSumm(EvalSumm),+ EvalSymbol(Eval),+ )++import qualified Math.SetCover.Exact as ESC++import Control.Monad (replicateM, )++import qualified Data.Set as Set; import Data.Set (Set, )+import qualified Data.Array as Array+import qualified Data.List.Match as Match+import qualified Data.List.HT as ListHT+import qualified Data.List as List+import Data.Tuple.HT (mapPair, )+import Data.Foldable (foldMap, )+import Data.Ord.HT (comparing, )++++data X a = EvalSymbol (EvalSymbol a) | EvalRow Row | EvalSummary EvalSumm+ deriving (Eq, Ord, Show)++type Assign a = ESC.Assign (Either [(Column, a)] (Row, EvalSumm)) (Set (X a))++{-+The solver is pretty slow with these assignments.+E.g. for the codes @["abw", "abx", "aby", "abz"]@+there cannot be a distinguishing code,+so there cannot be one for @["abcw", "abcx", "abcy", "abcz"]@.+However, the solver cannot draw this conclusion by itself.+Another example:+The evaluation summary @EvalSumm (width-1) 1@ is impossible.+The solver should detect this automatically.++Maybe it is possible to assist the solver with redundant information+that the evaluations must be pairwise distinct+and even more must be pairwise and pointwise distinct.+However, the example above shows that searching for a distinguishing code+might be of limited utility after all.+-}+assignsFromMatchingCodes ::+ (Ord a) => AssignFlags -> Int -> [a] -> [[a]] -> [Assign a]+assignsFromMatchingCodes flags width set codes =+ map+ (\(ESC.Assign label sym) ->+ ESC.Assign (Left label) (Set.map EvalSymbol sym))+ (assignsFromCodeSymbols flags width set codes)+ +++ concat+ (map+ (\row ->+ map+ (\xs ->+ let fill eval =+ mapPair+ (length,+ map (EvalSymbol . Eval eval row . fst)) $+ ListHT.partition ((Just eval ==) . snd) $+ zip [Column 0 ..] xs+ (correctPlaces, remPlaces) = fill CorrectPlace+ (correctSymbols, remSymbols) = fill CorrectSymbol+ evalSumm = EvalSumm correctPlaces correctSymbols+ in ESC.assign (Right (row, evalSumm)) . Set.fromList $+ EvalRow row : EvalSummary evalSumm :+ remPlaces ++ remSymbols) $+ replicateM width [Nothing, Just CorrectPlace, Just CorrectSymbol]) $+ Match.take codes [Row 0 ..])+ +++ (do correctPlaces <- [0..width]+ correctSymbols <- [0..width-correctPlaces]+ return . ESC.assign (Left []) . Set.singleton $+ EvalSummary $ EvalSumm correctPlaces correctSymbols)+++{- |+For a given list of codes,+find a guess that has different evaluations with respect to all of these codes.+If we know at a certain point in the game+that there is only a small number of possible codes left,+we can use this procedure to find a guess that solves the puzzle immediately.+E.g. @distinguishingCodes 6 ['a'..'z'] ["master", "puzzle", "bubble"] == [..., "jalbay", ...]@+because @map (eval "jalbay") ["master", "puzzle", "bubble"] == [Eval 0 1, Eval 1 0, Eval 1 1]@++Problem:+For 4 6-letter codes the solution takes several seconds,+for more letters it does not finish within an hour.+Thus this approach is not practical.++Example:+There is no distinguishing code for @["abcdew", "abcdex", "abcdey", "abcdez"]@,+but the solver does not detect that in reasonable time.++If we would not only have a list of codes+but also a corresponding list of evaluations+the problem would boil down to the one addressed by 'assignsFromGuesses'.+-}+distinguishingCodes ::+ (Ord a) => AssignFlags -> Int -> [a] -> [[a]] -> [([a], [EvalSumm])]+distinguishingCodes flags width set codes =+ map (mapPair (codeFromLabels, map snd . List.sortBy (comparing fst)) .+ ListHT.unzipEithers) $+ ESC.partitions $ ESC.intSetFromSetAssigns $+ assignsFromMatchingCodes flags width set codes++{- |+Replace all unused symbols by a single one,+because unused symbols behave the same way with respect to the @codes@.+This returns a shorter list of codes but is also much faster.+-}+distinguishingCodesCondensed ::+ (Ord a) => AssignFlags -> Int -> [a] -> [[a]] -> [([a], [EvalSumm])]+distinguishingCodesCondensed flags width set codes =+ let unused =+ Set.deleteMin $ Set.difference (Set.fromList set) $+ foldMap Set.fromList codes+ in distinguishingCodes flags width+ (filter (flip Set.notMember unused) set) codes+++codeFromLabels :: [[(Column, a)]] -> [a]+codeFromLabels mxs =+ case concat mxs of+ xs -> Array.elems $ Array.array (Column 0, Column (length xs - 1)) xs
+ example/Mastermind/Example.hs view
@@ -0,0 +1,118 @@+module Mastermind.Example where++import Mastermind.Guess (+ countEval,+ defaultAssignFlags,+ AssignFlag(UniqueSymbol),+ AssignFlags,+ EvalSumm(EvalSumm),+ )+++import qualified Control.Monad.Trans.State as MS++import qualified Data.EnumSet as EnumSet+import Data.Tuple.HT (mapSnd)+++data T a =+ Cons {+ flags_ :: AssignFlags,+ width_ :: Int,+ alphabet_ :: [a],+ guesses_ :: [([a], EvalSumm)]+ }++consDup, consUnique :: [a] -> [([a], EvalSumm)] -> T a+consDup set guesses =+ let width = maximum $ map (length . fst) guesses+ in Cons defaultAssignFlags width set guesses++consUnique set guesses =+ case consDup set guesses of+ ex -> ex {flags_ = EnumSet.insert UniqueSymbol $ flags_ ex}++apply ::+ (AssignFlags -> Int -> [a] -> [([a], EvalSumm)] -> b) -> T a -> b+apply f (Cons flags width set guesses) = f flags width set guesses+++cover :: T Char+cover =+ consDup ['a'..'z'] $+ ("prxyt", EvalSumm 0 1) :+ ("smbjy", EvalSumm 0 0) :+ ("krpcu", EvalSumm 0 2) :+ ("ccxlz", EvalSumm 1 0) :+ ("rltxk", EvalSumm 0 1) :+ ("epakz", EvalSumm 0 1) :+ ("acivr", EvalSumm 1 2) :+ ("cqqar", EvalSumm 2 0) :+ ("cfver", EvalSumm 4 0) :+ ("wnhgd", EvalSumm 0 0) :+ []++coverContra :: T Char+coverContra =+ cover{+ guesses_ = ("ocver", EvalSumm 3 0) : guesses_ cover+ }++cafe :: T Char+cafe =+ consUnique ['a'..'f'] $+ ("cbad", EvalSumm 1 1) :+ ("fbec", EvalSumm 0 3) :+ ("beaf", EvalSumm 0 3) :+ []++master :: T Char+master =+ consDup ['a'..'z'] $+ map (mapSnd (MS.evalState countEval)) $+ ("aaaayw", "x") :+ ("bbbdcw", "") :+ ("eefeym", "oo") :+ ("iuzamf", "oo") :+ ("gvarfe", "ooo") :+ ("paqfes", "xxo") :+ ("vamsej", "ooxx") :+ ("amgses", "ooox") :+ ("majgep", "xxx") :+ []++haskell :: T Char+haskell =+ consDup ['a'..'z'] $+ map (mapSnd (MS.evalState countEval)) $+ ("dkryqnx", "o") :+ ("dcyuyjj", "") :+ ("bxfbrsf", "o") :+ ("hgqmihi", "x") :+ ("itkwkkm", "o") :+ ("ixzrlkk", "oo") :+ ("kgslggl", "xxoo") :+ ("ggglvxw", "o") :+ ("llskehl", "xxxxoo") :+ []++no00, no01, no02, no03, no04 :: T Char+no00 =+ consDup ['a'..'f'] $+ ("adab", EvalSumm 0 0) :+ []++no01 =+ consDup ['a'..'c'] $+ ("aaab", EvalSumm 1 1) :+ []++no02 =+ consDup ['a'..'f'] $+ ("ffce", EvalSumm 1 2) :+ ("dade", EvalSumm 2 0) :+ ("dcfe", EvalSumm 2 1) :+ []++no03 = consDup ['a'..'c'] [("ab", EvalSumm 1 0)]+no04 = consDup ['a'..'c'] [("ab", EvalSumm 1 1)]
+ example/Mastermind/Guess.hs view
@@ -0,0 +1,244 @@+module Mastermind.Guess where++import Mastermind.Utility (histogram)++import qualified Math.SetCover.Exact as ESC++import qualified Control.Monad.Trans.State as MS+import Control.Monad (liftM2, replicateM, guard, )++import qualified Data.EnumSet as EnumSet; import Data.EnumSet (EnumSet, )+import qualified Data.Map as Map+import qualified Data.Set as Set; import Data.Set (Set, )+import qualified Data.Foldable as Fold+import qualified Data.Array as Array+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.Tuple.HT (mapPair, )+import Data.Maybe.HT (toMaybe)+import Data.Traversable (forM, )+++data EvalSymbol a = Pos Column | Eval Eval Row Column | Symbol a+ deriving (Eq, Ord, Show)++data Eval = CorrectPlace | CorrectSymbol+ deriving (Eq, Ord, Show)+++newtype Row = Row Int deriving (Eq, Ord, Show)++instance Enum Row where+ toEnum = Row+ fromEnum (Row k) = k+++newtype Column = Column Int deriving (Eq, Ord, Show, Array.Ix)++instance Enum Column where+ toEnum = Column+ fromEnum (Column k) = k+++{- |+* 'UniqueSymbol': Only consider codes where every symbol is unique.++* 'UseSymbol': Avoid duplicates in 'consistentCodes'. See below.++> *Main> consistentCodes EnumSet.empty 2 ['a'..'b'] []+> ["aa","ab","ba","bb","aa","bb"]+> *Main> consistentCodes (EnumSet.singleton UseSymbol) 2 ['a'..'b'] []+> ["ab","ba","aa","bb"]+-}+data AssignFlag = UniqueSymbol | UseSymbol+ deriving (Eq, Ord, Show, Enum)++type AssignFlags = EnumSet AssignFlag++defaultAssignFlags :: AssignFlags+defaultAssignFlags = EnumSet.fromList [UseSymbol]++allFlagSets :: [AssignFlags]+allFlagSets = [EnumSet.empty, EnumSet.singleton UseSymbol]++assignsFromCodeSymbols ::+ (Ord a) =>+ AssignFlags ->+ Int -> [a] -> [[a]] -> [ESC.Assign [(Column, a)] (Set (EvalSymbol a))]+assignsFromCodeSymbols flags width set codes =+ let uniqueSymbol = EnumSet.member UniqueSymbol flags+ useSymbol = EnumSet.member UseSymbol flags+ in+ liftM2+ (\pat a ->+ let ks = map fst $ filter snd $ zip [Column 0 ..] pat+ in ESC.assign (map (flip (,) a) ks) $ Set.unions $+ Mn.when useSymbol (Set.singleton (Symbol a)) :+ Set.fromList (map Pos ks) :+ zipWith+ (\row code ->+ Set.fromList $+ let (correctlyPlaced, remCode) =+ ListHT.partition (\(_k, (used,equ)) -> used && equ) $+ zip [Column 0 ..] $ zip pat $ map (a==) code+ in map (Eval CorrectPlace row . fst) correctlyPlaced+ +++ map (Eval CorrectSymbol row . fst)+ (Match.take+ (filter (fst . snd) remCode)+ (filter (snd . snd) remCode)))+ [Row 0 ..] codes)+ ((if useSymbol then id else tail) $+ if uniqueSymbol+ then take (width+1) $ map (take width) $+ scanl (flip (:)) (repeat False) (True : repeat False)+ else replicateM width [False, True])+ set+++{-+For correctness,+'X' would not need the 'Symbol' constructor and the type parameter @a@.+I.e. it would not need any reference to symbols.+For every symbol, @Set X@ describes its distribution pattern across all guesses.+-}+data X a = EvalSymbol (EvalSymbol a) | EvalReserve Row Column | EvalRow Eval Row+ deriving (Eq, Ord, Show)++type Label a = Either (Row, Maybe Eval, [Bool]) [(Column, a)]+type Assign a = ESC.Assign (Label a) (Set (X a))++data EvalSumm = EvalSumm Int Int deriving (Eq, Ord, Show)++{-+For every symbol and every distribution pattern within a code+@assignsFromCodeSymbols@ computes the resulting evaluation pins+bound to according positions.+The second part (@concat@) marks the possible positions+by filling out the remaining positions with @EvalSymbol (Eval eval row colum)@.+@EvalReserve@ is used to avoid use of a position+for both correctly placed and wrongly placed symbols.+Without this mechanism we get this bug:++> Main> take 10 $ consistentCodes 2 ['a'..'c'] [("ab", EvalSumm 1 1)]+> ["aa","bb"]+-}+assignsFromGuesses ::+ (Ord a) => AssignFlags -> Int -> [a] -> [([a], EvalSumm)] -> [Assign a]+assignsFromGuesses flags width set guesses =+ map+ (\(ESC.Assign label sym) ->+ ESC.Assign (Right label) (Set.map EvalSymbol sym))+ (assignsFromCodeSymbols flags width set $ map fst guesses)+ +++ concat+ (zipWith+ (\row (_, EvalSumm correctPlaces correctSymbols) ->+ let fill eval k =+ map+ (\pattern ->+ ESC.assign (Left (row, Just eval, pattern)) .+ Set.fromList . (EvalRow eval row :) .+ uncurry (++) .+ mapPair+ (map (EvalReserve row . fst),+ map (EvalSymbol . Eval eval row . fst)) .+ ListHT.partition snd . zip [Column 0 ..] $ pattern) $+ choose width k+ in fill CorrectPlace correctPlaces+ +++ fill CorrectSymbol correctSymbols+ +++ map+ (\pattern ->+ ESC.assign (Left (row, Nothing, pattern)) .+ Set.fromList .+ map (EvalReserve row . fst) .+ filter snd . zip [Column 0 ..] $ pattern)+ (choose width (width-correctPlaces-correctSymbols)))+ [Row 0 ..] guesses)++nameFromEval :: Maybe Eval -> String+nameFromEval eval =+ case eval of+ Nothing -> "wrong symbol"+ Just CorrectSymbol -> "correct symbol"+ Just CorrectPlace -> "correct place"++countEval :: MS.State String EvalSumm+countEval =+ let count c = fmap length $ MS.state $ ListHT.partition (c==)+ in liftM2 EvalSumm (count 'x') (count 'o')++charFromEval :: Maybe Eval -> Char+charFromEval eval =+ case eval of+ Nothing -> '.'+ Just CorrectSymbol -> 'o'+ Just CorrectPlace -> 'x'++formatPattern :: Maybe Eval -> [Bool] -> String+formatPattern eval =+ let char = charFromEval eval+ in map (\b -> if b then char else '_')++-- cf. combinatorial:Combinatorics.choose+choose :: Int -> Int -> [[Bool]]+choose n0 k0 =+ flip MS.evalStateT k0 $ do+ bits <-+ forM [n0,n0-1..1] $ \n ->+ MS.StateT $ \k ->+ guard (0<=k && k<=n) >> [(False, k), (True, pred k)]+ MS.gets (0==) >>= guard+ return bits+++codeFromLabels :: [Label a] -> [a]+codeFromLabels mxs =+ case concatMap (either (const []) id) mxs of+ xs -> Array.elems $ Array.array (Column 0, Column (length xs - 1)) xs+++consistentCodes ::+ (Ord a) => AssignFlags -> Int -> [a] -> [([a], EvalSumm)] -> [[a]]+consistentCodes flags width alphabet guesses =+ map codeFromLabels $ ESC.partitions $ ESC.intSetFromSetAssigns $+ assignsFromGuesses flags width alphabet guesses+++-- cf. board-games:Mastermind+evaluate :: (Ord a) => [a] -> [a] -> EvalSumm+evaluate code attempt =+ uncurry EvalSumm $+ mapPair+ (length,+ Fold.sum . uncurry (Map.intersectionWith min) .+ mapPair (histogram,histogram) . unzip) $+ ListHT.partition (uncurry (==)) $+ zip code attempt+++{-+These ones need exceptionally much time:++> mapM_ (putStrLn . formatEvalGuess) $ autoPlay ['a'..'z'] "maple"+> mapM_ (putStrLn . formatEvalGuess) $ autoPlay ['a'..'z'] "wheat"++With the UniqueSymbol flag it becomes fast, again:++> autoPlay (EnumSet.insert UniqueSymbol defaultAssignFlags)+-}+autoPlay :: (Ord a) => AssignFlags -> [a] -> [a] -> [([a], EvalSumm)]+autoPlay flags set secret =+ List.unfoldr+ (\guesses ->+ toMaybe (all ((secret/=) . fst) guesses) $+ case consistentCodes flags (length secret) set guesses of+ [] -> error "autoPlay: algorithm went wrong"+ guess:_ ->+ let evaluatedGuess = (guess, evaluate secret guess)+ in (evaluatedGuess, evaluatedGuess:guesses))+ []
+ example/Mastermind/Test.hs view
@@ -0,0 +1,83 @@+module Mastermind.Test where++import Mastermind.Guess (+ autoPlay,+ consistentCodes,+ evaluate,+ AssignFlag(UseSymbol, UniqueSymbol),+ AssignFlags, allFlagSets,+ EvalSumm(EvalSumm),+ )++import qualified Test.QuickCheck as QC++import Control.Monad (liftM2, )+import Control.Applicative ((<$>), )++import qualified Data.EnumSet as EnumSet+import qualified Data.List.HT as ListHT+import Data.Maybe (listToMaybe, )+++-- cf. board-games:Test.Mastermind+genEvalSumm :: Int -> QC.Gen EvalSumm+genEvalSumm width = do+ total <- QC.frequency $ map (\k -> (k+1, return k)) [1 .. width]+ rightPlaces <- QC.choose (0,total)+ return $ EvalSumm rightPlaces (total - rightPlaces)++genGuess :: Int -> [a] -> QC.Gen [a]+genGuess width set = QC.vectorOf width $ QC.elements set++genGuessUnique :: Int -> [a] -> QC.Gen [a]+genGuessUnique 0 _ = return []+genGuessUnique width set = do+ (x,xs) <- QC.elements $ ListHT.removeEach set+ (x:) <$> genGuessUnique (width-1) xs++genGuesses :: Int -> [a] -> QC.Gen [([a], EvalSumm)]+genGuesses width set =+ fmap (take 2) $ QC.listOf1 $+ liftM2 (,) (genGuessUnique width set) (genEvalSumm width)++genConsistentCode :: (Ord a) => AssignFlags -> Int -> [a] -> QC.Gen (Maybe [a])+genConsistentCode flags width set =+ listToMaybe . consistentCodes flags width set <$> genGuesses width set+++propConsistency ::+ (Ord a) => AssignFlags -> Int -> [a] -> [([a], EvalSumm)] -> Bool+propConsistency flags width set guesses =+ and $+ liftM2+ (\(guess,eval) candidate -> eval == evaluate guess candidate)+ guesses (take 10 $ consistentCodes flags width set guesses)++propAutoPlay :: (Ord a) => AssignFlags -> [a] -> [a] -> Bool+propAutoPlay flags set secret =+ fst (last (autoPlay flags set secret)) == secret+++tests :: [(String, (Int, QC.Property))]+tests =+ let n = 4+ set = ['a'..'k']+ forAll count gen = (,) count . QC.forAll gen+ formatFlags flags =+ if EnumSet.member UseSymbol flags+ then "UseSymbol"+ else "OmitSymbol"++ in (allFlagSets >>= \flags ->+ ("Duplicate.Consistency." ++ formatFlags flags,+ forAll 500 (genGuesses n set) (propConsistency flags n set)) :+ ("Duplicate.AutoPlay." ++ formatFlags flags,+ forAll 100 (genGuess n set) (propAutoPlay flags set)) :+ [])+ +++ (map (EnumSet.insert UniqueSymbol) allFlagSets >>= \flags ->+ ("Unique.Consistency." ++ formatFlags flags,+ forAll 1000 (genGuesses n set) (propConsistency flags n set)) :+ ("Unique.AutoPlay." ++ formatFlags flags,+ forAll 200 (genGuessUnique n set) (propAutoPlay flags set)) :+ [])
+ example/Mastermind/Utility.hs view
@@ -0,0 +1,11 @@+module Mastermind.Utility where++import qualified Data.Map as Map; import Data.Map (Map, )+++histogram :: (Ord a) => [a] -> Map a Int+histogram = Map.fromListWith (+) . attach 1++{-# INLINE attach #-}+attach :: b -> [a] -> [(a, b)]+attach a = map (flip (,) a)
+ example/MastermindKnead.hs view
@@ -0,0 +1,34 @@+module Main where++import qualified Mastermind.Example as Example+import qualified Mastermind.Guess as Guess+import Mastermind.Guess (assignsFromGuesses)++import qualified Math.SetCover.Exact.Knead.Saturated as ESC_KneadSat+import qualified Math.SetCover.Exact.Knead as ESC_Knead++import qualified System.IO.Lazy as LazyIO+++mainKnead :: IO ()+mainKnead = do+ let example = Example.haskell+ mapM_ (putStrLn . Guess.codeFromLabels) $ ESC_Knead.partitions $+ Example.apply assignsFromGuesses example++mainKneadIO :: IO ()+mainKneadIO = do+ let example = Example.master+ partit <- ESC_Knead.partitionsIO+ mapM_ (putStrLn . Guess.codeFromLabels) =<<+ (LazyIO.run $ partit $ Example.apply assignsFromGuesses example)++mainKneadVector :: IO ()+mainKneadVector = do+ let example = Example.haskell+ mapM_ (putStrLn . Guess.codeFromLabels) $ ESC_KneadSat.partitions $+ Example.apply assignsFromGuesses example+++main :: IO ()+main = mainKnead
example/Nonogram.hs view
@@ -12,24 +12,27 @@ import qualified Nonogram.Encoding.BlackWhite as BlackWhite import qualified Nonogram.Encoding.Plug as Plug import qualified Nonogram.Encoding.Naive as Naive-import Nonogram.Base (Strip, Color(White, Black))+import Nonogram.Base (Strip, Color(White, Black), ColorMap) import qualified Math.SetCover.Exact.Priority as ESC import qualified Math.SetCover.Exact as ESCS import qualified Math.SetCover.BitPosition as BitPos import qualified Math.SetCover.BitSet as BitSet+import qualified Math.SetCover.BitPriorityQueue as BitPQ import qualified Math.SetCover.Queue as Queue -import qualified Data.OrdPSQ as PSQ; import Data.OrdPSQ (OrdPSQ) import qualified Data.Map as Map; import Data.Map (Map) import qualified Data.Set as Set; import Data.Set (Set) import qualified Data.EnumMap as EnumMap import qualified Data.NonEmpty as NonEmpty import qualified Data.List.HT as ListHT+import Data.OrdPSQ (OrdPSQ) import Data.IntPSQ (IntPSQ) import Data.EnumSet (EnumSet)+import Data.IntSet (IntSet) import Data.Foldable (foldMap) import Data.NonEmpty ((!:))+import Data.Word (Word64) decode :: [[Int]] -> [[Int]] -> [Set (Int, Int)]@@ -78,7 +81,7 @@ (take rows [0..]) (take columns [0..]) -formatBW :: Int -> Int -> Map (Int, Int) Color -> String+formatBW :: Int -> Int -> ColorMap -> String formatBW rows columns set = unlines $ ListHT.outerProduct@@ -114,6 +117,59 @@ testImage :: IO () testImage = decodeImage $ Example.encodeStrings Example.letterP ++type Evolve queue set = ([[Int]], [[Int]]) -> [[ESC.State queue ColorMap set]]++evolveGen ::+ Queue.Methods queue set ->+ [ESCS.Assign ColorMap set] -> [[ESC.State queue ColorMap set]]+evolveGen methods assigns =+ takeWhile (not . null) $+ iterate+ (concatMap (ESC.step methods) .+ filter (not . Queue.null methods . ESC.queue))+ [ESC.initState methods assigns]++evolveQueueMapBW ::+ Evolve+ (OrdPSQ Strip Int (OrdPSQ BlackWhite.Item Int (EnumSet Queue.SetId)))+ (Map Strip (Set BlackWhite.Item))+evolveQueueMapBW = evolveGen queueMap . uncurry BlackWhite.assignsBW++evolveQueueMap ::+ Evolve+ (OrdPSQ Strip Int (OrdPSQ Combinatoric.Item Int (EnumSet Queue.SetId)))+ (Map Strip (Set Combinatoric.Item))+evolveQueueMap = evolveGen queueMap . uncurry Combinatoric.assignsBW++evolveQueueMapBit ::+ Evolve+ (OrdPSQ Strip Int (IntPSQ Int (EnumSet Queue.SetId)))+ (Map Strip (BitSet.Set Word64))+evolveQueueMapBit =+ evolveGen queueMapBit .+ Combinatoric.bitAssigns . uncurry Combinatoric.assignsBW++evolveQueueBitPQ ::+ Evolve (BitPQ.Queue Integer Queue.SetId) (BitSet.Set Integer)+evolveQueueBitPQ (rows, columns) =+ evolveGen ESC.queueBitPQ $+ Combinatoric.bitVectorAssigns (length rows) (length columns) $+ Combinatoric.assignsBW rows columns++evolveQueueBit ::+ Evolve (IntPSQ Int (EnumSet Queue.SetId)) (BitSet.Set Integer)+evolveQueueBit (rows, columns) =+ evolveGen ESC.queueBit $+ Combinatoric.bitVectorAssigns (length rows) (length columns) $+ Combinatoric.assignsBW rows columns++evolveQueueIntSet :: Evolve (IntPSQ Int (EnumSet Queue.SetId)) IntSet+evolveQueueIntSet (rows, columns) =+ evolveGen ESC.queueIntSet $+ Combinatoric.intSetAssigns (length rows) (length columns) $+ Combinatoric.assignsBW rows columns+ evolve :: ([[Int]], [[Int]]) -> IO () evolve (rows, columns) = let formatIntermediate state =@@ -122,9 +178,7 @@ Map.unionsWith (error "conflicting colors") . ESC.usedSubsets $ state) in mapM_ (putStrLn . besidesMany 2 . map formatIntermediate) $- fst $ ListHT.breakAfter (all (PSQ.null . ESC.queue)) $- iterate (concatMap (ESC.step queueMap))- [ESC.initState queueMap $ Combinatoric.assignsBW rows columns]+ evolveQueueMap (rows, columns) main :: IO () main = evolve Example.soccerEnc
example/Nonogram/Base.hs view
@@ -35,7 +35,9 @@ data Color = White | Black deriving (Eq, Ord, Show, Enum) +type ColorMap = Map (Int,Int) Color + noAssign :: (Monoid map) => set -> ESC.Assign map set noAssign = ESC.assign mempty @@ -67,5 +69,5 @@ 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 :: Int -> Int -> Color -> ColorMap squareBW r c = Map.singleton (r,c)
example/Nonogram/Encoding/BlackWhite.hs view
@@ -18,12 +18,13 @@ is combined with the space to the left and right border, respectively. -} module Nonogram.Encoding.BlackWhite- (assigns, assignsBW, bitAssigns, bitVectorAssigns) where+ (Item, assigns, assignsBW, bitAssigns, bitVectorAssigns) where import qualified Nonogram.Base as Base import Nonogram.Base (Strip(Strip), strip, BrickId(BrickId),- Orientation(Horizontal, Vertical), Color(White, Black), noAssign)+ Orientation(Horizontal, Vertical),+ Color(White, Black), ColorMap, noAssign) import qualified Math.SetCover.BitSet as BitSet import qualified Math.SetCover.Exact as ESC@@ -115,7 +116,7 @@ assigns :: [[Int]] -> [[Int]] -> [Assign (Set (Int,Int))] assigns = assignsGen Base.square -assignsBW :: [[Int]] -> [[Int]] -> [Assign (Map (Int,Int) Color)]+assignsBW :: [[Int]] -> [[Int]] -> [Assign ColorMap] assignsBW = assignsGen Base.squareBW
example/Nonogram/Encoding/Combinatoric.hs view
@@ -6,12 +6,12 @@ The solver tends to need very few guesses. -} module Nonogram.Encoding.Combinatoric- (assigns, assignsBW, bitAssigns, intSetAssigns, bitVectorAssigns) where+ (Item, assigns, assignsBW, bitAssigns, intSetAssigns, bitVectorAssigns) where import qualified Nonogram.Base as Base import Nonogram.Base (Strip(Strip), strip, Orientation(Horizontal, Vertical),- Color(White, Black), noAssign)+ Color(White, Black), ColorMap, noAssign) import qualified Math.SetCover.BitSet as BitSet import qualified Math.SetCover.Exact as ESC@@ -92,7 +92,7 @@ assigns :: [[Int]] -> [[Int]] -> [Assign (Set (Int,Int))] assigns = assignsGen Base.square -assignsBW :: [[Int]] -> [[Int]] -> [Assign (Map (Int,Int) Color)]+assignsBW :: [[Int]] -> [[Int]] -> [Assign ColorMap] assignsBW = assignsGen Base.squareBW @@ -113,7 +113,8 @@ intSetAssigns ::- Int -> Int -> [ESC.Assign map (Map Strip (Set Item))] -> [ESC.Assign map IntSet]+ Int -> Int ->+ [ESC.Assign map (Map Strip (Set Item))] -> [ESC.Assign map IntSet] intSetAssigns nr nc = map (fmap (fold . Map.mapWithKey (intSetFromItems nr nc)))
+ example/Random.hs view
@@ -0,0 +1,65 @@+module Random (intSetFromSetAssigns, shuffle) where++import Mastermind.Utility (attach)++import qualified Math.SetCover.Exact as ESC++import System.Random (StdGen, randomR, )++import qualified Control.Monad.Trans.State as MS+import Control.Applicative ((<$>), )++import qualified Data.Map as Map+import qualified Data.IntSet as IntSet+import qualified Data.Set as Set; import Data.Set (Set, )+import qualified Data.Sequence as Seq; import Data.Sequence (Seq, )+import Data.Tuple.HT (mapSnd, )+import Data.Monoid ((<>), )+++{- |+This is a variant of 'ESC.intSetFromSetAssigns'+that includes shuffling of elements.+This way, we can make 'consistentCodesRnd' prefer, say, symbol @z@ to @a@.+-}+intSetFromSetAssigns ::+ (Ord a) =>+ [ESC.Assign label (Set a)] ->+ MS.State StdGen [ESC.Assign label IntSet.IntSet]+intSetFromSetAssigns asns = do+ toMapInt <- mapIntFromSet asns+ let toIntSet = IntSet.fromList . Map.elems . toMapInt+ return $ map (fmap toIntSet) asns++-- cf. ESC+mapIntFromSet ::+ (Ord a) =>+ [ESC.Assign label (Set a)] -> MS.State StdGen (Set a -> Map.Map a Int)+mapIntFromSet asns = do+ mapToInt <-+ fmap (Map.fromList . flip zip [0..]) $+ shuffle $ Set.toList $ ESC.unions $ map ESC.labeledSet asns+ return $ Map.intersection mapToInt . constMap ()++-- SetCover.EnumMap+constMap :: (Ord a) => b -> Set.Set a -> Map.Map a b+constMap a = Map.fromAscList . attach a . Set.toAscList+++shuffle :: [a] -> MS.State StdGen [a]+shuffle = shuffleSeq . Seq.fromList++shuffleSeq :: Seq a -> MS.State StdGen [a]+shuffleSeq xs =+ if Seq.null xs+ then return []+ else do+ (y, ys) <- select xs+ (y:) <$> shuffleSeq ys++select :: Seq a -> MS.State StdGen (a, Seq a)+select xs = do+ k <- MS.state $ randomR (0, Seq.length xs - 1)+ case mapSnd Seq.viewl $ Seq.splitAt k xs of+ (_, Seq.EmptyL) -> error "Seq.size must have been zero"+ (ys, z Seq.:< zs) -> return (z, ys <> zs)
example/Soma.hs view
@@ -69,12 +69,12 @@ format :: [Map.Map PackedCoords Brick] -> String format v =- let wuerfelx = Map.unions v+ let cubex = Map.unions v in forNestedCoords unlines (intercalate " | ") (intercalate " ") (\c -> maybe "." (\(Brick n) -> show n) $- Map.lookup (packCoords size c) wuerfelx)+ Map.lookup (packCoords size c) cubex) size printMask :: [Map.Map PackedCoords Brick] -> IO ()@@ -121,18 +121,18 @@ testme1 = testme $ Brick 1 mainBase = do- let lsg = map (map ESC.label) $ nest (length shapes) (concatMap ew) [[]]- mapM_ printMask lsg- print $ length lsg+ let sol = map (map ESC.label) $ nest (length shapes) (concatMap ew) [[]]+ mapM_ printMask sol+ print $ length sol mainState = do- let lsg = ESC.partitions allAssigns- mapM_ printMask lsg- print $ length lsg+ let sol = ESC.partitions allAssigns+ mapM_ printMask sol+ print $ length sol mainBits = do- let lsg = ESC.partitions $ map (fmap packMask) allAssigns- mapM_ printMask lsg- print $ length lsg+ let sol = ESC.partitions $ map (fmap packMask) allAssigns+ mapM_ printMask sol+ print $ length sol main = mainBits
example/Sudoku.hs view
@@ -9,22 +9,32 @@ import Data.Word (Word32, Word64) +import qualified Control.Monad.Trans.State as MS import Control.Monad (liftM3, guard) +import qualified Random as Random+import System.Random (StdGen, getStdGen, )++import qualified Graphics.Ascii.Haha.Terminal as ANSI+import Text.Printf (printf)+ import qualified Data.Array as Array import qualified Data.Map as Map import qualified Data.Set as Set-import Data.Foldable (foldMap)-import Data.Array (array)+import Data.Foldable (foldMap, forM_)+import Data.Array (array, listArray)+import Data.IntSet (IntSet) import Data.Set (Set) import Data.List.HT (sliceVertical)-import Data.List (intersperse)+import Data.List (intersperse, intercalate)+import Data.Tuple.HT (mapSnd) data X = Pos Int Int | Row Int Int | Column Int Int | Square Int Int Int deriving (Eq, Ord, Show) -type Assign = ESC.Assign ((Int, Int), Int)+type Cell = ((Int, Int), Int)+type Assign = ESC.Assign Cell assign :: Int -> Int -> Int -> Assign (Set X) assign k i j =@@ -66,14 +76,58 @@ bitVectorAssigns :: [Assign BitVector] bitVectorAssigns = ESC.bitVectorFromSetAssigns assigns +intSetAssigns :: [Assign IntSet]+intSetAssigns = ESC.intSetFromSetAssigns assigns -format :: [((Int, Int), Int)] -> String++format :: [Cell] -> String format = unlines . map (intersperse ' ') . sliceVertical 9 . Array.elems . fmap (\n -> toEnum $ n + fromEnum '0') . array ((0,0),(8,8)) +formatSparse :: [Cell] -> String+formatSparse =+ unlines . map (intersperse ' ') . sliceVertical 9 . Array.elems .+ (listArray ((0,0),(8,8)) (repeat '_') Array.//) .+ map (mapSnd (\n -> toEnum $ n + fromEnum '0')) ++fgColor :: ANSI.Color -> String+fgColor c = ANSI.clr (ANSI.fg c)++highlightBars ::+ (Array.Ix row, Array.Ix col) =>+ [(row, (col, col))] ->+ Array.Array (row, col) [Char] -> Array.Array (row, col) [Char]+highlightBars bars arr =+ Array.accum+ (\str lr ->+ if lr then ANSI.cyanBg ++ str else str ++ ANSI.resetBg) arr $+ concatMap+ (\(row,(left,right)) -> [((row,left),True), ((row,right),False)]) bars++formatColored :: Set X -> Maybe Cell -> [Cell] -> String+formatColored set current =+ unlines . map (intercalate " ") . sliceVertical 9 . Array.elems .+ highlightBars+ (flip foldMap set $ \x ->+ case x of+ Pos _ _ -> []+ Row _ row -> [(row, (0,8))]+ Column _ col -> map (\row -> (row, (col,col))) [0..8]+ Square _ row3 col3 ->+ map (\row -> (row, (col3*3,col3*3+2))) [row3*3 .. row3*3+2]) .+ (Array.//+ maybe []+ (\(currentPos, currentSym) ->+ [(currentPos,+ fgColor ANSI.Blue ++ show currentSym ++ fgColor ANSI.Reset)])+ current) .+ (listArray ((0,0),(8,8)) (repeat "_") Array.//) .+ map (mapSnd show)++ exampleHawiki1 :: [String] exampleHawiki1 = " 6 8 " :@@ -87,9 +141,21 @@ " 5 " : [] +exampleRandom :: [String]+exampleRandom =+ " 2 8 9 5" :+ " 2 " :+ " 9 " :+ " 19 7" :+ "8 5 6" :+ "2 9 8 5 " :+ " 3 " :+ " 1 8 " :+ " 652 1" :+ []+ stateFromString ::- (ESC.Set set) =>- [Assign set] -> [String] -> ESC.State ((Int, Int), Int) set+ (ESC.Set set) => [Assign set] -> [String] -> ESC.State Cell set stateFromString asgns css = foldl (flip ESC.updateState) (ESC.initState asgns) $ do let asnMap = foldMap (\asn -> Map.singleton (ESC.label asn) asn) asgns@@ -102,7 +168,84 @@ ((i,j), fromEnum c - fromEnum '0') asnMap -main, mainAll, mainSolve, mainBit, mainBitVector :: IO ()+data Step a b c =+ Attempt a+ | Complete b+ | Fail c++data Choice = None | Unique | Multiple++indentTree ::+ ESC.Tree label set ->+ [([Int], Step ((Choice, set), label, [label]) [label] (set, [label]))]+indentTree =+ let go numbers labels tree =+ case tree of+ ESC.Leaf -> [(numbers, Complete labels)]+ ESC.Branch set subTrees ->+ case subTrees of+ [(label,subTree)] ->+ (numbers, Attempt ((Unique, set), label, label:labels)) :+ go numbers (label:labels) subTree+ [] -> [(numbers, Fail (set, labels))]+ _ ->+ concatMap+ (\(k, (label,subTree)) ->+ (k:numbers,+ Attempt ((Multiple, set), label, label:labels)) :+ go (k:numbers) (label:labels) subTree) $+ zip [1 ..] subTrees+ in go [] []++formatReason :: (Choice, Set X) -> String+formatReason (choice, set) =+ let uniqueStr =+ case choice of+ None -> "no possible"+ Unique -> "unique"+ Multiple -> "try"+ in case Set.toList set of+ [x] ->+ case x of+ Pos row col ->+ printf "%s number at position (%i,%i)" uniqueStr row col+ Row k row ->+ printf "%s position of %i in row %i" uniqueStr k row+ Column k col ->+ printf "%s position of %i in column %i" uniqueStr k col+ Square k row3 col3 ->+ printf "%s position of %i in square (%i,%i)"+ uniqueStr k row3 col3+ _ -> error "reason set must be a singleton"+++{- |+This generates lots of Sudoku puzzles in a random way.+However, I assume that it will not generate all possible sudokus,+it may generate duplicates and they will certainly not be equally distributed.+-}+randomPuzzles :: MS.State StdGen [[Cell]]+randomPuzzles =+ return . ESC.partitions+ =<< Random.intSetFromSetAssigns+ =<< Random.shuffle assigns++minimizePuzzle :: [Cell] -> [Cell]+minimizePuzzle =+ let asnMap = foldMap (\asn -> Map.singleton (ESC.label asn) asn) bitAssigns+ lookupAssign =+ flip (Map.findWithDefault (error "coordinates not available")) asnMap+ go state xs (y:ys) =+ case ESC.search $ foldl (flip ESC.updateState) state ys of+ [_] -> go state xs ys+ _ -> go (ESC.updateState y state) (ESC.label y : xs) ys+ go _ xs [] = xs+ in go (ESC.initState bitAssigns) [] . map lookupAssign+++main, mainAll, mainSolve, mainBit, mainBitVector, mainIntSet,+ mainTree, mainDetail, mainGenerate :: IO ()+ mainAll = mapM_ (putStrLn . format) $ ESC.partitions bitAssigns @@ -118,4 +261,49 @@ mapM_ (putStrLn . format) $ ESC.search $ stateFromString bitVectorAssigns exampleHawiki1 -main = mainBitVector+mainIntSet =+ mapM_ (putStrLn . format) $ ESC.search $+ stateFromString intSetAssigns exampleHawiki1++mainTree = do+ let s0 = stateFromString assigns exampleHawiki1+ forM_ (indentTree $ ESC.completeTree s0) $ \(numbers, msg) ->+ putStrLn $+ (intercalate "." $ map show $ reverse numbers)+ +++ (case msg of+ Attempt (reason,(pos,k),_) ->+ ": " ++ show k ++ " at " ++ show pos +++ " - " ++ formatReason reason+ Complete labels -> "\n" ++ format (labels ++ ESC.usedSubsets s0)+ Fail (reason,_) ->+ ": failed because " ++ formatReason (None,reason))++mainDetail = do+ let s0 = stateFromString assigns exampleHawiki1+ forM_ (indentTree $ ESC.completeTree s0) $ \(numbers, msg) ->+ putStrLn $+ (intercalate "." $ map show $ reverse numbers)+ +++ (case msg of+ Attempt (reason, cell@(pos,k), labels) ->+ ": " ++ show k ++ " at " ++ show pos +++ " - " ++ formatReason reason ++ "\n\n" +++ formatColored (snd reason)+ (Just cell) (labels ++ ESC.usedSubsets s0)+ Complete _labels -> ": completed\n"+ Fail (reason, labels) ->+ ": failed because " ++ formatReason (None,reason) ++ "\n\n" +++ formatColored reason Nothing (labels ++ ESC.usedSubsets s0))++mainGenerate = do+ gen <- getStdGen+ case MS.evalState randomPuzzles gen of+ solution:_ -> do+ putStrLn $ formatSparse solution+ let minSolution = minimizePuzzle solution+ putStrLn $ formatSparse minSolution+ printf "%d initially filled cells\n\n" $ length minSolution+ _ -> fail "to few puzzles"++main = mainDetail
example/TetrisCube.hs view
@@ -188,12 +188,12 @@ format :: [Map.Map PackedCoords BrickId] -> String format v =- let wuerfelx = Map.unions v+ let cubex = Map.unions v in Cuboid.forNestedCoords unlines (intercalate " | ") (intercalate " ") (\c -> maybe "." formatBrickId $- Map.lookup (Cuboid.packCoords size c) wuerfelx)+ Map.lookup (Cuboid.packCoords size c) cubex) size printMask :: [Map.Map PackedCoords BrickId] -> IO ()@@ -228,14 +228,14 @@ testme1 = testme (Blue, 1) mainState = do- let lsg = ESC.partitions allAssigns- mapM_ printMask lsg- print $ length lsg+ let sol = ESC.partitions allAssigns+ mapM_ printMask sol+ print $ length sol mainBits = do- let lsg = ESC.partitions $ map (fmap packMask) allAssigns- mapM_ printMask lsg- print $ length lsg+ let sol = ESC.partitions $ map (fmap packMask) allAssigns+ mapM_ printMask sol+ print $ length sol mainParallel = Pool.run $ map snd $
set-cover.cabal view
@@ -1,5 +1,5 @@ Name: set-cover-Version: 0.0.9+Version: 0.1 License: BSD3 License-File: LICENSE Author: Henning Thielemann, Helmut Podhaisky@@ -10,8 +10,9 @@ Description: Solver for exact set cover problems. Included examples:- Sudoku, Nonogram, 8 Queens, Domino tiling, Mastermind,- Soma Cube, Tetris Cube, Cube of L's, Logika's Baumeister puzzle.+ Sudoku, Nonogram, 8 Queens, Domino tiling, Mastermind, Alphametics,+ Soma Cube, Tetris Cube, Cube of L's,+ Logika's Baumeister puzzle, Lonpos pyramid, Conway's puzzle. The generic algorithm allows to choose between slow but flexible @Set@ from @containers@ package and fast but cumbersome bitvectors.@@ -19,20 +20,32 @@ For getting familiar with the package I propose to study the Queen8 example along with "Math.SetCover.Exact". .+ The Sudoku and Nonogram examples also demonstrate+ how to interpret the set-cover solution in a human-friendly way.+ . Build examples with @cabal install -fbuildExamples@. . The package needs only Haskell 98.+ There is also an experimental implementation using LLVM and @knead@.+ Do not rely on that interface in released packages. Tested-With: GHC==7.4.2, GHC==7.6.3, GHC==7.8.2 Cabal-Version: >=1.8 Build-Type: Simple-Extra-Source-Files: Changes.md+Extra-Source-Files:+ Changes.md+ Makefile Flag buildExamples- description: Build example executables- default: False+ Description: Build example executables+ Default: False +Flag llvm+ Description: Enable efficient signal processing using LLVM+ Manual: True+ Default: False+ Source-Repository this- Tag: 0.0.9+ Tag: 0.1 Type: darcs Location: http://hub.darcs.net/thielema/set-cover/ @@ -43,32 +56,79 @@ Library Build-Depends: psqueues >=0.2 && <0.3,- enummapset >=0.1 && <0.6,- containers >=0.4 && <0.6,+ enummapset >=0.1 && <0.7,+ transformers >=0.2 && <0.6,+ array >=0.4 && <0.6,+ containers >=0.4 && <0.7,+ non-empty >=0.2 && <0.4, semigroups >=0.1 && <1.0, utility-ht >=0.0.12 && <0.1,+ prelude-compat ==0.*, base >=4 && <5 GHC-Options: -Wall Hs-Source-Dirs: src Exposed-Modules: Math.SetCover.Bit- Math.SetCover.BitMap Math.SetCover.BitSet Math.SetCover.BitPosition+ Math.SetCover.BitPriorityQueue Math.SetCover.Queue Math.SetCover.Exact Math.SetCover.Exact.Priority+ Math.SetCover.Exact.UArray Math.SetCover.Cuboid Other-Modules:- Math.SetCover.IntSet- Math.SetCover.BitPriorityQueue+ Math.SetCover.BitMap Math.SetCover.EnumMap Math.SetCover.Queue.Set Math.SetCover.Queue.Map Math.SetCover.Queue.Bit Math.SetCover.Queue.BitPriorityQueue+ Math.SetCover.Exact.Block + If flag(llvm)+ Build-Depends:+ knead >=0.4 && <0.5,+ llvm-extra >=0.8 && <0.9,+ llvm-tf >=3.1.1 && <3.2,+ tfp >=1.0 && <1.1,+ comfort-array >=0.3 && <0.5,+ storable-endian >=0.2.6 && <0.3,+ bool8 >=0.0 && <0.1,+ lazyio >=0.1 && <0.2+ Exposed-Modules:+ Math.SetCover.Exact.Knead+ Math.SetCover.Exact.Knead.Vector+ Math.SetCover.Exact.Knead.Saturated+ Other-Modules:+ Math.SetCover.Exact.Knead.Symbolic++Test-Suite set-cover-test+ Type: exitcode-stdio-1.0+ Build-Depends:+ set-cover,+ transformers >=0.2 && <0.6,+ enummapset,+ containers,+ array >=0.1 && <0.6,+ utility-ht,+ QuickCheck >=2.5 && <3.0,+ base+ Main-Is: Test.hs+ Hs-Source-Dirs: test, example+ If flag(llvm)+ Hs-Source-Dirs: test/knead+ Else+ Hs-Source-Dirs: test/plain+ GHC-Options: -Wall+ Other-Modules:+ Mastermind.Test+ Mastermind.Guess+ Mastermind.Utility+ Test.Knead+ Test.Utility+ Executable tetris-cube If flag(buildExamples) Build-Depends:@@ -117,6 +177,9 @@ If flag(buildExamples) Build-Depends: set-cover,+ haha >=0.3.1 && <0.4,+ random >=1.0 && <1.2,+ transformers >=0.2 && <0.6, containers, array >=0.1 && <0.6, utility-ht,@@ -126,6 +189,7 @@ GHC-Options: -Wall -rtsopts -threaded Hs-Source-Dirs: example Main-Is: Sudoku.hs+ Other-Modules: Random, Mastermind.Utility Executable lcube If flag(buildExamples)@@ -226,12 +290,13 @@ Nonogram.Encoding.Naive Nonogram.Base -Executable mastermind+Executable mastermind-setcover If flag(buildExamples) Build-Depends: set-cover, random >=1.0 && <1.2, transformers >=0.2 && <0.6,+ enummapset, containers, array >=0.1 && <0.6, utility-ht,@@ -241,7 +306,61 @@ GHC-Options: -Wall Hs-Source-Dirs: example Main-Is: Mastermind.hs+ Other-Modules:+ Mastermind.Utility+ Mastermind.Guess+ Mastermind.Distinguish+ Mastermind.Example+ Random +Executable mastermind-knead+ If flag(buildExamples) && flag(llvm)+ GHC-Prof-Options: -rtsopts -auto-all+ Build-Depends:+ set-cover,+ haha >=0.3.1 && <0.4,+ random >=1.0 && <1.2,+ lazyio,+ transformers >=0.2 && <0.6,+ enummapset,+ containers,+ array >=0.1 && <0.6,+ utility-ht,+ base+ Else+ Buildable: False+ Extra-Libraries: stdc+++ GHC-Options: -Wall+ Hs-Source-Dirs: example+ Main-Is: MastermindKnead.hs+ Other-Modules:+ Mastermind.Utility+ Mastermind.Guess+ Mastermind.Distinguish+ Mastermind.Example+ Random++Benchmark mastermind-benchmark+ Type: exitcode-stdio-1.0+ Build-Depends:+ set-cover,+ timeit,+ QuickCheck >=2.5 && <3.0,+ random >=1.0 && <1.2,+ transformers >=0.2 && <0.6,+ enummapset,+ containers,+ array >=0.1 && <0.6,+ utility-ht,+ base+ GHC-Options: -Wall+ Hs-Source-Dirs: example+ Main-Is: Mastermind/Benchmark.hs+ Other-Modules:+ Mastermind.Test+ Mastermind.Guess+ Mastermind.Utility+ Executable pangram If flag(buildExamples) Build-Depends:@@ -253,3 +372,19 @@ GHC-Options: -Wall Hs-Source-Dirs: example Main-Is: Pangram.hs++Executable conway-puzzle+ If flag(buildExamples)+ Build-Depends:+ set-cover,+ pooled-io >=0.0 && <0.1,+ transformers,+ containers,+ base+ Else+ Buildable: False+ GHC-Options: -Wall -rtsopts -threaded+ Hs-Source-Dirs: example+ Main-Is: ConwayPuzzle.hs+ Other-Modules:+ Utility
src/Math/SetCover/Bit.hs view
@@ -1,7 +1,8 @@ module Math.SetCover.Bit where +import qualified Data.IntSet as IntSet; import Data.IntSet (IntSet) import qualified Data.Bits as Bits-import Data.Bits (Bits)+import Data.Bits (Bits, complement) import Data.Word (Word8, Word16, Word32, Word64) import Prelude hiding (null) @@ -15,12 +16,12 @@ -} class Ord bits => C bits where empty :: bits- complement, keepMinimum :: bits -> bits- xor, (.&.), (.|.) :: bits -> bits -> bits+ keepMinimum :: bits -> bits+ difference, xor, (.&.), (.|.) :: bits -> bits -> bits instance C Word8 where empty = 0- complement = Bits.complement+ difference xs ys = xs .&. complement ys keepMinimum xs = xs .&. (-xs) xor = Bits.xor (.&.) = (Bits..&.)@@ -28,7 +29,7 @@ instance C Word16 where empty = 0- complement = Bits.complement+ difference xs ys = xs .&. complement ys keepMinimum xs = xs .&. (-xs) xor = Bits.xor (.&.) = (Bits..&.)@@ -36,7 +37,7 @@ instance C Word32 where empty = 0- complement = Bits.complement+ difference xs ys = xs .&. complement ys keepMinimum xs = xs .&. (-xs) xor = Bits.xor (.&.) = (Bits..&.)@@ -44,7 +45,7 @@ instance C Word64 where empty = 0- complement = Bits.complement+ difference xs ys = xs .&. complement ys keepMinimum xs = xs .&. (-xs) xor = Bits.xor (.&.) = (Bits..&.)@@ -52,14 +53,19 @@ instance C Integer where empty = 0- complement = Bits.complement+ difference xs ys = xs .&. complement ys keepMinimum xs = xs .&. (-xs) xor = Bits.xor (.&.) = (Bits..&.) (.|.) = (Bits..|.) -difference :: C bits => bits -> bits -> bits-difference xs ys = xs .&. complement ys+instance C IntSet where+ empty = IntSet.empty+ difference = IntSet.difference+ keepMinimum = IntSet.singleton . IntSet.findMin+ xor x y = IntSet.difference (IntSet.union x y) (IntSet.intersection x y)+ (.&.) = IntSet.intersection+ (.|.) = IntSet.union {-@@ -70,7 +76,8 @@ instance (C a, C b) => C (Sum a b) where empty = Sum empty empty- complement (Sum l h) = Sum (complement l) (complement h)+ difference (Sum xl xh) (Sum yl yh) =+ Sum (difference xl yl) (difference xh yh) xor (Sum xl xh) (Sum yl yh) = Sum (xor xl yl) (xor xh yh) Sum xl xh .&. Sum yl yh = Sum (xl.&.yl) (xh.&.yh) Sum xl xh .|. Sum yl yh = Sum (xl.|.yl) (xh.|.yh)
src/Math/SetCover/BitMap.hs view
@@ -14,8 +14,10 @@ import Math.SetCover.Bit (difference, xor, (.|.), (.&.)) import qualified Data.List.Reverse.StrictSpine as ListRev+import qualified Data.List as List import Data.Monoid (Monoid, mempty, mappend) import Data.Semigroup (Semigroup, (<>))+import Data.Tuple.HT (mapSnd, swap) {-@@ -44,9 +46,11 @@ inc :: Bit.C bits => Set bits -> Map bits -> Map bits inc (Set xs0) (Map ys0) =- let go c [] = if c==Bit.empty then [] else [c]- go c (x:xs) = xor c x : go (c .&. x) xs- in Map $ go xs0 ys0+ Map $+ mapAccumAffix+ (\c -> if c==Bit.empty then [] else [c])+ (\c x -> (c .&. x, xor c x))+ xs0 ys0 sub :: Bit.C bits => Map bits -> Map bits -> Map bits@@ -62,9 +66,22 @@ dec :: Bit.C bits => Set bits -> Map bits -> Map bits dec (Set xs0) (Map ys0) =- let go c [] = if c==Bit.empty then [] else error "dec: underflow"- go c (x:xs) = xor c x : go (difference c x) xs- in Map $ go xs0 ys0+ Map $+ mapAccumAffix+ (\c -> if c==Bit.empty then [] else error "dec: underflow")+ (\c x -> (difference c x, xor c x))+ xs0 ys0++{-# INLINE mapAccumAffix #-}+mapAccumAffix, _mapAccumAffix ::+ (acc -> [y]) -> (acc -> x -> (acc, y)) -> acc -> [x] -> [y]+mapAccumAffix affix f =+ let go acc0 (x:xs) = let (acc1, y) = f acc0 x in y : go acc1 xs+ go acc [] = affix acc+ in go++_mapAccumAffix affix f acc =+ uncurry (++) . mapSnd affix . swap . List.mapAccumL f acc intersectionSet :: (Bit.C bits) => Map bits -> Set bits -> Map bits intersectionSet (Map xs) (Set y) = Map $ normalize $ map (y.&.) xs
src/Math/SetCover/BitPosition.hs view
@@ -1,11 +1,13 @@-module Math.SetCover.BitPosition (C, unpack, singleton, bitPosition) where+module Math.SetCover.BitPosition+ (C, Sized, unpack, singleton, bitPosition) where import qualified Math.SetCover.BitSet as BitSet import qualified Math.SetCover.Bit as Bit import Math.SetCover.Bit ((.&.)) +import qualified Data.IntSet as IntSet; import Data.IntSet (IntSet) import qualified Data.Bits as Bits-import Data.Bits (Bits, shiftR)+import Data.Bits (Bits, shiftR, complement) import Data.Word (Word8, Word16, Word32, Word64) import qualified Data.List.HT as ListHT@@ -24,9 +26,9 @@ in (x, BitSet.difference set x) {-# INLINE positionMasks #-}-positionMasks :: (Integral bits, Bit.C bits) => [bits]+positionMasks :: (Integral bits, Bits bits, Bit.C bits) => [bits] positionMasks =- map (Bit.complement . div (-1) . (1+)) $+ map (complement . div (-1) . (1+)) $ takeWhile (/=0) $ iterate (\w -> w*w) 2 {-@@ -74,25 +76,32 @@ zip [0, 64 ..] . takeWhile (/=0) . iterate (flip shiftR 64) unpack = concatMap (\(offset,x) -> map (offset+) $ unpack (BitSet.Set x)) .- zip [0, 64 ..] . map (\w -> word64 $ w .&. fromIntegral (-1 :: Word64)) .- takeWhile (/=0) . iterate (flip shiftR 64) . (\(BitSet.Set x) -> x)+ zip [0, 64 ..] .+ map (\w -> word64 $ w .&. fromIntegral (complement 0 :: Word64)) .+ takeWhile (/=0) . iterate (flip shiftR 64) . BitSet.getBits +instance C IntSet where+ bit = IntSet.singleton+ bitPositionPlain = IntSet.findMin+ unpack = IntSet.toList . BitSet.getBits+ word64 :: Integer -> Word64 word64 = fromIntegral -{- |-Instantiating @a@ with 'Integer' will end badly because it has no fixed size!--}-instance (Integral a, C a, C b) => C (Bit.Sum a b) where- bit = bitSum $ bitSize positionMasks- bitPositionPlain = bitSumPosition $ bitSize positionMasks- unpack = bitSumUnpack $ bitSize positionMasks newtype Size bits = Size Int -bitSize :: C bits => [bits] -> Size bits-bitSize = Size . Bits.bit . length+class C bits => Sized bits where size :: Size bits+instance Sized Word8 where size = Size 8+instance Sized Word16 where size = Size 16+instance Sized Word32 where size = Size 32+instance Sized Word64 where size = Size 64 +instance (Sized a, C b) => C (Bit.Sum a b) where+ bit = bitSum size+ bitPositionPlain = bitSumPosition size+ unpack = bitSumUnpack size+ bitSum :: (C a, C b) => Size a -> Int -> Bit.Sum a b bitSum (Size offset) pos = if pos < offset@@ -110,7 +119,7 @@ unpack (BitSet.Set a) ++ map (offset +) (unpack (BitSet.Set b)) bitPosition :: (C bits) => BitSet.Set bits -> Int-bitPosition (BitSet.Set bits) = bitPositionPlain bits+bitPosition = bitPositionPlain . BitSet.getBits singleton :: (C bits) => Int -> BitSet.Set bits singleton = BitSet.Set . bit
src/Math/SetCover/BitPriorityQueue.hs view
@@ -1,10 +1,19 @@-module Math.SetCover.BitPriorityQueue where+module Math.SetCover.BitPriorityQueue (+ Queue,+ null,+ fromSets,+ elemUnions,+ partition,+ difference,+ findMin,+ findMinValue,+ ) where import qualified Math.SetCover.EnumMap as EnumMapX import qualified Math.SetCover.BitPosition as BitPos import qualified Math.SetCover.BitMap as BitMap import qualified Math.SetCover.BitSet as BitSet-import Math.SetCover.EnumMap (constIntMap)+import Math.SetCover.EnumMap (constIntMapFromBits) import qualified Data.EnumSet as EnumSet; import Data.EnumSet (EnumSet) import qualified Data.IntMap as IntMap; import Data.IntMap (IntMap)@@ -13,7 +22,9 @@ import Data.Monoid (mempty, mconcat) import Data.Maybe.HT (toMaybe) +import Prelude hiding (null) + {- We could generalize @EnumSet e@ to @a@ and pretend that the priorities are independent of the 'EnumSet' sizes.@@ -39,13 +50,17 @@ mconcat $ map BitPos.singleton $ IntMap.keys m findMin :: (BitPos.C bits) => Queue bits e -> Maybe (EnumSet e)-findMin q@(Queue ns m) =+findMin = fmap snd . findMinValue++findMinValue ::+ (BitPos.C bits) => Queue bits e -> Maybe (BitSet.Set bits, EnumSet e)+findMinValue q@(Queue ns m) = let used = keysBits q- in toMaybe (not $ BitSet.null used) $+ minSet = BitSet.keepMinimum $ BitMap.minimumSet used ns+ in toMaybe (not $ BitSet.null used) $ (,) minSet $ IntMap.findWithDefault (error "findMin: key with minimal priority must be in IntMap")- (BitPos.bitPosition $ BitSet.keepMinimum $- BitMap.minimumSet used ns)+ (BitPos.bitPosition minSet) m difference ::@@ -59,6 +74,6 @@ (BitPos.C bits, Enum e) => Queue bits e -> BitSet.Set bits -> (Queue bits e, Queue bits e) partition (Queue ns m) s =- let section = IntMap.intersection m $ constIntMap () s+ let section = IntMap.intersection m $ constIntMapFromBits () s in (Queue (BitMap.intersectionSet ns s) section, Queue (BitMap.differenceSet ns s) $ IntMap.difference m section)
src/Math/SetCover/BitSet.hs view
@@ -7,7 +7,7 @@ import Data.Semigroup (Semigroup, (<>)) -newtype Set bits = Set bits deriving (Eq, Ord, Show)+newtype Set bits = Set {getBits :: bits} deriving (Eq, Ord, Show) instance (Bit.C bits) => Semigroup (Set bits) where Set x <> Set y = Set $ x.|.y
src/Math/SetCover/Cuboid.hs view
@@ -51,11 +51,8 @@ numberOf2LayerAtoms :: [[String]] -> Int numberOf2LayerAtoms = Fold.sum .- Map.intersectionWith (*)- (Map.fromList [('.', 1), ('\'', 1), (':', 2)]) .- Map.fromListWith (+) .- map (flip (,) 1) .- concat . concat+ Map.intersectionWith (*) (Map.fromList [('.', 1), ('\'', 1), (':', 2)]) .+ Map.fromListWith (+) . map (flip (,) 1) . concat . concat forNestedCoords ::@@ -78,16 +75,22 @@ deriving (Eq, Ord, Show) -dx, dy, dz :: Num a => Coords a -> Coords a-dx (Coords x y z) = Coords x (-z) y -- [1 0 0; 0 0 -1; 0 1 0]-dy (Coords x y z) = Coords (-z) y x -- [0 0 -1; 0 1 0; 1 0 0]-dz (Coords x y z) = Coords (-y) x z -- [0 -1 0; 1 0 0; 0 0 1]+rotX, rotY, rotZ :: Num a => Coords a -> Coords a+rotX (Coords x y z) = Coords x (-z) y -- [1 0 0; 0 0 -1; 0 1 0]+rotY (Coords x y z) = Coords (-z) y x -- [0 0 -1; 0 1 0; 1 0 0]+rotZ (Coords x y z) = Coords (-y) x z -- [0 -1 0; 1 0 0; 0 0 1] +primRotations :: Num a => Coords (Coords a -> Coords a)+primRotations = Coords rotX rotY rotZ+ rotations :: Num a => [Coords a -> Coords a]-rotations =+rotations = rotationsGen primRotations++rotationsGen :: Num a => Coords (Coords a -> Coords a) -> [Coords a -> Coords a]+rotationsGen (Coords rx ry rz) = liftA2 (.)- [id, dx, dx.dx, dx.dx.dx]- [id, dz, dz.dz, dz.dz.dz, dy, dy.dy.dy]+ [id, rx, rx.rx, rx.rx.rx]+ [id, rz, rz.rz, rz.rz.rz, ry, ry.ry.ry] type Size = Coords Int@@ -120,6 +123,10 @@ liftA2 (-) sz (size ts) allOrientations :: (Num a, Ord a) => [Coords a] -> [[Coords a]]-allOrientations ts =+allOrientations = allOrientationsGen primRotations++allOrientationsGen ::+ (Num a, Ord a) => Coords (Coords a -> Coords a) -> [Coords a] -> [[Coords a]]+allOrientationsGen pr ts = Set.toList $ Set.fromList $- map (normalForm . flip map ts) rotations+ map (normalForm . flip map ts) $ rotationsGen pr
src/Math/SetCover/EnumMap.hs view
@@ -6,6 +6,7 @@ import qualified Data.EnumMap as EnumMap; import Data.EnumMap (EnumMap) import qualified Data.EnumSet as EnumSet; import Data.EnumSet (EnumSet) import qualified Data.IntMap as IntMap; import Data.IntMap (IntMap)+import qualified Data.IntSet as IntSet; import Data.IntSet (IntSet) import qualified Data.Map as Map import qualified Data.Set as Set @@ -26,9 +27,13 @@ in (section, EnumMap.difference m section) +{-# INLINE attach #-}+attach :: b -> [a] -> [(a, b)]+attach a = map (flip (,) a)+ -- Map.fromSet is available from containers-0.5 constMap :: (Ord a) => b -> Set.Set a -> Map.Map a b-constMap a = Map.fromAscList . map (\k -> (k, a)) . Set.toAscList+constMap a = Map.fromAscList . attach a . Set.toAscList transposeSet :: (Enum e, Ord a) => EnumMap e (Set.Set a) -> Map.Map a (EnumSet e)@@ -44,11 +49,20 @@ EnumMap.mapWithKey (fmap . EnumMap.singleton) -constIntMap :: (BitPos.C bits) => b -> BitSet.Set bits -> IntMap b-constIntMap a = IntMap.fromAscList . map (\k -> (k, a)) . BitPos.unpack+constIntMapFromBits :: (BitPos.C bits) => b -> BitSet.Set bits -> IntMap b+constIntMapFromBits a = IntMap.fromAscList . attach a . BitPos.unpack transposeBitSet :: (BitPos.C bits, Enum e) => EnumMap e (BitSet.Set bits) -> IntMap (EnumSet e) transposeBitSet =+ IntMap.unionsWith EnumSet.union . EnumMap.elems .+ EnumMap.mapWithKey (constIntMapFromBits . EnumSet.singleton)+++constIntMap :: b -> IntSet -> IntMap b+constIntMap a = IntMap.fromAscList . attach a . IntSet.toAscList++transposeIntSet :: (Enum e) => EnumMap e IntSet -> IntMap (EnumSet e)+transposeIntSet = IntMap.unionsWith EnumSet.union . EnumMap.elems . EnumMap.mapWithKey (constIntMap . EnumSet.singleton)
src/Math/SetCover/Exact.hs view
@@ -3,26 +3,31 @@ <http://en.wikipedia.org/wiki/Exact_cover> -} module Math.SetCover.Exact (- Assign(..), assign, bitVectorFromSetAssigns,+ Assign(..), assign,+ bitVectorFromSetAssigns, intSetFromSetAssigns, partitions, search, step, State(..), initState, updateState, Set(..),+ Tree(..), decisionTree, completeTree,+ Choose(..), ) where -import qualified Math.SetCover.IntSet as IntSetX import qualified Math.SetCover.BitMap as BitMap import qualified Math.SetCover.BitSet as BitSet import qualified Math.SetCover.Bit as Bit+import Math.SetCover.EnumMap (constMap) import Control.Applicative ((<$>), (<$)) import qualified Data.IntSet as IntSet import qualified Data.Map as Map import qualified Data.Set as Set-import qualified Data.List as List import qualified Data.List.Match as Match+import qualified Data.List as List import qualified Data.Foldable as Fold+import Data.Function.HT (compose2) import Data.Maybe.HT (toMaybe)+import Data.Tuple.HT (mapFst, mapSnd) import Data.Bits (setBit) import Prelude hiding (null)@@ -39,10 +44,17 @@ unions :: [set] -> set difference :: set -> set -> set {- |+ @minimize free assigns@ finds a set element @x@ from @free@+ that is contained in the least number of sets in @assigns@.+ Then it returns the assigns where @x@ is contained in the associated set.+ This formulation allows us not to name @x@+ and thus we do not need a second type variable for @set@ elements+ and no type family from @set@ to its element type.+ 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.+ @free@ must be a superset of all sets in the assign list.+ @free@ must be non-empty.+ The @assigns@ list may be empty. The output of assigns must be a subsequence of the input assigns, that is, it must be a subset of the input and it must be in the same order. This requirement was originally needed by 'minimize' for 'Map.Map',@@ -50,30 +62,43 @@ -} minimize :: set -> [Assign label set] -> [Assign label set] +class Set set => Choose set where+ {-+ Compute a set containing one element+ that is contained in a minimal number of assignment sets.+ -}+ chooseMinimize :: set -> [Assign label set] -> (set, [Assign label set])+ instance (Ord a) => Set (Set.Set a) where null = Set.null disjoint x y = Set.null $ Set.intersection x y unions = Set.unions difference = Set.difference- minimize free =- Fold.minimumBy Match.compareLength .- foldr (Map.unionWith (++)) (constMap [] free) .- map (\a -> constMap [a] $ labeledSet a)+ minimize free = Fold.minimumBy Match.compareLength . histogramSet free -{--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 (Ord a) => Choose (Set.Set a) where+ chooseMinimize free =+ mapFst Set.singleton .+ List.minimumBy (compose2 Match.compareLength snd) .+ Map.toList . histogramSet free +histogramSet ::+ Ord k =>+ Set.Set k ->+ [Assign label (Set.Set k)] ->+ Map.Map k [Assign label (Set.Set k)]+histogramSet free =+ foldr (Map.unionWith (++)) (constMap [] free) .+ map (\a -> constMap [a] $ labeledSet a)++ {- | This instance supports Maps of Sets. This way you can structure your sets hierarchically. You may also use it to combine several low-level bitsets. A Map must not contain empty subsets. -}-instance (Ord k, Set a) => Set (Map.Map k a) where+instance (Ord k, Set set) => Set (Map.Map k set) where null = Map.null disjoint x y = Fold.and $ Map.intersectionWith disjoint x y unions =@@ -81,39 +106,59 @@ difference = Map.differenceWith (\x y -> let z = difference x y in toMaybe (not $ null z) z)- minimize free asns =- map label $- Fold.minimumBy Match.compareLength $- Map.intersectionWith minimize free $- foldr (Map.unionWith (++)) ([] <$ free) $- map (\asn -> (:[]) . assign asn <$> labeledSet asn) asns+ minimize free =+ map label . Fold.minimumBy Match.compareLength .+ Map.intersectionWith minimize free . histogramMap free +instance (Ord k, Choose set) => Choose (Map.Map k set) where+ chooseMinimize free =+ (\(k,(minSet,asns)) -> (Map.singleton k minSet, map label asns)) .+ List.minimumBy (compose2 Match.compareLength (snd.snd)) . Map.toList .+ Map.intersectionWith chooseMinimize free . histogramMap free +histogramMap ::+ (Ord k, Set set) =>+ Map.Map k set ->+ [Assign label (Map.Map k set)] ->+ Map.Map k [Assign (Assign label (Map.Map k set)) set]+histogramMap free =+ foldr (Map.unionWith (++)) ([] <$ free) .+ map (\asn -> (:[]) . assign asn <$> labeledSet asn)++ instance (Bit.C a) => Set (BitSet.Set a) where null = BitSet.null disjoint = BitSet.disjoint unions = Fold.fold difference = BitSet.difference- minimize free available =+ minimize free = snd . chooseMinimize free++instance (Bit.C a) => Choose (BitSet.Set a) where+ chooseMinimize free available = let singleMin = BitSet.keepMinimum $ BitMap.minimumSet free $ Fold.foldMap (BitMap.fromSet . labeledSet) available- in filter (not . BitSet.disjoint singleMin . labeledSet) available+ in (singleMin,+ filter (not . BitSet.disjoint singleMin . labeledSet) available) + instance Set IntSet.IntSet where null = IntSet.null disjoint x y = IntSet.null $ IntSet.intersection x y unions = IntSet.unions difference = IntSet.difference- minimize free available =- let bitset = BitSet.Set . IntSetX.fromIntSet- singleMin =- (\(BitSet.Set s) -> IntSetX.findMin s) $- BitMap.minimumSet (bitset free) $- Fold.foldMap (BitMap.fromSet . bitset . labeledSet) available- in filter (IntSet.member singleMin . labeledSet) available+ minimize free = snd . chooseMinimize free +instance Choose IntSet.IntSet where+ chooseMinimize free available =+ let singleMin =+ IntSet.findMin $ BitSet.getBits $+ BitMap.minimumSet (BitSet.Set free) $+ Fold.foldMap (BitMap.fromSet . BitSet.Set . labeledSet) available+ in (IntSet.singleton singleMin,+ filter (IntSet.member singleMin . labeledSet) available) + {- | 'Assign' allows to associate a set with a label. If a particular set is chosen for a set cover,@@ -148,14 +193,27 @@ (Ord a) => [Assign label (Set.Set a)] -> [Assign label (BitSet.Set Integer)] bitVectorFromSetAssigns asns =+ let bitVec = Fold.foldl' setBit 0 . mapIntFromSet asns+ in map (fmap (BitSet.Set . bitVec)) asns++{- |+Like 'bitVectorFromSetAssigns' but generates 'IntSet.IntSet'+instead of 'Integer' bitvectors.+Since containers-0.5.5 as shipped with GHC-7.8.4,+'IntSet.IntSet' should usually be more efficient than 'Integer'.+-}+intSetFromSetAssigns ::+ (Ord a) => [Assign label (Set.Set a)] -> [Assign label IntSet.IntSet]+intSetFromSetAssigns asns =+ let intSet = IntSet.fromList . Map.elems . mapIntFromSet asns+ in map (fmap intSet) asns++mapIntFromSet ::+ (Ord a) => [Assign label (Set.Set a)] -> Set.Set a -> Map.Map a Int+mapIntFromSet asns = let mapToInt = Map.fromList $ zip (Set.toList $ unions $ map labeledSet asns) [0..]- err = error "bitVectorFromSetAssigns: element disappeared"- bitVec =- Fold.foldl' setBit 0 .- map (flip (Map.findWithDefault err) mapToInt) .- Set.toList- in map (fmap (BitSet.Set . bitVec)) asns+ in Map.intersection mapToInt . constMap () {- | The state of the search.@@ -176,7 +234,7 @@ State { availableSubsets :: [Assign label set], freeElements :: set,- usedSubsets :: [Assign label set]+ usedSubsets :: [label] } instance Functor (Assign label) where@@ -184,7 +242,7 @@ instance Functor (State label) where fmap f (State ab fp pb) =- State (map (fmap f) ab) (f fp) (map (fmap f) pb)+ State (map (fmap f) ab) (f fp) pb initState :: Set set => [Assign label set] -> State label set initState subsets =@@ -196,13 +254,13 @@ {-# INLINE updateState #-} updateState :: Set set => Assign label set -> State label set -> State label set-updateState attempt@(Assign _ attemptedSet) s =+updateState (Assign attemptLabel attemptedSet) s = State { availableSubsets = filter (disjoint attemptedSet . labeledSet) $ availableSubsets s, freeElements = difference (freeElements s) attemptedSet,- usedSubsets = attempt : usedSubsets s+ usedSubsets = attemptLabel : usedSubsets s } @@ -232,15 +290,13 @@ The algorithm might not be extraordinarily fast, but in all cases it consumes only little memory since it only has to maintain the current state of search.++Precondition: 'freeElements' of the input state must not be empty. -} {-# INLINE step #-} step :: Set set => State label set -> [State label set] step s =- if List.null (availableSubsets s) || null (freeElements s)- then []- else- map (flip updateState s) $- minimize (freeElements s) (availableSubsets s)+ map (flip updateState s) $ minimize (freeElements s) (availableSubsets s) {- | Start the search for partitions on a certain search state.@@ -253,7 +309,7 @@ search :: Set set => State label set -> [[label]] search s = if null (freeElements s)- then [map label $ usedSubsets s]+ then [usedSubsets s] else step s >>= search {- |@@ -270,8 +326,25 @@ depends on the implementation and you must not rely on them. -You may use 'listToMaybe' in order to select only the first solution.+You may use 'Data.Maybe.listToMaybe' in order to select only the first solution. -} {-# INLINE partitions #-} partitions :: Set set => [Assign label set] -> [[label]] partitions = search . initState++++data Tree label set = Leaf | Branch set [(label, Tree label set)]+ deriving (Eq)++completeTree :: Choose set => State label set -> Tree label set+completeTree s =+ if null (freeElements s)+ then Leaf+ else+ uncurry Branch $+ mapSnd (map (\asn -> (label asn, completeTree $ updateState asn s))) $+ chooseMinimize (freeElements s) (availableSubsets s)++decisionTree :: Choose set => [Assign label set] -> Tree label set+decisionTree = completeTree . initState
+ src/Math/SetCover/Exact/Block.hs view
@@ -0,0 +1,37 @@+module Math.SetCover.Exact.Block (blocksFromSets) where++import Math.SetCover.EnumMap (constMap)++import qualified Data.List as List+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Monoid.HT as Mn+import Data.Set (Set)+import Data.Tuple.HT (swap)+import Data.Bits (Bits, bitSize, setBit, shiftL, complement)+++blocksFromSets ::+ (Ord a, Num block, Bits block) => [Set a] -> ([[block]], [block])+blocksFromSets sets =+ let dummyBlock = 0+ blockSize = bitSize dummyBlock+ complete = Set.unions sets+ mapToInt = Map.fromList $ zip (Set.toList complete) [0..]+ blocks =+ blocksFromInts blockSize .+ Map.elems . Map.intersection mapToInt . constMap ()+ in (map blocks sets,+ case divMod (Set.size complete) blockSize of+ (numBlocks,remd) ->+ replicate numBlocks (complement 0 `asTypeOf` dummyBlock) +++ Mn.when (remd>0) [shiftL 1 remd - 1])++blocksFromInts :: (Num block, Bits block) => Int -> [Int] -> [block]+blocksFromInts blockSize =+ zipWith blockFromBits (iterate (blockSize+) 0) . snd .+ flip (List.mapAccumL (\elems pivot -> swap $ span (<pivot) elems))+ (iterate (blockSize+) blockSize)++blockFromBits :: (Num block, Bits block) => Int -> [Int] -> block+blockFromBits offset = List.foldl' setBit 0 . map (subtract offset)
+ src/Math/SetCover/Exact/Knead.hs view
@@ -0,0 +1,193 @@+{- |+This re-implements "Math.SetCover.Exact.UArray" using LLVM.+-}+module Math.SetCover.Exact.Knead (+ partitionsIO, searchIO, stepIO,+ partitions,+ State(..), initStateIO, updateStateIO,+ BitSet(..),+ SetId, SetDim, BlockId, BlockDim,+ ) where++import qualified Math.SetCover.Exact as ESC+import Math.SetCover.Exact.Knead.Symbolic (+ SetId, SetDim, BlockId, BlockDim, DigitId, DigitDim,+ Block,+ BitSet(nullBlock, blocksFromSets, keepMinimumBit),+ sumBags3,+ difference,+ getRow,+ nullSet,+ disjoint,+ differenceWithRow,+ findIndices,+ filterDisjointRows,+ )++import Control.Monad.HT ((<=<))+import Control.Monad (foldM)+import Control.Applicative (liftA3, pure, (<$>))++import qualified Data.Array.Knead.Parameterized.Render as Render+import qualified Data.Array.Knead.Simple.Physical as Phys+import qualified Data.Array.Knead.Simple.Symbolic as Symb+import qualified Data.Array.Knead.Simple.Slice as Slice+import qualified Data.Array.Knead.Shape as Shape+import qualified Data.Array.Knead.Expression as Expr+import Data.Array.Knead.Expression ((.|.*))++import qualified Data.Array.Comfort.Shape as ComfortShape+import qualified Data.Array.Comfort.Boxed as Array+import Data.Array.Comfort.Boxed (Array)+++import qualified System.IO.Lazy as LazyIO+import System.IO.Unsafe (unsafePerformIO)++import qualified Data.List.Match as Match+import qualified Data.Set as Set+import qualified Data.Bool8 as Bool8+import Data.Set (Set)+import Data.Bool8 (Bool8)++import Prelude2010+import Prelude ()+++data State label =+ State {+ availableSubsets ::+ (Array SetDim label, Phys.Array (SetDim,BlockDim) Block),+ freeElements :: Phys.Array BlockDim Block,+ usedSubsets :: [label]+ }++initStateIO :: (Ord a) => [ESC.Assign label (Set a)] -> IO (State label)+initStateIO assigns = do+ let neAssigns = filter (not . Set.null . ESC.labeledSet) assigns+ (avails, freeBlocks) = blocksFromSets $ map ESC.labeledSet neAssigns+ shSets = Shape.ZeroBased $ fromIntegral $ length neAssigns+ free <- Phys.vectorFromList freeBlocks+ avail <-+ Phys.fromList (shSets, Phys.shape free) $+ concatMap (Match.take freeBlocks) avails+ return $+ State {+ availableSubsets =+ (Array.fromList shSets $ map ESC.label neAssigns, avail),+ freeElements = free,+ usedSubsets = []+ }+++updateStateIO :: IO (SetId -> State label -> LazyIO.T (State label))+updateStateIO = do+ filt <- filterDisjointRows+ diff <- Render.run differenceWithRow+ return $ \k s ->+ LazyIO.interleave $+ liftA3 State+ (filt k $ availableSubsets s)+ (diff (freeElements s) k $ snd $ availableSubsets s)+ (pure (fst (availableSubsets s) Array.! k : usedSubsets s))++++_minimumSet ::+ IO (Phys.Array BlockDim Block ->+ Phys.Array (DigitDim, BlockDim) Block -> IO (Phys.Array BlockDim Block))+_minimumSet = do+ runNullSet <- Render.run (Expr.bool8FromP . nullSet)+ runDifferenceWithRow <- Render.run differenceWithRow+ return $ \baseSet bag ->+ foldM+ (\mins k -> do+ newMins <- runDifferenceWithRow mins k bag+ isNull <- runNullSet newMins+ return $ if Bool8.toBool isNull then mins else newMins)+ baseSet+ (reverse $ ComfortShape.indices $ fst $ Phys.shape bag)+++differenceWithRowNull ::+ IO (Phys.Array BlockDim Block ->+ DigitId -> Phys.Array (DigitDim, BlockDim) Block ->+ IO (Bool8, Phys.Array BlockDim Block))+differenceWithRowNull =+ Render.run $ \set k bag ->+ Render.MapAccumLSequence+ (\acc x -> Expr.zip (acc.|.*x) x)+ (Expr.bool8FromP . nullBlock)+ Expr.zero+ (Symb.zipWith difference set $ getRow k bag)++minimumSet ::+ IO (Phys.Array BlockDim Block ->+ Phys.Array (DigitDim, BlockDim) Block -> IO (Phys.Array BlockDim Block))+minimumSet = do+ runDifferenceWithRow <- differenceWithRowNull+ return $ \baseSet bag ->+ foldM+ (\mins k -> do+ (isNull,newMins) <- runDifferenceWithRow mins k bag+ return $ if Bool8.toBool isNull then mins else newMins)+ baseSet+ (reverse $ ComfortShape.indices $ fst $ Phys.shape bag)++++keepMinimum :: IO (Phys.Array BlockDim Block -> IO (BlockId,Block))+keepMinimum =+ Render.run $ \xs ->+ Expr.maybe Expr.zero (Expr.mapSnd keepMinimumBit) $+ Symb.findAll (Expr.not . nullBlock . Expr.snd) $+ Symb.zip (Symb.id (Symb.shape xs)) xs++affectedRows ::+ IO (Phys.Array (SetDim,BlockDim) Block -> (BlockId,Block) -> IO [SetId])+affectedRows = do+ affected <-+ Render.run $ \arr (j,bit) ->+ findIndices $ Symb.map (Expr.not . disjoint bit) $+ Slice.apply (Slice.pickSnd j) $ Symb.fix arr+ return $ \arr bit -> Phys.toList =<< affected arr bit++minimize ::+ IO (Phys.Array BlockDim Block ->+ Phys.Array (SetDim,BlockDim) Block -> IO [SetId])+minimize = do+ smBags <- sumBags3+ minSet <- minimumSet+ keepMin <- keepMinimum+ affected <- affectedRows+ return $ \free arr ->+ affected arr =<< keepMin =<< minSet free =<< smBags arr++stepIO :: IO (State label -> LazyIO.T [State label])+stepIO = do+ update <- updateStateIO+ minim <- minimize+ return $ \s ->+ mapM (flip update s) =<<+ LazyIO.interleave (minim (freeElements s) (snd $ availableSubsets s))++searchIO :: IO (State label -> LazyIO.T [[label]])+searchIO = do+ stp <- stepIO+ nullSt <- Render.run (Expr.bool8FromP . nullSet)+ let srch s = do+ isNull <- LazyIO.interleave $ nullSt (freeElements s)+ if Bool8.toBool isNull+ then return [usedSubsets s]+ else concat <$> (mapM srch =<< stp s)+ return srch++partitionsIO :: (Ord a) => IO ([ESC.Assign label (Set a)] -> LazyIO.T [[label]])+partitionsIO = do+ srch <- searchIO+ return $ srch <=< LazyIO.interleave . initStateIO++partitions :: (Ord a) => [ESC.Assign label (Set a)] -> [[label]]+partitions =+ let parts = unsafePerformIO partitionsIO+ in unsafePerformIO . LazyIO.run . parts
+ src/Math/SetCover/Exact/Knead/Saturated.hs view
@@ -0,0 +1,473 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+module Math.SetCover.Exact.Knead.Saturated (+ partitionsIO, searchIO, stepIO,+ partitions,+ State(..), initStateIO, updateStateIO,+ ) where++import qualified Math.SetCover.Exact as ESC+import Math.SetCover.Exact.Knead.Vector (Block)+import Math.SetCover.Exact.Knead.Symbolic+ (SetId, SetDim, BlockId, BlockDim, blocksFromSets,+ nullSet, disjoint, disjointRows, differenceWithRow,+ findIndices, collectRows)++import qualified Control.Monad.HT as Monad+import Control.Monad.HT ((<=<))+import Control.Monad (foldM)+import Control.Applicative (liftA2, liftA3, pure, (<$>), (<*>))++import qualified Data.Array.Knead.Parameterized.Render as Render+import qualified Data.Array.Knead.Simple.Physical as Phys+import qualified Data.Array.Knead.Simple.Symbolic as Symb+import qualified Data.Array.Knead.Simple.Slice as Slice+import qualified Data.Array.Knead.Shape as Shape+import qualified Data.Array.Knead.Expression.Vector as ExprVec+import qualified Data.Array.Knead.Expression as Expr+import Data.Array.Knead.Expression (Exp, (/=*), (<*), (.&.*), )++import qualified Data.Array.Comfort.Boxed as Array+import Data.Array.Comfort.Boxed (Array)++import qualified LLVM.Extra.Extension.X86 as X86+import qualified LLVM.Extra.Extension as Ext+import qualified LLVM.Extra.Multi.Vector as MultiVector+import qualified LLVM.Extra.Multi.Value.Vector as MultiValueVec+import qualified LLVM.Extra.Multi.Value as MultiValue+import LLVM.Extra.Multi.Vector.Memory ()+import LLVM.Extra.Multi.Value (atom)++import qualified LLVM.Core as LLVM++import qualified Type.Data.Num.Decimal as TypeNum+import Type.Data.Num.Decimal ((:+:))++import qualified System.IO.Lazy as LazyIO+import System.IO.Unsafe (unsafePerformIO)++import qualified Data.NonEmpty.Class as NonEmptyC+import qualified Data.List.Match as Match+import qualified Data.Set as Set+import qualified Data.Word as Word+import qualified Data.Int as Int+import qualified Data.Bool8 as Bool8+import qualified Data.Bits as Bits+import Data.Functor.Compose (Compose(Compose,getCompose))+import Data.Set (Set)++import Prelude2010+import Prelude ()+++type NumCounters = TypeNum.D16+type Counter = Word.Word8+type Counters = LLVM.Vector NumCounters Counter+type Subblock = Word.Word8+type Block16 = LLVM.Vector TypeNum.D8 Word.Word16+-- type Block128 = LLVM.WordN TypeNum.D128++bitSize :: Int+bitSize = Bits.bitSize (0::Counter)++numCounters :: Integer+numCounters =+ TypeNum.integerFromSingleton+ (TypeNum.singleton :: TypeNum.Singleton NumCounters)++type CounterId = Int.Int16+type BitId = Int.Int8++type CounterDim = Shape.ZeroBased CounterId+type BitDim = Shape.ZeroBased BitId+++data State label =+ State {+ availableSubsets ::+ (Array SetDim label, Phys.Array (SetDim,BlockDim) Block),+ freeElements :: Phys.Array BlockDim Block,+ usedSubsets :: [label]+ }++initStateIO :: (Ord a) => [ESC.Assign label (Set a)] -> IO (State label)+initStateIO assigns = do+ let neAssigns = filter (not . Set.null . ESC.labeledSet) assigns+ (avails, freeBlocks) = blocksFromSets $ map ESC.labeledSet neAssigns+ shSets = Shape.ZeroBased $ fromIntegral $ length neAssigns+ free <- Phys.vectorFromList freeBlocks+ avail <-+ Phys.fromList (shSets, Phys.shape free) $+ concatMap (Match.take freeBlocks) avails+ return $+ State {+ availableSubsets =+ (Array.fromList shSets $ map ESC.label neAssigns, avail),+ freeElements = free,+ usedSubsets = []+ }+++repVec :: Counter -> Exp Counters+repVec = Expr.fromInteger' . toInteger++{- |+We add bytes with saturation.+The first operand must consist exclusively of zeros and ones.++With saturation we perform the same as the unoptimized algorithm+if the element with minimum occurrence is contained in at most 254 sets.+This is pretty much and should never happen.+If all elements occur in more than 254 sets+then we will choose the first one+which might lead to an unnecessary long case analysis,+but would still yield correct results.+-}+incSat :: Exp Counters -> Exp Counters -> Exp Counters+incSat x y =+ let maxBnd = repVec maxBound+ in ExprVec.select (ExprVec.cmp LLVM.CmpEQ y maxBnd)+ maxBnd (Expr.add x y)++incSatGeneric ::+ LLVM.Value Counters -> LLVM.Value Counters ->+ LLVM.CodeGenFunction r (LLVM.Value Counters)+incSatGeneric x y =+ (\(MultiValue.Cons z) -> getCompose z)+ <$>+ Expr.unliftM2 incSat+ (MultiValue.Cons (Compose x)) (MultiValue.Cons (Compose y))++incSatX86 :: Exp Counters -> Exp Counters -> Exp Counters+incSatX86 =+ Expr.liftM2+ (MultiValue.liftM2+ (\xc yc ->+ Compose <$>+ case (getCompose xc, getCompose yc) of+ (x,y) ->+ Ext.run (incSatGeneric x y)+ (X86.paddusb128 <*> pure x <*> pure y)))++sumRows ::+ Symb.Array (SetDim, blockDim) Counters ->+ Render.FoldOuterL SetDim blockDim Counters Counters+sumRows xs =+ Render.FoldOuterL (flip incSatX86)+ (Symb.fill (Expr.snd $ Symb.shape xs) Expr.zero) xs+++extrudeBits :: Slice.T sh (sh, BitDim)+extrudeBits =+ Slice.extrudeSnd $ Expr.compose $ Shape.ZeroBased $+ Expr.fromInteger' $ toInteger bitSize++extrudeCounters :: Slice.T sh (sh, CounterDim)+extrudeCounters =+ Slice.extrudeSnd $ Expr.compose $ Shape.ZeroBased $+ Expr.fromInteger' numCounters++toCounters :: Exp Block -> Exp Counters+toCounters =+ Expr.liftM (MultiValue.liftM (fmap Compose . LLVM.bitcast))++_pickBits :: Exp BitId -> Exp Block -> Exp Counters+_pickBits k block =+ repVec 1 .&.* Expr.shr (toCounters block) (ExprVec.replicate (bitPos k))+++word16 :: Exp BitId -> Exp Word.Word16+word16 = Expr.liftM (MultiValue.liftM LLVM.ext) . bitPos++toBlock16 :: Exp Block -> Exp Block16+toBlock16 =+ Expr.liftM (MultiValue.liftM (fmap Compose . LLVM.bitcast))++fromBlock16 :: Exp Block16 -> Exp Counters+fromBlock16 =+ Expr.liftM (MultiValue.liftM (fmap Compose . LLVM.bitcast . getCompose))++pickBitsX86 :: Exp BitId -> Exp Block -> Exp Counters+pickBitsX86 k block =+ repVec 1 .&.*+ fromBlock16 (Expr.shr (toBlock16 block) (ExprVec.replicate (word16 k)))++uninterleaveBits ::+ Symb.Array (SetDim, BlockDim) Block ->+ Symb.Array (SetDim, (BlockDim, BitDim)) Counters+uninterleaveBits =+ Symb.mapWithIndex (\ix block -> pickBitsX86 (Expr.snd (Expr.snd ix)) block) .+ Slice.apply (Slice.second extrudeBits)+++filterDisjointRows ::+ IO (SetId ->+ (Array SetDim label, Phys.Array (SetDim,BlockDim) Block) ->+ IO (Array SetDim label, Phys.Array (SetDim,BlockDim) Block))+filterDisjointRows = do+ disjRows <- Render.run $ \k -> findIndices . disjointRows k+ collect <- Render.run collectRows+ return $ \k0 (labels,sets) -> do+ perm <- disjRows k0 sets+ liftA2 (,)+ (Array.fromList (Phys.shape perm) . map (labels Array.!)+ <$> Phys.toList perm)+ (collect perm sets)++updateStateIO :: IO (SetId -> State label -> LazyIO.T (State label))+updateStateIO = do+ filt <- filterDisjointRows+ diff <- Render.run differenceWithRow+ return $ \k s ->+ LazyIO.interleave $+ liftA3 State+ (filt k $ availableSubsets s)+ (diff (freeElements s) k $ snd $ availableSubsets s)+ (pure (fst (availableSubsets s) Array.! k : usedSubsets s))+++mvvec :: MultiValue.T (LLVM.Vector n a) -> MultiVector.T n a+mvvec (MultiValue.Cons x) = MultiVector.Cons x++extract ::+ (TypeNum.Positive n, MultiVector.C a) =>+ Exp CounterId -> Exp (LLVM.Vector n a) -> Exp a+extract =+ Expr.liftM2+ (\(MultiValue.Cons k) v ->+ flip MultiVector.extract (mvvec v) =<< LLVM.zext k)++extractBlock :: Exp CounterId -> Exp Block -> Exp Subblock+extractBlock =+ Expr.liftM2+ (\(MultiValue.Cons k) (MultiValue.Cons v) ->+ MultiValue.Cons <$> (LLVM.extractelement v =<< LLVM.zext k))++flattenCounters ::+ Symb.Array (BlockDim, BitDim) Counters ->+ Symb.Array ((BlockDim,CounterDim), BitDim) Counter+flattenCounters =+ Symb.mapWithIndex (\ix block -> extract (Expr.snd (Expr.fst ix)) block) .+ Slice.apply (Slice.first extrudeCounters)+++bitPos :: Exp BitId -> Exp Subblock+bitPos = Expr.liftM (MultiValue.liftM LLVM.bitcast)++singleBit :: Exp BitId -> Exp Subblock+singleBit = Expr.shl 1 . bitPos+++argMin ::+ (MultiValue.Select x, MultiValue.Select y, MultiValue.Comparison y) =>+ Exp (x,y) -> Exp (x,y) -> Exp (x,y)+argMin xy0 xy1 = Expr.select (Expr.snd xy0 <* Expr.snd xy1) xy0 xy1++argMinimum ::+ (Shape.C sh, Shape.Index sh ~ ix, MultiValue.Select ix) =>+ Symb.Array sh Counter -> Exp ix+argMinimum = Expr.fst . Symb.fold1All argMin . Symb.mapWithIndex Expr.zip++_keepMinimum ::+ IO (Phys.Array (BlockDim, BitDim) Counters ->+ IO ((BlockId,CounterId),Counter))+_keepMinimum =+ Render.run $ Expr.mapSnd singleBit . argMinimum . flattenCounters+++argMinMasked ::+ (MultiValue.Select x, MultiValue.Select y, MultiValue.Comparison y) =>+ Exp (Bool, (x,y)) -> Exp (Bool, (x,y)) -> Exp (Bool, (x,y))+argMinMasked xy0 xy1 =+ Expr.select (Expr.fst xy1)+ (Expr.select (Expr.fst xy0)+ (Expr.zip Expr.true $ argMin (Expr.snd xy0) (Expr.snd xy1))+ xy1)+ xy0++testBlockBit :: Exp CounterId -> Exp BitId -> Exp Block -> Exp Bool+testBlockBit k j block = Expr.shr (extractBlock k block) (bitPos j) .&.* 1 /=* 0++flattenBlockBits ::+ Symb.Array BlockDim Block ->+ Symb.Array ((BlockDim,CounterDim), BitDim) Bool+flattenBlockBits =+ Symb.mapWithIndex+ (Expr.modify2 ((atom,atom),atom) atom $ \((_n,k),j) block ->+ testBlockBit k j block) .+ Slice.apply (Slice.compose extrudeCounters extrudeBits)++argMinimumMasked ::+ Symb.Array BlockDim Block ->+ Symb.Array ((BlockDim,CounterDim), BitDim) Counter ->+ Exp ((BlockId,CounterId),BitId)+argMinimumMasked free =+ Expr.fst . Expr.snd . Symb.fold1All argMinMasked .+ Symb.zip (flattenBlockBits free) . Symb.mapWithIndex Expr.zip++_keepMinimumMasked ::+ IO (Phys.Array BlockDim Block ->+ Phys.Array (BlockDim,BitDim) Counters ->+ IO ((BlockId,CounterId),Counter))+_keepMinimumMasked =+ Render.run $ \free ->+ Expr.mapSnd singleBit . argMinimumMasked free . flattenCounters+++argMinVec ::+ (TypeNum.Positive n,+ MultiVector.Select x, MultiVector.Select y, MultiVector.Comparison y) =>+ Exp (LLVM.Vector n (x,y)) -> Exp (LLVM.Vector n (x,y)) ->+ Exp (LLVM.Vector n (x,y))+argMinVec xy0 xy1 =+ ExprVec.select+ (ExprVec.cmp LLVM.CmpLT (ExprVec.snd xy0) (ExprVec.snd xy1)) xy0 xy1++argMinMaskedVec ::+ (TypeNum.Positive n,+ MultiVector.Select x, MultiVector.Select y, MultiVector.Comparison y) =>+ Exp (LLVM.Vector n (Bool, (x,y))) -> Exp (LLVM.Vector n (Bool, (x,y))) ->+ Exp (LLVM.Vector n (Bool, (x,y)))+argMinMaskedVec xy0 xy1 =+ ExprVec.select (ExprVec.fst xy1)+ (ExprVec.select (ExprVec.fst xy0)+ (ExprVec.zip (ExprVec.replicate Expr.true) $+ argMinVec (ExprVec.snd xy0) (ExprVec.snd xy1))+ xy1)+ xy0++testBlockBitVec ::+ Exp BitId -> Exp Block -> Exp (LLVM.Vector NumCounters Bool)+testBlockBitVec j block =+ ExprVec.cmp LLVM.CmpNE Expr.zero $ pickBitsX86 j block++flattenBlockBitsVec ::+ Symb.Array BlockDim Block ->+ Symb.Array (BlockDim,BitDim) (LLVM.Vector NumCounters Bool)+flattenBlockBitsVec =+ Symb.mapWithIndex+ (Expr.modify2 (atom,atom) atom $ \(_n,j) block ->+ testBlockBitVec j block) .+ Slice.apply extrudeBits++argMinimumMaskedVec ::+ Symb.Array BlockDim Block ->+ Symb.Array (BlockDim, BitDim) Counters ->+ Exp (LLVM.Vector NumCounters (Bool, ((BlockId, BitId), Counter)))+argMinimumMaskedVec free =+ Symb.fold1All argMinMaskedVec .+ Symb.zipWith ExprVec.zip (flattenBlockBitsVec free) .+ Symb.mapWithIndex (ExprVec.zip . ExprVec.replicate)++counterIds :: Exp (LLVM.Vector NumCounters CounterId)+counterIds = ExprVec.cons (LLVM.vector (NonEmptyC.iterate (1+) 0))++_keepMinimumMaskedVector ::+ Exp (LLVM.Vector NumCounters (Bool, ((BlockId, BitId), Counter))) ->+ Exp ((BlockId, CounterId), BitId)+_keepMinimumMaskedVector =+ Expr.liftM+ (fmap (MultiValue.fst . MultiValue.snd) .+ foldM (Expr.unliftM2 argMinMasked)+ (MultiValue.zip (MultiValue.cons False) MultiValue.undef)+ <=< MultiValueVec.dissect)+ .+ ExprVec.mapSnd+ (ExprVec.mapFst (ExprVec.mapFst (flip ExprVec.zip counterIds)))++type+ IxVector n =+ MultiValue.T (LLVM.Vector n+ (Bool, (((BlockId, CounterId), BitId), Counter)))++argMinMaskedVecHalf ::+ (TypeNum.Positive n, TypeNum.Positive n2, (n:+:n) ~ n2,+ MultiVector.Select x, MultiVector.Select y, MultiVector.Comparison y) =>+ MultiValue.T (LLVM.Vector n2 (Bool, (x, y))) ->+ LLVM.CodeGenFunction r (MultiValue.T (LLVM.Vector n (Bool, (x, y))))+argMinMaskedVecHalf x =+ Monad.liftJoin2+ (Expr.unliftM2 argMinMaskedVec)+ (MultiValueVec.take x)+ (MultiValueVec.takeRev x)++keepMinimumMaskedCascade ::+ Exp (LLVM.Vector NumCounters (Bool, ((BlockId, BitId), Counter))) ->+ Exp ((BlockId, CounterId), BitId)+keepMinimumMaskedCascade =+ Expr.fst . Expr.snd+ .+ Expr.liftM+ (\x16 -> do+ x8 <- argMinMaskedVecHalf x16+ x4 <- argMinMaskedVecHalf x8+ x2 <- argMinMaskedVecHalf x4+ Monad.liftJoin2 (Expr.unliftM2 argMinMasked)+ (MultiValueVec.extract (LLVM.valueOf 0) (x2 :: IxVector TypeNum.D2))+ (MultiValueVec.extract (LLVM.valueOf 1) x2))+ .+ ExprVec.mapSnd+ (ExprVec.mapFst (ExprVec.mapFst (flip ExprVec.zip counterIds)))++{- |+In general this function will choose a different minimal element+than 'keepMinimumMasked'.+-}+keepMinimumMaskedVec ::+ IO (Phys.Array BlockDim Block ->+ Phys.Array (BlockDim, BitDim) Counters ->+ IO ((BlockId,CounterId),Subblock))+keepMinimumMaskedVec =+ Render.run $ \free ->+ Expr.mapSnd singleBit . keepMinimumMaskedCascade .+ argMinimumMaskedVec free+++affectedRows ::+ IO (Phys.Array (SetDim,BlockDim) Block ->+ ((BlockId,CounterId),Subblock) -> IO [SetId])+affectedRows = do+ affected <-+ Render.run $ \arr ((j,k),bit) ->+ findIndices $ Symb.map (Expr.not . disjoint bit . extractBlock k) $+ Slice.apply (Slice.pickSnd j) $ Symb.fix arr+ return $ \arr bit -> Phys.toList =<< affected arr bit+++minimize ::+ IO (Phys.Array BlockDim Block ->+ Phys.Array (SetDim,BlockDim) Block -> IO [SetId])+minimize = do+ smRows <- Render.run (sumRows . uninterleaveBits)+ affected <- affectedRows+ keepMin <- keepMinimumMaskedVec+ return $ \free arr -> affected arr =<< keepMin free =<< smRows arr++stepIO :: IO (State label -> LazyIO.T [State label])+stepIO = do+ update <- updateStateIO+ minim <- minimize+ return $ \s ->+ mapM (flip update s) =<<+ LazyIO.interleave (minim (freeElements s) (snd $ availableSubsets s))++searchIO :: IO (State label -> LazyIO.T [[label]])+searchIO = do+ stp <- stepIO+ nullSt <- Render.run (Expr.bool8FromP . nullSet)+ let srch s = do+ isNull <- LazyIO.interleave $ nullSt (freeElements s)+ if Bool8.toBool isNull+ then return [usedSubsets s]+ else concat <$> (mapM srch =<< stp s)+ return srch++partitionsIO :: (Ord a) => IO ([ESC.Assign label (Set a)] -> LazyIO.T [[label]])+partitionsIO = do+ srch <- searchIO+ return $ srch <=< LazyIO.interleave . initStateIO++partitions :: (Ord a) => [ESC.Assign label (Set a)] -> [[label]]+partitions =+ let parts = unsafePerformIO partitionsIO+ in unsafePerformIO . LazyIO.run . parts
+ src/Math/SetCover/Exact/Knead/Symbolic.hs view
@@ -0,0 +1,303 @@+module Math.SetCover.Exact.Knead.Symbolic (+ BitSet(..),+ Block,++ SetId, SetDim, BlockId, BlockDim, DigitId, DigitDim,+ sumBags3,+ difference,+ getRow,+ nullSet,+ disjoint,+ disjointRows,+ differenceWithRow,+ findIndices,+ filterDisjointRows,+ collectRows,+ ) where++import qualified Math.SetCover.Exact.Block as Blocks++import Control.Monad.HT ((<=<))+import Control.Applicative (liftA2, (<$>))++import qualified Data.Array.Knead.Parameterized.Render as Render+import qualified Data.Array.Knead.Simple.Physical as Phys+import qualified Data.Array.Knead.Simple.Symbolic as Symb+import qualified Data.Array.Knead.Simple.Slice as Slice+import qualified Data.Array.Knead.Shape as Shape+import qualified Data.Array.Knead.Expression as Expr+import Data.Array.Knead.Simple.Symbolic ((!))+import Data.Array.Knead.Expression+ (Exp, (==*), (<*), xor, (.|.*), (.&.*), )++import qualified Data.Array.Comfort.Shape as ComfortShape+import qualified Data.Array.Comfort.Storable.Unchecked as ComfortArray+import qualified Data.Array.Comfort.Boxed as Array+import Data.Array.Comfort.Boxed (Array)++import qualified LLVM.Extra.Multi.Value as MultiValue+import LLVM.Extra.Multi.Value (atom)++import qualified Data.Word as Word+import qualified Data.Int as Int+import Data.Set (Set)++import Prelude2010+import Prelude ()++++class (MultiValue.Logic block) => BitSet block where+ nullBlock :: Exp block -> Exp Bool+ blocksFromSets :: (Ord a) => [Set a] -> ([[block]], [block])+ keepMinimumBit :: Exp block -> Exp block++instance BitSet Word.Word8 where+ nullBlock block = block ==* Expr.zero+ blocksFromSets sets = Blocks.blocksFromSets sets+ keepMinimumBit = keepMinimumBitPrim++instance BitSet Word.Word16 where+ nullBlock block = block ==* Expr.zero+ blocksFromSets sets = Blocks.blocksFromSets sets+ keepMinimumBit = keepMinimumBitPrim++instance BitSet Word.Word32 where+ nullBlock block = block ==* Expr.zero+ blocksFromSets sets = Blocks.blocksFromSets sets+ keepMinimumBit = keepMinimumBitPrim++instance BitSet Word.Word64 where+ nullBlock block = block ==* Expr.zero+ blocksFromSets sets = Blocks.blocksFromSets sets+ keepMinimumBit = keepMinimumBitPrim++keepMinimumBitPrim ::+ (MultiValue.Additive a, MultiValue.Logic a) => Exp a -> Exp a+keepMinimumBitPrim =+ Expr.liftM (\x -> MultiValue.and x =<< MultiValue.neg x)++++type Block = Word.Word64++-- SetId must allow negative numbers since it is used for empty plain Arrays+type SetId = Int.Int32+type BlockId = Int.Int32+type DigitId = Word.Word32++type SetDim = Shape.ZeroBased SetId+type BlockDim = Shape.ZeroBased BlockId+type DigitDim = Shape.ZeroBased DigitId+++addLow, addHigh :: MultiValue.Logic a => Exp a -> Exp a -> Exp a -> Exp a+addLow a b c = a `xor` b `xor` c+addHigh a b c = c.&.*(a.|.*b) .|.* a.&.*b++add2 ::+ IO (Phys.Array ((SetDim, BlockDim), DigitDim) Block ->+ IO (Phys.Array ((SetDim, BlockDim), DigitDim) Block))+add2 =+ Render.run $ \xs ->+ Render.MapAccumLSimple+ (Expr.modify2 atom (atom,atom) $ \carry (a,b) ->+ (addHigh a b carry, addLow a b carry))+ (Symb.fill (Expr.fst (Symb.shape xs)) Expr.zero)+ (halfBags xs)+++zbAtom :: Shape.ZeroBased (MultiValue.Atom a)+zbAtom = Shape.ZeroBased atom++halfBags ::+ Symb.Array ((SetDim, BlockDim), DigitDim) Block ->+ Symb.Array ((SetDim, BlockDim), DigitDim) (Block,Block)+halfBags xs =+ Symb.map+ (Expr.modify2 ((zbAtom, atom), zbAtom) ((atom,atom),atom)+ (\((Shape.ZeroBased numSets, _shBlocks), Shape.ZeroBased numDigits)+ ((n,j),k) ->+ elseIfThen Expr.zero (k<*numDigits) $+ Expr.zip+ (xs ! Expr.zip (Expr.zip (2*n) j) k)+ (elseIfThen Expr.zero (2*n+1<*numSets)+ (xs ! Expr.zip (Expr.zip (2*n+1) j) k)))+ (Symb.shape xs)) $+ Symb.id+ (Expr.modify ((zbAtom, atom), zbAtom)+ (\((Shape.ZeroBased numSets, shBlocks), Shape.ZeroBased numDigits) ->+ ((Shape.ZeroBased (Expr.idiv (numSets+1) 2), shBlocks),+ Shape.ZeroBased (numDigits+1)))+ (Symb.shape xs))++elseIfThen :: MultiValue.C a => Exp a -> Exp Bool -> Exp a -> Exp a+elseIfThen y c x = Expr.ifThenElse c x y+++removeDimension ::+ IO (Phys.Array ((SetDim, BlockDim), DigitDim) Block ->+ IO (Phys.Array (DigitDim, BlockDim) Block))+removeDimension =+ Render.run $+ Symb.fix .+ Slice.apply+ (Slice.first (Slice.pickFst Expr.zero)+ `Slice.compose`+ Slice.transpose)++sumLoop ::+ IO (Phys.Array ((SetDim, BlockDim), DigitDim) Block ->+ IO (Phys.Array (DigitDim, BlockDim) Block))+sumLoop = do+ runAdd2 <- add2+ remDim <- removeDimension++ let go xs =+ if (ComfortShape.zeroBasedSize $ fst $ fst $ Phys.shape xs) > 1+ then go =<< runAdd2 xs+ else remDim xs++ return go++addSingleDim :: Phys.Array sh a -> Phys.Array (sh,DigitDim) a+addSingleDim = ComfortArray.mapShape (flip (,) (Shape.ZeroBased 1))++{-+ToDo:+We could use a carry-save adder that would enable more parallelism.+Unfortunately, currently we cannot benefit from this opportunity.+-}+_sumBags ::+ IO (Phys.Array (SetDim,BlockDim) Block ->+ IO (Phys.Array (DigitDim,BlockDim) Block))+_sumBags = (.addSingleDim) <$> sumLoop+++{- |+A faster first addition step.+In the first addition we do not need to propagate carry.+We use this fact for reducing the number of rows to a third.+-}+_add3 ::+ IO (Phys.Array (SetDim, BlockDim) Block ->+ IO (Phys.Array ((SetDim, BlockDim), DigitDim) Block))+_add3 =+ Render.run $ \xs ->+ Symb.mapWithIndex+ (Expr.modify2 (atom,atom) (atom,atom,atom) $ \(_,k) (a,b,c) ->+ Expr.ifThenElse (k ==* Expr.zero) (addLow a b c) (addHigh a b c))+ (Slice.apply (Slice.extrudeSnd digitDim2) $ thirdBags xs)++add3 ::+ IO (Phys.Array (SetDim, BlockDim) Block ->+ IO (Phys.Array ((SetDim, BlockDim), DigitDim) Block))+add3 =+ Render.run $+ Render.AddDimension digitDim2+ (Expr.modify2 atom (atom,atom,atom) $ \k (a,b,c) ->+ Expr.ifThenElse (k ==* Expr.zero) (addLow a b c) (addHigh a b c))+ .+ thirdBags++digitDim2 :: Exp DigitDim+digitDim2 = Expr.compose $ Shape.ZeroBased $ Expr.fromInteger' 2++thirdBags ::+ Symb.Array (SetDim, BlockDim) Block ->+ Symb.Array (SetDim, BlockDim) (Block,Block,Block)+thirdBags xs =+ Symb.map+ (Expr.modify (atom,atom)+ (\(n,j) ->+ Expr.zip3+ (xs ! Expr.zip (3*n) j)+ (condAccess xs (3*n+1) j)+ (condAccess xs (3*n+2) j))) $+ Symb.id+ (Expr.mapFst+ (Expr.modify zbAtom+ (\(Shape.ZeroBased numSets) ->+ Shape.ZeroBased $ Expr.idiv (numSets+2) 3))+ (Symb.shape xs))++condAccess ::+ Symb.Array (SetDim, BlockDim) Block -> Exp SetId -> Exp BlockId -> Exp Block+condAccess xs n j =+ Expr.ifThenElse (n <* Shape.zeroBasedSize (Expr.fst (Symb.shape xs)))+ (xs ! Expr.zip n j) Expr.zero++sumBags3 ::+ IO (Phys.Array (SetDim,BlockDim) Block ->+ IO (Phys.Array (DigitDim,BlockDim) Block))+sumBags3 = liftA2 (<=<) sumLoop add3+++difference :: (MultiValue.Logic a) => Exp a -> Exp a -> Exp a+difference x y = x .&.* Expr.complement y++differenceWithRow ::+ (Shape.C k, MultiValue.Logic block) =>+ Symb.Array BlockDim block -> Exp (Shape.Index k) ->+ Symb.Array (k,BlockDim) block -> Symb.Array BlockDim block+differenceWithRow x k bag =+ Symb.zipWith difference x (getRow k bag)+++disjoint :: (BitSet block) => Exp block -> Exp block -> Exp Bool+disjoint x y = nullBlock $ x .&.* y++getRow ::+ (Shape.C k, MultiValue.C block) =>+ Exp (Shape.Index k) ->+ Symb.Array (k, BlockDim) block -> Symb.Array BlockDim block+getRow k = Slice.apply (Slice.pickFst k)++nullSet :: (BitSet block) => Symb.Array BlockDim block -> Exp Bool+nullSet =+ Expr.maybe Expr.true (const Expr.false) . Symb.findAll (Expr.not . nullBlock)++disjointRow ::+ (BitSet block) =>+ Exp SetId -> Exp SetId -> Symb.Array (SetDim, BlockDim) block -> Exp Bool+disjointRow k0 k1 bag =+ nullSet $ Symb.zipWith (.&.*) (getRow k0 bag) (getRow k1 bag)++disjointRows ::+ (BitSet block) =>+ Exp SetId -> Symb.Array (SetDim,BlockDim) block -> Symb.Array SetDim Bool+disjointRows k0 sets =+ Symb.map+ (\k1 -> disjointRow k0 k1 sets)+ (Symb.id (Expr.fst (Symb.shape sets)))+++findIndices ::+ Symb.Array SetDim Bool -> Render.MapFilter SetDim (SetId,Bool) SetId+findIndices arr =+ Render.MapFilter Expr.fst Expr.snd+ (Symb.zip (Symb.id $ Symb.shape arr) arr)++collectRows ::+ (MultiValue.C block) =>+ Symb.Array SetDim SetId ->+ Symb.Array (SetDim,BlockDim) block -> Symb.Array (SetDim,BlockDim) block+collectRows rows sets =+ Symb.backpermute+ (Expr.mapFst (const $ Symb.shape rows) (Symb.shape sets))+ (Expr.mapFst (rows!))+ sets++filterDisjointRows ::+ IO (SetId ->+ (Array SetDim label, Phys.Array (SetDim,BlockDim) Block) ->+ IO (Array SetDim label, Phys.Array (SetDim,BlockDim) Block))+filterDisjointRows = do+ disjRows <- Render.run $ \k sets -> findIndices $ disjointRows k sets+ collect <- Render.run collectRows+ return $ \k (labels,sets) -> do+ perm <- disjRows k sets+ liftA2 (,)+ (Array.fromList (Phys.shape perm) . map (labels Array.!)+ <$> Phys.toList perm)+ (collect perm sets)
+ src/Math/SetCover/Exact/Knead/Vector.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE TypeFamilies #-}+module Math.SetCover.Exact.Knead.Vector (+ ByteVector, Block(..),+ ) where++import qualified Math.SetCover.Exact.Knead as ESC_Knead+import qualified Math.SetCover.Exact.Block as Blocks+import Math.SetCover.Exact.Knead (BitSet)++import Control.Applicative (liftA2)++import qualified Data.Array.Knead.Expression as Expr++import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMem+import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Arithmetic as A++import qualified LLVM.Core as LLVM+import qualified Type.Data.Num.Decimal as TypeNum++import qualified Foreign.Storable as Store+import Foreign.Storable (Storable)+import Foreign.Marshal.Array (advancePtr)+import Foreign.Ptr (castPtr)+import Data.Storable.Endian (peekLE, pokeLE)++import qualified Data.NonEmpty.Mixed as NonEmptyM+import qualified Data.NonEmpty.Class as NonEmptyC+import qualified Data.NonEmpty as NonEmpty+import qualified Data.Empty as Empty+import Data.Word (Word8, Word64)+import Data.Bits (shiftL, shiftR)+++type ByteVector = LLVM.Vector TypeNum.D16 Word8+data Block = Block {block0, block1 :: !Word64}++blockSize :: Int+blockSize = 2+++{-# INLINE getByte #-}+getByte :: Int -> Word64 -> Word8+getByte k x = fromIntegral $ shiftR x k++{-# INLINE _putByte #-}+_putByte :: Int -> Word8 -> Word64+_putByte k x = shiftL (fromIntegral x) k+++instance Storable Block where+ sizeOf = (blockSize*) . Store.sizeOf . block0+ alignment = (blockSize*) . Store.alignment . block0+ poke ptr (Block x0 x1) = do+ let ptr64 = castPtr ptr+ pokeLE ptr64 x0+ pokeLE (advancePtr ptr64 1) x1+ peek ptr =+ let ptr64 = castPtr ptr+ in liftA2 Block (peekLE ptr64) (peekLE (advancePtr ptr64 1))++instance MultiValue.C Block where+ type Repr f Block = f ByteVector+ cons (Block x0 x1) =+ MultiValue.consPrimitive $ LLVM.vector $+ fmap (\k -> if k<8 then getByte k x0 else getByte k x1) $+ NonEmptyC.iterate (1+) 0+ undef = MultiValue.undefPrimitive+ zero = MultiValue.zeroPrimitive+ phis = MultiValue.phisPrimitive+ addPhis = MultiValue.addPhisPrimitive++instance MultiValue.Logic Block where+ and = MultiValue.liftM2 LLVM.and; or = MultiValue.liftM2 LLVM.or+ xor = MultiValue.liftM2 LLVM.xor; inv = MultiValue.liftM LLVM.inv++instance MultiValueMem.C Block where+ type Struct Block = ByteVector+ load = MultiValueMem.loadPrimitive+ store = MultiValueMem.storePrimitive+ decompose = MultiValueMem.decomposePrimitive+ compose = MultiValueMem.composePrimitive++toWord128 ::+ LLVM.Value ByteVector ->+ LLVM.CodeGenFunction r (LLVM.Value (LLVM.WordN TypeNum.D128))+toWord128 = LLVM.bitcast++fromWord128 ::+ LLVM.Value (LLVM.WordN TypeNum.D128) ->+ LLVM.CodeGenFunction r (LLVM.Value ByteVector)+fromWord128 = LLVM.bitcast++instance BitSet Block where+ nullBlock =+ Expr.liftM (MultiValue.liftM (\x ->+ A.cmp LLVM.CmpEQ (LLVM.value LLVM.zero) =<< toWord128 x))+ blocksFromSets sets =+ let (avails, free) = Blocks.blocksFromSets sets+ numBlocks = - div (- length free) blockSize+ makeBlock (NonEmpty.Cons x0 (NonEmpty.Cons x1 Empty.Cons)) =+ Block x0 x1+ sliceRow =+ take numBlocks . map makeBlock . fst .+ NonEmptyM.sliceVertical . (++ repeat 0)+ in (map sliceRow avails, sliceRow free)+ keepMinimumBit =+ Expr.liftM (MultiValue.liftM (\x0 ->+ do x <- toWord128 x0; fromWord128 =<< A.and x =<< A.neg x))
src/Math/SetCover/Exact/Priority.hs view
@@ -8,7 +8,8 @@ Assign, ESC.label, ESC.labeledSet, ESC.assign, partitions, search, step, State(..), initState, updateState,- SetId, queueMap, queueSet, queueBit, queueBitPQ,+ Tree(..), decisionTree, completeTree,+ SetId, queueMap, queueSet, queueBit, queueBitPQ, queueIntSet, ) where import qualified Math.SetCover.Queue.Map as QueueMap@@ -21,11 +22,13 @@ import qualified Math.SetCover.Queue as Queue import qualified Math.SetCover.Exact as ESC import Math.SetCover.Queue (Methods, SetId(SetId))-import Math.SetCover.Exact (Assign(Assign), labeledSet)+import Math.SetCover.Exact (Assign(Assign), labeledSet, Tree(Branch,Leaf)) import qualified Math.SetCover.EnumMap as EnumMapX import qualified Data.EnumMap as EnumMap; import Data.EnumMap (EnumMap) import qualified Data.Foldable as Fold+import Data.EnumSet (EnumSet)+import Data.Tuple.HT (mapSnd) data State queue label set =@@ -60,23 +63,27 @@ usedSubsets = attemptLabel : usedSubsets s } +{-# INLINE nextStates #-}+nextStates ::+ Methods queue set ->+ State queue label set ->+ EnumSet SetId -> [State queue label set]+nextStates dict s =+ map (flip (updateState dict) s) . EnumMap.elems .+ EnumMapX.intersection (availableSubsets s)+ {-# INLINE step #-} step :: Methods queue set -> State queue label set -> [State queue label set] step dict s =- if EnumMap.null (availableSubsets s)- then []- else- flip Fold.foldMap (Queue.findMin dict (queue s)) $- map (flip (updateState dict) s) . EnumMap.elems .- EnumMapX.intersection (availableSubsets s)+ flip Fold.foldMap (Queue.findMin dict (queue s)) $ nextStates dict s {-# INLINE search #-} search :: Methods queue set -> State queue label set -> [[label]] search dict = let go s =- if Queue.null dict (queue s)- then [usedSubsets s]- else step dict s >>= go+ case Queue.findMin dict (queue s) of+ Nothing -> [usedSubsets s]+ Just setIds -> nextStates dict s setIds >>= go in go {-# INLINE partitions #-}@@ -84,6 +91,22 @@ partitions dict = search dict . initState dict ++completeTree :: Methods queue set -> State queue label set -> Tree label set+completeTree dict =+ let go s =+ case Queue.findMinValue dict (queue s) of+ Nothing -> Leaf+ Just mins ->+ uncurry Branch $ flip mapSnd mins $+ map (\asn -> (ESC.label asn, go $ updateState dict asn s)) .+ EnumMap.elems . EnumMapX.intersection (availableSubsets s)+ in go++decisionTree :: Methods queue set -> [Assign label set] -> Tree label set+decisionTree dict = completeTree dict . initState dict++ -- * different priority queue implementations queueMap :: Ord a => Queue.Methods queue set -> QueueMap.Methods a queue set@@ -94,6 +117,9 @@ queueBit :: BitPos.C bits => QueueBit.Methods bits queueBit = QueueBit.methods++queueIntSet :: QueueBit.MethodsIntSet+queueIntSet = QueueBit.methodsIntSet queueBitPQ :: BitPos.C bits => QueueBitPQ.Methods bits queueBitPQ = QueueBitPQ.methods
+ src/Math/SetCover/Exact/UArray.hs view
@@ -0,0 +1,267 @@+{- |+This implements "Math.SetCover.Exact" using unboxed arrays of bit vectors.+It should always be faster than using 'Integer's as bit vectors.+In contrast to 'IntSet' the set representation here is dense,+but has a much simpler structure.+It should be faster than 'IntSet' for most applications.+-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Math.SetCover.Exact.UArray (+ partitions, search, step,+ State(..), initState, updateState,+ ) where++import qualified Math.SetCover.Exact as ESC+import qualified Math.SetCover.Bit as Bit+import Math.SetCover.Exact.Block (blocksFromSets)++import Control.Monad.ST.Strict (ST)+import Control.Monad (foldM, forM_, when)++import qualified Data.Array.ST as STUArray+import qualified Data.Array.Unboxed as UArray+import qualified Data.List.Match as Match+import qualified Data.Set as Set+import qualified Data.Word as Word+import Data.Array.ST (STUArray, runSTUArray, writeArray)+import Data.Array.Unboxed (UArray)+import Data.Array.IArray (listArray, bounds, range, (!))+import Data.Array (Array, Ix)+import Data.Set (Set)+import Data.Tuple.HT (mapPair, mapSnd, fst3)+import Data.Bits (xor, (.&.), (.|.))++++type Block = Word.Word64++newtype SetId = SetId Int deriving (Eq,Ord,Ix,Enum,Show)+newtype DigitId = DigitId Int deriving (Eq,Ord,Ix,Enum,Show)+newtype BlockId = BlockId Int deriving (Eq,Ord,Ix,Show)+++data State label =+ State {+ availableSubsets :: (Array SetId label, UArray (SetId,BlockId) Block),+ freeElements :: UArray BlockId Block,+ usedSubsets :: [label]+ }++initState :: (Ord a) => [ESC.Assign label (Set a)] -> State label+initState assigns =+ let neAssigns = filter (not . Set.null . ESC.labeledSet) assigns+ (avails, free) = blocksFromSets $ map ESC.labeledSet neAssigns+ firstSet = SetId 0; lastSet = SetId $ length neAssigns - 1+ firstBlock = BlockId 0; lastBlock = BlockId $ length free - 1+ in State {+ availableSubsets =+ (listArray (firstSet,lastSet) $ map ESC.label neAssigns,+ listArray ((firstSet,firstBlock), (lastSet,lastBlock)) $+ concatMap (Match.take free) avails),+ freeElements = listArray (firstBlock,lastBlock) free,+ usedSubsets = []+ }+++type DifferenceWithRow k =+ UArray BlockId Block -> k ->+ UArray (k,BlockId) Block -> UArray BlockId Block++{-# SPECIALISE differenceWithRow :: DifferenceWithRow SetId #-}+{-# SPECIALISE differenceWithRow :: DifferenceWithRow DigitId #-}+differenceWithRow :: (Ix k) => DifferenceWithRow k+differenceWithRow x k bag =+ listArray (bounds x) $+ map (\j -> Bit.difference (x!j) (bag!(k,j))) (range $ bounds x)+++disjoint :: Block -> Block -> Bool+disjoint x y = x.&.y == 0++disjointRow :: SetId -> SetId -> UArray (SetId, BlockId) Block -> Bool+disjointRow k0 k1 sets =+ all+ (\j -> disjoint (sets!(k0,j)) (sets!(k1,j)))+ (range $ mapPair (snd,snd) $ bounds sets)++filterDisjointRows ::+ SetId ->+ (Array SetId label, UArray (SetId,BlockId) Block) ->+ (Array SetId label, UArray (SetId,BlockId) Block)+filterDisjointRows k0 (labels,sets) =+ let ((kl,jl), (ku,ju)) = bounds sets+ rows = filter (\k1 -> disjointRow k0 k1 sets) $ range (kl,ku)+ firstSet = SetId 0; lastSet = SetId $ length rows - 1+ rowsArr = listArray (firstSet, lastSet) rows+ bnds = ((firstSet,jl), (lastSet,ju))+ in (UArray.amap (labels!) rowsArr,+ listArray bnds $ map (\(n,j) -> sets!(rowsArr!n,j)) $ range bnds)+++{-# INLINE updateState #-}+updateState :: SetId -> State label -> State label+updateState k s =+ State {+ availableSubsets = filterDisjointRows k $ availableSubsets s,+ freeElements =+ differenceWithRow (freeElements s) k $ snd $ availableSubsets s,+ usedSubsets = fst (availableSubsets s) ! k : usedSubsets s+ }++++halfBags :: SetId -> SetId -> (SetId, SetId)+halfBags (SetId firstBag) (SetId lastBag) =+ (SetId $ div (lastBag-firstBag) 2,+ SetId $ div (lastBag-firstBag-1) 2)++double :: SetId -> SetId+double (SetId n) = SetId (2*n)++add2TransposedST ::+ UArray (SetId, BlockId, DigitId) Block ->+ ST s (STUArray s (SetId, BlockId, DigitId) Block)+add2TransposedST xs = do+ let ((firstBag,firstBlock,firstDigit), (lastBag,lastBlock,lastDigit)) =+ UArray.bounds xs+ let newFirstBag = SetId 0+ let (newLastBag, newLastFullBag) = halfBags firstBag lastBag++ let mostSigNull =+ all (\(n,j) -> xs!(n,j,lastDigit) == 0) $+ range ((firstBag,firstBlock), (lastBag,lastBlock))+ let newLastDigit = if mostSigNull then lastDigit else succ lastDigit++ ys <- STUArray.newArray_+ ((newFirstBag, firstBlock, firstDigit),+ (newLastBag, lastBlock, newLastDigit))+ forM_ (range (newFirstBag,newLastFullBag)) $ \n ->+ forM_ (range (firstBlock,lastBlock)) $ \j ->+ writeArray ys (n,j,newLastDigit) =<<+ foldM+ (\carry k -> do+ let a = xs ! (double n, j, k)+ let b = xs ! (succ $ double n, j, k)+ writeArray ys (n,j,k) $ xor carry (xor a b)+ return $ carry.&.(a.|.b) .|. a.&.b)+ 0 (range (firstDigit, pred newLastDigit))+ when (newLastFullBag<newLastBag) $ do+ let n = newLastBag+ forM_ (range (firstBlock,lastBlock)) $ \j -> do+ forM_ (range (firstDigit, pred newLastDigit)) $ \k ->+ writeArray ys (n,j,k) $ xs!(double n,j,k)+ writeArray ys (n,j,newLastDigit) 0+ return ys++add2ST ::+ UArray (SetId, DigitId, BlockId) Block ->+ ST s (STUArray s (SetId, DigitId, BlockId) Block)+add2ST xs = do+ let ((firstBag,firstDigit,firstBlock), (lastBag,lastDigit,lastBlock)) =+ UArray.bounds xs+ let newFirstBag = SetId 0+ let (newLastBag, newLastFullBag) = halfBags firstBag lastBag++ let mostSigNull =+ all (\(n,j) -> xs!(n,lastDigit,j) == 0) $+ range ((firstBag,firstBlock), (lastBag,lastBlock))+ let newLastDigit = if mostSigNull then lastDigit else succ lastDigit++ ys <- STUArray.newArray_+ ((newFirstBag, firstDigit, firstBlock),+ (newLastBag, newLastDigit, lastBlock))+ forM_ (range (newFirstBag,newLastFullBag)) $ \n ->+ forM_ (range (firstBlock,lastBlock)) $ \j ->+ writeArray ys (n,newLastDigit,j) =<<+ foldM+ (\carry k -> do+ let a = xs ! (double n, k, j)+ let b = xs ! (succ $ double n, k, j)+ writeArray ys (n,k,j) $ xor carry (xor a b)+ return $ carry.&.(a.|.b) .|. a.&.b)+ 0 (range (firstDigit, pred newLastDigit))+ when (newLastFullBag<newLastBag) $ do+ let n = newLastBag+ forM_ (range (firstBlock,lastBlock)) $ \j -> do+ forM_ (range (firstDigit,pred newLastDigit)) $ \k ->+ writeArray ys (n,k,j) $ xs!(double n,k,j)+ writeArray ys (n,newLastDigit,j) 0+ return ys++add2 ::+ UArray (SetId, DigitId, BlockId) Block ->+ UArray (SetId, DigitId, BlockId) Block+add2 xs = runSTUArray (add2ST xs)++sumBags :: UArray (SetId,BlockId) Block -> UArray (DigitId,BlockId) Block+sumBags arr =+ let go xs =+ if (UArray.rangeSize $ mapPair (fst3,fst3) $ bounds xs) > 1+ then go $ add2 xs+ else UArray.ixmap+ (case bounds xs of+ ((_,kl,jl), (_,ku,ju)) -> ((kl,jl), (ku,ju)))+ (\(k,j) -> (SetId 0, k, j)) xs+ in go $+ UArray.ixmap+ (case bounds arr of+ ((nl,jl), (nu,ju)) -> ((nl, DigitId 0, jl), (nu, DigitId 0, ju)))+ (\(n,_,j) -> (n,j)) arr++_sumBagsTransposed ::+ UArray (SetId,BlockId) Block -> UArray (DigitId,BlockId) Block+_sumBagsTransposed arr =+ let go xs =+ if (UArray.rangeSize $ mapPair (fst3,fst3) $ bounds xs) > 1+ then go $ runSTUArray (add2TransposedST xs)+ else UArray.ixmap+ (case bounds xs of+ ((_,jl,kl), (_,ju,ku)) -> ((kl,jl), (ku,ju)))+ (\(k,j) -> (SetId 0, j, k)) xs+ in go $+ UArray.ixmap+ (case bounds arr of+ ((nl,jl), (nu,ju)) -> ((nl, jl, DigitId 0), (nu, ju, DigitId 0)))+ (\(n,j,_) -> (n,j)) arr+++nullSet :: UArray BlockId Block -> Bool+nullSet = all (0==) . UArray.elems++minimumSet ::+ UArray BlockId Block ->+ UArray (DigitId, BlockId) Block -> UArray BlockId Block+minimumSet baseSet bag =+ foldr+ (\k mins ->+ case differenceWithRow mins k bag of+ newMins -> if nullSet newMins then mins else newMins)+ baseSet+ (range $ mapPair (fst,fst) $ bounds bag)++keepMinimum :: UArray BlockId Block -> (BlockId,Block)+keepMinimum =+ mapSnd Bit.keepMinimum . head . dropWhile ((0==) . snd) . UArray.assocs++affectedRows :: (Ix n) => UArray (n,BlockId) Block -> (BlockId,Block) -> [n]+affectedRows arr (j,bit) =+ filter (\n -> not $ disjoint bit $ arr!(n,j)) $+ range $ mapPair (fst,fst) $ bounds arr++minimize :: UArray BlockId Block -> UArray (SetId,BlockId) Block -> [SetId]+minimize free arr =+ affectedRows arr . keepMinimum . minimumSet free $ sumBags arr++step :: State label -> [State label]+step s =+ map (flip updateState s) $+ minimize (freeElements s) (snd $ availableSubsets s)++search :: State label -> [[label]]+search s =+ if nullSet (freeElements s)+ then [usedSubsets s]+ else search =<< step s++partitions :: (Ord a) => [ESC.Assign label (Set a)] -> [[label]]+partitions = search . initState
− src/Math/SetCover/IntSet.hs
@@ -1,42 +0,0 @@-module Math.SetCover.IntSet (Set, fromIntSet, findMin) where--import qualified Math.SetCover.Bit as Bit--import qualified Data.IntSet as IntSet-import Data.IntSet (IntSet)---data Set = Set {_complement :: Bool, _set :: IntSet}- deriving (Eq, Ord)--fromIntSet :: IntSet -> Set-fromIntSet = Set False--findMin :: Set -> Int-findMin (Set c s) =- if c- then head $ dropWhile (flip IntSet.member s) [0..]- else IntSet.findMin s--xor :: IntSet -> IntSet -> IntSet-xor x y = IntSet.difference (IntSet.union x y) (IntSet.intersection x y)--instance Bit.C Set where- empty = fromIntSet IntSet.empty- keepMinimum = fromIntSet . IntSet.singleton . findMin- complement (Set c s) = Set (not c) s- xor (Set c0 s0) (Set c1 s1) = Set (c0/=c1) (xor s0 s1)- Set c0 s0 .&. Set c1 s1 =- Set (c0&&c1) $- case (c0,c1) of- (False, False) -> IntSet.intersection s0 s1- (False, True) -> IntSet.difference s0 s1- (True, False) -> IntSet.difference s1 s0- (True, True) -> IntSet.union s0 s1- Set c0 s0 .|. Set c1 s1 =- Set (c0||c1) $- case (c0,c1) of- (False, False) -> IntSet.union s0 s1- (False, True) -> IntSet.difference s1 s0- (True, False) -> IntSet.difference s0 s1- (True, True) -> IntSet.intersection s0 s1
src/Math/SetCover/Queue.hs view
@@ -1,4 +1,4 @@-module Math.SetCover.Queue (SetId(..), Methods(..)) where+module Math.SetCover.Queue (SetId(..), Methods(..), findMin) where import Data.EnumMap (EnumMap) import Data.EnumSet (EnumSet)@@ -16,6 +16,9 @@ fromEnumMap :: EnumMap SetId set -> queue, partition :: queue -> set -> (EnumSet SetId, queue), difference :: queue -> EnumMap SetId set -> queue,- findMin :: queue -> Maybe (EnumSet SetId),+ findMinValue :: queue -> Maybe (set, EnumSet SetId), null :: queue -> Bool }++findMin :: Methods queue set -> queue -> Maybe (EnumSet SetId)+findMin dict = fmap snd . findMinValue dict
src/Math/SetCover/Queue/Bit.hs view
@@ -2,7 +2,10 @@ Alternative to "Math.SetCover.Queue.Set" that represents sets by bit masks and uses the faster Int priority queue. -}-module Math.SetCover.Queue.Bit (Methods, methods) where+module Math.SetCover.Queue.Bit (+ Methods, methods,+ MethodsIntSet, methodsIntSet,+ ) where import qualified Math.SetCover.Queue as Queue import Math.SetCover.Queue (SetId)@@ -14,8 +17,10 @@ import qualified Data.IntPSQ as PSQ import qualified Data.EnumSet as EnumSet; import Data.EnumSet (EnumSet) import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet import qualified Data.List as List-import Data.Tuple.HT (swap, mapFst, thd3)+import Data.IntSet (IntSet)+import Data.Tuple.HT (swap, mapFst) type@@ -33,7 +38,27 @@ Queue.difference = \q -> foldl (flip deleteSetFromPSQ) q . IntMap.toList . EnumMapX.transposeBitSet,- Queue.findMin = fmap thd3 . PSQ.findMin,+ Queue.findMinValue =+ fmap (\(elm, _, ns) -> (BitPos.singleton elm, ns)) . PSQ.findMin,+ Queue.null = PSQ.null+ }+++type MethodsIntSet = Queue.Methods (PSQ.IntPSQ Int (EnumSet SetId)) IntSet++methodsIntSet :: MethodsIntSet+methodsIntSet =+ Queue.Methods {+ Queue.fromEnumMap =+ PSQ.fromList . map (\(elm, ns) -> (elm, EnumSet.size ns, ns)) .+ IntMap.toList . EnumMapX.transposeIntSet,+ Queue.partition =+ \q -> mapFst EnumSet.unions . partitionPSQ q . IntSet.toList,+ Queue.difference = \q ->+ foldl (flip deleteSetFromPSQ) q .+ IntMap.toList . EnumMapX.transposeIntSet,+ Queue.findMinValue =+ fmap (\(elm, _, ns) -> (IntSet.singleton elm, ns)) . PSQ.findMin, Queue.null = PSQ.null }
src/Math/SetCover/Queue/BitPriorityQueue.hs view
@@ -22,6 +22,6 @@ Queue.fromEnumMap = BitPQ.fromSets, Queue.partition = (mapFst BitPQ.elemUnions.) . BitPQ.partition, Queue.difference = \q -> BitPQ.difference q . BitPQ.fromSets,- Queue.findMin = BitPQ.findMin,+ Queue.findMinValue = BitPQ.findMinValue, Queue.null = BitPQ.null }
src/Math/SetCover/Queue/Map.hs view
@@ -6,11 +6,10 @@ import qualified Data.OrdPSQ as PSQ import qualified Data.EnumSet as EnumSet import qualified Data.Map as Map; import Data.Map (Map)-import Control.Monad.HT ((<=<)) import Control.Applicative ((<$>)) import Data.Monoid (Monoid, mempty, mappend)-import Data.Maybe (mapMaybe)-import Data.Tuple.HT (mapFst, mapSnd, thd3)+import Data.Maybe (mapMaybe, fromMaybe)+import Data.Tuple.HT (mapFst, mapSnd) type Methods a queue set = Queue.Methods (PSQ.OrdPSQ a Int queue) (Map a set)@@ -30,9 +29,17 @@ Queue.difference = \q s -> apply ((addMinSize m .) . Queue.difference m) q (EnumMapX.transposeMap s),- Queue.findMin = Queue.findMin m . thd3 <=< PSQ.findMin,+ Queue.findMinValue = \qo -> do+ (elm,_,qi) <- PSQ.findMin qo+ let (minSet,ns) =+ checkSubQueue "findMinValue" $ Queue.findMinValue m qi+ return (Map.singleton elm minSet, ns), Queue.null = PSQ.null }++checkSubQueue :: String -> Maybe queue -> queue+checkSubQueue name =+ fromMaybe (error ("Queue.Map." ++ name ++ ": empty sub-queue")) addMinSize :: Queue.Methods queue set -> queue -> Maybe (Int, queue) addMinSize m q = flip (,) q . EnumSet.size <$> Queue.findMin m q
src/Math/SetCover/Queue/Set.hs view
@@ -13,7 +13,8 @@ import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.List as List-import Data.Tuple.HT (swap, mapFst, thd3)+import Data.EnumMap (EnumMap)+import Data.Tuple.HT (swap, mapFst) type Methods a = Queue.Methods (PSQ.OrdPSQ a Int (EnumSet SetId)) (Set.Set a)@@ -26,9 +27,9 @@ Map.toList . EnumMapX.transposeSet, Queue.partition = \q -> mapFst EnumSet.unions . partitionPSQ q . Set.toList,- Queue.difference = \q ->- foldl (flip deleteSetFromPSQ) q . Map.toList . EnumMapX.transposeSet,- Queue.findMin = fmap thd3 . PSQ.findMin,+ Queue.difference = differencePSQ,+ Queue.findMinValue =+ fmap (\(elm, _, ns) -> (Set.singleton elm, ns)) . PSQ.findMin, Queue.null = PSQ.null } @@ -45,6 +46,16 @@ (error "partitionPSQ: key not contained in queue's key set") (\(_p,v,q1) -> (q1, v)) $ PSQ.deleteView k q0)++differencePSQ, _differencePSQ ::+ (Ord k, Enum e) =>+ PSQ.OrdPSQ k Int (EnumSet e) ->+ EnumMap e (Set.Set k) -> PSQ.OrdPSQ k Int (EnumSet e)+differencePSQ q =+ foldl (flip deleteSetFromPSQ) q . Map.toList . EnumMapX.transposeSet++_differencePSQ q =+ Map.foldlWithKey (curry . flip deleteSetFromPSQ) q . EnumMapX.transposeSet deleteSetFromPSQ :: (Ord k) =>
+ test/Test.hs view
@@ -0,0 +1,314 @@+module Main where++import qualified Mastermind.Test as Mastermind+import qualified Test.Knead as TestKnead+import Test.Utility+ (normalizeSolution, equivalentSolutions,+ setAssigns, genWord, genWords,+ InflatedString, genInflatedWords, forAllShrinkSmall)++import qualified Math.SetCover.Exact.UArray as ESC_UArray+import qualified Math.SetCover.Exact.Priority as ESCP+import qualified Math.SetCover.Exact as ESC+import qualified Math.SetCover.Queue as Queue++import Control.Monad (liftM2)+import Control.Applicative ((<$>))++import qualified Data.Map as Map; import Data.Map(Map)+import qualified Data.Set as Set; import Data.Set(Set)++import qualified Data.Foldable as Fold+import qualified Data.List as List+import qualified Data.Monoid.HT as Mn+import Data.Ord.HT (comparing)+import Data.Eq.HT (equating)+import Data.Tuple.HT (mapFst, mapSnd)++import qualified Test.QuickCheck as QC+++distinct :: (QC.Arbitrary a, Eq a) => QC.Gen [a]+distinct = List.nub <$> QC.arbitrary++singletonAssigns :: [a] -> [ESC.Assign a (Set a)]+singletonAssigns = map (\x -> ESC.assign x (Set.singleton x))++partitionDistinct :: [Char] -> Bool+partitionDistinct xs =+ case ESC.partitions $ singletonAssigns xs of+ [ys] -> equating List.sort xs ys+ _ -> False++partitionMultiplicity :: [Char] -> Bool+partitionMultiplicity xs =+ (Fold.product $ Map.fromListWith (+) $ map (flip (,) 1) xs)+ ==+ (length $ ESC.partitions $ singletonAssigns xs)+++sortInt :: [(Int, a)] -> [(Int, a)]+sortInt = List.sortBy (comparing fst)++genShuffled :: QC.Gen ([String], [String])+genShuffled = do+ kxs <- take 10 <$> QC.listOf (liftM2 (,) QC.arbitrary genWord)+ return (snd <$> kxs, snd <$> sortInt kxs)++partitionShuffled :: [String] -> [String] -> Bool+partitionShuffled xs ys =+ equivalentSolutions+ (ESC.partitions $ setAssigns xs)+ (ESC.partitions $ setAssigns ys)+++genExtraSet :: QC.Gen (String, [String])+genExtraSet = do+ xs <- genWords+ let es = Fold.foldMap Set.fromList xs+ x <-+ if Set.null es+ then return ""+ else take 5 <$> (QC.listOf $ QC.elements $ Set.toList es)+ return (x,xs)+++{- |+This function compares two multi-sets represented by sorted lists.++@+List.sort xs `orderedSublist` List.sort ys+==>+Set.fromList xs `Set.isSubsetOf` Set.fromList ys+@++The converse is not true, because e.g. @xs == "aa", ys == "a"@.+-}+orderedSublist :: (Ord a) => [a] -> [a] -> Bool+orderedSublist xs0 ys0 =+ foldr+ (\y go xt ->+ case xt of+ [] -> True+ x:xs ->+ case compare x y of+ LT -> False+ GT -> go xt+ EQ -> go xs)+ null ys0 xs0++partitionAddSet :: String -> [String] -> Bool+partitionAddSet x xs =+ (normalizeSolution $ ESC.partitions $ setAssigns xs)+ `orderedSublist`+ (normalizeSolution $ ESC.partitions $ setAssigns $ x : xs)+++removeOverlap :: (Ord a) => [Set a] -> [Set a]+removeOverlap xs =+ filter (not . Set.null) $ snd $+ List.mapAccumL+ (\uni y -> (Set.difference uni y, Set.intersection y uni))+ (Set.unions xs) xs++removeOverlapList :: (Ord a) => [[a]] -> [[a]]+removeOverlapList = map Set.toList . removeOverlap . map Set.fromList++genPartition :: QC.Gen ([String], [String])+genPartition = do+ xs <- genWords+ return (removeOverlapList xs, xs)++partitionAddPartition :: [String] -> [String] -> Bool+partitionAddPartition ys xs =+ let nys =+ zipWith (\n y -> ESC.assign (Left n) (Set.fromList y)) [(0::Int) ..] ys+ in elem+ (map ESC.label nys)+ (map List.sort $ ESC.partitions $+ nys ++ map (\x -> ESC.assign (Right x) (Set.fromList x)) xs)+++partitionIntegerBitSet :: [InflatedString] -> Bool+partitionIntegerBitSet xs =+ let asns = setAssigns xs+ in equivalentSolutions+ (ESC.partitions asns)+ (ESC.partitions $ ESC.bitVectorFromSetAssigns asns)++partitionIntSet :: [InflatedString] -> Bool+partitionIntSet xs =+ let asns = setAssigns xs+ in equivalentSolutions+ (ESC.partitions asns)+ (ESC.partitions $ ESC.intSetFromSetAssigns asns)++partitionUArray :: [InflatedString] -> Bool+partitionUArray xs =+ let asns = setAssigns xs+ in equivalentSolutions+ (ESC.partitions asns)+ (ESC_UArray.partitions asns)+++genPairs :: QC.Gen [[(Char,Char)]]+genPairs =+ fmap (take 10) $ QC.listOf $+ fmap (take 10) $ QC.listOf $+ liftM2 (,) (QC.choose ('A','C')) (QC.choose ('a','c'))++-- | occasionally add non-overlapping sets such that there are solutions+genSolvablePairs :: QC.Gen [[(Char,Char)]]+genSolvablePairs = do+ pairs <- genPairs+ b0 <- QC.arbitrary+ b1 <- QC.arbitrary+ return $+ pairs+ ++ Mn.when b0 (removeOverlapList pairs)+ ++ Mn.when b1 (removeOverlapList $ reverse pairs)++uncurryMap :: (Ord a, Ord b) => [(a, b)] -> Map a (Set b)+uncurryMap = Map.fromListWith Set.union . map (mapSnd Set.singleton)++partitionMap :: [[(Char,Char)]] -> Bool+partitionMap xs =+ equivalentSolutions+ (ESC.partitions $ setAssigns xs)+ (ESC.partitions $ map (\m -> ESC.assign m $ uncurryMap m) xs)+++partitionQueueGen ::+ (Ord label, ESC.Set set) =>+ Queue.Methods queue set -> ([a] -> [ESC.Assign label set]) -> [a] -> Bool+partitionQueueGen methods makeAssigns xs =+ let asns = makeAssigns xs+ in equivalentSolutions+ (ESC.partitions asns)+ (ESCP.partitions methods asns)++partitionQueueSet :: [String] -> Bool+partitionQueueSet = partitionQueueGen ESCP.queueSet setAssigns++mapAssigns ::+ [[(Char, Char)]] -> [ESC.Assign [(Char, Char)] (Map Char (Set Char))]+mapAssigns = map (\m -> ESC.assign m $ uncurryMap m)++partitionQueueMap :: [[(Char,Char)]] -> Bool+partitionQueueMap =+ partitionQueueGen (ESCP.queueMap ESCP.queueSet) mapAssigns++partitionQueueBit :: [String] -> Bool+partitionQueueBit =+ partitionQueueGen ESCP.queueBit (ESC.bitVectorFromSetAssigns . setAssigns)++partitionQueueBitPQ :: [String] -> Bool+partitionQueueBitPQ =+ partitionQueueGen ESCP.queueBitPQ (ESC.bitVectorFromSetAssigns . setAssigns)++partitionQueueIntSet :: [String] -> Bool+partitionQueueIntSet =+ partitionQueueGen ESCP.queueIntSet (ESC.intSetFromSetAssigns . setAssigns)+++flattenTreeForward :: ESC.Tree label set -> [[label]]+flattenTreeForward =+ let go ESC.Leaf = [[]]+ go (ESC.Branch _ xs) =+ concatMap (\(label, subTree) -> (label:) <$> go subTree) xs+ in go++flattenTree :: ESC.Tree label set -> [[label]]+flattenTree =+ let go labels tree =+ case tree of+ ESC.Leaf -> [labels]+ ESC.Branch _ xs -> concatMap (uncurry $ go . (:labels)) xs+ in go []++partitionTree :: [String] -> Bool+partitionTree xs =+ let asns = setAssigns xs+ in equivalentSolutions+ (ESC.partitions asns)+ (flattenTree $ ESC.decisionTree asns)+++treeQueueGen ::+ (Ord label, ESC.Choose set, Eq set) =>+ Queue.Methods queue set -> ([a] -> [ESC.Assign label set]) -> [a] -> Bool+treeQueueGen methods makeAssigns xs =+ let asns = makeAssigns xs+ in ESC.decisionTree asns == ESCP.decisionTree methods asns+++forAll ::+ (QC.Testable prop, Show a) =>+ QC.Gen a -> (a -> prop) -> (Int, QC.Property)+forAll gen = (,) 1000 . QC.forAll gen++forAllShrink ::+ (QC.Testable prop, Show a, QC.Arbitrary a) =>+ QC.Gen a -> (a -> prop) -> (Int, QC.Property)+forAllShrink gen = (,) 1000 . QC.forAllShrink gen QC.shrink++tests :: [(String, (Int, QC.Property))]+tests =+ map (mapFst ("Exact."++)) $+ ("partitionDistinct",+ forAll (take 10 <$> distinct) partitionDistinct) :+ ("partitionMultiplicity",+ forAllShrink (take 10 <$> QC.arbitrary) partitionMultiplicity) :+ ("partitionShuffled",+ forAll genShuffled $ uncurry partitionShuffled) :+ ("partitionAddSet",+ forAll genExtraSet $ uncurry partitionAddSet) :+ ("partitionAddPartition",+ forAll genPartition $ uncurry partitionAddPartition) :+ ("partitionIntegerBitSet",+ forAllShrinkSmall genInflatedWords partitionIntegerBitSet) :+ ("partitionIntSet",+ forAllShrinkSmall genInflatedWords partitionIntSet) :+ ("partitionUArray",+ forAllShrinkSmall genInflatedWords partitionUArray) :+ TestKnead.tests +++ ("partitionMap",+ forAll genSolvablePairs partitionMap) :+ ("partitionQueueSet",+ forAllShrink genWords partitionQueueSet) :+ ("partitionQueueMap",+ forAll genSolvablePairs partitionQueueMap) :+ ("partitionQueueBit",+ forAllShrink genWords partitionQueueBit) :+ ("partitionQueueBitPQ",+ forAllShrink genWords partitionQueueBitPQ) :+ ("partitionQueueIntSet",+ forAllShrink genWords partitionQueueIntSet) :+ ("partitionTree",+ forAllShrink genWords partitionTree) :+ ("treeQueueSet",+ forAllShrink genWords $ treeQueueGen ESCP.queueSet setAssigns) :+ ("treeQueueMap",+ forAll genSolvablePairs $+ treeQueueGen (ESCP.queueMap ESCP.queueSet) mapAssigns) :+ ("treeQueueBit",+ forAllShrink genWords $+ treeQueueGen ESCP.queueBit (ESC.bitVectorFromSetAssigns . setAssigns)) :+ ("treeQueueBitPQ",+ forAllShrink genWords $+ treeQueueGen ESCP.queueBitPQ (ESC.bitVectorFromSetAssigns . setAssigns)) :+ ("treeQueueIntSet",+ forAllShrink genWords $+ treeQueueGen ESCP.queueIntSet (ESC.intSetFromSetAssigns . setAssigns)) :+ []+++quickCheck :: (Int, QC.Property) -> IO ()+quickCheck (count, prop) =+ QC.quickCheckWith (QC.stdArgs {QC.maxSuccess = count}) prop++main :: IO ()+main =+ mapM_ (\(msg,prop) -> putStr (msg++": ") >> quickCheck prop) $++ tests ++ map (mapFst ("Mastermind."++)) Mastermind.tests
+ test/Test/Utility.hs view
@@ -0,0 +1,47 @@+module Test.Utility where++import qualified Math.SetCover.Exact as ESC++import Control.Applicative ((<$>))++import qualified Data.Set as Set+import qualified Data.List as List+import Data.Set(Set)+import Data.Eq.HT (equating)++import qualified Test.QuickCheck as QC+++setAssigns :: (Ord a) => [[a]] -> [ESC.Assign [a] (Set a)]+setAssigns = map (\x -> ESC.assign x (Set.fromList x))++normalizeSolution :: Ord a => [[a]] -> [[a]]+normalizeSolution = List.sort . map List.sort++equivalentSolutions :: Ord a => [[a]] -> [[a]] -> Bool+equivalentSolutions = equating normalizeSolution+++genWord :: QC.Gen String+genWord = take 5 <$> QC.listOf (QC.choose ('a','e'))++genWords :: QC.Gen [String]+genWords = take 10 <$> QC.listOf genWord++type InflatedString = [(Char,Int)]++inflate :: String -> InflatedString+inflate = concatMap (\c -> map ((,) c) [0..49])++{- |+Make sure that bitset-based implementations+are forced to use more than one Word64 or one 128 bit vector.+-}+genInflatedWords :: QC.Gen [InflatedString]+genInflatedWords = fmap inflate <$> genWords+++forAllShrinkSmall ::+ (QC.Testable prop, Show a, QC.Arbitrary a) =>+ QC.Gen a -> (a -> prop) -> (Int, QC.Property)+forAllShrinkSmall gen = (,) 200 . QC.forAllShrink gen QC.shrink
+ test/knead/Test/Knead.hs view
@@ -0,0 +1,35 @@+module Test.Knead where++import Test.Utility+ (InflatedString, setAssigns, equivalentSolutions,+ forAllShrinkSmall, genInflatedWords)++import qualified Math.SetCover.Exact.Knead.Saturated as ESC_KneadSat+import qualified Math.SetCover.Exact.Knead as ESC_Knead+import qualified Math.SetCover.Exact as ESC++import qualified Test.QuickCheck as QC+++partitionKnead :: [InflatedString] -> Bool+partitionKnead xs =+ let asns = setAssigns xs+ in ESC.partitions asns+ ==+ ESC_Knead.partitions asns++partitionKneadVector :: [InflatedString] -> Bool+partitionKneadVector xs =+ let asns = setAssigns xs+ in equivalentSolutions+ (ESC.partitions asns)+ (ESC_KneadSat.partitions asns)+++tests :: [(String, (Int, QC.Property))]+tests =+ ("partitionKnead",+ forAllShrinkSmall genInflatedWords partitionKnead) :+ ("partitionKneadVector",+ forAllShrinkSmall genInflatedWords partitionKneadVector) :+ []
+ test/plain/Test/Knead.hs view
@@ -0,0 +1,4 @@+module Test.Knead where++tests :: [a]+tests = []