I have recently come across an article about implementing a one-dimensional cellular automaton using comonads. But this material is a bit outdated. Therefore, I’ve decided to write an article of my own and consider two-dimensional cellular automata by the example of The Game of Life:

Universe

Let’s take a look at Universe data type that is defined the following way:

data Universe a = Universe [a] a [a] It’s a doubly infinite list focusing on some element that we can shift using the following functions:

left, right :: Universe a -> Universe a left (Universe (a:as) x bs) = Universe as a (x:bs) right (Universe as x (b:bs)) = Universe (x:as) b bs

It’s basically a zipper, but we can consider it as a constant C-pointer to the infinite memory area as all increment and decrement operations are applicable to it. But how do we dereference it? Let’s define the function that will get a focused value:

extract :: Universe a -> a extract (Universe _ x _) = x

For example, Universe [-1, -2..] 0 [1, 2..] represents all integers. Nevertheless, Universe [0, -1..] 1 [2, 3..] are also integers but with slightly changed context (we point to another element).

To get all powers of 2, apply (2**) function to Universe of integers. It’s quite simple to determine the instance of Fucntor class that follows all the laws:

instance Functor Universe where fmap f (Universe as x bs) = Universe (fmap f as) (f x) (fmap f bs) -- accordingly powersOf2 = fmap (2**) (Universe [-1, -2..] 0 [1, 2..]) -- ..0.25, 0.5, 1, 2, 4..

In a cellular automaton cell values depend on the values of all other cells of the previous step. Therefore, we can create Universe of all shifts and a rule for their convolution.

duplicate :: Universe a -> Universe (Universe a) duplicate u = Universe (tail $ iterate left u) u (tail $ iterate right u)

Convolution rule should be of Universe a -> a type. Thus, a rule example for Universe Bool can be the following:

rule :: Universe Bool -> Bool rule u = lx /= cx where lx = extract $ left u cx = extract u

Having applied the rule to Universe of all shifts, we get the following state of the automaton:

next :: Universe a -> (Universe a -> a) -> Universe a next u r = fmap r (duplicate u) -- accordingly un = Universe (repeat False) True (repeat False) `next` rule

Comonads

We can see that our functions follow the following rules:

extract . duplicate = id fmap extract . duplicate = id duplicate . duplicate = fmap duplicate . duplicate

Therefore, Universe forms a comonad and next function corresponds to (=>>) operator. A comonad is a monad dual. Thus, we can see the following analogies between their operations. For instance, join superposes embedded scopes, while duplicate, on the contrary, doubles the scope; return locates into the scope and extract extracts from it, etc.

A Two-Dimensional Cellular Automaton

Now, we can just as well implement a two-dimensional cellular automaton. To begin with, let’s declare a type of the two-dimensional Universe:

newtype Universe2 a = Universe2 { getUniverse2 :: Universe (Universe a) } In Haskell, it’s really simple to apply a function to embedded containers with the help of fmap composition. Thus, it’s no problem to write an instance of Functor class for Universe2.

instance Functor Universe2 where fmap f = Universe2 . (fmap . fmap) f . getUniverse2

We can make a comonad instance by analogy with a regular Universe. Since Universe2 is just a wrapper, we can define the methods using the current terms.

For example, it’s quite simple to execute extract twice. As for duplicate, in order to get shifts of embedded scopes, we should define a helper function:

instance Comonad Universe2 where extract = extract . extract . getUniverse2 duplicate = fmap Universe2 . Universe2 . shifted . shifted . getUniverse2 where shifted :: Universe (Universe a) -> Universe (Universe (Universe a)) shifted u = Universe (tail $ iterate (fmap left) u) u (tail $ iterate (fmap right) u)

That’s almost it! We just should define the rule and apply it with the help of (=>>). In The Game of Life, a new state of a cell depends on the state of neighboring cells. Thus, let’s define the function of their location:

nearest3 :: Universe a -> [a] nearest3 u = fmap extract [left u, u, right u] neighbours :: (Universe2 a) -> [a] neighbours u = [ nearest3 . extract . left , pure . extract . left . extract , pure . extract . right . extract , nearest3 . extract . right ] >>= ($ getUniverse2 u) Here’s the rule itself: data Cell = Dead | Alive deriving (Eq, Show) rule :: Universe2 Cell -> Cell rule u | nc == 2 = extract u | nc == 3 = Alive | otherwise = Dead where nc = length $ filter (==Alive) (neighbours u)

Summary

Thus, we can implement any cellular automaton by simply defining rule function. Thanks to lazy calculations, we get the infinite field as a present, though it leads to linear memory consumption.

Since we apply the rule to each element of the infinite list, to calculate the cells that have not been referred to, we will have to go through all the previous steps. Therefore, we should keep them in memory.

The source code of both files:

Universe.hs:

module Universe where import Control.Comonad data Universe a = Universe [a] a [a] newtype Universe2 a = Universe2 { getUniverse2 :: Universe (Universe a) } left :: Universe a -> Universe a left (Universe (a:as) x bs) = Universe as a (x:bs) right :: Universe a -> Universe a right (Universe as x (b:bs)) = Universe (x:as) b bs makeUniverse fl fr x = Universe (tail $ iterate fl x) x (tail $ iterate fr x) instance Functor Universe where fmap f (Universe as x bs) = Universe (fmap f as) (f x) (fmap f bs) instance Comonad Universe where duplicate = makeUniverse left right extract (Universe _ x _) = x takeRange :: (Int, Int) -> Universe a -> [a] takeRange (a, b) u = take (b-a+1) x where Universe _ _ x | a < 0 = iterate left u !! (-a+1) | otherwise = iterate right u !! (a-1) instance Functor Universe2 where fmap f = Universe2 . (fmap . fmap) f . getUniverse2 instance Comonad Universe2 where extract = extract . extract . getUniverse2 duplicate = fmap Universe2 . Universe2 . shifted . shifted . getUniverse2 where shifted :: Universe (Universe a) -> Universe (Universe (Universe a)) shifted = makeUniverse (fmap left) (fmap right) takeRange2 :: (Int, Int) -> (Int, Int) -> Universe2 a -> [[a]] takeRange2 (x0, y0) (x1, y1) = takeRange (y0, y1) . fmap (takeRange (x0, x1)) . getUniverse2

Life.hs: