Programming puzzle (expressions that evaluate to 100)

one_hundred.hs

{-# LANGUAGE LambdaCase #-}

import Data.List
import Text.Parsec.Prim hiding ((<|>), many)
import Text.Parsec.Expr
import Text.Parsec.Pos
import Text.Parsec.Combinator
import Text.Parsec.Error
import Data.Functor
import Data.Functor.Identity
import Control.Applicative

infixl 0 |>
x |> f = f x

hacky :: IO ()
hacky = exprs [1 .. 9]
        |> filter (\e -> eval e == 100)
        |> unlines
        |> putStr
  where
  exprs numbers = map show numbers
                  |> map (: [])
                  |> intersperse ["+", "-", ""]
                  |> sequence
                  |> map concat

  eval s = let [(v, rest)] = reads s in eval' v rest

  eval' n [] = n
  eval' n (op : rest) = let [(m, rest')] = reads rest in eval' (getOp op n m) rest'

  getOp '+' = (+)
  getOp '-' = (-)

data Op = Minus | Plus | Concat deriving (Eq)

data Expr = Number Int | Expr Op Expr Expr deriving (Eq)

instance Show Op where
  show Minus  = "-"
  show Plus   = "+"
  show Concat = ""

instance Show Expr where
  show (Number n)    = show n
  show (Expr op l r) = show l ++ show op ++ show r

tok :: (Show t, Stream s m t) => (t -> Maybe a) -> ParsecT s u m a
tok f = tokenPrim show (\pos _ _ -> incSourceColumn pos 1) f

literal :: (Eq a, Show a, Stream s m a) => a -> ParsecT s u m a
literal v = tok (\t -> if t == v then Just t else Nothing)

leftInt :: Parsec [Either Int Op] () Expr
leftInt = tok $ \case
  Left n -> Just (Number n)
  _      -> Nothing

operatorTable :: OperatorTable [Either Int Op] () Identity Expr
operatorTable =
  [ [ Infix (literal (Right Concat) $> Expr Concat) AssocLeft]
  , [ Infix (literal (Right Minus ) $> Expr Minus ) AssocLeft
    , Infix (literal (Right Plus  ) $> Expr Plus  ) AssocLeft
    ]
  ]

expr :: Parsec [Either Int Op] () Expr
expr = buildExpressionParser operatorTable leftInt

digits :: Int -> [Int]
digits n = unfoldr f n |> reverse
  where
  f 0 = Nothing
  f n = Just (m, n') where (n', m) = n `divMod` 10

undigits :: [Int] -> Int
undigits ds = foldl' (\n d -> 10 * n + d) 0 ds

eval :: Expr -> Int
eval (Number n) = n
eval (Expr Minus  l r) = eval l - eval r
eval (Expr Plus   l r) = eval l + eval r
eval (Expr Concat l r) = digits (eval l) ++ digits (eval r) |> undigits

matchingExprs :: Int -> [Int] -> Either ParseError [String]
matchingExprs target numbers = do exprs <- generateExprs
                                  let matches = filter (\e -> eval e == target) exprs
                                  map show matches |> return
  where
  generateExprs = map Left numbers
                  |> map (: [])
                  |> intersperse ([Right Minus, Right Plus, Right Concat])
                  |> sequence
                  |> mapM (parse expr "")

elegant :: IO ()
elegant = matchingExprs 100 [1 .. 9]
          |> either show unlines
          |> putStr

main :: IO ()
main = elegant