Day Fourteen

DayFourteen.hs

module DayFourteen
    ( main
    ) where
import qualified Data.Maybe as M
import qualified Data.Ord as O
import qualified Data.Text as T
import qualified Data.Text.IO as TI
import qualified Data.List as L
import qualified Data.List.Split as LS
import qualified Data.Set as S
import qualified Data.Function as F
import Debug.Trace

data GameState = GameState { rocks :: S.Set Coordinate, sand :: S.Set Coordinate, hasFloor :: Bool } deriving (Eq)
data Coordinate = Coordinate { row :: Int, column :: Int } deriving (Eq, Show, Ord)

type RockFormation = [Coordinate]

spaceOccupied coordinate world = (coordinate `S.member` (rocks world)) || (coordinate `S.member` (sand world))


floorRow world = highestRow + 2
  where highestRow = L.maximum (map row (S.toList (rocks world)))

hitsFloor world row = (hasFloor world) && (floorRow world) <= (row + 1)

spaceBelowOccupied world coordinate@(Coordinate row col) = spaceOccupied (below coordinate) world || hitsFloor world row
spaceBelowLeftOccupied world coordinate@(Coordinate row col) = spaceOccupied (belowLeft coordinate) world || hitsFloor world row
spaceBelowRightOccupied world coordinate@(Coordinate row col) = spaceOccupied (belowRight coordinate) world || hitsFloor world row

below (Coordinate row col) = Coordinate (row + 1) col
belowLeft (Coordinate row col) = Coordinate (row + 1) (col - 1)
belowRight (Coordinate row col) = Coordinate (row + 1) (col + 1)

fallOnce world coordinate = go (isInFreeFall world coordinate) (spaceBelowOccupied world coordinate) (spaceBelowLeftOccupied world coordinate) (spaceBelowRightOccupied world coordinate)
  where go True _ _ _ = Nothing
        go False False _ _ = Just $ below coordinate
        go False True False _ = Just $ belowLeft coordinate
        go False True True False = Just $ belowRight coordinate
        go False _ _ _ = Just $ coordinate

isInFreeFall world coordinate = (row coordinate) > (highestRow + 5)
  where highestRow = L.maximum (map row (S.toList (rocks world)))

fallFull :: GameState -> Coordinate -> (Maybe Coordinate)
fallFull world coordinate = do
  afterOneStep <- fallOnce world coordinate
  let stuck = (afterOneStep == coordinate)
  answer <- if stuck then (Just coordinate) else (fallFull world afterOneStep)
  return answer

myTrace x = trace (show x) x

addSingleSand world = world { sand = newSand }
  where fallSandPosition = myTrace $ fallFull world sandOrigin
        addSand Nothing = (sand world)
        addSand (Just position) = S.insert position (sand world)
        newSand = addSand fallSandPosition

worldIsFull world = sandOrigin `S.member` (sand world)

partTwo world n
  | worldIsFull world = n
  | otherwise = partTwo (addSingleSand world) (n+1)

main world n
  | ((addSingleSand world) == world) = world
  | otherwise = main (addSingleSand world) (n+1)

buildWorld formations hasFloor = GameState rocks (S.fromList []) hasFloor
  where rocks = foldl1 S.union $ map allRocks formations

addManySand world 0 = world
addManySand world n = addManySand (addSingleSand world) $ n-1

testWorldV1 = buildWorld [[Coordinate 4 498, Coordinate 6 498, Coordinate 6 496],[Coordinate 4 503, Coordinate 4 502, Coordinate 9 502, Coordinate 9 494]] False
testWorldV2 = buildWorld [[Coordinate 4 498, Coordinate 6 498, Coordinate 6 496],[Coordinate 4 503, Coordinate 4 502, Coordinate 9 502, Coordinate 9 494]] True


allRocks formation = S.fromList $ L.concatMap fillOutSegment pairs
  where pairs = (zip formation (tail formation))
        fillOutSegment ((Coordinate startRow startCol), (Coordinate endRow endCol))
          | (startRow == endRow) = map (\c -> (Coordinate startRow c)) $ itemsBetween startCol endCol
          | (startCol == endCol) = map (\r -> (Coordinate r startCol)) $ itemsBetween startRow endRow
          | otherwise = []

itemsBetween a b
  | a < b = [a..b]
  | otherwise = [b..a]

sandOrigin = Coordinate 0 500

instance Show GameState where
  show gs = L.intercalate "\n" lines
    where startColumn = L.minimum (map column (S.toList (rocks gs))) - 10
          endColumn = L.maximum (map column (S.toList (rocks gs))) + 10
          endRow = L.maximum (map row (S.toList (rocks gs))) + 10
          lines = map renderLine [0..endRow]
          renderLine lineNum = map (\c -> renderChar (Coordinate lineNum c)) [startColumn..endColumn]
          renderChar coord = if coord == sandOrigin
                               then '+'
                             else if coord `S.member` (rocks gs)
                               then '#'
                             else if coord `S.member` (sand gs)
                               then '*'
                             else if (row coord) == (floorRow gs) && (hasFloor gs)
                               then 'F'
                             else '.'

parse line = map parseCoordinate $ LS.splitOn " -> " line
  where parseCoordinate s = Coordinate (read (splitted !! 1)) (read (splitted !! 0))
          where splitted = LS.splitOn "," s


getLines path = do
  input <- TI.readFile path
  return $ map T.unpack $ T.lines input