-
Notifications
You must be signed in to change notification settings - Fork 0
/
day-18.hs
executable file
·206 lines (168 loc) · 5.46 KB
/
day-18.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
#!/usr/bin/env stack
-- stack --resolver=lts-18.18 script --package split --package containers --package array --package PSQueue --package mtl
import Data.Char
import Data.List
import Data.List.Split
import qualified Data.Map as M
import Control.Monad.State
testExplosions = "\
\[[[[[9,8],1],2],3],4]\n\
\[7,[6,[5,[4,[3,2]]]]]\n\
\[[6,[5,[4,[3,2]]]],1]\n\
\[[3,[2,[1,[7,3]]]],[6,[5,[4,[3,2]]]]]"
testSplits = "\
\[10,0]\n\
\[0,[11,0]]\n\
\[0,[0,11]]\n\
\[0,[0,0]]"
testMagnitudes = "\
\[[1,2],[[3,4],5]]\n\
\[[[[0,7],4],[[7,8],[6,0]]],[8,1]]\n\
\[[[[1,1],[2,2]],[3,3]],[4,4]]\n\
\[[[[3,0],[5,3]],[4,4]],[5,5]]\n\
\[[[[5,0],[7,4]],[5,5]],[6,6]]\n\
\[[[[8,7],[7,7]],[[8,6],[7,7]]],[[[0,7],[6,6]],[8,7]]]"
main :: IO ()
main = do
putStrLn "Explosions"
mapM_ (putStrLn . show . explode . zipper) $ parseExpressions testExplosions
putStrLn "Splits"
mapM_ (putStrLn . show . sfSplit . zipper) $ parseExpressions testSplits
putStrLn "Reduce"
putStrLn $ show $ reduce $ head $ parseExpressions "[[[[[4,3],4],4],[7,[[8,4],9]]],[1,1]]"
putStrLn "Add"
putStrLn $ show $ addAll $ parseExpressions "[[[[4,3],4],4],[7,[[8,4],9]]]\n[1,1]"
putStrLn $ show $ addAll $ parseExpressions "[1,1]\n[2,2]\n[3,3]\n[4,4]"
putStrLn $ show $ addAll $ parseExpressions "[1,1]\n[2,2]\n[3,3]\n[4,4]\n[5,5]"
putStrLn $ show $ addAll $ parseExpressions "[1,1]\n[2,2]\n[3,3]\n[4,4]\n[5,5]\n[6,6]"
putStrLn "Magnitude"
mapM_ (putStrLn . show . magnitude) $ parseExpressions testMagnitudes
putStrLn "Input"
nums <- fmap parseExpressions getContents
let finalSum = addAll nums
putStrLn $ show $ finalSum
putStrLn $ show $ magnitude finalSum
putStrLn "Largest Sum of Pairs by Magnitude"
putStrLn $ show $ largestPairMagnitude nums
biSplit :: Eq a => [a] -> [a] -> ([a], [a])
biSplit delim s = (a, concat (b:c))
where (a:b:c) = splitOn delim s
mapFirst :: (a -> Bool) -> (a -> a) -> [a] -> [a]
mapFirst _ _ [] = []
mapFirst pred act (a:as)
| pred a = act a:as
| otherwise = a:mapFirst pred act as
cmpFst :: Ord a => (a, b) -> (a, b) -> Ordering
cmpFst (a1, _) (a2, _) = a1 `compare` a2
cmpSnd :: Ord b => (a, b) -> (a, b) -> Ordering
cmpSnd (_, b1) (_, b2) = b1 `compare` b2
data Sf = Pair Sf Sf | Leaf Int deriving(Eq)
instance Show Sf where
show (Leaf n) = show n
show (Pair l r) = "[" ++ show l ++ "," ++ show r ++ "]"
data Crumb = L Sf | R Sf
isLeft :: Crumb -> Bool
isLeft (L _) = True
isLeft _ = False
isRight :: Crumb -> Bool
isRight = not . isLeft
cmap :: (Sf -> Sf) -> Crumb -> Crumb
cmap act (L sf) = L $ act sf
cmap act (R sf) = R $ act sf
type Zipper = (Sf, [Crumb])
goLeft :: Zipper -> Zipper
goLeft (Pair l r, cs) = (l, L r:cs)
goRight :: Zipper -> Zipper
goRight (Pair l r, cs) = (r, R l:cs)
goUp :: Zipper -> Zipper
goUp (l, L r:cs) = (Pair l r, cs)
goUp (r, R l:cs) = (Pair l r, cs)
zipper :: Sf -> Zipper
zipper sf@(Pair l r) = (sf, [])
zipUp :: Zipper -> Sf
zipUp (sf, []) = sf
zipUp z = zipUp $ goUp z
zipUpTo :: (Crumb -> Bool) -> Zipper -> Maybe Zipper
zipUpTo _ (_, []) = Nothing
zipUpTo pred z@(sf, c:_)
| pred c = Just $ goUp z
| otherwise = zipUpTo pred $ goUp z
type Parser = State String
pull :: Int -> Parser String
pull n = do
prefix <- gets $ take n
modify $ drop n
return prefix
pullWhile :: (Char -> Bool) -> Parser String
pullWhile predicate = do
(prefix, remainder) <- gets $ span predicate
put remainder
return prefix
parseExpression :: Parser Sf
parseExpression = do
first <- gets head
case first of
'[' -> do
modify tail
left <- parseExpression
modify tail
right <- parseExpression
modify tail
return $ Pair left right
_ -> do
val <- fmap read $ pullWhile (`notElem` ",]")
return $ Leaf val
parseExpressions :: String -> [Sf]
parseExpressions s = map (evalState parseExpression) $ lines s
explode :: Zipper -> Sf
explode (Pair (Leaf l) (Leaf r), cs@(a:b:c:d:_)) = zipUp explodedZip
where
zerodZip = (Leaf 0, cs)
addedLeftZip = modifyLeft (addRight l) zerodZip
explodedZip = modifyRight (addLeft r) addedLeftZip
explode z@(Leaf n, _) =
case nextRight of
Just z' -> explode $ goRight z'
Nothing -> zipUp z
where nextRight = zipUpTo isLeft z
explode z = explode $ goLeft z
modifyLeft :: (Sf -> Sf) -> Zipper -> Zipper
modifyLeft act (sf, cs) = (sf, mapFirst isRight (cmap act) cs)
modifyRight :: (Sf -> Sf) -> Zipper -> Zipper
modifyRight act (sf, cs) = (sf, mapFirst isLeft (cmap act) cs)
addLeft :: Int -> Sf -> Sf
addLeft n (Leaf m) = Leaf $ n + m
addLeft n (Pair l r) = Pair (addLeft n l) r
addRight :: Int -> Sf -> Sf
addRight n (Leaf m) = Leaf $ n + m
addRight n (Pair l r) = Pair l (addRight n r)
sfSplit :: Zipper -> Sf
sfSplit z@(Leaf n, cs)
| n >= 10 = let half = fromIntegral n / 2 in zipUp $ (Pair (Leaf $ floor half) (Leaf $ ceiling half), cs)
| otherwise =
let nextRight = zipUpTo isLeft z in
case nextRight of
Just z' -> sfSplit $ goRight z'
Nothing -> zipUp z
sfSplit z = sfSplit $ goLeft z
reduce :: Sf -> Sf
reduce sf
| sf /= exploded = reduce exploded
| sf /= split = reduce split
| otherwise = sf
where
zip = zipper sf
exploded = explode zip
split = sfSplit zip
add :: Sf -> Sf -> Sf
add l r = reduce $ Pair l r
addAll :: [Sf] -> Sf
addAll = foldl1 add
magnitude :: Sf -> Int
magnitude (Leaf n) = n
magnitude (Pair l r) = 3 * magnitude l + 2 * magnitude r
largestPairMagnitude :: [Sf] -> (Int, (Sf, Sf))
largestPairMagnitude sfs = maximumBy cmpFst $ do
l <- sfs
r <- sfs
if l /= r then return (magnitude $ l `add` r, (l, r)) else []