src/advent12/advent12-comonad.hs

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