# Haskell Quiz/Countdown/Solution Dolio

### From HaskellWiki

(added backtracking search) |
(sharpen cat) |
||

Line 78: | Line 78: | ||

</haskell> |
</haskell> |
||

− | [[Category:Code]] |
+ | [[Category:Haskell Quiz solutions|Countdown]] |

## Revision as of 10:46, 13 January 2007

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 (not . flip elem 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