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