feat(2017.07-haskell): solve Part Two, terribly

VERSION

@@ -1 +1 @@
-2023.6.2.20
+2023.6.2.21

package.yaml

@@ -220,6 +220,8 @@ executables:
   aoc-2017-day07:
     <<: *executable
     main: AdventOfCode.Year2017.Day07
+    dependencies:
+      - extra
   aoc-2018-day01:
     <<: *executable
     main: AdventOfCode.Year2018.Day01

src/AdventOfCode/Year2017/Day07.hs

@@ -3,13 +3,16 @@
 module AdventOfCode.Year2017.Day07 where
 
 import AdventOfCode.Input (parseInput, parseString)
-import AdventOfCode.TH (defaultMainMaybe, inputFilePath)
+import AdventOfCode.TH (inputFilePath)
 import Control.Monad (void)
 import Data.Graph (Graph, Vertex)
 import qualified Data.Graph as Graph
+import Data.List (unfoldr)
+import Data.List.Extra (maximumOn, sumOn')
 import Data.Maybe (fromMaybe)
 import Data.Text (Text)
 import qualified Data.Text as Text
+import Data.Tuple.Extra (dupe, thd3)
 import Text.Trifecta
   ( Parser,
     commaSep,
@@ -26,16 +29,42 @@ import Text.Trifecta
 type GraphTuple = (Graph, Vertex -> ((Text, Integer), Text, [Text]), Text -> Maybe Vertex)
 
 main :: IO ()
-main = $(defaultMainMaybe)
+main =
+  do
+    input <- getInput
+    putStr "Part One: "
+    print =<< partOne input
+    putStr "Part Two: "
+    print =<< partTwo input
 
-partOne :: (MonadFail m) => GraphTuple -> m Text
+partOne :: (MonadFail m) => GraphTuple -> m (Either Text Integer)
 partOne (graph, nodeFromVertex, _vertexFromKey) =
   case Graph.topSort graph of
-    top : _ -> let (_, name, _) = nodeFromVertex top in pure name
+    top : _ -> let (_, name, _) = nodeFromVertex top in pure (Left name)
     [] -> fail "Empty graph!"
 
-partTwo :: (MonadFail m) => GraphTuple -> m Text
-partTwo = undefined
+partTwo :: (MonadFail m) => GraphTuple -> m (Either Text Integer)
+partTwo (graph, nodeFromVertex, vertexFromKey) =
+  case map nodeFromVertex . take 2 . reverse $ iterateMaybe go (head (Graph.topSort graph)) of
+    [((_, weight), _, _), (_, _, stack)] ->
+      let weightsAbove = map weightAbove stack
+       in pure . Right $ weight - maximum weightsAbove + minimum weightsAbove
+    _unexpected -> fail "Shame!"
+  where
+    go vertex =
+      let stack = thd3 (nodeFromVertex vertex)
+          weights = [(k', weightAbove k') | k' <- stack]
+          (maxK, maxWeight) = maximumOn snd weights
+       in if all ((== maxWeight) . snd) weights
+            then Nothing
+            else vertexFromKey maxK
+    weightAbove k =
+      case nodeFromVertex <$> vertexFromKey k of
+        Just ((_, w), _, stack) -> w + sumOn' weightAbove stack
+        Nothing -> 0
+
+iterateMaybe :: (a -> Maybe a) -> a -> [a]
+iterateMaybe f x = x : unfoldr (fmap dupe . f) x
 
 getInput :: IO GraphTuple
 getInput = parseInput parseGraph $(inputFilePath)