> The other two points also occured to me to. So why not challenge C++
> to show a generic (and efficient !) cryptarithm solver ... I can do
> that easily in Prolog or even better in CLP. People more fluent in
> Haskell can do it there.
Here is a generic cryptarithm solver, written in Haskell. It does
use a State Monad library, which is based on the work documented in
"Functional Programming with Overloading and Higher-Order Polymorphism",
Mark P. Jones, Advanced School of Functional Programming, 1995.
This can solve the puzzle in about 3 seconds on my laptop.
On key optimization is captured by the line
guard (topN `mod` 10 == botN)
in the function solve. It prunes searches than simply
can not ever reach valid results.
module Main where
import List
import Maybe
import Monad
import MonadState
-- Define DigitState monad as a monad with "Digits" for its state,
-- and an inner List monad. This is much the same as:
-- newtype DigitState = DigitState (Digits -> [(a,Digits))])
-- which some might recognize as the list-of-successes parsing monad.
type DigitState a = StateT Digits [] a
-- Our digits state
-- * First we have the remaining digit to allocate.
-- * Second, we have the mapping from Char to Digit,
-- for the chars that have been mapped so far.
data Digits = Digits {
digits :: [Int],
digitEnv :: [(Char,Int)]
} deriving Show
initState = Digits {
digits = [0..9],
digitEnv = []
}
-- permute adds a mapping from a char to each of the
-- remaining allocable digits.
-- This is used in the context of the list-of-successes
-- monad, so it actually returns all possible mappings.
permute :: Char -> DigitState Int
permute c =
do st <- get
let xs = digits st
(i,is) <- lift [ (x,xs \\ [x]) | x <- xs]
put (st { digits = is,
digitEnv = (c,i):digitEnv st })
return i
-- select attempt first checks to see if a mapping
-- from a specific char to digit already has been
-- mapped. If so, use the mapping, otherwise
-- add a new mapping.
select :: Char -> DigitState Int
select c =
do st <- get
case lookup c (digitEnv st) of
Just r -> return r
Nothing -> permute c
-- solve takes a list of list of (backwards) letters,
-- and a list of (backwards) letters, and tries
-- to map the letter to digits, such that
-- the sum of the first list of letters (mapped to digits)
-- is equal to the sum of the second list of letters,
-- again mapped to digits.
--
-- So a possible mapping for A+B=C might be
-- solve ["A","B"] "C" 0
-- => A -> 1, B -> 2, C -> 3
solve :: [[Char]] -> [Char] -> Int -> DigitState ()
solve tops (bot:bots) carry =
do topN <- (case tops of
[] -> return carry
(top:_) ->
do topNS <- mapM select top
return (sum topNS + carry))
botN <- select bot
guard (topN `mod` 10 == botN) -- key optimization
solve (rest tops) bots (topN `div` 10)
where
rest [] = []
rest (x:xs) = xs
solve [] [] 0 = return ()
solve _ _ _ = mzero
-- Puzzle provides a cleaner interface into solve.
-- The strings are in the order *we* write them.
puzzle :: [[Char]] -> [Char] -> String
puzzle top bot =
if length (nub (concat top ++ bot)) > 10
then error "can not map more than 10 chars"
else if topVal /= botVal
then error ("Internal Error")
else unlines [ [c] ++ " => " ++ show i |
(c,i) <- digitEnv answer
]
where
solution = solve (transpose (map reverse top))
(reverse bot)
0
answer = case (execStateT solution initState) of
(a:_) -> a
[] -> error "can not find a solution"
env = digitEnv answer
look c = fromJust (lookup c env)
topVal = sum [expand xs | xs <- top]
botVal = expand bot
expand = foldl (\ a b -> a * 10 + look b) 0
main = putStr (
puzzle ["THIRTY",
"TWELVE",
"TWELVE",
"TWELVE",
"TWELVE",
"TWELVE"]
"NINETY")
