OperatorPlacementProblem2017.hs

{-# LANGUAGE LambdaCase #-}

import           Data.Ratio (denominator, numerator)

data Expr = Number Rational | Paren Arith
instance Show Expr where
    show = \case
        Number n -> case denominator n of
            1 -> show (numerator n)
            _ -> show n
        Paren p -> "(" ++ show p ++ ")"

data Op = Add | Sub | Mul | Div
instance Show Op where
    show = \case
        Add -> "+"
        Sub -> "-"
        Mul -> "*"
        Div -> "/"

data Arith = Arith Op Expr Expr
instance Show Arith where
    show (Arith op left right) = unwords [show left, show op, show right]

iterOps :: [Op]
iterOps = [Add, Sub, Mul, Div]

iterExprs :: [Rational] -> [Expr]
iterExprs []   = []
iterExprs [n]  = [Number n]
iterExprs args =
    map Paren
        [ Arith op leftExpr rightExpr
        | leftArgLength <- [1 .. length args - 1]
        , let (leftArg, rightArg) = splitAt leftArgLength args
        , leftExpr <- iterExprs leftArg
        , rightExpr <- iterExprs rightArg
        , op <- iterOps
        ]

eval :: Expr -> Maybe Rational
eval = \case
    Number n -> Just n
    Paren p -> case p of
        Arith op left right -> case op of
            Div -> (/) <$> eval left <*> (eval right >>= nonZero)
            _   -> evalOp op <$> eval left <*> eval right
  where
    evalOp = \case
        Add -> (+)
        Sub -> (-)
        Mul -> (*)
        Div -> (/)
    nonZero x = case x of
        0 -> Nothing
        _ -> Just x

main :: IO ()
main = mapM_ print (filter isSolution (iterExprs source))
  where
    source = [10, 9 .. 1]
    isSolution expr = eval expr == Just 2017