advent10.hs

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