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

What is "the 1,3,4,6 problem"?

I'm going to publish a blog post about it in a bit, but the "1,3,4,6" problem comes from the beginning of Hacking: The Art of Exploitation:

Using the numbers 1, 3, 4, and 6, each exactly once, come up with an arithmetic expression using the usual four mathematical operators (addition, subtraction, multiplication, division) that evaluates to 24. So for example, you might try 1 + (3 * 4)/2, but that evaluates to 7, not 24.

The code above solves the puzzle using brute force, by generating all possible arithmetic expressions satisfying the problem constraints; it then prints all of them that evaluate to 24.

Are parenthesis allowed? (You have it in your example, although not necessary at that place.)

Yeah, you can parenthesize however you want.

PS--don't give the answer away :)

I've got another solution:

{-
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
E.g. 1 4 6 3 / + - evalutes as 1-(4+(6/3)) = -5.
-}

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

push :: a -> State [a] ()
push x = do
    xs <- get
    put (x : xs)

pop :: State [a] a
pop = do
    x:xs <- get
    put xs
    return x

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

evalWord :: String -> State [Rational] ()
evalWord "+" = doOp (+)
evalWord "-" = doOp (-)
evalWord "*" = doOp (*)
evalWord "/" = do
    x1 <- pop
    x2 <- pop
    push (if x1 == 0 then 0 else x2 / x1)   -- ugly; should have State (Maybe [Rational])

evalWord cs | all isDigit cs = push (read cs % 1)
            | otherwise = error "Unknown word"

eval :: String -> Rational
eval s = head $ (execState $ foldl1 (>>) $ map evalWord $ words s) []

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]

stringsToCheck = map (intercalate " ") combosOfDigitsAndOperators

solutions = map fst $ filter snd $ map (\s -> (s, eval s == 24%1)) $ stringsToCheck

Awesome! That's probably the coolest example of the State monad I've seen yet.

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