├── README.md
└── Life.hs


/README.md:
--------------------------------------------------------------------------------
1 | # GameOfLife
2 | Conway's Game of Life using a comonad
3 | 


--------------------------------------------------------------------------------
/Life.hs:
--------------------------------------------------------------------------------
  1 | {-# language TypeFamilies #-}
  2 | module Life where
  3 | import Data.List
  4 | import Control.Comonad
  5 | import Data.Distributive
  6 | import Data.Functor.Compose
  7 | import Data.Functor.Foldable
  8 | 
  9 | -- Infinite stream
 10 | data Stream a = (:>) { headS :: a
 11 |                      , tailS :: Stream a}
 12 |   deriving Functor
 13 | 
 14 | infixr 5 :>
 15 | 
 16 | -- Stream is both a recursive and a corecursive data structure
 17 | -- We can fold and unfold it using cata and ana
 18 | 
 19 | data Pair a x = P a x
 20 |   deriving Functor
 21 | 
 22 | type instance Base (Stream a) = Pair a
 23 | 
 24 | instance Recursive (Stream a) where
 25 |     project (a :> as) = P a as
 26 | 
 27 | instance Corecursive (Stream a) where
 28 |     embed (P a as) = a :> as
 29 | 
 30 | -- Stream is distributive over any functor
 31 | instance Distributive Stream where
 32 |     distribute :: Functor f => f (Stream a) -> Stream (f a)
 33 |     -- distribute stms = (headS <$> stms) :> distribute (tailS <$> stms)
 34 |     -- or, using corecursion:
 35 |     distribute = ana (\fStms -> P (headS <$> fStms) (tailS <$> fStms))
 36 | 
 37 | instance Show a => Show (Stream a) where
 38 |   show = unwords . fmap show . take 6 . toInfList
 39 | 
 40 | repeatS :: a -> Stream a
 41 | repeatS = ana (\a -> P a a)
 42 | 
 43 | iterateS :: (a -> a) -> a -> Stream a
 44 | iterateS f = ana (\a -> P a (f a))
 45 | 
 46 | -- The first argument is the padding
 47 | fromListS :: a -> [a] -> Stream a
 48 | fromListS z = ana go
 49 |   where go [] = P z []
 50 |         go (a : as) = P a as
 51 | 
 52 | toInfList :: Stream a -> [a]
 53 | toInfList = cata (\(P a as) -> a : as)
 54 | 
 55 | -- Bidirectional infinite stream
 56 | -- Contains a backward and a forward stream
 57 | data Cursor a = Cur { bwStm :: Stream a
 58 |                     , fwStm :: Stream a }
 59 |   deriving Functor
 60 | 
 61 | instance Distributive Cursor where
 62 |     distribute :: Functor f => f (Cursor a) -> Cursor (f a)
 63 |     distribute fCur = Cur (distribute (bwStm <$> fCur)) 
 64 |                           (distribute (fwStm <$> fCur))
 65 | 
 66 | instance Comonad Cursor where
 67 |   extract (Cur _ (a :> _)) = a
 68 |   duplicate bi = Cur (iterateS moveBwd (moveBwd bi)) 
 69 |                      (iterateS moveFwd bi)
 70 | 
 71 | instance Show a => Show (Cursor a) where
 72 |   show (Cur _ fw) = show fw ++ "\n"
 73 | 
 74 | moveFwd :: Cursor a -> Cursor a
 75 | moveFwd (Cur bw (a :> as)) = Cur (a :> bw) as
 76 | 
 77 | moveBwd :: Cursor a -> Cursor a
 78 | moveBwd (Cur (a :> as) fw) = Cur as (a :> fw)
 79 | 
 80 | repeatCur :: a -> Cursor a
 81 | repeatCur a = Cur (repeatS a) (repeatS a)
 82 | 
 83 | listToCur :: a -> [a] -> Cursor a
 84 | listToCur z as = Cur (repeatS z) (fromListS z as)
 85 | 
 86 | get2 :: Cursor a -> [a]
 87 | get2 cur = [extract (moveBwd cur), extract (moveFwd cur)]
 88 | 
 89 | get3 :: Cursor a -> [a]
 90 | get3 cur = [extract (moveBwd cur), extract cur, extract (moveFwd cur)]
 91 | 
 92 | 
 93 | data Cell = Empty | Full
 94 |   deriving Enum
 95 | 
 96 | instance Show Cell where
 97 |   show Empty = "."
 98 |   show Full  = "o"
 99 | 
100 | -- 2-dimensional infinite grid
101 | -- A bidirectional stream of bidirectional streams
102 | 
103 | type Grid a = Compose Cursor Cursor a
104 | 
105 | instance (Comonad w2, Comonad w1, Distributive w1) => Comonad (Compose w2 w1) where
106 |     extract = extract . extract . getCompose
107 |     duplicate = fmap Compose . Compose .
108 |                 fmap distribute . duplicate . fmap duplicate .
109 |                 getCompose
110 | 
111 | instance {-# OVERLAPPING #-} Show a => Show (Grid a) where
112 |   show = show . getCompose
113 | 
114 | matrixToGrid :: a -> [[a]] -> Grid a
115 | matrixToGrid z = Compose . listToCur (repeatCur z) . fmap (listToCur z)
116 | 
117 | get8neighbors :: Grid a -> [a]
118 | get8neighbors (Compose grid) =
119 |   get3 (extract $ moveBwd grid) ++
120 |   get2 (extract grid) ++
121 |   get3 (extract $ moveFwd grid)
122 | 
123 | countNeighbors :: Grid Cell -> Int
124 | countNeighbors = sum . fmap fromEnum . get8neighbors
125 | 
126 | -- Calculate next generation at the current location in the Grid
127 | 
128 | nextGen :: Grid Cell -> Cell
129 | nextGen grid
130 |   | cnt == 3 = Full
131 |   | cnt == 2 = extract grid
132 |   | otherwise = Empty
133 |   where
134 |       cnt = countNeighbors grid
135 | 
136 | generations :: Grid Cell -> [Grid Cell]
137 | generations = iterate $ extend nextGen
138 | 
139 | parseChar :: Char -> Cell
140 | parseChar '.' = Empty
141 | parseChar 'o' = Full
142 | parseChar _ = error "Invalid grid input"
143 | 
144 | main :: IO ()
145 | main = do
146 |   -- A glider pattern
147 |   let matrix = fmap (fmap parseChar) [".o.", "..o", "ooo", "...", "..."]
148 |       grid = matrixToGrid Empty matrix
149 |   print $ take 9 (generations grid)
150 | 


--------------------------------------------------------------------------------