adventofcode16/app/advent10.hs

   1 import Text.Parsec hiding (State)
   2 import Data.Text (pack, unpack, toTitle)
   3 import Control.Monad.State.Lazy
   4 import Data.List (partition, findIndices, sort, find)
   5 import Data.Maybe (fromJust)
   6
   7 data Destination = Bot | Output deriving (Show, Read, Eq)
   8 -- Rule bot low-destination high-destination
   9 -- Gift bot value
  10 data Instruction = Rule { ruleId :: Int
  11                         , lowDestType :: Destination
  12                         , lowDestId :: Int
  13                         , highDestType :: Destination
  14                         , highDestId :: Int
  15                         } |
  16                    Gift { giftId :: Int
  17                         , value :: Int
  18                         }
  19                    deriving (Show)
  20
  21 -- bod id [item1, item2]
  22 data Place = Place { placeId :: Int
  23                    , placeType :: Destination
  24                    , items :: [Int]}
  25                    deriving (Show)
  26
  27 -- delivery by bot of low-value and high-value
  28 data Event = Delivery { deliveryId :: Int
  29                       , lowDelivery :: Int
  30                       , highDelivery :: Int
  31                       } |
  32              Update { updateId :: Int
  33                     , updateType :: Destination
  34                     , updateItem :: Int
  35                     } deriving (Show)
  36
  37 type Factory = ([Place], [Instruction], [Event])
  38 -- data FactorySt History = FactorySt (Factory -> (Factory, History))
  39
  40 emptyFactory :: Factory
  41 emptyFactory = ([], [], [])
  42
  43 main :: IO ()
  44 main = do
  45     text <- readFile "data/advent10.txt"
  46     let instructions = successfulParse $ parseIfile text
  47     part1 instructions
  48     part2 instructions
  49
  50
  51 part1 :: [Instruction] -> IO ()
  52 part1 instructions =
  53     do  let (_, _, events) = snd $  runState (runFactory instructions) emptyFactory
  54         -- let (places, instructions, events) = snd finalFactory
  55         print $ deliveryId $ fromJust $ findDelivery events 17 61
  56
  57 part2 :: [Instruction] -> IO ()
  58 part2 instructions =
  59     do  let (places, _, _) = snd $  runState (runFactory instructions) emptyFactory
  60         let outs = findOutputs places [0, 1, 2]
  61         let product = foldl1 (*) $ concatMap (items) outs
  62         print $ product
  63
  64
  65 findDelivery :: [Event] -> Int -> Int -> Maybe Event
  66 findDelivery events lowItem highItem = find (delivery) events
  67     where delivery Update {} = False
  68           delivery Delivery {deliveryId = bot, lowDelivery = l, highDelivery = h}
  69             | l == lowItem && h == highItem = True
  70             | otherwise = False
  71
  72 findOutputs :: [Place] -> [Int] -> [Place]
  73 findOutputs outputs ids = filter (interesting) outputs
  74     where interesting Place {placeId = p, placeType = t, items = i}
  75             | (p `elem` ids) && t == Output = True
  76             | otherwise = False
  77
  78
  79 runFactory :: [Instruction] -> State Factory ()
  80 runFactory instructions = do
  81     addInstructions instructions
  82     runInstructions instructions
  83
  84
  85
  86 instructionFile = instructionLine `endBy` newline
  87 instructionLine = ruleL <|> giftL
  88
  89
  90 ruleL =
  91     do (string "bot" >> spaces)
  92        bot <- many1 digit
  93        (spaces >> string "gives low to" >> spaces)
  94        lowDestType <- (string "output" <|> string "bot")
  95        spaces
  96        lowDest <- many1 digit
  97        (spaces >> string "and high to" >> spaces)
  98        highDestType <- (string "output" <|> string "bot")
  99        spaces
 100        highDest <- many1 digit
 101        let rule = Rule (read bot)
 102                    (read $ unpack $ toTitle $ pack lowDestType)
 103                    (read lowDest)
 104                    (read $ unpack $ toTitle $ pack highDestType)
 105                    (read highDest)
 106        return rule
 107
 108 giftL =
 109     do (string "value" >> spaces)
 110        value <- many1 digit
 111        (spaces >> string "goes to bot" >> spaces)
 112        bot <- many1 digit
 113        let gift = Gift (read bot) (read value)
 114        return gift
 115
 116
 117 parseIfile :: String -> Either ParseError [Instruction]
 118 parseIfile input = parse instructionFile "(unknown)" input
 119
 120 parseIline :: String -> Either ParseError Instruction
 121 parseIline input = parse instructionLine "(unknown)" input
 122
 123 successfulParse :: Either ParseError [a] -> [a]
 124 successfulParse (Left _) = []
 125 successfulParse (Right a) = a
 126
 127
 128
 129
 130 addInstructions :: [Instruction] -> State Factory ()
 131 addInstructions [] = return ()
 132 addInstructions (i:is) = do
 133     addInstruction i
 134     addInstructions is
 135
 136
 137 addInstruction :: Instruction -> State Factory ()
 138 addInstruction r@(Rule {lowDestType = ld, lowDestId = li,
 139                      highDestType = hd, highDestId = hi}) =
 140     do (places, rules, history) <- get
 141        put (places, r:rules, history)
 142        addPlace (Place {placeType = ld, placeId = li, items = []})
 143        addPlace (Place {placeType = hd, placeId = hi, items = []})
 144 addInstruction Gift {giftId = g} =
 145     do addPlace (Place {placeType = Bot, placeId = g, items = []})
 146
 147
 148 addPlace :: Place -> State Factory ()
 149 addPlace place =
 150     do  (places, rules, history) <- get
 151         if not $ placeElem place places
 152             then put ((place:places), rules, history)
 153         else return ()
 154
 155
 156 runInstructions :: [Instruction] -> State Factory ()
 157 runInstructions [] = return ()
 158 runInstructions (i:is) =
 159     do  runInstruction i
 160         runInstructions is
 161
 162
 163 runInstruction :: Instruction -> State Factory ()
 164 runInstruction Rule {} = return ()
 165 runInstruction g@(Gift {}) =
 166     do  updatePlace (giftId g) Bot (value g)
 167         propogateUpdates
 168
 169 updatePlace :: Int -> Destination -> Int -> State Factory ()
 170 updatePlace b d i =
 171     do  (places, instructions, events) <- get
 172         let (place0s, otherPlaces) = partition (samePlace (Place {placeId = b, placeType = d, items = []})) places
 173         let place = head place0s
 174         let place' = place {items = i:(items place)}
 175         let update = Update {updateId = b, updateType = d, updateItem = i}
 176         put (place':otherPlaces, instructions, update:events)
 177
 178
 179 propogateUpdates :: State Factory ()
 180 propogateUpdates =
 181     do  (places, instructions, events) <- get
 182         let (fullBots, otherPlaces) = fullRobots places
 183         if (not . null) fullBots
 184             then do let fullBot = head fullBots
 185                     let maybeRule = findRule instructions (placeId fullBot)
 186                     case maybeRule of
 187                         Nothing -> propogateUpdates
 188                         Just rule -> do let small:large:_ = sort $ items fullBot
 189                                         let emptyBot = fullBot {items = []}
 190                                         let delivery = Delivery { deliveryId = placeId fullBot
 191                                                                 , lowDelivery = small
 192                                                                 , highDelivery = large
 193                                                                 }
 194                                         put (emptyBot:(tail fullBots) ++ otherPlaces,
 195                                              instructions,
 196                                              delivery:events)
 197                                         updatePlace (lowDestId rule) (lowDestType rule) small
 198                                         updatePlace (highDestId rule) (highDestType rule) large
 199                                         propogateUpdates
 200             else return ()
 201
 202
 203 placeElem :: Place -> [Place] -> Bool
 204 placeElem place places = (not . null) $ findIndices (samePlace place) places
 205
 206 samePlace :: Place -> Place -> Bool
 207 samePlace p1 p2 = (placeId p1 == placeId p2) && (placeType p1 == placeType p2)
 208
 209 fullRobots :: [Place] -> ([Place], [Place])
 210 fullRobots places = partition (\p -> placeType p == Bot && length (items p) >= 2) places
 211
 212 findRule :: [Instruction] -> Int -> Maybe Instruction
 213 findRule instructions bot = find ruleForBot instructions
 214     where ruleForBot Gift {} = False
 215           ruleForBot Rule {ruleId = b}
 216             | b == bot = True
 217             | otherwise = False