day 11
part 2 actually worked without optimizations, but i almost made out of ram so i made the optimizations
This commit is contained in:
parent
6b1ab660ac
commit
00062fcb2a
|
@ -0,0 +1,150 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
import qualified Data.Text as T
|
||||
import Data.Char (isSpace, isNumber)
|
||||
import Data.List (find, isPrefixOf, stripPrefix, intercalate, sort)
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.List.Split (startsWith, splitOn)
|
||||
import GHC.Utils.Misc (nTimes)
|
||||
|
||||
{- cabal:
|
||||
build-depends: base, split
|
||||
-}
|
||||
|
||||
-- i've been told this needs bigints so i've switched all Ints storing worry values to Integers
|
||||
|
||||
data Operation = Add Integer | Multiply Integer | MultiplySelf
|
||||
deriving (Show, Eq)
|
||||
|
||||
execOperation :: Operation -> Integer -> Integer
|
||||
execOperation (Add n) x = x + n
|
||||
execOperation (Multiply n) x = x * n
|
||||
execOperation MultiplySelf x = x * x
|
||||
|
||||
newtype Condition = Divisible Integer
|
||||
deriving (Show, Eq)
|
||||
|
||||
check :: Condition -> Integer -> Bool
|
||||
check (Divisible n) x = x `mod` n == 0
|
||||
|
||||
newtype Test = Test (Condition, Int, Int)
|
||||
deriving (Show, Eq)
|
||||
|
||||
executeTest :: Test -> Integer -> Int
|
||||
executeTest (Test (cond, a, b)) n = if check cond n then a else b
|
||||
|
||||
data Monkey = Monkey {
|
||||
monkeyItems :: [Integer],
|
||||
monkeyOperation :: Operation,
|
||||
monkeyTest :: Test
|
||||
} deriving (Show, Eq)
|
||||
|
||||
trim :: String -> String
|
||||
trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
|
||||
|
||||
replace :: Int -> a -> [a] -> [a]
|
||||
replace pos newVal list = take pos list ++ newVal : drop (pos+1) list
|
||||
|
||||
findByPrefix :: String -> [String] -> Maybe String
|
||||
findByPrefix prefix = find (prefix `isPrefixOf`)
|
||||
|
||||
findByPrefixAndStrip :: String -> [String] -> Maybe String
|
||||
findByPrefixAndStrip prefix list = do
|
||||
el <- findByPrefix prefix list
|
||||
stripPrefix prefix el
|
||||
|
||||
giveMonkeyItem :: Monkey -> Integer -> Monkey
|
||||
giveMonkeyItem monkey item = Monkey (monkeyItems monkey ++ [item]) (monkeyOperation monkey) (monkeyTest monkey)
|
||||
|
||||
parseMonkey :: String -> Monkey
|
||||
parseMonkey m = monkey
|
||||
where
|
||||
-- let's just assume the dataset isn't malformed, okay................. just This Once, index promise
|
||||
monkey = Monkey (fromJust parseItems) (fromJust parseOperation) (fromJust parseTest)
|
||||
|
||||
parseItems :: Maybe [Integer]
|
||||
parseItems = do
|
||||
itemsStr <- findByPrefixAndStrip "Starting items: " ln
|
||||
return $ map read $ splitOn "," itemsStr
|
||||
parseOperation :: Maybe Operation
|
||||
parseOperation = do
|
||||
operationStr <- findByPrefixAndStrip "Operation: new = " ln
|
||||
let [leftHand, op, rightHand] = words operationStr
|
||||
return $ case op of
|
||||
"+" -> Add $ read rightHand
|
||||
"*" -> if rightHand == "old" then MultiplySelf else Multiply $ read rightHand
|
||||
p -> error $ "Unknown operator " ++ p
|
||||
parseTest :: Maybe Test
|
||||
parseTest = do
|
||||
cond <- parseCondition
|
||||
outcomeTrue <- parseOutcome "true"
|
||||
outcomeFalse <- parseOutcome "false"
|
||||
return $ Test (cond, outcomeTrue, outcomeFalse)
|
||||
parseCondition :: Maybe Condition
|
||||
parseCondition = do
|
||||
conditionStr <- findByPrefixAndStrip "Test: " ln
|
||||
let w = words conditionStr
|
||||
nStr <- find (isNumber . head) w
|
||||
let n = read nStr
|
||||
return $ case head w of
|
||||
"divisible" -> Divisible n
|
||||
cond -> error $ "Unknown condition" ++ cond
|
||||
parseOutcome :: String -> Maybe Int
|
||||
parseOutcome s = do
|
||||
outcomeStr <- findByPrefixAndStrip ("If " ++ s ++ ": ") ln
|
||||
return $ read $ last $ words outcomeStr
|
||||
|
||||
ln = map trim $ lines m
|
||||
|
||||
parse :: String -> [Monkey]
|
||||
parse l = map (parseMonkey . unlines . drop 1 . lines . T.unpack) $ T.splitOn "\n\n" $ T.pack l
|
||||
|
||||
-- > The process of each monkey taking a single turn is called a round.
|
||||
executeRound :: [Monkey] -> [(Monkey, Int)]
|
||||
executeRound monkeys = foldl executeTurn (zip monkeys (repeat 0)) [0 .. length monkeys - 1]
|
||||
where
|
||||
executeTurn :: [(Monkey, Int)] -> Int -> [(Monkey, Int)]
|
||||
executeTurn monkeys idx = replace idx (newMonkeys !! idx, inspectCount + itemCount) $ zip newMonkeys (map snd monkeys)
|
||||
where
|
||||
newMonkeys = processItem (map fst monkeys) idx
|
||||
itemCount = length $ monkeyItems $ fst $ monkeys !! idx
|
||||
inspectCount = snd $ monkeys !! idx
|
||||
|
||||
processItem :: [Monkey] -> Int -> [Monkey]
|
||||
processItem monkeys idx
|
||||
| null items = monkeys
|
||||
| otherwise = processItem'
|
||||
where
|
||||
items = monkeyItems monkey
|
||||
operation = monkeyOperation monkey
|
||||
test = monkeyTest monkey
|
||||
monkey = monkeys !! idx
|
||||
|
||||
-- processItem' is called when we know the list is not empty. prevents Dumb Errors
|
||||
processItem' = processItem afterThrowItem idx
|
||||
where
|
||||
afterThrowItem = replace throwItemTo (giveMonkeyItem throwItemToMonkey newItem) afterRemoveItem
|
||||
afterRemoveItem = replace idx (Monkey newItems operation test) monkeys
|
||||
newItems = tail items
|
||||
throwItemToMonkey = monkeys !! throwItemTo
|
||||
throwItemTo = executeTest test newItem
|
||||
newItem = execOperation operation item `div` 3
|
||||
item = head items
|
||||
|
||||
executeRoundAccum :: [(Monkey, Int)] -> [(Monkey, Int)]
|
||||
executeRoundAccum m = zipWith (\x (m, y) -> (m, x + y)) inspections (executeRound monkeys)
|
||||
where
|
||||
monkeys = map fst m
|
||||
inspections = map snd m
|
||||
|
||||
-- lol
|
||||
getMonkeyBusiness :: [Int] -> Int
|
||||
getMonkeyBusiness values = sorted !! 0 * sorted !! 1
|
||||
where sorted = reverse $ sort values
|
||||
|
||||
main = interact $
|
||||
show
|
||||
. getMonkeyBusiness . map snd
|
||||
. nTimes 20 executeRoundAccum
|
||||
. (\monkeys -> zip monkeys (repeat 0))
|
||||
. parse
|
|
@ -0,0 +1,153 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
import qualified Data.Text as T
|
||||
import Data.Char (isSpace, isNumber)
|
||||
import Data.List (find, isPrefixOf, stripPrefix, intercalate, sort)
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.List.Split (startsWith, splitOn)
|
||||
import GHC.Utils.Misc (nTimes)
|
||||
|
||||
{- cabal:
|
||||
build-depends: base, split
|
||||
-}
|
||||
|
||||
-- i've been told this needs bigints so i've switched all Ints storing worry values to Integers
|
||||
|
||||
data Operation = Add Integer | Multiply Integer | MultiplySelf
|
||||
deriving (Show, Eq)
|
||||
|
||||
execOperation :: Operation -> Integer -> Integer
|
||||
execOperation (Add n) x = x + n
|
||||
execOperation (Multiply n) x = x * n
|
||||
execOperation MultiplySelf x = x * x
|
||||
|
||||
-- part 2 optimization checks mean that this can only be Divisible, sorry!
|
||||
newtype Condition = Divisible Integer
|
||||
deriving (Show, Eq)
|
||||
|
||||
check :: Condition -> Integer -> Bool
|
||||
check (Divisible n) x = x `mod` n == 0
|
||||
|
||||
newtype Test = Test (Condition, Int, Int)
|
||||
deriving (Show, Eq)
|
||||
|
||||
executeTest :: Test -> Integer -> Int
|
||||
executeTest (Test (cond, a, b)) n = if check cond n then a else b
|
||||
|
||||
data Monkey = Monkey {
|
||||
monkeyItems :: [Integer],
|
||||
monkeyOperation :: Operation,
|
||||
monkeyTest :: Test
|
||||
} deriving (Show, Eq)
|
||||
|
||||
trim :: String -> String
|
||||
trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
|
||||
|
||||
replace :: Int -> a -> [a] -> [a]
|
||||
replace pos newVal list = take pos list ++ newVal : drop (pos+1) list
|
||||
|
||||
findByPrefix :: String -> [String] -> Maybe String
|
||||
findByPrefix prefix = find (prefix `isPrefixOf`)
|
||||
|
||||
findByPrefixAndStrip :: String -> [String] -> Maybe String
|
||||
findByPrefixAndStrip prefix list = do
|
||||
el <- findByPrefix prefix list
|
||||
stripPrefix prefix el
|
||||
|
||||
giveMonkeyItem :: Monkey -> Integer -> Monkey
|
||||
giveMonkeyItem monkey item = Monkey (monkeyItems monkey ++ [item]) (monkeyOperation monkey) (monkeyTest monkey)
|
||||
|
||||
parseMonkey :: String -> Monkey
|
||||
parseMonkey m = monkey
|
||||
where
|
||||
-- let's just assume the dataset isn't malformed, okay................. just This Once, index promise
|
||||
monkey = Monkey (fromJust parseItems) (fromJust parseOperation) (fromJust parseTest)
|
||||
|
||||
parseItems :: Maybe [Integer]
|
||||
parseItems = do
|
||||
itemsStr <- findByPrefixAndStrip "Starting items: " ln
|
||||
return $ map read $ splitOn "," itemsStr
|
||||
parseOperation :: Maybe Operation
|
||||
parseOperation = do
|
||||
operationStr <- findByPrefixAndStrip "Operation: new = " ln
|
||||
let [leftHand, op, rightHand] = words operationStr
|
||||
return $ case op of
|
||||
"+" -> Add $ read rightHand
|
||||
"*" -> if rightHand == "old" then MultiplySelf else Multiply $ read rightHand
|
||||
p -> error $ "Unknown operator " ++ p
|
||||
parseTest :: Maybe Test
|
||||
parseTest = do
|
||||
cond <- parseCondition
|
||||
outcomeTrue <- parseOutcome "true"
|
||||
outcomeFalse <- parseOutcome "false"
|
||||
return $ Test (cond, outcomeTrue, outcomeFalse)
|
||||
parseCondition :: Maybe Condition
|
||||
parseCondition = do
|
||||
conditionStr <- findByPrefixAndStrip "Test: " ln
|
||||
let w = words conditionStr
|
||||
nStr <- find (isNumber . head) w
|
||||
let n = read nStr
|
||||
return $ case head w of
|
||||
"divisible" -> Divisible n
|
||||
cond -> error $ "Unknown condition" ++ cond
|
||||
parseOutcome :: String -> Maybe Int
|
||||
parseOutcome s = do
|
||||
outcomeStr <- findByPrefixAndStrip ("If " ++ s ++ ": ") ln
|
||||
return $ read $ last $ words outcomeStr
|
||||
|
||||
ln = map trim $ lines m
|
||||
|
||||
parse :: String -> [Monkey]
|
||||
parse l = map (parseMonkey . unlines . drop 1 . lines . T.unpack) $ T.splitOn "\n\n" $ T.pack l
|
||||
|
||||
-- > The process of each monkey taking a single turn is called a round.
|
||||
executeRound :: [Monkey] -> [(Monkey, Int)]
|
||||
executeRound monkeys = foldl executeTurn (zip monkeys (repeat 0)) [0 .. length monkeys - 1]
|
||||
where
|
||||
executeTurn :: [(Monkey, Int)] -> Int -> [(Monkey, Int)]
|
||||
executeTurn monkeys idx = replace idx (newMonkeys !! idx, inspectCount + itemCount) $ zip newMonkeys (map snd monkeys)
|
||||
where
|
||||
newMonkeys = processItem (map fst monkeys) idx
|
||||
itemCount = length $ monkeyItems $ fst $ monkeys !! idx
|
||||
inspectCount = snd $ monkeys !! idx
|
||||
|
||||
processItem :: [Monkey] -> Int -> [Monkey]
|
||||
processItem monkeys idx
|
||||
| null items = monkeys
|
||||
| otherwise = processItem'
|
||||
where
|
||||
items = monkeyItems monkey
|
||||
operation = monkeyOperation monkey
|
||||
test = monkeyTest monkey
|
||||
monkey = monkeys !! idx
|
||||
|
||||
-- processItem' is called when we know the list is not empty. prevents Dumb Errors
|
||||
processItem' = processItem afterThrowItem idx
|
||||
where
|
||||
afterThrowItem = replace throwItemTo (giveMonkeyItem throwItemToMonkey newItem) afterRemoveItem
|
||||
afterRemoveItem = replace idx (Monkey newItems operation test) monkeys
|
||||
newItems = tail items
|
||||
throwItemToMonkey = monkeys !! throwItemTo
|
||||
throwItemTo = executeTest test newItem
|
||||
newItem = execOperation operation item `mod` worryLimit
|
||||
item = head items
|
||||
-- bit ugly but it's alright
|
||||
worryLimit = product $ map ((\(Test (Divisible n, _, _)) -> n) . monkeyTest) monkeys
|
||||
|
||||
executeRoundAccum :: [(Monkey, Int)] -> [(Monkey, Int)]
|
||||
executeRoundAccum m = zipWith (\x (m, y) -> (m, x + y)) inspections (executeRound monkeys)
|
||||
where
|
||||
monkeys = map fst m
|
||||
inspections = map snd m
|
||||
|
||||
-- lol
|
||||
getMonkeyBusiness :: [Int] -> Int
|
||||
getMonkeyBusiness values = sorted !! 0 * sorted !! 1
|
||||
where sorted = reverse $ sort values
|
||||
|
||||
main = interact $
|
||||
show
|
||||
. getMonkeyBusiness . map snd
|
||||
. nTimes 10000 executeRoundAccum
|
||||
. (\monkeys -> zip monkeys (repeat 0))
|
||||
. parse
|
Loading…
Reference in New Issue