Comonadically finding all the ways to focus on a grid

Question

{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
import Control.Comonad
import Data.Functor.Reverse
import Data.List (unfoldr)

First some context (ha ha). I have a zipper over non-empty lists.

data LZipper a = LZipper (Reverse [] a) a [a]
    deriving (Eq, Ord, Show, Read, Functor, Foldable, Traversable)

mkZipper :: a -> [a] -> LZipper a
mkZipper = LZipper (Reverse [])

You can step in either direction along the zipper, but you might fall off the end.

fwd, bwd :: LZipper a -> Maybe (LZipper a)
fwd (LZipper _ _ []) = Nothing
fwd (LZipper (Reverse xs) e (y:ys)) = Just $ LZipper (Reverse (e:xs)) y ys
bwd (LZipper (Reverse []) _ _) = Nothing
bwd (LZipper (Reverse (x:xs)) e ys) = Just $ LZipper (Reverse xs) x (e:ys)

Duplicating a zipper shows you all the ways you could look at it, with the focus on the way you're looking at it currently.

instance Comonad LZipper where
    extract (LZipper _ x _) = x
    duplicate z = LZipper (Reverse $ unfoldr (step bwd) z) z (unfoldr (step fwd) z)
        where step move = fmap (\y -> (y, y)) . move

For example:

ghci> duplicate (mkZipper 'a' "bc")
LZipper (Reverse [])
        (LZipper (Reverse "") 'a' "bc")
        [LZipper (Reverse "a") 'b' "c",LZipper (Reverse "ba") 'c' ""]
-- Abc -> *Abc* aBc abC

ghci> fmap duplicate (fwd $ mkZipper 'a' "bc")
Just (LZipper (Reverse [LZipper (Reverse "") 'a' "bc"])
              (LZipper (Reverse "a") 'b' "c")
              [LZipper (Reverse "ba") 'c' ""])
-- aBc -> Abc *aBc* abC

(I'm using capitals and asterisks to indicate the focal point of the zipper.)

---

I'm trying to work with two-dimensional grids with a focus, represented as a zipper of zippers. Each inner zipper is a row of the grid. My end goal is to find paths through a grid by hopping from neighbour to neighbour.

Moving through the grid maintains the invariant that all the rows are focused on the same index. This makes it easy to focus on any of your neighbours.

type Grid a = LZipper (LZipper a)

up, down, left, right :: Grid a -> Maybe (Grid a)
up = bwd
down = fwd
left = traverse bwd
right = traverse fwd

extractGrid :: Grid a -> a
extractGrid = extract . extract
mkGrid :: (a, [a]) -> [(a, [a])] -> Grid a
mkGrid (x, xs) xss = mkZipper (mkZipper x xs) $ map (uncurry mkZipper) xss

Examples:

ghci> let myGrid = mkGrid ('a', "bc") [('d', "ef"), ('g', "hi")]
ghci> myGrid
LZipper (Reverse [])
        (LZipper (Reverse "") 'a' "bc")
        [LZipper (Reverse "") 'd' "ef",LZipper (Reverse "") 'g' "hi"]
-- +-------+ 
-- | A b c |
-- | d e f |
-- | g h i |
-- +-------+

ghci> return myGrid >>= right >>= down
Just (LZipper (Reverse [LZipper (Reverse "a") 'b' "c"])
              (LZipper (Reverse "d") 'e' "f")
              [LZipper (Reverse "g") 'h' "i"])
-- +-------+ 
-- | a b c |
-- | d E f |
-- | g h i |
-- +-------+

What I want is the equivalent of LZipper's duplicate for grids: a function that takes a grid and produces a grid of all the ways you could look at the grid, with the focus on the current way you're looking at it.

duplicateGrid :: Grid a -> Grid (Grid a)

What I'm expecting:

duplicateGrid myGrid
+-------------------------------+
| ********* +-------+ +-------+ |
| * A b c * | a B c | | a b C | |
| * d e f * | d e f | | d e f | |
| * g h i * | g h i | | g h i | |
| ********* +-------+ +-------+ |
| +-------+ +-------+ +-------+ |
| | a b c | | a b c | | a b c | |
| | D e f | | d E f | | d e F | |
| | g h i | | g h i | | g h i | |
| +-------+ +-------+ +-------+ |
| +-------+ +-------+ +-------+ |
| | a b c | | a b c | | a b c | |
| | d e f | | d e f | | d e f | |
| | G h i | | g H i | | g h I | |
| +-------+ +-------+ +-------+ |
+-------------------------------+

I tried duplicateGrid = duplicate . duplicate. This has the correct type, but (assuming that I interpreted the show output correctly, which I probably didn't) it only gives me grids focused somewhere on the first column:

(duplicate . duplicate) myGrid
+-------------------------------+
| ********* +-------+ +-------+ |
| * A b c * | a b c | | a b c | |
| * d e f * | D e f | | d e f | |
| * g h i * | g h i | | G h i | |
| ********* +-------+ +-------+ |
| +-------+ +-------+ +-------+ |
| | A b c | | a b c | | a b c | |
| | d e f | | D e f | | d e f | |
| | g h i | | g h i | | G h i | |
| +-------+ +-------+ +-------+ |
| +-------+ +-------+ +-------+ |
| | A b c | | a b c | | a b c | |
| | d e f | | D e f | | d e f | |
| | g h i | | g h i | | G h i | |
| +-------+ +-------+ +-------+ |
+-------------------------------+

I also tried duplicateGrid = duplicate . fmap duplicate. Assuming once again that I'm capable of interpreting the show output, this gave me something that both contained the wrong grids and had the focuses of the rows misaligned, such that moving down would also move you along:

(duplicate . fmap duplicate) myGrid
+-------------------------------+
| ********* +-------+ +-------+ |
| * A b c * | D e f | | G h i | |
| * a B c * | d E f | | g H i | |
| * a b C * | d e F | | g h I | |
| ********* +-------+ +-------+ |
| +-------+ ********* +-------+ |
| | A b c | * D e f * | G h i | |
| | a B c | * d E f * | g H i | |
| | a b C | * d e F * | g h I | |
| +-------+ ********* +-------+ |
| +-------+ +-------+ ********* |
| | A b c | | D e f | * G h i * |
| | a B c | | d E f | * g H i * |
| | a b C | | d e F | * g h I * |
| +-------+ +-------+ ********* |
+-------------------------------+

This feels like it'd be an easy question for those in the know, but it's making my head spin. I suppose I could hand-crank a function which calls up, down, left and right, but I feel like the comonadic machinery ought to be able to do it for me. What is the correct implementation of duplicateGrid?

Answer 1

It's a bit of an issue here that we're trying to compose Grid with itself, because this setup gives us way too many incorrect ways to implement a duplicate with the right type. It's useful to consider the general case where the composed comonads aren't necessarily the same.

Suppose we have f and g comonads. The type of duplicate becomes:

duplicate :: f (g a) -> f (g (f (g a)))

We can get the following solely using the Comonad instances:

duplicate . fmap duplicate :: f (g a) -> f (f (g (g a)))

From this it becomes apparent that we need to swap f and g in the middle.

There's a type class called Distributive that has the method we want.

class Functor g => Distributive g where
    distribute :: Functor f => f (g a) -> g (f a)

In particular, we need to implement Distributive g, and then duplicate for the composed comonad can be implemented as:

duplicate = fmap distribute . duplicate . fmap duplicate

However, the documentation in Distributive says that values of g must have the exact same shape, so we can zip together an arbitrary number of copies without loss of information.

To illustrate this, if Vec n a is an n-sized vector, then distribute :: [Vec n a] -> Vec n [a] is just matrix transposition. It's necessary to pin the down size of the inner vector beforehand, because transposition on a "ragged" matrix must drop some elements, and that's not lawful behavior. Infinite streams and zippers also distribute fine, as they too have just one possible size.

Zipper is not a lawful Distributive because Zipper contains values with differently sized contexts. Still, we can implement improper distribution that supposes uniform context sizes.

Below I'll implement duplicate for Grid in terms of improper distribution for the underlying lists.

Alternatively, one could just roll up their sleeves and implement a transposition function on Zipper (Zipper a) directly. I actually did this, but it gave me a headache and I'm far from being confident that it's correct. It's better to make the types as general as possible, in order to narrow down the space of possible implementations, so there's less room for errors.

I'm going to omit Reverse in order to reduce syntactic noise; I hope you excuse me.

{-# language DeriveFunctor #-}

import Control.Comonad
import Data.List
import Control.Monad

data Zipper a = Zipper [a] a [a] deriving (Eq, Show, Functor)

lefts, rights :: Zipper a -> [a]
lefts  (Zipper ls _ _) = ls
rights (Zipper _ _ rs) = rs

bwd :: Zipper a -> Maybe (Zipper a)
bwd (Zipper [] _ _) = Nothing
bwd (Zipper (l:ls) a rs) = Just $ Zipper ls l (a:rs)

fwd :: Zipper a -> Maybe (Zipper a)
fwd (Zipper _ _ []) = Nothing
fwd (Zipper ls a (r:rs)) = Just $ Zipper (a:ls) r rs

instance Comonad Zipper where
  extract (Zipper _ a _) = a
  duplicate z =
    Zipper (unfoldr (fmap (join (,)) . bwd) z) z (unfoldr (fmap (join (,)) . fwd) z)

We can distribute lists if we know their length beforehand. Since Haskell lists can be infinite, we should measure length with possibly infinite lazy naturals. An alternative solution to measuring length would be using a "guide" list along which we can zip other lists. However, I would rather not assume in the distribution functions that such a dummy list is always available.

data Nat = Z | S Nat

length' :: [a] -> Nat
length' = foldr (const S) Z

distList :: Functor f => Nat -> f [a] -> [f a]
distList Z     fas = []
distList (S n) fas = (head <$> fas) : distList n (tail <$> fas)

Of course, this fails with runtime exceptions if our length assumption is incorrect.

We can distribute Zippers by distributing their focuses and contexts, provided that we know the lengths of the contexts:

distZipper :: Functor f => Nat -> Nat -> f (Zipper a) -> Zipper (f a)
distZipper l r fz = Zipper
  (distList l (lefts <$> fz)) (extract <$> fz) (distList r (rights <$> fz))

Finally, we can duplicate Grids in the way we saw before, but first we have to determine the shape of the inner Zippers. Since we assume that all inner Zippers have the same shape, we only look at the Zipper in the focus:

duplicateGrid :: Grid a -> Grid (Grid a)
duplicateGrid grid@(Zipper _ (Zipper ls _ rs) _) = 
    fmap (distZipper (length' ls) (length' rs)) $ duplicate $ fmap duplicate grid

Testing this (as you must have already experienced) is pretty awful, and I haven't yet gotten around to check even a two-by-two case by hand.

Still, I'm fairly confident in the above implementation, since the definitions are highly constrained by the types.