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

<https://adventofcode.com/2016/day/11>

-}
module Main (main) where

import Control.Lens
import Data.Bits
import Data.List
import Data.Maybe
import Advent.Search (bfsOn)
import Advent.SmallSet (SmallSet)
import Advent.SmallSet qualified as SBS

-- Types ---------------------------------------------------------------

data Floor = Floor !SmallSet !SmallSet -- ^ gen micro
  deriving (Floor -> Floor -> Bool
(Floor -> Floor -> Bool) -> (Floor -> Floor -> Bool) -> Eq Floor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Floor -> Floor -> Bool
== :: Floor -> Floor -> Bool
$c/= :: Floor -> Floor -> Bool
/= :: Floor -> Floor -> Bool
Eq, Eq Floor
Eq Floor =>
(Floor -> Floor -> Ordering)
-> (Floor -> Floor -> Bool)
-> (Floor -> Floor -> Bool)
-> (Floor -> Floor -> Bool)
-> (Floor -> Floor -> Bool)
-> (Floor -> Floor -> Floor)
-> (Floor -> Floor -> Floor)
-> Ord Floor
Floor -> Floor -> Bool
Floor -> Floor -> Ordering
Floor -> Floor -> Floor
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 :: Floor -> Floor -> Ordering
compare :: Floor -> Floor -> Ordering
$c< :: Floor -> Floor -> Bool
< :: Floor -> Floor -> Bool
$c<= :: Floor -> Floor -> Bool
<= :: Floor -> Floor -> Bool
$c> :: Floor -> Floor -> Bool
> :: Floor -> Floor -> Bool
$c>= :: Floor -> Floor -> Bool
>= :: Floor -> Floor -> Bool
$cmax :: Floor -> Floor -> Floor
max :: Floor -> Floor -> Floor
$cmin :: Floor -> Floor -> Floor
min :: Floor -> Floor -> Floor
Ord, Int -> Floor -> ShowS
[Floor] -> ShowS
Floor -> String
(Int -> Floor -> ShowS)
-> (Floor -> String) -> ([Floor] -> ShowS) -> Show Floor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Floor -> ShowS
showsPrec :: Int -> Floor -> ShowS
$cshow :: Floor -> String
show :: Floor -> String
$cshowList :: [Floor] -> ShowS
showList :: [Floor] -> ShowS
Show)

data Building = Building
  { Building -> Int
_bldgSteps    :: !Int
  , Building -> [Floor]
_lowerFloors  :: [Floor]
  , Building -> Floor
_currentFloor :: {-# UNPACK #-} !Floor
  , Building -> [Floor]
_higherFloors :: [Floor]
  }
  deriving Int -> Building -> ShowS
[Building] -> ShowS
Building -> String
(Int -> Building -> ShowS)
-> (Building -> String) -> ([Building] -> ShowS) -> Show Building
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Building -> ShowS
showsPrec :: Int -> Building -> ShowS
$cshow :: Building -> String
show :: Building -> String
$cshowList :: [Building] -> ShowS
showList :: [Building] -> ShowS
Show

makeLenses ''Building

-- Main logic and parameters -------------------------------------------

main :: IO ()
IO ()
main =
  do Maybe Int -> IO ()
forall a. Show a => a -> IO ()
print (Building -> Maybe Int
solutionSteps Building
part1)
     Maybe Int -> IO ()
forall a. Show a => a -> IO ()
print (Building -> Maybe Int
solutionSteps Building
part2)

part1 :: Building
part1 :: Building
part1 = Int -> [Floor] -> Floor -> [Floor] -> Building
Building Int
0 [] ( [Int] -> [Int] -> Floor
mkFloor [Int
0] [Int
0])
                      [ [Int] -> [Int] -> Floor
mkFloor [Int
1..Int
4] []
                      , [Int] -> [Int] -> Floor
mkFloor [] [Int
1..Int
4]
                      , [Int] -> [Int] -> Floor
mkFloor [] [] ]

part2 :: Building
part2 :: Building
part2 = Int -> [Floor] -> Floor -> [Floor] -> Building
Building Int
0 [] ( [Int] -> [Int] -> Floor
mkFloor [Int
0..Int
2] [Int
0..Int
2])
                      [ [Int] -> [Int] -> Floor
mkFloor [Int
3..Int
6] []
                      , [Int] -> [Int] -> Floor
mkFloor [] [Int
3..Int
6]
                      , [Int] -> [Int] -> Floor
mkFloor [] [] ]

solutionSteps :: Building -> Maybe Int
solutionSteps :: Building -> Maybe Int
solutionSteps Building
b =
  [Int] -> Maybe Int
forall a. [a] -> Maybe a
listToMaybe [ Building
b'Building -> Getting Int Building Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int Building Int
Lens' Building Int
bldgSteps | Building
b' <- (Building -> Int)
-> (Building -> [Building]) -> Building -> [Building]
forall r a. Ord r => (a -> r) -> (a -> [a]) -> a -> [a]
bfsOn Building -> Int
mkRep Building -> [Building]
advanceBuilding Building
b
                              , Building -> Bool
isSolved Building
b' ]

--Floor operations -----------------------------------------------------

mkFloor :: [Int] -> [Int] -> Floor
mkFloor :: [Int] -> [Int] -> Floor
mkFloor [Int]
xs [Int]
ys = SmallSet -> SmallSet -> Floor
Floor ([Int] -> SmallSet
SBS.fromList [Int]
xs) ([Int] -> SmallSet
SBS.fromList [Int]
ys)

isEmptyFloor :: Floor -> Bool
isEmptyFloor :: Floor -> Bool
isEmptyFloor (Floor SmallSet
x SmallSet
y) = SmallSet -> Bool
SBS.null SmallSet
x Bool -> Bool -> Bool
&& SmallSet -> Bool
SBS.null SmallSet
y

isValidFloor :: Floor -> Bool
isValidFloor :: Floor -> Bool
isValidFloor (Floor SmallSet
gens SmallSet
mics) = SmallSet -> Bool
SBS.null SmallSet
gens Bool -> Bool -> Bool
|| SmallSet -> Bool
SBS.null (SmallSet
mics SmallSet -> SmallSet -> SmallSet
SBS.\\ SmallSet
gens)

floorUnion :: Floor -> Floor -> Floor
floorUnion :: Floor -> Floor -> Floor
floorUnion (Floor SmallSet
x SmallSet
y) (Floor SmallSet
u SmallSet
v) = SmallSet -> SmallSet -> Floor
Floor (SmallSet -> SmallSet -> SmallSet
SBS.union SmallSet
x SmallSet
u) (SmallSet -> SmallSet -> SmallSet
SBS.union SmallSet
y SmallSet
v)

floorDifference :: Floor -> Floor -> Floor
floorDifference :: Floor -> Floor -> Floor
floorDifference (Floor SmallSet
x SmallSet
y) (Floor SmallSet
u SmallSet
v) = SmallSet -> SmallSet -> Floor
Floor (SmallSet
x SmallSet -> SmallSet -> SmallSet
SBS.\\ SmallSet
u) (SmallSet
y SmallSet -> SmallSet -> SmallSet
SBS.\\ SmallSet
v)

pickFromFloor :: Floor -> [Floor]
pickFromFloor :: Floor -> [Floor]
pickFromFloor (Floor SmallSet
gs SmallSet
ms) = [Floor]
pair [Floor] -> [Floor] -> [Floor]
forall a. [a] -> [a] -> [a]
++ [Floor]
twoGens [Floor] -> [Floor] -> [Floor]
forall a. [a] -> [a] -> [a]
++ [Floor]
twoMics [Floor] -> [Floor] -> [Floor]
forall a. [a] -> [a] -> [a]
++ [Floor]
oneGen [Floor] -> [Floor] -> [Floor]
forall a. [a] -> [a] -> [a]
++ [Floor]
oneMic
  where
    gens :: [Int]
gens = SmallSet -> [Int]
SBS.toList SmallSet
gs
    mics :: [Int]
mics = SmallSet -> [Int]
SBS.toList SmallSet
ms
    twoGens :: [Floor]
twoGens = do SmallSet
xs <- [Int] -> SmallSet
SBS.fromList ([Int] -> SmallSet) -> [[Int]] -> [SmallSet]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int] -> [[Int]]
forall a. [a] -> [[a]]
pick2 [Int]
gens
                 Floor -> [Floor]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Floor -> [Floor]) -> Floor -> [Floor]
forall a b. (a -> b) -> a -> b
$! SmallSet -> SmallSet -> Floor
Floor SmallSet
xs SmallSet
SBS.empty
    twoMics :: [Floor]
twoMics = do SmallSet
xs <- [Int] -> SmallSet
SBS.fromList ([Int] -> SmallSet) -> [[Int]] -> [SmallSet]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int] -> [[Int]]
forall a. [a] -> [[a]]
pick2 [Int]
mics
                 Floor -> [Floor]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Floor -> [Floor]) -> Floor -> [Floor]
forall a b. (a -> b) -> a -> b
$! SmallSet -> SmallSet -> Floor
Floor SmallSet
SBS.empty SmallSet
xs
    pair :: [Floor]
pair    = do SmallSet
x <- Int -> SmallSet
SBS.singleton (Int -> SmallSet) -> [Int] -> [SmallSet]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                        Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
1 (SmallSet -> [Int]
SBS.toList (SmallSet -> SmallSet -> SmallSet
SBS.intersection SmallSet
gs SmallSet
ms))
                 Floor -> [Floor]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Floor -> [Floor]) -> Floor -> [Floor]
forall a b. (a -> b) -> a -> b
$! SmallSet -> SmallSet -> Floor
Floor SmallSet
x SmallSet
x
    oneGen :: [Floor]
oneGen  = do SmallSet
x <- Int -> SmallSet
SBS.singleton (Int -> SmallSet) -> [Int] -> [SmallSet]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int]
gens
                 Floor -> [Floor]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Floor -> [Floor]) -> Floor -> [Floor]
forall a b. (a -> b) -> a -> b
$! SmallSet -> SmallSet -> Floor
Floor SmallSet
x SmallSet
SBS.empty
    oneMic :: [Floor]
oneMic  = do SmallSet
x <- Int -> SmallSet
SBS.singleton (Int -> SmallSet) -> [Int] -> [SmallSet]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int]
mics
                 Floor -> [Floor]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Floor -> [Floor]) -> Floor -> [Floor]
forall a b. (a -> b) -> a -> b
$! SmallSet -> SmallSet -> Floor
Floor SmallSet
SBS.empty SmallSet
x

pick2 :: [a] -> [[a]]
pick2 :: forall a. [a] -> [[a]]
pick2 [a]
xs = [ [a
x,a
y] | a
x:[a]
ys <- [a] -> [[a]]
forall a. [a] -> [[a]]
tails [a]
xs, a
y <- [a]
ys ]

floorRep :: Floor -> Int
floorRep :: Floor -> Int
floorRep (Floor SmallSet
gens SmallSet
mics) =
  Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (SmallSet -> Word64
SBS.setRep SmallSet
gens Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL`  Int
7 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|.  SmallSet -> Word64
SBS.setRep SmallSet
mics)

-- Building operations -------------------------------------------------

isSolved :: Building -> Bool
isSolved :: Building -> Bool
isSolved Building
b = [Floor] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Building
bBuilding -> Getting [Floor] Building [Floor] -> [Floor]
forall s a. s -> Getting a s a -> a
^.Getting [Floor] Building [Floor]
Lens' Building [Floor]
higherFloors) Bool -> Bool -> Bool
&& (Floor -> Bool) -> [Floor] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Floor -> Bool
isEmptyFloor (Building
bBuilding -> Getting [Floor] Building [Floor] -> [Floor]
forall s a. s -> Getting a s a -> a
^.Getting [Floor] Building [Floor]
Lens' Building [Floor]
lowerFloors)

advanceBuilding :: Building -> [Building]
advanceBuilding :: Building -> [Building]
advanceBuilding Building
b =
  [ Building
b3 Building -> (Building -> Building) -> Building
forall a b. a -> (a -> b) -> b
& (Int -> Identity Int) -> Building -> Identity Building
Lens' Building Int
bldgSteps ((Int -> Identity Int) -> Building -> Identity Building)
-> Int -> Building -> Building
forall a s t. Num a => ASetter s t a a -> a -> s -> t
+~ Int
1
       | Floor
subset <- Floor -> [Floor]
pickFromFloor (Building
bBuilding -> Getting Floor Building Floor -> Floor
forall s a. s -> Getting a s a -> a
^.Getting Floor Building Floor
Lens' Building Floor
currentFloor)
       , Building
b1     <- (Floor -> Floor) -> Building -> [Building]
updateCurrentFloor (Floor -> Floor -> Floor
`floorDifference` Floor
subset) Building
b
       , Building
b2     <- ReifiedLens' Building [Floor]
-> ReifiedLens' Building [Floor] -> Building -> [Building]
move (Lens' Building [Floor] -> ReifiedLens' Building [Floor]
forall s t a b. Lens s t a b -> ReifiedLens s t a b
Lens ([Floor] -> f [Floor]) -> Building -> f Building
Lens' Building [Floor]
lowerFloors) (Lens' Building [Floor] -> ReifiedLens' Building [Floor]
forall s t a b. Lens s t a b -> ReifiedLens s t a b
Lens ([Floor] -> f [Floor]) -> Building -> f Building
Lens' Building [Floor]
higherFloors) Building
b1
                [Building] -> [Building] -> [Building]
forall a. [a] -> [a] -> [a]
++ ReifiedLens' Building [Floor]
-> ReifiedLens' Building [Floor] -> Building -> [Building]
move (Lens' Building [Floor] -> ReifiedLens' Building [Floor]
forall s t a b. Lens s t a b -> ReifiedLens s t a b
Lens ([Floor] -> f [Floor]) -> Building -> f Building
Lens' Building [Floor]
higherFloors) (Lens' Building [Floor] -> ReifiedLens' Building [Floor]
forall s t a b. Lens s t a b -> ReifiedLens s t a b
Lens ([Floor] -> f [Floor]) -> Building -> f Building
Lens' Building [Floor]
lowerFloors) Building
b1
       , Building
b3     <- (Floor -> Floor) -> Building -> [Building]
updateCurrentFloor (Floor -> Floor -> Floor
floorUnion Floor
subset) Building
b2
       ]

updateCurrentFloor :: (Floor -> Floor) -> Building -> [Building]
updateCurrentFloor :: (Floor -> Floor) -> Building -> [Building]
updateCurrentFloor Floor -> Floor
f Building
b =
  [ Building
b' | let (Floor
fl',Building
b') = Building
b Building -> (Building -> (Floor, Building)) -> (Floor, Building)
forall a b. a -> (a -> b) -> b
& (Floor -> (Floor, Floor)) -> Building -> (Floor, Building)
Lens' Building Floor
currentFloor ((Floor -> (Floor, Floor)) -> Building -> (Floor, Building))
-> (Floor -> Floor) -> Building -> (Floor, Building)
forall b s t a. LensLike ((,) b) s t a b -> (a -> b) -> s -> (b, t)
<%~ Floor -> Floor
f, Floor -> Bool
isValidFloor Floor
fl' ]

{-# INLINE move #-}
move ::
  ReifiedLens' Building [Floor] ->
  ReifiedLens' Building [Floor] ->
  Building ->
  [Building]
move :: ReifiedLens' Building [Floor]
-> ReifiedLens' Building [Floor] -> Building -> [Building]
move (Lens Lens' Building [Floor]
back) (Lens Lens' Building [Floor]
front) Building
b =
  [ Building
b Building -> (Building -> Building) -> Building
forall a b. a -> (a -> b) -> b
& ([Floor] -> Identity [Floor]) -> Building -> Identity Building
Lens' Building [Floor]
back         (([Floor] -> Identity [Floor]) -> Building -> Identity Building)
-> ([Floor] -> [Floor]) -> Building -> Building
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Floor -> [Floor] -> [Floor]
forall s a. Cons s s a a => a -> s -> s
cons (Building
bBuilding -> Getting Floor Building Floor -> Floor
forall s a. s -> Getting a s a -> a
^.Getting Floor Building Floor
Lens' Building Floor
currentFloor)
      Building -> (Building -> Building) -> Building
forall a b. a -> (a -> b) -> b
& (Floor -> Identity Floor) -> Building -> Identity Building
Lens' Building Floor
currentFloor ((Floor -> Identity Floor) -> Building -> Identity Building)
-> Floor -> Building -> Building
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Floor
x
      Building -> (Building -> Building) -> Building
forall a b. a -> (a -> b) -> b
& ([Floor] -> Identity [Floor]) -> Building -> Identity Building
Lens' Building [Floor]
front        (([Floor] -> Identity [Floor]) -> Building -> Identity Building)
-> [Floor] -> Building -> Building
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Floor]
xs
  | Floor
x:[Floor]
xs <- [ Building
bBuilding -> Getting [Floor] Building [Floor] -> [Floor]
forall s a. s -> Getting a s a -> a
^.Getting [Floor] Building [Floor]
Lens' Building [Floor]
front ]
  ]

-- | Characterize a 4-floor building with up to 7 generator/chip pairs
mkRep :: Building -> Int
mkRep :: Building -> Int
mkRep (Building Int
_ [Floor]
x Floor
_ [Floor]
z) = (Int -> Floor -> Int) -> Int -> [Floor] -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Int -> Floor -> Int
aux ([Floor] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Floor]
x) ([Floor]
x [Floor] -> [Floor] -> [Floor]
forall a. [a] -> [a] -> [a]
++ [Floor]
z)
  where
    aux :: Int -> Floor -> Int
aux Int
acc Floor
fl = Int
acc Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
14 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Floor -> Int
floorRep Floor
fl