Aay Twelve

DayTwelve.hs

{-# LANGUAGE OverloadedStrings #-}

module DayTwelve
    ( partTwo
    ) where
import qualified Data.Maybe as M
import qualified Data.Text as T
import qualified Data.Text.IO as TI
import qualified Data.List as L
import qualified Data.List.Extra as LE
import qualified Data.Char as C
import qualified Data.Set as S

data Coordinate = Coordinate {row::Int, column::Int} deriving (Eq, Show, Ord)
data FrontierItem = FrontierItem {path :: [Coordinate]} deriving (Eq, Show)
data SearchState = SearchState {frontier::[FrontierItem], explored::(S.Set Coordinate)} deriving (Eq, Show)
data GridSquare = StartSquare | DestinationSquare | IntermediateSquare Int deriving (Eq, Show)
type Grid = [[GridSquare]]

 -- tree search
initialState grid = SearchState [FrontierItem [startSquare]] $ S.fromList [startSquare]
  where startSquare = findStart grid

updateFrontier grid state = foldl go (SearchState [] (explored state)) (frontier state)
  where go currentState frontierItem = SearchState newFrontier $ newExplored
          where newFrontier = smallNewFrontier ++ (frontier currentState)
                newExplored = S.union (S.fromList (map currentPlace newFrontier)) (explored currentState)
                smallNewFrontier = map tackOn $ filter notExplored $ accessible grid $ currentPlace frontierItem
                tackOn coordinate = FrontierItem (coordinate:(path frontierItem))
		notExplored coordinate = S.notMember coordinate (explored currentState)

shortestPath grid state = go found
  where found = LE.find isWinner (frontier state)
        isWinner frontierItem = gridAt (currentPlace frontierItem) == DestinationSquare
	gridAt (Coordinate row column) = (grid !! row) !! column
	go Nothing = if ((updateFrontier grid state) == state) then Nothing else shortestPath grid (updateFrontier grid state)
	go (Just it) = Just it

newFrontierItems grid explored item = L.filter (\e -> S.notMember e explored) (accessible grid (currentPlace item))

currentPlace = head . path

-- navigation in the grid
neighbors grid coordinate@(Coordinate row column) = L.filter inGrid naiveNeighbors
  where naiveNeighbors = [Coordinate (row + 1) column, Coordinate (row - 1) column, Coordinate row (column + 1), Coordinate row (column - 1)]
        inGrid (Coordinate row column) = row >= 0 && column >= 0 && row < rowCount && column < columnCount
	rowCount = length grid
	columnCount = length $ head grid

accessible grid coordinate = L.filter isAccessible $ neighbors grid coordinate
  where isAccessible b = canStep (gridAt coordinate) (gridAt b)
	gridAt (Coordinate row column) = (grid !! row) !! column

canStep StartSquare (IntermediateSquare 0) = True
canStep StartSquare (IntermediateSquare _) = False
canStep StartSquare DestinationSquare = True
canStep StartSquare _ = False
canStep (IntermediateSquare a) DestinationSquare = a >= 24
canStep (IntermediateSquare a) (IntermediateSquare b) = (b < a) || (b - a) < 2
canStep (IntermediateSquare a) _ = False
canStep DestinationSquare _ = False

-- orchestration

findStart grid = head $ filter isStart allCoordinates
  where gridAt (Coordinate row column) = (grid !! row) !! column
        isStart coordinate = (gridAt coordinate) == StartSquare
	rowCount = length grid
	columnCount = length $ head grid
	allCoordinates = map makeCoordinate $ cartesianProduct [0..(rowCount - 1)] [0..(columnCount - 1)]
	makeCoordinate (row,col) = Coordinate row col


findStarts grid = filter isStart allCoordinates
  where gridAt (Coordinate row column) = (grid !! row) !! column
        isStart coordinate = (gridAt coordinate) == StartSquare || (gridAt coordinate) == IntermediateSquare 0
	rowCount = length grid
	columnCount = length $ head grid
	allCoordinates = map makeCoordinate $ cartesianProduct [0..(rowCount - 1)] [0..(columnCount - 1)]
	makeCoordinate (row,col) = Coordinate row col

cartesianProduct a b = (,) <$> a <*> b

allInitialStates grid = map makeState (findStarts grid)
  where makeState coordinate = SearchState [FrontierItem [coordinate]] $ S.fromList [coordinate]

partTwo grid = map scoreIt (allInitialStates grid)
  where scoreIt state = scoreMaybe (shortestPath grid state)
        scoreMaybe Nothing = Nothing
        scoreMaybe (Just answer) = Just $ length $ path $ answer


testInput = [
  "Sabqponm",
  "abcryxxl",
  "accszExk",
  "acctuvwj",
  "abdefghi"
  ]
testGrid = map parse testInput

parse line = L.map parseChar line
  where parseChar 'S' = StartSquare
        parseChar 'E' = DestinationSquare
        parseChar c = IntermediateSquare $ C.ord c - C.ord 'a'

getInput path = do
  input <- TI.readFile path
  let
    parsed = map (parse . T.unpack) $ T.lines input
  return parsed