FOUR-est for the trees code

Tree.hs

module Tree (
  Tree(Plus,
       Minus,
       Times,
       Divide,
       Expt,
       Negate,
       Sqrt,
       Factorial,
       Four),
  eval,
  evalToInt,
  trees ) where

import Control.Monad (liftM, liftM2, mfilter)
import Data.List (inits, tails)

data Tree = Plus Tree Tree
          | Minus Tree Tree
          | Times Tree Tree
          | Divide Tree Tree
          | Expt Tree Tree
          | Negate Tree
          | Sqrt Tree
          | Factorial Tree
          | Four
  deriving (Read, Show)

trees :: [Tree] -> [Tree]
trees [x] = [ f x | f <- [ id, Negate, Sqrt, Factorial ] ]
trees xs = do
  (left, right) <- splits xs
  t1            <- trees left
  t2            <- trees right
  p             <- pairs t1 t2
  trees [p]

splits :: [a] -> [([a], [a])]
splits xs = init $ tail $ zip (inits xs) (tails xs)

pairs :: Tree -> Tree -> [Tree]
pairs a b = [ f a b | f <- [ Plus, Minus, Times, Divide, Expt ] ]

eval :: Tree -> Maybe Float
eval (Plus a b)  = binop (+) a b
eval (Minus a b) = binop (-) a b
eval (Times a b) = binop (*) a b
eval (Expt a b)  = binop (**) a b
eval (Divide a b) = liftM2 (/) (eval a) (mfilter (/=0) (eval b))
eval (Negate a) = unaryop (0-) a
eval (Sqrt a)   = unaryop sqrt a
eval (Factorial Four) = Just (4 * 3 * 2)
eval (Factorial _)    = Nothing
eval Four = Just 4

binop :: (Float -> Float -> Float) -> Tree -> Tree -> Maybe Float
binop op a b = liftM2 op (eval a) (eval b)

unaryop :: (Float -> Float) -> Tree -> Maybe Float
unaryop op a = liftM op (eval a)

evalToInt :: Tree -> Maybe Int
evalToInt t = round <$> mfilter good (eval t)

good :: Float -> Bool
good v = 0 <= v && v <= 20 && isInt v

isInt :: Float -> Bool
isInt n = fromIntegral (round n :: Int) == n

missing.hs

import Tree
import Data.Maybe (mapMaybe)
import Data.Set (difference, elems, fromList, Set)

solutions :: Set Int
solutions = fromList $ mapMaybe evalToInt $ trees $ replicate 4 Four

main :: IO ()
main = print $ elems $ difference (fromList [0..20]) solutions

solutions.hs

{-# LANGUAGE TupleSections #-}

import Tree
import Data.List (maximumBy, minimumBy, sortBy)
import Data.Map.Strict (fromListWith, assocs)
import Data.Maybe (mapMaybe)
import Data.Ord (comparing)
import System.Environment (getArgs)

size :: Tree -> Integer
size (Plus a b)    = 1 + size a + size b
size (Minus a b)   = 1 + size a + size b
size (Times a b)   = 1 + size a + size b
size (Divide a b)  = 1 + size a + size b
size (Expt a b)    = 1 + size a + size b
size (Negate a)    = 1 + size a
size (Sqrt a)      = 1 + size a
size (Factorial a) = 1 + size a + 1 -- prefer solutions w/o !
size (Four)        = 1

evaluated :: [(Int, Tree)]
evaluated = mapMaybe (\t -> (,t) <$> evalToInt t) $ trees $ replicate 4 Four

solutions :: ((Tree -> Tree -> Ordering) -> [Tree] -> Tree) -> [(Int, Tree)]
solutions p = sortBy (comparing fst) $ singleSolutions where
  singleSolutions = assocs $ fromListWith preferred evaluated
  preferred a b   = p (comparing size) [a, b]

ordering :: [String] -> (Tree -> Tree -> Ordering) -> [Tree] -> Tree
ordering ["-c"] = maximumBy
ordering ["-s"] = minimumBy
ordering _      = minimumBy

main :: IO ()
main = do
  args <- getArgs
  mapM_ print (solutions $ ordering args)

Tex.hs

module Tex (display) where

import Tree

tex :: Tree -> String
tex p@(Plus a b)                = binop "+" p a b
tex p@(Minus a b)               = binop "-" p a b
tex p@(Expt a b)                = binop "^" p a b
tex p@(Times a b)               = binop "\\times" p a b
tex p@(Divide a@(Divide x y) b) = frac (divide a x y) (group p b)
tex p@(Divide a b)              = frac (group p a) (group p b)
tex p@(Negate a)                = prefix "-" p a
tex p@(Factorial a)             = postfix "!" p a
tex (Sqrt a)                    = "\\sqrt{" ++ tex a ++ "}"
tex Four                        = "4"

binop :: String -> Tree -> Tree -> Tree -> String
binop op p a b = group p a ++ " " ++ op ++ " " ++ group p b

prefix :: String -> Tree -> Tree -> String
prefix op p a = "{" ++ op ++ group p a ++ "}"

postfix :: String -> Tree -> Tree -> String
postfix op p a = "{" ++ group p a ++ op ++ "}"

divide :: Tree -> Tree -> Tree -> String
divide a x y = (group a x ++ " / " ++ group a y)

frac :: String -> String -> String
frac num denom = "\\frac{" ++ num ++ "}{" ++ denom ++ "}"

group :: Tree -> Tree -> String
group parent child
  | p > c     = "(" ++ t ++ ")"
  | p == c    = "{" ++ t ++ "}"
  | otherwise = t
  where
    p = precedence parent
    c = precedence child
    t = tex child

precedence :: Tree -> Integer
precedence (Plus _ _)    = 1
precedence (Minus _ _)   = 1
precedence (Times _ _)   = 2
precedence (Divide _ _)  = 2
precedence (Negate _)    = 3
precedence (Sqrt _)      = 3
precedence (Factorial _) = 3
precedence (Expt _ _)    = 3
precedence Four          = 5

display :: (Integer, Tree) -> String
display (n, t) = show n ++ " = " ++ tex t

texify.hs

import Tex (display)
import System.Environment (getArgs)

main :: IO ()
main = do
  args <- getArgs
  file <- readFile $ head args
  mapM_ (putStrLn . display) $ map read $ lines file