Make10.hs

import Data.List
import Data.Char
import Control.Monad

data Expr = Number Int | Op Char
instance Show Expr where
    show (Number x) = show x
    show (Op ch) = [ch]

type Ops a = [(a -> a -> [a], Char )]

solve :: (Num a,Eq a) => [Int] -> Int -> Ops a -> [[Expr]]
solve xs ans ops = go [] xs
    where
    go [x] [] | x == fromIntegral ans = return []
    go (x1:x2:l) xs = shift (x1:x2:l) xs `mplus` reduce x1 x2 l xs
    go l xs = shift l xs
    shift l xs = do
        x <- xs
        r <- go (fromIntegral x:l) (delete x xs)
        return (Number x:r)
    reduce x1 x2 l xs = do
        (op,ch) <- ops
        x3 <- op x1 x2
        r <- go (x3:l) xs
        return (Op ch:r)

ops1 :: Ops Rational
ops1 = [ (add,'+'),(sub,'-'),(mul,'*'),(divZero,'/') ]
    where
    add a b = return (a+b)
    sub a b = return (a-b)
    mul a b = return (a*b)
    divZero a b | b == 0 = [] | otherwise = return (a/b)

ops2 :: Ops Int
ops2 = [ (add,'+'),(sub,'-'),(mul,'*'),(div','/') ]
    where
    add a b = return (a+b)
    sub a b | a < b = [] | otherwise = return (a-b)
    mul a b = return (a*b)
    div' a b | b == 0 || mod a b /= 0 = [] 
             | otherwise = return (div a b)

showExpr :: [Expr] -> String
showExpr = go []
    where
    go [s] [] = s
    go (s1:s2:ss) (op:l) | isOp op = go ((unparen $ unwords [s1,show op,s2]):ss) l
    go ss (x:l) = go (show x:ss) l
    isOp (Op _) = True
    isOp _ = False
    unparen s = "(" ++ s ++ ")"

main :: IO ()
main = do
    let l = do 
        d1 <- [0..9]
        d2 <- [d1..9]
        d3 <- [d2..9]
        d4 <- [d3..9]
        return [d1,d2,d3,d4]
    forM_ l $ \xs -> do
        let s = map intToDigit xs
        let ans1 = solve xs 10 ops1
        let ans2 = solve xs 10 ops2
        when (null ans1) $ do
            putStrLn $ s ++ " no answer"
        when (null ans2 && not (null ans1)) $ do
            putStrLn $ s ++ " " ++ show (length ans1) ++ " " ++ showExpr (head ans1)