I am reading this paper by Chris Okasaki; titled "Breadth-First Numbering: Lessons from a Small Exercise in Algorithm Design".
A question is - how is the magic happening in the algorithm? There are some figures (e.g. figure 7 titled "threading the output of one level into the input of next level")
Unfortunately, maybe it's only me, but that figure has completely baffled me. I don't understand how the threading happens at all?
Breadth first traversal means traversing levels of a tree one by one. So let's assume we already know what are the numbers at the beginning of each level - the number of traversed elements so far before each level. For the simple example in the paper
import Data.Monoid
data Tree a = Tree (Tree a) a (Tree a)
| Empty
deriving (Show)
example :: Tree Char
example = Tree (Tree Empty 'b' (Tree Empty 'c' Empty)) 'a' (Tree Empty 'd' Empty)
the sizes would be 0, 1, 3, 4. Knowing this, we can thread such a list of sizes through a give tree (sub-tree) left-to-right: We advance the first element of the list by one for the node, and thread the tail of the list first through the left and then through the right subtree (see thread below).
After doing so, we'll get again the same list of sizes, only shifted by one - now we have the total number of elements after each level. So the trick is: Assume we have such a list, use it for the computation, and then feed the output as the input - tie the knot.
A sample implementation:
tagBfs :: (Monoid m) => (a -> m) -> Tree a -> Tree m
tagBfs f t = let (ms, r) = thread (mempty : ms) t
in r
where
thread ms Empty = (ms, Empty)
thread (m : ms) (Tree l x r) =
let (ms1, l') = thread ms l
(ms2, r') = thread ms1 r
in ((m <> f x) : ms2, Tree l' m r')
generalized to Monoid (for numbering you'd give const $ Sum 1 as the function).
One way to view tree numbering is in terms of a traversal. Specifically, we want to traverse the tree in breadth-first order using State to count up. The necessary Traversable instance looks something like this. Note that you'd probably actually want to define this instance for a newtype like BFTree, but I'm just using the raw Tree type for simplicity. This code is strongly inspired by ideas in Cirdec's monadic rose tree unfolding code, but the situation here seems to be substantially simpler. Hopefully I haven't missed something horrible.
{-# LANGUAGE DeriveFunctor,
GeneralizedNewtypeDeriving,
LambdaCase #-}
{-# OPTIONS_GHC -Wall #-}
module BFT where
import Control.Applicative
import Data.Foldable
import Data.Traversable
import Prelude hiding (foldr)
data Tree a = Tree (Tree a) a (Tree a)
| Empty
deriving (Show, Functor)
newtype Forest a = Forest {getForest :: [Tree a]}
deriving (Functor)
instance Foldable Forest where
foldMap = foldMapDefault
-- Given a forest, produce the forest consisting
-- of the children of the root nodes of non-empty
-- trees.
children :: Forest a -> Forest a
children (Forest xs) = Forest $ foldr go [] xs
where
go Empty c = c
go (Tree l _a r) c = l : r : c
-- Given a forest, produce a list of the root nodes
-- of the elements, with `Nothing` values in place of
-- empty trees.
parents :: Forest a -> [Maybe a]
parents (Forest xs) = foldr go [] xs
where
go Empty c = Nothing : c
go (Tree _l a _r) c = Just a : c
-- Given a list of values (mixed with blanks) and
-- a list of trees, attach the values to pairs of
-- trees to build trees; turn the blanks into `Empty`
-- trees.
zipForest :: [Maybe a] -> Forest a -> [Tree a]
zipForest [] _ts = []
zipForest (Nothing : ps) ts = Empty : zipForest ps ts
zipForest (Just p : ps) (Forest ~(t1 : ~(t2 : ts'))) =
Tree t1 p t2 : zipForest ps (Forest ts')
instance Traversable Forest where
-- Traversing an empty container always gets you
-- an empty one.
traverse _f (Forest []) = pure (Forest [])
-- First, traverse the parents. The `traverse.traverse`
-- gets us into the `Maybe`s. Then traverse the
-- children. Finally, zip them together, and turn the
-- result into a `Forest`. If the `Applicative` in play
-- is lazy enough, like lazy `State`, I believe
-- we avoid the double traversal Okasaki mentions as
-- a problem for strict implementations.
traverse f xs = (Forest .) . zipForest <$>
(traverse.traverse) f (parents xs) <*>
traverse f (children xs)
instance Foldable Tree where
foldMap = foldMapDefault
instance Traversable Tree where
traverse f t =
(\case {(Forest [r]) -> r;
_ -> error "Whoops!"}) <$>
traverse f (Forest [t])
Now we can write code to pair up each element of the tree with its breadth-first number like this:
import Control.Monad.Trans.State.Lazy
numberTree :: Tree a -> Tree (Int, a)
numberTree tr = flip evalState 1 $ for tr $ \x ->
do
v <- get
put $! (v+1)
return (v,x)
Related
I have the following code to do an inorder traversal of a Binary Tree:
data BinaryTree a =
Node a (BinaryTree a) (BinaryTree a)
| Leaf
deriving (Show)
inorder :: (a -> b -> b) -> b -> BinaryTree a -> b
inorder f acc tree = go tree acc
where go Leaf z = z
go (Node v l r) z = (go r . f v . go l) z
Using the inorder function above I'd like to get the kth element without having to traverse the entire list.
The traversal is a little like a fold given that you pass it a function and a starting value. I was thinking that I could solve it by passing k as the starting value, and a function that'll decrement k until it reaches 0 and at that point returns the value inside the current node.
The problem I have is that I'm not quite sure how to break out of the recursion of inorder traversal short of modifying the whole function, but I feel like having to modify the higher order function ruins the point of using a higher order function in the first place.
Is there a way to break after k iterations?
I observe that the results of the recursive call to go on the left and right subtrees are not available to f; hence no matter what f does, it cannot choose to ignore the results of recursive calls. Therefore I believe that inorder as written will always walk over the entire tree. (edit: On review, this statement may be a bit strong; it seems f may have a chance to ignore left subtrees. But the point basically stands; there is no reason to elevate left subtrees over right subtrees in this way.)
A better choice is to give the recursive calls to f. For example:
anyOldOrder :: (a -> b -> b -> b) -> b -> BinaryTree a -> b
anyOldOrder f z = go where
go Leaf = z
go (Node v l r) = f v (go l) (go r)
Now when we write
flatten = anyOldOrder (\v ls rs -> ls ++ [v] ++ rs) []
we will find that flatten is sufficiently lazy:
> take 3 (flatten (Node 'c' (Node 'b' (Node 'a' Leaf Leaf) Leaf) undefined))
"abc"
(The undefined is used to provide evidence that this part of the tree is never inspected during the traversal.) Hence we may write
findK k = take 1 . reverse . take k . flatten
which will correctly short-circuit. You can make flatten slightly more efficient with the standard difference list technique:
flatten' t = anyOldOrder (\v l r -> l . (v:) . r) id t []
Just for fun, I also want to show how to implement this function without using an accumulator list. Instead, we will produce a stateful computation which walks over the "interesting" part of the tree, stopping when it reaches the kth element. The stateful computation looks like this:
import Control.Applicative
import Control.Monad.State
import Control.Monad.Trans.Maybe
kthElem k v l r = l <|> do
i <- get
if i == k
then return v
else put (i+1) >> r
Looks pretty simple, hey? Now our findK function will farm out to kthElem, then do some newtype unwrapping:
findK' k = (`evalState` 1) . runMaybeT . anyOldOrder (kthElem 3) empty
We can verify that it is still as lazy as desired:
> findK' 3 $ Node 'c' (Node 'b' (Node 'a' Leaf Leaf) Leaf) undefined
Just 'c'
There are (at least?) two important generalizations of the notion of folding a list. The first, more powerful, notion is that of a catamorphism. The anyOldOrder of Daniel Wagner's answer follows this pattern.
But for your particular problem, the catamorphism notion is a bit more power than you need. The second, weaker, notion is that of a Foldable container. Foldable expresses the idea of a container whose elements can all be mashed together using the operation of an arbitrary Monoid. Here's a cute trick:
{-# LANGUAGE DeriveFoldable #-}
-- Note that for this trick only I've
-- switched the order of the Node fields.
data BinaryTree a =
Node (BinaryTree a) a (BinaryTree a)
| Leaf
deriving (Show, Foldable)
index :: [a] -> Int -> Maybe a
[] `index` _ = Nothing
(x : _) `index` 0 = Just x
(_ : xs) `index` i = xs `index` (i - 1)
(!?) :: Foldable f => Int -> f a -> Maybe a
xs !? i = toList xs `index` i
Then you can just use !? to index into your tree!
That trick is cute, and in fact deriving Foldable is a tremendous convenience, but it won't help you understand anything. I'll start by showing how you can define treeToList fairly directly and efficiently, without using Foldable.
treeToList :: BinaryTree a -> [a]
treeToList t = treeToListThen t []
The magic is in the treeToListThen function. treeToListThen t more converts t to a list and appends the list more to the end of the result. This slight generalization turns out to be all that's required to make conversion to a list efficient.
treeToListThen :: BinaryTree a -> [a] -> [a]
treeToListThen Leaf more = more
treeToListThen (Node v l r) more =
treeToListThen l $ v : treeToListThen r more
Instead of producing an inorder traversal of the left subtree and then appending everything else, we tell the left traversal what to stick on the end when it's done! This avoids the potentially serious inefficiency of repeated list concatenation that can turn things O(n^2) in bad cases.
Getting back to the Foldable notion, turning things into lists is a special case of foldr:
toList = foldr (:) []
So how can we implement foldr for trees? It ends up being somewhat similar to what we did with toList:
foldrTree :: (a -> b -> b) -> b -> BinaryTree a -> b
foldrTree _ n Leaf = n
foldrTree c n (Node v l r) = foldrTree c rest l
where
rest = v `c` foldrTree c n r
That is, when we go down the left side, we tell it that when it's done, it should deal with the current node and its right child.
Now foldr isn't quite the most fundamental operation of Foldable; that is actually
foldMap :: (Foldable f, Monoid m)
=> (a -> m) -> f a -> m
It is possible to implement foldr using foldMap, in a somewhat tricky fashion using a peculiar Monoid. I don't want to overload you with details of that right now, unless you ask (but you should look at the default definition of foldr in Data.Foldable). Instead, I'll show how foldMap can be defined using Daniel Wagner's anyOldOrder:
instance Foldable BinaryTree where
foldMap f = anyOldOrder bin mempty where
bin lres v rres = lres <> f v <> rres
Recently, I've asked a question for building DFS tree from Graph in Stackoverflow and had learned that it can be simply implemented by using State Monad.
DFS in haskell
While DFS requires to track only visited nodes, so that we can use 'Set' or 'List' or some sort of linear data structure to track visited nodes, BFS requires 'visited node' and 'queue' data structure to be accomplished.
My pseudocode for BFS is
Q = empty queue
T = empty Tree
mark all nodes except u as unvisited
while Q is nonempty do
u = deq(Q)
for each vertex v ∈ Adj(u)
if v is not visited
then add edge (u,v) to T
Mark v as visited and enq(v)
As can be inferred from pseudocode, we only have to do 3 processes per iteration.
dequeue point from queue
add all unvisited neighbors of the point to current tree's child, queue and 'visited' list
repeat this for next in queue
Since we are not using recursive traversal for BFS search, we need some other traversal method such as while loop. I've looked up loop-while package in hackage, but it seems somewhat deprecated.
What I assume is that I require some sort of code like this :
{-...-}
... = evalState (bfs) ((Set.singleton start),[start])
where
neighbors x = Map.findWithDefault [] x adj
bfs =do (vis,x:queue)<-get
map (\neighbor ->
if (Set.member neighbor vis)
then put(vis,queue)
else put ((Set.insert neighbor vis), queue++[neighbor]) >> (addToTree neighbor)
) neighbors x
(vis,queue)<-get
while (length queue > 0)
I understand that this implementation is very erroneous but this should give minimalistic view for how I think BFS should be implemented. Also, I really don't know how to circumvent using while loop for do blocks.(i.e should I use recursive algorithm to overcome it or should I think of completely different strategy)
Considering one of the answer I've found in previous question linked above, it seems like the answer should look like this :
newtype Graph a = Graph (Map.Map a [a]) deriving (Ord, Eq, Show)
data Tree a = Tree a [Tree a] deriving (Ord, Eq, Show)
bfs :: (Ord a) => Graph a -> a -> Tree a
bfs (Graph adj) start = evalState (bfs') ((Set.singleton start),[start])
where
bfs' = {-part where I don't know-}
Finally, if such implementation for BFS using state monad is impossible due to some reason, (which I believe not to be) please correct my false assumption.
I've seen some of the examples for BFS in Haskell without using state monad but I want to learn more about how state monad can be processed and couldn't have found any of examples of BFS implemented using state monad.
Thanks in advance.
EDIT:
I came up with some sort of algorithm using state monad but I fall in infinite loop.
bfs :: (Ord a) => Graph a -> a -> Tree a
bfs (Graph adj) start = evalState (bfs' (Graph adj) start) (Set.singleton start)
bfs' :: (Ord a) => Graph a -> a -> State (Set.Set a) (Tree a)
bfs' (Graph adj) point= do
vis <- get
let neighbors x = Map.findWithDefault [] x adj
let addableNeighbors (x:xs) = if Set.member x vis
then addableNeighbors(xs)
else x:addableNeighbors(xs)
let addVisited (vis) (ns) = Set.union (vis) $ Set.fromList ns
let newVisited = addVisited vis $ addableNeighbors $ neighbors point
put newVisited
return (Tree point $ map (flip evalState newVisited) (map (bfs' (Graph adj)) $ addableNeighbors $ neighbors point))
EDIT2: With some expense of space complexity, I've came out with a solution to get BFS graph using graph to return and queue to process. Despite it is not the optimal solution for generating BFS tree/graph, it will work.
bfs :: (Ord a) => Graph a -> a -> Graph a
bfs (Graph adj) start = evalState (bfs' (Graph adj) (Graph(Map.empty)) [start]) (Set.singleton start)
bfs':: (Ord a) => Graph a -> Graph a -> [a] -> State (Set.Set a) (Graph a)
bfs' _ (Graph ret) [] = return (Graph ret)
bfs' (Graph adj) (Graph ret) (p:points)= do
vis <- get
let neighbors x = Map.findWithDefault [] x adj
let addableNeighbors ns
| null ns = []
| otherwise = if Set.member (head ns) vis
then addableNeighbors(tail ns)
else (head ns):addableNeighbors(tail ns)
let addVisited (v) (ns) = Set.union (v) $ Set.fromList ns
let unVisited = addableNeighbors $ neighbors p
let newVisited = addVisited vis unVisited
let unionGraph (Graph g1) (Graph g2) = Graph (Map.union g1 g2)
put newVisited
bfs' (Graph adj) (unionGraph (Graph ret) (Graph (Map.singleton p unVisited))) (points ++ unVisited)
EDIT3: I've added convert function for graph to tree. Running function in EDIT2, and EDIT3 will yield BFS Tree. It is not the best algorithm for computation time wise, but I believe it is intuitive and easy to understand for newbies like me :)
graphToTree :: (Ord a) => Graph a -> a -> Tree a
graphToTree (Graph adj) point = Tree point $ map (graphToTree (Graph adj)) $ neighbors point
where neighbors x = Map.findWithDefault [] x adj
Converting a graph into a Tree breadth-first is a bit more difficult than simply searching the graph breadth-first. If you are searching the graph, you only ever need to return from a single branch. When converting the graph into a tree, the result needs to include results from multiple branches.
We can use a more general type than Graph a for what we can search or convert to trees. We can search or convert to trees anything with a function a -> [a]. For a Graph we'd use the function (Map.!) m, where m is the Map. Searching with a transposition table has a signature like
breadthFirstSearchUnseen:: Ord r => (a -> r) -> -- how to compare `a`s
(a -> Bool) -> -- where to stop
(a -> [a]) -> -- where you can go from an `a`
[a] -> -- where to start
Maybe [a]
Converting the function to a tree that contains each reachable node at the earliest depth has a signature like
shortestPathTree :: Ord r => (a -> r) -> -- how to compare `a`s
(a -> l) -- what label to put in the tree
(a -> [a]) -> -- where you can go from an `a`
a -> -- where to start
Tree l
We can slightly more generally start at any number of nodes and build a Forest that contains each reachable node at the earliest depth.
shortestPathTrees :: Ord r => (a -> r) -> -- how to compare `a`s
(a -> l) -- what label to put in the tree
(a -> [a]) -> -- where you can go from an `a`
[a] -> -- where to start
[Tree l]
Searching
Performing the conversion to a tree doesn't really help us search, we can perform breadth first searches on the original graph.
import Data.Sequence (viewl, ViewL (..), (><))
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
breadthFirstSearchUnseen:: Ord r => (a -> r) -> (a -> Bool) -> (a -> [a]) -> [a] -> Maybe [a]
breadthFirstSearchUnseen repr p expand = combine Set.empty Seq.empty []
where
combine seen queued ancestors unseen =
go
(seen `Set.union` (Set.fromList . map repr $ unseen))
(queued >< (Seq.fromList . map ((,) ancestors) $ unseen))
go seen queue =
case viewl queue of
EmptyL -> Nothing
(ancestors, a) :< queued ->
if p a
then Just . reverse $ ancestors'
else combine seen queued ancestors' unseen
where
ancestors' = a:ancestors
unseen = filter (flip Set.notMember seen . repr) . expand $ a
The state maintained in the above search algorithm is a Seq queue of what nodes to visit next and a Set of nodes that have already been seen. If we instead kept track of nodes that have already been visited, then we could visit the same node multiple times if we find multiple paths to the node at the same depth. There's a more complete explanation in the answer I wrote this breadth first search for.
We can easily write searching Graphs in terms of our general search.
import qualified Data.Map as Map
newtype Graph a = Graph (Map.Map a [a]) deriving (Ord, Eq, Show)
bfsGraph :: (Ord a) => Graph a -> (a -> Bool) -> [a] -> Maybe [a]
bfsGraph (Graph adj) test = breadthFirstSearchUnseen id test ((Map.!) adj)
We can also write how to search Trees themselves.
import Data.Tree
bfsTrees :: (Ord a) => (a -> Bool) -> [Tree a] -> Maybe [a]
bfsTrees test = fmap (map rootLabel) . breadthFirstSearchUnseen rootLabel (test . rootLabel) subForest
Building trees
Building trees breadth-first is a lot more difficult. Fortunately Data.Tree already provides ways to build Trees in breadth first order from a monadic unfold. The breadth first order will take care of the queuing, we will only need to keep track of the state for the nodes we've already seen.
unfoldTreeM_BF has the type Monad m => (b -> m (a, [b])) -> b -> m (Tree a). m is the Monad our computations will be in, b is the type of data we are going to build the tree based on, and a is the type for the labels of the tree. In order to use it to build a tree we need to make a function b -> m (a, [b]). We're going to rename a to l for label, and b to a, which is what we've been using for our nodes. We need to make an a -> m (l, [a]). For m, we'll use the State monad from transformers to keep track of some state; the state will be the Set of nodes whose representation r we've already seen; we'll be using the State (Set.Set r) monad. Overall, we need to provide a function a -> State (Set.Set r) (l, [a]).
expandUnseen :: Ord r => (a -> r) -> (a -> l) -> (a -> [a]) -> a -> State (Set.Set r) (l, [a])
expandUnseen repr label expand a = do
seen <- get
let unseen = filter (flip Set.notMember seen . repr) . uniqueBy repr . expand $ a
put . Set.union seen . Set.fromList . map repr $ unseen
return (label a, unseen)
To build the trees, we run the state computation built by unfoldForestM_BF
shortestPathTrees :: Ord r => (a -> r) -> (a -> l) -> (a -> [a]) -> [a] -> [Tree l]
shortestPathTrees repr label expand = run . unfoldForestM_BF k . uniqueBy repr
where
run = flip evalState Set.empty
k = expandUnseen repr label expand
uniqueBy is a nubBy that takes advantage of an Ord instance instead of Eq.
uniqueBy :: Ord r => (a -> r) -> [a] -> [a]
uniqueBy repr = go Set.empty
where
go seen [] = []
go seen (x:xs) =
if Set.member (repr x) seen
then go seen xs
else x:go (Set.insert (repr x) seen) xs
We can write building shortest path trees from Graphs in terms of our general shortest path tree building
shortestPathsGraph :: Ord a => Graph a -> [a] -> [Tree a]
shortestPathsGraph (Graph adj) = shortestPathTrees id id ((Map.!) adj)
We can do the same for filtering a Forest to only the shortest paths through the Forest.
shortestPathsTree :: Ord a => [Tree a] -> [Tree a]
shortestPathsTree = shortestPathTrees rootLabel rootLabel subForest
My solution is based on working level-by-level (wrt. to BFS), see also this question and answer.
The general idea is: Assume we already know the sets of visited elements prior each level of our BFS as a list of sets. Then we can traverse the graph, level by level, updating our list of sets, constructing the output Tree on the way.
The trick is that after such a level-by-level traversal, we'll have the sets of visited elements after each level. And this is the same as the list before each level, just shifted by one. So by tying the knot, we can use the shifted output as the input for the procedure.
import Control.Monad.State
import qualified Data.Map as M
import Data.Maybe (fromMaybe, catMaybes)
import qualified Data.Set as S
import Data.Tree
newtype Graph a = Graph (M.Map a [a])
deriving (Ord, Eq, Show)
tagBfs :: (Ord a) => Graph a -> a -> Maybe (Tree a)
tagBfs (Graph g) s = let (t, sets) = runState (thread s) (S.empty : sets)
in t
where
thread x = do
sets#(s : subsets) <- get
case M.lookup x g of
Just vs | not (S.member x s) -> do
-- recursively create sub-nodes and update the subsets list
let (nodes, subsets') = runState
(catMaybes `liftM` mapM thread vs) subsets
-- put the new combined list of sets
put (S.insert x s : subsets')
-- .. and return the node
return . Just $ Node x nodes
_ -> return Nothing -- node not in the graph, or already visited
Running tagBfs example2 'b' it on the following example
example2 :: Graph Char
example2 = Graph $ M.fromList
[ ('a', ['b', 'c', 'd'])
, ('b', ['a'])
, ('c', [])
, ('d', [])
]
yields
Just (Node {rootLabel = 'b',
subForest = [Node {rootLabel = 'a',
subForest = [Node {rootLabel = 'c',
subForest = []},
Node {rootLabel = 'd',
subForest = []}
]}
]}
)
I was reading this mailing list post, where someone had a question about a threaded RB tree in Haskell, and the end of the response said:
I suggest you (Lex) either go imperative (with STRef or IORef) or do
without threading, unless you're sure that you'll be doing many more
lookups and traversals than inserts and deletes.
Implying that, although creating threaded trees in Haskell is generally not a good idea, it does still make lookups and traversals more efficient without resorting to imperative algorithms.
However, I can't think of a way threads could make haskell trees more efficient without using imperative constructs. Is it even possible?
However, I can't think of a way threads could make haskell trees more
efficient without using imperative constructs. Is it even possible?
Technically, exactly the same benefits that apply to an imperative threaded tree also apply to a persistent threaded tree. However, due to some extra costs of such a data structure, it's not always a practical choice.
Consider the situation where you have a tree that won't be modified, however you'll frequently need to make linear traversals (e.g. find a node and the subsequent n nodes, or a full linear traversal, etc). In an imperative language, a threaded tree can be more efficient in this case than a non-threaded tree because linear traversals can be performed directly, without keeping a stack. It should be clear that this is exactly the same case as with a persistent structure because of our assumption that the tree won't be modified, so clearly linear traversals of the threaded tree would be more efficient in the persistent structure too.
So, what are the downsides of a persistent threaded tree? First, inserts/deletes will be much more expensive than in an ordinary tree, because every node prior to the modified node will also need to be recreated. So the structure will only be beneficial when mutations are rare or nonexistent. But in that case, you're probably better off creating an array from the tree and traversing that (unless you want to lookup a starting position). So it ends up being a rather complicated data structure that would only be used in very limited circumstances. But for that very specific use case, it would be more efficient than a plain binary tree.
Edit: here's an example of how to implement a threaded binary tree purely. Implementation of deletions is left as an exercise, no attempt has been made to keep the tree balanced, and I make no promises about correctness. But after building up a Tree using Prelude.foldl Threaded.insert Threaded.empty, both Data.Foldable.toList and foldThread (:[]) return the same list, so it's probably pretty close to correct.
{-# LANGUAGE DeriveFoldable #-}
module Threaded where
import Control.Applicative
import Control.Monad
import Data.Foldable (Foldable (..))
import Data.Monoid
newtype Tree a = Tree {unTree :: Maybe (NonNullTree a) }
deriving (Eq, Foldable)
-- its a little easier to work with non-null trees.
data NonNullTree a = Bin (Link a) a (Link a)
data Link a =
Normal (NonNullTree a) -- a child branch
| Thread (NonNullTree a) -- a thread to another branch
| Null -- left child of min value, or right child of max value
-- N.B. don't try deriving type class instances, such as Eq or Show. If you derive
-- them, many of the derived functions will be infinite loops. If you want instances
-- for Show or Eq, you'll have to write them by hand and break the loops by
-- not following Thread references.
empty :: Tree a
empty = Tree Nothing
singleton :: a -> Tree a
singleton a = Tree . Just $ Bin Null a Null
instance Foldable NonNullTree where
foldMap f (Bin l a r) = mconcat [foldMap f l, f a, foldMap f r]
-- when folding, we only want to follow actual children, not threads.
-- Using this instance, we can compare with folding via threads.
instance Foldable Link where
foldMap f (Normal t) = foldMap f t
foldMap f _ = mempty
-- |find the first value in the tree >= the search term
-- O(n) complexity, we can do better!
tlookup :: Ord a => Tree a -> a -> Maybe a
tlookup tree needle = getFirst $ foldMap search tree
where
search a = if a >= needle then First (Just a) else mempty
-- | fold over the tree by following the threads. The signature matches `foldMap` for easy
-- comparison, but `foldl'` or `traverse` would likely be more common operations.
foldThread :: Monoid m => (a -> m) -> Tree a -> m
foldThread f (Tree (Just root)) = deep mempty root
where
-- descend to the leftmost child, then follow threads to the right.
deep acc (Bin l a r) = case l of
Normal tree -> deep acc tree
_ -> follow (acc `mappend` f a) r
follow acc (Normal tree) = deep acc tree
-- in this case we know the left child is a thread pointing to the
-- current node, so we can ignore it.
follow acc (Thread (Bin _ a r)) = follow (acc `mappend` f a) r
follow acc Null = acc
-- used internally. sets the left child of the min node to the 'prev0' link,
-- and the right child of the max node to the 'next0' link.
relinkEnds :: Link a -> Link a -> NonNullTree a -> NonNullTree a
relinkEnds prev0 next0 root = case go prev0 next0 root of
Normal root' -> root'
_ -> error "relinkEnds: invariant violation"
where
go prev next (Bin l a r) =
-- a simple example of knot-tying.
-- * l' depends on 'this'
-- * r' depends on 'this'
-- * 'this' depends on both l' and r'
-- the whole thing works because Haskell is lazy, and the recursive 'go'
-- function never actually inspects the 'prev' and 'next' arguments.
let l' = case l of
Normal lTree -> go prev (Thread this) lTree
_ -> prev
r' = case r of
Normal rTree -> go (Thread this) next rTree
_ -> next
this = Bin l' a r'
in Normal this
-- | insert a value into the tree, overwriting it if already present.
insert :: Ord a => Tree a -> a -> Tree a
insert (Tree Nothing) a = singleton a
insert (Tree (Just root)) a = case go Null Null root of
Normal root' -> Tree $ Just root'
_ -> error "insert: invariant violation"
where
go prev next (Bin l val r) = case compare a val of
LT ->
-- ties a knot similarly to the 'relinkEnds' function.
let l' = case l of
Normal lTree -> go prev thisLink lTree
_ -> Normal $ Bin prev a thisLink
r' = case r of
Normal rTree -> Normal $ relinkEnds thisLink next rTree
_ -> next
this = Bin l' val r'
thisLink = Thread this
in Normal this
EQ ->
let l' = case l of
Normal lTree -> Normal $ relinkEnds prev thisLink lTree
_ -> prev
r' = case r of
Normal rTree -> Normal $ relinkEnds thisLink next rTree
_ -> next
this = Bin l' a r'
thisLink = Thread this
in Normal this
GT ->
let l' = case l of
Normal lTree -> Normal $ relinkEnds prev thisLink lTree
_ -> prev
r' = case r of
Normal rTree -> go thisLink next rTree
_ -> Normal $ Bin thisLink a next
this = Bin l' val r'
thisLink = Thread this
in Normal this
This is a follow up to my previous question about processing a Vector representation of a 5.1m edge directed graph. I am trying to implement Kosaraju's graph algorithm and thus need to rearrange my Vector in the order of the finishing times of a depth first search (DFS) on the edges reversed. I have code that runs on small data sets but that fails to return in 10 minutes on the full data set. (I can't exclude that a loop arises from the big graph, but there are no signs of that on my test data.)
DFS needs to avoid revisiting nodes, so I need some sort of 'state' for the search (currently a tuple, should I use a State Monad?). The first search should return a reordered Vector, but I am keeping things simple at present by returning a list of the reordered Node indexes so that I can process the Vector in one go subsequently.
I presume the issue lies in dfsInner. The code below 'remembers' the nodes visited updating the explored field of each node (third guard). Although I tried to make it tail recursive, the code seems to grow memory use fairly fast. Do I need to enforce some strictness and if so, how? (I have another version that I use on a single search search, which checks for previous visits by looking at the start nodes of the unexplored edges on the stack and the list of nodes that have been completed. This does not grow so quickly, but does not return for any well connected node.)
However, it could also be the foldr', but how can I detect that?
This is supposedly Coursera homework, but I'm no longer sure I can tick the honour code button! Learning is more important though, so I don't really want a copy/paste answer. What I have is not very elegant - it has an imperative feel to it too, which is driven by the issue with keeping some sort of state - see third guard. I'd welcome comments on design patterns.
type NodeName = Int
type Edges = [NodeName]
type Explored = Bool
type Stack = [(Int, Int)]
data Node = Node NodeName Explored Edges Edges deriving (Eq, Show)
type Graph = Vector Node
main = do
edges <- V.fromList `fmap` getEdges "SCC.txt"
let
maxIndex = fst $ V.last edges
gr = createGraph maxIndex edges
res = dfsOuter gr
--return gr
putStrLn $ show res
dfsOuter gr =
let tmp = V.foldr' callInner (gr,[]) gr
in snd tmp
callInner :: Node -> (Graph, Stack) -> (Graph, Stack)
callInner (Node idx _ fwd bwd) (gr,acc) =
let (Node _ explored _ _) = gr V.! idx
in case explored of
True -> (gr, acc)
False ->
let
initialStack = map (\l -> (idx, l)) bwd
gr' = gr V.// [(idx, Node idx True fwd bwd)]
(gr'', newScc) = dfsInner idx initialStack (length acc) (gr', [])
in (gr'', newScc++acc)
dfsInner :: NodeName -> Stack -> Int -> (Graph, [(Int, Int)]) -> (Graph, [(Int, Int)])
dfsInner start [] finishCounter (gr, acc) = (gr, (start, finishCounter):acc)
dfsInner start stack finishCounter (gr, acc)
| nextStart /= start = -- no more places to go from this node
dfsInner nextStart stack (finishCounter + 1) $ (gr, (start, finishCounter):acc)
| nextExplored =
-- nextExplored || any (\(y,_) -> y == stack0Head) stack || any (\(x,_) -> x == stack0Head) acc =
dfsInner start (tail stack) finishCounter (gr, acc)
| otherwise =
dfsInner nextEnd (add2Stack++stack) finishCounter (gr V.// [(nextEnd, Node idx True nextLHS nextRHS)], acc)
-- dfsInner gr stack0Head (add2Stack++stack) finishCounter acc
where
(nextStart, nextEnd) = head stack
(Node idx nextExplored nextLHS nextRHS) = gr V.! nextEnd
add2Stack = map (\l -> (nextEnd, l)) nextRHS
In a nutshell:
Know the time complexities.
There are a lot of fine points to optimization, a large subset of which being not very important in everyday programming, but fail to know the asymptotic complexities and programs will often just not work at all.
Haskell libraries usually document the complexities, especially when it's not obvious or not effective (linear of worse). In particular, all the complexities relevant to this question can be found in Data.List and Data.Vector.
The performance is killed by V.// here. Vectors are boxed or unboxed immutable contiguous arrays in memory. Hence, modifying them requires copying the entire vector. Since we have O(N) such modifications, the whole algorithm is O(n^2), so we have to copy about 2 terabytes with N = 500000. So, there isn't much use for marking visited nodes inside the vector. Instead, build an IntSet of indices as needed.
initialStack (length acc) also looks really bad. It's almost never a good idea to use length on large lists, because it's also O(n). It's probably not as nearly as bad as // in your code, since it sits in a relatively rarely occurring branch, but it'd still leave the performance crippled after we've corrected the vector issue.
Also, the search implementation seems rather unclear and overcomplicated to me. Aiming for a literal-minded translation of the pseudocode on the Wiki page should be a good start. Also, it's unnecessary to store the indices in nodes, since they can be determined from vector positions and the adjacency lists.
Based on #andras gist, I rewrote my code as below. I did not use Arrow functions as I am unfamiliar with them, and my second depth first search is stylistically the same as the first one (instead of #Andras filterM approach). The end result is that it completes in 20% of the time of Andras' code (21s instead of 114s).
import qualified Data.Vector as V
import qualified Data.IntSet as IS
import qualified Data.ByteString.Char8 as BS
import Data.List
import Control.Monad
import Control.Monad.State
--import Criterion.Main
--getEdges :: String -> IO [(Int, Int)]
getEdges file = do
lines <- (map BS.words . BS.lines) `fmap` BS.readFile file
let
pairs = (map . map) (maybe (error "can't read Int") fst . BS.readInt) lines
pairs' = [(a, b) | [a, b] <- pairs] -- adds 9 seconds
maxIndex = fst $ last pairs'
graph = createGraph maxIndex pairs'
return graph
main = do
graph <- getEdges "SCC.txt"
--let
--maxIndex = fst $ V.last edges
let
fts = bwdLoop graph
leaders = fst $ execState (fwdLoop graph fts) ([], IS.empty)
print $ length leaders
type Connections = [Int]
data Node = Node {fwd, bwd :: Connections} deriving (Show)
type Graph = V.Vector Node
type Visited = IS.IntSet
type FinishTime = Int
type FinishTimes = [FinishTime]
type Leaders = [Int]
createGraph :: Int -> [(Int, Int)] -> Graph
createGraph maxIndex pairs =
let
graph = V.replicate (maxIndex+1) (Node [] [])
graph' = V.accum (\(Node f b) x -> Node (x:f) b) graph pairs
in V.accum (\(Node f b) x -> Node f (x:b)) graph' $ map (\(a,b) -> (b,a)) pairs
bwdLoop :: Graph -> FinishTimes
bwdLoop g = fst $ execState (mapM_ go $ reverse [0 .. V.length g - 1]) ([], IS.empty) where
go :: Int -> State (FinishTimes, Visited) ()
go i = do
(fTimes, vs) <- get
let visited = IS.member i vs
if not visited then do
put (fTimes, IS.insert i vs)
mapM_ go $ bwd $ g V.! i
-- get state again after changes from mapM_
(fTimes', vs') <- get
put (i : fTimes', vs')
else return ()
fwdLoop :: Graph -> FinishTimes -> State (Leaders, Visited) ()
fwdLoop _ [] = return ()
fwdLoop g (i:fts) = do
(ls, vs) <- get
let visited = IS.member i vs
if not visited then do
put (i:ls, IS.insert i vs)
mapM_ go $ fwd $ g V.! i
else return ()
fwdLoop g fts
where
go :: Int -> State (Leaders, Visited) ()
go i = do
(ls, vs) <- get
let visited = IS.member i vs
if not visited then do
put (ls, IS.insert i vs)
mapM_ go $ fwd $ g V.! i
else return ()
How can I define a Haskell function which will apply a function to every value in a binary tree? So I know that it is similar to the map function - and that its type would be:
mapT :: (a -> b) -> Tree a -> Tree b
But thats about it...
You can declare an instance of class Functor. This is a standard class for data types which allow a function to be mapped over. Please note how similar the type of fmap is to your mapT's type:
class Functor f where
fmap :: (a -> b) -> f a -> f b
Let's assume your tree is defined as
data Tree a = Node (Tree a) (Tree a) | Leaf a
deriving (Show)
Then you can declare an instance of Functor this way:
instance Functor Tree where
fmap f (Node l r) = Node (fmap f l) (fmap f r)
fmap f (Leaf x) = Leaf (f x)
This is how you can use it:
main = do
let t = Node (Node (Leaf 1) (Leaf 2)) (Leaf 3)
let f = show . (2^)
putStrLn $ "Old Tree: " ++ (show t)
putStrLn $ "New Tree: " ++ (show . fmap f $ t)
Output:
Old Tree: Node (Node (Leaf 1) (Leaf 2)) (Leaf 3)
New Tree: Node (Node (Leaf "2") (Leaf "4")) (Leaf "8")
You can also define for convenience:
mapT = fmap
Surely, you can do it without type classes, but it makes the code more readable for the others if you use standard functions (everyone knows the usual behaviour of fmap).
I'll pretend this is homework and not give away all of the answer. If I'm mistaken, my apologies.
Probably your Tree type looks something like this:
data Tree a = TreeNode a (Tree a) (Tree a) | EmptyNode
There are two cases here, and you will need to write a mapT implementation for each of them:
An internal node, TreeNode, which carries a value of type a and has a left and a right child. What needs to be done in this case?
A terminal node, EmptyNode. What needs to be done in this case?
The basic format of the map function applies to both. Let's look at the definition of the map function for lists:
map f (x:xs) = f x : map f xs
map _ [] = []
We can generalize this like so:
You take the first value in the data structure
Apply the function to it
Recursively call your map function with the remainder of the data structure
Pass both the modified value and the recursive call into the constructor for your type.
When you reach the end, stop recursing
All you really need is to look at your constructor and the map function should fall into place.
Interesting question if the input and output are supposed to be sorted binary trees. If you just naively traverse the tree and apply the function, the output tree may no longer be sorted. For example, consider if the function is non-linear, like
f(x) = x * x - 3 * x + 2
If the input has { 1, 2, 3, 4 } then the output will have { 2, 0, 0, 2 }. Should the output tree contain only 0 and 2?
If so, you may need to iteratively build up the output tree as you strip down and process the input tree.