codepad

Language:

{-
  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')

Private [?]

Run code