Level-order repminPrint

Question

repmin problem is pretty well-known. We are given a data type for trees:

data Tree a = Leaf a | Fork (Tree a) a (Tree a) deriving Show

We need to write a function down (repmin) which would take a tree of numbers and replace all numbers in it by their minimum in a single pass. It is also possible to print the tree out along the way (let us say function repminPrint does this). Both repmin and pre-, post- and in-order repminPrint could be written down easily using value recursion. Here is an example for in-order repminPrint:

import Control.Arrow

replaceWithM :: (Tree Int, Int) -> IO (Tree Int, Int)
replaceWithM (Leaf a, m)      = print a >> return (Leaf m, a)
replaceWithM (Fork l mb r, m) = do 
                                  (l', ml) <- replaceWithM (l, m)
                                  print mb
                                  (r', mr) <- replaceWithM (r, m)
                                  return (Fork l' m r', ml `min` mr `min` mb)

repminPrint = loop (Kleisli replaceWithM)

But what if we want to write level-order repminPrint down?

My guess is that we cannot use the queue as we need the ml and mr to update the binding for m. I cannot see how this could be down with a queue. I wrote down an instance for level-order Foldable Tree to show what I mean:

instance Foldable Tree where
 foldr f ini t = helper f ini [t] where
  helper f ini []                 = ini
  helper f ini ((Leaf v) : q      = v `f` helper f ini q
  helper f ini ((Fork l v r) : q) = v `f` (helper f ini (q ++ [l, r]))

As you can see, we do not run anything on l and r during the current recursive call.

So, how could this be done? I would appreciate hints instead of full solutions.

Answer 1

I think the best way to accomplish what you're looking to do here is with a traversal (in the sense of the Traversable class). First, I'm going to generalise a little bit to rose trees:

data Tree a
  = a :& [Tree a]
  deriving (Show, Eq, Ord, Functor, Foldable, Traversable)

All of the functions I show should be pretty straightforward to change into the tree definition you have given, but this type is a little more general and shows some of the patterns a little better I think.

Our first task, then, is to write the repmin function on this tree. We also want to write it using the derived Traversable instance. Luckily, the pattern done by repmin can be expressed using a combination of the reader and writer applicatives:

unloop :: WriterT a ((->) a) b -> b
unloop m = 
  let (x,w) = runWriterT m w
  in x
      
repmin :: Ord a => Tree a -> Tree a
repmin = unloop . traverse (WriterT .  f)
  where
    f x ~(Just (Min y)) = (y, Just (Min x))

While we're using the monad transformer version of WriterT here of course we don't need to, since Applicatives always compose.

The next step is to turn this into the repminPrint function: for this, we will need the RecursiveDo extension, which allows us to tie the knot in the unloop function even while we're inside the IO monad.

unloopPrint :: WriterT a (ReaderT a IO) b -> IO b
unloopPrint m = mdo
  (x,w) <- runReaderT (runWriterT m) w
  pure x

repminPrint :: (Ord a, Show a) => Tree a -> IO (Tree a)
repminPrint = unloopPrint . traverse (WriterT . ReaderT . f)
  where
    f x ~(Just (Min y)) = (y, Just (Min x)) <$ print x

Right: so at this stage, we have managed to write a version of repminPrint which uses any generic traversal to do the repmin function. Of course, it still is in-order, rather than breadth-first:

>>> repminPrint (1 :& [2 :& [4 :& []], 3 :& [5 :& []]])
1
2
4
3
5

What's missing now is a traversal which walks over the tree in breadth-first, rather than depth-first, order. I'm going to use the function I wrote here:

bft :: Applicative f => (a -> f b) -> Tree a -> f (Tree b)
bft f (x :& xs) = liftA2 (:&) (f x) (bftF f xs)

bftF :: Applicative f => (a -> f b) -> [Tree a] -> f [Tree b]
bftF t = fmap head . foldr (<*>) (pure []) . foldr f [pure ([]:)]
  where
    f (x :& xs) (q : qs) = liftA2 c (t x) q : foldr f (p qs) xs
    
    p []     = [pure ([]:)]
    p (x:xs) = fmap (([]:).) x : xs

    c x k (xs : ks) = ((x :& xs) : y) : ys
      where (y : ys) = k ks

All in all, that makes the following a single-pass, breadth-first repminPrint using an applicative traversal:

unloopPrint :: WriterT a (ReaderT a IO) b -> IO b
unloopPrint m = mdo
  (x,w) <- runReaderT (runWriterT m) w
  pure x

repminPrint :: (Ord a, Show a) => Tree a -> IO (Tree a)
repminPrint = unloopPrint . bft (WriterT . ReaderT . f)
  where
    f x ~(Just (Min y)) = (y, Just (Min x)) <$ print x

>>> repminPrint (1 :& [2 :& [4 :& []], 3 :& [5 :& []]])
1
2
3
4
5