How to create a tree of random values in Haskell? - haskell

I've been working on learning about the state monad. I'm working with trees, defined as follows...
data Tree a = Unary (Tree a) | Binary (Tree a) (Tree a)| Ternary (Tree a) (Tree a) (Tree a) | Leaf a
What I'm currently trying to do is make a function with type signature randomize :: Tree a -> Tree Int that returns a tree where each leaf (Leaf a) is replaced by a leaf (Leaf 0) or a (Leaf 1) with equal probability.
I previously wrote a function I called label :: Enum b => Tree a -> b -> Tree b that traverses a Tree and replaces every Leaf a with a Leaf b where b is incremented every time a leaf is visited. It is defined as follows
label:: Enum b => Tree a -> b -> Tree b
label tree b = evalState (mapSucc (\s -> (s, succ s)) tree) b where
mapSucc f (Leaf a) = Leaf <$> state f
mapSucc f (Unary t1) = Unary <$> mapSucc f t1
mapSucc f (Binary t1 t2) = Binary <$> mapSucc f t1 <*> mapSucc f t2
mapSucc f (Ternary t1 t2 t3) = Ternary <$> mapSucc f t1 <*> mapSucc f t2 <*> mapSucc f t3
These seem to be very similar problems, you are weaving the state through each, you're just producing values differently. I tried...
randomize tree = evalState ( mapRandom (randomR (0,1)) tree) newStdGen where
mapRandom f (Leaf a) = Leaf <$> state f
mapRandom f (Unary t1) = Unary <$> mapRandom f t1
mapRandom f (Binary t1 t2) = Binary <$> mapRandom f t1 <*> mapRandom f t2
mapRandom f (Ternary t1 t2 t3) = Ternary <$> mapRandom f t1 <*> mapRandom f t2 <*> mapRandom f t3
however the compiler gave me the following
state.hs:55:41: error:
• No instance for (RandomGen (IO StdGen))
arising from a use of ‘randomR’
• In the first argument of ‘mapRandom’, namely ‘(randomR (0, 1))’
In the first argument of ‘evalState’, namely
‘(mapRandom (randomR (0, 1)) tree)’
In the expression:
evalState (mapRandom (randomR (0, 1)) tree) newStdGen
I thought Int was an instance of random, so I'm not really sure what to do to get an instance of Random, and if I did manage that if my thought process is on the right path. Would my solution work if I were to get an instance of random. I guess I'm not sure if my shortcoming stems from simply not knowing how to use System.Random or if I am not understanding the type of function I need. I've spent a significant amount of time trying to make randomize work but to no avail. Any help with understanding would be greatly appreciated.

From the compiler error message, it seems the problem is caused by the fact that your random number generator comes wrapped in the IO monad, because you have used function newStdGen.
You can get an unwrapped generator by using function mkStdGen instead. This function takes a parameter of Type Int as the seed of the generator.
For example, this code compiles:
randomize :: (Random a, Num a) => Int -> Tree a -> Tree a
randomize seed tree = evalState ( mapRandom (randomR (0,1)) tree) (mkStdGen seed) where
mapRandom f (Leaf a) = Leaf <$> state f
mapRandom f (Unary t1) = Unary <$> mapRandom f t1
mapRandom f (Binary t1 t2) = Binary <$> mapRandom f t1 <*> mapRandom f t2
mapRandom f (Ternary t1 t2 t3) = Ternary <$> mapRandom f t1
<*> mapRandom f t2 <*> mapRandom f t3
and you get as a bonus the possibility to reproduce the same sequence of random numbers at will (by passing the same seed again), something that newStdGen does not provide.
Function newStdGen uses the system clock to generate the seed, hence the need to involve the IO monad.
Addendum:
How to avoid duplicating the tree traversal code
Function randomize above works. However, it is not entirely satisfactory: it involves the algorithm for tree traversal, and it decides which range of values to use, and also which type of random number generator. So it seems to fail something known in computer programming as the Single Responsibility Principle (SRP).
One might need a different range some day. Also, you can make a case that the Threefish random number generator has better statistical properties than the standard Haskell one, and wish to use its Haskell implementation.
The path of least resistance is to clone the code for randomize and replace mkStdGen by mkTFGen. But at that point, the tree traversal code gets duplicated. And there are many potential duplicates. We should find a better way.
The general problem is to produce a new version of the initial tree using a stateful mapping. Here, we have so far ignored the values in the initial tree, but this is just for the particular case of a random output tree.
Generally, the type signature of the required transformation function would have to be:
statefulTreeMap :: (a -> s -> (b,s)) -> s -> Tree a -> (Tree b, s)
where s is the type of the state. In the case of randomize, the state is just (the current state of) the random number generator.
You can easily write the code for statefulTreeMap manually, using clauses like this:
statefulTreeMap step st0 (Binary tra1 tra2) =
let (trb1, st1) = statefulTreeMap step st0 tra1
(trb2, st2) = statefulTreeMap step st1 tra2
in (Binary trb1 trb2 , st2)
But this is not really the most Haskellish way.
It turns out this is quite similar to the mapAccumL library function. And the Haskell language library makes mapAccumL available for any entity belonging to the Traversable typeclass. Note that #amalloy mentions the Traversable typeclass in one of the comments.
So we could try to make our Tree type an instance of Traversable, and then make use of function mapAccumL.
This can be done by providing the code for function traverse explicitely:
instance Traversable Tree where
traverse fn (Unary ta) = Unary <$> (traverse fn ta)
traverse fn (Binary ta tb) = Binary <$> (traverse fn ta) <*> (traverse fn tb)
traverse fn (Ternary ta tb tc) = Ternary <$> (traverse fn ta) <*> (traverse fn tb) <*> (traverse fn tc)
traverse fn (Leaf a) = Leaf <$> fn a
But this is not even necessary. Instead, one can summon the compiler heavy artillery (at least in recent enough versions), and just ask it to generate the Tree version of traverse, by enabling the DeriveTraversable language extension:
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
import qualified Data.Tuple as T
import qualified Data.Traversable as TR
import System.Random
import qualified System.Random.TF as TF
import Control.Monad.State
data Tree a = Unary (Tree a) | Binary (Tree a) (Tree a) |
Ternary (Tree a) (Tree a) (Tree a) | Leaf a
deriving (Eq, Show, Functor, Foldable, Traversable)
Then we can have a generic version of our target statefulTreeMap function by putting some plumbing code around the mapAccumL function we've just got for free:
-- general solution for any Traversable entity:
statefulMap :: Traversable tr => (a -> s -> (b,s)) -> s -> tr a -> (tr b, s)
statefulMap step st0 tra =
let fn = \s y -> T.swap (step y s)
p = TR.mapAccumL fn st0 tra -- works in reverse if using mapAccumR
in
T.swap p
and we can immediately specialize it for Tree objects:
statefulTreeMap :: (a -> s -> (b,s)) -> s -> Tree a -> (Tree b, s)
statefulTreeMap = statefulMap
Thus we're almost done. We can now write a number of versions of randomize by supplying more plumbing code:
-- generic random tree generation, with range and generator as external parameters:
randomize2 :: (RandomGen gt, Random b, Num b) => (b,b) -> gt -> Tree a -> Tree b
randomize2 range gen tra =
let step = (\a g -> randomR range g) -- leftmost parameter ignored
in fst $ statefulTreeMap step gen tra -- drop final state of rng
-- version taking just a seed, with output range and generator type both hardwired:
randomize3 :: (Random b, Num b) => Int -> Tree a -> Tree b
randomize3 seed tra = let rng = TF.mkTFGen seed
range = (0,9)
in randomize2 range rng tra
Test code:
main = do
let seed = 4243
rng0 = TF.mkTFGen seed
tr1 = Ternary (Ternary (Leaf 1) (Leaf 2) (Leaf 3))
(Leaf (4::Integer))
(Binary (Leaf 12) (Leaf 13))
tr11 = (randomize seed tr1) :: Tree Integer
tr12 = (randomize2 (0,9) rng0 tr1) :: Tree Integer
tr13 = (randomize3 seed tr1) :: Tree Integer
putStrLn $ "tr1 = " ++ (show tr1) ++ "\n"
putStrLn $ "tr11 = " ++ (show tr11)
putStrLn $ "tr12 = " ++ (show tr12)
putStrLn $ "tr13 = " ++ (show tr13)
putStrLn $ "tr11 == tr12 = " ++ (show (tr11 == tr12))
putStrLn $ "tr11 == tr13 = " ++ (show (tr11 == tr13))
Program output:
tr1 = Ternary (Ternary (Leaf 1) (Leaf 2) (Leaf 3)) (Leaf 4) (Binary (Leaf 12) (Leaf 13))
tr11 = Ternary (Ternary (Leaf 9) (Leaf 6) (Leaf 0)) (Leaf 3) (Binary (Leaf 2) (Leaf 6))
tr12 = Ternary (Ternary (Leaf 9) (Leaf 6) (Leaf 0)) (Leaf 3) (Binary (Leaf 2) (Leaf 6))
tr13 = Ternary (Ternary (Leaf 9) (Leaf 6) (Leaf 0)) (Leaf 3) (Binary (Leaf 2) (Leaf 6))
tr11 == tr12 = True
tr11 == tr13 = True
So, in fact, we have eliminated the need for any explicit tree traversal code.
Side note:
Of course, the statefulTreeMap function can be used for tasks unrelated to pseudo-randomness. For example, we might want to give consecutive numbers to the elements of a Tree object:
enumerate :: Tree a -> Tree (a, Int)
enumerate = fst . (statefulTreeMap (\a rs -> ((a, head rs), tail rs)) [0..])
Testing under ghci:
λ>
λ> enumerate tr1
Ternary (Ternary (Leaf (1,0)) (Leaf (2,1)) (Leaf (3,2))) (Leaf (4,3)) (Binary (Leaf (12,4)) (Leaf (13,5)))
λ>

Your attempt was close. The problem is that newStdGen is an IO StdGen, but you need an StdGen. To fix that, change evalState ( mapRandom (randomR (0,1)) tree) newStdGen to evalState ( mapRandom (randomR (0,1)) tree) <$> newStdGen. Note that it'll then be randomize :: Tree a -> IO (Tree Int) rather than randomize :: Tree a -> Tree Int, but you can't avoid changing the type signature (your only other option is to make the StdGen be a parameter, which also changes it).

Related

How does repmin place values in the tree in Haskell?

I really like the repmin problem:
Write down repmin :: Tree Int -> Tree Int, which replaces all the numbers in the tree by their minimum in a single pass.
If I were writing something like this in python, I would go for passing values by their reference (let's say one-element lists instead of numbers is good enough):
def repmin(tree, wrapped_min_link=None):
x, subforest = tree
if wrapped_min_link is None:
wrapped_min_link = [x]
else:
[m] = wrapped_min_link
wrapped_min_link = [min(m, x)]
n = len(subforest)
subforest_min = [None] * n
for i in range(n):
if subforest[i]:
subforest_min[i] = repmin(subforest[i], wrapped_min_link)
return (wrapped_min_link, subforest_min)
It seems to me like a fitting way to wrap one's head around the knot-tying solution in Haskell (I wrote this one for rose trees from Data.Tree):
copyRose :: Tree Int -> Int -> (Tree Int, Int)
copyRose (Node x []) m = (Node m [], x)
copyRose (Node x fo) m =
let
unzipIdMinimum =
foldr (\ ~(a, b) ~(as, bmin) -> (a:as, b `min` bmin)) ([], maxBound :: Int)
(fo', y) = unzipIdMinimum . map (flip copyRose m) $ fo
in (Node m fo', x `min` y)
repmin :: Tree Int -> Tree Int
repmin = (loop . uncurry) copyRose
Yet, I reckon the solutions to work very differently. Here is my understanding of the latter one:
Let us rewrite loop for (->) a bit:
loop f b = let cd = f (b, snd cd) in fst cd
I reckon it to be loop for (->)'s workalike as snd gives the same degree of laziness as pattern-matching within let.
So, when repmin traverses through the tree, it is:
Building up the minimum in the tree to be returned as the second element of the pair.
Leaves snd $ copyRose (tree, m) behind in every node.
Thus, when the traversal comes to an end, the programme knows the value of snd $ copyRose (tree, m) (that is, the minimum in the tree) and is able to show it whenever some node of the tree is being computed.
Do I understand repmin in Haskell correctly?
This is more an extended comment than an answer, but I don't really think of your implementation as single-pass. It looks like it traverses the tree once, producing a new, lazily-generated, tree and the global minimum, but it actually produces a lazily generated tree and an enormous tree of thunks that will eventually calculate the minimum. To avoid this, you can get closer to the Python code by generating the tree eagerly, keeping track of the minimum as you go.
You'll note that I've generalized the type from Int to an arbitrary Ord type. You'll also note that I've used to different type variables to refer to the type of elements in the given tree and the type of the minimum passed in to generate a new tree—this lets the type system tell me if I mix them up.
repmin :: Tree a -> Tree a
repmin = (loop . uncurry) copyRose
copyRose :: Ord a => Tree a -> b -> (Tree b, a)
copyRose (Node x ts) final_min
| (ts', m) <- copyForest x ts final_min
= (Node final_min ts', m)
copyForest :: Ord a => a -> [Tree a] -> b -> ([Tree b], a)
copyForest !m [] _final_min = ([], m)
copyForest !m (t : ts) final_min
| (t', m') <- copyTree m t final_min
, (ts', m'') <- copyForest m' ts final_min
= (t' : ts', m'')
copyTree :: Ord a => a -> Tree a -> b -> (Tree b, a)
copyTree !m (Node x ts) final_min
| (ts', m') <- copyForest (min m x) ts final_min
= (Node final_min ts', m')
Exercise: rewrite this in monadic style using ReaderT to pass the global minimum and State to keep track of the minimum so far.

Haskell Function for checking if element is in Tree, returning Depth

I am currently doing an assigment for a class in which I have to implement a function which checks if an element is in a tree.
It is supposed to return Nothing when the element is not in the tree and Just (depth at which it was found) when it is.
An example:
sample1
##1
#3 2
###7 5 6 4
- contains 6 sample1 returns Just 2
- contains 1 sample1 returns Just 0
- contains 2 sample1 returns Just 1
- contains 8 sample1 returns Nothing
Here is what we are given:
Heap functional data structure:
module Fdata.Heap where
-- A signature for min-heaps
data Heap e t = Heap {
empty :: t e,
insert :: e -> t e -> t e,
findMin :: t e -> Maybe e,
deleteMin :: t e -> Maybe (t e),
merge :: t e -> t e -> t e,
contains :: e -> t e -> Maybe Int
}
An implementation of self-adjusting heaps:
import Fdata.Heap
import Fdata.Tree
-- An implementation of self-adjusting heaps
heap :: (Eq e, Ord e) => Heap e Tree
heap = Heap {
empty = Empty,
insert = \x t -> merge' (Node x Empty Empty) t,
findMin = \t -> case t of
Empty -> Nothing
(Node x _ _) -> Just x,
deleteMin = \t -> case t of
Empty -> Nothing
(Node _ l r) -> Just (merge' r l),
merge = \l r -> case (l, r) of
(Empty, t) -> t
(t, Empty) -> t
(t1#(Node x1 l1 r1), t2#(Node x2 l2 r2)) ->
if x1 <= x2
then Node x1 (merge' t2 r1) l1
else Node x2 (merge' t1 r2) l2,
contains = \x t -> case (x,t) of
(x,Empty)-> Nothing
(x,tx#(Node x1 l1 r1) ->
|x==x1 = Just 0
|x>x1 = (1+ (contains x l)
|x<x1 = (1+ (contains x r)
}
where
merge' = merge heap
The tree implementation
module Fdata.Tree where
import Fdata.Heap
data Tree x
= Empty
| Node x (Tree x) (Tree x)
deriving (Eq, Show)
leaf x = Node x Empty Empty
-- Convert a list to a heap
list2heap :: Heap x t -> [x] -> t x
list2heap i = foldl f z
where
f = flip $ insert i
z = empty i
-- Convert a heap to a list
heap2list :: Heap x t -> t x -> [x]
heap2list i t
= case (findMin i t, deleteMin i t) of
(Nothing, Nothing) -> []
(Just x, Just t') -> x : heap2list i t'
I am supposed to implement the contains function in the implementation for self-adjusting heaps.
I am not allowed to use any helper functions and I am supposed to use the maybe function.
My current implementation:
contains = \x t -> case (x,t) of
(x,Empty) -> Nothing
(x,tx#(Node x1 l1 r1))
|x==x1 -> Just 0
|x>x1 -> (1+ (contains x l1)
|x<x1 -> (1+ (contains x r1)
This does not work, since I get a parse error on input |.
I really dont know how to fix this since I did use 4 spaces instead of tabs and according to this: https://wiki.haskell.org/Case
the syntax is correct...
I once managed to fix this, but I got a type error about (1+ (contains x l), so this probably is not correct.
Any hint would be appreciated.
EDIT:
Thanks to everyone who answered!
Really appreciate that everyone took the time to explain their answers in great detail.
First of all:
there were some smaller mistakes, as pointed out by some of you in the comments:
I missed one closing parenthesis and accidentially named one argument l1 and another r1 and afterwards used r and l.
Fixed both mistakes.
Someone wrote that I do not need to use a lambda function. The problem is when I use something like:
contains _ Empty = Nothing
I get the error:
parse Error on input '_'.
However, lambda functions do not give me any errors about the input arguments.
Currently the only function that works without any errors is:
contains = \e t -> case (e,t) of
(_,Empty) -> Nothing
(e , Node x t1 t2) ->
if e == (head (heap2list heap (Node x t1 t2)))
then Just 0
else if (fmap (+1) (contains heap e t1))== Nothing
then (fmap (+1) (contains heap e t2))
else (fmap (+1) (contains heap e t1))
Found at:
Counting/Getting "Level" of a hierarchical data
Found by:Krom
One way of structuring contains :: Eq a => a -> Tree a -> Maybe Integer is to first label each element in your tree with its depth, using something like this, then fold the tree to find the element you're looking for, pulling its depth out with it. You can do this without very much code!
Jumping right in where this answer left off, here's contains.
contains :: Eq a => a -> Tree a -> Maybe Integer
contains x = fmap fst . find ((== x) . snd) . labelDepths
That's the whole function! This is classic functional programming style: rather than hand-crank a bespoke recursive tree traversal function I've structured the code as a pipeline of reusable operations. In Haskell pipelines are constructed using the composition operator (.) and are read from left to right. The result of labelDepths is passed to find ((== x) . snd), whose result is then passed to fmap fst.
labelDepths :: Tree a -> Tree (Integer, a), which I've explained in detail in the answer I linked above, attaches an Integer depth to each element of the input tree.
find :: Foldable t => (a -> Bool) -> t a -> Maybe a is a standard function which extracts the first element of a container (like a tree, or a list) that satisfies a predicate. In this instance, the Foldable structure in question is a Tree, so t ~ Tree and find :: (a -> Bool) -> Tree a -> Maybe a. The predicate I've given to find is ((== x) . snd), which returns True if the second element of its input tuple equals x: find ((== x) . snd) :: Tree (Integer, a) -> Maybe (Integer, a). find works by folding the input structure - testing its elements one at a time until it finds one that matches the predicate. The order in which elements are processed is defined by the container's Foldable instance, of which more below.
fmap :: Functor f => (a -> b) -> f a -> f b is another standard function. It applies a mapping function uniformly to each element of a container, transforming its elements from type a to type b. This time the container in question is the return value of find, which is a Maybe, so fmap :: (a -> b) -> Maybe a -> Maybe b. The mapping function I've supplied is fst, which extracts the first element of a tuple: fmap fst :: Maybe (Integer, a) -> Maybe Integer.
So putting it all together, you can see that this is a fairly direct implementation of my English description of the process above. First we label every element in the tree with its depth, then we find an element which matches the item we're looking for, then we extract the depth with which the element was previously labelled.
I mentioned above that Tree is a Foldable container. In fact, this isn't the case quite yet - there's no instance of Foldable for Tree. The easiest way to get a Foldable instance for Tree is to turn on the DeriveFoldable GHC extension and utter the magic words deriving Foldable.
{-# LANGUAGE DeriveFoldable #-}
data Tree x = Empty | Node x (Tree x) (Tree x) deriving Foldable
This automatically-implemented instance of Foldable will perform a preorder traversal, processing the tree in a top-down fashion. (x is considered to be "to the left of" l and r in the expression Node x l r.) You can adjust the derived traversal order by adjusting the layout of the Node constructor.
That said, I'm guessing that this is an assignment and you're not allowed to modify the definition of Tree or apply any language extensions. So you'll need to hand-write your own instance of Foldable, following the template at the bottom of this post. Here's an implementation of foldr which performs a preorder traversal.
instance Foldable Tree where
foldr f z Empty = z
foldr f z (Node x l r) = f x (foldr f (foldr f z r) l)
The Node case is the interesting one. We fold the tree from right to left (since this is a foldr) and from bottom to top. First we fold the right subtree, placing z at the rightmost leaf. Then we use the aggregated result of the right subtree as the seed for folding the left subtree. Finally we use the result of folding all of the Node's children as the aggregator to apply to f x.
Hopefully you didn't find this answer too advanced! (Happy to answer any questions you have.) While the other answers do a good job of showcasing how to write recursive tree traversal functions, I really wanted to give you a glimpse of the real power of functional programming. When you think at a higher level - breaking down a problem into its component parts, structuring operations as pipelines, and learning to spot common patterns like zipping, folding and mapping - you can be very productive and solve problems with very little code.
An instance of Foldable for a binary tree
To instantiate Foldable you need to provide a definition for at least foldMap or foldr.
data Tree a = Leaf
| Node (Tree a) a (Tree a)
instance Foldable Tree where
foldMap f Leaf = mempty
foldMap f (Node l x r) = foldMap f l `mappend` f x `mappend` foldMap f r
foldr f acc Leaf = acc
foldr f acc (Node l x r) = foldr f (f x (foldr f acc r)) l
This implementation performs an in-order traversal of the tree.
ghci> let myTree = Node (Node Leaf 'a' Leaf) 'b' (Node Leaf 'c' Leaf)
-- +--'b'--+
-- | |
-- +-'a'-+ +-'c'-+
-- | | | |
-- * * * *
ghci> toList myTree
"abc"
The DeriveFoldable extension allows GHC to generate Foldable instances based on the structure of the type. We can vary the order of the machine-written traversal by adjusting the layout of the Node constructor.
data Inorder a = ILeaf
| INode (Inorder a) a (Inorder a) -- as before
deriving Foldable
data Preorder a = PrLeaf
| PrNode a (Preorder a) (Preorder a)
deriving Foldable
data Postorder a = PoLeaf
| PoNode (Postorder a) (Postorder a) a
deriving Foldable
-- injections from the earlier Tree type
inorder :: Tree a -> Inorder a
inorder Leaf = ILeaf
inorder (Node l x r) = INode (inorder l) x (inorder r)
preorder :: Tree a -> Preorder a
preorder Leaf = PrLeaf
preorder (Node l x r) = PrNode x (preorder l) (preorder r)
postorder :: Tree a -> Postorder a
postorder Leaf = PoLeaf
postorder (Node l x r) = PoNode (postorder l) (postorder r) x
ghci> toList (inorder myTree)
"abc"
ghci> toList (preorder myTree)
"bac"
ghci> toList (postorder myTree)
"acb"
This function doesn't need to be a lambda:
contains x t =
Adding x to the case serves no purpose, since you only match it back to x. You can instead use pattern matching in the function head:
contains _ Empty = Nothing
The Node case has three sub-cases, where the value being searched for is less-than, greater-than, or equal to the value in the Node. If you order them that way, you get a symmetry from the less-than and greater-than tests, and can handle the equal case with an otherwise.
When recusring, you are going to get a Maybe Int, to which you want to add one. You can't do that directly because the Int is inside the Maybe. Normally, you would lift the addition, but I suspect that this is where the required call to maybe should go (however unnatural it may seem):
contains x (Node x' l r) | x < x' = maybe Nothing (Just . (+1)) $ contains x l
| x > x' = maybe Nothing (Just . (+1)) $ contains x r
| otherwise = Just 0
Instead of using maybe, the (+1) could have been lifted into the Maybe with fmap (or <$>):
... = fmap (+1) $ contains ...
Using maybe is unnatural because it has to explicitly pass the Nothing, and also re-wrap the Just.
This does not work, since I get a parse error on input |
Your previous line misses a closing parenthesis.
I got a Typ error about (1+ (contains x l)), so this probably is not correct.
The idea is totally correct, the issue is that contains x l returns a Maybe Int instead of an Int so you cannot directly add to that. You can only add to the result when it's a Just. There's a helper function that does exactly that, do something to Justs and keep Nothings: fmap (from Functor).
contains = \x t -> case (x,t) of
(x,Empty)-> Nothing
(x,tx#(Node x1 l1 r1))
|x==x1 -> Just 0
|x>x1 -> fmap (1+) (contains x l)
|x<x1 -> fmap (1+) (contains x r)
Btw, I'd write this as
contains x Empty = Nothing
contains x (Node v l r) = if x == v
then Just 0
else fmap (+1) $ contains x $ if x > v then l else r

finding sum of tree to list using haskell

I am trying to apply sum using id function while giving input to program.but i am with below. any guidance is much appreciated.
data Tree a = Leaf a | Node (Tree a) a (Tree a) deriving (Eq, Show)
reduce_tree :: Tree a -> (a -> b) -> (b -> a -> b -> b) -> b
reduce_tree (Leaf v) = [v]
reduce_tree (Node left root right) = reduce_tree left ++ [root] ++ reduce_tree right
input as follows:
ghci> reduce_tree (VNode (VLeaf 1) 2 (VNode (VLeaf 3) 4 (VLeaf 5)))
id sum
where sum t1 v t2 = t1 + v + t2
15
Since I don't understand your question completely, here are some observations:
reduce_tree's type signature suggests that it should have more arguments than you give it.
If f is a function that maps values of type a to values of type b, and g is what appears to be an accumulating function of three arguments (although I'm unsure why two are not enough), then
reduce_tree :: Tree a -> (a -> b) -> (b -> a -> b -> b) -> b
reduce_tree (Leaf v) f g = ...
reduce_tree (Node left v right) f g = ...
If reduce_tree is in fact a reduce function, and not one that simply flattens trees into lists, you may draw inspiration from Data.Foldable.
data Tree a = Leaf a | Node (Tree a) a (Tree a) deriving (Show, Eq)
treefold :: (a -> b -> b) -> b -> Tree a -> b
treefold f acc (Leaf x) = f x acc
treefold f acc1 (Node left x right) =
let acc2 = treefold f acc1 right
acc3 = f x acc2
acc4 = treefold f acc3 left
in acc4
With such a function you can either flatten or sum the elements of a tree:
flattenTree :: Tree a -> [a]
flattenTree tree = treefold (:) [] tree
sumTree :: Num a => Tree a -> a
sumTree tree = treefold (+) 0 tree
The only bell that rings when you say "apply sum using id function" is that perhaps you wish to use continuations. This is already covered thoroughly in e.g. Haskell: tail recursion version of depth of binary tree and concisely in Tail-recursion on trees (Standard ML). A Haskell equivalent would be:
treefold :: (a -> b -> b) -> b -> Tree a -> b
treefold f acc tree = tf f acc tree id
where
tf f acc (Leaf x) k = k (f x acc)
tf f acc (Node left x right) old_k = tf f left acc new_k
where
new_k = \acc -> tf f right (f x acc) old_k
Now sumTree can be defined in the exact same way as before, except it would use folding as well as the identity function as the initial continuation. Or you could extract the helper function tf to the top-level if you want to feed the traversal function with the function id yourself.
Oh, if I understand correctly, I think you are just trying to enter your example into ghci. I would recommend putting the complexity in the file:
sum_tree :: Tree Int -> Int
sum_tree t = reduce_tree t id sum
where sum t1 v t2 = t1 + v + t2
then in ghci, after you have loaded the file that sum_tree and reduce_tree are defined in,
ghci> sum_tree (VNode (VLeaf 1) 2 (VNode (VLeaf 3) 4 (VLeaf 5))
If you must do it all in ghci, be aware that you can't use where in ghci usually, since where is only used in definitions. Use let ... in instead:
ghci> let sum t1 v t2 = t1 + v + t2 in reduce_tree (VNode (VLeaf 1) 2 (VNode (VLeaf 3) 4 (VLeaf 5))) id sum
If you for some reason don't want to use let, you can use a lambda:
ghci> reduce_tree (VNode (VLeaf 1) 2 (VLeaf 3)) id (\t1 v t2 -> t1 + v + t2)
Did I understand your question correctly?

How to define a state monad?

I want to define a State monad that manages errors (in a sense like Maybe): if an error/problem occurs during the "do" computation, it is signal led and propagated by >>=.
The error should also contain a string describing it.
After, i want to apply this monad to mapTreeM, using for map a function that assumes states as numbers and a tree containing numbers, and at each visiting step updates the current state by adding to it the value of the current leaf; the resulting tree must contain a pair with the old leaf value and the state at the visiting instant. Such visit must fail if the state becomes negative during the computation, and succeed if it is positive.
e.g. Given this tree: Branch (Branch (Leaf 7) (Branch (Leaf (-1)) (Leaf 3))) (Branch (Leaf (-2)) (Leaf 9))
We obtain a tree (considering the initial state 0): Branch (Branch (Leaf (7,7)) (Branch (Leaf (-1,6)) (Leaf (3,9)))) (Branch (Leaf (-2,7)) (Leaf (9,16)))
If we put -18 in the second leaf, we should obtain an erroneous value signaling that we reached a negative state (-11).
I did a thing like this to print the tree without managing errors...i haven't understood how to do it.
The following is my code:
module Main where
-- State monad
newtype State st a = State (st -> (st, a))
instance Monad (State state) where
return x = State(\s -> (s,x))
State f >>= g = State(\oldstate ->
let (newstate, val) = f oldstate
State newf = g val
in newf newstate)
-- Recursive data structure for representing trees
data Tree a = Leaf a | Branch (Tree a) (Tree a)
deriving (Show,Eq)
-- Utility methods
getState :: State state state
getState = State(\state -> (state,state))
putState :: state -> State state ()
putState new = State(\_ -> (new, ()))
mapTreeM :: (Num a) => (a -> State state b) -> Tree a -> State state (Tree b)
mapTreeM f (Leaf a) =
f a >>= (\b -> return (Leaf b))
mapTreeM f (Branch lhs rhs) = do
lhs' <- mapTreeM f lhs
rhs' <- mapTreeM f rhs
return (Branch lhs' rhs')
numberTree :: (Num a) => Tree a -> State a (Tree (a,a))
numberTree tree = mapTreeM number tree
where number v = do
cur <- getState
putState(cur+v)
return (v,cur+v)
-- An instance of a tree
testTree = (Branch
(Branch
(Leaf 7) (Branch (Leaf (-1)) (Leaf 3)))
(Branch
(Leaf (-2)) (Leaf (-20))))
runStateM :: State state a -> state -> a
runStateM (State f) st = snd (f st)
main :: IO()
main = print $ runStateM (numberTree testTree) 0
Can I propose an alternative solution to your problem? While Monads are good for many things, what you want to do can be done with a simple function that
keeps track of errors.
My function transferVal below is an example of such function.
The function transferVal traverses the
Tree from left to right while keeping the last value found. If an error occurs, the function returns the error and stops traversing the Tree.
Instead of using Maybe, it is often better to use Either <error_type> <result_type> to get a more clear error if something goes wrong. In my example, I use ([ChildDir],a) where [ChildDir] contains the
"direction" of the incriminated node and a is the erroneous value that triggered the error. The function printErrorsOrTree is an example of how you can use the output of transferVal and main contains 4 examples of which the first three are correct and the last one triggers the error that you was expecting.
module Main where
import Data.List (intercalate)
import Control.Monad (mapM_)
data Tree a = Leaf a | Branch (Tree a) (Tree a)
deriving (Show,Eq)
-- given a Branch, in which child the error is?
data ChildDir = LeftChild | RightChild
deriving Show
-- an error is the direction to get to the error from the root and the
-- value that triggered the error
type Error a = ([ChildDir],a)
-- util to append a direction to an error
appendDir :: ChildDir -> Error a -> Error a
appendDir d (ds,x) = (d:ds,x)
transferVal :: (Ord a,Num a) => Tree a -> Either (Error a) (Tree (a,a))
transferVal = fmap fst . go 0
where go :: (Ord a,Num a) => a -> Tree a -> Either (Error a) (Tree (a,a),a)
go c (Leaf x) = let newC = x + c
in if newC < 0
then Left ([],newC)
else Right (Leaf (x,newC),newC)
go c (Branch t1 t2) = case go c t1 of
Left e -> Left $ appendDir LeftChild e
Right (newT1,newC) -> case go newC t2 of
Left e -> Left $ appendDir RightChild e
Right (newT2,newC') -> Right (Branch newT1 newT2,newC')
printErrorsOrTree :: (Show a,Show b) => Either (Error a) (Tree b) -> IO ()
printErrorsOrTree (Left (ds,x)) = putStrLn $ "Error in position " ++ (intercalate " -> " $ map show ds) ++ ". Error value is " ++ show x
printErrorsOrTree (Right t) = putStrLn $ "Result: " ++ show t
main :: IO ()
main = mapM_ runExample
[(Leaf 1)
,(Branch (Leaf 1) (Leaf 2))
,(Branch (Branch (Leaf 7) (Branch (Leaf (-1)) (Leaf 3))) (Branch (Leaf (-2)) (Leaf 9)))
,(Branch (Branch (Leaf 7) (Branch (Leaf (-11)) (Leaf 3))) (Branch (Leaf (-2)) (Leaf 9)))]
where runExample orig = do
let res = transferVal orig
print orig
printErrorsOrTree res
By making your Tree datatype an instance of Traversable, you can use mapM (from Data.Traversable) to map an action over a Tree. You can also layer the StateT monad transformer atop the Either monad to provide error handling.
import Control.Monad.State
import Control.Applicative
import Control.Monad.Error
import Data.Monoid
import Data.Foldable
import Data.Traversable
import qualified Data.Traversable as T
-- our monad which carries state but allows for errors with string message
type M s = StateT s (Either String)
data Tree a = Leaf a | Branch (Tree a) (Tree a)
deriving (Show,Eq)
-- Traversable requires Functor
instance Functor Tree where
fmap f (Leaf a) = Leaf (f a)
fmap f (Branch lhs rhs) = Branch (fmap f lhs) (fmap f rhs)
-- Traversable requires Foldable
instance Foldable Tree where
foldMap f (Leaf a) = f a
foldMap f (Branch lhs rhs) = foldMap f lhs `mappend` foldMap f rhs
-- Finally, we can get to Traversable
instance Traversable Tree where
traverse f (Leaf a) = Leaf <$> f a
traverse f (Branch lhs rhs) = Branch <$> traverse f lhs <*> traverse f rhs
testTree = (Branch
(Branch
(Leaf 7) (Branch (Leaf (-1)) (Leaf 3)))
(Branch
(Leaf (-2)) (Leaf (-20))))
numberTree :: (Num a, Ord a) => Tree a -> M a (Tree (a,a))
numberTree = T.mapM number where
number v = do
cur <- get
let nxt = cur+v
-- lift the error into the StateT layer
when (nxt < 0) $ throwError "state went negative"
put nxt
return (v, nxt)
main :: IO ()
main =
case evalStateT (numberTree testTree) 0 of
Left e -> putStrLn $ "Error: " ++ e
Right t -> putStrLn $ "Success: " ++ show t

How to represent tree with sharing in Haskell

I would like to represent a "tree" of the following shape in Haskell:
/\
/\/\
/\/\/\
/\/\/\/\
` ` ` ` `
/ and \ are the branches and ` the leaves. You can see that starting at any node, following the left path, then the right gets you to the same node as following the right path then the left. You should be able to label the leaves, apply a function of the two decendants at each node, and propagate this information to the root in O(n^2) time. My naive efforts are giving me an exponential run time. Any hints?
It is certainly possible to construct a tree with shared nodes. For example, we could just define:
data Tree a = Leaf a | Node (Tree a) (Tree a)
and then carefully construct a value of this type as in
tree :: Tree Int
tree = Node t1 t2
where
t1 = Node t3 t4
t2 = Node t4 t5
t3 = Leaf 2
t4 = Leaf 3
t5 = Leaf 5
to achieve sharing of subtrees (in this case t4).
However, as this form of sharing is not observable in Haskell, it is very hard to maintain: for example if you traverse a tree to relabel its leaves
relabel :: (a -> b) -> Tree a -> Tree b
relabel f (Leaf x) = Leaf (f x)
relabel f (Node l r) = Node (relabel f l) (relabel f r)
you loose sharing. Also, when doing a bottom-up computation such as
sum :: Num a => Tree a -> a
sum (Leaf n) = n
sum (Node l r) = sum l + sum r
you end up not taking advantage of sharing and possibly duplicate work.
To overcome these problems, you can make sharing explicit (and hence observable) by encoding your trees in a graph-like manner:
type Ptr = Int
data Tree' a = Leaf a | Node Ptr Ptr
data Tree a = Tree {root :: Ptr, env :: Map Ptr (Tree' a)}
The tree from the example above can now be written as
tree :: Tree Int
tree = Tree {root = 0, env = fromList ts}
where
ts = [(0, Node 1 2), (1, Node 3 4), (2, Node 4 5),
(3, Leaf 2), (4, Leaf 3), (5, Leaf 5)]
The price to pay is that functions that traverse these structures are somewhat cumbersome to write, but we can now define for example a relabeling function that preserves sharing
relabel :: (a -> b) -> Tree a -> Tree b
relabel f (Tree root env) = Tree root (fmap g env)
where
g (Leaf x) = Leaf (f x)
g (Node l r) = Node l r
and a sum function that doesn't duplicate work when the tree has shared nodes:
sum :: Num a => Tree a -> a
sum (Tree root env) = fromJust (lookup root env')
where
env' = fmap f env
f (Leaf n) = n
f (Node l r) = fromJust (lookup l env') + fromJust (lookup r env')
Perhaps you can represent it simply as a list of leaves and apply the function level by level until you're down to one value, i.e. something like this:
type Tree a = [a]
propagate :: (a -> a -> a) -> Tree a -> a
propagate f xs =
case zipWith f xs (tail xs) of
[x] -> x
xs' -> propagate f xs'

Resources