```1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 ``` ```{- Solve cryto arithmetic puzzles, e.g. SEND + MORE ------- = MONEY - find an assignment of distinct digits 0..9 to letters such that the above addition holds - use the list monad for backtracking search Pedro Vasconcelos , 2015 -} import Control.Monad import Control.Monad.State import Data.List ((\\)) import Data.Map (Map) import qualified Data.Map as Map ------------------------------------------------------------------ -- naive solution; -- "deep" backtracking search solveNaive = do s <- [1..9] e <- [0..9] \\ [s] n <- [0..9] \\ [s, e] d <- [0..9] \\ [s, e, n] m <- [1..9] \\ [s, e, n, d] o <- [0..9] \\ [s, e, n, d, m] r <- [0..9] \\ [s, e, n, d, m, o] y <- [0..9] \\ [s, e, n, d, m, o, r] let send = toNumber [s,e,n,d] let more = toNumber [m,o,r,e] let money = toNumber [m,o,n,e,y] guard (send + more == money) return (send, more, money) -- convert a list of digits to a number toNumber :: [Int] -> Int toNumber = foldl (\x y -> x*10+y) 0 ------------------------------------------------------------------------ -- better solution using "shallow" backtracking -- a partial letter assignments type Assign = Map Letter Digit type Letter = Char type Digit = Int -- a monad combining state (assignments) and lists (backtracking search) type Solve = StateT Assign [] -- generic solver, e.g. -- solveFast "SEND" "MORE" "MONEY" (1 solution) -- solveFast "GREAT" "SWERC" "PORTO" (6 solutions) solveFast :: String -> String -> String -> [Assign] solveFast xs ys rs = do (_,solution) <- runStateT search Map.empty return solution where search = do solveAux (reverse xs) (reverse ys) (reverse rs) 0 x <- values (head xs) y <- values (head ys) r <- values (head rs) guard (x/=0 && y/=0 && r/=0) -- worker function for recursive search solveAux (a:as) (b:bs) (r:rs) carry = do x <- values a y <- values b -- x+y+carry adds up giving (new carry, z) let (carry', z) = (x+y+carry)`quotRem`10 -- bind the result digit bind r z solveAux as bs rs carry' -- continue solveAux [] [] [] carry = guard (carry == 0) solveAux [] [] [r] carry = bind r carry -- auxiliary monadic actions -- list possible values for a letter values :: Letter -> Solve Digit values letter = do assign <- get case Map.lookup letter assign of Nothing -> let digits = [0..9] \\ Map.elems assign in msum [ put (Map.insert letter digit assign) >> return digit | digit <- digits] Just digit -> return digit -- assign a digit to a letter bind :: Letter -> Digit -> Solve () bind letter digit = do assign <- get case Map.lookup letter assign of Nothing -> do guard (digit `notElem` Map.elems assign) put (Map.insert letter digit assign) Just digit' -> do guard (digit == digit') ```