Haskell Quiz/Verbal Arithmetic/Solution Jethr0
From HaskellWiki
< Haskell Quiz | Verbal Arithmetic(Difference between revisions)
m (my solution to verbal arithmetic) |
m |
||
| (One intermediate revision not shown.) | |||
| Line 25: | Line 25: | ||
parts = ["forty", "ten", "ten"] | parts = ["forty", "ten", "ten"] | ||
result = "sixty" | result = "sixty" | ||
| - | |||
| - | |||
| - | |||
| - | |||
| - | |||
| - | |||
solve :: [String] -> String -> StateT St [] () | solve :: [String] -> String -> StateT St [] () | ||
solve parts' res' = do | solve parts' res' = do | ||
| - | |||
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 57: | ||
-- set digits, make per-digit check with carry and apply constraints | -- set digits, make per-digit 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 86: | ||
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> | ||
Current revision
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" 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 per-digit 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)
