2024-12-04 17:15:59 +11:00
{- # OPTIONS_GHC - Wno - x - partial # -}
2024-12-03 11:18:01 +11:00
import Aoc
import Data.List.Split ( splitOn )
import Data.List ( nub )
import Data.Tuple ( swap )
import Data.Maybe ( fromJust )
type Pref = ( ( String , String ) , Int )
parseLine :: String -> Pref
parseLine line =
let [ a , " would " , verb , points , " happiness " , " units " , " by " , " sitting " , " next " , " to " , b ] = words line in
let [ b' , " " ] = splitOn " . " b in
let sign = case verb of { " lose " -> - 1 ; " gain " -> 1 } in
( ( a , b' ) , sign * read points )
process :: [ Pref ] -> ( [ String ] , [ Pref ] )
process prefs = ( people , prefs )
where people = nub $ concatMap ( unpair . fst ) prefs
scoreLookup :: [ Pref ] -> ( String , String ) -> Int
scoreLookup prefs pair = fromJust ( lookup pair prefs ) + fromJust ( lookup ( swap pair ) prefs )
part1 :: ( [ String ] , [ Pref ] ) -> Int
part1 ( people , prefs ) = maximum $ map ( sum . map ( scoreLookup prefs ) . adjacents . ( first : ) . ( ++ [ first ] ) ) $ permutations $ tail people
where first = head people
-- it's probably more efficient to actually go through the list of prefs to find the one that is decreasing the score the most for each permutation, rather than just doing part1 again with another person, but it is fast enough for me to not bother.
part2 :: ( [ String ] , [ Pref ] ) -> Int
part2 ( people , prefs ) = part1 ( " " : people , concatMap ( \ p -> [ ( ( " " , p ) , 0 ) , ( ( p , " " ) , 0 ) ] ) people ++ prefs )
main :: IO ()
main = aocMain ( process . map parseLine ) part1 part2
