1 {- Andy Gill, Oct 99 2 3 Here is a generic cryptarithm solver, written in Haskell. It does 4 use a State Monad library, which is based on the work documented in 5 "Functional Programming with Overloading and Higher-Order Polymorphism", 6 Mark P. Jones, Advanced School of Functional Programming, 1995. 7 8 This can solve the puzzle in about 3 seconds on my laptop. 9 On key optimization is captured by the line 10 guard (topN `mod` 10 == botN) 11 in the function solve. It prunes searches than simply 12 can not ever reach valid results. 13 -} 14 15 module Main where 16 17 import Monad 18 import MonadState 19 import List 20 import Maybe 21 22 -- newtype DigitState = DigitState (Digits -> [(a,Digits))]) 23 -- which some might recognize as the list-of-successes parsing monad. 24 25 type DigitState a = StateT Digits [] a 26 27 -- Our digits state 28 -- * First we have the remaining digit to allocate. 29 -- * Second, we have the mapping from Char to Digit, 30 -- for the chars that have been mapped so far. 31 32 data Digits = Digits { 33 digits :: [Int], 34 digitEnv :: [(Char,Int)] 35 } deriving Show 36 37 initState = Digits { 38 digits = [0..9], 39 digitEnv = [] 40 } 41 42 -- permute adds a mapping from a char to each of the 43 -- remaining allocable digits. 44 -- This is used in the context of the list-of-successes 45 -- monad, so it actually returns all possible mappings. 46 47 permute :: Char -> DigitState Int 48 permute c = 49 do st <- get 50 let xs = digits st 51 (i,is) <- lift [ (x,xs \\ [x]) | x <- xs] 52 put (st { digits = is, 53 digitEnv = (c,i):digitEnv st }) 54 return i 55 56 -- select attempt first checks to see if a mapping 57 -- from a specific char to digit already has been 58 -- mapped. If so, use the mapping, otherwise 59 -- add a new mapping. 60 61 select :: Char -> DigitState Int 62 select c = 63 do st <- get 64 case lookup c (digitEnv st) of 65 Just r -> return r 66 Nothing -> permute c 67 68 -- solve takes a list of list of (backwards) letters, 69 -- and a list of (backwards) letters, and tries 70 -- to map the letter to digits, such that 71 -- the sum of the first list of letters (mapped to digits) 72 -- is equal to the sum of the second list of letters, 73 -- again mapped to digits. 74 -- 75 -- So a possible mapping for A+B=C might be 76 -- solve ["A","B"] "C" 0 77 -- => A -> 1, B -> 2, C -> 3 78 79 solve :: [[Char]] -> [Char] -> Int -> DigitState () 80 solve tops (bot:bots) carry = 81 do topN <- (case tops of 82 [] -> return carry 83 (top:_) -> 84 do topNS <- mapM select top 85 return (sum topNS + carry)) 86 botN <- select bot 87 guard (topN `mod` 10 == botN) -- key optimization 88 solve (rest tops) bots (topN `div` 10) 89 where 90 rest [] = [] 91 rest (x:xs) = xs 92 solve [] [] 0 = return () 93 solve _ _ _ = mzero 94 95 -- Puzzle provides a cleaner interface into solve. 96 -- The strings are in the order *we* write them. 97 98 puzzle :: [[Char]] -> [Char] -> String 99 puzzle top bot = 100 if length (nub (concat top ++ bot)) > 10 101 then error "can not map more than 10 chars" 102 else if topVal /= botVal 103 then error ("Internal Error") 104 else unlines [ [c] ++ " => " ++ show i | 105 (c,i) <- digitEnv answer 106 ] 107 where 108 solution = solve (transpose (map reverse top)) 109 (reverse bot) 110 0 111 answer = case (execStateT solution initState) of 112 (a:_) -> a 113 [] -> error "can not find a solution" 114 env = digitEnv answer 115 look c = fromJust (lookup c env) 116 topVal = sum [expand xs | xs <- top] 117 botVal = expand bot 118 expand = foldl (\ a b -> a * 10 + look b) 0 119 120 main = putStr ( 121 puzzle ["THIRTY", 122 "TWELVE", 123 "TWELVE", 124 "TWELVE", 125 "TWELVE", 126 "TWELVE"] 127 "NINETY")