Haskell solution to the 1,3,4,6 problem

bruteforce.hs

import Control.Monad (mapM_)

main :: IO ()
main = printSolutions 24 [1,3,4,6] "+-*/"

data BareTree a = BLeaf a | BBranch (BareTree a) (BareTree a) deriving Show

type Op = Char

toOp :: (Fractional a) => Op -> (a -> a -> a)
toOp '+' = (+)
toOp '-' = (-)
toOp '*' = (*)
toOp '/' = (/)

data ArithTree a =  ALeaf a | ABranch Op (ArithTree a) (ArithTree a)

instance (Show a) => Show (ArithTree a) where
    show (ALeaf x) = show x
    show (ABranch op leftTree rightTree) =
        "(" ++ show leftTree ++ ")" ++ [op] ++ "(" ++ show rightTree ++ ")"


insert :: a -> BareTree a -> [BareTree a]
insert x (BLeaf y) =
    [BBranch (BLeaf x) (BLeaf y), BBranch (BLeaf y) (BLeaf x)]
insert x bt@(BBranch leftTree rightTree) =
    let 
        leftPreInsert = BBranch (BLeaf x) bt
        rightPreInsert = BBranch bt (BLeaf x)
        leftSubInserts = do
            leftSubInsert <- insert x leftTree
            return (BBranch leftSubInsert rightTree)
        rightSubInserts = do
            rightSubInsert <- insert x rightTree
            return (BBranch leftTree rightSubInsert)
    in 
        [leftPreInsert, rightPreInsert] ++ leftSubInserts ++ rightSubInserts

allBareTrees :: [a] -> [BareTree a]
allBareTrees [x] = [BLeaf x]
allBareTrees (x:xs) = allBareTrees xs >>= insert x

opifyWith :: [Op] -> BareTree a -> [ArithTree a]
opifyWith _ (BLeaf x) = [ALeaf x]
opifyWith ops (BBranch leftTree rightTree) = do
    op <- ops
    opifiedLeftTree <- opifyWith ops leftTree
    opifiedRightTree <- opifyWith ops rightTree
    return (ABranch op opifiedLeftTree opifiedRightTree)

allArithTrees :: (Fractional a) => [a] -> [Op] -> [ArithTree a]
allArithTrees ints ops = allBareTrees ints >>= opifyWith ops

eval :: (Fractional a) => ArithTree a -> Maybe a
eval (ALeaf x) = return x

eval (ABranch '/' leftTree rightTree) = do
    rightResult <- eval rightTree
    if rightResult == 0 then
        Nothing
    else do
        leftResult <- eval leftTree
        return (toOp '/' leftResult rightResult)

eval (ABranch op leftTree rightTree) = do
    leftResult <- eval leftTree
    rightResult <- eval rightTree
    return (toOp op leftResult rightResult)

findSolutions :: (Fractional a) => a -> [a] -> [Op] -> [ArithTree a]
findSolutions answer ints ops =
    filter (\tree -> eval tree == Just answer) (allArithTrees ints ops)

printSolutions :: Fractional a => a -> [a] -> [Op] -> IO ()
printSolutions answer ints ops =
    let solutions = findSolutions answer ints ops
    in mapM_ (putStrLn . show) solutions

Cleaner using the StateT monad transformer on Maybe:

{-
Use each of the numbers 1, 3, 4, and 6 exactly once 
with any of the four basic math operations (addition, 
subtraction, multiplication, and division) to total 24.

Each number must be used once and only once, and you may 
define the order of operations; for example, 
3 * (4 + 6) + 1 = 31 is valid, however incorrect, 
since it doesn't total 24.


My idea:
take 1, 3, 4, 6 in any order and push to stack
take 3 of +, -, *, / (repeats okey) and evaluate
-}

import Control.Monad.State
import Data.Char(isDigit)
import Data.Ratio
import Data.List(permutations)
import Data.Maybe

type StackMonad a b = StateT [a] Maybe b

push :: a -> StackMonad a ()
push x = do
    xs <- get
    put (x : xs)


pop :: StackMonad a a
pop = do
    xxs <- get
    case xxs of
        [] -> mzero
        x:xs -> do 
            put xs
            return x


doOp :: (a -> a -> a) -> StackMonad a ()
doOp op = do
    x1 <- pop
    x2 <- pop
    push (x2 `op` x1)

doDiv :: Fractional a => StackMonad a ()
doDiv = do
    x1 <- pop
    x2 <- pop
    guard $ x1 /= 0
    push (x2 / x1)

evalWord :: String -> StackMonad Rational ()
evalWord "+" = doOp (+)
evalWord "-" = doOp (-)
evalWord "*" = doOp (*)
evalWord "/" = doDiv
evalWord cs | all isDigit cs = push (read cs % 1)
            | otherwise = mzero

eval :: [String] -> Maybe Rational
eval ss = case execStateT (foldl1 (>>) $ map evalWord ss) [] of
    Just (r:_) -> Just r
    _ -> Nothing


digits = map show [1, 3, 4, 6]
operators = ["+", "-", "*", "/"]

combosOfDigits = permutations digits
combosOfOperators = [[op1, op2, op3] | op1 <- operators, op2 <- operators, op3 <- operators]
combosOfDigitsAndOperators = [digits ++ operators | digits <- combosOfDigits, operators <- combosOfOperators]

maybeSolution :: [String] -> Maybe [String]
maybeSolution ss | eval ss == Just (24%1) = Just ss
                 | otherwise = Nothing

solutions :: [[String]]
solutions = mapMaybe maybeSolution combosOfDigitsAndOperators