Dear all, there is this neat "one-line" BFS implementation bfs :: Eq a => ( a -> [a] ) -> a -> [a] bfs next start = let xs = nub $ start : ( xs >>= next ) in xs but it has a problem: it only works for infinite graphs. This is fine: take 20 $ bfs ( \ x -> [2*x, x+1] ) 1 but this is not: take 20 $ bfs ( \ x -> filter (>0) [ div x 2, x - 1 ] ) 10 Is there a nice way to repair this? (I know how to code a BFS but here I'm asking for a one-liner.) J. W.
On Mon, Mar 22, 2010 at 11:02:32AM +0100, Johannes Waldmann wrote:
Dear all, there is this neat "one-line" BFS implementation
bfs :: Eq a => ( a -> [a] ) -> a -> [a] bfs next start = let xs = nub $ start : ( xs >>= next ) in xs
but it has a problem: it only works for infinite graphs. This is fine:
take 20 $ bfs ( \ x -> [2*x, x+1] ) 1
but this is not:
take 20 $ bfs ( \ x -> filter (>0) [ div x 2, x - 1 ] ) 10
Is there a nice way to repair this?
bfs :: (a -> [a]) -> a -> [a] bfs f s = concat $ takeWhile (not . null) $ iterate (>>= f) [s]
On Mon, Mar 22, 2010 at 10:30:32AM +0000, Johannes Waldmann wrote:
Nice! - Where's the 'nub'?
A bit longer: bfs :: Eq a => (a -> [a]) -> a -> [a] bfs f s = concat $ takeWhile (not . null) $ map snd $ iterate step ([], [s]) where step (seen, xs) = let seen' = xs++seen in (seen', nub $ [y | x <- xs, y <- f x, notElem y seen'])
Ross Paterson wrote:
On Mon, Mar 22, 2010 at 10:30:32AM +0000, Johannes Waldmann wrote:
Nice! - Where's the 'nub'?
A bit longer:
bfs :: Eq a => (a -> [a]) -> a -> [a] bfs f s = concat $ takeWhile (not . null) $ map snd $ iterate step ([], [s]) where step (seen, xs) = let seen' = xs++seen in (seen', nub $ [y | x <- xs, y <- f x, notElem y seen'])
Basically the same idea: bfs next start = let go _ [] = [] go xs ys = let zs = nub (ys >>= next) \\ xs in ys ++ go (zs ++ xs) zs in go [start] [start] A slightly different approach is to add stage markers to the produced streams, say bfs next start = let xs = nub $ Left 0 : Right s : (xs >>= next') next' (Left n) = [Left (n + 1)] next' (Right s) = map Right (next s) stop (Left _ : Left _ : _) = [] stop (Left x : xs) = stop xs stop (Right x : xs) = x : stop xs in stop xs or bfs next start = lefts . takeWhile (not . null) . unfoldr (Just . span (either (const False) (const True)) . tail) $ fix (nub . (Left 0 :) . (Right start :) . (>>= either ((:[]) . Left . succ) (map Right . next))) This has the advantage that nub can be used directly. But it's far from beautiful. regards, Bertram
Bertram Felgenhauer wrote:
or bfs next start = lefts . takeWhile (not . null)
I copied the wrong version. This should be bfs next start = rights . concat . takeWhile (not . null) -- rest unchanged . unfoldr (Just . span (either (const False) (const True)) . tail) $ fix (nub . (Left 0 :) . (Right start :) . (>>= either ((:[]) . Left . succ) (map Right . next))) Bertram
A bit closer to the original: bfs :: Eq a => (a -> [a]) -> a -> [a] bfs f s = concat $ takeWhile (not . null) levels where levels = foldr trim [] $ [s] : map (nub . (>>= f)) levels trim xs xss = xs : map (\\ xs) xss
Johannes Waldmann wrote:
Dear all, there is this neat "one-line" BFS implementation
bfs :: Eq a => ( a -> [a] ) -> a -> [a] bfs next start = let xs = nub $ start : ( xs >>= next ) in xs
but it has a problem: it only works for infinite graphs. This is fine:
take 20 $ bfs ( \ x -> [2*x, x+1] ) 1
but this is not:
take 20 $ bfs ( \ x -> filter (>0) [ div x 2, x - 1 ] ) 10
Is there a nice way to repair this? (I know how to code a BFS but here I'm asking for a one-liner.)
There is a neat trick to handle the finite case which I first read about in Leon P. Smith's article Lloyd Allison’s Corecursive Queues: Why Continuations Matter. http://themonadreader.wordpress.com/2009/07/29/issue-14/ Namely, you have to keep track of the "current" queue size so that the program doesn't hang when the queue becomes empty: bfs' f x = let xs = more 1 (x:xs) in x:xs where more 0 _ = [] more n (x:xs) = f x ++ more (n + length (f x) - 1) xs Unfortunately, this cannot be made to work with nub because that would screw up the size calculation. Regards, Heinrich Apfelmus -- http://apfelmus.nfshost.com
participants (4)
-
Bertram Felgenhauer -
Heinrich Apfelmus -
Johannes Waldmann -
Ross Paterson