Tuesday, June 26, 2007

Search in Haskell

I've been playing around today with search in Haskell, and besides from some overly technical papers and a confusing explanation on the YAHT wiki book, I haven't found anything useful. So I though I'd put up what I could figure out.

First, let's use type classes to get some modularity. Search can be over trees or graphs or whatever, basically we just need states and a function to give us the children of a node. We also are going need to compare states to check if we have reached the goal.

> class (Ord a) => SearchState a where
> children :: a -> [a]

For instance, let's say we are trying to solve the numeric maze given in the haskell wiki. In this problem our state is just an integer.

> newtype NumMaze = NumMaze Integer deriving (Show, Eq, Ord)

And here is the instantiation. Our operations to generate children are (x+2), (x*2), (x/2). So

> instance SearchState NumMaze where
> children (NumMaze n) =
> map NumMaze $
> [n+2, n*2]++[n `div` 2 | 2 `divides` n]
> where divides a b = b `mod` a == 0

Now we can write very generic functions for the search operations. We'll start with a monadic depth first search. Depth first search is very natural for functional programming (if we don't worry about blowing the stack). We dive in with recursion. There is good explanation of this on the haskell wikibook here. Instead of using a graph, we use our search state and simplify the code by using a fold.

> dfs :: (SearchState a,MonadPlus m) => a -> a -> m[a]
> dfs start target
> | start == target = return [start]
> | otherwise =
> foldr mplus mzero $
> [ dfs c target >>= \path -> return (start:path)) |
> c <- children start] The code has two cases. If we have reached the goal, it returns a list of success with the result. Otherwise, in the list comprehension it tries searching each child. If it finds a successful path, it adds it returns it. You might wonder where we handle failure. If there are no children, the fold returns mzero which will propagate failure to its parents. When the parent gets a failure, mplus will try a different path, and we have backtracking. Next we'll try breadth first search. Here is one way to do it by passing a queue as an accumulator. > bfs :: (SearchState a,Monad m) => a -> a -> m [a]
> bfs start target = bfs' [[start]] >>= return . reverse
> where
> bfs' [] = fail "No Path"
> bfs' ((s:r):ns)
> | s == target = return (s:r)
> | otherwise = bfs' (ns ++[c:s:r |c<-children s]) We can make this faster by adding a set to keep track of states that we have already visited. > import Data.Set (empty, notMember, union, fromList)

> bfs2 :: (SearchState a,Monad m) => a -> a -> m [a]
> bfs2 start target = bfs' [[start]] empty >>= return .reverse
> where
> bfs' [] _ = fail "No Path"
> bfs' ((s:r):ns) seen
> | s == target = return (s:r)
> | otherwise = bfs' (ns ++new') seen'
> where
> new' = [c:s:r|
> c <- children s, > c `notMember` seen]
> seen' = seen `union` (fromList $ map head new')

So these functions are nice, and they are how I would write them in O'Caml. But they just feel too ugly for haskell. I know, I'm getting spoiled. So I thought I would give a shot at a lazier version. The rest of this entry is my very basic understanding of the Functional Pearl Breadth-First Combinators.

First, depth first search. I visualize it like this. Imagine, that the states form a tree, and we want to first transform the tree to a stream, and then process it linearly. Haskell makes this absurdly easy. First, imagine that we can linearize all the children searches. This gives us a matrix-like list of streams (since we are doing DFS, we hope they are not infinite, but that does not break the formulation) i.e.

[[Child1, Child1.1, Child1.2 ...],
[Child2, Child2.1, ...],
...
]

Since this is DFS, we want to explore these in order. This means all we need to do in concat them, and we have the full traversal. Bam!

> lazyDFT :: (SearchState a) => a -> [a]
> lazyDFT start = start : (concat $ map lazyDFT $ children start)

In the paper they call this the "and" operator for logical combination.

Now, what about Breadth-first search. Well we want to move one level at a time instead of following a single path to its end. If we know that our tree is balanced, we can simply transpose the matrix and then take the concat

[[Child1, Child1.1, Child1.2 ...],
[Child2, Child2.1, ...],
...
]
-->
[[Child1, Child2, Child3 ...],
[Child1.1, Child2.1, ...],
...
]

Here is the code using Data.List's lazy transpose function.

> lazyBFTBal :: (SearchState a) => a -> [a]
> lazyBFTBal start =
> start:(concat $ transpose $ map lazyBFTBal $ children start)

Hmm... Not sure the best way to proceed here. In all honesty, I find the rest of the combinators paper to be a bit confusing to say the least, but I'll try to fake it. I want to make sure I traverse the tree in order, so I'll preserve the order at each level. The new type signature is .

lazyBFT :: (SearchState a) => a -> [[a]]

and the matrix looks like,

[[[Child1], [Child1.1, Child1.2] ...],
[[Child2], [Child2.1], [Child2.1.1]],
...
]
transposed to
[[[Child1], [Child2] ...],
[[Child1.1, Child1.2], [Child2.1],...],
[ [Child2.1.1],..]
...
]

and then we concat each row,

[[Child1,Child2,...], [Child1.1,Child1.2],[Child2.1.1]]

Score! Back to where we started.

The code looks like,

> lazyBFT start = [start]:(map concat $ transpose $ map lazyBFT $ children start)

If I use it on the problem we started with yields.

*Main> take 3 $ lazyBFT (NumMaze 10)
[[NumMaze 10],[NumMaze 12,NumMaze 5,NumMaze 20],[NumMaze 14,NumMaze 6,NumMaze 24,NumMaze 7,NumMaze 10,NumMaze 22,NumMaze 10,NumMaze 40]]

Now lets add some of the pruning back.

> lazyBFT2 seen start = [start]:(map concat $ transpose $ map (lazyBFT2 seen') $ c)
> where c = [c| c <- children start , c `notMember` seen] > seen' = seen `union` (fromList c)

*Main> take 3 $ lazyBFT2 (singleton $ NumMaze 10) (NumMaze 10)
[[NumMaze 10],[NumMaze 12,NumMaze 5,NumMaze 20],[NumMaze 14,NumMaze 6,NumMaze 24,NumMaze 7,NumMaze 22,NumMaze 40]]



Okay, I'll stop here for now. Pretty cool stuff. I wonder, is there is a lazy way to do this pruning? Maybe next post...

No comments: