Generalized Snoc

gsnoc.lhs

I've recently been thinking about how to generialize an efficient version of the snoc operation on lists.

Specifically, one can represent lists by indentifying them with their fold functions:

> -- data List a = List { fold :: forall r. r -> (a -> r -> r) -> r }

This representation, as in the case of difference lists, admits efficient versions of the cons operation at both ends of the list:

> -- cons :: a -> List a -> List a
> -- cons a l = List (\r0 acc -> acc a $ fold l r0 acc)

> -- snoc :: a -> List a -> List a
> -- snoc a l = List (\r0 acc -> fold l (acc a r0) acc)

I wondered if it was possible to generialize this to arbitrary least fixed point types. What I came up with is satisfactory, but I wonder if there is a better generalization of the original snoc function.

We'll need these imports and extensions:

> {-# LANGUAGE RankNTypes, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}

> import qualified Data.Void as V
> import qualified Data.Monoid as M
> import qualified Data.Foldable as F
> import qualified Data.Traversable as T

First, let's generalize the type List given above to any type constructor f:

> newtype Rec f = Rec { cata :: forall r. (f r -> r) -> r }

The cons operation is easily generalized - Rec f is an initial f-algebra, and the algebra map gives the generalization of cons:

> gcons :: (Functor f) => f (Rec f) -> Rec f
> gcons x = Rec cata' where
>   cata' phi = phi $ fmap (flip cata phi) x

Generalizing snoc is a little less obvious. I came up with the following.

What I'd like to do is to replace the leaves of the recursive structure with one more level of f structure. By "leaves" I mean values of Rec f with no structurally smaller elements. These are given by the summands in (f x) with no factor of x.

Given a Traversable instance for f, we can attempt to convert f into a leaf:

> toLeaf :: (Functor f, T.Traversable f) => f a -> Maybe (f V.Void)
> toLeaf = T.mapM (const Nothing)

> gsnoc :: (Functor f, T.Traversable f) => Rec f -> (forall r. f V.Void -> f (f V.Void)) -> Rec f
> gsnoc x f = Rec cata' where
>   cata' phi = cata x (phi' phi)
>   phi' phi y = case toLeaf y of 
>     Nothing -> phi y
>     (Just leaf) -> phi $ fmap (($) (phi . fmap V.absurd)) $ f leaf

> data ListF a x = Nil | Cons a x deriving (Functor, F.Foldable, T.Traversable)

> type List a = Rec (ListF a)

> nil :: List a
> nil = gcons Nil

> cons :: a -> List a -> List a
> cons a l = gcons $ Cons a l

> test1 :: List Int
> test1 = cons 1 $ cons 2 $ cons 3 $ nil

> toList :: List a -> [a]
> toList = flip cata toList' where
>   toList' Nil = []
>   toList' (Cons a l) = a:l

> snocList :: a -> ListF a V.Void -> ListF a (ListF a V.Void) 
> snocList a Nil = Cons a Nil

> data TreeF a x = Tip | Branch x a x deriving (Functor, F.Foldable, T.Traversable)

> type Tree a = Rec (TreeF a)

> tip :: Tree a
> tip = gcons Tip

> branch :: Tree a -> a -> Tree a -> Tree a
> branch l a r = gcons $ Branch l a r

> test2 :: Tree Int
> test2 = branch tip 1 (branch (branch tip 3 tip) 2 (branch tip 4 tip))

> flattenTree :: Tree a -> [a]
> flattenTree = flip cata flattenTree' where
>   flattenTree' Tip = []
>   flattenTree' (Branch l a r) = l ++ [a] ++ r

> snocTree :: a -> TreeF a V.Void -> TreeF a (TreeF a V.Void) 
> snocTree a Tip = Branch Tip a Tip