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