Haskell Quiz/Countdown/Solution Dolio

I played around with this problem for quite a while, and constructed three different solutions.

The first is a naive solution. It searches the entire problem space, except that it discards any intermediate results of 0 (to avoid division errors). I was too impatient to see if it could solve the example problem, but it can solve smaller versions of it.

The next solution (better), makes use of various pruning methods via pick and search. It doesn't prune away all duplicate values, but it eliminates enough to solve the sample problem in a few seconds, and the harder problem listed lower in about half a minute.

The third solution (best), in addition to using the same pruning in better, uses the Cont monad to construct an escape continuation. Instead of appending all intermediate values and checking for the best candidate at the end, if best finds that the target value has been constructed, it immediately aborts the search indicating that the target has been met.

All three functions have the same signature, and so can be interchanged as desired in the main function.

Edit: I've added an efficient backtracking search. It has roughly the same performance as the exit continuation search.

module Main where
import Control.Monad
import Control.Monad.Cont
import Control.Monad.Instances
import Data.Ord
import Data.List
import Data.Ratio
import System

naive, better, best :: Rational -> [Rational] -> Rational

naive t l = minimumBy (comparing $ abs . subtract t) $ naive' l
 where
 naive' []    = []
 naive' l@[x] = l
 naive' l     = l ++ concat [ naive' . filter (/= 0) $ (f x y) : (l \\ [x, y])
                              | x <- l, y <- delete x l, f <- [(+),(-),(/),(*)] ]

better t l = minimumBy (comparing $ abs . subtract t) $ better' l l
 where
 better' _ []    = []
 better' _ l@[x] = l
 better' s l     = l ++ concat (search better' s l)

best t l = runCont (callCC $ \c -> 
            minimumBy (comparing $ abs . subtract t) `liftM` best' c l l) id
 where
 best' _   _ []     = return []
 best' esc s l
    | any (t==) l   = esc t
    | null (tail l) = return l
    | otherwise     = liftM ((head l:) . concat) . sequence $ search (best' esc) s l

backtrack t l = head $ bt l l
 where
 bt _ []    = error "Null input" -- we shouldn't get here
 bt s l
    | head l == t   = [t]        -- prune if we've found the answer
    | null (tail l) = l
    | otherwise     = choose . (head l:) . concat $ search bt s l
 -- At each branch point, choose finds the best generated solution,
 -- potentially exiting early if the target is found.
 choose (x:y:zs)
    | x == t                    = [t]
    | abs (x - t) < abs (y - t) = choose (x:zs)
    | otherwise                 = choose (y:zs)
 choose l                       = l

search f s l = do p@[x, y] <- pick 2 l
                  let l'   = l \\ p
                      next = filter (`notElem` s)
                               . filter ((==1) . denominator)
                               . filter (> 0)
                               . nub
                               $ [ x*y, x+y, x-y, y-x, x/y, y/x ]
                      s'   = next ++ s
                  map (f s') . map (:l') $ next

pick 0  _     = [[]]
pick _ []     = []
pick n (x:xs) = map (x:) (pick (n-1) xs) ++ pick n xs

main = do (t:l) <- map ((%1) . read) `fmap` getArgs
          print . numerator $ best t l