-- Simple back-tracking search with delimited control -- Illustrating shift/reset, and the application of different search -- strategies to the same program without re-writing it module Searches where import Control.Monad.Cont hiding (mplus) import System.Environment (getArgs) -- Lazy search tree -- which is the result of a non-deterministic expression. -- Thunks are important to _prevent_ memoization so that we -- could examine the tree several times without fully expanding it. -- Iterative deepening below critically relies on that property. data SearchTree a = Leaf a | Node [() -> SearchTree a] -- Different search strategies can be implemented as operations -- on the search tree. -- Depth-first search dfs :: SearchTree a -> [a] dfs (Leaf x) = [x] dfs (Node b) = concatMap (\x -> dfs $ x ()) b -- Breadth-first search bfs :: SearchTree a -> [a] bfs tree = loop [\() -> tree] where loop [] = [] loop (h:t) = case h () of Leaf x -> x : loop t Node b -> loop (t ++ b) -- Iterative deepening -- It should be obvious that the code repeatedly expands the nodes -- of the tree as it examines the tree deeper and deeper. -- One is tempted to eliminate the repetition (e.g., by changing -- the SearchTree declaration to take advantage of GHC's memoization). -- However, that will miss the point: re-evaluating the same -- expressions (nodes) over and over again is the essence of -- iterative deepening. The algorithm trades time for space: -- for very large search trees, it is overall better to recompute the -- nodes than to store them. -- The algorithm is complete, like BFS -- it always finds a solution if one -- exists -- and yet is memory-efficient as DFS. -- BFS takes so much memory, to store the frontier of the search, -- that it becomes impractical for even the moderate toy problems. -- Collect the values from the leaves whose distance from -- the root is exactly d. -- Return Nothing if d is greater than the depth of the tree -- The clause `depth_search d (Node [])' proved very useful: -- It plugs the memory leak. depth_search :: Int -> SearchTree a -> Maybe [a] depth_search 0 (Leaf x) = Just [x] depth_search d (Leaf _) = Nothing depth_search d (Node [])= Nothing depth_search 0 (Node _) = Just [] depth_search d (Node b) = foldr (\t a -> join (depth_search (d-1) (t ())) a) Nothing b where join x Nothing = x join Nothing x = x join (Just l1) (Just l2) = Just (l1 ++ l2) iter_deepening :: SearchTree a -> [a] iter_deepening t = loop 0 where loop d = check d (depth_search d t) check d Nothing = [] check d (Just l) = l ++ loop (d+1) -- Other search strategies can be added easily. -- Reifying a non-deterministic program as a search tree -- Notably we do _not_ use SearchTree itself as a monad -- Defining shift/reset in terms of Cont runC :: Cont w w -> w runC m = runCont m id reset :: Cont a a -> Cont w a reset = return . runC shift :: ((a -> w) -> Cont w w) -> Cont w a shift f = Cont (runC . f) -- Non-deterministic choice from a _finite_ list -- This is the only primitive. Everything else is implemented in terms -- of choose choose :: [a] -> Cont (SearchTree w) a choose lst = shift (\k -> return $ Node (map (\x () -> k x) lst)) -- Failing computation failure :: Cont (SearchTree w) a failure = choose [] -- How to run non-deterministic computation reify :: Cont (SearchTree a) a -> SearchTree a reify m = runC (fmap Leaf m) -- With Cont and reification, we separate the vexing issues of the search -- strategy from constructing a computation. -- Examples: computing Pythagorean triples ex1 = reify $ do x <- choose [1..10] y <- choose [1..10] z <- choose [1..10] if x*x + y*y == z*z then return (x,y,z) else failure test1d = dfs ex1 -- [(3,4,5),(4,3,5),(6,8,10),(8,6,10)] test1b = bfs ex1 -- the same, but takes 8 times more memory test1i = iter_deepening ex1 -- about as much memory as DFS -- Non-deterministic choice from a potentially _infinite_ list -- First, we define mplus to join two computations together. -- We define mplus in terms of choose mplus :: Cont (SearchTree w) a -> Cont (SearchTree w) a -> Cont (SearchTree w) a -- mplus e1 e2 = choose [e1,e2] >>= id -- or we may inline choose and simplify a bit: mplus e1 e2 = shift (\f -> return $ Node [\ () -> runCont (e1 >>= return . f) id, \ () -> runCont (e2 >>= return . f) id]) -- We may further hand-optimize that expression to the following. -- But it leaks memory! It retains the constructed tree -- mplus e1 e2 = Cont (\k -> Node [\() -> runCont e1 k, -- \() -> runCont e2 k]) -- See an article on preventing memoization in search problems. -- Generally speaking, mplus is not associative. It better not be, -- since associative and non-commutative mplus makes the search -- strategy incomplete. -- Consider -- e1 `mplus` return False >>= (\x -> if x then mzero else return x) -- where e1 = return True `mplus` e1 -- If mplus is associative and non-commutative, the search will diverge -- although a solution exists -- We can now define the general choice choose' [] = failure choose' [x] = return x choose' (h:t) = return h `mplus` (choose' t) -- A stream of numbers, more efficient that choose' [1..] from i = choose [return i, from $! i + 1] >>= id -- Pythagorean triples from the range of numbers ex2 range = reify $ do x <- choose' range y <- choose' range z <- choose' range if x*x + y*y == z*z then return (x,y,z) else failure -- Finite range test2d = dfs $ ex2 [1..10] -- [(3,4,5),(4,3,5),(6,8,10),(8,6,10)] test2b = bfs $ ex2 [1..10] -- Infinite range -- DFS expectedly diverges, but BFS and iterative deepening give -- solutions; iterative deepening takes much less memory than BFS. test3d = take 5 . dfs $ ex2 [1..] -- diverges!! test3b = take 5 . bfs $ ex2 [1..] -- [(3,4,5),(4,3,5),(6,8,10),(8,6,10),(5,12,13)] test3i = take 5 . iter_deepening $ ex2 [1..] -- [(3,4,5),(4,3,5),(6,8,10),(8,6,10),(5,12,13)] -- Compiling it: -- ghc -O2 -rtsopts -main-is Searches.main Searches.hs -- To run this code -- GHCRTS="-tstderr" ./Searches bfs 30 -- GHCRTS="-tstderr" ./Searches iter 30 ex3 = reify $ do x <- from 1 y <- from 1 z <- from 1 if x*x + y*y == z*z then return (x,y,z) else failure main :: IO () main = getArgs >>= check where check [key,ns] | [(n,"")] <- reads ns = print $ take n . select key $ ex3 select "bfs" = bfs select "iter" = iter_deepening {- ./Searches bfs 30 +RTS -tstderr [(3,4,5),(4,3,5),(6,8,10),(8,6,10),(5,12,13),(12,5,13),(9,12,15),(12,9,15),(8,15,17),(15,8,17),(12,16,20),(16,12,20),(7,24,25),(24,7,25),(10,24,26),(15,20,25),(20,15,25),(24,10,26),(20,21,29),(21,20,29),(18,24,30),(24,18,30),(16,30,34),(30,16,34),(12,35,37),(21,28,35),(28,21,35),(35,12,37),(9,40,41),(15,36,39)] <> ./Searches iter 30 +RTS -tstderr [(3,4,5),(4,3,5),(6,8,10),(8,6,10),(5,12,13),(12,5,13),(9,12,15),(12,9,15),(8,15,17),(15,8,17),(12,16,20),(16,12,20),(7,24,25),(24,7,25),(10,24,26),(15,20,25),(20,15,25),(24,10,26),(20,21,29),(21,20,29),(18,24,30),(24,18,30),(16,30,34),(30,16,34),(12,35,37),(21,28,35),(28,21,35),(35,12,37),(9,40,41),(15,36,39)] <> ./Searches iter 100 +RTS -tstderr [(3,4,5),(4,3,5),(6,8,10),(8,6,10),(5,12,13),(12,5,13),(9,12,15),(12,9,15),(8,15,17),(15,8,17),(12,16,20),(16,12,20),(7,24,25),(24,7,25),(10,24,26),(15,20,25),(20,15,25),(24,10,26),(20,21,29),(21,20,29),(18,24,30),(24,18,30),(16,30,34),(30,16,34),(12,35,37),(21,28,35),(28,21,35),(35,12,37),(9,40,41),(15,36,39),(36,15,39),(40,9,41),(24,32,40),(32,24,40),(27,36,45),(36,27,45),(14,48,50),(48,14,50),(20,48,52),(24,45,51),(30,40,50),(40,30,50),(45,24,51),(48,20,52),(28,45,53),(45,28,53),(11,60,61),(33,44,55),(44,33,55),(60,11,61),(40,42,58),(42,40,58),(16,63,65),(36,48,60),(48,36,60),(63,16,65),(25,60,65),(60,25,65),(33,56,65),(56,33,65),(39,52,65),(52,39,65),(32,60,68),(60,32,68),(21,72,75),(24,70,74),(42,56,70),(56,42,70),(70,24,74),(72,21,75),(48,55,73),(55,48,73),(18,80,82),(30,72,78),(45,60,75),(60,45,75),(72,30,78),(80,18,82),(13,84,85),(84,13,85),(48,64,80),(64,48,80),(36,77,85),(77,36,85),(40,75,85),(75,40,85),(51,68,85),(68,51,85),(39,80,89),(80,39,89),(35,84,91),(60,63,87),(63,60,87),(84,35,91),(54,72,90),(72,54,90),(20,99,101),(99,20,101),(28,96,100),(96,28,100)] <> -}