diff --git a/example/Alphametics.hs b/example/Alphametics.hs new file mode 100644 --- /dev/null +++ b/example/Alphametics.hs @@ -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 diff --git a/example/Domino.hs b/example/Domino.hs new file mode 100644 --- /dev/null +++ b/example/Domino.hs @@ -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 diff --git a/set-cover.cabal b/set-cover.cabal --- a/set-cover.cabal +++ b/set-cover.cabal @@ -1,5 +1,5 @@ Name: set-cover -Version: 0.0.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 diff --git a/src/Math/SetCover/Cuboid.hs b/src/Math/SetCover/Cuboid.hs --- a/src/Math/SetCover/Cuboid.hs +++ b/src/Math/SetCover/Cuboid.hs @@ -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 =