Cellular Automata Using Comonads

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  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:

import Control.Comonad
import Control.Applicative
import System.Process (rawSystem)
import Universe
data Cell = Dead | Alive
    deriving (Eq, Show)
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)
rule :: Universe2 Cell -> Cell
rule u
    | nc == 2   = extract u
    | nc == 3   = Alive
    | otherwise = Dead
    where nc = length $ filter (==Alive) (neighbours u)
renderLife :: Universe2 Cell -> String
renderLife = unlines . map concat . map (map renderCell) . takeRange2 (-7, -7) (20, 20)
    where renderCell Alive = "██"
          renderCell Dead  = "  "
fromList :: a -> [a] -> Universe a
fromList d (x:xs) = Universe (repeat d) x (xs ++ repeat d)
fromList2 :: a -> [[a]] -> Universe2 a
fromList2 d = Universe2 . fromList ud . fmap (fromList d)
    where ud = Universe (repeat d) d (repeat d)
cells = [ [ Dead, Alive,  Dead]
        , [Alive,  Dead,  Dead]
        , [Alive, Alive, Alive] ]
main = do
    gameLoop $ fromList2 Dead cells
gameLoop :: Universe2 Cell -> IO a
gameLoop u = do
    getLine
    rawSystem "clear" []
    putStr $ renderLife u
    gameLoop (u =>> rule)