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

<https://adventofcode.com/2018/day/17>
-}
module Main (main) where

import Advent (format, countBy)
import Advent.Coord (below, coordCol, coordRow, left, right, Coord(..))
import Data.Array.Unboxed as A
import Data.Foldable (foldl')
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Set (Set)
import Data.Set qualified as Set

-- | Print the answers to day 17
--
-- >>> :main
-- 38364
-- 30551
main :: IO ()
IO ()
main =
 do let toLine :: Either (Int, Int, Int) (Int, Int, Int) -> [Coord]
toLine (Left (Int
y, Int
xlo, Int
xhi)) = [Int -> Int -> Coord
C Int
y Int
x | Int
x <- [Int
xlo..Int
xhi]]
        toLine (Right (Int
x, Int
ylo, Int
yhi)) = [Int -> Int -> Coord
C Int
y Int
x | Int
y <- [Int
ylo..Int
yhi]]
    [Coord]
input <- (Either (Int, Int, Int) (Int, Int, Int) -> [Coord])
-> [Either (Int, Int, Int) (Int, Int, Int)] -> [Coord]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Either (Int, Int, Int) (Int, Int, Int) -> [Coord]
toLine ([Either (Int, Int, Int) (Int, Int, Int)] -> [Coord])
-> IO [Either (Int, Int, Int) (Int, Int, Int)] -> IO [Coord]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [format|2018 17 (y=%d, x=%d..%d%n|x=%d, y=%d..%d%n)*|]

    let walls :: UArray Coord Bool
walls = [Coord] -> UArray Coord Bool
toArray [Coord]
input
        frames :: [(UArray Coord Bool, Set Coord)]
frames = UArray Coord Bool -> [(UArray Coord Bool, Set Coord)]
fillSteps UArray Coord Bool
walls
        (UArray Coord Bool
walls', Set Coord
water) = [(UArray Coord Bool, Set Coord)] -> (UArray Coord Bool, Set Coord)
forall a. HasCallStack => [a] -> a
last [(UArray Coord Bool, Set Coord)]
frames

    let flowingN :: Int
flowingN  = Set Coord -> Int
forall a. Set a -> Int
Set.size Set Coord
water
        standingN :: Int
standingN = (Bool -> Bool) -> [Bool] -> Int
forall (f :: * -> *) a. Foldable f => (a -> Bool) -> f a -> Int
countBy Bool -> Bool
forall a. a -> a
id ((Bool -> Bool -> Bool) -> [Bool] -> [Bool] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
(/=) (UArray Coord Bool -> [Bool]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
A.elems UArray Coord Bool
walls) (UArray Coord Bool -> [Bool]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
A.elems UArray Coord Bool
walls'))

    Int -> IO ()
forall a. Show a => a -> IO ()
print (Int
flowingN Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
standingN)
    Int -> IO ()
forall a. Show a => a -> IO ()
print Int
standingN

-- clay walls and standing water representation ------------------------

-- | Walls are represented with a 'True' value in the array.
type Walls = A.UArray Coord Bool

isWall :: Walls -> Coord -> Bool
isWall :: UArray Coord Bool -> Coord -> Bool
isWall UArray Coord Bool
walls Coord
c = UArray Coord Bool -> Coord -> Bool
forall i (a :: * -> * -> *) e.
(Ix i, IArray a e) =>
a i e -> i -> Bool
inArray UArray Coord Bool
walls Coord
c Bool -> Bool -> Bool
&& UArray Coord Bool
walls UArray Coord Bool -> Coord -> Bool
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
A.! Coord
c

-- water flow logic ----------------------------------------------------

-- | Given some initial clay walls, generate the sequence of updated
-- walls (including standing water) and flowing water coordinates.
fillSteps :: Walls -> [(Walls, Set Coord)]
fillSteps :: UArray Coord Bool -> [(UArray Coord Bool, Set Coord)]
fillSteps UArray Coord Bool
walls = (UArray Coord Bool
walls, Map Coord Mode -> Set Coord
forall k a. Map k a -> Set k
Map.keysSet Map Coord Mode
water)
             (UArray Coord Bool, Set Coord)
-> [(UArray Coord Bool, Set Coord)]
-> [(UArray Coord Bool, Set Coord)]
forall a. a -> [a] -> [a]
: if [(Coord, Bool)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Coord, Bool)]
fills then [] else UArray Coord Bool -> [(UArray Coord Bool, Set Coord)]
fillSteps (UArray Coord Bool
walls UArray Coord Bool -> [(Coord, Bool)] -> UArray Coord Bool
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)] -> a i e
A.// [(Coord, Bool)]
fills)
  where
    water :: Map Coord Mode
water = UArray Coord Bool -> Map Coord Mode
waterflow UArray Coord Bool
walls

    fills :: [(Coord, Bool)]
fills = [(Int -> Int -> Coord
C Int
ly Int
x, Bool
True)
               | c :: Coord
c@(C Int
ly Int
lx) <- Map Coord Mode -> [Coord]
forall k a. Map k a -> [k]
Map.keys Map Coord Mode
water
               , UArray Coord Bool -> Coord -> Bool
isWall UArray Coord Bool
walls (Coord -> Coord
below Coord
c)
               , UArray Coord Bool -> Coord -> Bool
isWall UArray Coord Bool
walls (Coord -> Coord
left  Coord
c)
               , Coord
rightWall <- Coord -> [Coord]
isContained Coord
c
               , Int
x <- [Int
lx .. Coord -> Int
coordCol Coord
rightWall Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
               ]

    -- search to the right to see that the bottom extends out to a wall
    isContained :: Coord -> [Coord]
isContained Coord
c
      | UArray Coord Bool
walls UArray Coord Bool -> Coord -> Bool
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
A.! Coord
c       = [Coord
c]
      | UArray Coord Bool
walls UArray Coord Bool -> Coord -> Bool
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
A.! Coord -> Coord
below Coord
c = Coord -> [Coord]
isContained (Coord -> Coord
right Coord
c)
      | Bool
otherwise         = []

-- water flow logic ----------------------------------------------------

-- | Water flow mode. This optimization just keeps the water running
-- flat along a surface from trying to turn around back into itself.
data Mode = LookLeft | LookRight | LookDown
  deriving (Mode -> Mode -> Bool
(Mode -> Mode -> Bool) -> (Mode -> Mode -> Bool) -> Eq Mode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Mode -> Mode -> Bool
== :: Mode -> Mode -> Bool
$c/= :: Mode -> Mode -> Bool
/= :: Mode -> Mode -> Bool
Eq, Eq Mode
Eq Mode =>
(Mode -> Mode -> Ordering)
-> (Mode -> Mode -> Bool)
-> (Mode -> Mode -> Bool)
-> (Mode -> Mode -> Bool)
-> (Mode -> Mode -> Bool)
-> (Mode -> Mode -> Mode)
-> (Mode -> Mode -> Mode)
-> Ord Mode
Mode -> Mode -> Bool
Mode -> Mode -> Ordering
Mode -> Mode -> Mode
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Mode -> Mode -> Ordering
compare :: Mode -> Mode -> Ordering
$c< :: Mode -> Mode -> Bool
< :: Mode -> Mode -> Bool
$c<= :: Mode -> Mode -> Bool
<= :: Mode -> Mode -> Bool
$c> :: Mode -> Mode -> Bool
> :: Mode -> Mode -> Bool
$c>= :: Mode -> Mode -> Bool
>= :: Mode -> Mode -> Bool
$cmax :: Mode -> Mode -> Mode
max :: Mode -> Mode -> Mode
$cmin :: Mode -> Mode -> Mode
min :: Mode -> Mode -> Mode
Ord, Int -> Mode -> String -> String
[Mode] -> String -> String
Mode -> String
(Int -> Mode -> String -> String)
-> (Mode -> String) -> ([Mode] -> String -> String) -> Show Mode
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Mode -> String -> String
showsPrec :: Int -> Mode -> String -> String
$cshow :: Mode -> String
show :: Mode -> String
$cshowList :: [Mode] -> String -> String
showList :: [Mode] -> String -> String
Show)

waterflow :: Walls -> Map Coord Mode
waterflow :: UArray Coord Bool -> Map Coord Mode
waterflow UArray Coord Bool
walls = ((Coord, Mode) -> [(Coord, Mode)])
-> (Coord, Mode) -> Map Coord Mode
forall a b. Ord a => ((a, b) -> [(a, b)]) -> (a, b) -> Map a b
reachable (UArray Coord Bool -> (Coord, Mode) -> [(Coord, Mode)]
waterStep UArray Coord Bool
walls) (Int -> Int -> Coord
C Int
startY Int
500, Mode
LookDown)
  where
    startY :: Int
startY = Coord -> Int
coordRow ((Coord, Coord) -> Coord
forall a b. (a, b) -> a
fst (UArray Coord Bool -> (Coord, Coord)
forall i. Ix i => UArray i Bool -> (i, i)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
A.bounds UArray Coord Bool
walls))

-- | Given the current walls (including standing water), a water
-- coordinate, and the direction the water is flowing, generate
-- the neighboring water flows.
waterStep :: Walls -> (Coord, Mode) -> [(Coord, Mode)]
waterStep :: UArray Coord Bool -> (Coord, Mode) -> [(Coord, Mode)]
waterStep UArray Coord Bool
walls (Coord
c, Mode
mode)
  | Bool -> Bool
not (UArray Coord Bool -> Coord -> Bool
forall i (a :: * -> * -> *) e.
(Ix i, IArray a e) =>
a i e -> i -> Bool
inArray UArray Coord Bool
walls (Coord -> Coord
below Coord
c)) = []
  | Bool -> Bool
not (UArray Coord Bool
walls UArray Coord Bool -> Coord -> Bool
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
A.! Coord -> Coord
below Coord
c) = [ (Coord -> Coord
below Coord
c, Mode
LookDown) ]
  | Bool
otherwise = ((Coord, Mode) -> Bool) -> [(Coord, Mode)] -> [(Coord, Mode)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ((Coord, Mode) -> Bool) -> (Coord, Mode) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UArray Coord Bool -> Coord -> Bool
isWall UArray Coord Bool
walls (Coord -> Bool)
-> ((Coord, Mode) -> Coord) -> (Coord, Mode) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coord, Mode) -> Coord
forall a b. (a, b) -> a
fst)
              ([(Coord, Mode)] -> [(Coord, Mode)])
-> [(Coord, Mode)] -> [(Coord, Mode)]
forall a b. (a -> b) -> a -> b
$ [ (Coord -> Coord
left  Coord
c, Mode
LookLeft ) | Mode
mode Mode -> Mode -> Bool
forall a. Eq a => a -> a -> Bool
/= Mode
LookRight ]
             [(Coord, Mode)] -> [(Coord, Mode)] -> [(Coord, Mode)]
forall a. [a] -> [a] -> [a]
++ [ (Coord -> Coord
right Coord
c, Mode
LookRight) | Mode
mode Mode -> Mode -> Bool
forall a. Eq a => a -> a -> Bool
/= Mode
LookLeft  ]

-- searching -----------------------------------------------------------

-- | Given a function describing neighboring states find all of the
-- reachable state given a starting state. Each state is associated
-- with some metadata that comes from the first time that state was reached.
reachable :: Ord a => ((a,b) -> [(a,b)]) -> (a,b) -> Map a b
reachable :: forall a b. Ord a => ((a, b) -> [(a, b)]) -> (a, b) -> Map a b
reachable (a, b) -> [(a, b)]
next = Map a b -> (a, b) -> Map a b
aux Map a b
forall k a. Map k a
Map.empty
  where
    aux :: Map a b -> (a, b) -> Map a b
aux Map a b
seen (a
k,b
v)
      | a -> Map a b -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member a
k Map a b
seen = Map a b
seen
      | Bool
otherwise         = (Map a b -> (a, b) -> Map a b) -> Map a b -> [(a, b)] -> Map a b
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map a b -> (a, b) -> Map a b
aux (a -> b -> Map a b -> Map a b
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert a
k b
v Map a b
seen) ((a, b) -> [(a, b)]
next (a
k,b
v))

-- array helpers -------------------------------------------------------

-- | Test if an index is contained within an array.
inArray :: (Ix i, IArray a e) => a i e -> i -> Bool
inArray :: forall i (a :: * -> * -> *) e.
(Ix i, IArray a e) =>
a i e -> i -> Bool
inArray = (i, i) -> i -> Bool
forall a. Ix a => (a, a) -> a -> Bool
A.inRange ((i, i) -> i -> Bool) -> (a i e -> (i, i)) -> a i e -> i -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a i e -> (i, i)
forall i. Ix i => a i e -> (i, i)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
A.bounds

-- | Convert a list of coordinates into an array marked 'True' for the
-- listed coordinates.
toArray :: [Coord] -> A.UArray Coord Bool
toArray :: [Coord] -> UArray Coord Bool
toArray [Coord]
xs = (Bool -> Bool -> Bool)
-> Bool -> (Coord, Coord) -> [(Coord, Bool)] -> UArray Coord Bool
forall (a :: * -> * -> *) e i e'.
(IArray a e, Ix i) =>
(e -> e' -> e) -> e -> (i, i) -> [(i, e')] -> a i e
A.accumArray (\Bool
_ Bool
e -> Bool
e) Bool
False (Int -> Int -> Coord
C Int
miny Int
minx, Int -> Int -> Coord
C Int
maxy Int
maxx)
                        [ (Coord
xy, Bool
True) | Coord
xy <- [Coord]
xs ]
  where
    miny :: Int
miny = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ((Coord -> Int) -> [Coord] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Coord -> Int
coordRow [Coord]
xs)
    maxy :: Int
maxy = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((Coord -> Int) -> [Coord] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Coord -> Int
coordRow [Coord]
xs)
    minx :: Int
minx = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ((Coord -> Int) -> [Coord] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Coord -> Int
coordCol [Coord]
xs) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
    maxx :: Int
maxx = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((Coord -> Int) -> [Coord] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Coord -> Int
coordCol [Coord]
xs) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1