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.

I think the traversal order shouldn’t matter…I may be wrong, but I would reach for laziness: build a tree of the same shape as the input, where each value is replaced with a reference to the *same* “minimum” thunk, whose value is computed from the whole tree. You can do it with `ArrowLoop`, but I’d use `MonadFix` with `do`…`rec`… notation. Of course, while there’s only one *explicit* traversal in the source, at runtime there are two, in a way, interleaved: one for the tree’s *structure* (allocating a new tree whose nodes all point to the same thunk), one for its *values* (forcing the thunk). — Jon Purdy, Jul 14 '20 at 23:27
I'm not sure if this is really doable: Consider how you can traverse the tree in BFS order and during this traversal also "reconstruct" it at the same time. This is a simpler problem than what you're aiming for, but is absolutely essential that you can do that first. How would you approach this simpler problem? — alias, Jul 15 '20 at 07:29
[might be related](https://stackoverflow.com/questions/60516485/building-a-binary-tree-not-bst-in-haskell-breadth-first). (also, @alias) — Will Ness, Jul 15 '20 at 09:01
@WillNess That's quite tour-de-force. Does it only build "full" trees though? i.e., fully balanced? I suspect the OP's case is for a general tree. — alias, Jul 15 '20 at 17:52
@alias I think so, yes. left-biased in the fringe, too. otherwise it would have to return a list of trees, modeling the nondeterminism. — Will Ness, Jul 16 '20 at 03:04

score 1 · Accepted Answer · answered Jul 17 '20 at 13:40

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

Level-order repminPrint

1 Answers1