Implicit Corecursive Queues

Posted on May 14, 2019

Fusion

I was looking again at one of my implementations of breadth-first traversals:

bfe :: Tree a -> [a] [a] = f r b [] bfe rf r b [] where Node x xs) fw bw = x : fw (xs : bw) f (x xs) fw bwfw (xsbw) = [] b [][] = foldl ( foldr f) b qs [] b qsf) b qs []

And I was wondering if I could fuse away the intermediate list. On the following line:

Node x xs) fw bw = x : fw (xs : bw) f (x xs) fw bwfw (xsbw)

The xs : bw is a little annoying, because we know it’s going to be consumed eventually by a fold. When that happens, it’s often a good idea to remove the list, and just inline the fold. In other words, if you see the following:

foldr f b (x : y : []) f b (x[])

You should replace it with this:

f x (f y b)

If you try and do that with the above definition, you get something like the following:

bfenum :: Tree a -> [a] [a] = f t b b bfenum tf t b b where Node x xs) fw bw = x : fw (bw . flip ( foldr f) xs) f (x xs) fw bwfw (bwf) xs) = x b b xx b

Infinite Types

The trouble is that the above comes with type errors:

Cannot construct the infinite type: b ~ (b -> c) -> [a]

This error shows up occasionally when you try and do heavy church-encoding in Haskell. You get a similar error when trying to encode the Y combinator:

y = \f -> (\x -> f (x x)) (\x -> f (x x)) \f(\xf (x x)) (\xf (x x))

• Occurs check: cannot construct the infinite type: t0 ~ t0 -> t

The solution for the y combinator is to use a newtype, where we can catch the recursion at a certain point to help the typechecker.

newtype Mu a = Mu ( Mu a -> a) a) = (\h -> h $ Mu h) (\x -> f . (\( Mu g) -> g) x $ x) y f(\hh) (\x(\(g)g) xx)

The trick for our queue is similar:

newtype Q a = Q { q :: ( Q a -> [a]) -> [a] } [a])[a] } bfenum :: Tree a -> [a] [a] = q (f t b) e bfenum tq (f t b) e where Node x xs) fw = Q (\bw -> x : q fw (bw . flip ( foldr f) xs)) f (x xs) fw(\bwq fw (bwf) xs)) b = fix ( Q . flip id ) fix ( e = fix ( flip q) fix (q)

This is actually equivalent to the continuation monad:

newtype Fix f = Fix { unFix :: f ( Fix f) } f (f) } type Q a = Fix ( ContT a []) a []) q = runContT . unFix runContTunFix bfenum :: Tree a -> [a] [a] = q (f t b) e bfenum tq (f t b) e where Node x xs) fw = Fix (mapContT (x : ) ( flip ( foldr f) xs <$> unFix fw)) f (x xs) fw(mapContT (x) (f) xsunFix fw)) b = fix ( Fix . pure ) fix ( e = fix ( flip q) fix (q)

Terminating

There’s a problem though: this algorithm never checks for an end. That’s ok if there isn’t one, mind you. For instance, with the following “unfold” function:

infixr 9 #. (#.) :: Coercible b c => (b -> c) -> (a -> b) -> a -> c b c(bc)(ab) ( #. ) _ = coerce ) _coerce {-# INLINE (#.) #-} bfUnfold :: (a -> (b,[a])) -> a -> [b] (a(b,[a]))[b] = g t (fix ( Q #. flip id )) (fix ( flip q)) bfUnfold f tg t (fix ()) (fix (q)) where = x : q fw (bw . flip ( foldr (( Q . ) #. g)) xs) g b fw bwq fw (bw((g)) xs) where = f b (x,xs)f b

We can write a decent enumeration of the rationals.

-- Stern-Brocot rats1 :: [ Rational ] = bfUnfold step (( 0 , 1 ),( 1 , 0 )) rats1bfUnfold step ((),()) where = (n % d,[(lb , m),(m , rb)]) step (lb,rb)(nd,[(lb , m),(m , rb)]) where m @ (n,d) = adj lb rb (n,d)adj lb rb = (w + y,x + z) adj (w,x) (y,z)(wy,xz) -- Calkin-Wilf rats2 :: [ Rational ] = bfUnfold step ( 1 , 1 ) rats2bfUnfold step ( where = (m % n,[(m,m + n),(n + m,n)]) step (m,n)(mn,[(m,mn),(nm,n)])

However, if we do want to stop at some point, we need a slight change to the queue type.

newtype Q a = Q { q :: Maybe ( Q a -> [a]) -> [a] } [a])[a] } bfenum :: Tree a -> [a] [a] = q (f t b) e bfenum tq (f t b) e where Node x xs) fw = Q (\bw -> x : q fw ( Just (m bw . flip ( foldr f) xs))) f (x xs) fw(\bwq fw ((m bwf) xs))) b = fix ( Q . maybe [] . flip ( $ )) fix ([])) e = Nothing m = fromMaybe ( flip q e) fromMaybe (q e)

Monadic

We can actually add in a monad to the above unfold without much difficulty.

newtype Q m a = Q { q :: Maybe ( Q m a -> m [a]) -> m [a] } m am am [a])m [a] } bfUnfold :: Monad m => (a -> m (b,[a])) -> a -> m [b] (am (b,[a]))m [b] = g t b e bfUnfold f tg t b e where = f s >>= g s fw bwf s \ ~ (x,xs) -> (x : ) <$> q fw ( Just (m bw . flip ( foldr (( Q . ) #. g)) xs)) (x,xs)(xq fw ((m bw((g)) xs)) b = fix ( Q #. maybe ( pure []) . flip ( $ )) fix ([]))) e = Nothing m = fromMaybe ( flip q e) fromMaybe (q e)

And it passes the torture tests for a linear-time breadth-first unfold from Feuer (2015). It breaks when you try and use it to build a tree, though.

Phases

Finally, we can try and make the above code a little more modular, by actually packaging up the queue type as a queue.

newtype Q a = Q { q :: Maybe ( Q a -> [a]) -> [a] } [a])[a] } newtype Queue a = Queue { runQueue :: Q a -> Q a } a } now :: a -> Queue a = Queue (\fw -> Q (\bw -> x : q fw bw)) now x(\fw(\bwq fw bw)) delay :: Queue a -> Queue a = Queue (\fw -> Q (\bw -> q fw ( Just (m bw . runQueue xs)))) delay xs(\fw(\bwq fw ((m bwrunQueue xs)))) where m = fromMaybe ( flip q Nothing ) fromMaybe ( instance Monoid ( Queue a) where a) mempty = Queue id mappend ( Queue xs) ( Queue ys) = Queue (xs . ys) xs) (ys)(xsys) run :: Queue a -> [a] [a] Queue xs) = q (xs b) Nothing run (xs)q (xs b) where b = fix ( Q . maybe [] . flip ( $ )) fix ([])) bfenum :: Tree a -> [a] [a] = run (f t) bfenum trun (f t) where Node x xs) = now x <> delay ( foldMap f xs) f (x xs)now xdelay (f xs)

At this point, our type is starting to look a lot like the Phases type from Noah Easterly’s tree-traversals package. This is exciting: the Phases type has the ideal interface for level-wise traversals. Unfortunately, it has the wrong time complexity for <*> and so on: my suspicion is that the queue type above here is to Phases as the continuation monad is to the free monad. In other words, we’ll get efficient construction at the expense of no inspection. Unfortunately, I can’t figure out how to turn the above type into an applicative. Maybe in a future post!

Finally, a lot of this is working towards finally understanding Smith (2009) and Allison (2006).