Map List Over a Tree

Question

Consider the following definition of a tree:

data Tree a = Leaf a | Node [Tree a]

And a sample tree:

input :: Tree String
input = Node [Leaf "a", Leaf "b", Node [Leaf "c", Leaf "d"]]

I'm trying to 'map' a list over such a tree, whereas the values of the tree should be discarded. In the case of [0..] being the list, the result should look like:

output :: Tree Int
output = Node [Leaf 0, Leaf 1, Node [Leaf 2, Leaf 3]]

So I'm looking for a function..

seqTree :: [b] -> Tree a -> Tree b
seqTree = undefined

.. for which the following holds:

seqTree [0..] input == output

I came to the conclusion that a function like this must wrap another function in order to keep track of list items which has not been 'taken' yet:

seqTree' :: [b] -> Tree a -> Tree ([b], b)
seqTree' xxs@(x:xs) t = case t of
  Leaf _  -> Leaf (xs, x)
--Node ts = the tricky part... maybe something with foldr?
seqTree' [] t = error "empty list."

With this I was hoping to implement seqTree, which would require some final mapping over the whole tree, I guess there are better ways to do this, here is a verbose version:

finish :: Tree (a,b) -> Tree b
finish t = case t of
  Leaf v  -> Leaf $ snd v
  Node ts -> Node (map finish ts)

And finally:

seqTree xs t = finish $ seqTree' xs t 

This compiles, however as marked with the comment, the function seqTree' is partial. Does anybody know how to fix this, and furthermore, what would be a more appropriate, less low level approach for solving this?

Answer 1

I think there is a way to view this as a specific case of something more general: a stateful computation that produces a Tree as output by combining many smaller stateful computations at the original tree's leaves. Lee provides a good way to implement this by hand using State and a list of labels, but we can simplify things and reuse some built-in machinery from Applicative and State, by splitting the job into a two-step process: first, fmap over your tree, replacing each node with an identical value in the State s monad, and then using sequenceA :: Tree (State s a) -> State s (Tree a) to run the stateful computation through each of the nodes in sequence.

Of course, this means you will have to implement Foldable and Traversable for your tree type, but those are good instances to write for a tree type anyway. Supposing that those have been written, you could implement your function like this:

seqTree :: [b] -> Tree a -> Tree b
seqTree labels = evalState labels . sequenceA . (nextLabel <$)
  where nextLabel = do
    (x:xs) <- get
    put xs
    pure x

Or alternatively, as pointed out in the comments on a previous version of this answer, instead of sequenceA . (nextLabel <$), it is probably cleaner to write traverse (const nextLabel).

Answer 2

You could use State where the state contain the remaining list of values. You can then provide a function which transforms the values in the tree based on the current value and the next value in the input stream e.g.

data Tree a = Leaf a | Node [Tree a] deriving (Show)

input :: Tree String
input = Node [Leaf "a", Leaf "b", Node [Leaf "c", Leaf "d"]]

labelWithState :: (a -> l -> b) -> Tree a -> State [l] (Tree b)
labelWithState f (Leaf v) = do
  (l : ls) <- get
  put ls
  pure $ Leaf (f v l)
labelWithState f (Node ts) = do
  lts <- traverse (labelWithState f) ts
  pure $ Node lts

labelWith :: (a -> l -> b) -> [l] -> Tree a -> Tree b
labelWith f ls t = evalState (labelWithState f t) ls

then you can define seqTree as:

seqTree :: [b] -> Tree a -> Tree b
seqTree = labelWith (\_ l -> l)

Answer 3

I do not really see why you need a "finish" so to speak. You can define a function:

seqTree' :: [b] -> Tree a -> ([b],Tree b)

that maps a part of the sequence on the given subtree and returns the resulting tree together with the not yet consumed elements. So you pass the list of elements through the function calls so to speak, each function "eats" some elements from it and returns the tail such that other functions can "eat" the next elements.

Now as with most recursive functions, there is a base-case where the Tree a is a Leaf x:

seqTree' (x:xs) (Leaf _) = (xs,Leaf x)

Here you thus return a Leaf x with the given element of the sequence, and you return the remainder of the sequence.

Next there is also the seqTree' case for the Node, in this case you feed your sequence to a call to seqTree' and that call consumes a part of the tree, the remainder is used in a call for the second child and so on. So for a tree with three children, it would look like:

--Example
seqTree' xsa (Tree [na,nb,nc]) = (xsd,Tree [oa,ob,oc])
    where (xsb,oa) = seqTree' xsa na
          (xsc,ob) = seqTree' xsb nb
          (xsd,oc) = seqTree' xsc nc

Nice thing is, there exists already such a function: mapAccumL. So you can write:

seqTree' xsa (Node nodes) = (xsz,Node newnodes)
    where (xsz,newnodes) = mapAccumL seqTree' xsa nodes

Or the full function:

seqTree' (x:xs) (Leaf _) = (xs,Leaf x)
seqTree' xsa (Node nodes) = (xsz,Node newnodes)
    where (xsz,newnodes) = mapAccumL seqTree' xsa nodes

Now we only need to construct a call from seqTree to seqTree' which is simply dropping the remaining feed:

seqTree xs tree = snd $ seqTree' xs tree

Or a bit shorter:

seqTree xs = snd . seqTree' xs

If I add deriving Show to your Tree a definition and I run the program, I got:

*Main> seqTree [0..] input
Node [Leaf 0,Leaf 1,Node [Leaf 2,Leaf 3]]