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     -- print soilSpec
  33     let ground = makeGround soilSpec
  34     -- print ground
  35     -- putStrLn $ showGround ground
  36     -- putStrLn $ showGround $ handleSource ground (500, 0)
  37     -- print $ handleSource ground (500, 0)
  38     let ground' = filled ground
  39     print $ part1 ground'
  40     print $ part2 ground'
  41     -- print $ part1 tests
  42     -- print $ part2 tests program
  43
  44
  45 part1 ground = M.size $ M.union still flowing
  46     where (_minX, _maxX, minY, maxY) = bounds ground
  47           inBoundGround = M.filterWithKey (\(_x, y) _ -> (y >= minY) && (y <= maxY)) ground
  48           still = M.filter (== Still) inBoundGround
  49           flowing = M.filter (== Flowing) inBoundGround
  50
  51 part2 ground = M.size $ still
  52     where (_minX, _maxX, minY, maxY) = bounds ground
  53           inBoundGround = M.filterWithKey (\(_x, y) _ -> (y >= minY) && (y <= maxY)) ground
  54           still = M.filter (== Still) inBoundGround
  55
  56 makeGround :: [SoilSpecLine] -> Ground
  57 makeGround soilSpec = foldl' addSpecLine M.empty soilSpec
  58
  59 addSpecLine :: Ground -> SoilSpecLine -> Ground
  60 addSpecLine ground ((fixed, fixedVal), (ranged, from, to)) =
  61     foldr (\c -> M.insert c Clay) ground addedCells
  62     where cells = [(fixedVal, i) | i <- [from..to] ]
  63           addedCells = if fixed == "x" then cells else map swap cells
  64
  65 showGround :: Ground -> String
  66 showGround ground = unlines $ map (showGroundLine minX maxX ground) [minY..maxY]
  67     where (minX, maxX, minY, maxY) = bounds ground
  68
  69 showGroundLine :: Integer -> Integer -> Ground -> Integer -> String
  70 showGroundLine minX maxX ground y = [showGroundCell x | x <- [minX..maxX]]
  71     where showGroundCell x = if (x, y) `M.member` ground
  72                                then case ground!(x, y) of
  73                                         Clay -> '#' -- '\x2591'
  74                                         Flowing -> '|'
  75                                         Still -> 'o' -- '\x2593'
  76                                         Sand -> '.'
  77                                 else '.'
  78
  79 bounds :: Ground -> (Integer, Integer, Integer, Integer)
  80 bounds ground = (minX, maxX, minY, maxY)
  81     where keys = M.keys ground -- $ M.filter (== Clay) ground
  82           minX = minimum $ map fst keys
  83           maxX = maximum $ map fst keys
  84           minY = minimum $ map snd keys
  85           maxY = maximum $ map snd keys
  86
  87 up (x, y) = (x, y-1)
  88 down (x, y) = (x, y+1)
  89 left (x, y) = (x-1, y)
  90 right (x, y) = (x+1, y)
  91
  92
  93 filled :: Ground -> Ground
  94 filled ground = handleSource ground (500, 0)
  95
  96
  97 handleSource :: Ground -> Coord -> Ground
  98 -- handleSource ground here | trace ("source " ++ show here ++ "\n" ++ showGround ground) False = undefined
  99 handleSource ground here
 100     | (snd here) > maxY = ground
 101     | otherwise = flood ground' here
 102     where (_minX, _maxX, _minY, maxY) = bounds ground
 103           under = M.findWithDefault Sand (down here) ground
 104           ground' = if under == Sand
 105                     then handleSource (M.insert here Flowing ground) (down here)
 106                     else M.insert here Flowing ground
 107
 108     -- else if (down here) `M.notMember` ground
 109     --      then handleSource ground' (down here)
 110     --      else flood ground' here
 111     -- where (_minX, _maxX, _minY, maxY) = bounds ground
 112     --       ground' = (M.insert here Water ground)
 113
 114 flood :: Ground -> Coord -> Ground
 115 -- flood ground here | trace ("flood " ++ show here) False = undefined
 116 flood ground here = foldl' handleSource groundB sources
 117     where (groundL, sourcesL, boundL) = floodLeft ground here
 118           (groundR, sourcesR, boundR) = floodRight groundL here
 119           sources = sourcesL ++ sourcesR
 120           groundB = if boundL && boundR
 121                     then stillWater groundR here
 122                     else groundR
 123
 124
 125     -- if null sources
 126     -- then flood groundLR (up here)
 127     -- else foldl' handleSource groundLR sources
 128     -- where (groundL, sourcesL) = floodLeft ground here
 129     --       (groundLR,  sourcesR) = floodRight groundL here
 130     --       sources = sourcesL ++ sourcesR
 131
 132 -- if the ground under is sand, create a new source
 133 -- otherwise,
 134 -- if the groudnd to the left is clay, stop
 135 -- if the ground to the left isn't clay, flood left
 136
 137 floodLeft :: Ground -> Coord -> (Ground, [Coord], Bool)
 138 -- floodLeft ground here | trace ("flood <= " ++ show here) False = undefined
 139 floodLeft ground here =
 140     if leftWards == Clay
 141     then (ground, [], True)
 142     else case (under, underLeft) of
 143         (Clay, Sand) -> (ground', [left here], False)
 144         (Clay, Clay) -> floodLeft ground' (left here)
 145         (Still, Still) -> floodLeft ground' (left here)
 146         (Still, Clay) -> floodLeft ground' (left here)
 147         (Clay, Still) -> floodLeft ground' (left here)
 148         _             -> (ground, [], False)
 149     where ground' = (M.insert (left here) Flowing ground)
 150           under = M.findWithDefault Sand (down here) ground
 151           leftWards = M.findWithDefault Sand (left here) ground
 152           underLeft =  M.findWithDefault Sand (left (down here)) ground
 153
 154
 155 floodRight :: Ground -> Coord -> (Ground, [Coord], Bool)
 156 -- floodRight ground here | trace ("flood => " ++ show here) False = undefined
 157 floodRight ground here =
 158     if rightWards == Clay
 159     then (ground, [], True)
 160     else case (under, underRight) of
 161         (Clay, Sand) -> (ground', [right here], False)
 162         (Clay, Clay) -> floodRight ground' (right here)
 163         (Still, Still) -> floodRight ground' (right here)
 164         (Still, Clay) -> floodRight ground' (right here)
 165         (Clay, Still) -> floodRight ground' (right here)
 166         _             -> (ground, [], False)
 167     where ground' = (M.insert (right here) Flowing ground)
 168           under = M.findWithDefault Sand (down here) ground
 169           rightWards = M.findWithDefault Sand (right here) ground
 170           underRight =  M.findWithDefault Sand (right (down here)) ground
 171     -- if under == Sand
 172     -- then (ground', [here])
 173     -- else if rightWards == Clay
 174     --      then (ground', [])
 175     --      else if (under == Water) && (rightWards == Sand)
 176     --           then (ground', [])
 177     --           else floodRight ground' (left here)
 178     -- where ground' = (M.insert here Water ground)
 179     --       under = M.findWithDefault Sand (down here) ground
 180     --       rightWards = M.findWithDefault Sand (right here) ground
 181 -- floodRight ground here =
 182     -- case under of
 183     --     Sand -> (ground', [here])
 184     --     Water -> (ground', [])
 185     --     otherwise -> if (right here) `M.notMember` ground
 186     --                  then floodRight ground' (right here)
 187     --                  else if ground!(right here) == Water
 188     --                       then floodRight ground' (right here)
 189     --                       else (ground', [])
 190     -- where ground' = (M.insert here Water ground)
 191     --       under = M.findWithDefault Sand (down here) ground
 192
 193 stillWater :: Ground -> Coord -> Ground
 194 -- stillWater ground here | trace ("stilling " ++ show here) False = undefined
 195 stillWater ground here = stillWaterR groundL here
 196     where groundL = stillWaterL ground here
 197
 198 stillWaterL :: Ground -> Coord -> Ground
 199 -- stillWaterL ground here | trace ("stilling L" ++ show here) False = undefined
 200 stillWaterL ground here =
 201     if ground!(left here) == Clay
 202     then ground'
 203     else stillWaterL ground' (left here)
 204     where ground' =(M.insert here Still ground)
 205
 206 stillWaterR :: Ground -> Coord -> Ground
 207 -- stillWaterR ground here | trace ("stilling R" ++ show here) False = undefined
 208 stillWaterR ground here =
 209     if ground!(right here) == Clay
 210     then ground'
 211     else stillWaterR ground' (right here)
 212     where ground' = (M.insert here Still ground)
 213
 214
 215
 216 -- Parse the input file
 217
 218 type Parser = Parsec Void Text
 219
 220 sc :: Parser ()
 221 sc = L.space (skipSome spaceChar) CA.empty CA.empty
 222
 223 lexeme  = L.lexeme sc
 224 integer = lexeme L.decimal
 225 symb = L.symbol sc
 226
 227 equalP = symb "="
 228 commaP = symb ","
 229 ellipsisP = ".."
 230 axisP = symb "x" <|> symb "y"
 231
 232 fileP = many rowP
 233
 234 rowP = (,) <$> fixedP <* commaP <*> rangeP
 235
 236 fixedP = (,) <$> axisP <* equalP <*> integer
 237 rangeP = (,,) <$> axisP <* equalP <*> integer <* ellipsisP <*> integer
 238
 239
 240 successfulParse :: Text -> [SoilSpecLine]
 241 successfulParse input =
 242         case parse fileP "input" input of
 243                 Left  _error -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err
 244                 Right soilSpec -> soilSpec