set-cover 0.0.3 → 0.0.4
raw patch · 4 files changed
+436/−8 lines, 4 filesdep +transformersdep ~basedep ~containersdep ~utility-htnew-component:exe:alphameticsnew-component:exe:domino
Dependencies added: transformers
Dependency ranges changed: base, containers, utility-ht
Files
- example/Alphametics.hs +200/−0
- example/Domino.hs +201/−0
- set-cover.cabal +29/−2
- src/Math/SetCover/Cuboid.hs +6/−6
+ example/Alphametics.hs view
@@ -0,0 +1,200 @@+{- |+Solve the following verbal arithmetics puzzle:++> SEND+> +MORE+> -----+> MONEY+-}+module Main where++import qualified Math.SetCover.Exact as ESC++import qualified Control.Monad.Trans.State as MS+import Control.Monad (liftM2, guard)++import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.List.HT as ListHT+import Data.Maybe (catMaybes)+import Data.Map (Map)+import Data.Set (Set)+++data+ X =+ Variable Char | Digit Int |+ Column Int | Position Int Char Int | Carry Int Bool+ deriving (Eq, Ord, Show)++type Assign = ESC.Assign (Maybe (Char, Int)) (Set X)+++assign :: (Ord b) => a -> [b] -> ESC.Assign a (Set b)+assign x ys = ESC.assign x $ Set.fromList ys++noAssign :: (Ord b) => [b] -> ESC.Assign (Maybe a) (Set b)+noAssign = assign Nothing++revIndex :: String -> Map Char Int+revIndex = Map.fromList . flip zip [0..] . reverse++histogram :: [String] -> Map Char [Int]+histogram =+ Map.unionsWith (++) . map (fmap (:[]) . revIndex)++variableAssigns :: [String] -> [Assign]+variableAssigns rows = do+ let leadingVars = Set.fromList $ map head rows+ (var, poss) <- Map.toList $ histogram rows+ (digit, otherDigits) <-+ (if Set.member var leadingVars+ then tail+ else id) $+ ListHT.removeEach [0..9]+ return $ assign (Just (var, digit)) $+ [Variable var, Digit digit] +++ liftM2+ (\pos otherDigit -> Position pos var otherDigit)+ poss otherDigits++unassignedDigits :: [Assign]+unassignedDigits = map (ESC.assign Nothing . Set.singleton . Digit) [0..9]++add :: Int -> Char -> Char -> Char -> [Assign]+add pos xChar yChar zChar = do+ x <- [0..9]+ y <- [0..9]+ let (carryOut,z) = divMod (x+y) 10+ return $ noAssign+ [Column pos,+ Position pos xChar x, Position pos yChar y, Position pos zChar z,+ Carry (pos+1) (0/=carryOut)]++addCarry :: Int -> Char -> Char -> Char -> [Assign]+addCarry pos xChar yChar zChar = do+ x <- [0..9]+ y <- [0..9]+ carryIn <- [0..1]+ let (carryOut,z) = divMod (x+y+carryIn) 10+ return $ noAssign+ [Column pos,+ Position pos xChar x, Position pos yChar y, Position pos zChar z,+ Carry pos (0==carryIn), Carry (pos+1) (0/=carryOut)]++endCarry :: Int -> Char -> [Assign]+endCarry pos zChar = do+ carryIn <- [0,1]+ return $ noAssign+ [Column pos, Position pos zChar carryIn, Carry pos (0==carryIn)]++endCarry1 :: Int -> Char -> Char -> [Assign]+endCarry1 pos yChar zChar = do+ y <- [0..9]+ carryIn <- [0,1]+ let (carryOut,z) = divMod (y+carryIn) 10+ guard $ carryOut == 0+ return $ noAssign+ [Column pos,+ Position pos yChar y, Position pos zChar z,+ Carry pos (0==carryIn)]++-- one solution+assignsMoney :: [Assign]+assignsMoney =+ endCarry 4 'm' +++ addCarry 3 's' 'm' 'o' +++ addCarry 2 'e' 'o' 'n' +++ addCarry 1 'n' 'r' 'e' +++ add 0 'd' 'e' 'y' +++ variableAssigns ["send", "more", "money"] +++ unassignedDigits++-- 7 solutions+assigns224 :: [Assign]+assigns224 =+ endCarry 3 'f' +++ addCarry 2 't' 't' 'o' +++ addCarry 1 'w' 'w' 'u' +++ add 0 'o' 'o' 'r' +++ variableAssigns ["two", "two", "four"] +++ unassignedDigits++-- 1200 solutions+assigns145 :: [Assign]+assigns145 =+ endCarry1 3 'f' 'f' +++ addCarry 2 'o' 'o' 'i' +++ addCarry 1 'n' 'u' 'v' +++ add 0 'e' 'r' 'e' +++ variableAssigns ["one", "four", "five"] +++ unassignedDigits++-- no solutions+assigns358 :: [Assign]+assigns358 =+ endCarry1 4 't' 'e' +++ addCarry 3 'f' 'h' 'i' +++ addCarry 2 'i' 'r' 'g' +++ addCarry 1 'v' 'e' 'h' +++ add 0 'e' 'e' 't' +++ variableAssigns ["five", "three", "eight"] +++ unassignedDigits++-- no solutions+assigns459 :: [Assign]+assigns459 =+ addCarry 3 'f' 'f' 'n' +++ addCarry 2 'o' 'i' 'i' +++ addCarry 1 'u' 'v' 'n' +++ add 0 'r' 'e' 'e' +++ variableAssigns ["four", "five", "nine"] +++ unassignedDigits++-- 32 solutions+assigns448 :: [Assign]+assigns448 =+ endCarry 4 'e' +++ addCarry 3 'f' 'f' 'i' +++ addCarry 2 'o' 'o' 'g' +++ addCarry 1 'u' 'u' 'h' +++ add 0 'r' 'r' 't' +++ variableAssigns ["four", "four", "eight"] +++ unassignedDigits++mainSetCover :: IO ()+mainSetCover =+ mapM_ (print . catMaybes) $ ESC.partitions assignsMoney++++choose :: MS.StateT [a] [] a+choose = MS.StateT ListHT.removeEach++infixl 9 .:++(.:) :: Num a => a -> a -> a+x.:y = 10*x+y++bruteForceMoney :: [[(Char, Int)]]+bruteForceMoney = flip MS.evalStateT [0..9] $ do+ s <- choose; guard (s/=0)+ m <- choose; guard (m/=0)+ e <- choose+ n <- choose+ d <- choose+ o <- choose+ r <- choose+ y <- choose+ guard $ s.:e.:n.:d + m.:o.:r.:e == m.:o.:n.:e.:y+ return $+ ('s', s) : ('e', e) : ('n', n) : ('d', d) :+ ('m', m) : ('o', o) : ('r', r) : ('y', y) :+ []++mainBruteForce :: IO ()+mainBruteForce = mapM_ print bruteForceMoney+++main :: IO ()+main = mainSetCover
+ example/Domino.hs view
@@ -0,0 +1,201 @@+{-+Juergen Goering+Labyrinth der Denkspiele, Seite 127++Zerlege folgende Felder in Dominosteine:++3134205+3110266+3550426+6321201+5045254+3660301+5451243+6264410+++25114225+25304365+11305361+24465661+23560204+63540204+60043311+-}+module Main where++import qualified Math.SetCover.Exact as ESC++import qualified Data.List.HT as ListHT+import qualified Data.Set as Set+import Data.Set (Set)+import Data.Monoid (Monoid, mempty, mappend, mconcat)+++data+ Score = S0 | S1 | S2 | S3 | S4 | S5 | S6+ deriving (Eq, Ord, Show, Enum, Bounded)++data+ X = Brick Score Score | Position Int Int+ deriving (Eq, Ord, Show)++type Position = (Int, Int)++data Corner = Corner (Bool, Bool) (Bool, Bool) deriving (Eq)++data+ Borders = Borders {+ vertical, horizontal :: Set Position+ }++type Assign = ESC.Assign Borders (Set X)++instance Monoid Borders where+ mempty = Borders mempty mempty+ mappend x y =+ Borders {+ vertical = Set.union (vertical x) (vertical y),+ horizontal = Set.union (horizontal x) (horizontal y)+ }+++above, left :: Position -> Position+above (row,col) = (row-1, col)+left (row,col) = (row, col-1)++below, right :: Position -> Position+below (row,col) = (row+1, col)+right (row,col) = (row, col+1)+++brick :: Score -> Score -> X+brick x y = Brick (min x y) (max x y)++assign :: (Ord a) => map -> [a] -> ESC.Assign map (Set a)+assign m xs = ESC.assign m (Set.fromList xs)++attachPositions :: [[a]] -> [[(Position, a)]]+attachPositions = zipWith (\x -> zipWith (\y -> (,) (x,y)) [0..]) [0..]++assigns :: [[Score]] -> [Assign]+assigns xs =+ let ps = attachPositions xs+ in concat+ (ListHT.mapAdjacent+ (zipWith+ (\(p0,b0) (p1,b1) ->+ assign+ (Borders {+ vertical =+ Set.fromList $+ p0 : p1 : right p0 : right p1 : [],+ horizontal = Set.fromList $ p0 : below p1 : []+ })+ [brick b0 b1, uncurry Position p0, uncurry Position p1]))+ ps)+ +++ concatMap+ (ListHT.mapAdjacent+ (\(p0,b0) (p1,b1) ->+ assign+ (Borders {+ horizontal =+ Set.fromList $+ p0 : p1 : below p0 : below p1 : [],+ vertical = Set.fromList $ p0 : right p1 : []+ })+ [brick b0 b1, uncurry Position p0, uncurry Position p1]))+ ps++formatBar :: Corner -> Char+formatBar set =+ case set of+ Corner (False, False) (False, False) -> ' '+ Corner (False, False) (True, True ) -> '\x2500'+ Corner (True, True ) (False, False) -> '\x2502'+ Corner (True, True ) (True, True ) -> '\x253C'++ Corner (False, False) (False, True ) -> '\x2574'+ Corner (False, False) (True , False) -> '\x2576'+ Corner (False, True ) (False, False) -> '\x2577'+ Corner (True, False) (False, False) -> '\x2575'++ Corner (False, True ) (False, True ) -> '\x250C'+ Corner (False, True ) (True, False) -> '\x2510'+ Corner (True, False) (False, True ) -> '\x2514'+ Corner (True, False) (True, False) -> '\x2518'++ Corner (True, True ) (False, True ) -> '\x251C'+ Corner (True, True ) (True, False) -> '\x2524'+ Corner (False, True ) (True, True ) -> '\x252C'+ Corner (True, False) (True, True ) -> '\x2534'+++double :: a -> (a,a)+double a = (a,a)++formatCorner, formatHorizontal, formatVertical :: Borders -> Position -> Char+formatCorner m p =+ formatBar $+ Corner+ (Set.member (above p) (vertical m), Set.member p (vertical m))+ (Set.member (left p) (horizontal m), Set.member p (horizontal m))+formatHorizontal m p =+ formatBar (Corner (False,False) (double $ Set.member p (horizontal m)))+formatVertical m p =+ formatBar (Corner (double $ Set.member p (vertical m)) (False,False))++{- |+@mapIntersperse f g [a,b,c]@+computes+@[f 0, g 0 a, f 1, g 1 b, f 2, g 2 c, f 3]@+-}+mapIntersperse :: (Int -> b) -> (Int -> a -> b) -> [a] -> [b]+mapIntersperse f g xs =+ f 0 : concat (zipWith (\n x -> [g n x, f (n+1)]) [0..] xs)++format :: [[Score]] -> Borders -> String+format xss m =+ unlines $+ mapIntersperse+ (\row ->+ mapIntersperse+ (\col -> formatCorner m (row,col))+ (\col _ -> formatHorizontal m (row,col))+ (case xss of xs:_ -> xs; [] -> []))+ (\row ->+ mapIntersperse+ (\col -> formatVertical m (row,col))+ (\ _col n -> toEnum $ fromEnum '0' + fromEnum n))+ xss+++fieldSimple :: [[Score]]+fieldSimple = map (map toEnum) $+ (3:1:3:4:2:0:5:[]) :+ (3:1:1:0:2:6:6:[]) :+ (3:5:5:0:4:2:6:[]) :+ (6:3:2:1:2:0:1:[]) :+ (5:0:4:5:2:5:4:[]) :+ (3:6:6:0:3:0:1:[]) :+ (5:4:5:1:2:4:3:[]) :+ (6:2:6:4:4:1:0:[]) :+ []++fieldRussian :: [[Score]]+fieldRussian = map (map toEnum) $+ (2:5:1:1:4:2:2:5:[]) :+ (2:5:3:0:4:3:6:5:[]) :+ (1:1:3:0:5:3:6:1:[]) :+ (2:4:4:6:5:6:6:1:[]) :+ (2:3:5:6:0:2:0:4:[]) :+ (6:3:5:4:0:2:0:4:[]) :+ (6:0:0:4:3:3:1:1:[]) :+ []++main :: IO ()+main =+ let field = fieldRussian+ in mapM_ (putStrLn . format field . mconcat) $+ ESC.partitions $ assigns field
set-cover.cabal view
@@ -1,5 +1,5 @@ Name: set-cover-Version: 0.0.3+Version: 0.0.4 License: BSD3 License-File: LICENSE Author: Henning Thielemann, Helmut Podhaisky@@ -28,7 +28,7 @@ default: False Source-Repository this- Tag: 0.0.3+ Tag: 0.0.4 Type: darcs Location: http://code.haskell.org/~thielema/set-cover/ @@ -139,3 +139,30 @@ Other-Modules: Parallelism Utility++Executable alphametics+ If flag(buildExamples)+ Build-Depends:+ set-cover,+ transformers,+ containers,+ utility-ht,+ base+ Else+ Buildable: False+ GHC-Options: -Wall -rtsopts -threaded+ Hs-Source-Dirs: example+ Main-Is: Alphametics.hs++Executable domino+ If flag(buildExamples)+ Build-Depends:+ set-cover,+ containers,+ utility-ht,+ base+ Else+ Buildable: False+ GHC-Options: -Wall -rtsopts -threaded+ Hs-Source-Dirs: example+ Main-Is: Domino.hs
src/Math/SetCover/Cuboid.hs view
@@ -110,14 +110,14 @@ size :: [Coords Int] -> Coords Int size = fmap succ . foldl1 (liftA2 max) +move :: Coords Int -> [Coords Int] -> [Coords Int]+move displacement = map (liftA2 (+) displacement)+ allPositions :: Size -> [Coords Int] -> [[Coords Int]] allPositions sz ts =- map (\displacement -> map (liftA2 (+) displacement) ts) $- Trav.sequence $- liftA2- (\k r -> [0 .. k-1-r])- sz- (foldl1 (liftA2 max) ts)+ map (flip move ts) $+ Trav.traverse (enumFromTo 0) $+ liftA2 (-) sz (size ts) allOrientations :: (Num a, Ord a) => [Coords a] -> [[Coords a]] allOrientations ts =