--- /dev/null
+-- Writeup at https://work.njae.me.uk/2022/12/19/advent-of-code-2022-day-18/
+
+import Debug.Trace
+
+import AoC
+import Prelude hiding (Left, Right)
+import qualified Data.Map.Strict as M
+import Data.Map.Strict ((!))
+import Linear hiding (E)
+import Control.Lens
+import Data.Ix
+import Data.Maybe
+import Data.List
+import Data.Char
+import Control.Monad.Reader
+
+
+type Position = V2 Int -- r, c
+_r :: Lens' (V2 Int) Int
+_r = _x
+_c :: Lens' (V2 Int) Int
+_c = _y
+
+data Cell = Tile | Wall
+ deriving (Show, Eq)
+
+type FieldMap = M.Map Position Cell
+
+data Direction = Right | Down | Left | Up
+ deriving (Show, Eq, Ord, Enum, Bounded)
+
+predW, succW :: (Eq a, Bounded a, Enum a) => a -> a
+predW a
+ | a == minBound = maxBound
+ | otherwise = pred a
+succW a
+ | a == maxBound = minBound
+ | otherwise = succ a
+
+data PathElement = Forward Int | Clockwise | Anticlockwise
+ deriving (Show, Eq)
+
+data Person = Person {_position :: Position, _facing :: Direction}
+ deriving (Show, Eq)
+makeLenses ''Person
+
+data Field = Field { getMap :: FieldMap, whatsAheadFunc :: Person -> FieldContext Person, whatsAtFunc :: Position -> FieldContext Cell}
+type FieldContext = Reader Field
+
+data Face = A | B | C | D | E | F
+ deriving (Show, Eq)
+
+main :: IO ()
+main =
+ do dataFileName <- getDataFileName
+ text <- readFile dataFileName
+ let (field, instrs) = successfulParse text
+ print $ part1 field instrs
+ print $ part2 field instrs
+ -- print $ probeAllCorners field
+
+part1 fieldMap instrs = passwordOf endPerson
+ where field = mkFlatField fieldMap
+ startPos = V2 0 $ fromJust $ minimumOf (folded . filteredBy (_r . only 0) . _c) $ M.keysSet fieldMap
+ startPerson = Person startPos Right
+ endPerson = runReader (walk startPerson instrs) field
+
+part2 fieldMap instrs = passwordOf endPerson
+ where field = mkCubeField fieldMap
+ startPos = V2 0 $ fromJust $ minimumOf (folded . filteredBy (_r . only 0) . _c) $ M.keysSet fieldMap
+ startPerson = Person startPos Right
+ endPerson = runReader (walk startPerson instrs) field
+
+-- probeCube fieldMap startPos startDirection = endPerson
+-- where field = mkCubeField fieldMap
+-- startPerson = Person startPos startDirection
+-- endPerson = runReader (whatsAheadCube startPerson) field
+
+-- probeAllCorners fieldMap = [(p, probeACorner p field) | p <- persons]
+-- where persons = [ Person (V2 r c) f
+-- | r <- [0, 49, 50, 99, 100, 149]
+-- , c <- [0, 49, 50, 99, 100, 149, 150, 199]
+-- , f <- [Right, Down, Left, Up]
+-- , (V2 r c) `M.member` fieldMap
+-- ]
+-- field = mkCubeField fieldMap
+
+-- probeACorner person field
+-- | Debug.Trace.trace (show person) False = undefined
+-- | otherwise = runReader (whatsAheadCube person) field
+
+
+passwordOf :: Person -> Int
+passwordOf person = 1000 * (person ^. position . _r + 1)
+ + 4 * (person ^. position . _c + 1)
+ + (fromEnum $ person ^. facing)
+
+
+mkFlatField :: FieldMap -> Field
+mkFlatField fieldMap =
+ Field { getMap = fieldMap
+ , whatsAheadFunc = whatsAheadFlat
+ , whatsAtFunc = whatsAt}
+
+
+mkCubeField :: FieldMap -> Field
+mkCubeField fieldMap =
+ Field { getMap = fieldMap
+ , whatsAheadFunc = whatsAheadCube
+ , whatsAtFunc = whatsAt}
+
+whatsAt :: Position -> FieldContext Cell
+whatsAt posiiton =
+ do fieldMap <- asks getMap
+ return $ fieldMap ! posiiton
+
+whatsAheadFlat :: Person -> FieldContext Person
+whatsAheadFlat person =
+ do let easyNext = (person ^. position) + (deltaOf $ person ^. facing)
+ fieldMap <- asks getMap
+ if easyNext `M.member` fieldMap
+ then return $ person & position .~ easyNext
+ else do let currenFacing = person ^. facing
+ let currentRow = person ^. position . _r
+ let currentCol = person ^. position . _c
+ let rightMovingCol = fromJust $ minimumOf (folded . filteredBy (_r . only currentRow) . _c) $ M.keysSet fieldMap
+ let leftMovingCol = fromJust $ maximumOf (folded . filteredBy (_r . only currentRow) . _c) $ M.keysSet fieldMap
+ let upMovingRow = fromJust $ maximumOf (folded . filteredBy (_c . only currentCol) . _r) $ M.keysSet fieldMap
+ let downMovingRow = fromJust $ minimumOf (folded . filteredBy (_c . only currentCol) . _r) $ M.keysSet fieldMap
+ return $ case currenFacing of
+ Right -> person & position . _c .~ rightMovingCol
+ Left -> person & position . _c .~ leftMovingCol
+ Up -> person & position . _r .~ upMovingRow
+ Down -> person & position . _r .~ downMovingRow
+
+
+-- A B
+-- C
+-- D E
+-- F
+
+whatsAheadCube :: Person -> FieldContext Person
+whatsAheadCube person =
+ do let easyNext = (person ^. position) + (deltaOf $ person ^. facing)
+ let currentFace = faceOf (person ^. position)
+ let nextFace = faceOf easyNext
+ fieldMap <- asks getMap
+ if (easyNext `M.member` fieldMap) && (currentFace == nextFace)
+ then return $ person & position .~ easyNext
+ else return $ crossEdge person currentFace
+
+faceOf :: Position -> Face
+faceOf position
+ | (inRange (0, 49) r) && (inRange (50, 99) c) = A
+ | (inRange (0, 49) r) && (inRange (100, 149) c) = B
+ | (inRange (50, 99) r) && (inRange (50, 99) c) = C
+ | (inRange (100, 149) r) && (inRange (0, 49) c) = D
+ | (inRange (100, 149) r) && (inRange (50, 99) c) = E
+ | (inRange (150, 199) r) && (inRange (0, 49) c) = F
+ | otherwise = error "Not a face"
+ where r = position ^. _r
+ c = position ^. _c
+
+crossEdge :: Person -> Face -> Person
+crossEdge person face =
+ case (d, face) of
+ (Up, A) -> person & position . _r .~ (interpol c 150 199) & position . _c .~ 0 & facing .~ Right
+ (Right, A) -> person & position . _c .~ 100
+ (Down, A) -> person & position . _r .~ 50
+ (Left, A) -> person & position . _r .~ (interpol r 149 100) & position . _c .~ 0 & facing .~ Right
+
+ (Up, B) -> person & position . _r .~ 199 & position . _c .~ (interpol c 0 49)
+ (Right, B) -> person & position . _r .~ (interpol r 149 100) & position . _c .~ 99 & facing .~ Left
+ (Down, B) -> person & position . _r .~ (interpol c 50 99) & position . _c .~ 99 & facing .~ Left
+ (Left, B) -> person & position . _c .~ 99
+
+ (Up, C) -> person & position . _r .~ 49
+ (Right, C) -> person & position . _r .~ 49 & position . _c .~ (interpol r 100 149) & facing .~ Up
+ (Down, C) -> person & position . _r .~ 100
+ (Left, C) -> person & position . _r .~ 100 & position . _c .~ (interpol r 0 49) & facing .~ Down
+
+ (Up, D) -> person & position . _r .~ (interpol c 50 99) & position . _c .~ 50 & facing .~ Right
+ (Right, D) -> person & position . _c .~ 50
+ (Down, D) -> person & position . _r .~ 150
+ (Left, D) -> person & position . _r .~ (interpol r 49 0) & position . _c .~ 50 & facing .~ Right
+
+ (Up, E) -> person & position . _r .~ 99
+ (Right, E) -> person & position . _r .~ (interpol r 49 0) & position . _c .~ 149 & facing .~ Left
+ (Down, E) -> person & position . _r .~ (interpol c 150 199) & position . _c .~ 49 & facing .~ Left
+ (Left, E) -> person & position . _c .~ 49
+
+ (Up, F) -> person & position . _r .~ 149
+ (Right, F) -> person & position . _r .~ 149 & position . _c .~ (interpol r 50 99) & facing .~ Up
+ (Down, F) -> person & position . _r .~ 0 & position . _c .~ (interpol c 100 149)
+ (Left, F) -> person & position . _r .~ 0 & position . _c .~ (interpol r 50 99) & facing .~ Down
+
+ otherwise -> error ("Crossing illegal boundary " ++ show (person, face))
+
+ where r = person ^. position . _r
+ c = person ^. position . _c
+ d = person ^. facing
+ interpol x start end = (signum (end - start)) * (x `mod` 50) + start
+
+
+walk :: Person -> [PathElement] -> FieldContext Person
+walk person [] = return person
+walk person (step:steps) =
+ do person' <- walkOne person step
+ walk person' steps
+
+walkOne :: Person -> PathElement -> FieldContext Person
+walkOne person (Forward n)
+ | n == 0 = return person
+ | otherwise =
+ do whatsAhead <- asks whatsAheadFunc
+ person' <- whatsAhead person
+ whatsAt <- asks whatsAtFunc
+ nextCell <- whatsAt (person' ^. position)
+ if nextCell == Wall
+ then return person
+ else walkOne person' (Forward (n - 1))
+walkOne person Clockwise = return $ person & facing %~ succW
+walkOne person Anticlockwise = return $ person & facing %~ predW
+
+deltaOf :: Direction -> Position
+deltaOf Right = V2 0 1
+deltaOf Down = V2 1 0
+deltaOf Left = V2 0 -1
+deltaOf Up = V2 -1 0
+
+
+-- Parse the input file
+
+successfulParse :: String -> (FieldMap, [PathElement])
+successfulParse text = (mkField $ takeWhile ((> 0) . length) $ init $ lines text, mkInstructions $ last $ lines text)
+
+mkField :: [String] -> FieldMap
+mkField rows = M.fromList
+ [ (V2 r c, mkCell r c)
+ | r <- [0..maxR], c <- [0..maxC]
+ , isCell r c rows
+ ]
+ where maxR = length rows - 1
+ maxC = (length $ head rows) - 1
+ -- isCell r c = ((rows !! r) !! c) `elem` (".#" :: String)
+ mkCell r c
+ | cell == '.' = Tile
+ | cell == '#' = Wall
+ where cell = (rows !! r) !! c
+
+isCell r c rows = isRow && isCol && ((rows !! r) !! c) `elem` (".#" :: String)
+ where isRow = r < length rows
+ isCol = c < (length $ rows !! r)
+
+mkInstructions :: String -> [PathElement]
+mkInstructions [] = []
+mkInstructions text@(t:ts)
+ | isDigit t = mkWalk text
+ | otherwise = mkTurn text
+mkWalk text = (Forward $ read digits) : (mkInstructions remainder)
+ where (digits, remainder) = span (isDigit) text
+mkTurn (t:ts)
+ | t == 'R' = Clockwise : (mkInstructions ts)
+ | t == 'L' = Anticlockwise : (mkInstructions ts)
projects / advent-of-code-22.git / blobdiff