Solves the generalized 4 numbers game (AKA 24 game) in Haskell. Answers the question "can you make this number out of those numbers (using basic operations)? If so, how?"

four_numbers.hs

import Data.List
import System.Environment

---------- Main ----------

main :: IO ()
main = main1

main1 :: IO ()
main1 = do
  args <- getArgs
  let numArgs = map (\x -> read x :: Int) args
      numbers = init numArgs
      number = fromIntegral . last $ numArgs
  putStrLn $ intercalate "\n" $ eqnsWhere numbers number

-- usage: ./four_numbers 1 2 3 4 31
-- prints out the ways to make 31 using 1 2 3 and 4 on a new line
-- eg. (-1 + ((4 ^ 3) / 2))

main2 :: IO ()
main2 = do
  args <- getArgs
  let n = read (head args) :: Int
      eqns = map (eqnToStr . genericizeEqn) $ treesWithNLeaves n
  putStrLn $ intercalate "\n" $ eqns
-- usage: ./four_numbers 4
-- prints out all possible trees on a new line
-- eg. (A op (A op (A op A)))

----------  Trees ----------

-- Each tree can store nDataType in every node, iDataType in every internal node,
-- and lDataType in every leaf
-- I could have implimented the same functionality with (ndata, Either pdata ldata)
-- at every node but then I would have less type-safety
data Tree nDataType iDataType lDataType =
  LeafNode nDataType lDataType |
  IntNode nDataType iDataType
    (Tree nDataType iDataType lDataType)
    (Tree nDataType iDataType lDataType)
  deriving (Show)

mapTree :: Tree nDataType iDataType lDataType ->
  ((nDataType, iDataType) -> (nDataType', iDataType')) ->
  ((nDataType, lDataType) -> (nDataType', lDataType')) ->
  Tree nDataType' iDataType' lDataType'
mapTree (LeafNode a b) _ l_transform = LeafNode a' b'
  where (a', b') = l_transform (a, b)
mapTree (IntNode a b left right) i_transform l_transform =
  IntNode a' b' left' right'
  where (a', b') = i_transform (a, b)
        left' = mapTree left i_transform l_transform
        right' = mapTree right i_transform l_transform

-- Does a DFS and fills in each node with data from the lists
decorate_ :: Tree () () () -> ([node_data], [int_data], [leaf_data])
  -> (Tree node_data int_data leaf_data, [node_data], [int_data], [leaf_data])
decorate_ (LeafNode _ _) (nodes, ints, leaves) = (leaf, nodes', ints', leaves')
  where leaf = LeafNode (head nodes) (head leaves)
        (nodes', ints', leaves') = (tail nodes, ints, tail leaves)
decorate_ (IntNode _ _ left right) (nodes, ints, leaves) =
  (int_node, nodes''', ints''', leaves''')
  where int_node = IntNode (head nodes) (head ints) left' right'
        (nodes', ints', leaves') = ((tail nodes), (tail ints), leaves)
        (left', nodes'', ints'', leaves'') = decorate_ left (nodes', ints', leaves')
        (right', nodes''', ints''', leaves''') = decorate_ right (nodes'', ints'', leaves'')

decorate :: Tree () () () -> [node_data] -> [int_data] -> [leaf_data]
  -> Tree node_data int_data leaf_data
decorate tree nodes ints leaves = first $ decorate_ tree (nodes, ints, leaves)
  where first (x, _, _, _) = x

----------  Tree generation ----------

treesWithNLeaves :: Int -> [Tree () () ()]
treesWithNLeaves 1 = [(LeafNode () ())]
-- put together a tree with i leaves and a tree with n - i leaves to get a tree of n leaves
treesWithNLeaves n = [(IntNode () () left right) |
            i <- [1..(n-1)],
            left <- treesWithNLeaves i,
            right <- treesWithNLeaves (n - i)]

-- number of internal nodes of a tree with n leaves
intNodesWithNLeaves :: Int -> Int
intNodesWithNLeaves n = n - 1

-- number of nodes of a tree with n leaves
nodesWithNLeaves :: Int -> Int
nodesWithNLeaves 1 = 1
nodesWithNLeaves n = 2 * n - 1

----------  Equation trees ----------

eqnToStr :: Tree String String String -> String
eqnToStr (LeafNode unary num) = unary ++ num
eqnToStr (IntNode unary binary left right) =
  unary ++ "(" ++ (eqnToStr left) ++ " " ++ binary ++ " " ++ (eqnToStr right) ++ ")"

-- converts arbitrary tree to a tree whose internal nodes say "op" and leaf nodes say "A"
-- useful for displaying a tree
genericizeEqn :: Tree a b c -> Tree String String String
genericizeEqn tree = mapTree tree
                      (\_ -> ("", "op"))
                      (\_ -> ("", "A" ))

evaluate :: Tree (a -> b) (b -> b -> a) a -> b
-- Evaluates a tree with unary operators at every node, binary operators
-- at every internal node, and numbers at every leaf
evaluate (LeafNode unary num) = unary num
evaluate (IntNode unary binary left right) =
  unary $ binary (evaluate left) (evaluate right)

eqnsFrom :: [Int] -> [(Float, String)]
-- Turns each equation into its evaluation and a string representing it
eqnsFrom numbers = [
  (evaluate $ decorate tree (map fst unaries') (map fst binaries') (map fromIntegral numbers'),
   eqnToStr $ decorate tree (map snd unaries') (map snd binaries') (map show numbers'))
  | unaries' <- mproduct unaries $ nodesWithNLeaves n,
    binaries' <- mproduct binaries $ intNodesWithNLeaves n,
    numbers' <- permutations numbers,
    tree <- treesWithNLeaves n]
  where n = length numbers

-- Returns all equations of numbers that evaluate to number
eqnsWhere :: [Int] -> Float -> [String]
eqnsWhere numbers number = map snd $ filter (\(val, _) -> val == number) $ eqnsFrom numbers

----------  Unary operators ----------

identity :: Float -> Float
identity x = x
negative :: Float -> Float
negative x = -x
-- Unused unary operators
-- factorial :: Float -> Float
-- factorial x 
--  | not $ isInt x = 0/0
--  | x > 6 = 0/0
--  | otherwise = product [1..x]
-- double_factorial :: Float -> Float
-- double_factorial x
--  | not $ isInt x = 0/0
--  | x > 15 = 0/0
--  | odd (floor x :: Int) = product [1, 3 .. x]
--  | otherwise = product [2, 4 .. x]
-- neg_factorial :: Float -> Float
-- neg_factorial x = - (factorial x)

unaries :: [(Float -> Float, String)]
unaries = [(identity, ""), (negative, "-")
           -- , (factorial, "!"), (neg_factorial, "-!"), (double_factorial, "!!")
           -- , (fromIntegral . floor, "floor"), (fromIntegral . ceiling, "ceiling")
          ]

---------- Binary operators ----------

-- Unused binary operator
-- nth_root :: Float -> Float -> Float
-- nth_root x y = x ** (1/y)
concat_digits :: Float -> Float -> Float
concat_digits x y
 | x > 0 && y > 0 && isInt x && isInt y = y + x * 10 ^ digits y
 | otherwise = 0/0

binaries :: [(Float -> Float -> Float, String)]
binaries = [((+), "+"), ((*), "*"), ((/), "/"), ((**), "^"), (concat_digits, ".")
           -- , (nth_root, "root"), (logBase, "log")
           ]

---------- Helpers ----------

isInt :: Float -> Bool
isInt x = x == (fromInteger $ round x)

digits :: Float -> Int
digits x = floor $ 1 + (logBase 10 x)

-- mproduct lst n computes the cartesian product of lst with itself n times
-- unfortunately haskell cannot deal with variable-sized tuples, so the result
-- is a list of lists (rather than a list of tuples)
mproduct :: [a] -> Int -> [[a]]
mproduct lst 0 = [[] | _ <- lst]
mproduct lst 1 = [[x] | x <- lst]
mproduct lst n = [r ++ [x] | r <- mproduct lst (n - 1), x <- lst]