From 9d0577cc4c0de3b9904ed8e5fceea6e33f149f75 Mon Sep 17 00:00:00 2001 From: Neil Smith Date: Mon, 24 Jul 2023 15:57:34 +0100 Subject: [PATCH] Optimised day 19 --- advent-of-code22.cabal | 31 ++++ advent19/Main.hs | 242 ++++++++++++++++++------------- advent19/MainExplicitClosed.hs | 258 +++++++++++++++++++++++++++++++++ advent19/MainOriginal.hs | 224 ++++++++++++++++++++++++++++ advent19/MainSingle.hs | 224 ++++++++++++++++++++++++++++ 5 files changed, 878 insertions(+), 101 deletions(-) create mode 100644 advent19/MainExplicitClosed.hs create mode 100644 advent19/MainOriginal.hs create mode 100644 advent19/MainSingle.hs diff --git a/advent-of-code22.cabal b/advent-of-code22.cabal index 8a1b109..2301cd2 100644 --- a/advent-of-code22.cabal +++ b/advent-of-code22.cabal @@ -278,11 +278,42 @@ executable advent18 main-is: advent18/Main.hs build-depends: text, attoparsec, containers, linear, lens +executable advent19original + import: common-extensions, build-directives + main-is: advent19/MainOriginal.hs + build-depends: text, attoparsec, containers, pqueue, mtl, lens, multiset, parallel, deepseq + executable advent19 import: common-extensions, build-directives main-is: advent19/Main.hs build-depends: text, attoparsec, containers, pqueue, mtl, lens, multiset, parallel, deepseq +executable advent19prof + import: common-extensions, build-directives + main-is: advent19/Main.hs + build-depends: text, attoparsec, containers, pqueue, mtl, lens, multiset, parallel, deepseq + ghc-options: -O2 + -Wall + -threaded + -fprof-auto + -rtsopts "-with-rtsopts=-N -p -s -hT" + -- add -ls for generating the eventlog + +executable advent19excl + import: common-extensions, build-directives + main-is: advent19/MainExplicitClosed.hs + build-depends: text, attoparsec, containers, pqueue, mtl, lens, multiset, parallel, deepseq + +executable advent19exprof + import: common-extensions, build-directives + main-is: advent19/MainExplicitClosed.hs + build-depends: text, attoparsec, containers, pqueue, mtl, lens, multiset, parallel, deepseq + ghc-options: -O2 + -Wall + -threaded + -fprof-auto + -rtsopts "-with-rtsopts=-N -p -s -hT" + executable advent20 import: common-extensions, build-directives main-is: advent20/Main.hs diff --git a/advent19/Main.hs b/advent19/Main.hs index 25f608a..55f6bbb 100644 --- a/advent19/Main.hs +++ b/advent19/Main.hs @@ -1,6 +1,7 @@ -- Writeup at https://work.njae.me.uk/2022/12/21/advent-of-code-2022-day-19/ +-- Optimised at https://work.njae.me.uk/2023/07/24/optimising-haskell-example-4/ --- import Debug.Trace +import Debug.Trace import AoC import Data.Text (Text) @@ -12,7 +13,7 @@ import qualified Data.Set as S import qualified Data.Sequence as Q import qualified Data.Map.Strict as M import Data.Map.Strict ((!)) -import Data.MultiSet as MS +import qualified Data.MultiSet as MS import Data.Sequence ((|>)) import Data.List import Data.Maybe @@ -23,17 +24,19 @@ import GHC.Generics (Generic) import Control.Parallel.Strategies import Control.DeepSeq --- pattern Empty <- (Q.viewl -> Q.EmptyL) where Empty = Q.empty --- pattern x :< xs <- (Q.viewl -> x Q.:< xs) where (:<) = (Q.<|) --- pattern xs :> x <- (Q.viewr -> xs Q.:> x) where (:>) = (Q.|>) data Resource = Ore | Clay | Obsidian | Geode - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic, Enum, Bounded) instance NFData Resource type Collection = MS.MultiSet Resource +hashCollection :: Collection -> Int +hashCollection c = + let k = 200 + in sum $ zipWith (\r n -> (MS.occur r c) * n) [minBound .. maxBound] $ iterate (* k) 1 + type Blueprint = M.Map Resource Collection data TimedBlueprint = TimedBlueprint { getBlueprint :: Blueprint, getTimeLimit :: Int, getMaxRobots :: Collection} @@ -41,63 +44,31 @@ data TimedBlueprint = TimedBlueprint { getBlueprint :: Blueprint, getTimeLimit : type BlueprintContext = Reader TimedBlueprint -data SingleSearchState = SingleSearchState +data SearchState = SearchState { _resources :: Collection , _robots :: Collection + , _currentTime :: Int } deriving (Eq, Show, Ord) -makeLenses ''SingleSearchState +makeLenses ''SearchState + +type StateHash = (Int, Int, Int) +hashSearchState :: SearchState -> StateHash +hashSearchState s = (hashCollection (s ^. resources), hashCollection (s ^. robots), s ^. currentTime) -instance NFData SingleSearchState where - rnf (SingleSearchState a b) = rnf a `seq` rnf b `seq` () +instance NFData SearchState where + rnf (SearchState a b c) = rnf a `seq` rnf b `seq` rnf c `seq` () -data Agendum s = - Agendum { _current :: s - , _trail :: Q.Seq s +data Agendum = + Agendum { _current :: SearchState + , _trail :: Q.Seq SearchState , _trailBenefit :: Int , _benefit :: Int } deriving (Show, Eq, Ord) makeLenses ''Agendum -type Agenda s = P.MaxPQueue Int (Agendum s) - -type ExploredStates s = S.Set (s, Int, Int) - - -class (Eq s, Ord s, Show s) => SearchState s where - emptySearchState :: s - successors :: s -> BlueprintContext (Q.Seq s) - estimateBenefit :: s -> Int -> BlueprintContext Int - -instance SearchState SingleSearchState where - emptySearchState = SingleSearchState { _resources = MS.empty, _robots = MS.singleton Ore } - - successors state = - do blueprint <- asks getBlueprint - maxRobots <- asks getMaxRobots - let buildableRobots = M.keys $ M.filter (\required -> required `MS.isSubsetOf` (state ^. resources)) blueprint - --- if more bots than needed for making any single bot, don't make more of that bot - let usefulRobots = MS.foldOccur (\res maxNeeded rs -> - if (MS.occur res (state ^. robots)) >= maxNeeded - then Data.List.delete res rs - else rs - ) buildableRobots maxRobots - let madeRobots = [ state & robots %~ MS.insert robot - & resources %~ ( `MS.difference` (blueprint ! robot) ) - | robot <- usefulRobots - ] - let afterBuild = [state] ++ madeRobots - let afterGather = fmap (\s -> s & resources %~ (MS.union (state ^. robots))) afterBuild - return $ Q.fromList afterGather - - - estimateBenefit currentState timeElapsed = - do timeLimit <- asks getTimeLimit - let timeRemaining = timeLimit - (timeElapsed + 1) - let currentGeodes = MS.occur Geode (currentState ^. resources) - let currentRobotsGather = (MS.occur Geode (currentState ^. robots)) * timeRemaining - let newRobotsGather = (timeRemaining * (timeRemaining + 1)) `div` 2 - return $ currentGeodes + currentRobotsGather + newRobotsGather +type Agenda = P.MaxPQueue Int Agendum +type ExploredStates = S.Set StateHash main :: IO () main = @@ -107,88 +78,157 @@ main = print $ part1 blueprints print $ part2 blueprints -part1 :: [(Int, Blueprint)] -> Int +part1, part2 :: [(Int, Blueprint)] -> Int part1 blueprints = sum [n * (MS.occur Geode (r ^. resources)) | (n, r) <- results] - where results = [ (n, _current $ fromJust $ runReader searchSpace (TimedBlueprint blueprint 24 (robotLimits blueprint)) ) - | (n, blueprint) <- blueprints ] :: [(Int, SingleSearchState)] - robotLimits bp = M.foldl' MS.maxUnion MS.empty bp --- part1 blueprints = sum [n * (MS.occur Geode (r ^. resources)) | (n, r) <- pResults] --- where -- results = [ (n, _current $ fromJust $ runReader searchSpace (TimedBlueprint blueprint 24 (robotLimits blueprint)) ) --- -- | (n, blueprint) <- blueprints ] :: [(Int, SingleSearchState)] --- -- pResults = parMap rdeepseq id results --- -- pResults = (fmap runABlueprint blueprints) `using` parList rdeepseq --- pResults = (fmap runABlueprint blueprints) `using` (parList rdeepseq) --- runABlueprint (n, blueprint) = (n, _current $ fromJust $ --- runReader searchSpace (TimedBlueprint blueprint 24 (robotLimits blueprint)) ) --- robotLimits bp = M.foldl' MS.maxUnion MS.empty bp - -part2 :: [(Int, Blueprint)] -> Int -part2 blueprints = product [MS.occur Geode (r ^. resources) | r <- pResults] - where results = [ _current $ fromJust $ runReader searchSpace (TimedBlueprint blueprint 32 (robotLimits blueprint)) - | (_, blueprint) <- (take 3 blueprints) ] :: [SingleSearchState] - pResults = parMap rdeepseq id results - robotLimits bp = M.foldl' MS.maxUnion MS.empty bp - -searchSpace :: SearchState s => BlueprintContext (Maybe (Agendum s)) +-- part1 blueprints = results + -- where results = fmap (scoreBlueprint 24) blueprints + where results = parMap rdeepseq (scoreBlueprint 24) blueprints + +-- part2 :: [(Int, Blueprint)] -> Int +part2 blueprints = product [MS.occur Geode (r ^. resources) | (_, r) <- results] + -- where results = fmap (scoreBlueprint 32) $ take 3 blueprints + where results = parMap rdeepseq (scoreBlueprint 32) $ take 3 blueprints + +robotLimits :: Blueprint -> Collection +robotLimits bp = M.foldl' MS.maxUnion MS.empty bp + +scoreBlueprint :: Int -> (Int, Blueprint) -> (Int, SearchState) +scoreBlueprint t (n, bp) = ( n + , runReader searchSpace (TimedBlueprint bp t (robotLimits bp)) + ) + +searchSpace :: BlueprintContext SearchState searchSpace = do agenda <- initAgenda - -- aStar agenda S.empty - res <- aStar agenda S.empty - return (res `seq` res) + -- searchAll agenda S.empty emptySearchState + result <- aStar agenda S.empty + return $ (fromJust result) ^. current -initAgenda :: SearchState s => BlueprintContext (Agenda s) +initAgenda :: BlueprintContext Agenda initAgenda = do let startState = emptySearchState - b <- estimateBenefit startState 0 + b <- estimateBenefit startState return $ P.singleton b Agendum { _current = startState, _trail = Q.empty, _trailBenefit = 0, _benefit = b} -aStar :: SearchState s => Agenda s -> ExploredStates s -> BlueprintContext (Maybe (Agendum s)) + +aStar :: Agenda -> ExploredStates -> BlueprintContext (Maybe Agendum) aStar agenda closed - -- | trace ("Peeping " ++ (show $ fst $ P.findMin agenda) ++ ": " ++ (show reached) ++ " <- " ++ (show $ toList $ Q.take 1 $ _trail $ currentAgendum) ++ " :: " ++ (show newAgenda)) False = undefined - -- | trace ("Peeping " ++ (show $ _current $ snd $ P.findMax agenda) ++ " benefit " ++ (show $ fst $ P.findMax agenda) ++ " : elapsed " ++ (show $ Q.length $ _trail $ snd $ P.findMax agenda)) False = undefined | P.null agenda = return Nothing | otherwise = do let (_, currentAgendum) = P.findMax agenda let reached = currentAgendum ^. current nexts <- candidates currentAgendum closed let newAgenda = foldl' (\q a -> P.insert (_benefit a) a q) (P.deleteMax agenda) nexts - -- let beamAgenda = P.fromDescList $ P.take 10000 newAgenda -- agenda beam width - -- let beamAgenda = P.fromDescList $ P.take 5000 newAgenda -- agenda beam width - reachedGoal <- isGoal currentAgendum - let cl = (reached, currentAgendum ^. trailBenefit, Q.length $ currentAgendum ^. trail) - if reachedGoal + let cl = hashSearchState reached + atTimeLimit <- isTimeLimit currentAgendum + if atTimeLimit then return (Just currentAgendum) else if (cl `S.member` closed) then aStar (P.deleteMax agenda) closed - -- else aStar newAgenda (S.insert cl closed) else aStar newAgenda (S.insert cl closed) -candidates :: SearchState s => Agendum s -> ExploredStates s -> BlueprintContext (Q.Seq (Agendum s)) +candidates :: Agendum -> ExploredStates -> BlueprintContext (Q.Seq Agendum) candidates agendum closed = do let candidate = agendum ^. current let previous = agendum ^. trail - let prevBenefit = agendum ^. trailBenefit succs <- successors candidate - succAgs <- mapM (makeAgendum previous prevBenefit) succs - let nonloops = Q.filter (\s -> (s ^. current, s ^. trailBenefit, Q.length $ s ^. trail) `S.notMember` closed) succAgs + succAgs <- mapM (makeAgendum previous) succs + let nonloops = Q.filter (\s -> (hashSearchState $ s ^. current) `S.notMember` closed) succAgs return nonloops -makeAgendum :: SearchState s => Q.Seq s -> Int -> s -> BlueprintContext (Agendum s) -makeAgendum previous prevBenefit newState = - do predicted <- estimateBenefit newState (Q.length previous) +makeAgendum :: Q.Seq SearchState -> SearchState -> BlueprintContext Agendum +makeAgendum previous newState = + do predicted <- estimateBenefit newState let newTrail = previous |> newState - -- let incurred = geodesFound newState - let incurred = 0 + let incurred = (MS.occur Geode (newState ^. resources)) return Agendum { _current = newState , _trail = newTrail , _trailBenefit = incurred , _benefit = incurred + predicted } -isGoal :: SearchState s => Agendum s -> BlueprintContext Bool -isGoal agendum = +isTimeLimit :: Agendum -> BlueprintContext Bool +isTimeLimit agendum = do timeLimit <- asks getTimeLimit - return $ Q.length (agendum ^. trail) == timeLimit + return $ (agendum ^. current . currentTime) >= timeLimit + +emptySearchState :: SearchState +emptySearchState = SearchState { _resources = MS.empty, _robots = MS.singleton Ore, _currentTime = 0 } + +successors :: SearchState -> BlueprintContext (Q.Seq SearchState) +successors state = + do blueprint <- asks getBlueprint + maxRobots <- asks getMaxRobots + timeLimit <- asks getTimeLimit + + let robotSuccessors = Q.fromList $ catMaybes $ M.elems $ M.mapWithKey (handleRobot state maxRobots timeLimit) blueprint + + let timeRemaining = timeLimit - (state ^. currentTime) + let gathered = MS.foldOccur (\res n acc -> MS.insertMany res (n * timeRemaining) acc) + MS.empty + (state ^. robots) + let delayUntilEnd = (state & currentTime .~ timeLimit + & resources %~ (MS.union gathered) + ) + return ( robotSuccessors |> delayUntilEnd ) + +handleRobot :: SearchState -> Collection -> Int -> Resource -> Collection -> Maybe SearchState +handleRobot state maxRobots timeLimit robot recipe + | sufficientRobots robot state maxRobots = Nothing + | otherwise = buildWhenReady robot state recipe timeLimit + +-- do I already have enough of this robot? +sufficientRobots :: Resource -> SearchState -> Collection -> Bool +sufficientRobots robot state maxRobots = + (robot `MS.member` maxRobots) + && + ((MS.occur robot (state ^. robots)) >= (MS.occur robot maxRobots)) + +-- assuming I can't build this robot, how long do I have to wait for the current +-- robots to gather enough to build it? +buildDelay :: SearchState -> Collection -> Maybe Int +buildDelay state recipe + -- | MS.null delay = Just 0 + | all (\r -> MS.member r rbts) (MS.distinctElems shortfall) = Just $ maximum0 $ fmap snd $ MS.toOccurList delay + | otherwise = Nothing + where shortfall = recipe `MS.difference` (state ^. resources) + delay = MS.foldOccur calcOneDelay MS.empty shortfall + rbts = state ^. robots + calcOneDelay resource count acc = + MS.insertMany resource + -- (count `div` (MS.occur resource rbts) + 1) + (ceiling $ (fromIntegral count) / (fromIntegral $ MS.occur resource rbts)) + acc + maximum0 xs = if (null xs) then 0 else maximum xs + +buildWhenReady :: Resource -> SearchState -> Collection -> Int -> Maybe SearchState +buildWhenReady robot state recipe timeLimit = + do waitDelay <- buildDelay state recipe + delay <- tooLate (state ^. currentTime) (waitDelay + 1) timeLimit + let gathered = MS.foldOccur (\res n acc -> MS.insertMany res (n * delay) acc) + MS.empty + (state ^. robots) + return (state & robots %~ MS.insert robot -- add the robot + & resources %~ (MS.union gathered) -- add the gathered resources + & resources %~ ( `MS.difference` recipe ) -- remove the resources to build it + & currentTime %~ (+ delay) + ) + +tooLate :: Int -> Int -> Int -> Maybe Int +tooLate current delay timeLimit + | (current + delay) <= timeLimit = Just delay + | otherwise = Nothing + + +estimateBenefit :: SearchState -> BlueprintContext Int +estimateBenefit currentState = + do timeLimit <- asks getTimeLimit + let timeElapsed = currentState ^. currentTime + let timeRemaining = timeLimit - timeElapsed + let currentRobotsGather = (MS.occur Geode (currentState ^. robots)) * timeRemaining + let newRobotsGather = (timeRemaining * (timeRemaining + 1)) `div` 2 + return $ currentRobotsGather + newRobotsGather + -- Parse the input file @@ -219,4 +259,4 @@ successfulParse :: Text -> [(Int, Blueprint)] successfulParse input = case parseOnly blueprintsP input of Left _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err - Right blueprints -> blueprints \ No newline at end of file + Right blueprints -> blueprints diff --git a/advent19/MainExplicitClosed.hs b/advent19/MainExplicitClosed.hs new file mode 100644 index 0000000..9c5e3b8 --- /dev/null +++ b/advent19/MainExplicitClosed.hs @@ -0,0 +1,258 @@ +-- Writeup at https://work.njae.me.uk/2022/12/21/advent-of-code-2022-day-19/ +-- Optimised at https://work.njae.me.uk/2023/07/24/optimising-haskell-example-4/ + +import Debug.Trace + +import AoC +import Data.Text (Text) +import qualified Data.Text.IO as TIO +import Data.Attoparsec.Text hiding (take, D) +import Control.Applicative +import qualified Data.PQueue.Prio.Max as P +import qualified Data.Set as S +import qualified Data.Sequence as Q +import qualified Data.Map.Strict as M +import Data.Map.Strict ((!)) +import qualified Data.MultiSet as MS +import Data.Sequence ((|>)) +import Data.List +import Data.Maybe +-- import Data.Ord +import Control.Monad.Reader +import Control.Lens hiding ((<|), (|>), (:>), (:<), indices) +import GHC.Generics (Generic) +import Control.Parallel.Strategies +import Control.DeepSeq + +data Resource = Ore | Clay | Obsidian | Geode + deriving (Show, Eq, Ord, Generic) + +instance NFData Resource + +type Collection = MS.MultiSet Resource + + +type Blueprint = M.Map Resource Collection + +data TimedBlueprint = TimedBlueprint { getBlueprint :: Blueprint, getTimeLimit :: Int, getMaxRobots :: Collection} + deriving (Show, Eq, Ord) + +type BlueprintContext = Reader TimedBlueprint + +data SearchState = SearchState + { _resources :: Collection + , _robots :: Collection + , _currentTime :: Int + } deriving (Eq, Show, Ord) +makeLenses ''SearchState + + +instance NFData SearchState where + rnf (SearchState a b c) = rnf a `seq` rnf b `seq` rnf c `seq` () + +data Agendum = + Agendum { _current :: SearchState + , _trail :: Q.Seq SearchState + , _trailBenefit :: Int + , _benefit :: Int + } deriving (Show, Eq, Ord) +makeLenses ''Agendum + +type Agenda = P.MaxPQueue Int Agendum + +type ExploredStates = S.Set SearchState + +main :: IO () +main = + do dataFileName <- getDataFileName + text <- TIO.readFile dataFileName + let blueprints = successfulParse text + print $ part1 blueprints + print $ part2 blueprints + +part1, part2 :: [(Int, Blueprint)] -> Int +part1 blueprints = sum [n * (MS.occur Geode (r ^. resources)) | (n, r) <- results] +-- part1 blueprints = results + -- where results = fmap (scoreBlueprint 24) blueprints + where results = parMap rdeepseq (scoreBlueprint 24) blueprints + +-- part2 :: [(Int, Blueprint)] -> Int +part2 blueprints = product [MS.occur Geode (r ^. resources) | (_, r) <- results] + where results = parMap rdeepseq (scoreBlueprint 32) $ take 3 blueprints + +robotLimits :: Blueprint -> Collection +robotLimits bp = M.foldl' MS.maxUnion MS.empty bp + +scoreBlueprint :: Int -> (Int, Blueprint) -> (Int, SearchState) +scoreBlueprint t (n, bp) = ( n + , runReader searchSpace (TimedBlueprint bp t (robotLimits bp)) + ) + +searchSpace :: BlueprintContext SearchState +searchSpace = + do agenda <- initAgenda + -- searchAll agenda S.empty emptySearchState + result <- aStar agenda S.empty + return $ (fromJust result) ^. current + +initAgenda :: BlueprintContext Agenda +initAgenda = + do let startState = emptySearchState + b <- estimateBenefit startState + return $ P.singleton b Agendum { _current = startState, _trail = Q.empty, _trailBenefit = 0, _benefit = b} + +aStar :: Agenda -> ExploredStates -> BlueprintContext (Maybe Agendum) +aStar agenda closed + -- | trace ("Peeping " ++ (show $ fst $ P.findMin agenda) ++ ": " ++ (show reached) ++ " <- " ++ (show $ toList $ Q.take 1 $ _trail $ currentAgendum) ++ " :: " ++ (show newAgenda)) False = undefined + -- | trace ("Peeping " ++ (show $ _current $ snd $ P.findMax agenda) ++ " benefit " ++ (show $ fst $ P.findMax agenda) ++ " : elapsed " ++ (show $ Q.length $ _trail $ snd $ P.findMax agenda)) False = undefined + | P.null agenda = return Nothing + | otherwise = + do let (_, currentAgendum) = P.findMax agenda + let reached = currentAgendum ^. current + nexts <- candidates currentAgendum closed + let newAgenda = foldl' (\q a -> P.insert (_benefit a) a q) (P.deleteMax agenda) nexts + -- let cl = hashSearchState reached + atTimeLimit <- isTimeLimit currentAgendum + if atTimeLimit + then return (Just currentAgendum) + else if (reached `S.member` closed) + then aStar (P.deleteMax agenda) closed + -- else aStar newAgenda (S.insert cl closed) + else aStar newAgenda (S.insert reached closed) + +candidates :: Agendum -> ExploredStates -> BlueprintContext (Q.Seq Agendum) +candidates agendum closed = + do let candidate = agendum ^. current + let previous = agendum ^. trail + -- let nextLen = Q.length previous + 1 + let prevBenefit = agendum ^. trailBenefit + succs <- successors candidate + succAgs <- mapM (makeAgendum previous prevBenefit) succs + let nonloops = Q.filter (\s -> (s ^. current) `S.notMember` closed) succAgs + return nonloops + +makeAgendum :: Q.Seq SearchState -> Int -> SearchState -> BlueprintContext Agendum +makeAgendum previous prevBenefit newState = + -- do predicted <- estimateBenefit newState (Q.length previous) + do predicted <- estimateBenefit newState + let newTrail = previous |> newState + let incurred = (MS.occur Geode (newState ^. resources)) + return Agendum { _current = newState + , _trail = newTrail + , _trailBenefit = incurred + , _benefit = incurred + predicted + } + +isTimeLimit :: Agendum -> BlueprintContext Bool +isTimeLimit agendum = + do timeLimit <- asks getTimeLimit + -- return $ Q.length (agendum ^. trail) == timeLimit + return $ (agendum ^. current . currentTime) >= timeLimit + +emptySearchState :: SearchState +emptySearchState = SearchState { _resources = MS.empty, _robots = MS.singleton Ore, _currentTime = 0 } + +successors :: SearchState -> BlueprintContext (Q.Seq SearchState) +successors state = + do blueprint <- asks getBlueprint + maxRobots <- asks getMaxRobots + timeLimit <- asks getTimeLimit + + let robotSuccessors = Q.fromList $ catMaybes $ M.elems $ M.mapWithKey (handleRobot state maxRobots timeLimit) blueprint + + let timeRemaining = timeLimit - (state ^. currentTime) + let gathered = MS.foldOccur (\res n acc -> MS.insertMany res (n * timeRemaining) acc) + MS.empty + (state ^. robots) + let delayUntilEnd = (state & currentTime .~ timeLimit + & resources %~ (MS.union gathered) + ) + return ( robotSuccessors |> delayUntilEnd ) + +handleRobot :: SearchState -> Collection -> Int -> Resource -> Collection -> Maybe SearchState +handleRobot state maxRobots timeLimit robot recipe + | sufficientRobots robot state maxRobots = Nothing + -- | buildableRobot state recipe = buildRobotAndGather robot state recipe + | otherwise = buildWhenReady robot state recipe timeLimit + +-- do I already have enough of this robot? +sufficientRobots :: Resource -> SearchState -> Collection -> Bool +sufficientRobots robot state maxRobots = + (robot `MS.member` maxRobots) + && + ((MS.occur robot (state ^. robots)) >= (MS.occur robot maxRobots)) + +buildDelay :: SearchState -> Collection -> Maybe Int +buildDelay state recipe + -- | MS.null delay = Just 0 + | all (\r -> MS.member r rbts) (MS.distinctElems shortfall) = Just $ maximum0 $ fmap snd $ MS.toOccurList delay + | otherwise = Nothing + where shortfall = recipe `MS.difference` (state ^. resources) + delay = MS.foldOccur calcOneDelay MS.empty shortfall + rbts = state ^. robots + calcOneDelay resource count acc = + MS.insertMany resource + -- (count `div` (MS.occur resource rbts) + 1) + (ceiling $ (fromIntegral count) / (fromIntegral $ MS.occur resource rbts)) + acc + maximum0 xs = if (null xs) then 0 else maximum xs + +buildWhenReady :: Resource -> SearchState -> Collection -> Int -> Maybe SearchState +buildWhenReady robot state recipe timeLimit = + do waitDelay <- buildDelay state recipe + delay <- tooLate (state ^. currentTime) (waitDelay + 1) timeLimit + let gathered = MS.foldOccur (\res n acc -> MS.insertMany res (n * delay) acc) + MS.empty + (state ^. robots) + return (state & robots %~ MS.insert robot -- add the robot + & resources %~ (MS.union gathered) + & resources %~ ( `MS.difference` recipe ) -- remove the resources to build it + & currentTime %~ (+ delay) + ) + +tooLate :: Int -> Int -> Int -> Maybe Int +tooLate current delay timeLimit + | (current + delay) <= timeLimit = Just delay + | otherwise = Nothing + + +estimateBenefit :: SearchState -> BlueprintContext Int +estimateBenefit currentState = + do timeLimit <- asks getTimeLimit + let timeElapsed = currentState ^. currentTime + let timeRemaining = timeLimit - timeElapsed + let currentRobotsGather = (MS.occur Geode (currentState ^. robots)) * timeRemaining + let newRobotsGather = (timeRemaining * (timeRemaining + 1)) `div` 2 + return $ currentRobotsGather + newRobotsGather + + +-- Parse the input file + +blueprintsP :: Parser [(Int, Blueprint)] +blueprintP :: Parser (Int, Blueprint) +robotP :: Parser (Resource, Collection) +requirementsP :: Parser Collection +requirementP :: Parser (Resource, Int) +resourceP, oreP, clayP, obsidianP, geodeP :: Parser Resource + +blueprintsP = blueprintP `sepBy` endOfLine +blueprintP = blueprintify <$> (("Blueprint " *> decimal) <* ": ") <*> (robotP `sepBy` ". ") <* "." + where blueprintify n robots = + (n, M.fromList robots) +robotP = (,) <$> ("Each " *> resourceP) <*> (" robot costs " *> requirementsP) + +requirementsP = MS.fromOccurList <$> (requirementP `sepBy` " and ") + +requirementP = (flip (,)) <$> (decimal <* " ") <*> resourceP + +resourceP = oreP <|> clayP <|> obsidianP <|> geodeP +oreP = Ore <$ "ore" +clayP = Clay <$ "clay" +obsidianP = Obsidian <$ "obsidian" +geodeP = Geode <$ "geode" + +successfulParse :: Text -> [(Int, Blueprint)] +successfulParse input = + case parseOnly blueprintsP input of + Left _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err + Right blueprints -> blueprints \ No newline at end of file diff --git a/advent19/MainOriginal.hs b/advent19/MainOriginal.hs new file mode 100644 index 0000000..4252c7a --- /dev/null +++ b/advent19/MainOriginal.hs @@ -0,0 +1,224 @@ +-- Writeup at https://work.njae.me.uk/2022/12/21/advent-of-code-2022-day-19/ + +-- import Debug.Trace + +import AoC +import Data.Text (Text) +import qualified Data.Text.IO as TIO +import Data.Attoparsec.Text hiding (take, D) +import Control.Applicative +import qualified Data.PQueue.Prio.Max as P +import qualified Data.Set as S +import qualified Data.Sequence as Q +import qualified Data.Map.Strict as M +import Data.Map.Strict ((!)) +import Data.MultiSet as MS +import Data.Sequence ((|>)) +import Data.List +import Data.Maybe +-- import Data.Ord +import Control.Monad.Reader +import Control.Lens hiding ((<|), (|>), (:>), (:<), indices) +import GHC.Generics (Generic) +import Control.Parallel.Strategies +import Control.DeepSeq + +-- pattern Empty <- (Q.viewl -> Q.EmptyL) where Empty = Q.empty +-- pattern x :< xs <- (Q.viewl -> x Q.:< xs) where (:<) = (Q.<|) +-- pattern xs :> x <- (Q.viewr -> xs Q.:> x) where (:>) = (Q.|>) + +data Resource = Ore | Clay | Obsidian | Geode + deriving (Show, Eq, Ord, Generic) + +instance NFData Resource + +type Collection = MS.MultiSet Resource + +type Blueprint = M.Map Resource Collection + +data TimedBlueprint = TimedBlueprint { getBlueprint :: Blueprint, getTimeLimit :: Int, getMaxRobots :: Collection} + deriving (Show, Eq, Ord) + +type BlueprintContext = Reader TimedBlueprint + +data SingleSearchState = SingleSearchState + { _resources :: Collection + , _robots :: Collection + } deriving (Eq, Show, Ord) +makeLenses ''SingleSearchState + +instance NFData SingleSearchState where + rnf (SingleSearchState a b) = rnf a `seq` rnf b `seq` () + +data Agendum s = + Agendum { _current :: s + , _trail :: Q.Seq s + , _trailBenefit :: Int + , _benefit :: Int + } deriving (Show, Eq, Ord) +makeLenses ''Agendum + +type Agenda s = P.MaxPQueue Int (Agendum s) + +type ExploredStates s = S.Set (s, Int, Int) + + +class (Eq s, Ord s, Show s) => SearchState s where + emptySearchState :: s + successors :: s -> BlueprintContext (Q.Seq s) + estimateBenefit :: s -> Int -> BlueprintContext Int + +instance SearchState SingleSearchState where + emptySearchState = SingleSearchState { _resources = MS.empty, _robots = MS.singleton Ore } + + successors state = + do blueprint <- asks getBlueprint + maxRobots <- asks getMaxRobots + let buildableRobots = M.keys $ M.filter (\required -> required `MS.isSubsetOf` (state ^. resources)) blueprint + --- if more bots than needed for making any single bot, don't make more of that bot + let usefulRobots = MS.foldOccur (\res maxNeeded rs -> + if (MS.occur res (state ^. robots)) >= maxNeeded + then Data.List.delete res rs + else rs + ) buildableRobots maxRobots + let madeRobots = [ state & robots %~ MS.insert robot + & resources %~ ( `MS.difference` (blueprint ! robot) ) + | robot <- usefulRobots + ] + let afterBuild = [state] ++ madeRobots + let afterGather = fmap (\s -> s & resources %~ (MS.union (state ^. robots))) afterBuild + return $ Q.fromList afterGather + + + estimateBenefit currentState timeElapsed = + do timeLimit <- asks getTimeLimit + let timeRemaining = timeLimit - (timeElapsed + 1) + let currentGeodes = MS.occur Geode (currentState ^. resources) + let currentRobotsGather = (MS.occur Geode (currentState ^. robots)) * timeRemaining + let newRobotsGather = (timeRemaining * (timeRemaining + 1)) `div` 2 + return $ currentGeodes + currentRobotsGather + newRobotsGather + + +main :: IO () +main = + do dataFileName <- getDataFileName + text <- TIO.readFile dataFileName + let blueprints = successfulParse text + print $ part1 blueprints + -- print $ part2 blueprints + +-- part1 :: [(Int, Blueprint)] -> Int +part1 blueprints = sum [n * (MS.occur Geode (r ^. resources)) | (n, r) <- results] +-- part1 blueprints = pResults + where results = [ (n, _current $ fromJust $ runReader searchSpace (TimedBlueprint blueprint 24 (robotLimits blueprint)) ) + | (n, blueprint) <- blueprints ] :: [(Int, SingleSearchState)] + pResults = parMap rdeepseq id results + robotLimits bp = M.foldl' MS.maxUnion MS.empty bp +-- part1 blueprints = sum [n * (MS.occur Geode (r ^. resources)) | (n, r) <- pResults] +-- where -- results = [ (n, _current $ fromJust $ runReader searchSpace (TimedBlueprint blueprint 24 (robotLimits blueprint)) ) +-- -- | (n, blueprint) <- blueprints ] :: [(Int, SingleSearchState)] +-- -- pResults = parMap rdeepseq id results +-- -- pResults = (fmap runABlueprint blueprints) `using` parList rdeepseq +-- pResults = (fmap runABlueprint blueprints) `using` (parList rdeepseq) +-- runABlueprint (n, blueprint) = (n, _current $ fromJust $ +-- runReader searchSpace (TimedBlueprint blueprint 24 (robotLimits blueprint)) ) +-- robotLimits bp = M.foldl' MS.maxUnion MS.empty bp + +part2 :: [(Int, Blueprint)] -> Int +part2 blueprints = product [MS.occur Geode (r ^. resources) | r <- pResults] + where results = [ _current $ fromJust $ runReader searchSpace (TimedBlueprint blueprint 32 (robotLimits blueprint)) + | (_, blueprint) <- (take 3 blueprints) ] :: [SingleSearchState] + pResults = parMap rdeepseq id results + robotLimits bp = M.foldl' MS.maxUnion MS.empty bp + +searchSpace :: SearchState s => BlueprintContext (Maybe (Agendum s)) +searchSpace = + do agenda <- initAgenda + -- aStar agenda S.empty + res <- aStar agenda S.empty + return (res `seq` res) + +initAgenda :: SearchState s => BlueprintContext (Agenda s) +initAgenda = + do let startState = emptySearchState + b <- estimateBenefit startState 0 + return $ P.singleton b Agendum { _current = startState, _trail = Q.empty, _trailBenefit = 0, _benefit = b} + +aStar :: SearchState s => Agenda s -> ExploredStates s -> BlueprintContext (Maybe (Agendum s)) +aStar agenda closed + -- | trace ("Peeping " ++ (show $ fst $ P.findMin agenda) ++ ": " ++ (show reached) ++ " <- " ++ (show $ toList $ Q.take 1 $ _trail $ currentAgendum) ++ " :: " ++ (show newAgenda)) False = undefined + -- | trace ("Peeping " ++ (show $ _current $ snd $ P.findMax agenda) ++ " benefit " ++ (show $ fst $ P.findMax agenda) ++ " : elapsed " ++ (show $ Q.length $ _trail $ snd $ P.findMax agenda)) False = undefined + | P.null agenda = return Nothing + | otherwise = + do let (_, currentAgendum) = P.findMax agenda + let reached = currentAgendum ^. current + nexts <- candidates currentAgendum closed + let newAgenda = foldl' (\q a -> P.insert (_benefit a) a q) (P.deleteMax agenda) nexts + -- let beamAgenda = P.fromDescList $ P.take 10000 newAgenda -- agenda beam width + -- let beamAgenda = P.fromDescList $ P.take 5000 newAgenda -- agenda beam width + reachedGoal <- isGoal currentAgendum + let cl = (reached, currentAgendum ^. trailBenefit, Q.length $ currentAgendum ^. trail) + if reachedGoal + then return (Just currentAgendum) + else if (cl `S.member` closed) + then aStar (P.deleteMax agenda) closed + -- else aStar newAgenda (S.insert cl closed) + else aStar newAgenda (S.insert cl closed) + +candidates :: SearchState s => Agendum s -> ExploredStates s -> BlueprintContext (Q.Seq (Agendum s)) +candidates agendum closed = + do let candidate = agendum ^. current + let previous = agendum ^. trail + let prevBenefit = agendum ^. trailBenefit + succs <- successors candidate + succAgs <- mapM (makeAgendum previous prevBenefit) succs + let nonloops = Q.filter (\s -> (s ^. current, s ^. trailBenefit, Q.length $ s ^. trail) `S.notMember` closed) succAgs + return nonloops + +makeAgendum :: SearchState s => Q.Seq s -> Int -> s -> BlueprintContext (Agendum s) +makeAgendum previous prevBenefit newState = + do predicted <- estimateBenefit newState (Q.length previous) + let newTrail = previous |> newState + -- let incurred = geodesFound newState + let incurred = 0 + return Agendum { _current = newState + , _trail = newTrail + , _trailBenefit = incurred + , _benefit = incurred + predicted + } + +isGoal :: SearchState s => Agendum s -> BlueprintContext Bool +isGoal agendum = + do timeLimit <- asks getTimeLimit + return $ Q.length (agendum ^. trail) == timeLimit + +-- Parse the input file + +blueprintsP :: Parser [(Int, Blueprint)] +blueprintP :: Parser (Int, Blueprint) +robotP :: Parser (Resource, Collection) +requirementsP :: Parser Collection +requirementP :: Parser (Resource, Int) +resourceP, oreP, clayP, obsidianP, geodeP :: Parser Resource + +blueprintsP = blueprintP `sepBy` endOfLine +blueprintP = blueprintify <$> (("Blueprint " *> decimal) <* ": ") <*> (robotP `sepBy` ". ") <* "." + where blueprintify n robots = + (n, M.fromList robots) +robotP = (,) <$> ("Each " *> resourceP) <*> (" robot costs " *> requirementsP) + +requirementsP = MS.fromOccurList <$> (requirementP `sepBy` " and ") + +requirementP = (flip (,)) <$> (decimal <* " ") <*> resourceP + +resourceP = oreP <|> clayP <|> obsidianP <|> geodeP +oreP = Ore <$ "ore" +clayP = Clay <$ "clay" +obsidianP = Obsidian <$ "obsidian" +geodeP = Geode <$ "geode" + +successfulParse :: Text -> [(Int, Blueprint)] +successfulParse input = + case parseOnly blueprintsP input of + Left _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err + Right blueprints -> blueprints \ No newline at end of file diff --git a/advent19/MainSingle.hs b/advent19/MainSingle.hs new file mode 100644 index 0000000..46fd58c --- /dev/null +++ b/advent19/MainSingle.hs @@ -0,0 +1,224 @@ +-- Writeup at https://work.njae.me.uk/2022/12/21/advent-of-code-2022-day-19/ + +import Debug.Trace + +import AoC +import Data.Text (Text) +import qualified Data.Text.IO as TIO +import Data.Attoparsec.Text hiding (take, D) +import Control.Applicative +import qualified Data.PQueue.Prio.Max as P +import qualified Data.Set as S +import qualified Data.Sequence as Q +import qualified Data.Map.Strict as M +import Data.Map.Strict ((!)) +import Data.MultiSet as MS +import Data.Sequence ((|>)) +import Data.List +import Data.Maybe +-- import Data.Ord +import Control.Monad.Reader +import Control.Lens hiding ((<|), (|>), (:>), (:<), indices) +import GHC.Generics (Generic) +import Control.Parallel.Strategies +import Control.DeepSeq + +-- pattern Empty <- (Q.viewl -> Q.EmptyL) where Empty = Q.empty +-- pattern x :< xs <- (Q.viewl -> x Q.:< xs) where (:<) = (Q.<|) +-- pattern xs :> x <- (Q.viewr -> xs Q.:> x) where (:>) = (Q.|>) + +data Resource = Ore | Clay | Obsidian | Geode + deriving (Show, Eq, Ord, Generic) + +instance NFData Resource + +type Collection = MS.MultiSet Resource +hashCollection c = (MS.occur Ore c) + 200 * (MS.occur Clay c) + 200 * 200 * (MS.occur Obsidian c) + 200 * 200 * 200 * (MS.occur Geode c) + + +type Blueprint = M.Map Resource Collection + +data TimedBlueprint = TimedBlueprint { getBlueprint :: Blueprint, getTimeLimit :: Int, getMaxRobots :: Collection} + deriving (Show, Eq, Ord) + +type BlueprintContext = Reader TimedBlueprint + +data SearchState = SearchState + { _resources :: Collection + , _robots :: Collection + } deriving (Eq, Show, Ord) +makeLenses ''SearchState +hashSearchState s = (hashCollection (s ^. resources), hashCollection (s ^. robots)) + +instance NFData SearchState where + rnf (SearchState a b) = rnf a `seq` rnf b `seq` () + +data Agendum = + Agendum { _current :: SearchState + , _trail :: Q.Seq SearchState + , _trailBenefit :: Int + , _benefit :: Int + } deriving (Show, Eq, Ord) +makeLenses ''Agendum + +type Agenda = P.MaxPQueue Int Agendum + +-- type ExploredStates = S.Set (SearchState, Int, Int) +-- type ExploredStates = S.Set ((Int, Int), Int, Int) +type ExploredStates = S.Set ((Int, Int), Int) + +main :: IO () +main = + do dataFileName <- getDataFileName + text <- TIO.readFile dataFileName + let blueprints = successfulParse text + print $ part1 blueprints + -- print $ part2 blueprints + +part1 :: [(Int, Blueprint)] -> Int +part1 blueprints = sum [n * (MS.occur Geode (r ^. resources)) | (n, r) <- results] + -- where results = fmap (scoreBlueprint 24) blueprints + where results = parMap rdeepseq (scoreBlueprint 24) blueprints + +part2 :: [(Int, Blueprint)] -> Int +part2 blueprints = product [MS.occur Geode (r ^. resources) | (_, r) <- results] + where results = parMap rdeepseq (scoreBlueprint 32) $ take 3 blueprints + +robotLimits :: Blueprint -> Collection +robotLimits bp = M.foldl' MS.maxUnion MS.empty bp + +scoreBlueprint :: Int -> (Int, Blueprint) -> (Int, SearchState) +scoreBlueprint t (n, bp) = ( n + , _current $ fromJust $ runReader searchSpace (TimedBlueprint bp t (robotLimits bp)) + ) + +searchSpace :: BlueprintContext (Maybe Agendum) +searchSpace = + do agenda <- initAgenda + aStar agenda S.empty 0 + +initAgenda :: BlueprintContext Agenda +initAgenda = + do let startState = emptySearchState + b <- estimateBenefit startState 0 + return $ P.singleton b Agendum { _current = startState, _trail = Q.empty, _trailBenefit = 0, _benefit = b} + +aStar :: Agenda -> ExploredStates -> Int -> BlueprintContext (Maybe Agendum) +aStar agenda closed bestFound + -- | trace ("Peeping " ++ (show $ fst $ P.findMin agenda) ++ ": " ++ (show reached) ++ " <- " ++ (show $ toList $ Q.take 1 $ _trail $ currentAgendum) ++ " :: " ++ (show newAgenda)) False = undefined + -- | trace ("Peeping " ++ (show $ _current $ snd $ P.findMax agenda) ++ " benefit " ++ (show $ fst $ P.findMax agenda) ++ " : elapsed " ++ (show $ Q.length $ _trail $ snd $ P.findMax agenda)) False = undefined + -- | trace ((show bestFound) ++ " " ++ (show $ _trailBenefit $ snd $ P.findMax agenda) ++ ": " ++ (show $ _current $ snd $ P.findMax agenda)) False = undefined + | P.null agenda = return Nothing + | otherwise = + do let (_, currentAgendum) = P.findMax agenda + let reached = currentAgendum ^. current + let bestFound' = max bestFound (currentAgendum ^. trailBenefit) + nexts <- candidates currentAgendum closed bestFound' + let newAgenda = foldl' (\q a -> P.insert (_benefit a) a q) (P.deleteMax agenda) nexts + -- let beamAgenda = P.fromDescList $ P.take 10000 newAgenda -- agenda beam width + -- let beamAgenda = P.fromDescList $ P.take 5000 newAgenda -- agenda beam width + reachedGoal <- isGoal currentAgendum + -- let cl = (reached, currentAgendum ^. trailBenefit, Q.length $ currentAgendum ^. trail) + -- let cl = (hashSearchState reached, currentAgendum ^. trailBenefit, Q.length $ currentAgendum ^. trail) + let cl = (hashSearchState reached, Q.length $ currentAgendum ^. trail) + if reachedGoal + then return (Just currentAgendum) + else if (cl `S.member` closed) + then aStar (P.deleteMax agenda) closed bestFound' + -- else aStar newAgenda (S.insert cl closed) + else aStar newAgenda (S.insert cl closed) bestFound' + +candidates :: Agendum -> ExploredStates -> Int -> BlueprintContext (Q.Seq Agendum) +candidates agendum closed bestFound = + do let candidate = agendum ^. current + let previous = agendum ^. trail + let nextLen = Q.length previous + 1 + let prevBenefit = agendum ^. trailBenefit + succs <- successors candidate + succAgs <- mapM (makeAgendum previous prevBenefit) succs + let succAgs' = Q.filter (\a -> a ^. benefit >= bestFound) succAgs + -- let nonloops = Q.filter (\s -> (hashSearchState $ s ^. current, s ^. trailBenefit, nextLen) `S.notMember` closed) succAgs' + let nonloops = Q.filter (\s -> (hashSearchState $ s ^. current, nextLen) `S.notMember` closed) succAgs' + return nonloops + +makeAgendum :: Q.Seq SearchState -> Int -> SearchState -> BlueprintContext Agendum +makeAgendum previous prevBenefit newState = + do predicted <- estimateBenefit newState (Q.length previous) + let newTrail = previous |> newState + let incurred = (MS.occur Geode (newState ^. resources)) + -- let incurred = 0 + return Agendum { _current = newState + , _trail = newTrail + , _trailBenefit = incurred + , _benefit = incurred + predicted + } + +isGoal :: Agendum -> BlueprintContext Bool +isGoal agendum = + do timeLimit <- asks getTimeLimit + return $ Q.length (agendum ^. trail) == timeLimit + +emptySearchState :: SearchState +emptySearchState = SearchState { _resources = MS.empty, _robots = MS.singleton Ore } + +successors :: SearchState -> BlueprintContext (Q.Seq SearchState) +successors state = + do blueprint <- asks getBlueprint + maxRobots <- asks getMaxRobots + let buildableRobots = M.keys $ M.filter (\required -> required `MS.isSubsetOf` (state ^. resources)) blueprint + --- if more bots than needed for making any single bot, don't make more of that bot + let usefulRobots = MS.foldOccur (\res maxNeeded rs -> + if (MS.occur res (state ^. robots)) >= maxNeeded + then Data.List.delete res rs + else rs + ) buildableRobots maxRobots + let madeRobots = [ state & robots %~ MS.insert robot + & resources %~ ( `MS.difference` (blueprint ! robot) ) + | robot <- usefulRobots + ] + let afterBuild = [state] ++ madeRobots + let afterGather = fmap (\s -> s & resources %~ (MS.union (state ^. robots))) afterBuild + return $ Q.fromList afterGather + + +estimateBenefit :: SearchState -> Int -> BlueprintContext Int +estimateBenefit currentState timeElapsed = + do timeLimit <- asks getTimeLimit + let timeRemaining = timeLimit - (timeElapsed + 1) + -- let currentGeodes = MS.occur Geode (currentState ^. resources) + let currentRobotsGather = (MS.occur Geode (currentState ^. robots)) * timeRemaining + let newRobotsGather = (timeRemaining * (timeRemaining + 1)) `div` 2 + -- return $ currentGeodes + currentRobotsGather + newRobotsGather + return $ currentRobotsGather + newRobotsGather + + +-- Parse the input file + +blueprintsP :: Parser [(Int, Blueprint)] +blueprintP :: Parser (Int, Blueprint) +robotP :: Parser (Resource, Collection) +requirementsP :: Parser Collection +requirementP :: Parser (Resource, Int) +resourceP, oreP, clayP, obsidianP, geodeP :: Parser Resource + +blueprintsP = blueprintP `sepBy` endOfLine +blueprintP = blueprintify <$> (("Blueprint " *> decimal) <* ": ") <*> (robotP `sepBy` ". ") <* "." + where blueprintify n robots = + (n, M.fromList robots) +robotP = (,) <$> ("Each " *> resourceP) <*> (" robot costs " *> requirementsP) + +requirementsP = MS.fromOccurList <$> (requirementP `sepBy` " and ") + +requirementP = (flip (,)) <$> (decimal <* " ") <*> resourceP + +resourceP = oreP <|> clayP <|> obsidianP <|> geodeP +oreP = Ore <$ "ore" +clayP = Clay <$ "clay" +obsidianP = Obsidian <$ "obsidian" +geodeP = Geode <$ "geode" + +successfulParse :: Text -> [(Int, Blueprint)] +successfulParse input = + case parseOnly blueprintsP input of + Left _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err + Right blueprints -> blueprints \ No newline at end of file -- 2.34.1