import Control.Monad.State import Control.Monad.Error data Tree = Leaf Int | Plus Tree Tree | Times Tree Tree | Divide Tree Tree | Minus Tree Tree data Found = Found Tree deriving Show instance Show Tree where show (Leaf a) = show a show (Plus t1 t2) = "(" ++ (show t1) ++ " + " ++ (show t2) ++ ")" show (Times t1 t2) = "(" ++ (show t1) ++ " * " ++ (show t2) ++ ")" show (Divide t1 t2) = "(" ++ (show t1) ++ " / " ++ (show t2) ++ ")" show (Minus t1 t2) = "(" ++ (show t1) ++ " - " ++ (show t2) ++ ")" instance Error Found where noMsg = Found (Leaf 0) data CState = CState {target :: Int, bestValue :: Int, bestTree :: Tree, num :: Int} type Countdown a = ErrorT Found (State CState) a eval :: Tree -> Int eval (Leaf i) = i eval (Plus t1 t2) = (eval t1) + (eval t2) eval (Times t1 t2) = (eval t1) * (eval t2) eval (Divide t1 t2) = (eval t1) `div` (eval t2) eval (Minus t1 t2) = (eval t1) - (eval t2) take1 :: [a] -> [(a,[a])] take1 [] = [] take1 (x:l) = (x,l):(map (\(a,al) -> (a,x:al)) (take1 l)) pairs :: [a] -> [([a],[a])] pairs [] = [] pairs [_] = [] pairs (x:l) = (map (\(x',l') -> ([x,x'], l')) (take1 l)) ++ (map (\(l1,l2) -> (l1,x:l2)) (pairs l)) dvd b a = (a `mod` b) == 0 registerTree :: (Tree,Int) -> Countdown (Tree,Int) registerTree (t,v) = do tgt <- lift \$ gets target bv <- lift \$ gets bestValue if abs (bv - tgt) > abs (v - tgt) then lift \$ modify (\s -> s{bestTree = t, bestValue = v}) else return () if v == tgt then throwError (Found t) else return () n <- lift \$ gets num lift \$ modify (\s -> s{num = n + 1}) return (t,v) joinTrees :: (Tree,Int) -> (Tree,Int) -> Countdown [(Tree,Int)] joinTrees (t1,v1) (t2,v2) = do let p = Just (Plus t1 t2, v1+v2) t = Just (Times t1 t2, v1*v2) d = if v1 `dvd` v2 then Just (Divide t2 t1, v2 `div` v1) else if v2 `dvd` v1 then Just (Divide t1 t2, v1 `div` v2) else Nothing m = if v1 > v2 then Just (Minus t1 t2, v1 - v2) else if v1 < v2 then Just (Minus t2 t1, v2 - v1) else Nothing in check [p,t,d,m] >>= return where check [] = return [] check (x:l) = case x of Just xx -> do l' <- check l registerTree xx return (xx:l') Nothing -> check l >>= return search :: [(Tree, Int)] -> Countdown () search [] = return () search [_] = return () --search l = mapM_ (\([t1,t2],l') -> (joinTrees t1 t2) >>= (mapM_ (search . (:l')))) (pairs l) search l = mapM (\([t1,t2],l') -> (joinTrees t1 t2) >>= mapM (return . (:l'))) (pairs l) >>= (mapM_ search) . concat runCountdown l tgt = let (a, CState _ _ t n) = runState (runErrorT ((mapM (\i -> registerTree (Leaf i,i)) l) >>= search)) (CState tgt 0 (Leaf 0) 0) in (t, eval t, n) -- runCountdown [75,50,2,3,9,7] 7968