default-language: Haskell2010
build-depends: base >= 4.7 && < 5
, containers
+
+executable advent12
+ hs-source-dirs: src/advent12
+ main-is: advent12.hs
+ default-language: Haskell2010
+ build-depends: base >= 4.7 && < 5
+ , text
+ , megaparsec
+ , containers
+
+executable life
+ hs-source-dirs: src/advent12
+ main-is: life.hs
+ default-language: Haskell2010
+ build-depends: base >= 4.7 && < 5
+ , comonad
--- /dev/null
+initial state: #..#.#..##......###...###
+
+##### => .
+####. => #
+###.# => #
+###.. => #
+##.## => #
+##.#. => #
+##..# => .
+##... => .
+#.### => #
+#.##. => .
+#.#.# => #
+#.#.. => .
+#..## => .
+#..#. => .
+#...# => .
+#.... => .
+.#### => #
+.###. => .
+.##.# => .
+.##.. => #
+.#.## => #
+.#.#. => #
+.#..# => .
+.#... => #
+..### => .
+..##. => .
+..#.# => .
+..#.. => #
+...## => #
+...#. => .
+....# => .
+..... => .
--- /dev/null
+initial state: #.##.###.#.##...##..#..##....#.#.#.#.##....##..#..####..###.####.##.#..#...#..######.#.....#..##...#
+
+.#.#. => .
+...#. => #
+..##. => .
+....# => .
+##.#. => #
+.##.# => #
+.#### => #
+#.#.# => #
+#..#. => #
+##..# => .
+##### => .
+...## => .
+.#... => .
+###.. => #
+#..## => .
+#...# => .
+.#..# => #
+.#.## => .
+#.#.. => #
+..... => .
+####. => .
+##.## => #
+..### => #
+#.... => .
+###.# => .
+.##.. => #
+#.### => #
+..#.# => .
+.###. => #
+##... => #
+#.##. => #
+..#.. => #
--- /dev/null
+<!DOCTYPE html>
+<html lang="en-us">
+<head>
+<meta charset="utf-8"/>
+<title>Day 12 - Advent of Code 2018</title>
+<!--[if lt IE 9]><script src="/static/html5.js"></script><![endif]-->
+<link href='//fonts.googleapis.com/css?family=Source+Code+Pro:300&subset=latin,latin-ext' rel='stylesheet' type='text/css'>
+<link rel="stylesheet" type="text/css" href="/static/style.css?18"/>
+<link rel="stylesheet alternate" type="text/css" href="/static/highcontrast.css?0" title="High Contrast"/>
+<link rel="shortcut icon" href="/favicon.png"/>
+</head><!--
+
+
+
+
+Oh, hello! Funny seeing you here.
+
+I appreciate your enthusiasm, but you aren't going to find much down here.
+There certainly aren't clues to any of the puzzles. The best surprises don't
+even appear in the source until you unlock them for real.
+
+Please be careful with automated requests; I'm not Google, and I can only take
+so much traffic. Please be considerate so that everyone gets to play.
+
+If you're curious about how Advent of Code works, it's running on some custom
+Perl code. Other than a few integrations (auth, analytics, ads, social media),
+I built the whole thing myself, including the design, animations, prose, and
+all of the puzzles.
+
+The puzzles are most of the work; the easiest ones take 3-4 hours each, but the
+harder ones take 6-8 hours, and a few even longer than that. A lot of effort
+went into building this thing - I hope you're enjoying playing it as much as I
+enjoyed making it for you!
+
+If you'd like to hang out, I'm @ericwastl on Twitter.
+
+- Eric Wastl
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+-->
+<body>
+<header><div><h1 class="title-global"><a href="/">Advent of Code</a></h1><nav><ul><li><a href="/2018/about">[About]</a></li><li><a href="/2018/events">[Events]</a></li><li><a href="https://teespring.com/adventofcode" target="_blank">[Shop]</a></li><li><a href="/2018/settings">[Settings]</a></li><li><a href="/2018/auth/logout">[Log Out]</a></li></ul></nav><div class="user">Neil Smith <a href="/2018/support" class="supporter-badge" title="Advent of Code Supporter">(AoC++)</a> <span class="star-count">24*</span></div></div><div><h1 class="title-event"> <span class="title-event-wrap">{'year':</span><a href="/2018">2018</a><span class="title-event-wrap">}</span></h1><nav><ul><li><a href="/2018">[Calendar]</a></li><li><a href="/2018/support">[AoC++]</a></li><li><a href="/2018/sponsors">[Sponsors]</a></li><li><a href="/2018/leaderboard">[Leaderboard]</a></li><li><a href="/2018/stats">[Stats]</a></li></ul></nav></div></header>
+
+<div id="sidebar">
+<div id="sponsor"><div class="quiet">Our <a href="/2018/sponsors">sponsors</a> help make Advent of Code possible:</div><div class="sponsor"><a href="https://www.wearedevelopers.com/world-congress/" target="_blank" onclick="if(ga)ga('send','event','sponsor','click',this.href);" rel="noopener">WeAreDevelopers</a> - Use "AOC-25", save EUR 25 and join 10^4 devs on June 6-7 at the WeAreDevelopers World Congress in Berlin ticket.get(now)</div></div>
+</div><!--/sidebar-->
+
+<main>
+<article class="day-desc"><h2>--- Day 12: Subterranean Sustainability ---</h2><p>The year 518 is significantly more underground than your history books implied. Either that, or you've arrived in a <span title="It's probably this one. Can never be too sure, though.">vast cavern network</span> under the North Pole.</p>
+<p>After exploring a little, you discover a long tunnel that contains a row of small pots as far as you can see to your left and right. A few of them contain plants - someone is trying to grow things in these geothermally-heated caves.</p>
+<p>The pots are numbered, with <code>0</code> in front of you. To the left, the pots are numbered <code>-1</code>, <code>-2</code>, <code>-3</code>, and so on; to the right, <code>1</code>, <code>2</code>, <code>3</code>.... Your puzzle input contains a list of pots from <code>0</code> to the right and whether they do (<code>#</code>) or do not (<code>.</code>) currently contain a plant, the <em>initial state</em>. (No other pots currently contain plants.) For example, an initial state of <code>#..##....</code> indicates that pots <code>0</code>, <code>3</code>, and <code>4</code> currently contain plants.</p>
+<p>Your puzzle input also contains some notes you find on a nearby table: someone has been trying to figure out how these plants <em>spread</em> to nearby pots. Based on the notes, for each generation of plants, a given pot has or does not have a plant based on whether that pot (and the two pots on either side of it) had a plant in the last generation. These are written as <code>LLCRR => N</code>, where <code>L</code> are pots to the left, <code>C</code> is the current pot being considered, <code>R</code> are the pots to the right, and <code>N</code> is whether the current pot will have a plant in the next generation. For example:</p>
+<ul>
+<li>A note like <code>..#.. => .</code> means that a pot that contains a plant but with no plants within two pots of it will not have a plant in it during the next generation.</li>
+<li>A note like <code>##.## => .</code> means that an empty pot with two plants on each side of it will remain empty in the next generation.</li>
+<li>A note like <code>.##.# => #</code> means that a pot has a plant in a given generation if, in the previous generation, there were plants in that pot, the one immediately to the left, and the one two pots to the right, but not in the ones immediately to the right and two to the left.</li>
+</ul>
+<p>It's not clear what these plants are for, but you're sure it's important, so you'd like to make sure the current configuration of plants is sustainable by determining what will happen after <em><code>20</code> generations</em>.</p>
+<p>For example, given the following input:</p>
+<pre><code>initial state: #..#.#..##......###...###
+
+...## => #
+..#.. => #
+.#... => #
+.#.#. => #
+.#.## => #
+.##.. => #
+.#### => #
+#.#.# => #
+#.### => #
+##.#. => #
+##.## => #
+###.. => #
+###.# => #
+####. => #
+</code></pre>
+<p>For brevity, in this example, only the combinations which do produce a plant are listed. (Your input includes all possible combinations.) Then, the next 20 generations will look like this:</p>
+<pre><code> 1 2 3
+ 0 0 0 0
+ 0: ...#..#.#..##......###...###...........
+ 1: ...#...#....#.....#..#..#..#...........
+ 2: ...##..##...##....#..#..#..##..........
+ 3: ..#.#...#..#.#....#..#..#...#..........
+ 4: ...#.#..#...#.#...#..#..##..##.........
+ 5: ....#...##...#.#..#..#...#...#.........
+ 6: ....##.#.#....#...#..##..##..##........
+ 7: ...#..###.#...##..#...#...#...#........
+ 8: ...#....##.#.#.#..##..##..##..##.......
+ 9: ...##..#..#####....#...#...#...#.......
+10: ..#.#..#...#.##....##..##..##..##......
+11: ...#...##...#.#...#.#...#...#...#......
+12: ...##.#.#....#.#...#.#..##..##..##.....
+13: ..#..###.#....#.#...#....#...#...#.....
+14: ..#....##.#....#.#..##...##..##..##....
+15: ..##..#..#.#....#....#..#.#...#...#....
+16: .#.#..#...#.#...##...#...#.#..##..##...
+17: ..#...##...#.#.#.#...##...#....#...#...
+18: ..##.#.#....#####.#.#.#...##...##..##..
+19: .#..###.#..#.#.#######.#.#.#..#.#...#..
+20: .#....##....#####...#######....#.#..##.
+</code></pre>
+<p>The generation is shown along the left, where <code>0</code> is the initial state. The pot numbers are shown along the top, where <code>0</code> labels the center pot, negative-numbered pots extend to the left, and positive pots extend toward the right. Remember, the initial state begins at pot <code>0</code>, which is not the leftmost pot used in this example.</p>
+<p>After one generation, only seven plants remain. The one in pot <code>0</code> matched the rule looking for <code>..#..</code>, the one in pot <code>4</code> matched the rule looking for <code>.#.#.</code>, pot <code>9</code> matched <code>.##..</code>, and so on.</p>
+<p>In this example, after 20 generations, the pots shown as <code>#</code> contain plants, the furthest left of which is pot <code>-2</code>, and the furthest right of which is pot <code>34</code>. Adding up all the numbers of plant-containing pots after the 20th generation produces <code><em>325</em></code>.</p>
+<p><em>After <code>20</code> generations, what is the sum of the numbers of all pots which contain a plant?</em></p>
+</article>
+<p>Your puzzle answer was <code>2571</code>.</p><article class="day-desc"><h2 id="part2">--- Part Two ---</h2><p>You realize that 20 generations aren't enough. After all, these plants will need to last another 1500 years to even reach your timeline, not to mention your future.</p>
+<p><em>After fifty billion (<code>50000000000</code>) generations, what is the sum of the numbers of all pots which contain a plant?</em></p>
+</article>
+<p>Your puzzle answer was <code>3100000000655</code>.</p><p class="day-success">Both parts of this puzzle are complete! They provide two gold stars: **</p>
+<p>At this point, you should <a href="/2018">return to your advent calendar</a> and try another puzzle.</p>
+<p>If you still want to see it, you can <a href="12/input" target="_blank">get your puzzle input</a>.</p>
+<p>You can also <span class="share">[Share<span class="share-content">on
+ <a href="https://twitter.com/intent/tweet?text=I%27ve+completed+%22Subterranean+Sustainability%22+%2D+Day+12+%2D+Advent+of+Code+2018&url=https%3A%2F%2Fadventofcode%2Ecom%2F2018%2Fday%2F12&related=ericwastl&hashtags=AdventOfCode" target="_blank">Twitter</a>
+ <a href="http://www.reddit.com/submit?url=https%3A%2F%2Fadventofcode%2Ecom%2F2018%2Fday%2F12&title=I%27ve+completed+%22Subterranean+Sustainability%22+%2D+Day+12+%2D+Advent+of+Code+2018" target="_blank">Reddit</a
+></span>]</span> this puzzle.</p>
+</main>
+
+<!-- ga -->
+<script>
+(function(i,s,o,g,r,a,m){i['GoogleAnalyticsObject']=r;i[r]=i[r]||function(){
+(i[r].q=i[r].q||[]).push(arguments)},i[r].l=1*new Date();a=s.createElement(o),
+m=s.getElementsByTagName(o)[0];a.async=1;a.src=g;m.parentNode.insertBefore(a,m)
+})(window,document,'script','//www.google-analytics.com/analytics.js','ga');
+ga('create', 'UA-69522494-1', 'auto');
+ga('send', 'pageview');
+</script>
+<!-- /ga -->
+</body>
+</html>
\ No newline at end of file
--- /dev/null
+{-# LANGUAGE OverloadedStrings, DeriveFunctor #-}
+
+-- import Data.List
+
+import Data.Text (Text)
+import qualified Data.Text.IO as TIO
+
+import Data.Void (Void)
+
+import Text.Megaparsec
+import Text.Megaparsec.Char
+import qualified Text.Megaparsec.Char.Lexer as L
+import qualified Control.Applicative as CA
+
+import Control.Applicative
+import Control.Comonad
+
+import Control.Monad (forM_)
+
+-- import qualified Data.Set as S
+
+
+-- main :: IO ()
+-- main = do
+-- text <- TIO.readFile "data/advent12.txt"
+-- let (initial, rules) = successfulParse text
+-- print initial
+-- print rules
+
+
+main :: IO ()
+main = do
+ let ig = tape X initialGame
+ let tl = timeline conwayRules ig
+ forM_ (takeS 5 tl) $ \s -> do
+ printSheet 3 s
+ putStrLn "---"
+
+
+-- These two typeclasses probably make some people groan.
+class LeftRight t where
+ left :: t a -> t a
+ right :: t a -> t a
+
+-- | An infinite list of values
+data Stream a = a :> Stream a
+ deriving (Functor)
+
+
+-- * Stream utilities
+
+-- | Allows finitary beings to view slices of a 'Stream'
+takeS :: Int -> Stream a -> [a]
+takeS 0 _ = []
+takeS n (x :> xs) = x : (takeS (n-1) xs)
+
+-- | Build a 'Stream' from a generator function
+unfoldS :: (b -> (a, b)) -> b -> Stream a
+unfoldS f c = x :> unfoldS f d
+ where (x, d) = f c
+
+-- | Build a 'Stream' by mindlessly repeating a value
+repeatS :: a -> Stream a
+repeatS x = x :> repeatS x
+
+-- | Build a 'Stream' from a finite list, filling in the rest with a designated
+-- default value
+fromS :: a -> [a] -> Stream a
+fromS def [] = repeatS def
+fromS def (x:xs) = x :> (fromS def xs)
+
+-- | Prepend values from a list to an existing 'Stream'
+prependList :: [a] -> Stream a -> Stream a
+prependList [] str = str
+prependList (x:xs) str = x :> (prependList xs str)
+
+-- | A 'Stream' is a comonad
+instance Comonad Stream where
+ extract (a :> _) = a
+ duplicate s@(a :> as) = s :> (duplicate as)
+
+-- | It is also a 'ComonadApply'
+instance ComonadApply Stream where
+ (f :> fs) <@> (x :> xs) = (f x) :> (fs <@> xs)
+
+-- * Tapes, our workhorse
+
+-- | A 'Tape' is always focused on one value in a 1-dimensional infinite stream
+data Tape a = Tape (Stream a) a (Stream a)
+ deriving (Functor)
+
+-- | We can go left and right along a tape!
+instance LeftRight Tape where
+ left (Tape (l :> ls) c rs) = Tape ls l (c :> rs)
+ right (Tape ls c (r :> rs)) = Tape (c :> ls) r rs
+
+-- | Build out the left, middle, and right parts of a 'Tape' with generator
+-- functions.
+unfoldT
+ :: (c -> (a, c))
+ -> (c -> a)
+ -> (c -> (a, c))
+ -> c
+ -> Tape a
+unfoldT prev center next =
+ Tape
+ <$> unfoldS prev
+ <*> center
+ <*> unfoldS next
+
+-- | A simplified unfolding mechanism that will be useful shortly
+tapeIterate
+ :: (a -> a)
+ -> (a -> a)
+ -> a
+ -> Tape a
+tapeIterate prev next = unfoldT (dup . prev) id (dup . next)
+ where dup a = (a, a)
+
+-- | Create a 'Tape' from a list where everything to the left is some default
+-- value and the list is the focused value and everything to the right.
+tapeFromList :: a -> [a] -> Tape a
+tapeFromList def xs = right $ Tape background def $ fromS def xs
+ where background = repeatS def
+
+tapeToList :: Int -> Tape a -> [a]
+tapeToList n (Tape ls x rs) =
+ reverse (takeS n ls) ++ [x] ++ (takeS n rs)
+
+instance Comonad Tape where
+ extract (Tape _ c _) = c
+ duplicate = tapeIterate left right
+
+instance ComonadApply Tape where
+ (Tape fl fc fr) <@> (Tape xl xc xr) =
+ Tape (fl <@> xl) (fc xc) (fr <@> xr)
+
+
+-- | Construct an infinite tape in all directions from a base value.
+background :: a -> Tape a
+background x = Tape (repeatS x) x (repeatS x)
+
+-- | This just makes some things more readable
+(&) :: a -> (a -> b) -> b
+(&) = flip ($)
+
+-- | A cell can be alive ('O') or dead ('X').
+data Cell = X | O deriving (Eq)
+
+instance Show Cell where
+ show X = "\x2591"
+ show O = "\x2593"
+
+-- | The first list is of numbers of live neighbors to make a dead 'Cell' become
+-- alive; the second is numbers of live neighbors that keeps a live 'Cell'
+-- alive.
+type Ruleset = ([Int], [Int])
+
+cellToInt :: Cell -> Int
+cellToInt X = 0
+cellToInt O = 1
+
+conwayRules :: Ruleset
+conwayRules = ([3], [2, 3])
+
+executeRules :: Ruleset -> Tape Cell -> Cell
+executeRules rules s = go (extract s) where
+
+ -- there is probably a more elegant way of getting all 8 neighbors
+ neighbors = [ s & left & left & extract
+ , s & left & extract
+ , s & extract
+ , s & right & extract
+ , s & right & right & extract
+ ]
+ liveCount = sum $ map cellToInt neighbors
+ go O | liveCount `elem` persist = O
+ | otherwise = X
+ go X | liveCount `elem` born = O
+ | otherwise = X
+
+-- | A simple glider
+initialGame :: [Cell]
+initialGame = map cToCell "#..#.#..##......###...###"
+ where cToCell c = if c == '#' then O else X
+
+-- | A 'Stream' of Conway games.
+timeline :: Ruleset -> Tape Cell -> Stream (Tape Cell)
+timeline rules ig = go ig where
+ go ig = ig :> (go (rules' <@> (duplicate ig)))
+ rules' = background $ executeRules rules
+
+
+applyRule rule cells =
+
+
+-- Parse the input file
+
+type Parser = Parsec Void Text
+
+sc :: Parser ()
+sc = L.space (skipSome spaceChar) CA.empty CA.empty
+
+symb = L.symbol sc
+potP = char '.' <|> char '#'
+
+initialPrefix = symb "initial state:"
+ruleSepP = symb "=>"
+
+fileP = (,) <$> initialP <*> many ruleP
+initialP = initialPrefix *> many potP <* sc
+ruleP = (,) <$> ruleLHS <* ruleSepP <*> ruleRHS
+ruleLHS = count 5 potP <* sc
+ruleRHS = potP <* sc
+
+successfulParse :: Text -> (String, [(String, Char)])
+successfulParse input =
+ case parse fileP "input" input of
+ Left _error -> ("", []) -- TIO.putStr $ T.pack $ parseErrorPretty err
+ Right world -> world
\ No newline at end of file
--- /dev/null
+{-# LANGUAGE OverloadedStrings #-}
+
+import Data.Text (Text)
+import qualified Data.Text.IO as TIO
+
+import Data.Void (Void)
+
+import Text.Megaparsec
+import Text.Megaparsec.Char
+import qualified Text.Megaparsec.Char.Lexer as L
+import qualified Control.Applicative as CA
+
+import Data.List
+import qualified Data.Set as S
+
+type Pots = S.Set Int
+data Rule = Rule [Bool] Bool deriving (Eq, Show)
+
+main :: IO ()
+main = do
+ text <- TIO.readFile "data/advent12.txt"
+ let (initial, rules) = successfulParse text
+ let row = makeWorld 0 initial
+ print $ part1 rules row
+ print $ part2 rules row
+
+part1 :: [Rule] -> Pots -> Int
+part1 rules row = sum $ (iterate (\r -> applyRules rules r) row)!!20
+
+
+part2 :: [Rule] -> Pots -> Integer
+-- part2 rules pots = (length differentQuads, steadyDiff, sum la, sum lb, sum lc, sum ld)-- (fromIntegral (sum la)) + steadyDiff * remainingGenerations
+part2 rules pots = (fromIntegral (sum lc)) + steadyDiff * remainingGenerations
+ where rows = (iterate (\r -> applyRules rules r) pots)
+ rowQuads = zip4 rows (drop 1 rows) (drop 2 rows) (drop 3 rows)
+ sameDiffs (a, b, c, d) = length (nub [(sum a) - (sum b), (sum b) - (sum c), (sum c) - (sum d) ]) == 1
+ differentQuads = takeWhile (not . sameDiffs) rowQuads
+ (_la, _lb, lc, ld) = last differentQuads
+ remainingGenerations = 50000000000 - (fromIntegral (length differentQuads)) - 1
+ steadyDiff = fromIntegral $ (sum ld) - (sum lc)
+
+
+makeWorld :: Int -> [Bool] -> Pots
+makeWorld start = S.fromList . map fst . filter snd . zip [start..]
+
+applyRuleAt :: [Rule] -> Int -> Pots -> (Int, Bool)
+applyRuleAt rules location pots = (location, result)
+ where (Rule _ result) = head $ filter (\r -> matchRuleAt r location pots) rules
+
+matchRuleAt :: Rule -> Int -> Pots -> Bool
+matchRuleAt (Rule pattern _) location pots = patternHere == potsHere
+ where patternHere = makeWorld (location - 2) pattern
+ potsHere = S.filter (\l -> abs (location - l) <= 2) pots
+
+
+applyRules :: [Rule] -> Pots -> Pots
+applyRules rules pots = S.fromList $ map fst $ filter snd potValues
+ where start = S.findMin pots
+ end = S.findMax pots
+ potValues = map (\location -> applyRuleAt rules location pots) [(start-3)..(end+3)]
+
+-- showPots pots = map (\i -> showPot i pots) [-10..110]
+-- where showPot i pots = if i `S.member` pots then '#' else '.'
+
+
+-- Parse the input file
+
+type Parser = Parsec Void Text
+
+sc :: Parser ()
+sc = L.space (skipSome spaceChar) CA.empty CA.empty
+
+symb = L.symbol sc
+potP = (char '.' *> pure False) <|> (char '#' *> pure True)
+
+initialPrefix = symb "initial state:"
+ruleSepP = symb "=>"
+
+fileP = (,) <$> initialP <*> many ruleP
+initialP = initialPrefix *> many potP <* sc
+ruleP = Rule <$> ruleLHS <* ruleSepP <*> ruleRHS
+ruleLHS = count 5 potP <* sc
+ruleRHS = potP <* sc
+
+successfulParse :: Text -> ([Bool], [Rule])
+successfulParse input =
+ case parse fileP "input" input of
+ Left _error -> ([], []) -- TIO.putStr $ T.pack $ parseErrorPretty err
+ Right world -> world
\ No newline at end of file
--- /dev/null
+{-# LANGUAGE DeriveFunctor #-}
+
+import Control.Applicative
+import Control.Comonad
+
+import Control.Monad (forM_)
+
+-- These two typeclasses probably make some people groan.
+class LeftRight t where
+ left :: t a -> t a
+ right :: t a -> t a
+
+class UpDown t where
+ up :: t a -> t a
+ down :: t a -> t a
+
+-- | An infinite list of values
+data Stream a = a :> Stream a
+ deriving (Functor)
+
+
+-- * Stream utilities
+
+-- | Allows finitary beings to view slices of a 'Stream'
+takeS :: Int -> Stream a -> [a]
+takeS 0 _ = []
+takeS n (x :> xs) = x : (takeS (n-1) xs)
+
+-- | Build a 'Stream' from a generator function
+unfoldS :: (b -> (a, b)) -> b -> Stream a
+unfoldS f c = x :> unfoldS f d
+ where (x, d) = f c
+
+-- | Build a 'Stream' by mindlessly repeating a value
+repeatS :: a -> Stream a
+repeatS x = x :> repeatS x
+
+-- | Build a 'Stream' from a finite list, filling in the rest with a designated
+-- default value
+fromS :: a -> [a] -> Stream a
+fromS def [] = repeatS def
+fromS def (x:xs) = x :> (fromS def xs)
+
+-- | Prepend values from a list to an existing 'Stream'
+prependList :: [a] -> Stream a -> Stream a
+prependList [] str = str
+prependList (x:xs) str = x :> (prependList xs str)
+
+-- | A 'Stream' is a comonad
+instance Comonad Stream where
+ extract (a :> _) = a
+ duplicate s@(a :> as) = s :> (duplicate as)
+
+-- | It is also a 'ComonadApply'
+instance ComonadApply Stream where
+ (f :> fs) <@> (x :> xs) = (f x) :> (fs <@> xs)
+
+-- * Tapes, our workhorse
+
+-- | A 'Tape' is always focused on one value in a 1-dimensional infinite stream
+data Tape a = Tape (Stream a) a (Stream a)
+ deriving (Functor)
+
+-- | We can go left and right along a tape!
+instance LeftRight Tape where
+ left (Tape (l :> ls) c rs) = Tape ls l (c :> rs)
+ right (Tape ls c (r :> rs)) = Tape (c :> ls) r rs
+
+-- | Build out the left, middle, and right parts of a 'Tape' with generator
+-- functions.
+unfoldT
+ :: (c -> (a, c))
+ -> (c -> a)
+ -> (c -> (a, c))
+ -> c
+ -> Tape a
+unfoldT prev center next =
+ Tape
+ <$> unfoldS prev
+ <*> center
+ <*> unfoldS next
+
+-- | A simplified unfolding mechanism that will be useful shortly
+tapeIterate
+ :: (a -> a)
+ -> (a -> a)
+ -> a
+ -> Tape a
+tapeIterate prev next = unfoldT (dup . prev) id (dup . next)
+ where dup a = (a, a)
+
+-- | Create a 'Tape' from a list where everything to the left is some default
+-- value and the list is the focused value and everything to the right.
+tapeFromList :: a -> [a] -> Tape a
+tapeFromList def xs = right $ Tape background def $ fromS def xs
+ where background = repeatS def
+
+tapeToList :: Int -> Tape a -> [a]
+tapeToList n (Tape ls x rs) =
+ reverse (takeS n ls) ++ [x] ++ (takeS n rs)
+
+instance Comonad Tape where
+ extract (Tape _ c _) = c
+ duplicate = tapeIterate left right
+
+instance ComonadApply Tape where
+ (Tape fl fc fr) <@> (Tape xl xc xr) =
+ Tape (fl <@> xl) (fc xc) (fr <@> xr)
+
+-- * Sheets! We're so close!
+
+-- | A 2-dimensional 'Tape' of 'Tape's.
+newtype Sheet a = Sheet (Tape (Tape a))
+ deriving (Functor)
+
+instance UpDown Sheet where
+ up (Sheet p) = Sheet (left p)
+ down (Sheet p) = Sheet (right p)
+
+instance LeftRight Sheet where
+ left (Sheet p) = Sheet (fmap left p)
+ right (Sheet p) = Sheet (fmap right p)
+
+-- Helper functions to take a given 'Sheet' and make an infinite 'Tape' of it.
+horizontal :: Sheet a -> Tape (Sheet a)
+horizontal = tapeIterate left right
+
+vertical :: Sheet a -> Tape (Sheet a)
+vertical = tapeIterate up down
+
+instance Comonad Sheet where
+ extract (Sheet p) = extract $ extract p
+ -- | See? Told you 'tapeIterate' would be useful
+ duplicate s = Sheet $ fmap horizontal $ vertical s
+
+instance ComonadApply Sheet where
+ (Sheet (Tape fu fc fd)) <@> (Sheet (Tape xu xc xd)) =
+ Sheet $ Tape (fu `ap` xu) (fc <@> xc) (fd `ap` xd)
+
+ where ap t1 t2 = (fmap (<@>) t1) <@> t2
+
+-- | Produce a 'Sheet' from a list of lists, where each inner list is a row.
+sheet :: a -> [[a]] -> Sheet a
+sheet def grid = Sheet cols
+ where cols = fmap (tapeFromList def) rows
+ rows = tapeFromList [def] grid
+
+-- | Slice a sheet for viewing purposes.
+sheetToList :: Int -> Sheet a -> [[a]]
+sheetToList n (Sheet zs) = tapeToList n $ fmap (tapeToList n) zs
+
+-- | Construct an infinite sheet in all directions from a base value.
+background :: a -> Sheet a
+background x = Sheet . duplicate $ Tape (repeatS x) x (repeatS x)
+
+printSheet :: Show a => Int -> Sheet a -> IO ()
+printSheet n sh = forM_ (sheetToList n sh) $ putStrLn . show
+
+-- | This just makes some things more readable
+(&) :: a -> (a -> b) -> b
+(&) = flip ($)
+
+-- | A cell can be alive ('O') or dead ('X').
+data Cell = X | O deriving (Eq)
+
+instance Show Cell where
+ show X = "\x2591"
+ show O = "\x2593"
+
+-- | The first list is of numbers of live neighbors to make a dead 'Cell' become
+-- alive; the second is numbers of live neighbors that keeps a live 'Cell'
+-- alive.
+type Ruleset = ([Int], [Int])
+
+cellToInt :: Cell -> Int
+cellToInt X = 0
+cellToInt O = 1
+
+conwayRules :: Ruleset
+conwayRules = ([3], [2, 3])
+
+executeRules :: Ruleset -> Sheet Cell -> Cell
+executeRules (born, persist) s = go (extract s) where
+
+ -- there is probably a more elegant way of getting all 8 neighbors
+ neighbors = [ s & up & extract
+ , s & down & extract
+ , s & left & extract
+ , s & right & extract
+ , s & up & right & extract
+ , s & up & left & extract
+ , s & down & left & extract
+ , s & down & right & extract ]
+ liveCount = sum $ map cellToInt neighbors
+ go O | liveCount `elem` persist = O
+ | otherwise = X
+ go X | liveCount `elem` born = O
+ | otherwise = X
+
+-- | A simple glider
+initialGame :: [[Cell]]
+initialGame = [ [ X, X, O ]
+ , [ O, X, O ]
+ , [ X, O, O ] ]
+
+-- | A 'Stream' of Conway games.
+timeline :: Ruleset -> Sheet Cell -> Stream (Sheet Cell)
+timeline rules ig = go ig where
+ go ig = ig :> (go (rules' <@> (duplicate ig)))
+ rules' = background $ executeRules rules
+
+main :: IO ()
+main = do
+ let ig = sheet X initialGame
+ let tl = timeline conwayRules ig
+ forM_ (takeS 5 tl) $ \s -> do
+ printSheet 3 s
+ putStrLn "---"
projects / advent-of-code-18.git / commitdiff