{-# Language QuasiQuotes, ImportQualifiedPost #-}
{-|
Module      : Main
Description : Day 14 solution
Copyright   : (c) Eric Mertens, 2022
License     : ISC
Maintainer  : emertens@gmail.com

<https://adventofcode.com/2022/day/14>

>>> :set -XQuasiQuotes
>>> let input = [format|- ((%u,%u)&( -> )%n)*|] "498,4 -> 498,6 -> 496,6\n503,4 -> 502,4 -> 502,9 -> 494,9\n"
>>> let world = Set.fromList (concatMap segs input)
>>> let limit = voidLimit world
>>> let Left world1 = fillFrom Left limit world top
>>> let picture = Data.Map.fromSet (const '█') world <> Data.Map.fromSet (const '◆') world1
>>> putStr (Advent.Coord.drawPicture picture)
······◆···
·····◆◆◆··
····█◆◆◆██
···◆█◆◆◆█·
··███◆◆◆█·
····◆◆◆◆█·
·◆·◆◆◆◆◆█·
█████████·
>>> Set.size world1 - Set.size world
24
>>> let Identity world2 = fillFrom Identity limit world top
>>> let picture = Data.Map.fromSet (const '█') world <> Data.Map.fromSet (const '◆') world2
>>> putStr (Advent.Coord.drawPicture picture)
··········◆··········
·········◆◆◆·········
········◆◆◆◆◆········
·······◆◆◆◆◆◆◆·······
······◆◆█◆◆◆██◆······
·····◆◆◆█◆◆◆█◆◆◆·····
····◆◆███◆◆◆█◆◆◆◆····
···◆◆◆◆·◆◆◆◆█◆◆◆◆◆···
··◆◆◆◆◆◆◆◆◆◆█◆◆◆◆◆◆··
·◆◆◆█████████◆◆◆◆◆◆◆·
◆◆◆◆◆·······◆◆◆◆◆◆◆◆◆
>>> Set.size world2 - Set.size world
93

-}
module Main where

import Control.Monad (foldM)
import Data.Functor.Identity (Identity(Identity))
import Data.List (find, foldl')
import Data.Set (Set)
import Data.Set qualified as Set

import Advent (format)
import Advent.Coord (coordRow, below, coordRow, left, right, Coord(..))

-- |
-- >>> :main
-- 644
-- 27324
main :: IO ()
IO ()
main =
 do [[(Int, Int)]]
input <- [format|2022 14 ((%u,%u)&( -> )%n)*|]
    let world :: Set Coord
world = [Coord] -> Set Coord
forall a. Ord a => [a] -> Set a
Set.fromList (([(Int, Int)] -> [Coord]) -> [[(Int, Int)]] -> [Coord]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [(Int, Int)] -> [Coord]
segs [[(Int, Int)]]
input)
        limit :: Int
limit = Set Coord -> Int
voidLimit Set Coord
world

    case (Set Coord -> Either (Set Coord) (Set Coord))
-> Int -> Set Coord -> Coord -> Either (Set Coord) (Set Coord)
forall (m :: * -> *).
Monad m =>
(Set Coord -> m (Set Coord))
-> Int -> Set Coord -> Coord -> m (Set Coord)
fillFrom Set Coord -> Either (Set Coord) (Set Coord)
forall a b. a -> Either a b
Left Int
limit Set Coord
world Coord
top of
      Right Set Coord
_     -> String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no solution"
      Left Set Coord
world1 -> Int -> IO ()
forall a. Show a => a -> IO ()
print (Set Coord -> Int
forall a. Set a -> Int
Set.size Set Coord
world1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Set Coord -> Int
forall a. Set a -> Int
Set.size Set Coord
world)

    case (Set Coord -> Identity (Set Coord))
-> Int -> Set Coord -> Coord -> Identity (Set Coord)
forall (m :: * -> *).
Monad m =>
(Set Coord -> m (Set Coord))
-> Int -> Set Coord -> Coord -> m (Set Coord)
fillFrom Set Coord -> Identity (Set Coord)
forall a. a -> Identity a
Identity Int
limit Set Coord
world Coord
top of
      Identity Set Coord
world2 -> Int -> IO ()
forall a. Show a => a -> IO ()
print (Set Coord -> Int
forall a. Set a -> Int
Set.size Set Coord
world2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Set Coord -> Int
forall a. Set a -> Int
Set.size Set Coord
world)

-- | The entry point of sand at @500,0@
top :: Coord
top :: Coord
top = Int -> Int -> Coord
C Int
0 Int
500

-- | Find the level beyond any walls.
voidLimit :: Set Coord -> Int
voidLimit :: Set Coord -> Int
voidLimit Set Coord
world = Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Coord -> Int
coordRow (Set Coord -> Coord
forall a. Ord a => Set a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum Set Coord
world)

-- | Fill the given world with sand from a fill coordinate returning the
-- final state of the world. This is parameterized over a callback for how
-- to handle when sand reaches the bottom of the level in order to allow
-- early termination or not.
fillFrom ::
  Monad m =>
  (Set Coord -> m (Set Coord)) {- ^ behavior when sand reaches limit -} ->
  Int                          {- ^ lower limit -} ->
  Set Coord                    {- ^ initial wall and sand locations -} ->
  Coord                        {- ^ location to fill from -} ->
  m (Set Coord)                {- ^ final wall and sand locations -}
fillFrom :: forall (m :: * -> *).
Monad m =>
(Set Coord -> m (Set Coord))
-> Int -> Set Coord -> Coord -> m (Set Coord)
fillFrom Set Coord -> m (Set Coord)
onVoid Int
limit Set Coord
world Coord
here
  | Int
limit Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Coord -> Int
coordRow Coord
here = Set Coord -> m (Set Coord)
onVoid Set Coord
world
  | Coord -> Set Coord -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Coord
here Set Coord
world = Set Coord -> m (Set Coord)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Set Coord
world
  | Bool
otherwise = Coord -> Set Coord -> Set Coord
forall a. Ord a => a -> Set a -> Set a
Set.insert Coord
here (Set Coord -> Set Coord) -> m (Set Coord) -> m (Set Coord)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Set Coord -> Coord -> m (Set Coord))
-> Set Coord -> [Coord] -> m (Set Coord)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((Set Coord -> m (Set Coord))
-> Int -> Set Coord -> Coord -> m (Set Coord)
forall (m :: * -> *).
Monad m =>
(Set Coord -> m (Set Coord))
-> Int -> Set Coord -> Coord -> m (Set Coord)
fillFrom Set Coord -> m (Set Coord)
onVoid Int
limit) Set Coord
world
                  [Coord -> Coord
below Coord
here, Coord -> Coord
left (Coord -> Coord
below Coord
here), Coord -> Coord
right (Coord -> Coord
below Coord
here)]

-- Turning line segments into sets of coordinates

segs :: [(Int,Int)] -> [Coord]
segs :: [(Int, Int)] -> [Coord]
segs ((Int, Int)
x:(Int, Int)
y:[(Int, Int)]
z) = (Int, Int) -> (Int, Int) -> [Coord]
seg (Int, Int)
x (Int, Int)
y [Coord] -> [Coord] -> [Coord]
forall a. [a] -> [a] -> [a]
++ [(Int, Int)] -> [Coord]
segs ((Int, Int)
y(Int, Int) -> [(Int, Int)] -> [(Int, Int)]
forall a. a -> [a] -> [a]
:[(Int, Int)]
z)
segs [(Int
x,Int
y)] = [Int -> Int -> Coord
C Int
y Int
x]
segs []      = []

seg :: (Int,Int) -> (Int,Int) -> [Coord]
seg :: (Int, Int) -> (Int, Int) -> [Coord]
seg (Int
a,Int
b) (Int
c,Int
d)
  | Int
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
c    = [Int -> Int -> Coord
C Int
y Int
a | Int
y <- [Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
b Int
d .. Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
b Int
d]]
  | Int
b Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
d    = [Int -> Int -> Coord
C Int
d Int
x | Int
x <- [Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
a Int
c .. Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
a Int
c]]
  | Bool
otherwise = String -> [Coord]
forall a. HasCallStack => String -> a
error String
"unexpected input"