src/advent17/advent17.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2
   3 -- import Debug.Trace
   4
   5 import Data.Text (Text)
   6 -- import qualified Data.Text as T
   7 import qualified Data.Text.IO as TIO
   8
   9 import Data.Void (Void)
  10
  11 import Text.Megaparsec
  12 import Text.Megaparsec.Char
  13 import qualified Text.Megaparsec.Char.Lexer as L
  14 import qualified Control.Applicative as CA
  15
  16 import Data.List
  17 -- import qualified Data.Set as S
  18
  19 import qualified Data.Map.Strict as M
  20 import Data.Map.Strict ((!))
  21 import Data.Tuple (swap)
  22
  23 type SoilSpecLine = ((Text, Integer), (Text, Integer, Integer))
  24 type Coord = (Integer, Integer) -- x, y
  25 data Soil = Sand | Clay | Still | Flowing deriving (Eq, Show, Enum, Bounded, Ord)
  26 type Ground = M.Map Coord Soil
  27
  28 main :: IO ()
  29 main = do
  30     text <- TIO.readFile "data/advent17.txt"
  31     let soilSpec = successfulParse text
  32     let ground = makeGround soilSpec
  33     let ground' = filled ground
  34     print $ part1 ground'
  35     print $ part2 ground'
  36
  37
  38 part1 ground = M.size $ M.union still flowing
  39     where (_minX, _maxX, minY, maxY) = bounds ground
  40           inBoundGround = M.filterWithKey (\(_x, y) _ -> (y >= minY) && (y <= maxY)) ground
  41           still = M.filter (== Still) inBoundGround
  42           flowing = M.filter (== Flowing) inBoundGround
  43
  44 part2 ground = M.size $ still
  45     where (_minX, _maxX, minY, maxY) = bounds ground
  46           inBoundGround = M.filterWithKey (\(_x, y) _ -> (y >= minY) && (y <= maxY)) ground
  47           still = M.filter (== Still) inBoundGround
  48
  49 makeGround :: [SoilSpecLine] -> Ground
  50 makeGround soilSpec = foldl' addSpecLine M.empty soilSpec
  51
  52 addSpecLine :: Ground -> SoilSpecLine -> Ground
  53 addSpecLine ground ((fixed, fixedVal), (_ranged, from, to)) =
  54     foldr (\c -> M.insert c Clay) ground addedCells
  55     where cells = [(fixedVal, i) | i <- [from..to] ]
  56           addedCells = if fixed == "x" then cells else map swap cells
  57
  58 showGround :: Ground -> String
  59 showGround ground = unlines $ map (showGroundLine minX maxX ground) [minY..maxY]
  60     where (minX, maxX, minY, maxY) = bounds ground
  61
  62 showGroundLine :: Integer -> Integer -> Ground -> Integer -> String
  63 showGroundLine minX maxX ground y = [showGroundCell x | x <- [minX..maxX]]
  64     where showGroundCell x = if (x, y) `M.member` ground
  65                                then case ground!(x, y) of
  66                                         Clay -> '#' -- '\x2591'
  67                                         Flowing -> '|'
  68                                         Still -> 'o' -- '\x2593'
  69                                         Sand -> '.'
  70                                 else '.'
  71
  72 bounds :: Ground -> (Integer, Integer, Integer, Integer)
  73 bounds ground = (minX, maxX, minY, maxY)
  74     where keys = M.keys ground -- $ M.filter (== Clay) ground
  75           minX = minimum $ map fst keys
  76           maxX = maximum $ map fst keys
  77           minY = minimum $ map snd keys
  78           maxY = maximum $ map snd keys
  79
  80 down (x, y) = (x, y+1)
  81 left (x, y) = (x-1, y)
  82 right (x, y) = (x+1, y)
  83
  84 filled :: Ground -> Ground
  85 filled ground = handleSource ground (500, 0)
  86
  87
  88 handleSource :: Ground -> Coord -> Ground
  89 -- handleSource ground here | trace ("source " ++ show here ++ "\n" ++ showGround ground) False = undefined
  90 handleSource ground here
  91     | (snd here) > maxY = ground
  92     | otherwise = flood ground' here
  93     where (_minX, _maxX, _minY, maxY) = bounds ground
  94           under = M.findWithDefault Sand (down here) ground
  95           ground' = if under == Sand
  96                     then handleSource (M.insert here Flowing ground) (down here)
  97                     else M.insert here Flowing ground
  98
  99 flood :: Ground -> Coord -> Ground
 100 -- flood ground here | trace ("flood " ++ show here) False = undefined
 101 flood ground here = foldl' handleSource groundB sources
 102     where (groundL, sourcesL, boundL) = floodLeft ground here
 103           (groundR, sourcesR, boundR) = floodRight groundL here
 104           sources = sourcesL ++ sourcesR
 105           groundB = if boundL && boundR
 106                     then stillWater groundR here
 107                     else groundR
 108
 109 floodLeft :: Ground -> Coord -> (Ground, [Coord], Bool)
 110 -- floodLeft ground here | trace ("flood <= " ++ show here) False = undefined
 111 floodLeft ground here =
 112     if leftWards == Clay
 113     then (ground, [], True)
 114     else case (under, underLeft) of
 115         (Clay, Sand) -> (ground', [left here], False)
 116         (Clay, Clay) -> floodLeft ground' (left here)
 117         (Still, Still) -> floodLeft ground' (left here)
 118         (Still, Clay) -> floodLeft ground' (left here)
 119         (Clay, Still) -> floodLeft ground' (left here)
 120         _             -> (ground, [], False)
 121     where ground' = (M.insert (left here) Flowing ground)
 122           under = M.findWithDefault Sand (down here) ground
 123           leftWards = M.findWithDefault Sand (left here) ground
 124           underLeft =  M.findWithDefault Sand (left (down here)) ground
 125
 126
 127 floodRight :: Ground -> Coord -> (Ground, [Coord], Bool)
 128 -- floodRight ground here | trace ("flood => " ++ show here) False = undefined
 129 floodRight ground here =
 130     if rightWards == Clay
 131     then (ground, [], True)
 132     else case (under, underRight) of
 133         (Clay, Sand) -> (ground', [right here], False)
 134         (Clay, Clay) -> floodRight ground' (right here)
 135         (Still, Still) -> floodRight ground' (right here)
 136         (Still, Clay) -> floodRight ground' (right here)
 137         (Clay, Still) -> floodRight ground' (right here)
 138         _             -> (ground, [], False)
 139     where ground' = (M.insert (right here) Flowing ground)
 140           under = M.findWithDefault Sand (down here) ground
 141           rightWards = M.findWithDefault Sand (right here) ground
 142           underRight =  M.findWithDefault Sand (right (down here)) ground
 143
 144 stillWater :: Ground -> Coord -> Ground
 145 -- stillWater ground here | trace ("stilling " ++ show here) False = undefined
 146 stillWater ground here = stillWaterR groundL here
 147     where groundL = stillWaterL ground here
 148
 149 stillWaterL :: Ground -> Coord -> Ground
 150 -- stillWaterL ground here | trace ("stilling L" ++ show here) False = undefined
 151 stillWaterL ground here =
 152     if ground!(left here) == Clay
 153     then ground'
 154     else stillWaterL ground' (left here)
 155     where ground' =(M.insert here Still ground)
 156
 157 stillWaterR :: Ground -> Coord -> Ground
 158 -- stillWaterR ground here | trace ("stilling R" ++ show here) False = undefined
 159 stillWaterR ground here =
 160     if ground!(right here) == Clay
 161     then ground'
 162     else stillWaterR ground' (right here)
 163     where ground' = (M.insert here Still ground)
 164
 165
 166 -- Parse the input file
 167
 168 type Parser = Parsec Void Text
 169
 170 sc :: Parser ()
 171 sc = L.space (skipSome spaceChar) CA.empty CA.empty
 172
 173 lexeme  = L.lexeme sc
 174 integer = lexeme L.decimal
 175 symb = L.symbol sc
 176
 177 equalP = symb "="
 178 commaP = symb ","
 179 ellipsisP = ".."
 180 axisP = symb "x" <|> symb "y"
 181
 182 fileP = many rowP
 183
 184 rowP = (,) <$> fixedP <* commaP <*> rangeP
 185
 186 fixedP = (,) <$> axisP <* equalP <*> integer
 187 rangeP = (,,) <$> axisP <* equalP <*> integer <* ellipsisP <*> integer
 188
 189
 190 successfulParse :: Text -> [SoilSpecLine]
 191 successfulParse input =
 192         case parse fileP "input" input of
 193                 Left  _error -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err
 194                 Right soilSpec -> soilSpec