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.List
  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, whatsAheadFunc :: Person -> FieldContext Person, whatsAtFunc :: Position -> FieldContext Cell}
  48 type FieldContext = Reader Field
  49
  50 data Face = A | B | C | D | E | F
  51   deriving (Show, Eq)
  52
  53 main :: IO ()
  54 main =
  55   do  dataFileName <- getDataFileName
  56       text <- readFile dataFileName
  57       let (field, instrs) = successfulParse text
  58       print $ part1 field instrs
  59       print $ part2 field instrs
  60       -- print $ probeAllCorners field
  61
  62 part1 fieldMap instrs = passwordOf endPerson
  63   where field = mkFlatField fieldMap
  64         startPos = V2 0 $ fromJust $ minimumOf (folded . filteredBy (_r . only 0) . _c) $ M.keysSet fieldMap
  65         startPerson = Person startPos Right
  66         endPerson = runReader (walk startPerson instrs) field
  67
  68 part2 fieldMap instrs = passwordOf endPerson
  69   where field = mkCubeField fieldMap
  70         startPos = V2 0 $ fromJust $ minimumOf (folded . filteredBy (_r . only 0) . _c) $ M.keysSet fieldMap
  71         startPerson = Person startPos Right
  72         endPerson = runReader (walk startPerson instrs) field
  73
  74 -- probeCube fieldMap startPos startDirection = endPerson
  75 --   where field = mkCubeField fieldMap
  76 --         startPerson = Person startPos startDirection
  77 --         endPerson = runReader (whatsAheadCube startPerson) field
  78
  79 -- probeAllCorners fieldMap = [(p, probeACorner p field) | p <- persons]
  80 --   where persons = [ Person (V2 r c) f
  81 --                   | r <- [0, 49, 50, 99, 100, 149]
  82 --                   , c <- [0, 49, 50, 99, 100, 149, 150, 199]
  83 --                   , f <- [Right, Down, Left, Up]
  84 --                   , (V2 r c) `M.member` fieldMap
  85 --                   ]
  86 --         field = mkCubeField fieldMap
  87
  88 -- probeACorner person field
  89 --   | Debug.Trace.trace (show person) False = undefined
  90 --   | otherwise =  runReader (whatsAheadCube person) field
  91
  92
  93 passwordOf :: Person -> Int
  94 passwordOf person = 1000 * (person ^. position . _r + 1)
  95                       + 4 * (person ^. position . _c + 1)
  96                       + (fromEnum $ person ^. facing)
  97
  98
  99 mkFlatField :: FieldMap -> Field
 100 mkFlatField fieldMap =
 101   Field { getMap = fieldMap
 102         , whatsAheadFunc = whatsAheadFlat
 103         , whatsAtFunc = whatsAt}
 104
 105
 106 mkCubeField :: FieldMap -> Field
 107 mkCubeField fieldMap =
 108   Field { getMap = fieldMap
 109         , whatsAheadFunc = whatsAheadCube
 110         , whatsAtFunc = whatsAt}
 111
 112 whatsAt :: Position -> FieldContext Cell
 113 whatsAt posiiton =
 114   do fieldMap <- asks getMap
 115      return $ fieldMap ! posiiton
 116
 117 whatsAheadFlat :: Person -> FieldContext Person
 118 whatsAheadFlat person =
 119   do let easyNext = (person ^. position) + (deltaOf $ person ^. facing)
 120      fieldMap <- asks getMap
 121      if easyNext `M.member` fieldMap
 122      then return $ person & position .~ easyNext
 123      else do let currenFacing = person ^. facing
 124              let currentRow = person ^. position . _r
 125              let currentCol = person ^. position . _c
 126              let rightMovingCol = fromJust $ minimumOf (folded . filteredBy (_r . only currentRow) . _c) $ M.keysSet fieldMap
 127              let leftMovingCol = fromJust $ maximumOf (folded . filteredBy (_r . only currentRow) . _c) $ M.keysSet fieldMap
 128              let upMovingRow = fromJust $ maximumOf (folded . filteredBy (_c . only currentCol) . _r) $ M.keysSet fieldMap
 129              let downMovingRow = fromJust $ minimumOf (folded . filteredBy (_c . only currentCol) . _r) $ M.keysSet fieldMap
 130              return $ case currenFacing of
 131                                  Right -> person & position . _c .~ rightMovingCol
 132                                  Left -> person & position . _c .~ leftMovingCol
 133                                  Up -> person & position . _r .~ upMovingRow
 134                                  Down -> person & position . _r .~ downMovingRow
 135
 136
 137 --   A B
 138 --   C
 139 -- D E
 140 -- F
 141
 142 whatsAheadCube :: Person -> FieldContext Person
 143 whatsAheadCube person =
 144   do let easyNext = (person ^. position) + (deltaOf $ person ^. facing)
 145      let currentFace = faceOf (person ^. position)
 146      let nextFace = faceOf easyNext
 147      fieldMap <- asks getMap
 148      if (easyNext `M.member` fieldMap) && (currentFace == nextFace)
 149      then return $ person & position .~ easyNext
 150      else return $ crossEdge person currentFace
 151
 152 faceOf :: Position -> Face
 153 faceOf position
 154   | (inRange (0, 49) r) && (inRange (50, 99) c) = A
 155   | (inRange (0, 49) r) && (inRange (100, 149) c) = B
 156   | (inRange (50, 99) r) && (inRange (50, 99) c) = C
 157   | (inRange (100, 149) r) && (inRange (0, 49) c) = D
 158   | (inRange (100, 149) r) && (inRange (50, 99) c) = E
 159   | (inRange (150, 199) r) && (inRange (0, 49) c) = F
 160   | otherwise = error "Not a face"
 161   where r = position ^. _r
 162         c = position ^. _c
 163
 164 crossEdge :: Person -> Face -> Person
 165 crossEdge person face =
 166   case (d, face) of
 167     (Up,    A) -> person & position . _r .~ (interpol c 150 199) & position . _c .~ 0 & facing .~ Right
 168     (Right, A) -> person & position . _c .~ 100
 169     (Down,  A) -> person & position . _r .~ 50
 170     (Left,  A) -> person & position . _r .~ (interpol r 149 100) & position . _c .~ 0 & facing .~ Right
 171
 172     (Up,    B) -> person & position . _r .~ 199 & position . _c .~ (interpol c 0 49)
 173     (Right, B) -> person & position . _r .~ (interpol r 149 100) & position . _c .~ 99 & facing .~ Left
 174     (Down,  B) -> person & position . _r .~ (interpol c 50 99) & position . _c .~ 99 & facing .~ Left
 175     (Left,  B) -> person & position . _c .~ 99
 176
 177     (Up,    C) -> person & position . _r .~ 49
 178     (Right, C) -> person & position . _r .~ 49 & position . _c .~ (interpol r 100 149) & facing .~ Up
 179     (Down,  C) -> person & position . _r .~ 100
 180     (Left,  C) -> person & position . _r .~ 100 & position . _c .~ (interpol r 0 49) & facing .~ Down
 181
 182     (Up,    D) -> person & position . _r .~ (interpol c 50 99) & position . _c .~ 50 & facing .~ Right
 183     (Right, D) -> person & position . _c .~ 50
 184     (Down,  D) -> person & position . _r .~ 150
 185     (Left,  D) -> person & position . _r .~ (interpol r 49 0) & position . _c .~ 50 & facing .~ Right
 186
 187     (Up,    E) -> person & position . _r .~ 99
 188     (Right, E) -> person & position . _r .~ (interpol r 49 0) & position . _c .~ 149 & facing .~ Left
 189     (Down,  E) -> person & position . _r .~ (interpol c 150 199) & position . _c .~ 49 & facing .~ Left
 190     (Left,  E) -> person & position . _c .~ 49
 191
 192     (Up,    F) -> person & position . _r .~ 149
 193     (Right, F) -> person & position . _r .~ 149 & position . _c .~ (interpol r 50 99) & facing .~ Up
 194     (Down,  F) -> person & position . _r .~ 0 & position . _c .~ (interpol c 100 149)
 195     (Left,  F) -> person & position . _r .~ 0 & position . _c .~ (interpol r 50 99) & facing .~ Down
 196
 197     otherwise -> error ("Crossing illegal boundary "  ++ show (person, face))
 198
 199   where r = person ^. position . _r
 200         c = person ^. position . _c
 201         d = person ^. facing
 202         interpol x start end = (signum (end - start)) * (x `mod` 50) + start
 203
 204
 205 walk :: Person -> [PathElement] -> FieldContext Person
 206 walk person [] = return person
 207 walk person (step:steps) =
 208   do person' <- walkOne person step
 209      walk person' steps
 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 r c rows = isRow && isCol && ((rows !! r) !! c) `elem` (".#" :: String)
 252   where isRow = r < length rows
 253         isCol = c < (length $ rows !! r)
 254
 255 mkInstructions :: String -> [PathElement]
 256 mkInstructions [] = []
 257 mkInstructions text@(t:ts)
 258   | isDigit t = mkWalk text
 259   | otherwise = mkTurn text
 260 mkWalk text = (Forward $ read digits) : (mkInstructions remainder)
 261   where (digits, remainder) = span (isDigit) text
 262 mkTurn (t:ts)
 263   | t == 'R' = Clockwise : (mkInstructions ts)
 264   | t == 'L' = Anticlockwise : (mkInstructions ts)