src/advent12/advent12-comonad.hs

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