src/advent12/life.hs

   1 {-# LANGUAGE DeriveFunctor #-}
   2
   3 -- From https://gist.github.com/gatlin/21d669321c617836a317693aef63a3c3
   4
   5
   6 import Control.Applicative
   7 import Control.Comonad
   8
   9 import Control.Monad (forM_)
  10
  11 -- These two typeclasses probably make some people groan.
  12 class LeftRight t where
  13     left :: t a -> t a
  14     right :: t a -> t a
  15
  16 class UpDown t where
  17     up :: t a -> t a
  18     down :: t a -> t a
  19
  20 -- | An infinite list of values
  21 data Stream a = a :> Stream a
  22     deriving (Functor)
  23
  24
  25 -- * Stream utilities
  26
  27 -- | Allows finitary beings to view slices of a 'Stream'
  28 takeS :: Int -> Stream a -> [a]
  29 takeS 0 _ = []
  30 takeS n (x :> xs) = x : (takeS (n-1) xs)
  31
  32 -- | Build a 'Stream' from a generator function
  33 unfoldS :: (b -> (a, b)) -> b -> Stream a
  34 unfoldS f c = x :> unfoldS f d
  35     where (x, d) = f c
  36
  37 -- | Build a 'Stream' by mindlessly repeating a value
  38 repeatS :: a -> Stream a
  39 repeatS x = x :> repeatS x
  40
  41 -- | Build a 'Stream' from a finite list, filling in the rest with a designated
  42 -- default value
  43 fromS :: a -> [a] -> Stream a
  44 fromS def [] = repeatS def
  45 fromS def (x:xs) = x :> (fromS def xs)
  46
  47 -- | Prepend values from a list to an existing 'Stream'
  48 prependList :: [a] -> Stream a -> Stream a
  49 prependList [] str = str
  50 prependList (x:xs) str = x :> (prependList xs str)
  51
  52 -- | A 'Stream' is a comonad
  53 instance Comonad Stream where
  54     extract (a :> _) = a
  55     duplicate s@(a :> as) = s :> (duplicate as)
  56
  57 -- | It is also a 'ComonadApply'
  58 instance ComonadApply Stream where
  59     (f :> fs) <@> (x :> xs) = (f x) :> (fs <@> xs)
  60
  61 -- * Tapes, our workhorse
  62
  63 -- | A 'Tape' is always focused on one value in a 1-dimensional infinite stream
  64 data Tape a = Tape (Stream a) a (Stream a)
  65     deriving (Functor)
  66
  67 -- | We can go left and right along a tape!
  68 instance LeftRight Tape where
  69     left (Tape (l :> ls) c rs) = Tape ls l (c :> rs)
  70     right (Tape ls c (r :> rs)) = Tape (c :> ls) r rs
  71
  72 -- | Build out the left, middle, and right parts of a 'Tape' with generator
  73 -- functions.
  74 unfoldT
  75     :: (c -> (a, c))
  76     -> (c -> a)
  77     -> (c -> (a, c))
  78     -> c
  79     -> Tape a
  80 unfoldT prev center next =
  81     Tape
  82     <$> unfoldS prev
  83     <*> center
  84     <*> unfoldS next
  85
  86 -- | A simplified unfolding mechanism that will be useful shortly
  87 tapeIterate
  88     :: (a -> a)
  89     -> (a -> a)
  90     -> a
  91     -> Tape a
  92 tapeIterate prev next = unfoldT (dup . prev) id (dup . next)
  93     where dup a = (a, a)
  94
  95 -- | Create a 'Tape' from a list where everything to the left is some default
  96 -- value and the list is the focused value and everything to the right.
  97 tapeFromList :: a -> [a] -> Tape a
  98 tapeFromList def xs = right $ Tape background def $ fromS def xs
  99     where background = repeatS def
 100
 101 tapeToList :: Int -> Tape a -> [a]
 102 tapeToList n (Tape ls x rs) =
 103     reverse (takeS n ls) ++ [x] ++ (takeS n rs)
 104
 105 instance Comonad Tape where
 106     extract (Tape _ c _) = c
 107     duplicate = tapeIterate left right
 108
 109 instance ComonadApply Tape where
 110     (Tape fl fc fr) <@> (Tape xl xc xr) =
 111         Tape (fl <@> xl) (fc xc) (fr <@> xr)
 112
 113 -- * Sheets! We're so close!
 114
 115 -- | A 2-dimensional 'Tape' of 'Tape's.
 116 newtype Sheet a = Sheet (Tape (Tape a))
 117     deriving (Functor)
 118
 119 instance UpDown Sheet where
 120     up (Sheet p) = Sheet (left p)
 121     down (Sheet p) = Sheet (right p)
 122
 123 instance LeftRight Sheet where
 124     left (Sheet p) = Sheet (fmap left p)
 125     right (Sheet p) = Sheet (fmap right p)
 126
 127 -- Helper functions to take a given 'Sheet' and make an infinite 'Tape' of it.
 128 horizontal :: Sheet a -> Tape (Sheet a)
 129 horizontal = tapeIterate left right
 130
 131 vertical :: Sheet a -> Tape (Sheet a)
 132 vertical = tapeIterate up down
 133
 134 instance Comonad Sheet where
 135     extract (Sheet p) = extract $ extract p
 136     -- | See? Told you 'tapeIterate' would be useful
 137     duplicate s = Sheet $ fmap horizontal $ vertical s
 138
 139 instance ComonadApply Sheet where
 140     (Sheet (Tape fu fc fd)) <@> (Sheet (Tape xu xc xd)) =
 141         Sheet $ Tape (fu `ap` xu) (fc <@> xc) (fd `ap` xd)
 142
 143         where ap t1 t2 = (fmap (<@>) t1) <@> t2
 144
 145 -- | Produce a 'Sheet' from a list of lists, where each inner list is a row.
 146 sheet :: a -> [[a]] -> Sheet a
 147 sheet def grid = Sheet cols
 148     where cols = fmap (tapeFromList def) rows
 149           rows = tapeFromList [def] grid
 150
 151 -- | Slice a sheet for viewing purposes.
 152 sheetToList :: Int -> Sheet a -> [[a]]
 153 sheetToList n (Sheet zs) = tapeToList n $ fmap (tapeToList n) zs
 154
 155 -- | Construct an infinite sheet in all directions from a base value.
 156 background :: a -> Sheet a
 157 background x = Sheet . duplicate $ Tape (repeatS x) x (repeatS x)
 158
 159 printSheet :: Show a => Int -> Sheet a -> IO ()
 160 printSheet n sh = forM_ (sheetToList n sh) $ putStrLn . show
 161
 162 -- | This just makes some things more readable
 163 (&) :: a -> (a -> b) -> b
 164 (&) = flip ($)
 165
 166 -- | A cell can be alive ('O') or dead ('X').
 167 data Cell = X | O deriving (Eq)
 168
 169 instance Show Cell where
 170     show X = "\x2591"
 171     show O = "\x2593"
 172
 173 -- | The first list is of numbers of live neighbors to make a dead 'Cell' become
 174 -- alive; the second is numbers of live neighbors that keeps a live 'Cell'
 175 -- alive.
 176 type Ruleset = ([Int], [Int])
 177
 178 cellToInt :: Cell -> Int
 179 cellToInt X = 0
 180 cellToInt O = 1
 181
 182 conwayRules :: Ruleset
 183 conwayRules = ([3], [2, 3])
 184
 185 executeRules :: Ruleset -> Sheet Cell -> Cell
 186 executeRules (born, persist) s = go (extract s) where
 187
 188     -- there is probably a more elegant way of getting all 8 neighbors
 189     neighbors = [ s & up & extract
 190                 , s & down & extract
 191                 , s & left & extract
 192                 , s & right & extract
 193                 , s & up & right & extract
 194                 , s & up & left & extract
 195                 , s & down & left & extract
 196                 , s & down & right & extract ]
 197     liveCount = sum $ map cellToInt neighbors
 198     go O | liveCount `elem` persist = O
 199          | otherwise                = X
 200     go X | liveCount `elem` born    = O
 201          | otherwise                = X
 202
 203 -- | A simple glider
 204 initialGame :: [[Cell]]
 205 initialGame = [ [ X, X, O ]
 206               , [ O, X, O ]
 207               , [ X, O, O ] ]
 208
 209 -- | A 'Stream' of Conway games.
 210 timeline :: Ruleset -> Sheet Cell -> Stream (Sheet Cell)
 211 timeline rules ig = go ig where
 212     go ig = ig :> (go (rules' <@> (duplicate ig)))
 213     rules' = background $ executeRules rules
 214
 215 main :: IO ()
 216 main = do
 217     let ig = sheet X initialGame
 218     let tl = timeline conwayRules ig
 219     forM_ (takeS 5 tl) $ \s -> do
 220         printSheet 3 s
 221         putStrLn "---"