I have some state that is represented as a tree
type Tree state
= Branch (List (Tree state))
| Leaf state
and I have a function to update the individual leaves given some action
updateLeaf : action -> state -> state
I would like a way to represent actions in some structure
type Structure action = ...
which carries an action and some means to know precisely which leaf in the tree to update.
For example, suppose I have the following tree:
Branch
[ Leaf "foo"
, Leaf "bar"
, Branch
[ Leaf "baz"
, Branch []
, Leaf "qux"
]
]
and I get some action say, "hello" and I would like it to apply my updateLeaf function only on "baz" in such a way that I end up with
Branch
[ Leaf "foo"
, Leaf "bar"
, Branch
[ Leaf "bazhello"
, Branch []
, Leaf "qux"
]
]
assuming my updateLeaf function is just string concatenation or (++). Furthermore, I would need this to pretty generic as in the structure would somehow track the position in the tree of the leaf it wishes to update.
In essence what I am looking for is for the following function:
updateTree
: (action -> state -> state)
-> Structure action
-> Tree state
-> Tree state
which will figure out which leaf in the tree to apply the given update function.
Finally, I also need it to work with address forwarding. Suppose the each leaf of the tree is represented as a button
viewLeaf : Address action -> state -> Html
viewLeaf address state =
button
[ onClick address ... ]
[ ... ]
and further suppose that the actions sent by the button on click are the ones that will update the state.
I would like to be able to define the following function
viewTree
: (Address action -> state -> Html)
-> Address (Structure action)
-> Tree state
-> Html
such that I can view all those buttons and the addresses are forwarded accordingly such that each button only affects itself. (I'm only interested in the forwarding aspect, not the visuals).
Thanks a lot for your help
A zipper is a way to navigate and modify a data structure. Suppose you have a tree, and you walk down the tree by choosing a branch. After 3 steps you encounter a leaf and you with to modify it. Now you want to return the modified tree, but you're 3 levels deep, how do you step back? Suppose that every time you go down a level in a tree, you leave a trail of breadcrumbs, so that you can reverse a step and reconstruct the tree. In other words, instead of just a tree you have a tuple (tree, breadcrumbs).
type Tree state = Branch (List (Tree state)) | Leaf state
-- Crumb contains 2 lists:
-- leafs/branches to the left of your focus
-- leafs/branches to the right of your focus
type Crumb state = Crumb (List (Tree state)) (List (Tree state))
type alias Zipper state = (Tree state, List (Crumb state))
tree : Tree String
tree = Branch [Leaf "foo",Leaf "bar",Branch [Leaf "baz",Branch [],Leaf "qux"]]
Every time you choose a branch, you cons the parent node and all other branches you didn't choose into breadcrumbs. Then you choose a new branch, so you cons its parent mode and all new branches you didn't choose in breadcrumbs. Therefore breadcrumbs contain all relevant information to reconstruct the previous step in reverse order. Let's implement going up and going to a leaf by name in a tree:
import Graphics.Element exposing (show)
break : (a -> Bool) -> List a -> (List a, List a)
break p xs = case (List.head xs, List.tail xs) of
(Nothing, Nothing) -> ([], [])
(Just x, Just xs') -> if p x
then ([], xs)
else let (ys,zs) = break p xs'
in (x::ys,zs)
treeInit : Tree state -> Zipper state
treeInit t = (t, [])
treeUp : Zipper state -> Zipper state
treeUp (subtree, Crumb l r::bs) = (Branch <| l++[subtree]++r, bs)
treeTo : state -> Zipper state -> Zipper state
treeTo name (Branch subtrees, bs) =
let (l, x::r) = break (\(Leaf name') -> name == name') subtrees
in (x, Crumb l r::bs)
main = tree |> treeInit |> treeTo "foo" |> show
But this doesn't allow to move focus from root to Leaf "baz" and doesn't allow to modify it, so let's add more functions (note that all our zipper functions can crash, we'll change this soon):
(!!) : List a -> Int -> a
xs !! i = case List.tail xs of
Nothing -> Debug.crash "index out of bounds"
Just xs' -> if i == 0
then case List.head xs of Just x -> x
else xs' !! (i-1)
treeToIndex : Int -> Zipper state -> Zipper state
treeToIndex i (Branch subtrees, bs) =
(subtrees!!i, Crumb (List.take i subtrees) (List.drop (i+1) subtrees)::bs)
treeReplace : state -> Zipper state -> Zipper state
treeReplace new (Leaf old, bs) = (Leaf new, bs)
main = tree |> treeInit |> treeToIndex 2 |> treeTo "baz" |> treeReplace "xyzzy" |> show
This whole chain of functions can crash easily if there is an index bigger than the branch size, or you try to go up from the root, and so on. Instead we should wrap the results in Maybe, so that instead of a crash, Nothing is returned. But how do we chain functions, now that they return Maybe (Zipper state), while they still accept Zipper state? This is where you use andThen, which has the type Maybe a -> (a -> Maybe b) -> Maybe b. Full code of your zipper below:
import Graphics.Element exposing (show)
import Maybe exposing (andThen)
type Tree state = Branch (List (Tree state)) | Leaf state
-- Crumb contains 2 lists:
-- leafs/branches to the left of your focus
-- leafs/branches to the right of your focus
type Crumb state = Crumb (List (Tree state)) (List (Tree state))
type alias Zipper state = (Tree state, List (Crumb state))
tree : Tree String
tree = Branch [Leaf "foo",Leaf "bar",Branch [Leaf "baz",Branch [],Leaf "qux"]]
break : (a -> Bool) -> List a -> (List a, List a)
break p xs = case (List.head xs, List.tail xs) of
(Nothing, Nothing) -> ([], [])
(Just x, Just xs') -> if p x
then ([], xs)
else let (ys,zs) = break p xs'
in (x::ys,zs)
treeInit : Tree state -> Zipper state
treeInit t = (t, [])
treeUp : Zipper state -> Maybe (Zipper state)
treeUp (subtree, bs) = case bs of
[] -> Nothing
Crumb l r::bs' -> Just (Branch <| l++[subtree]++r, bs')
treeTo : state -> Zipper state -> Maybe (Zipper state)
treeTo name node = case node of
(Branch subtrees, bs) ->
let (l, x::r) = break (\(Leaf name') -> name == name') subtrees
in Just (x, Crumb l r::bs)
_ -> Nothing
(!!) : List a -> Int -> Maybe a
xs !! i = case List.tail xs of
Nothing -> Nothing
Just xs' -> if i == 0
then List.head xs
else xs' !! (i-1)
treeToIndex : Int -> Zipper state -> Maybe (Zipper state)
treeToIndex i (Branch subtrees, bs) =
let newTree = subtrees!!i
in case newTree of
Nothing -> Nothing
Just newTree ->
let newCrumb = Crumb (List.take i subtrees) (List.drop (i+1) subtrees)
in Just (newTree, newCrumb::bs)
treeReplace : state -> Zipper state -> Maybe (Zipper state)
treeReplace new node = case node of
(Leaf old, bs) -> Just (Leaf new, bs)
_ -> Nothing
-- the function you're interested in most likely
treeUpdate : (state -> state) -> Zipper state -> Maybe (Zipper state)
treeUpdate f node = case node of
(Leaf name, bs) -> Just (Leaf (f name), bs)
_ -> Nothing
main = (tree |> treeInit |> treeToIndex 2)
`andThen` treeTo "baz" `andThen` treeReplace "xyzzy"
`andThen` treeUp `andThen` treeUp |> show
(Feel absolutely free to ask questions and clarifications, and I will update and improve this answer)
What you want is a zipper. Does everything you ask for in terms of
specifying a unique location in the tree
allowing modifications to the focus while preserving the rest.
easy reassembly of the tree.
If you want to bundle modifications with the precise location, then you just have to build a type which includes the zipper and the action.
There's a good section on zippers in Learn You a Haskell.
Once you understand the concept, it's easily applicable to many other datastructures.
It turns out that zippers allow one to achieve this. I will walkthrough the solution.
Using the following zipper
type alias Crumb a =
{ left : List (Tree a)
, right : List (Tree a)
}
type alias Zipper a = (Tree a, List (Crumb a))
One merely needs to implement the following functions
zipperMap : (Zipper a -> a -> b) -> Tree a -> Tree b
zipperUpdate : Zipper a -> (a -> a) -> Tree a -> Tree a
These can be implemented as follows
zipperMap : (Zipper a -> a -> b) -> Tree a -> Tree b
zipperMap f tree =
let
applyZipper ((subtree, crumbs) as zipper) =
case subtree of
Leaf a ->
Leaf (f zipper a)
Branch subtrees ->
subtrees
|> List.indexedMap (\index _ -> gotoIndex index zipper |> Maybe.map applyZipper)
|> keepJusts
|> Branch
in
applyZipper (fromTree tree)
zipperUpdate : Zipper a -> (a -> a) -> Tree a -> Tree a
zipperUpdate zipper f tree =
zipperMap (\z a -> if z == zipper then f a else a) tree
Where keepJusts is filters out the nothings from a list of maybes
keepJusts : List (Maybe a) -> List a
and gotoIndex goes to the nth subtree in a zipper
gotoIndex : Int -> Zipper a -> Maybe (Zipper a)
gotoIndex index (tree, bs) =
case tree of
Leaf _ ->
Nothing
Branch subtrees ->
case nth index subtrees of
Nothing ->
Nothing
Just newTree ->
let
newCrumb =
{ left = List.take index subtrees
, right = List.drop (index + 1) subtrees
}
in
Just (newTree, newCrumb :: bs)
Now, given the functions zipperMap and zipperUpdate we can apply these on our state.
Let us assume that the actions on the trees are represented as follows
type Action action state
= ChildAction (Zipper state) action
We can implement our update function as follows
update : (action -> state -> state)
-> Action action state
-> Tree state
-> Tree state
update updateChild action state =
case action of
ChildAction zipper childAction ->
zipperUpdate zipper (updateChild childAction) state
And we can implement our view function as follows
view : (Address action -> state -> Html)
-> Address (Action action state)
-> Tree state
-> Html
view viewChild address state =
let
viewZ zipper child =
let
childAddress =
Signal.forwardTo address (ChildAction zipper)
in
viewChild childAddress child
in
state
|> zipperMap viewZ
|> toList
|> div []
Where toList converts a tree to a list. While this is just an example, it helps illustrate how one can work with such things.
For more detail, you can see a fully functioning example here
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
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)
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 am pretty new to F# and I wanted to implement a solution to the following problem:
From a sequence of disk paths discovered in random order (e.g. "C:\Hello\foo" "C:" , "C:\Hello\bar" etc....) how to build (efficiently) the tree.
Assumption: the sequence is valid, which means the tree can be effectively created.
So I tried to implement with a recursive function ("mergeInto" in the following) which merges the tree "in place" with a list of string (the splitted path called "branch")
Here is my implementation, the immutability prevents side effects on the input tree, so I tried to use a ref cell for the input Tree but I encounter difficulty with the recursion. Any solution ?
open Microsoft.VisualStudio.TestTools.UnitTesting
type Tree =
|Node of string*list<Tree>
|Empty
let rec branchToTree (inputList:list<string>) =
match inputList with
| [] -> Tree.Empty
| head::tail -> Tree.Node (head, [branchToTree tail])
//branch cannot be empty list
let rec mergeInto (tree:Tree ref) (branch:list<string>) =
match !tree,branch with
| Node (value,_), head::tail when String.op_Inequality(value, head) -> raise (ApplicationException("Oops invariant loop broken"))
| Node (value,_), [_] -> ignore() //the branch is singleton and by loop invariant its head is the current Tree node -> nothing to do.
| Node (value,children), _ ->
let nextBranchValue = branch.Tail.Head //valid because of previous match
//broken attempt to retrieve a ref to the proper child
let targetChild = children
|> List.map (fun(child) -> ref child)
|> List.tryFind (fun(child) -> match !child with
|Empty -> false
|Node (value,_) -> value = nextBranchValue)
match targetChild with
|Some x -> mergeInto x branch.Tail //a valid child match then go deeper. NB: branch.Tail cannot be empty here
|None -> tree := Node(value, (Node (nextBranchValue,[])) :: children)//attach the next branch value to the children
| Empty,_ -> tree := branchToTree branch
[<TestClass>]
type TreeTests () =
[<TestMethod>]
member this.BuildTree () =
let initialTree = ref Tree.Empty
let branch1 = ["a";"b";"c"]
let branch2 = ["a";"b";"d"]
do mergeInto initialTree branch1
//-> my tree is ok
do mergeInto initialTree branch2
//->not ok, expected a
// |
// b
// / \
// d c
You can't make a ref to an element in a list, change the ref and then expect the item in the list to change. If you really want to do that then you should put the references into your Tree type.
type Tree =
|Node of string*list<Tree ref>
|Empty
let rec branchToTree (inputList:list<string>) =
match inputList with
| [] -> Tree.Empty
| head::tail -> Tree.Node(head, [ref (branchToTree tail)])
If you do that, remove the List.map (fun(child) -> ref child) part then your code works.
You might be interested in zippers which allow you to do something similar but without mutation.
Given the following simple BST definition:
data Tree x = Empty | Leaf x | Node x (Tree x) (Tree x)
deriving (Show, Eq)
inOrder :: Tree x -> [x]
inOrder Empty = []
inOrder (Leaf x) = [x]
inOrder (Node root left right) = inOrder left ++ [root] ++ inOrder right
I'd like to write an in-order function that can have side effects. I achieved that with:
inOrderM :: (Show x, Monad m) => (x -> m a) -> Tree x -> m ()
inOrderM f (Empty) = return ()
inOrderM f (Leaf y) = f y >> return ()
inOrderM f (Node root left right) = inOrderM f left >> f root >> inOrderM f right
-- print tree in order to stdout
inOrderM print tree
This works fine, but it seems repetitive - the same logic is already present in inOrder and my experience with Haskell leads me to believe that I'm probably doing something wrong if I'm writing a similar thing twice.
Is there any way that I can write a single function inOrder that can take either pure or monadic functions?
In inOrder you are mapping a Tree x to a [x], i. e. you sequentialize your tree. Why not just use mapM or mapM_ on the resulting list?
mapM_ print $ inOrder tree
Just to remind the types of the functions I've mentioned:
mapM :: (Monad m) => (a -> m b) -> [a] -> m [b]
mapM_ :: (Monad m) => (a -> m b) -> [a] -> m ()
You might want to look at implementing the Data.Traversable class or Data.Foldable class for your tree structure. Each only requires the definition of a single method.
In particular, if you implement the Data.Foldable class, you get the following two functions for free:
mapM_ :: (Foldable t, Monad m) => (a -> m b) -> t a -> m ()
toList :: Foldable t => t a -> [a]
It will also give you the rich set of functions (foldr, concatMap, any, ...) that you are used to using with the list type.
You only have to implement one of the following functions to create an instance of Data.Foldable:
foldMap :: Monoid m => (a -> m) -> t a -> m
foldr :: (a -> b -> b) -> b -> t a -> b