Day 18

4 files changed, 294 insertions, 0 deletions

diff --git a/day18/input.txt b/day18/input.txt
new file mode 100644
index 0000000..5cb1e48
--- /dev/null
+++ b/day18/input.txt
@@ -0,0 +1,100 @@
+[[[[3,0],[0,0]],1],4]
+[[[[3,4],0],[7,7]],[1,6]]
+[[[[2,0],5],7],[[[3,1],[2,6]],[[0,8],6]]]
+[[[[5,5],0],1],[[[0,0],1],[[0,6],[0,9]]]]
+[[0,[0,[1,7]]],[3,[1,[7,6]]]]
+[[[9,[5,2]],[[5,2],[6,8]]],[[[7,0],7],[[2,3],[9,4]]]]
+[[[[3,8],7],[[0,7],[2,0]]],[0,[[2,9],0]]]
+[[[7,[2,2]],[3,4]],[6,7]]
+[8,[[[3,3],8],[[7,1],[6,7]]]]
+[[9,[9,8]],[[1,[9,1]],[2,5]]]
+[[[7,8],[[1,2],[2,6]]],[[9,7],[6,[7,0]]]]
+[[[3,3],[[5,6],5]],[[[2,8],1],9]]
+[[[2,[5,0]],[[9,9],[4,0]]],[0,5]]
+[[[9,3],[[9,4],[5,8]]],[[[3,2],[7,1]],[[3,8],1]]]
+[[3,2],[[6,[0,9]],[8,3]]]
+[[[5,7],[[7,4],[4,6]]],[[[9,8],3],3]]
+[[[4,[2,8]],9],[[[8,5],[9,7]],[[8,9],[2,6]]]]
+[[[1,[2,4]],6],[[8,[5,2]],[[0,7],[4,1]]]]
+[[[[4,3],6],[[6,4],[4,2]]],[[9,0],[[5,9],9]]]
+[[[[3,0],6],[4,[7,5]]],4]
+[[[[1,0],[7,1]],0],[[[8,5],8],2]]
+[[[[2,9],[4,1]],[[8,9],[3,3]]],[9,[[0,7],2]]]
+[[1,[4,[4,2]]],[[[3,5],[8,8]],2]]
+[[[8,[1,4]],[[6,5],5]],[[7,[4,7]],4]]
+[[[[0,5],2],[[9,2],0]],0]
+[[[[6,2],[2,4]],[0,[7,3]]],[9,[8,[5,9]]]]
+[[8,0],2]
+[[[[0,2],2],[[9,2],[8,1]]],[[[7,6],[5,3]],6]]
+[[[[8,7],[5,3]],[[3,0],8]],[[[8,4],[2,2]],[[8,1],2]]]
+[[[[1,5],[4,6]],[[4,0],[2,4]]],[[1,1],[[0,7],[7,3]]]]
+[[7,2],[[7,[6,7]],[8,5]]]
+[[[9,7],[[6,6],9]],8]
+[[4,2],[[[1,0],[9,1]],[[0,7],[8,0]]]]
+[[[[5,9],5],[8,9]],[[2,4],[[5,2],[8,3]]]]
+[[[[4,5],[7,0]],[4,5]],[[7,[6,4]],[[1,7],[6,3]]]]
+[[2,0],4]
+[[2,[[5,1],[2,1]]],[[5,[7,2]],[[2,3],[7,0]]]]
+[[4,[4,9]],[9,[6,8]]]
+[[[[6,1],[1,5]],[0,[4,0]]],[[[7,0],2],4]]
+[[[[3,3],[2,2]],[[2,4],2]],[[8,[1,1]],4]]
+[[[[1,5],8],[[9,4],[7,7]]],[[[8,7],[7,2]],[0,[7,3]]]]
+[9,[[7,[0,4]],4]]
+[4,[0,8]]
+[[[[2,6],1],[8,[8,4]]],[[8,2],[1,[8,4]]]]
+[[7,[8,[8,8]]],[4,1]]
+[[0,6],[[7,[5,9]],[[7,1],8]]]
+[4,6]
+[[[[3,2],[5,6]],[0,7]],[8,[7,[9,5]]]]
+[[[3,7],[4,5]],6]
+[[[0,[3,9]],[9,1]],6]
+[[[[7,3],8],[6,7]],[[1,0],[1,7]]]
+[[[5,[4,8]],2],[[[7,1],6],[[0,3],2]]]
+[[1,0],[[1,2],[[2,0],1]]]
+[[8,[[6,1],[7,1]]],0]
+[[9,[2,0]],[[7,[6,2]],4]]
+[[[9,[9,4]],[[4,8],3]],[[9,0],[[2,2],[0,6]]]]
+[[[7,5],[[2,9],6]],[[2,4],[[1,1],[8,2]]]]
+[[[1,[6,3]],[[2,2],[1,8]]],[[[7,3],[6,0]],[4,[7,6]]]]
+[6,5]
+[[3,[9,[4,4]]],[[6,9],[4,5]]]
+[[[4,[1,8]],[[4,0],6]],[[[9,0],[8,3]],[[8,6],[3,2]]]]
+[[[8,[1,2]],[[3,9],6]],[[3,0],1]]
+[[1,[2,[4,0]]],6]
+[0,[[[1,3],[9,1]],[[3,8],[9,4]]]]
+[2,[2,[[2,7],[7,8]]]]
+[[[3,0],[[4,6],2]],[9,2]]
+[[[5,[2,2]],[[2,7],[9,9]]],[[3,[4,4]],[8,[9,8]]]]
+[[[[7,5],[7,9]],[[8,5],6]],[[1,[8,4]],[8,2]]]
+[[[6,4],[5,5]],[[[8,1],5],[[6,4],[6,9]]]]
+[[[[8,9],0],[[4,6],7]],[[[3,9],[6,4]],[8,[7,4]]]]
+[4,[[7,7],4]]
+[[[[4,9],[1,2]],[8,[4,7]]],[[8,[4,8]],[0,[5,4]]]]
+[1,[7,9]]
+[[[5,[2,0]],[[4,3],[6,8]]],[9,9]]
+[[[[3,9],9],[4,3]],[1,[3,[8,1]]]]
+[[[[8,7],[6,1]],[3,9]],[5,[[8,0],4]]]
+[[[[8,2],[4,6]],[6,[9,9]]],[1,[[7,7],4]]]
+[[7,5],[[5,0],[0,3]]]
+[[[6,0],[9,1]],[[[4,3],[5,0]],[[9,5],[0,0]]]]
+[8,[[3,6],3]]
+[[[[9,3],7],[1,3]],[[[6,4],[8,4]],[1,5]]]
+[[[[3,8],2],[5,4]],[[[1,8],5],[2,[2,7]]]]
+[[2,9],[6,[0,2]]]
+[[2,[7,9]],[[4,1],[[9,2],[0,7]]]]
+[[0,[6,4]],[[9,2],[0,[0,7]]]]
+[[[[7,2],[8,6]],[6,2]],[[[1,6],[2,2]],1]]
+[[1,6],[[[4,3],[8,2]],[3,[9,4]]]]
+[[9,[7,3]],[[[7,0],4],[[1,7],[2,2]]]]
+[[7,[5,[9,8]]],[[[7,5],[7,6]],[7,[9,8]]]]
+[[[[6,1],[4,3]],4],[[[5,9],4],2]]
+[[[[5,1],[2,5]],0],[[7,[5,7]],[[4,4],9]]]
+[9,2]
+[4,[[[6,6],5],7]]
+[[8,[[7,3],[0,7]]],8]
+[[[3,4],[[2,3],0]],[[[9,6],[1,1]],[4,[0,4]]]]
+[[[[3,3],[2,3]],[2,5]],[[4,[2,7]],3]]
+[[[8,[0,3]],2],[4,4]]
+[[[3,5],[[2,1],[3,4]]],[[0,3],4]]
+[[[[4,1],4],2],[[[3,7],2],[[8,1],3]]]
+[[[[0,6],[7,3]],[5,[3,9]]],[7,[[4,1],8]]]
diff --git a/day18/main.hs b/day18/main.hs
new file mode 100644
index 0000000..29cf312
--- /dev/null
+++ b/day18/main.hs
@@ -0,0 +1,181 @@
+module Main where
+
+import Data.Char (isDigit)
+import Data.Foldable (Foldable (foldl'))
+import Data.List (foldl1')
+import qualified Data.List as L
+import Data.Maybe (fromMaybe)
+import Debug.Trace (trace, traceShow, traceShowId)
+import Utils
+
+-- Snailfish number element
+data SFFlatE = SFFlatRegular Int | SFFlatStart | SFFlatEnd | SFFlatSep deriving (Eq)
+
+data SFTreeE = SFTreeRegular Int | SFTreePair (SFTreeE, SFTreeE) deriving (Eq)
+
+-- Snailfish number
+newtype SFFlatN = SFFlatN [SFFlatE] deriving (Eq)
+
+newtype SFTreeN = SFTreeN SFTreeE deriving (Eq)
+
+instance Num SFTreeN where
+  a + b = sfnSum a b
+  abs (SFTreeN a) = SFTreeN $ SFTreeRegular $ sfeMagn a
+
+instance Show SFTreeN where
+  show (SFTreeN sfe) = show sfe
+
+instance Show SFTreeE where
+  show (SFTreeRegular int) = show int
+  show (SFTreePair (a, b)) = "[" ++ show a ++ "," ++ show b ++ "]"
+
+instance Show SFFlatN where
+  show (SFFlatN sfes) = concatMap showSFFlatE sfes
+
+instance Show SFFlatE where
+  show = showSFFlatE
+
+showSFFlatE (SFFlatRegular int) = show int
+showSFFlatE SFFlatStart = "["
+showSFFlatE SFFlatEnd = "]"
+showSFFlatE SFFlatSep = ","
+
+expectSFFlatE :: SFFlatE -> [SFFlatE] -> [SFFlatE]
+expectSFFlatE expectedE (e : rest) =
+  if expectedE == e
+    then rest
+    else error $ "unexpected flat element: " ++ show e ++ ", expected: " ++ show expectedE
+expectSFFlatE _ [] = error "expectSFFlatE: empty []"
+
+flatToTree' :: [SFFlatE] -> (SFTreeE, [SFFlatE])
+flatToTree' (SFFlatStart : rest) =
+  let (result1, rest1) = flatToTree' rest
+      rest2 = expectSFFlatE SFFlatSep rest1
+      (result2, rest3) = flatToTree' rest2
+      rest4 = expectSFFlatE SFFlatEnd rest3
+   in (SFTreePair (result1, result2), rest4)
+flatToTree' ((SFFlatRegular int) : rest) =
+  (SFTreeRegular int, rest)
+flatToTree' other = error $ "weird flatToTree: " ++ show (SFFlatN other)
+
+flatToTree :: SFFlatN -> SFTreeN
+flatToTree (SFFlatN sfes) =
+  let (result, rest) = flatToTree' sfes
+   in if null rest
+        then SFTreeN result
+        else error $ "flatToTree incomplete: " ++ show (SFFlatN rest)
+
+treeToFlat' :: SFTreeE -> [SFFlatE]
+treeToFlat' (SFTreeRegular int) = [SFFlatRegular int]
+treeToFlat' (SFTreePair (a, b)) = concat [[SFFlatStart], treeToFlat' a, [SFFlatSep], treeToFlat' b, [SFFlatEnd]]
+
+treeToFlat :: SFTreeN -> SFFlatN
+treeToFlat (SFTreeN sfe) = SFFlatN $ treeToFlat' sfe
+
+sfnSum :: SFTreeN -> SFTreeN -> SFTreeN
+sfnSum (SFTreeN a) (SFTreeN b) =
+  let sum = SFTreeN $ SFTreePair (a, b)
+   in sfnReduce $ sum
+
+sfnReduceM :: SFTreeN -> Either SFTreeN SFTreeN
+sfnReduceM sfn =
+  let explodeM tree =
+        let exploded = sfnExplode tree
+         in if exploded /= tree then Left exploded else Right exploded
+      splitM tree =
+        let splitted = sfnSplit tree
+         in if splitted /= tree then Left splitted else Right splitted
+   in do
+        result1 <- explodeM sfn
+        result2 <- splitM sfn
+        return sfn
+
+sfnReduce sfn =
+  let afterReduce = sfnReduceM sfn
+   in case afterReduce of
+        Left sfn' -> sfnReduce sfn'
+        Right sfn' -> sfn'
+
+sfeMagn :: SFTreeE -> Int
+sfeMagn (SFTreeRegular int) = int
+sfeMagn (SFTreePair (a, b)) = 3 * sfeMagn a + 2 * sfeMagn b
+
+sfeSplitM :: SFTreeE -> Either SFTreeE SFTreeE
+sfeSplitM sfe@(SFTreeRegular int)
+  | int >= 10 = Left $ SFTreePair (SFTreeRegular $ int `div` 2, SFTreeRegular $ int - int `div` 2)
+  | otherwise = Right sfe
+sfeSplitM (SFTreePair (a, b)) = do
+  lhs <- case sfeSplitM a of
+    Left a' -> Left $ SFTreePair (a', b)
+    Right a' -> Right a'
+  rhs <- case sfeSplitM b of
+    Left b' -> Left $ SFTreePair (a, b')
+    Right b' -> Right b'
+  Right $ SFTreePair (lhs, rhs)
+
+sfnSplit :: SFTreeN -> SFTreeN
+sfnSplit (SFTreeN sfe) = sfe $> sfeSplitM .> fromSymEither .> SFTreeN
+
+sfnExplodeAtDepth :: Int -> Int -> SFFlatN -> Maybe ([SFFlatE], Int, SFFlatE, SFFlatE)
+sfnExplodeAtDepth idx 0 (SFFlatN (SFFlatStart : rest1)) =
+  let (leftValue : rest2) = rest1
+      (SFFlatSep : rest3) = rest2
+      (rightValue : rest4) = rest3
+      (SFFlatEnd : rest5) = rest4
+   in Just (SFFlatRegular 0 : rest5, idx, leftValue, rightValue)
+sfnExplodeAtDepth idx depth (SFFlatN (sfe : rest)) =
+  let depth' = case sfe of
+        SFFlatStart -> depth - 1
+        SFFlatEnd -> depth + 1
+        _ -> depth
+   in sfnExplodeAtDepth (idx + 1) depth' (SFFlatN rest) $> fmap (\(rest, b, c, d) -> (sfe : rest, b, c, d))
+sfnExplodeAtDepth idx depth (SFFlatN []) = Nothing
+
+replaceLeftRegularIfExists :: Int -> SFFlatE -> SFFlatN -> SFFlatN
+replaceLeftRegularIfExists idx replacement sfn@(SFFlatN sfes) =
+  let elemAtIdx = sfes !! idx
+      (SFFlatRegular rInt) = replacement
+   in case elemAtIdx of
+        SFFlatRegular int -> SFFlatN $ take idx sfes ++ [SFFlatRegular (rInt + int)] ++ drop (idx + 1) sfes
+        other -> if idx > 0 then replaceLeftRegularIfExists (idx - 1) replacement sfn else sfn
+
+replaceRightRegularIfExists :: Int -> SFFlatE -> SFFlatN -> SFFlatN
+replaceRightRegularIfExists idx replacement sfn@(SFFlatN sfes) =
+  let elemAtIdx = sfes !! idx
+      (SFFlatRegular rInt) = replacement
+   in case elemAtIdx of
+        SFFlatRegular int -> SFFlatN $ take idx sfes ++ [SFFlatRegular (rInt + int)] ++ drop (idx + 1) sfes
+        other -> if idx < length sfes - 1 then replaceRightRegularIfExists (idx + 1) replacement sfn else sfn
+
+sfnExplodeM :: SFTreeN -> Maybe SFTreeN
+sfnExplodeM tree = do
+  let flat1 = treeToFlat tree
+  (flat2', idx, leftValue, rightValue) <- sfnExplodeAtDepth 0 4 flat1
+  let flat2 = SFFlatN flat2'
+  let flat3 = replaceLeftRegularIfExists (idx - 1) leftValue flat2
+  let flat4 = replaceRightRegularIfExists (idx + 1) rightValue flat3
+  return (flatToTree flat4)
+
+sfnExplode :: SFTreeN -> SFTreeN
+sfnExplode tree = fromMaybe tree $ sfnExplodeM tree
+
+parseStringToSFFlatN ('[' : rest) = SFFlatStart : parseStringToSFFlatN rest
+parseStringToSFFlatN (']' : rest) = SFFlatEnd : parseStringToSFFlatN rest
+parseStringToSFFlatN (',' : rest) = SFFlatSep : parseStringToSFFlatN rest
+parseStringToSFFlatN (' ' : rest) = parseStringToSFFlatN rest
+parseStringToSFFlatN "" = []
+parseStringToSFFlatN other = SFFlatRegular (read $ takeWhile isDigit other) : parseStringToSFFlatN (dropWhile isDigit other)
+
+main :: IO ()
+main = do
+  contents <- getContents
+  let flats = contents $> lines .> map (parseStringToSFFlatN .> SFFlatN)
+  let trees = flats $> map flatToTree
+  let reduceResult = foldl1' (+) trees
+  print reduceResult
+  let magnResult = abs reduceResult
+  print magnResult
+
+  let allPairs = [(a, b) | a <- trees, b <- trees, a /= b]
+  let biggestMagn = allPairs $> map (uncurry (+) .> abs .> (\(SFTreeN (SFTreeRegular mag)) -> mag)) .> maximum
+  print biggestMagn
diff --git a/day18/simple.txt b/day18/simple.txt
new file mode 100644
index 0000000..d4d76ae
--- /dev/null
+++ b/day18/simple.txt
@@ -0,0 +1,3 @@
+[1,2]
+[3,4]
+[6,7]
diff --git a/day18/test.txt b/day18/test.txt
new file mode 100644
index 0000000..20d54d0
--- /dev/null
+++ b/day18/test.txt
@@ -0,0 +1,10 @@
+[[[0,[4,5]],[0,0]],[[[4,5],[2,6]],[9,5]]]
+[7,[[[3,7],[4,3]],[[6,3],[8,8]]]]
+[[2,[[0,8],[3,4]]],[[[6,7],1],[7,[1,6]]]]
+[[[[2,4],7],[6,[0,5]]],[[[6,8],[2,8]],[[2,1],[4,5]]]]
+[7,[5,[[3,8],[1,4]]]]
+[[2,[2,2]],[8,[8,1]]]
+[2,9]
+[1,[[[9,3],9],[[9,0],[0,7]]]]
+[[[5,[7,4]],7],1]
+[[[[4,2],2],6],[8,7]]
\ No newline at end of file