Day 10 AOC 2023

day_ten_2023.hs

{-# LANGUAGE OverloadedStrings #-}
module DayTen where

import qualified Data.Text as T
import qualified Data.List as L
import qualified Text.Read as TR
import Debug.Trace (traceShowId, traceShow)
import qualified Data.Maybe as M
import qualified Data.Set as S
import Safe (atDef, atMay, minimumMay, headMay)

gridAt :: [[a]] -> (Int, Int) -> Maybe a
gridAt items (rowIdx, colIdx) = row `atMay` colIdx
  where row = items `atRow` rowIdx
        atRow = atDef []

data Tile = Vertical | Horizontal | NE | NW | SW | SE | Ground | Start deriving (Show, Ord, Eq)



isVerticalBar Vertical = True
isVerticalBar _ = False

isHorizontalBar Horizontal = True
isHorizontalBar _ = False

isCorner NE = True
isCorner NW = True
isCorner SE = True
isCorner SW = True
isCorner _ = False

data Node = Node (Int, Int) Tile [Node]
instance Show Node
  where show (Node coordinates tile neighbors) = (show coordinates) ++ " " ++ (show tile) ++ "  [" ++ L.intercalate ", " (map showCheap neighbors) ++ "]"
          where showCheap (Node coordinates tile neighbors) = (show coordinates) ++ " " ++ (show tile)


getNeighbors (Node _ _ neighbors) = neighbors
getTile (Node _ tile _) = tile
getCoordinates (Node idx _ _) = idx

instance Ord Node
  where compare (Node firstCoordinates _ _) (Node secondCoordinates _ _) = compare firstCoordinates secondCoordinates

instance Eq Node
  where (Node firstCoordinates _ _) == (Node secondCoordinates _ _) = firstCoordinates == secondCoordinates

isSeed (Node _ Start _) = True
isSeed _ = False

goNorth (row,col) = (row - 1, col)
goSouth (row,col) = (row + 1, col)
goEast (row,col) = (row, col + 1)
goWest (row,col) = (row, col - 1)

neighborIndices Vertical (row,col) = [goNorth (row,col), goSouth (row,col)]
neighborIndices Horizontal (row,col) = [goEast (row, col), goWest (row,col)]
neighborIndices NE (row,col) = [goNorth (row, col), goEast (row,col)]
neighborIndices NW (row,col) = [goNorth (row, col), goWest (row,col)]
neighborIndices SE (row,col) = [goSouth (row, col), goEast (row,col)]
neighborIndices SW (row,col) = [goSouth (row, col), goWest (row,col)]
neighborIndices _ (row,col) = []


testInput :: [T.Text]
testInput = ["7-F7-",
             ".FJ|7",
             "SJLL7",
             "|F--J",
             "LJ.LJ"]


parseTile '|' = Vertical
parseTile '-' = Horizontal
parseTile 'L' = NE
parseTile 'J' = NW
parseTile '7' = SW
parseTile 'F' = SE
parseTile 'S' = Start
parseTile _ = Ground

parseGrid :: [T.Text] -> [[Tile]]
parseGrid = map (pad . (map parseTile) . T.unpack)
  where pad tiles = tiles


buildIdxGrid parsedInput = (map (\idx -> (map (\ri -> (idx, ri)) row)) colIdxs)
  where colIdxs = 0 `enumFromTo` (height - 1)
        row = 0 `enumFromTo` (width - 1)
        height = length parsedInput
        width = length $ head parsedInput


crudeNeighbors grid node@(Node coordinates tile _) =  (M.catMaybes (map (grid `gridAt`) (neighborIndices tile coordinates)))


getStart graph = head $ filter isSeed $ concat graph

mutualNeighbors grid node@(Node coordinates tile _) = filter pointsBack (crudeNeighbors grid node)
  where pointsBack neighbor
          | isSeed neighbor = True
          | otherwise = any (== node) (crudeNeighbors grid neighbor)

buildGraph parsedInput = answer
  where coordinateTemplate = buildIdxGrid parsedInput
        answer = map (M.catMaybes . (map buildNode)) coordinateTemplate
        buildNode (row,col) = do
          tile <- (parsedInput `gridAt` (row, col))
          let node = Node (row,col) tile (mutualNeighbors answer node) -- note that we are passing in 'node'...to build 'node'
          return node

followToEnd seenSoFar current@(Node _ Start neighbors) = [current]
followToEnd seenSoFar current@(Node _ _ neighbors)  = current : new
  where new = concatMap (followToEnd (S.insert current seenSoFar)) $ viableNeighbors
        viableNeighbors  = filter (\x -> (getTile x) /= Start) (S.toList $ (S.fromList neighbors) S.\\ seenSoFar)

partOne parsed = [length (followToEnd (S.fromList []) righted), length (followToEnd (S.fromList []) upped)]
  where start@(Node startCoords _ _) = getStart graph
        graph = buildGraph parsed
        upped = M.fromJust $ graph `gridAt` (goNorth startCoords)
        righted = M.fromJust $ graph `gridAt` (goEast startCoords)


partTwoTest :: [T.Text]
partTwoTest = ["..........",
               ".S------7.",
               ".|F----7|.",
               ".||....||.",
               ".||....||.",
               ".|L-7F-J|.",
               ".|..||..|.",
               ".L--JL--J.",
               ".........."]
partTwoSecondTest :: [T.Text]
partTwoSecondTest = ["FF7FSF7F7F7F7F7F---7",
                     "L|LJ||||||||||||F--J",
                     "FL-7LJLJ||||||LJL-77",
                     "F--JF--7||LJLJ7F7FJ-",
                     "L---JF-JLJ.||-FJLJJ7",
                     "|F|F-JF---7F7-L7L|7|",
                     "|FFJF7L7F-JF7|JL---7",
                     "7-L-JL7||F7|L7F-7F7|",
                     "L.L7LFJ|||||FJL7||LJ",
                     "L7JLJL-JLJLJL--JLJ.L"]

isLoop grid path = length path >= 8 && (isClosed || touchesStartTwice)
  where endOfLoop = last $ path
        touchesStartTwice = length (filter isNeighborOfStart path) == 2
        isNeighborOfStart node = any (\n -> (getTile n == Start)) (getNeighbors node)
        isClosed = (S.fromList $ concatMap  (crudeNeighbors grid) path) == pathSet
        pathSet = S.fromList path


allLoops grid = foldl go ([], S.empty) allNodes
  where allNodes = concat grid
        go (loopsSeen, deadEndNodes) node
          | any (elem node) loopsSeen = (loopsSeen, deadEndNodes)
          | node `elem` deadEndNodes = (loopsSeen, deadEndNodes)
          | isLoop grid fullPath = (fullPathSet:loopsSeen, deadEndNodes)
          | otherwise = (loopsSeen, S.union deadEndNodes fullPathSet)
          where fullPath = followToEnd S.empty node
                fullPathSet = (S.fromList fullPath)



listInteriorAlongPath :: (S.Set Node) -> Int -> [Node] -> [Tile] -> Node -> [Node] -> [Node]
listInteriorAlongPath bdry crossingsCompleted interiorsFound cornersSeen currentLocation [] = interiorsFound
listInteriorAlongPath bdry crossingsCompleted interiorsFound cornersSeen currentLocation (head:rest)
  | amOnBoundary && (not (adjacentBorder currentLocation head)) && (countsAsCrossing (headMay cornersSeen) (getTile currentLocation)) = listInteriorAlongPath bdry (crossingsCompleted + 1) newInteriors newCorners head rest
  | otherwise = vanillaRecur
  where newCorners
          | isCorner currentTile = currentTile : cornersSeen
          | otherwise = cornersSeen
        currentTile = (getTile currentLocation)
        vanillaRecur = listInteriorAlongPath bdry crossingsCompleted newInteriors newCorners head rest
        amOnBoundary = (currentLocation `elem` bdry)
        newInteriors
          | (odd crossingsCompleted) && (not amOnBoundary) = currentLocation : interiorsFound
          | otherwise = interiorsFound
        countsAsCrossing (Just SW) NE = True
        countsAsCrossing (Just SE) NW = True
        countsAsCrossing (Just NW) SE = True
        countsAsCrossing (Just NE) SW = True
        countsAsCrossing _ Horizontal = True
        countsAsCrossing _ Vertical = True
        countsAsCrossing _ _ = False

-- To do part 2, find the longest loop in your grid, pass it in here.
-- Make sure you've replaced 'S' with the relevant pipe, in my case it was '|'
findInterior loop grid = concatMap doRow rowPaths
  where rowPaths = (buildIdxGrid grid)
        doRow rowPath = listInteriorAlongPath loop 0 [] [] (gl (head rowPath)) (map gl (tail rowPath))
        gl = gridLookup grid




adjacentBorder a b = b `elem` (getNeighbors a)

gridLookup grid c = M.fromJust $ grid `gridAt` c