{-
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 <pbv@dcc.fc.up.pt>, 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')