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")