Tracing a tree?

Question

I have a type for a tree like so:

data Tree a = EmptyTree | Tree a [Tree a] deriving (Show, Ord, Eq)

freeTree :: Tree Integer  
freeTree =  Tree 2 [Tree 5 [], Tree 6 [Tree 8 [], Tree 9 []], Tree 7 []]

main = print freeTree

What I am trying to do is to write a function that could be used say like so:

trace freeTree

And what a trace on this tree would return is: [2],[2,5],[2,6],[2,7],[2,6,8],[2,6,9]

Basically what it does is:

Keep a list of nodes already on the 'stack' (The root node at each depth that got us here). Every time you reach a new node, add a list which is the list of stack nodes ++ current_node to the result list.

Could anyone offer any advice on how to do this?

Thanks

Answer 1

A first (not really efficient implementation):

trace :: Tree a -> [[a]]
trace t = trace' [([],t)] []

type Level a = [([a],Tree a)]

trace' :: Level a -> Level a -> [[a]]
trace' [] [] = []                                         -- current and next level empty? We're done!
trace' [] l = trace' l []                                 -- current level exhausted? Next level becomes current level and we construct a new level
trace' ((_,EmptyTree):ts) lu = trace' ts lu               -- currently an EmptyTree? Skip it
trace' ((h,Tree t c):ts) lu = ht : trace' ts (lu++el)     -- currently a tree? Enumerate and add childs
    where ht = h++[t]
          el = map (\x -> (ht,x)) c

The algorithm uses two Level a's, the current level and the next level. You always iterate first over the current level and for each item in the current level, you add the childs of that level to the next level until the current level is exhausted. The only problem with this approach is that the ++ operations are quite expensive, especially since they are applied left associative and not right associative. One can make it a bit more memory efficient as well by using a more compact tuple list representation.

You can make it more efficient by using a FIFO queue, for instance this one (let's assume at least the interface for all queues is the same, so in case you prefer another one, you can swap places).

In that case the code would read:

type Level a = [([a],Tree a)]
type LevelFiF a = FIFO ([a],Tree a)

trace' :: Level a -> LevelFiF a -> [[a]]
trace' [] ln | isEmpty ln = []
             | otherwise = trace' (toList ln) empty
trace' ((h,Tree t c):ts) ln = ht : trace' ts (foldl (flip enqueue) ln el)
    where ht = h++[t]
          el = map (\x -> (ht,x)) c
trace' (_:ts) ln = ht : trace' ts ln

You can probably make it more efficient using one of Haskell's monadic queues as well.

Answer 2

We can think that we have a trie where each node marks a valid word, and then the job is to enlist the words:

trace :: Tree a -> [[a]]
trace (Tree a ts) = [a] : map (a:) (trace =<< ts)
trace Empty       = []

tree1 = Tree 1 [Tree 2 [ Tree 3 [ Tree 4 [Tree 5 [] ]]]]
tree2 = Tree 2 [Tree 5 [], Tree 6 [Tree 8 [], Tree 9 []], Tree 7 []]

-- trace tree1 = [[1],[1,2],[1,2,3],[1,2,3,4],[1,2,3,4,5]]
-- trace tree2 = [[2],[2,5],[2,6],[2,6,8],[2,6,9],[2,7]]

This is a depth-first solution that can be lazily processed with space required only for the current word. It doesn't return words in the exact same order you specified; if strict breadth-first order is critical, you should go for iterative deepening:

traceIDeep :: Tree a -> [[a]]
traceIDeep t = concat $ takeWhile (not . null) $ map (`lvl` t) [0..] 
  where
  lvl 0 (Tree a ts) = [[a]]
  lvl l (Tree a ts) = map (a:) (lvl (l - 1) =<< ts)
  lvl _ Empty       = []

-- Now we have bfs order:
-- trace tree2 = [[2],[2,5],[2,6],[2,7],[2,6,8],[2,6,9]]