Cellular automata are one of the "go to" examples for comonads in Haskell.
Dan Piponi wrote his article on using comonads to evaluate cellular automata back in 2006, and that was pretty much my introduction to comonads in general. He used a list zipper.
Today, I want to use something a little bit more general and maybe draw some pictures.
Minding The Store
To that end, let's define the Store Comonad.
{-# LANGUAGE DeriveFunctor #-}
import Control.Comonad
-- show
data Store s a = Store (s -> a) s deriving Functor
instance Comonad (Store s) where
extract (Store f s) = f s
duplicate (Store f s) = Store (Store f) s
-- /show
experiment :: Functor f => (s -> f s) -> Store s a -> f a
experiment k (Store f s) = f <$> k s
main = putStrLn "It typechecks, so it must be correct!"A Store s a describes some "test" that takes a configuration s and will produce a value of type a, where we also have some ambient initial configuration of type s that is known with which we could start the experiment.
The experiment combinator characterizes a Store completely. It lets you explore variations on the initial conditions of our test.
experiment :: Functor f => (s -> f s) -> Store s a -> f a
experiment k (Store f s) = f <$> k s Store gives you a little bit more power than we want in a cellular automaton, as you can do both relative and global addressing, but it happens to be a very general construction, so we'll start there. It has the benefit that if we decide we want to play with automata in more than 1 dimension all we have to do is change out the state type.
The Store comonad has a lot of different uses that aren't immediately obvious. It is used heavily inside of the lens library.
A Glimpse Down the Rabbit Hole
(This section is completely skippable and is included as a highly technical aside)
An interesting exercise for the advanced Haskeller is to flip the definition of experiment and take that as the definition for Store.
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE RankNTypes #-}
import Control.Comonad
-- show
newtype Pretext s a = Pretext {
runPretext :: forall f. Functor f => (s -> f s) -> f a
} deriving Functor
experiment :: Functor f => (s -> f s) -> Pretext s a -> f a
experiment f (Pretext k) = k f
-- /show
main = putStrLn "It typechecks, so it must be correct!"Defining the Comonad instance for that type is a particularly enlightening challenge.
If you replace the Functor constraint in the definition above with Applicative you get a Comonad I call the Bazaar. This Comonad is used to derive many of the most brain-bending Traversal and uniplate-derived combinators in lens.
The code for its Comonad instance is identical to the instance for Pretext above, but it can also be made Applicative.
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE RankNTypes #-}
import Control.Comonad
import Control.Applicative
-- show
newtype Bazaar s a = Bazaar {
runBazaar :: forall f. Applicative f => (s -> f s) -> f a
} deriving Functor
-- /show
main = putStrLn "It typechecks, so it must be correct!"If you try to search for the Store-like analogue to the Bazaar, you wind you looking at what Twan van Laarhoven called a FunList in "A non-regular data type challenge".
{-# LANGUAGE DeriveFunctor #-}
import Control.Comonad
import Control.Applicative
-- show
data FunList s a
= Done a
| More s (FunList s (s -> a))
deriving Functor
-- /show
main = putStrLn "It typechecks, so it must be correct!"An interesting exercise is to derive the Applicative and Comonad instances for FunList. This exercise is much easier than the Pretext and Bazaar derivations, but still quite challenging.
Surprisingly FunList is actually a less powerful type than Bazaar in the presence of infinite traversals as many tools you can build will not terminate when you manipulate an infinite traversal with them built using a FunList, but will terminate when they are constructed using the Bazaar!
Following the Rules
Stephen Wolfram described a rather concise encoding of 2-color automata that can only look at their neighbors in "A New Kind of Science".
We can encode his family of 2-color rules as a comonadic action:
rule :: Num s => Word8 -> Store s Bool -> Bool
rule w (Store f s) = testBit w $
0 & partsOf (taking 3 bits) .~ [f (s+1), f s, f (s-1)]That is rather dense, so let's unpack it.
Wolfram numbers his rules from 0 to 255 because if you look at the current cell and the neighbor to the left and right of it, we have 3 inputs to consider. Each is a Bool so we have 2^3 different results to give. If we bundle all those possible results together as the bits of a Word8, the Word8 perfectly describes all of the possible 2-color cellular automata that can look at the current and neighboring cells.
So now the trick is doing that indexing. To do so, first we need to figure out which bit in our Word8 we are interested in. To do that we need to use the 3 booleans we obtain by tweaking our position and asking to perform our "experiment" there at the slightly modified positions instead.
Now we want to compose 3 bits together into an Int. We could do this with a bunch of conditional logic, etc. but there is a slightly cute encoding we can get when we use lens.
bits provides a Traversal of the individual bits of any instance of Bits. (In the case of Integer, though, because it is infinite sadly the Traversal can never finish reassembling the Integer, and so it devolves to merely a Fold.
taking n t takes a Traversal t and yields a Traversal that only touches the first n targets of the original Traversal.
Therefore taking 3 bits is the Traversal of the first 3 bits of a number.
partsOf takes a Traversal and gives you a (slightly hinky) Lens to a list of all of the targets of the traversal. You can freely replace that list with a new list (of the same length!). It is only a law abiding Lens if you do not change the length of the list of targets, but even if you violate these assumptions it is well behaved operationally. In fact you can safely remove taking n from the definition of rule above, and its semantics do not change.
And finally, we can use the fact that every Lens is a valid Setter to make the assignment.
0 & partsOf (taking 3 bits) .~ [f (s+1), f s, f (s-1)]then builds an Int n between 0 and 7 by starting with a 0 and setting its first 3 bits accordingly.
With that in hand we can now test the nth bit of the rule number and obtain our result.
Since Store s forms a Comonad though, we can extend our rule n to obtain a new Store s Bool from out existing Store s Bool.
Now if we, say, extend (rule 110) we get a function from one world to a new world, where that
rule has been applied uniformly across the entire world at the same time.
extend (rule 110) :: Num s => Store s Bool -> Store s BoolBy choosing an appropriate number type for s we can choose the topology for our automaton to live on!
We could repeatedly run our rules with
slowLoop :: (Store s a -> a) -> Store s a -> [Store s a]
slowLoop f = iterate (extend f)Got the Memo?
...but we'd get explosive slowdown. Why?
After a each loop iteration we depend on 3x as many evaluations as we did for the iteration before, because each evaluation is asking for all of the other old versions of the old neighbors, etc.
So the trick is to memoize our function. The easiest way to do that without reasoning about IO is to use a memo combinator package like data-memocombinators or my own representable-tries. I'll buck my trend and use Luke's package instead of mine.
But which function?
We don't want to memoize the comonad algebra itself. The argument to that is of type Store s a, and memoizing function spaces of function spaces gets truly messy. Let's make a function that turns a value in our Store comonad into one that memoizes its answers by memoizing the experiment it contains.
tab :: Memo s -> Store s a -> Store s a
tab opt (Store f s) = Store (opt f) stab takes a way to memoize a function from the context of our Store and a Store and yields a new Store that memoizes its results.
Memo comes from data-memocombinators.
type Memo a = forall r. (a -> r) -> a -> rA value of type Memo a describes a memoization strategy for functions from values of type a. It takes a function and turns it into a function that memoizes its results. It does so in a completely pure way that is worth exploring in its own right, but...
If we just use the fact that integral provides us with such a memoization strategy that works for any Integral type, we can derive a smarter loop!
loop :: Integral s => (Store s a -> a) -> Store s a -> [Store s a]
loop f = iterate (extend f . tab integral)Here when we are given a new Store before each iteration we simply upgrade it to memoize its results for each position as it is asked before handing it to our rule for further evaluation.
Let's Do the Time Warp Again
Now let's timewarp back to the stone age and print out endless reams of paper filled with automaton states.
To do that we need a way to see what some slice of our world looks like:
-- TODO: copy the whole program below here
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveFunctor #-}
import Control.Comonad
import Control.Lens as L
import Data.Bits
import Data.Bits.Lens as L
import qualified Data.ByteString as Strict
import qualified Data.ByteString.Lazy as Lazy
import Data.MemoCombinators
import Data.Word
import Diagrams.Backend.SVG
import Diagrams.Prelude as D
import Text.Blaze.Svg.Renderer.Utf8
import Yesod
data Store s a = Store (s -> a) s deriving Functor
instance Comonad (Store s) where
extract (Store f s) = f s
duplicate (Store f s) = Store (Store f) s
experiment :: Functor f => (s -> f s) -> Store s a -> f a
experiment k (Store f s) = f <$> k s
rule :: Num s => Word8 -> Store s Bool -> Bool
rule w (Store f s) = testBit w $
0 L.& partsOf (taking 3 L.bits) .~ [f (s+1), f s, f (s-1)]
tab :: Memo s -> Store s a -> Store s a
tab opt (Store f s) = Store (opt f) s
loop :: Integral s => (Store s a -> a) -> Store s a -> [Store s a]
loop f = iterate (extend f . tab integral)
-- show
window :: (Enum s, Num s) => s -> s -> Store s a -> [a]
window l h = experiment $ \ s -> [s-l..s+h]
xo :: Bool -> Char
xo True = 'X'
xo False = ' '
main = mapM_ (putStrLn . map xo . window 50 0) $
take 50 $ loop (rule 110) $ Store (==0) 0
-- /showI probably should have told that thing stop printing a little sooner. Sorry. ;)
window varies our position on the number line up or down a bit so we can see several data points.
xo converts each result into a form we might want to see.
Then we put it all together and run Wolfram's rule 110 starting with a single point at position 0 as our initial condition.
Pretty as a Picture
It isn't the stone age any more.
Matt Sottile did a pretty looking forest fire cellular automata example a couple of years back. But he had to render everything by hand using OpenGL.
Nowadays we can draw pretty pictures using Brent Yorgey's awesome diagrams package rather than carve ASCII X's into the walls of our cave.
Now that we have the windows of data we want, all we need to do is turn each window into a a bunch of squares and stitch those rows together into a Diagram.
grid :: [[Bool]] -> Diagram SVG R2
grid = vcat . map (hcat . cell) where
cell b = unitSquare D.# fc (if b then black else white)This post was spawned from a discussion with Rein Henrichs on #haskell. He supplied the initial version of the diagrams code. His version was much prettier.
diagrams supports rendering to a ton of formats including SVG, so we can transform our diagram into a document using diagrams-svg and blaze-svg. We could also render it directly to cairo and get out a PNG, get out an HTML canvas, a postscript document, etc.
We could use the renderSVG function to generate a file on disk, but it also isn't the 80s. Command line tools that spit out files are passé. So lets just get our hands on the file here in memory as a ByteString and make sure it's strict to deal with the impedence mismatch between the tools I'm using.
svg :: Diagram SVG R2 -> Strict.ByteString
svg = Strict.concat . Lazy.toChunks .
renderSvg . renderDia SVG (SVGOptions (Width 400) Nothing)But is it Web Scale?
The School of Haskell supports running full-fledged web-based applications from an "active" Haskell snippet, so lets give it a try.
If we put them these pieces of code together you should be able to click run below and get out pretty pictures out of a custom web server that all but fits on your screen.
Click Run!
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveFunctor #-}
import Control.Comonad
import Control.Lens as L
import Data.Bits
import Data.Bits.Lens as L
import qualified Data.ByteString as Strict
import qualified Data.ByteString.Lazy as Lazy
import Data.MemoCombinators
import Data.Word
import Diagrams.Backend.SVG
import Diagrams.Prelude as D
import Text.Blaze.Svg.Renderer.Utf8
import Yesod
data Store s a = Store (s -> a) s deriving Functor
instance Comonad (Store s) where
extract (Store f s) = f s
duplicate (Store f s) = Store (Store f) s
experiment :: Functor f => (s -> f s) -> Store s a -> f a
experiment k (Store f s) = f <$> k s
rule :: Num s => Word8 -> Store s Bool -> Bool
rule w (Store f s) = testBit w $ 0 L.& partsOf (taking 3 L.bits) .~ [f (s+1), f s, f (s-1)]
tab :: Memo s -> Store s a -> Store s a
tab opt (Store f s) = Store (opt f) s
loop :: Integral s => (Store s a -> a) -> Store s a -> [Store s a]
loop f = iterate (extend f . tab integral)
window :: (Enum s, Num s) => s -> s -> Store s a -> [a]
window l h = experiment $ \ s -> [s-l..s+h]
grid :: [[Bool]] -> Diagram SVG R2
grid = cat unitY . reverse . map (hcat . map cell) where
cell b = unitSquare D.# fc (if b then black else white)
svg :: Diagram SVG R2 -> Strict.ByteString
svg = Strict.concat . Lazy.toChunks . renderSvg . renderDia SVG (SVGOptions (Width 400) Nothing)
data App = App
instance Yesod App
mkYesod "App" [parseRoutes| / ImageR GET |]
getImageR :: MonadHandler m => m TypedContent
getImageR = sendResponse $ toTypedContent (typeSvg, toContent img)
img = svg . grid . map (window 49 0) . take 50 . loop (rule 110) $ Store (==0) (0 :: Int)
main = warpEnv AppThat clocks in at 60 lines of code. In that much space we defined the Store comonad, defined a generic evaluator that can handle any of Wolfram's 2-color automata, built a system of memoization to avoid asymptotic slowdown, took a cross section of our universe, and then rendered it to a diagram and built a custom web server to display that content here on the internet.
Almost all of the components we built are generic. We can define new types of automata, try out new initial conditions, jump around in time, with some work we can support multiple colors, new topologies, render the same diagram to different file formats conditionally based on browser preferences. The code above can be edited live here in your browser or downloaded and run locally on your own machine.
In the interest of full disclosure, the SVG that is rendered is far from optimal. The diagrams crew is aware of the issue and they are hard at work improving the way diagrams streams primitives to its backends, allowing it to take advantage of all the glorious structure that they have inside the Diagram type described in Brent's excellent functional pearl. Currently the communication process between diagrams and the backend is duplicating the transformation matrix and styling on a per element basis, and this is resulting in a much inflated document. When those changes go into diagrams and diagrams-svg, then this example will become much faster with no changes to this code.
I hope this shows how you can use a little bit of theory and some of the more practical components of the Haskell ecosystem to accomplish a lot with very little code.
-- Edward Kmett August 15, 2013
