gol.org

Monad

class Functor m => Monad m where
  pure :: a -> m a
  join :: m (m a) -> m a
  -- or
  bind :: (a -> m b) -> m a -> m b

Monad specifies how nested container “collapses”.

Comonad

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

Comonad specifies how a container “duplicates”.

An example of monad/comonad

Haskell library for State and Store.

type State s a = s -> (a, s)
type Store s a = (s -> a, s)

instance Monad (State s) where
  pure :: a -> s -> (s, a)
  pure a = \s -> (s, a)

  bind :: (a -> (s -> (s, b))) -- a -> m b
       -> (s -> (s, a))        -- m a
       -> (s -> (s, b))        -- m b
  bind f g = \s -> let (s', a) = g s
                       (s'', b) = (f a) s'
                    in (s'', b)

instance Comonad (Store s) where
  extract :: (s -> a, s) -> a
  extract (f, s) = f s

  extend :: ((s -> a, s) -> b)    -- w a -> b
         -> (s -> a, s)           -- w a
         -> (s -> b, s)           -- w b
  extend f (g, s) = (\s' -> f (g, s'), s)

Applications:

State

Mutable state simulation, parser

Store

A focused store (s acts like an index, and s->a is an indexed store)

A concrete focused store type

A doubly-ended infinite list - zipper.

type Zipper a = ([a], a, [a])

goLeft :: Zipper a -> Zipper a
goLeft ((a:as), curr, bs) = (as, a, (curr:bs))

goRight :: Zipper a -> Zipper a
goRight (as, curr, (b:bs)) = ((curr:as), b, bs)

-- Zipper a ~ Store Integer a
--            (Integer -> a, Integer)

Zipper comonad

instance Comonad Zipper where
  extract :: ([a], a, [a]) -> a
  extract (as, curr, bs) = curr

  extend :: (([a], a, [a]) -> b) -- w a -> b
         -> ([a], a, [a])        -- w a
         -> ([b], b, [b])        -- w b
  extend f (as, c, bs) =
    let b = f (as, c, bs)
    in (..., b, ...
  -- may be too complicated to express, let's turn to duplicate

  duplicate :: Zipper a -> Zipper (Zipper a)
  duplicate :: Zipper a -> ([Zipper a], Zipper a, [Zipper a])
  duplicate z = (iterate1 goLeft z, z, iterate1 goRight z)
       where iterate1 :: (a -> a) -> a -> [a]
             iterate1 f = drop 1 . iterate f

  -- now it's a lot easier
  extend :: (Zipper a -> b) -- w a -> b
         -> Zipper a        -- w a
         -> Zipper b        -- w b
  extend f z = fmap f (duplicate z)

Zipper 2D

An infinite 2d array.

type Zipper2D a = Zipper (Zipper a)

-- Zipper2D a ~ Store (Integer,Integer) a

Note: comonad implementation for zipper2d isn’t just trivially compose two zipper comonad. It involves in an extra layer of transposition.

Game of life

For the context of game of life, let’s define two aliases:

type Cell = Bool
type World a = Zipper2D a

rule :: World Cell -> Cell
rule w = case num_of_neighbors w of
           n | n < 2 -> False
           n | n in [2,3] -> True
           n | n > 3 -> False

Simulation!

step :: World Cell -> World Cell
step = extend rule

-- extend :: Comonad w => (w a -> b) -> w a -> w b

That’s it!

Read further

• https://chrispenner.ca/posts/conways-game-of-life
• https://javran.github.io/posts/2014-08-22-comonad-zipper-and-conways-game-of-life.html

gol_zipper_comonad.hs

{-# LANGUAGE DeriveFunctor #-}

import Data.List

class (Functor w) => Comonad w where
  extract :: w a -> a

  duplicate :: w a -> w (w a)
  duplicate = extend id

  extend :: (w a -> b) -> w a -> w b
  extend f wa = fmap f (duplicate wa)


data Zipper a = Zipper { curr :: a
                       , left :: [a]
                       , right :: [a]
                       }
                deriving (Functor)

goLeft :: Zipper a -> Zipper a
goLeft (Zipper c (x:l) r) = Zipper x l (c:r)

goRight :: Zipper a -> Zipper a
goRight (Zipper c l (y:r)) = Zipper y (c:l) r

newtype Zipper2D a = Zipper2D { runZipper2D :: Zipper (Zipper a) }
  deriving (Functor)

iterate1 :: (a -> a) -> a -> [a]
iterate1 f = tail . iterate f

instance Comonad Zipper where
  extract z = curr z
  duplicate z = Zipper z (iterate1 goLeft z) (iterate1 goRight z)

transposeZ :: Zipper (Zipper a) -> Zipper (Zipper a)
transposeZ zz = Zipper col0 colsleft colsright
  where col0 = (fmap curr zz)
        colsleft = (fmap . fmap) curr $ iterate1 (fmap goLeft) zz
        colsright = (fmap . fmap) curr $ iterate1 (fmap goRight) zz

instance Comonad Zipper2D where
  extract zz = curr $ curr $ runZipper2D zz
  duplicate zz = Zipper2D $ dup $ runZipper2D zz
    where dup :: Zipper (Zipper a) -> Zipper (Zipper (Zipper2D a))
          dup zz = (fmap . fmap) Zipper2D $ fmap transposeZ $ duplicate $ fmap duplicate zz

fromList :: a -> [a] -> Zipper a
fromList def [] = Zipper def (repeat def) (repeat def)
fromList def (x:xs) = Zipper x (repeat def) (xs ++ repeat def)

fromList2D :: a -> [[a]] -> Zipper2D a
fromList2D def [] = Zipper2D $ Zipper defrow defrows defrows
  where -- defrow :: Zipper a
        defrow = Zipper def (repeat def) (repeat def)
        -- defrows :: [Zipper a]
        defrows = repeat defrow

fromList2D def (r:rs) = Zipper2D $ Zipper (fromList def r) defrows (fromRows rs)
  where
  -- defrow :: Zipper a
  defrow = Zipper def (repeat def) (repeat def)
  -- defrows :: [Zipper a]
  defrows = repeat defrow
  -- fromRows :: [[a]] -> [Zipper a]
  fromRows [] = defrows
  fromRows (x:xs) = (fromList def x) : fromRows xs

toList :: Int -> Zipper a -> [a]
toList 0 _ = []
toList n z = (curr z) : toList (n - 1) (goRight z)

toList2D :: (Int, Int) -> Zipper2D a -> [[a]]
toList2D (h, w) (Zipper2D z) = map (toList w) $ toList h z

neighbors :: Zipper2D a -> [a]
neighbors (Zipper2D z) =
  [ curr . goLeft . curr . goLeft   -- top left
  , curr . curr . goLeft            -- top
  , curr . goRight . curr . goLeft  -- top right
  , curr . goLeft . curr            -- left
  , curr . goRight . curr           -- right
  , curr . goLeft . curr . goRight  -- bottom left
  , curr . curr . goRight           -- bottom
  , curr . goRight . curr . goRight -- bottom right
  ] <*> [z]

type Cell = Bool

rule :: Zipper2D Cell -> Cell
rule z = case length aliveNeighbors of
           n | n < 2 -> False
           n | n == 2 -> curr $ curr $ runZipper2D z
           n | n == 3 -> True
           n | n > 3 -> False
  where aliveNeighbors = filter id (neighbors z)

step :: Zipper2D Cell -> Zipper2D Cell
step = extend rule

print2D :: (Int, Int) -> Zipper2D Cell -> String
print2D (h, w) z = concat $ intersperse "\n" $ (map . map) printCell $ toList2D (h,w) z
  where printCell True = 'o'
        printCell False = ' '

main :: IO ()
main = do
  let z = fromList2D False [[True, True, False], [True, True, True], [False, True, False]]
  mapM_ (putStrLn . print2D (5, 5)) $ take 5 $ iterate step z