Cellular Christmas Tree

This post is late, the season has passed, and I am writing this in one of the least Christmasy places. Yet I like this little diversion so much that I’ll share it with you. Just look at how heart-warming this looks.

If you’re in the midst of a paper crisis, one of the best ways to procrastinate is to learn something you haven’t got around to for ages and doesn’t in any way contribute towards your paper. In my case, this was comonads.

It’s not that I didn’t know what comonads were. They are the dual concept of monads in category theory, but this sort of lost its meaning once I realised I don’t know what a monad is.

After some digging and head-scratching, I realised comonads are good for computing from a context. In comonad explanations, you often find zippers, multi-dimensional arrays, and streams as example instances, used in everything from cellular automata to dataflow analysis. In this post, we focus on zippers to implement cellular automata.

Below, we first give an overview of the comonad typeclass in Haskell and write out the instance for zippers. Then using the primitives of the typeclass, we build a blinking Christmas tree and briefly look at a way of displaying it finitely.

Comonad typeclass primer

Although hearing comonads are the dual of monads at a categorical level didn’t help me conceptually, it helps me remember the signatures of its primitives. For return, bind, and join of monads, there are coreturn, cobind, and cojoin in comonads. The function arrows in the signature of these functions are helpfully reversed. As one might expect, we can define cobind in terms of cojoin. This is what they mean when they say comonads are just the dual concept of monads, though without further explanation it is not as helpful as some think! These functions are also given different names in Haskell, extract, extend, and duplicate respectively. Whether these names make the concept clearer or more confusing is a source of lively discussions.

class Functor w => Comonad w where
  extract   :: w a -> a
  duplicate :: w a -> w (w a)
  extend    :: (w a -> b) -> w a -> w b
  extend f cm = fmap f (duplicate cm)

I know the definition is not terribly exciting after I gave it away in the explanation. Perhaps the interesting bit is the simple definition of extend in terms of duplicate. In particular, f in extend does some form of reduction from the context and this is applied over duplicate of a comonad instance. Intuitively, extend’s job is to use f to compute new focus points. This implies that duplicate’s function is to encapsulate the instance within itself with different points in focus.

OK. I know. That explanation was less than intuitive. Let’s see an instance instead. The data structure of interest today is a zipper. You can think of it as a list with a focus¹. It is defined along with helpful functions to change the focus point.

data Zipper a = Zipper [ a ] a [ a ] deriving Functor

left, right :: Zipper a -> Zipper a
left  (Zipper (l:ls) a rs) = Zipper ls l (a:rs)
right (Zipper ls a (r:rs)) = Zipper (a:ls) r rs

The middle parameter is the focus point and we have bunch of elements to the left and right. We’ll use zippers with infinite number of elements, but there isn’t a fundamental reason that has to be the case elsewhere. So you can think of a zipper as an infinite tape with a focus and left & right functions as shifting the tape.

Let’s get to the comonad instance for Zipper. The extract function is pleasingly dull and extracts the focus of the zipper. The duplicate function is slightly more interesting. It makes shifted copies of the zipper in a zipper where the number of shifts is determined by the direction and distance from the focus point of the enclosing zipper².

instance Comonad Zipper where
  extract (Zipper _ a _) = a
  duplicate u = Zipper (tail $ iterate left u) u (tail $ iterate right u)

If you’re still unsure about zippers and comonads there are better explanations of them than that of mine (such as those by Dan Piponi and Bartosz Milewski) which you can jump in before coming back for the Christmas tree. Also I am too cheap to discuss the laws that needs to be satisfied by a comonad instance as they are not enforcable by the Haskell type system. This might be another reason to check other tutorials.

Cellular automata for Christmas tree

Now that we are equipped with the full power of comonads, we can proceed to animate a Christmas tree—admittedly, an underwhelming use case.

We will use two cellular automata. First to grow the tree and then another to make it blink. We need an initial configuration to start the whole process and as promised, it is a single dot on an infinite tape.

initConf = Zipper (repeat 0) 1 (repeat 0)

Any respectable Christmas tree would have at least two dimensions and this zipper represents only the top of the tree. We heighten it by evolving this initial configuration via the reduction grow and stack the generations one below the other³.

grow :: Zipper Int -> Int
grow (Zipper (l:_) a (r:_)) = if l == r then 0 else 1

Here grow’s type signature corresponds exactly to that expected by the extend function. Functionally, it is the XOR of the left and right neighbours⁴.

If you evolve some number of generations, stack successive generations one after another, and print it on your terminal, you obtain a fine looking ASCII tree. In each generation, the farthest left and right 1-cells have one farther 0-cell. This cell, then, has a 0-cell and a 1-cell as its neighbours. In the next generation, these 0-cells become 1-cells and we get a triangular shape for stacking configurations. In a terminal, since the height of a letter is often longer than its width, we get a nice top angle suitable for a tree.

Now that we have a tree (of infinite height), we can focus on making it blink using the blink reduction.

blink :: Zipper Int -> Int
blink (Zipper _ 0 _) = 0
blink (Zipper (l1:l2:_) a (r1:r2:_)) = 1 + (l1 + l2 + a + r1 + r2) `mod` 3

It is constructed so that 0 is treated as dead space and maps to itself regardless the context and no other value ever maps to it (by adding one to a non-negative expression). We compute modulo three of a five-cells-wide window which gives us sufficiently “random” blinking pattern and three symbols to shift through.

With these two reductions, all we need is grow to generate as many configurations as we like the height of the tree to be and blink to animate it. The generations produced using grow will act as initial configurations of the automaton with the transition function blink. We can exploit Haskell’s laziness to generate a comprehensive tree and worry about its height, width, and number of animation frames once we want to display it.

trees :: [ [ Zipper Int ] ]
trees = transpose $ iterate (extend blink) <$> tree
  where
  tree = iterate (extend grow) initConf

Repeated application of grow through iterate produces tapes to stack and we use each of those configurations with blink to animate. All transpose gives is a list of frames of trees instead of a list of lists of configurations.

Displaying infinity

This is the trivial bit of it. Since the tree is vertically symmetric on the zipper focus, we can take equal number of items on each side to set the width and take as many tapes as we want to set the height.

frame :: Int -> Int -> [ Zipper a ] -> [ [ a ] ]
frame halfWidth height zs = take height $ frameConfig <$> zs
  where
  frameConfig (Zipper ls a rs) =
    reverse (take (halfWidth - 1) ls) ++ a : take (halfWidth - 1) rs

Asterisks, pluses, and x make better tree ornaments than integers.

display :: Int -> Char
display 0 = ' '
display 1 = 'x'
display 2 = '*'
display 3 = '+'

Bringing all of this together we can print frames forever (though blink behaves periodically) with some UNIX trickery to clear the terminal and inserting delays so our petty human eyes can follow the blinking.

main = do
  let (halfWidth, height) = (17, 16)
  forM_ trees $ \fr -> do
    putStrLn (intercalate "\n" (fmap display <$> frame halfWidth height fr))
    threadDelay 500000
    putStr "\ESC[2J" -- UNIX trickery to clear the terminal.

Concluding thoughts

Here it is, another comonad tutorial. I don’t think it is any better than the others, but it produces something different. A good exercise for strengthening your comonad-fu would be coding Conway’s Game of Life with the rules encoded as a reduction and the board represented as a two dimensional array. Perhaps you pursue understanding it categorically; in that case, come and tell me about it.

Happy past, present, and future holidays.

The full program is below for your convenience.

{-# LANGUAGE DeriveFunctor #-}

module Main where

import Data.List (transpose, intercalate)

import Control.Concurrent (threadDelay)
import Control.Monad (forM_)

class Functor w => Comonad w where
  extract   :: w a -> a
  duplicate :: w a -> w (w a)
  extend    :: (w a -> b) -> w a -> w b
  extend f cm = fmap f (duplicate cm)

data Zipper a = Zipper [ a ] a [ a ] deriving Functor

left, right :: Zipper a -> Zipper a
left  (Zipper (l:ls) a rs) = Zipper ls l (a:rs)
right (Zipper ls a (r:rs)) = Zipper (a:ls) r rs

instance Comonad Zipper where
  extract (Zipper _ a _) = a
  duplicate u = Zipper (tail $ iterate left u) u (tail $ iterate right u)

initConf = Zipper (repeat 0) 1 (repeat 0)

grow :: Zipper Int -> Int
grow (Zipper (l:_) a (r:_)) = if l == r then 0 else 1

blink :: Zipper Int -> Int
blink (Zipper _ 0 _) = 0
blink (Zipper (l1:l2:_) a (r1:r2:_)) = 1 + (l1 + l2 + a + r1 + r2) `mod` 3

trees :: [ [ Zipper Int ] ]
trees = transpose $ iterate (extend blink) <$> tree
  where
  tree = iterate (extend grow) initConf

frame :: Int -> Int -> [ Zipper a ] -> [ [ a ] ]
frame halfWidth height zs = take height $ frameConfig <$> zs
  where
  frameConfig (Zipper ls a rs) =
    reverse (take (halfWidth - 1) ls) ++ a : take (halfWidth - 1) rs

display :: Int -> Char
display 0 = ' '
display 1 = 'x'
display 2 = '*'
display 3 = '+'

main = do
  let (halfWidth, height) = (17, 16)
  forM_ trees $ \fr -> do
    putStrLn (intercalate "\n" (fmap display <$> frame halfWidth height fr))
    threadDelay 500000
    putStr "\ESC[2J" -- UNIX trickery to clear the terminal.