-
Notifications
You must be signed in to change notification settings - Fork 0
/
12.hs
executable file
·308 lines (275 loc) · 9.09 KB
/
12.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
#!/usr/bin/env stack
{- stack --resolver=nightly-2018-12-12 script --compile
--package "ansi-terminal containers here megaparsec monad-loops mtl pretty-show safe scanf split time timeit vector"
-}
-- relude
-- {-# Language NoImplicitPrelude #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
-- import Relude
import Control.Monad.Loops
import Control.Monad.State
import Debug.Trace
import Data.Bifunctor
import Data.CallStack
import Data.Char
import Data.Either
import Data.Foldable
import Data.Function
import Data.IntMap (IntMap)
import qualified Data.IntMap.Strict as IntMap
import Data.List as L
import Data.List.Split
import qualified Data.Map as M
import Data.Maybe
import Data.Ord
import qualified Data.Sequence as S
import qualified Data.Set as Set
import Data.String.Here
import Data.Time.Calendar
import Data.Time.Clock
import qualified Data.Vector.Unboxed as V
import Debug.Trace
import System.Console.ANSI
import System.Environment
import System.IO
import System.IO.Unsafe
import System.Exit
import System.TimeIt
import qualified Text.Megaparsec as P
import qualified Text.Megaparsec.Char as P
import Text.Printf
import qualified Text.Scanf as SC
import Text.Show.Pretty
pp :: Show a => a -> IO ()
pp = putStrLn . ppShow
ltrace :: Show a => String -> a -> a
ltrace msg x =
trace (msg++": "++show x)
x
-- | Trace (print to stderr) a showable value using a custom show function.
traceWith :: (a -> String) -> a -> a
traceWith f a = trace (f a) a
iterateN :: Int -> (a -> a) -> (a -> a)
iterateN n f = (!! n) . iterate f -- n must be positive
first3 (x,_,_) = x
second3 (_,x,_) = x
third3 (_,_,x) = x
first4 (x,_,_,_) = x
second4 (_,x,_,_) = x
third4 (_,_,x,_) = x
fourth4 (_,_,_,x) = x
forceSpine :: [a] -> ()
forceSpine = foldr (const id) ()
forceAllElementsWHNF :: [a] -> ()
forceAllElementsWHNF = foldr seq ()
--
testinput = [here|
initial state: #..#.#..##......###...###
...## => #
..#.. => #
.#... => #
.#.#. => #
.#.## => #
.##.. => #
.#### => #
#.#.# => #
#.### => #
##.#. => #
##.## => #
###.. => #
###.# => #
####. => #
|]
-- 1 2 3
-- 0 0 0 0
testoutput = [here|
0: ...#..#.#..##......###...###...........
1: ...#...#....#.....#..#..#..#...........
2: ...##..##...##....#..#..#..##..........
3: ..#.#...#..#.#....#..#..#...#..........
4: ...#.#..#...#.#...#..#..##..##.........
5: ....#...##...#.#..#..#...#...#.........
6: ....##.#.#....#...#..##..##..##........
7: ...#..###.#...##..#...#...#...#........
8: ...#....##.#.#.#..##..##..##..##.......
9: ...##..#..#####....#...#...#...#.......
10: ..#.#..#...#.##....##..##..##..##......
11: ...#...##...#.#...#.#...#...#...#......
12: ...##.#.#....#.#...#.#..##..##..##.....
13: ..#..###.#....#.#...#....#...#...#.....
14: ..#....##.#....#.#..##...##..##..##....
15: ..##..#..#.#....#....#..#.#...#...#....
16: .#.#..#...#.#...##...#...#.#..##..##...
17: ..#...##...#.#.#.#...##...#....#...#...
18: ..##.#.#....#####.#.#.#...##...##..##..
19: .#..###.#..#.#.#######.#.#.#..#.#...#..
20: .#....##....#####...#######....#.#..##.
|]
input = [here|
initial state: ###....#..#..#......####.#..##..#..###......##.##..#...#.##.###.##.###.....#.###..#.#.##.#..#.#
..### => #
..... => .
..#.. => .
.###. => .
...## => #
#.### => .
#.#.# => #
##..# => .
##.## => #
#...# => .
..##. => .
##.#. => .
...#. => .
#..#. => #
.#### => #
.#..# => #
##... => #
.##.# => .
....# => .
#.... => .
.#.#. => #
.##.. => .
###.# => #
####. => .
##### => #
#.##. => #
.#... => #
.#.## => #
###.. => #
#..## => .
#.#.. => #
..#.# => .
|]
type P = Bool -- plant
type PS = V.Vector P -- finite sequence of plants
type Rule = (PS,P) -- a rule for updating a plant based on its left and right neighbours
type X = Int -- x coordinate relative to the origin
type Region = (X,PS) -- a bounded region of plants, starting at the left x coordinate
type G = (Int,Region) -- the nth generation of plants. The region encloses all live plants.
type Score = Int -- a generation's live plants pot score
type Verbosity = Int -- verbosity level
neighbourhoodradius = 2
neighbourhoodlength = 2 * neighbourhoodradius + 1
parse :: String -> (G,[Rule])
parse s = (g0, rules)
where
l:_:ls = lines s
g0 = (0, (0, V.fromList $ map toplant $ drop 15 l) )
rules = map parserule ls
parserule :: String -> Rule
parserule s = (V.fromList $ map toplant ns, toplant p)
where
(ns,rest) = splitAt neighbourhoodlength s
p = last rest
toplant '#' = True
toplant _ = False
fromplant True = '#'
fromplant _ = '.'
-- show this generation's live region (from left-most to right-most live plants).
-- regions are displayed left-aligned, followed by the coordinates of those left-
-- and right-most plants.
showGeneration :: HasCallStack => G -> String
showGeneration (i,(x,ps)) =
printf "%11d: %4d,%4d %s" i x (x+l-1) (map fromplant $ V.toList ps)
where
l = V.length ps
generationScore :: HasCallStack => G -> Score
generationScore (_,(x,ps)) = sum $ map snd $ filter fst $ zip (V.toList ps) [x..]
-- given a region and an absolute x position that lies within that region,
-- get the neighbourhood-sized region of plants centered at that x position.
-- where the neighbourhood extends beyond the main region, it is filled with empty pots.
getPlants :: HasCallStack => Region -> X -> PS
getPlants (regionleftx,ps) centerx
| centerx < regionleftx || centerx > regionleftx + V.length ps =
error $ "getPlants x:"++show centerx++" is outside region"
| otherwise =
let
leftx = centerx - neighbourhoodradius
rightx = centerx + neighbourhoodradius
emptypots = V.replicate neighbourhoodradius False
ps' = V.concat [emptypots,ps,emptypots]
in
V.slice (-- traceWith (\l -> "slice "++show l++"-"++show (l+neighbourhoodlength)) $
leftx-regionleftx+neighbourhoodradius) neighbourhoodlength ps'
-- apply rules to decide one plant's next state.
-- arguments: rules, current live region of plants, absolute x position of this plant.
-- returns: this plant's new state.
updatePlant :: HasCallStack => [Rule] -> Region -> X -> P
updatePlant rules r px =
let
neighbourhood = getPlants r px
mp' = lookup neighbourhood rules
in
case mp' of
Just p' -> p'
Nothing -> False
-- | apply rules to generate next generation of plants.
-- may cause the live region to grow or shrink as plants are born or die at the ends.
--
-- >>> g = g0
-- >>> putStrLn $ showGeneration g
-- 0: 0, 24 #..#.#..##......###...###
-- >>> g <- nextgen 2 rules g
-- 1: 0, 24 #...#....#.....#..#..#..#
-- >>> g <- nextgen 2 rules g
-- 2: 0, 25 ##..##...##....#..#..#..##
-- >>> g <- nextgen 2 rules g
-- 3: -1, 25 #.#...#..#.#....#..#..#...#
-- >>> g <- nextgen 2 rules g
-- 4: 0, 26 #.#..#...#.#...#..#..##..##
--
nextgen :: HasCallStack => Verbosity -> [Rule] -> Int -> G -> IO G
nextgen verbosity rules maxn (i, oldregion@(x,ps)) =
let
l = V.length ps
emptypots = V.replicate neighbourhoodradius False
enlargedregion = (x-neighbourhoodradius, emptypots V.++ ps V.++ emptypots)
ps' = V.map (updatePlant rules enlargedregion) $ V.fromList [x-neighbourhoodradius .. x+l+neighbourhoodradius-1]
(newx,newps) = shrinkRegion (x-neighbourhoodradius, ps')
g' = (i+1, (newx,newps))
in
do
when (verbosity>=2) $ putStrLn $ showGeneration g'
when (verbosity==1 && i `mod` 1000 == 0) $ putStrLn $ showGeneration g'
if ps /= newps
then return g'
else do
let
dx = newx - x
gensremaining = maxn - (i+1)
finalx = newx + gensremaining * dx
finalgen = (maxn, (finalx,newps))
printf "plants are stable, early exit.\n"
printf "x changing by %d, %d generations to go, predicted final region start %d\n" dx gensremaining finalx
return finalgen
-- | shrink the live region to exclude any empty pots at the ends.
shrinkRegion :: Region -> Region
shrinkRegion (x,ps) = (x',ps')
where
(leftpots,rest) = V.break id ps
x' = x + V.length leftpots
(rightpots,_) = V.break id $ V.reverse ps
ps' = V.take (V.length rest - V.length rightpots) rest
-- run for n generations, printing each generation or other progress info depending on verbosity level,
-- and returning the last generation's live plants score.
run :: HasCallStack => String -> Int -> Verbosity -> IO Score -- initial state and rules input, number of generations to run, verbosity level
run input n verbosity = do
let (g0,rules) = parse input
when (verbosity>=2) $ putStrLn $ showGeneration g0
g <- iterateUntilM ((==n).fst) (nextgen verbosity rules n) g0
return $ generationScore g
(g0,rules) = parse testinput
iog1 = nextgen 0 rules 20 g0
iog2 = iog1 >>= nextgen 0 rules 20
main :: HasCallStack => IO ()
main = do
putStrLn "part 1: "
timeItShow $ run testinput 20 2 -- 325
putStrLn "\npart 2: "
args <- getArgs
let n:verbosity:[] = take 2 $ args ++ ["50000000000","0"]
timeItShow $ run input (read n) (read verbosity) -- 1700000000011, 0.14s
return ()