Skip to content

Instantly share code, notes, and snippets.

@cqfd
Created August 5, 2011 17:08
Show Gist options
  • Save cqfd/1127997 to your computer and use it in GitHub Desktop.
Save cqfd/1127997 to your computer and use it in GitHub Desktop.
Haskell solution to the 1,3,4,6 problem
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
@md2perpe
Copy link

md2perpe commented Aug 5, 2011

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

@cqfd
Copy link
Author

cqfd commented Aug 5, 2011

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

@md2perpe
Copy link

md2perpe commented Aug 6, 2011

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

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment