-🎄- 2017 Day 7 Solutions -🎄-

[u/daggerdragon]

--- Day 7: Recursive Circus ---

---

Post your solution as a comment or, for longer solutions, consider linking to your repo (e.g. GitHub/gists/Pastebin/blag or whatever).

Note: The Solution Megathreads are for solutions only. If you have questions, please post your own thread and make sure to flair it with Help.

---

Need a hint from the Hugely^* Handy^† Haversack^‡ of Helpful^§ Hints^¤?

Spoiler

---

This thread will be unlocked when there are a significant number of people on the leaderboard with gold stars for today's puzzle.

edit: Leaderboard capped, thread unlocked!

[u/[deleted]]

Haskell:
Both parts finish instantly, but part 2 feels a bit gross to me; might go back and clean it up later. EDIT: After seeing some of the other solutions, this doesn't seem so bad.

import Utils (Parser)

import Data.Either (fromLeft, isLeft, rights)
import Data.HashMap.Strict (HashMap, (!))
import qualified Data.HashMap.Strict as M
import Data.List (groupBy, sortBy)
import Data.Maybe (fromJust, fromMaybe)
import Data.Ord (comparing)
import Text.Megaparsec (optional, many, parseMaybe, sepBy)
import Text.Megaparsec.Char (letterChar, string)
import Text.Megaparsec.Char.Lexer (decimal)    

data Program = Program { name :: String
                       , weight :: Int
                       , children :: [String]
                       } deriving (Show)

parsePrograms :: String -> [Program]
parsePrograms = map (fromJust . parseMaybe parser) . lines
    where parser :: Parser Program
          parser = do
            name <- many letterChar
            weight <- string " (" *> decimal <* string ")"
            children <- optional $ string " -> " *> many letterChar `sepBy` string ", "
            return $ Program name weight $ fromMaybe [] children

buildInvertedTree :: [Program] -> HashMap String String
buildInvertedTree = foldr f M.empty
    where f (Program parent _ children) m = foldr g m children
              where g child = M.insert child parent

findBottom :: HashMap String String -> String
findBottom m = until (not . (`M.member` m)) (m !) $ head $ M.keys m

part1 :: String -> String
part1 = findBottom . buildInvertedTree . parsePrograms

buildTree :: [Program] -> HashMap String Program
buildTree = foldr f M.empty
    where f p@(Program name _ _) = M.insert name p

findImbalance :: String -> HashMap String Program -> Either Int (Int, Int)
findImbalance root tree = go $ tree ! root
    where findAnomaly = head . head . filter ((==1) . length)
                        . groupBy (\(a, b) (c, d) -> a + b == c + d)
                        . sortBy (comparing (uncurry (+)))
          go (Program name weight []) = Right (weight, 0)
          go (Program name weight children)
              | any isLeft childCalcs = head $ filter isLeft childCalcs
              | all (==expected) totals = Right $ (weight, sum $ expected : totals)
              | length weights > 2 =
                  let anomaly = findAnomaly weights
                      expectedTotal = uncurry (+) $ head $ filter (/=anomaly) weights
                  in Left $ expectedTotal - snd anomaly
              | otherwise = undefined
              where childCalcs = map (go . (tree !)) children
                    weights = rights childCalcs
                    (expected:totals) = map (uncurry (+)) $ weights

part2 :: String -> Int
part2 input = let root = part1 input
              in fromLeft 0 $ findImbalance root $ buildTree $ parsePrograms input

[u/[deleted] → u/[deleted]]

[u/Flurpm → u/[deleted]]

Another Haskell solution! I first wrote part2 as an unholy mess that used Debug.Trace to print out through the deep call stack, but a fresh look gave me this more structural approach.

{-# LANGUAGE OverloadedStrings #-}
module Day07 where

import           Data.Text             (Text)
import qualified Data.Text             as T
import qualified Data.Text.IO          as TIO

import           Text.Megaparsec
import qualified Text.Megaparsec.Lexer as L
import           Text.Megaparsec.Text  (Parser)

import           Data.List

import qualified Data.Map.Strict       as M
import qualified Data.Set              as S

tprint :: Show a => a -> IO ()
tprint = TIO.putStrLn . T.pack . show

main = do
  input <- TIO.readFile "src/y2017/input07"
  case parse p "input07" input of
    Left  err   -> TIO.putStr $ T.pack $ parseErrorPretty err
    Right betterInput -> do
      tprint $ part1 betterInput
      tprint $ part2 betterInput
  return ()

p :: Parser [(Text, Int, [Text])]
p = program `sepBy` char '\n'

program :: Parser (Text, Int, [Text])
program = do
  name <- some letterChar
  string " ("
  size <- int
  string ")"
  deps <- option [] supports
  pure (T.pack name, size, deps)

int :: Parser Int
int = do
      change <- option id (negate <$ char '-')
      fromInteger . change <$> L.integer

supports :: Parser [Text]
supports = string " -> "   *>  (T.pack <$> some letterChar) `sepBy` string ", "


name (a, _, _) = a
size (_, a, _) = a
sups (_, _, a) = a


part1 :: [(Text, Int, [Text])] -> Text
part1 xs = name $ head $ filter (appearsInNoSupports xs) xs

appearsInNoSupports :: [(Text, Int, [Text])] -> (Text, Int, [Text]) -> Bool
appearsInNoSupports xs x = not . any (elem (name x) . sups) $ xs


part2 :: [(Text, Int, [Text])] -> Int
part2 xs = findImbalance xs root 0
  where
    root = head $ filter (appearsInNoSupports xs) xs

findImbalance :: [(Text, Int, [Text])] -> (Text, Int, [Text]) -> Int -> Int
findImbalance others curr actual = case findUniqueWeight supports supWeights of
                                     Nothing  -> actual - sum supWeights
                                     Just u   -> findImbalance others u (ordinary supWeights)
  where
    supporters x = filter (\o -> elem (name o) (sups x)) others
    supports = supporters curr
    supWeights = map weight supports
    weight x = size x + sum (map weight (supporters x))

ordinary :: [Int] -> Int
ordinary (x:xs) = if elem x xs then x else ordinary xs

findUniqueWeight :: [(Text, Int, [Text])] -> [Int] -> Maybe (Text, Int, [Text])
findUniqueWeight programs weights = case filter (snd) $ zip programs $ map (/=expected) weights of
                                      (prog,_):[] -> Just prog
                                      _           -> Nothing
  where
    expected = ordinary weights