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
  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 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     otherwise -> error ("Crossing illegal boundary "  ++ show (person, face))
 203
 204   where r = person ^. position . _r
 205         c = person ^. position . _c
 206         d = person ^. facing
 207         interpol x start end = (signum (end - start)) * (x `mod` 50) + start
 208
 209
 210 walk :: Person -> [PathElement] -> FieldContext Person
 211 walk person path = foldM walkOne person path
 212
 213 walkOne :: Person -> PathElement -> FieldContext Person
 214 walkOne person (Forward n)
 215   | n == 0 = return person
 216   | otherwise =
 217       do whatsAhead <- asks whatsAheadFunc
 218          person' <- whatsAhead person
 219          -- whatsAt <- asks whatsAtFunc
 220          nextCell <- whatsAt (person' ^. position)
 221          if nextCell == Wall
 222          then return person
 223          else walkOne person' (Forward (n - 1))
 224 walkOne person Clockwise = return $ person & facing %~ succW
 225 walkOne person Anticlockwise = return $ person & facing %~ predW
 226
 227 deltaOf :: Direction -> Position
 228 deltaOf Right = V2 0 1
 229 deltaOf Down = V2 1 0
 230 deltaOf Left = V2 0 -1
 231 deltaOf Up = V2 -1 0
 232
 233
 234 -- Parse the input file
 235
 236 successfulParse :: String -> (FieldMap, [PathElement])
 237 successfulParse text = (mkField $ takeWhile ((> 0) . length) $ init $ lines text, mkInstructions $ last $ lines text)
 238
 239 mkField :: [String] -> FieldMap
 240 mkField rows = M.fromList
 241       [ (V2 r c, mkCell r c)
 242       | r <- [0..maxR], c <- [0..maxC]
 243       , isCell r c rows
 244       ]
 245   where maxR = length rows - 1
 246         maxC = (length $ head rows) - 1
 247         -- isCell r c = ((rows !! r) !! c) `elem` (".#" :: String)
 248         mkCell r c
 249           | cell == '.' = Tile
 250           | cell == '#' = Wall
 251           where cell = (rows !! r) !! c
 252
 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 :: String -> [PathElement]
 258 mkInstructions [] = []
 259 mkInstructions text@(t:ts)
 260   | isDigit t = mkWalk text
 261   | otherwise = mkTurn text
 262 mkWalk text = (Forward $ read digits) : (mkInstructions remainder)
 263   where (digits, remainder) = span (isDigit) text
 264 mkTurn (t:ts)
 265   | t == 'R' = Clockwise : (mkInstructions ts)
 266   | t == 'L' = Anticlockwise : (mkInstructions ts)