advent22/Main.hs

   1 -- Writeup at https://work.njae.me.uk/2022/12/19/advent-of-code-2022-day-18/
   2
   3 -- import Debug.Trace
   4
   5 import AoC
   6 import Prelude hiding (Left, Right)
   7 import qualified Data.Map.Strict as M
   8 import Data.Map.Strict ((!))
   9 import Linear hiding (E)
  10 import Control.Lens
  11 import Data.Ix
  12 import Data.Maybe
  13 import Data.Char
  14 import Control.Monad.Reader
  15
  16
  17 type Position = V2 Int -- r, c
  18 _r :: Lens' (V2 Int) Int
  19 _r = _x
  20 _c :: Lens' (V2 Int) Int
  21 _c = _y
  22
  23 data Cell = Tile | Wall
  24   deriving (Show, Eq)
  25
  26 type FieldMap = M.Map Position Cell
  27
  28 data Direction = Right | Down | Left | Up
  29   deriving (Show, Eq, Ord, Enum, Bounded)
  30
  31 predW, succW :: (Eq a, Bounded a, Enum a) => a -> a
  32 predW a
  33   | a == minBound = maxBound
  34   | otherwise = pred a
  35 succW a
  36   | a == maxBound = minBound
  37   | otherwise = succ a
  38
  39 data PathElement = Forward Int | Clockwise | Anticlockwise
  40   deriving (Show, Eq)
  41
  42 data Person = Person {_position :: Position, _facing :: Direction}
  43   deriving (Show, Eq)
  44 makeLenses ''Person
  45
  46 data Field = Field { getMap :: FieldMap
  47                    , whatsAheadFunc :: Person -> FieldContext Person
  48                    -- , whatsAtFunc :: Position -> FieldContext Cell
  49                    }
  50 type FieldContext = Reader Field
  51
  52 data Face = A | B | C | D | E | F
  53   deriving (Show, Eq)
  54
  55 main :: IO ()
  56 main =
  57   do  dataFileName <- getDataFileName
  58       text <- readFile dataFileName
  59       let (field, instrs) = successfulParse text
  60       print $ part1 field instrs
  61       print $ part2 field instrs
  62       -- print $ probeAllCorners field
  63
  64 part1, part2 :: FieldMap -> [PathElement] -> Int
  65 part1 fieldMap instrs = passwordOf endPerson
  66   where field = mkFlatField fieldMap
  67         startPos = V2 0 $ fromJust $ minimumOf (folded . filteredBy (_r . only 0) . _c) $ M.keysSet fieldMap
  68         startPerson = Person startPos Right
  69         endPerson = runReader (walk startPerson instrs) field
  70
  71 part2 fieldMap instrs = passwordOf endPerson
  72   where field = mkCubeField fieldMap
  73         startPos = V2 0 $ fromJust $ minimumOf (folded . filteredBy (_r . only 0) . _c) $ M.keysSet fieldMap
  74         startPerson = Person startPos Right
  75         endPerson = runReader (walk startPerson instrs) field
  76
  77 -- probeCube fieldMap startPos startDirection = endPerson
  78 --   where field = mkCubeField fieldMap
  79 --         startPerson = Person startPos startDirection
  80 --         endPerson = runReader (whatsAheadCube startPerson) field
  81
  82 -- probeAllCorners fieldMap = [(p, probeACorner p field) | p <- persons]
  83 --   where persons = [ Person (V2 r c) f
  84 --                   | r <- [0, 49, 50, 99, 100, 149]
  85 --                   , c <- [0, 49, 50, 99, 100, 149, 150, 199]
  86 --                   , f <- [Right, Down, Left, Up]
  87 --                   , (V2 r c) `M.member` fieldMap
  88 --                   ]
  89 --         field = mkCubeField fieldMap
  90
  91 -- probeACorner person field
  92 --   | Debug.Trace.trace (show person) False = undefined
  93 --   | otherwise =  runReader (whatsAheadCube person) field
  94
  95
  96 passwordOf :: Person -> Int
  97 passwordOf person = 1000 * (person ^. position . _r + 1)
  98                       + 4 * (person ^. position . _c + 1)
  99                       + (fromEnum $ person ^. facing)
 100
 101
 102 mkFlatField :: FieldMap -> Field
 103 mkFlatField fieldMap =
 104   Field { getMap = fieldMap
 105         , whatsAheadFunc = whatsAheadFlat
 106         -- , whatsAtFunc = whatsAt
 107         }
 108
 109
 110 mkCubeField :: FieldMap -> Field
 111 mkCubeField fieldMap =
 112   Field { getMap = fieldMap
 113         , whatsAheadFunc = whatsAheadCube
 114         -- , whatsAtFunc = whatsAt
 115         }
 116
 117 whatsAt :: Position -> FieldContext Cell
 118 whatsAt posiiton =
 119   do fieldMap <- asks getMap
 120      return $ fieldMap ! posiiton
 121
 122 whatsAheadFlat :: Person -> FieldContext Person
 123 whatsAheadFlat person =
 124   do let easyNext = (person ^. position) + (deltaOf $ person ^. facing)
 125      fieldMap <- asks getMap
 126      if easyNext `M.member` fieldMap
 127      then return $ person & position .~ easyNext
 128      else do let currenFacing = person ^. facing
 129              let currentRow = person ^. position . _r
 130              let currentCol = person ^. position . _c
 131              let rightMovingCol = fromJust $ minimumOf (folded . filteredBy (_r . only currentRow) . _c) $ M.keysSet fieldMap
 132              let leftMovingCol = fromJust $ maximumOf (folded . filteredBy (_r . only currentRow) . _c) $ M.keysSet fieldMap
 133              let upMovingRow = fromJust $ maximumOf (folded . filteredBy (_c . only currentCol) . _r) $ M.keysSet fieldMap
 134              let downMovingRow = fromJust $ minimumOf (folded . filteredBy (_c . only currentCol) . _r) $ M.keysSet fieldMap
 135              return $ case currenFacing of
 136                                  Right -> person & position . _c .~ rightMovingCol
 137                                  Left -> person & position . _c .~ leftMovingCol
 138                                  Up -> person & position . _r .~ upMovingRow
 139                                  Down -> person & position . _r .~ downMovingRow
 140
 141
 142 --   A B
 143 --   C
 144 -- D E
 145 -- F
 146
 147 whatsAheadCube :: Person -> FieldContext Person
 148 whatsAheadCube person =
 149   do let easyNext = (person ^. position) + (deltaOf $ person ^. facing)
 150      let currentFace = faceOf (person ^. position)
 151      let nextFace = faceOf easyNext
 152      fieldMap <- asks getMap
 153      if (easyNext `M.member` fieldMap) && (currentFace == nextFace)
 154      then return $ person & position .~ easyNext
 155      else return $ crossEdge person currentFace
 156
 157 faceOf :: Position -> Face
 158 faceOf position
 159   | (inRange (0, 49) r) && (inRange (50, 99) c) = A
 160   | (inRange (0, 49) r) && (inRange (100, 149) c) = B
 161   | (inRange (50, 99) r) && (inRange (50, 99) c) = C
 162   | (inRange (100, 149) r) && (inRange (0, 49) c) = D
 163   | (inRange (100, 149) r) && (inRange (50, 99) c) = E
 164   | (inRange (150, 199) r) && (inRange (0, 49) c) = F
 165   | otherwise = error "Not a face"
 166   where r = position ^. _r
 167         c = position ^. _c
 168
 169 crossEdge :: Person -> Face -> Person
 170 crossEdge person face =
 171   case (d, face) of
 172     (Up,    A) -> person & position . _r .~ (interpol c 150 199) & position . _c .~ 0 & facing .~ Right
 173     (Right, A) -> person & position . _c .~ 100
 174     (Down,  A) -> person & position . _r .~ 50
 175     (Left,  A) -> person & position . _r .~ (interpol r 149 100) & position . _c .~ 0 & facing .~ Right
 176
 177     (Up,    B) -> person & position . _r .~ 199 & position . _c .~ (interpol c 0 49)
 178     (Right, B) -> person & position . _r .~ (interpol r 149 100) & position . _c .~ 99 & facing .~ Left
 179     (Down,  B) -> person & position . _r .~ (interpol c 50 99) & position . _c .~ 99 & facing .~ Left
 180     (Left,  B) -> person & position . _c .~ 99
 181
 182     (Up,    C) -> person & position . _r .~ 49
 183     (Right, C) -> person & position . _r .~ 49 & position . _c .~ (interpol r 100 149) & facing .~ Up
 184     (Down,  C) -> person & position . _r .~ 100
 185     (Left,  C) -> person & position . _r .~ 100 & position . _c .~ (interpol r 0 49) & facing .~ Down
 186
 187     (Up,    D) -> person & position . _r .~ (interpol c 50 99) & position . _c .~ 50 & facing .~ Right
 188     (Right, D) -> person & position . _c .~ 50
 189     (Down,  D) -> person & position . _r .~ 150
 190     (Left,  D) -> person & position . _r .~ (interpol r 49 0) & position . _c .~ 50 & facing .~ Right
 191
 192     (Up,    E) -> person & position . _r .~ 99
 193     (Right, E) -> person & position . _r .~ (interpol r 49 0) & position . _c .~ 149 & facing .~ Left
 194     (Down,  E) -> person & position . _r .~ (interpol c 150 199) & position . _c .~ 49 & facing .~ Left
 195     (Left,  E) -> person & position . _c .~ 49
 196
 197     (Up,    F) -> person & position . _r .~ 149
 198     (Right, F) -> person & position . _r .~ 149 & position . _c .~ (interpol r 50 99) & facing .~ Up
 199     (Down,  F) -> person & position . _r .~ 0 & position . _c .~ (interpol c 100 149)
 200     (Left,  F) -> person & position . _r .~ 0 & position . _c .~ (interpol r 50 99) & facing .~ Down
 201
 202   where r = person ^. position . _r
 203         c = person ^. position . _c
 204         d = person ^. facing
 205         interpol x start end = (signum (end - start)) * (x `mod` 50) + start
 206
 207
 208 walk :: Person -> [PathElement] -> FieldContext Person
 209 walk person path = foldM walkOne person path
 210
 211 walkOne :: Person -> PathElement -> FieldContext Person
 212 walkOne person (Forward n)
 213   | n == 0 = return person
 214   | otherwise =
 215       do whatsAhead <- asks whatsAheadFunc
 216          person' <- whatsAhead person
 217          -- whatsAt <- asks whatsAtFunc
 218          nextCell <- whatsAt (person' ^. position)
 219          if nextCell == Wall
 220          then return person
 221          else walkOne person' (Forward (n - 1))
 222 walkOne person Clockwise = return $ person & facing %~ succW
 223 walkOne person Anticlockwise = return $ person & facing %~ predW
 224
 225 deltaOf :: Direction -> Position
 226 deltaOf Right = V2 0 1
 227 deltaOf Down = V2 1 0
 228 deltaOf Left = V2 0 -1
 229 deltaOf Up = V2 -1 0
 230
 231
 232 -- Parse the input file
 233
 234 successfulParse :: String -> (FieldMap, [PathElement])
 235 successfulParse text = (mkField $ takeWhile ((> 0) . length) $ init $ lines text, mkInstructions $ last $ lines text)
 236
 237 mkField :: [String] -> FieldMap
 238 mkField rows = M.fromList
 239       [ (V2 r c, mkCell r c)
 240       | r <- [0..maxR], c <- [0..maxC]
 241       , isCell r c rows
 242       ]
 243   where maxR = length rows - 1
 244         maxC = (length $ head rows) - 1
 245         -- isCell r c = ((rows !! r) !! c) `elem` (".#" :: String)
 246         mkCell r c
 247           | cell == '.' = Tile
 248           | cell == '#' = Wall
 249           where cell = (rows !! r) !! c
 250
 251 isCell :: Int -> Int -> [String] -> Bool
 252 isCell r c rows = isRow && isCol && ((rows !! r) !! c) `elem` (".#" :: String)
 253   where isRow = r < length rows
 254         isCol = c < (length $ rows !! r)
 255
 256 mkInstructions :: String -> [PathElement]
 257 mkInstructions [] = []
 258 mkInstructions text@(t:ts)
 259   | isDigit t = mkWalk text
 260   | otherwise = mkTurn text
 261 mkWalk text = (Forward $ read digits) : (mkInstructions remainder)
 262   where (digits, remainder) = span (isDigit) text
 263 mkTurn (t:ts)
 264   | t == 'R' = Clockwise : (mkInstructions ts)
 265   | t == 'L' = Anticlockwise : (mkInstructions ts)