{-# Language KindSignatures, GADTs, DataKinds, ParallelListComp, BlockArguments, TemplateHaskell, ImportQualifiedPost, QuasiQuotes #-}
{-|
Module      : Main
Description : Day 22 solution
Copyright   : (c) Eric Mertens, 2021
License     : ISC
Maintainer  : emertens@gmail.com

<https://adventofcode.com/2021/day/22>

This problem is made simple by processing commands
by subtracting away all future cuboids. Only the region
unique to the current command will affect the final output.

-}
module Main (main) where

import Advent.Format (format)
import Control.Monad.Trans.Writer.CPS (runWriterT, writerT, WriterT)
import Data.Kind (Type)
import Data.Maybe (isNothing, mapMaybe)
import Data.Monoid (All(All))

-- | On and off commands from the input file
data C = Con | Coff
  deriving (Int -> C -> ShowS
[C] -> ShowS
C -> String
(Int -> C -> ShowS) -> (C -> String) -> ([C] -> ShowS) -> Show C
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [C] -> ShowS
$cshowList :: [C] -> ShowS
show :: C -> String
$cshow :: C -> String
showsPrec :: Int -> C -> ShowS
$cshowsPrec :: Int -> C -> ShowS
Show, C -> C -> Bool
(C -> C -> Bool) -> (C -> C -> Bool) -> Eq C
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: C -> C -> Bool
$c/= :: C -> C -> Bool
== :: C -> C -> Bool
$c== :: C -> C -> Bool
Eq, Eq C
Eq C
-> (C -> C -> Ordering)
-> (C -> C -> Bool)
-> (C -> C -> Bool)
-> (C -> C -> Bool)
-> (C -> C -> Bool)
-> (C -> C -> C)
-> (C -> C -> C)
-> Ord C
C -> C -> Bool
C -> C -> Ordering
C -> C -> C
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
min :: C -> C -> C
$cmin :: C -> C -> C
max :: C -> C -> C
$cmax :: C -> C -> C
>= :: C -> C -> Bool
$c>= :: C -> C -> Bool
> :: C -> C -> Bool
$c> :: C -> C -> Bool
<= :: C -> C -> Bool
$c<= :: C -> C -> Bool
< :: C -> C -> Bool
$c< :: C -> C -> Bool
compare :: C -> C -> Ordering
$ccompare :: C -> C -> Ordering
Ord)

mempty -- template haskell staging

-- | >>> :main
-- 606484
-- 1162571910364852
main :: IO ()
main :: IO ()
main =
 do [(C, Int, Int, Int, Int, Int, Int)]
inp <- [format|22 (@C x=%d..%d,y=%d..%d,z=%d..%d%n)*|]
    let seg :: Int -> Int -> Seg
seg Int
lo Int
hi = Int -> Int -> Seg
Seg Int
lo (Int
hiInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) -- make upper limit exclusive
        steps :: [(C, Box ('S ('S ('S 'Z))))]
steps = [ (C
c, Int -> Int -> Seg
seg Int
x1 Int
x2 Seg -> Box ('S ('S 'Z)) -> Box ('S ('S ('S 'Z)))
forall (n :: N). Seg -> Box n -> Box ('S n)
:* Int -> Int -> Seg
seg Int
y1 Int
y2 Seg -> Box ('S 'Z) -> Box ('S ('S 'Z))
forall (n :: N). Seg -> Box n -> Box ('S n)
:* Int -> Int -> Seg
seg Int
z1 Int
z2 Seg -> Box 'Z -> Box ('S 'Z)
forall (n :: N). Seg -> Box n -> Box ('S n)
:* Box 'Z
Pt)
                | (C
c, Int
x1, Int
x2, Int
y1, Int
y2, Int
z1, Int
z2) <- [(C, Int, Int, Int, Int, Int, Int)]
inp]
        p1seg :: Seg
p1seg = Int -> Int -> Seg
seg (-Int
50) Int
50
        p1cube :: Box ('S ('S ('S 'Z)))
p1cube = Seg
p1seg Seg -> Box ('S ('S 'Z)) -> Box ('S ('S ('S 'Z)))
forall (n :: N). Seg -> Box n -> Box ('S n)
:* Seg
p1seg Seg -> Box ('S 'Z) -> Box ('S ('S 'Z))
forall (n :: N). Seg -> Box n -> Box ('S n)
:* Seg
p1seg Seg -> Box 'Z -> Box ('S 'Z)
forall (n :: N). Seg -> Box n -> Box ('S n)
:* Box 'Z
Pt
    Int -> IO ()
forall a. Show a => a -> IO ()
print ([(C, Box ('S ('S ('S 'Z))))] -> Int
forall (n :: N). [(C, Box n)] -> Int
solve (((C, Box ('S ('S ('S 'Z)))) -> Maybe (C, Box ('S ('S ('S 'Z)))))
-> [(C, Box ('S ('S ('S 'Z))))] -> [(C, Box ('S ('S ('S 'Z))))]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Box ('S ('S ('S 'Z))) -> Maybe (Box ('S ('S ('S 'Z)))))
-> (C, Box ('S ('S ('S 'Z)))) -> Maybe (C, Box ('S ('S ('S 'Z))))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Box ('S ('S ('S 'Z)))
-> Box ('S ('S ('S 'Z))) -> Maybe (Box ('S ('S ('S 'Z))))
forall (n :: N). Box n -> Box n -> Maybe (Box n)
intersectBox Box ('S ('S ('S 'Z)))
p1cube)) [(C, Box ('S ('S ('S 'Z))))]
steps))
    Int -> IO ()
forall a. Show a => a -> IO ()
print ([(C, Box ('S ('S ('S 'Z))))] -> Int
forall (n :: N). [(C, Box n)] -> Int
solve [(C, Box ('S ('S ('S 'Z))))]
steps)

-- | Figure out how many lights the given instructions turn on.
solve :: [(C, Box n)] -> Int
solve :: forall (n :: N). [(C, Box n)] -> Int
solve = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> ([(C, Box n)] -> [Int]) -> [(C, Box n)] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Box n -> Int) -> [Box n] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Box n -> Int
forall (n :: N). Box n -> Int
size ([Box n] -> [Int])
-> ([(C, Box n)] -> [Box n]) -> [(C, Box n)] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Box n] -> (C, Box n) -> [Box n])
-> [Box n] -> [(C, Box n)] -> [Box n]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [Box n] -> (C, Box n) -> [Box n]
forall (n :: N). [Box n] -> (C, Box n) -> [Box n]
applyCommand []

-- | Apply a command given a list of non-overlapping, illuminated regions.
applyCommand ::
  [Box n]    {- ^ pre-lit boxes  -} ->
  (C, Box n) {- ^ command        -} ->
  [Box n]    {- ^ post-lit boxes -}
applyCommand :: forall (n :: N). [Box n] -> (C, Box n) -> [Box n]
applyCommand [Box n]
ons (C
c, Box n
b) = [Box n
b | C
Con C -> C -> Bool
forall a. Eq a => a -> a -> Bool
== C
c] [Box n] -> [Box n] -> [Box n]
forall a. [a] -> [a] -> [a]
++ (Box n -> [Box n]) -> [Box n] -> [Box n]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Box n -> Box n -> [Box n]
forall (n :: N). Box n -> Box n -> [Box n]
subBox Box n
b) [Box n]
ons

-- * Segments

-- | A segment defined by an inclusive lower-bound and an exclusive upper-bound.
data Seg = Seg !Int !Int deriving (Seg -> Seg -> Bool
(Seg -> Seg -> Bool) -> (Seg -> Seg -> Bool) -> Eq Seg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Seg -> Seg -> Bool
$c/= :: Seg -> Seg -> Bool
== :: Seg -> Seg -> Bool
$c== :: Seg -> Seg -> Bool
Eq, Eq Seg
Eq Seg
-> (Seg -> Seg -> Ordering)
-> (Seg -> Seg -> Bool)
-> (Seg -> Seg -> Bool)
-> (Seg -> Seg -> Bool)
-> (Seg -> Seg -> Bool)
-> (Seg -> Seg -> Seg)
-> (Seg -> Seg -> Seg)
-> Ord Seg
Seg -> Seg -> Bool
Seg -> Seg -> Ordering
Seg -> Seg -> Seg
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
min :: Seg -> Seg -> Seg
$cmin :: Seg -> Seg -> Seg
max :: Seg -> Seg -> Seg
$cmax :: Seg -> Seg -> Seg
>= :: Seg -> Seg -> Bool
$c>= :: Seg -> Seg -> Bool
> :: Seg -> Seg -> Bool
$c> :: Seg -> Seg -> Bool
<= :: Seg -> Seg -> Bool
$c<= :: Seg -> Seg -> Bool
< :: Seg -> Seg -> Bool
$c< :: Seg -> Seg -> Bool
compare :: Seg -> Seg -> Ordering
$ccompare :: Seg -> Seg -> Ordering
Ord, Int -> Seg -> ShowS
[Seg] -> ShowS
Seg -> String
(Int -> Seg -> ShowS)
-> (Seg -> String) -> ([Seg] -> ShowS) -> Show Seg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Seg] -> ShowS
$cshowList :: [Seg] -> ShowS
show :: Seg -> String
$cshow :: Seg -> String
showsPrec :: Int -> Seg -> ShowS
$cshowsPrec :: Int -> Seg -> ShowS
Show)

-- | Compute the length of a segment
len :: Seg -> Int
len :: Seg -> Int
len (Seg Int
lo Int
hi) = Int
hi Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
lo

-- | Determine if two segments have some overlap
intersectSeg :: Seg -> Seg -> Maybe Seg
intersectSeg :: Seg -> Seg -> Maybe Seg
intersectSeg (Seg Int
alo Int
ahi) (Seg Int
blo Int
bhi)
  | Int
lo Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
hi = Seg -> Maybe Seg
forall a. a -> Maybe a
Just (Int -> Int -> Seg
Seg Int
lo Int
hi)
  | Bool
otherwise = Maybe Seg
forall a. Maybe a
Nothing
  where
    lo :: Int
lo = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
alo Int
blo
    hi :: Int
hi = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
ahi Int
bhi

-- | Determine if a value falls within a segment.
inSeg :: Int -> Seg -> Bool
inSeg :: Int -> Seg -> Bool
inSeg Int
x (Seg Int
lo Int
hi) = Int
lo Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
x Bool -> Bool -> Bool
&& Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
hi

-- * N-dimensional boxes

-- | Natural numbers (used for type index)
data N = S N | Z

-- | An n-dimensional box.
data Box :: N -> Type where
  Pt   :: Box 'Z -- ^ A single point
  (:*) :: Seg -> Box n -> Box ('S n) -- ^ A box extended along an axis

infixr 6 :* -- a little higher than list cons

instance Show (Box n) where
  showsPrec :: Int -> Box n -> ShowS
showsPrec Int
_ Box n
Pt = String -> ShowS
showString String
"Pt"
  showsPrec Int
p (Seg
x :* Box n
xs) = Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
6) (Seg -> ShowS
forall a. Show a => a -> ShowS
shows Seg
x ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" :* " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Box n -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
6 Box n
xs)

-- | Returns the number of points contained in a box.
--
-- >>> size (Seg 1 4 :* Seg 0 3 :* Seg 0 2 :* Pt)
-- 18
size :: Box n -> Int
size :: forall (n :: N). Box n -> Int
size Box n
Pt         = Int
1
size (Seg
s :* Box n
box) = Seg -> Int
len Seg
s Int -> Int -> Int
forall a. Num a => a -> a -> a
* Box n -> Int
forall (n :: N). Box n -> Int
size Box n
box

-- | The intersection of two boxes is the intersection of their segments.
intersectBox :: Box n -> Box n -> Maybe (Box n)
intersectBox :: forall (n :: N). Box n -> Box n -> Maybe (Box n)
intersectBox = (Seg -> Seg -> Maybe Seg) -> Box n -> Box n -> Maybe (Box n)
forall (f :: * -> *) (n :: N).
Applicative f =>
(Seg -> Seg -> f Seg) -> Box n -> Box n -> f (Box n)
traverseBox2 Seg -> Seg -> Maybe Seg
intersectSeg

-- | Subtract the second box from the first box returning a list of boxes
-- that cover all the remaining area.
--
-- >>> subBox (Seg 2 3 :* Pt) (Seg 0 4 :* Pt)
-- [Seg 0 2 :* Pt,Seg 3 4 :* Pt]
--
-- >>> subBox (Seg 3 5 :* Pt) (Seg 0 4 :* Pt)
-- [Seg 0 3 :* Pt]
subBox ::
  Box n {- ^ remove this -} ->
  Box n {- ^ from this -} ->
  [Box n]
subBox :: forall (n :: N). Box n -> Box n -> [Box n]
subBox Box n
b1 Box n
b2
  | Maybe (Box n) -> Bool
forall a. Maybe a -> Bool
isNothing (Box n -> Box n -> Maybe (Box n)
forall (n :: N). Box n -> Box n -> Maybe (Box n)
intersectBox Box n
b1 Box n
b2) = [Box n
b2]
  | Bool
otherwise = [Box n
b | (Box n
b, All Bool
False) <- WriterT All [] (Box n) -> [(Box n, All)]
forall w (m :: * -> *) a. Monoid w => WriterT w m a -> m (a, w)
runWriterT ((Seg -> Seg -> WriterT All [] Seg)
-> Box n -> Box n -> WriterT All [] (Box n)
forall (f :: * -> *) (n :: N).
Applicative f =>
(Seg -> Seg -> f Seg) -> Box n -> Box n -> f (Box n)
traverseBox2 Seg -> Seg -> WriterT All [] Seg
segs Box n
b1 Box n
b2)]
  where
    segs :: Seg -> Seg -> WriterT All [] Seg
segs s1 :: Seg
s1@(Seg Int
a Int
b) s2 :: Seg
s2@(Seg Int
c Int
d) =
      [(Seg, All)] -> WriterT All [] Seg
forall (m :: * -> *) w a.
(Functor m, Monoid w) =>
m (a, w) -> WriterT w m a
writerT [(Int -> Int -> Seg
Seg Int
lo Int
hi, Bool -> All
All (Int
lo Int -> Seg -> Bool
`inSeg` Seg
s1)) | Int
lo <- [Int]
xs | Int
hi <- [Int] -> [Int]
forall a. [a] -> [a]
tail [Int]
xs]
      where
        xs :: [Int]
xs = [Int
c] [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
a | Int
a Int -> Seg -> Bool
`inSeg` Seg
s2] [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
b | Int
b Int -> Seg -> Bool
`inSeg` Seg
s2] [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
d]

-- | Zip two boxes together.
traverseBox2 :: Applicative f => (Seg -> Seg -> f Seg) -> Box n -> Box n -> f (Box n)
traverseBox2 :: forall (f :: * -> *) (n :: N).
Applicative f =>
(Seg -> Seg -> f Seg) -> Box n -> Box n -> f (Box n)
traverseBox2 Seg -> Seg -> f Seg
f (Seg
x :* Box n
xs) (Seg
y :* Box n
ys) = Seg -> Box n -> Box ('S n)
forall (n :: N). Seg -> Box n -> Box ('S n)
(:*) (Seg -> Box n -> Box ('S n)) -> f Seg -> f (Box n -> Box ('S n))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seg -> Seg -> f Seg
f Seg
x Seg
y f (Box n -> Box ('S n)) -> f (Box n) -> f (Box ('S n))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Seg -> Seg -> f Seg) -> Box n -> Box n -> f (Box n)
forall (f :: * -> *) (n :: N).
Applicative f =>
(Seg -> Seg -> f Seg) -> Box n -> Box n -> f (Box n)
traverseBox2 Seg -> Seg -> f Seg
f Box n
xs Box n
Box n
ys
traverseBox2 Seg -> Seg -> f Seg
_ Box n
Pt        Box n
Pt        = Box 'Z -> f (Box 'Z)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Box 'Z
Pt