A brute force solution to verbal arithmetic

AVerbalArithmetic.hs

import Control.Monad (guard)
import Data.Bifunctor (second)
import Data.Foldable (for_, traverse_)
import Data.List (nub, permutations, unwords)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)


test :: IO ()
test = do
  let solutions = findSolutions testCase
  for_ solutions $ \solution ->
    putStrLn . unwords $ uncurry (:) . second show <$> Map.toList solution

-- Solution is: d7 e5 m1 n6 o0 r8 s9 y2
testCase = VerbalArithmetic "send" "more" "money" (+)

data VerbalArithmetic = VerbalArithmetic
  { input1 :: String
  , input2 :: String
  , result :: String
  , operation :: Int -> Int -> Int
  }

findSolutions :: VerbalArithmetic -> [Map Char Int]
findSolutions v = nub
  . filter (doesMappingMatch v)
  . getAllPossibleValues
  $ collectCharacters v

collectCharacters :: VerbalArithmetic -> String
collectCharacters v = nub $ input1 v ++ input2 v ++ result v

getAllPossibleValues :: String -> [Map Char Int]
getAllPossibleValues characters = do
  oneThroughNine <- permutations [0..9]
  pure . Map.fromList $ zip characters oneThroughNine

doesMappingMatch :: VerbalArithmetic -> Map Char Int -> Bool
doesMappingMatch v valueMap = fromMaybe False $ do
  val1 <- intFromString valueMap $ input1 v
  val2 <- intFromString valueMap $ input2 v
  valResult <- intFromString valueMap $ result v
  let op = operation v
  pure $ val1 `op` val2 == valResult

intFromString :: Map Char Int -> String -> Maybe Int
intFromString valueMap str = do
  strInt <- concatMap show <$> traverse (`Map.lookup` valueMap) str
  let firstInt = head strInt
  guard $ firstInt /= '0'
  pure $ read strInt

FancierVerbalArithmetic.hs

{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}

import Control.Monad (guard)
import Data.Bifunctor (second)
import Data.Foldable (for_, traverse_)
import Data.List (nub, permutations, unwords)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.String (IsString(..))


test :: IO ()
test = do
  let solutions = findSolutions testCase
  for_ solutions $ \solution ->
    putStrLn . unwords $ uncurry (:) . second show <$> Map.toList solution

-- Solution is: ka7 c6 e3 i2 n5 o0 r4 s1 t9 u8
testCase = VerbalArithmetic ("costarica" `Add` "eritrea" `Add` "estonia") "countries"

data VerbalArithmetic = VerbalArithmetic
  { arithmetic :: Arithmetic String
  , result :: String
  }

data Arithmetic a
  = Val a
  | Add (Arithmetic a) (Arithmetic a)
  | Sub (Arithmetic a) (Arithmetic a)
  | Mul (Arithmetic a) (Arithmetic a)
  | Div (Arithmetic a) (Arithmetic a)
  deriving (Functor, Foldable, Traversable)

instance IsString (Arithmetic String) where
  fromString = Val

-- These could be fancier with recursion-schemes
extractStrings :: Arithmetic String -> String
extractStrings (Val x) = x
extractStrings (Add x y) = extractStrings x ++ extractStrings y
extractStrings (Sub x y) = extractStrings x ++ extractStrings y
extractStrings (Mul x y) = extractStrings x ++ extractStrings y
extractStrings (Div x y) = extractStrings x ++ extractStrings y

runArithmetic :: Arithmetic Int -> Int
runArithmetic (Val x) = x
runArithmetic (Add x y) = runArithmetic x + runArithmetic y
runArithmetic (Sub x y) = runArithmetic x - runArithmetic y
runArithmetic (Mul x y) = runArithmetic x * runArithmetic y
runArithmetic (Div x y) = runArithmetic x `div` runArithmetic y

findSolutions :: VerbalArithmetic -> [Map Char Int]
findSolutions v = nub
  . filter (doesMappingMatch v)
  . getAllPossibleValues
  $ collectCharacters v

collectCharacters :: VerbalArithmetic -> String
collectCharacters v = nub $ extractStrings (arithmetic v) ++ result v

getAllPossibleValues :: String -> [Map Char Int]
getAllPossibleValues characters = do
  oneThroughNine <- permutations [0..9]
  pure . Map.fromList $ zip characters oneThroughNine

doesMappingMatch :: VerbalArithmetic -> Map Char Int -> Bool
doesMappingMatch v valueMap = fromMaybe False $ do
  valArithmetic <- traverse (intFromString valueMap) $ arithmetic v
  valResult <- intFromString valueMap $ result v
  pure $ runArithmetic valArithmetic == valResult

intFromString :: Map Char Int -> String -> Maybe Int
intFromString valueMap str = do
  strInt <- concatMap show <$> traverse (`Map.lookup` valueMap) str
  let firstInt = head strInt
  guard $ firstInt /= '0'
  pure $ read strInt