Haskell Quiz/Verbal Arithmetic/Solution Jethr0

From HaskellWiki
< Haskell Quiz‎ | Verbal Arithmetic
Revision as of 10:47, 12 July 2007 by JohannesAhlmann (talk | contribs) (my solution to verbal arithmetic)

(diff) ← Older revision | Latest revision (diff) | Newer revision → (diff)
Jump to: navigation, search

I'm using a StateT monad inside a list monad for backtracking. The State monad keeps track of the digits associated with characters and also a carry state, that remembers the carried number from prior additions.

Several constraints are already implemented (like leading digits not being zero, all associations being unique), but of course there could be lot added (checking for zero, even/odd-ness, ...)

Solution should be far quicker than generic brute-force/backtracking since it tries to fail as early as possible and with more elaborate constraints it should become even faster!

I couldn't be bothered to write yet another regexp/parser, as that didn't really interest me.

module Main where

import qualified Data.Map as Map
import qualified Data.List as List
import Data.Char (intToDigit)
import Control.Monad
import Control.Monad.State
import Data.Maybe (fromJust)

type Carry  = Integer
type Assocs = Map.Map Char Integer
type St     = (Assocs, Carry)

parts  = ["forty", "ten", "ten"]
result = "sixty"

-- turn words into pairs of digits
digitize :: [String] -> String -> [([Char], Char)]
digitize ps res = zip ps' (reverse res)
  where ps'  = (List.transpose . map reverse $ ps) ++ repeat ""

solve :: [String] -> String -> StateT St [] ()
solve parts' res' = do
  let digitPairs  = digitize parts' res'
  let constraints = makeConstraints parts' res'
  sequence_ . map (setDigitPairs constraints) $ digitPairs

{- construct constraints from actual data
    TODO: a+b=a => b=0
          a+a=c => c even
makeConstraints :: [String] -> String -> [StateT St [] ()]
makeConstraints parts' res' =
  -- leading digits shouldn't be zero
  map (constraintCheck (guard . (0/=))) firsts
  where firsts  = map head (res' : parts)
        constraintCheck cstr c = do
          (s,_) <- get
          case Map.lookup c s of 
            Nothing -> return ()
            Just i  -> cstr i

-- set digits, make per-digit check with carry and apply constraints
setDigitPairs cstrs (ds,res) = do
  ls <- sequence . map placer $ ds
  r  <- placer res

  (_,carry) <- get
  let r' = sum ls + carry
  guard $ r' `mod` 10 == r
  let carry' = r' `div` 10
  modify (\(a,_) -> (a,carry'))
  sequence cstrs

-- place number if not yet set and check for uniqueness,
--   otherwise return already set value
placer :: Char -> StateT St [] Integer
placer l = do
  (assoc,_) <- get
  case Map.lookup l assoc of
    Just i  -> return i
    Nothing -> do
      a <- lift [0..9]
      guard $ a `notElem` (Map.elems assoc)
      modify (\(ass,c) -> (Map.insert l a ass, c))
      return a

main = mapM_ print . Map.toList . fst . head $ 
        execStateT (solve parts result) (Map.empty :: Assocs, 0)