src/advent12/advent12-comonad.hs

   1 {-# LANGUAGE OverloadedStrings, DeriveFunctor #-}
   2
   3 -- Heavily based on https://gist.github.com/gatlin/21d669321c617836a317693aef63a3c3
   4 -- See also https://www.schoolofhaskell.com/user/edwardk/cellular-automata/part-3
   5
   6 -- import Data.List
   7
   8 import Data.Text (Text)
   9 import qualified Data.Text.IO as TIO
  10
  11 import Data.Void (Void)
  12
  13 import Text.Megaparsec
  14 import Text.Megaparsec.Char
  15 import qualified Text.Megaparsec.Char.Lexer as L
  16 import qualified Control.Applicative as CA
  17
  18 import Control.Applicative
  19 import Control.Comonad
  20
  21 import Control.Monad (forM_)
  22
  23 -- import qualified Data.Set as S
  24
  25
  26 -- main :: IO ()
  27 -- main = do
  28 --         text <- TIO.readFile "data/advent12.txt"
  29 --         let (initial, rules) = successfulParse text
  30 --         print initial
  31 --         print rules
  32
  33
  34 main :: IO ()
  35 main = do
  36     let ig = tape X initialGame
  37     let tl = timeline conwayRules ig
  38     forM_ (takeS 5 tl) $ \s -> do
  39         printSheet 3 s
  40         putStrLn "---"
  41
  42
  43 -- These two typeclasses probably make some people groan.
  44 class LeftRight t where
  45     left :: t a -> t a
  46     right :: t a -> t a
  47
  48 -- | An infinite list of values
  49 data Stream a = a :> Stream a
  50     deriving (Functor)
  51
  52
  53 -- * Stream utilities
  54
  55 -- | Allows finitary beings to view slices of a 'Stream'
  56 takeS :: Int -> Stream a -> [a]
  57 takeS 0 _ = []
  58 takeS n (x :> xs) = x : (takeS (n-1) xs)
  59
  60 -- | Build a 'Stream' from a generator function
  61 unfoldS :: (b -> (a, b)) -> b -> Stream a
  62 unfoldS f c = x :> unfoldS f d
  63     where (x, d) = f c
  64
  65 -- | Build a 'Stream' by mindlessly repeating a value
  66 repeatS :: a -> Stream a
  67 repeatS x = x :> repeatS x
  68
  69 -- | Build a 'Stream' from a finite list, filling in the rest with a designated
  70 -- default value
  71 fromS :: a -> [a] -> Stream a
  72 fromS def [] = repeatS def
  73 fromS def (x:xs) = x :> (fromS def xs)
  74
  75 -- | Prepend values from a list to an existing 'Stream'
  76 prependList :: [a] -> Stream a -> Stream a
  77 prependList [] str = str
  78 prependList (x:xs) str = x :> (prependList xs str)
  79
  80 -- | A 'Stream' is a comonad
  81 instance Comonad Stream where
  82     extract (a :> _) = a
  83     duplicate s@(a :> as) = s :> (duplicate as)
  84
  85 -- | It is also a 'ComonadApply'
  86 instance ComonadApply Stream where
  87     (f :> fs) <@> (x :> xs) = (f x) :> (fs <@> xs)
  88
  89 -- * Tapes, our workhorse
  90
  91 -- | A 'Tape' is always focused on one value in a 1-dimensional infinite stream
  92 data Tape a = Tape (Stream a) a (Stream a)
  93     deriving (Functor)
  94
  95 -- | We can go left and right along a tape!
  96 instance LeftRight Tape where
  97     left (Tape (l :> ls) c rs) = Tape ls l (c :> rs)
  98     right (Tape ls c (r :> rs)) = Tape (c :> ls) r rs
  99
 100 -- | Build out the left, middle, and right parts of a 'Tape' with generator
 101 -- functions.
 102 unfoldT
 103     :: (c -> (a, c))
 104     -> (c -> a)
 105     -> (c -> (a, c))
 106     -> c
 107     -> Tape a
 108 unfoldT prev center next =
 109     Tape
 110     <$> unfoldS prev
 111     <*> center
 112     <*> unfoldS next
 113
 114 -- | A simplified unfolding mechanism that will be useful shortly
 115 tapeIterate
 116     :: (a -> a)
 117     -> (a -> a)
 118     -> a
 119     -> Tape a
 120 tapeIterate prev next = unfoldT (dup . prev) id (dup . next)
 121     where dup a = (a, a)
 122
 123 -- | Create a 'Tape' from a list where everything to the left is some default
 124 -- value and the list is the focused value and everything to the right.
 125 tapeFromList :: a -> [a] -> Tape a
 126 tapeFromList def xs = right $ Tape background def $ fromS def xs
 127     where background = repeatS def
 128
 129 tapeToList :: Int -> Tape a -> [a]
 130 tapeToList n (Tape ls x rs) =
 131     reverse (takeS n ls) ++ [x] ++ (takeS n rs)
 132
 133 instance Comonad Tape where
 134     extract (Tape _ c _) = c
 135     duplicate = tapeIterate left right
 136
 137 instance ComonadApply Tape where
 138     (Tape fl fc fr) <@> (Tape xl xc xr) =
 139         Tape (fl <@> xl) (fc xc) (fr <@> xr)
 140
 141
 142 -- | Construct an infinite tape in all directions from a base value.
 143 background :: a -> Tape a
 144 background x = Tape (repeatS x) x (repeatS x)
 145
 146 -- | This just makes some things more readable
 147 (&) :: a -> (a -> b) -> b
 148 (&) = flip ($)
 149
 150 -- | A cell can be alive ('O') or dead ('X').
 151 data Cell = X | O deriving (Eq)
 152
 153 instance Show Cell where
 154     show X = "\x2591"
 155     show O = "\x2593"
 156
 157 -- | The first list is of numbers of live neighbors to make a dead 'Cell' become
 158 -- alive; the second is numbers of live neighbors that keeps a live 'Cell'
 159 -- alive.
 160 type Ruleset = ([Int], [Int])
 161
 162 cellToInt :: Cell -> Int
 163 cellToInt X = 0
 164 cellToInt O = 1
 165
 166 conwayRules :: Ruleset
 167 conwayRules = ([3], [2, 3])
 168
 169 executeRules :: Ruleset -> Tape Cell -> Cell
 170 executeRules rules s = go (extract s) where
 171
 172     -- there is probably a more elegant way of getting all 8 neighbors
 173     neighbors = [ s & left & left & extract
 174                 , s & left & extract
 175                 , s & extract
 176                 , s & right & extract
 177                 , s & right & right & extract
 178                 ]
 179     liveCount = sum $ map cellToInt neighbors
 180     go O | liveCount `elem` persist = O
 181          | otherwise                = X
 182     go X | liveCount `elem` born    = O
 183          | otherwise                = X
 184
 185 -- | A simple glider
 186 initialGame :: [Cell]
 187 initialGame = map cToCell "#..#.#..##......###...###"
 188     where cToCell c = if c == '#' then O else X
 189
 190 -- | A 'Stream' of Conway games.
 191 timeline :: Ruleset -> Tape Cell -> Stream (Tape Cell)
 192 timeline rules ig = go ig where
 193     go ig = ig :> (go (rules' <@> (duplicate ig)))
 194     rules' = background $ executeRules rules
 195
 196
 197 applyRule rule cells =
 198
 199
 200 -- Parse the input file
 201
 202 type Parser = Parsec Void Text
 203
 204 sc :: Parser ()
 205 sc = L.space (skipSome spaceChar) CA.empty CA.empty
 206
 207 symb = L.symbol sc
 208 potP = char '.' <|> char '#'
 209
 210 initialPrefix = symb "initial state:"
 211 ruleSepP = symb "=>"
 212
 213 fileP = (,) <$> initialP <*> many ruleP
 214 initialP = initialPrefix *> many potP <* sc
 215 ruleP = (,) <$> ruleLHS <* ruleSepP <*> ruleRHS
 216 ruleLHS = count 5 potP <* sc
 217 ruleRHS = potP <* sc
 218
 219 successfulParse :: Text -> (String, [(String, Char)])
 220 successfulParse input =
 221         case parse fileP "input" input of
 222                 Left  _error -> ("", []) -- TIO.putStr $ T.pack $ parseErrorPretty err
 223                 Right world -> world