Difference between revisions of "Haskell Quiz/Verbal Arithmetic/Solution Jethr0"
From HaskellWiki
m (my solution to verbal arithmetic) 
m 

(One intermediate revision by the same user not shown)  
Line 25:  Line 25:  
parts = ["forty", "ten", "ten"] 
parts = ["forty", "ten", "ten"] 

result = "sixty" 
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 :: [String] > String > StateT St [] () 

solve parts' res' = do 
solve parts' res' = do 

−  let digitPairs = digitize parts' res' 

let constraints = makeConstraints parts' res' 
let constraints = makeConstraints parts' res' 

−  +  mapM_ (setDigitPairs constraints) digitPairs 

+  
+  (_, carry) < get 

+  guard $ carry == 0 

+  
+  where digitPairs = zip ps' (reverse res') 

+  ps' = (List.transpose . map reverse $ parts) ++ repeat "" 

Line 58:  Line 51:  
 set digits, make perdigit check with carry and apply constraints 
 set digits, make perdigit check with carry and apply constraints 

setDigitPairs cstrs (ds,res) = do 
setDigitPairs cstrs (ds,res) = do 

−  ls < 
+  ls < mapM placer ds 
r < placer res 
r < placer res 

Line 87:  Line 80:  
main = mapM_ print . Map.toList . fst . head $ 
main = mapM_ print . Map.toList . fst . head $ 

execStateT (solve parts result) (Map.empty :: Assocs, 0) 
execStateT (solve parts result) (Map.empty :: Assocs, 0) 

+  
</haskell> 
</haskell> 
Latest revision as of 21:54, 15 July 2007
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/oddness, ...)
Solution should be far quicker than generic bruteforce/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"
solve :: [String] > String > StateT St [] ()
solve parts' res' = do
let constraints = makeConstraints parts' res'
mapM_ (setDigitPairs constraints) digitPairs
(_, carry) < get
guard $ carry == 0
where digitPairs = zip ps' (reverse res')
ps' = (List.transpose . map reverse $ parts) ++ repeat ""
{ 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 perdigit check with carry and apply constraints
setDigitPairs cstrs (ds,res) = do
ls < mapM 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)