{-# LANGUAGE OverloadedStrings        #-}

-- |
-- Module      : AOC.Challenge.Day14
-- License     : BSD3
--
-- Stability   : experimental
-- Portability : non-portable
--
-- Day 14.  See "AOC.Solver" for the types used in this module!

module AOC.Challenge.Day14 (
    day14a
  , day14b
  ) where

import           AOC.Common                 (CharParser, parseLines)
import           AOC.Solver                 ((:~>)(..))
import           Control.DeepSeq            (NFData)
import           Control.Lens.Indexed       (ifoldlM, ifoldl')
import           Data.Bits                  (setBit, clearBit)
import           Data.Functor               (void)
import           Data.IntMap                (IntMap)
import           Data.List                  (foldl')
import           GHC.Generics               (Generic)
import qualified Data.IntMap                as IM
import qualified Text.Megaparsec            as P
import qualified Text.Megaparsec.Char       as P
import qualified Text.Megaparsec.Char.Lexer as PP

data Instr =
      Mask [Maybe Bool]
    | Write Int Int
  deriving (Int -> Instr -> ShowS
[Instr] -> ShowS
Instr -> String
(Int -> Instr -> ShowS)
-> (Instr -> String) -> ([Instr] -> ShowS) -> Show Instr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Instr] -> ShowS
$cshowList :: [Instr] -> ShowS
show :: Instr -> String
$cshow :: Instr -> String
showsPrec :: Int -> Instr -> ShowS
$cshowsPrec :: Int -> Instr -> ShowS
Show, Instr -> Instr -> Bool
(Instr -> Instr -> Bool) -> (Instr -> Instr -> Bool) -> Eq Instr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Instr -> Instr -> Bool
$c/= :: Instr -> Instr -> Bool
== :: Instr -> Instr -> Bool
$c== :: Instr -> Instr -> Bool
Eq, Eq Instr
Eq Instr
-> (Instr -> Instr -> Ordering)
-> (Instr -> Instr -> Bool)
-> (Instr -> Instr -> Bool)
-> (Instr -> Instr -> Bool)
-> (Instr -> Instr -> Bool)
-> (Instr -> Instr -> Instr)
-> (Instr -> Instr -> Instr)
-> Ord Instr
Instr -> Instr -> Bool
Instr -> Instr -> Ordering
Instr -> Instr -> Instr
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 :: Instr -> Instr -> Instr
$cmin :: Instr -> Instr -> Instr
max :: Instr -> Instr -> Instr
$cmax :: Instr -> Instr -> Instr
>= :: Instr -> Instr -> Bool
$c>= :: Instr -> Instr -> Bool
> :: Instr -> Instr -> Bool
$c> :: Instr -> Instr -> Bool
<= :: Instr -> Instr -> Bool
$c<= :: Instr -> Instr -> Bool
< :: Instr -> Instr -> Bool
$c< :: Instr -> Instr -> Bool
compare :: Instr -> Instr -> Ordering
$ccompare :: Instr -> Instr -> Ordering
Ord, (forall x. Instr -> Rep Instr x)
-> (forall x. Rep Instr x -> Instr) -> Generic Instr
forall x. Rep Instr x -> Instr
forall x. Instr -> Rep Instr x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Instr x -> Instr
$cfrom :: forall x. Instr -> Rep Instr x
Generic)
instance NFData Instr

applyMask1 :: Int -> [Maybe Bool] -> Int
applyMask1 :: Int -> [Maybe Bool] -> Int
applyMask1 = (Int -> Int -> Maybe Bool -> Int) -> Int -> [Maybe Bool] -> Int
forall i (f :: * -> *) b a.
FoldableWithIndex i f =>
(i -> b -> a -> b) -> b -> f a -> b
ifoldl' ((Int -> Int -> Maybe Bool -> Int) -> Int -> [Maybe Bool] -> Int)
-> (Int -> Int -> Maybe Bool -> Int) -> Int -> [Maybe Bool] -> Int
forall a b. (a -> b) -> a -> b
$ \Int
i Int
x -> \case
    Maybe Bool
Nothing    -> Int
x
    Just Bool
False -> Int -> Int -> Int
forall a. Bits a => a -> Int -> a
clearBit Int
x Int
i
    Just Bool
True  -> Int -> Int -> Int
forall a. Bits a => a -> Int -> a
setBit   Int
x Int
i

day14a :: [Instr] :~> Int
day14a :: [Instr] :~> Int
day14a = MkSol :: forall a b.
(String -> Maybe a)
-> ((?dyno::DynoMap) => a -> Maybe b) -> (b -> String) -> a :~> b
MkSol
    { sParse :: String -> Maybe [Instr]
sParse = Parsec Void String Instr -> String -> Maybe [Instr]
forall a. Parsec Void String a -> String -> Maybe [a]
parseLines Parsec Void String Instr
parseInstr
    , sShow :: Int -> String
sShow  = Int -> String
forall a. Show a => a -> String
show
    , sSolve :: (?dyno::DynoMap) => [Instr] -> Maybe Int
sSolve = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> ([Instr] -> Int) -> [Instr] -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap Int -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (IntMap Int -> Int) -> ([Instr] -> IntMap Int) -> [Instr] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap Int, [Maybe Bool]) -> IntMap Int
forall a b. (a, b) -> a
fst ((IntMap Int, [Maybe Bool]) -> IntMap Int)
-> ([Instr] -> (IntMap Int, [Maybe Bool])) -> [Instr] -> IntMap Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((IntMap Int, [Maybe Bool]) -> Instr -> (IntMap Int, [Maybe Bool]))
-> (IntMap Int, [Maybe Bool])
-> [Instr]
-> (IntMap Int, [Maybe Bool])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (IntMap Int, [Maybe Bool]) -> Instr -> (IntMap Int, [Maybe Bool])
go (IntMap Int, [Maybe Bool])
forall a. Monoid a => a
mempty
    }
  where
    go :: (IntMap Int, [Maybe Bool]) -> Instr -> (IntMap Int, [Maybe Bool])
    go :: (IntMap Int, [Maybe Bool]) -> Instr -> (IntMap Int, [Maybe Bool])
go (!IntMap Int
mp, ![Maybe Bool]
msk) = \case
      Mask  [Maybe Bool]
msk'   -> (IntMap Int
mp, [Maybe Bool]
msk')
      Write Int
addr Int
n -> (Int -> Int -> IntMap Int -> IntMap Int
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
addr (Int -> [Maybe Bool] -> Int
applyMask1 Int
n [Maybe Bool]
msk) IntMap Int
mp, [Maybe Bool]
msk)

applyMask2 :: Int -> [Maybe Bool] -> [Int]
applyMask2 :: Int -> [Maybe Bool] -> [Int]
applyMask2 = (Int -> Int -> Maybe Bool -> [Int]) -> Int -> [Maybe Bool] -> [Int]
forall i (f :: * -> *) (m :: * -> *) b a.
(FoldableWithIndex i f, Monad m) =>
(i -> b -> a -> m b) -> b -> f a -> m b
ifoldlM ((Int -> Int -> Maybe Bool -> [Int])
 -> Int -> [Maybe Bool] -> [Int])
-> (Int -> Int -> Maybe Bool -> [Int])
-> Int
-> [Maybe Bool]
-> [Int]
forall a b. (a -> b) -> a -> b
$ \Int
i Int
x -> \case  -- we can save like 2ms with manual ifoldl'
    Maybe Bool
Nothing    -> [Int -> Int -> Int
forall a. Bits a => a -> Int -> a
clearBit Int
x Int
i, Int -> Int -> Int
forall a. Bits a => a -> Int -> a
setBit Int
x Int
i]
    Just Bool
False -> [Int
x]
    Just Bool
True  -> [Int -> Int -> Int
forall a. Bits a => a -> Int -> a
setBit Int
x Int
i]

day14b :: [Instr] :~> Int
day14b :: [Instr] :~> Int
day14b = MkSol :: forall a b.
(String -> Maybe a)
-> ((?dyno::DynoMap) => a -> Maybe b) -> (b -> String) -> a :~> b
MkSol
    { sParse :: String -> Maybe [Instr]
sParse = ([Instr] :~> Int) -> String -> Maybe [Instr]
forall a b. (a :~> b) -> String -> Maybe a
sParse [Instr] :~> Int
day14a
    , sShow :: Int -> String
sShow  = Int -> String
forall a. Show a => a -> String
show
    , sSolve :: (?dyno::DynoMap) => [Instr] -> Maybe Int
sSolve = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> ([Instr] -> Int) -> [Instr] -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap Int -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (IntMap Int -> Int) -> ([Instr] -> IntMap Int) -> [Instr] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap Int, [Maybe Bool]) -> IntMap Int
forall a b. (a, b) -> a
fst ((IntMap Int, [Maybe Bool]) -> IntMap Int)
-> ([Instr] -> (IntMap Int, [Maybe Bool])) -> [Instr] -> IntMap Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((IntMap Int, [Maybe Bool]) -> Instr -> (IntMap Int, [Maybe Bool]))
-> (IntMap Int, [Maybe Bool])
-> [Instr]
-> (IntMap Int, [Maybe Bool])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (IntMap Int, [Maybe Bool]) -> Instr -> (IntMap Int, [Maybe Bool])
go (IntMap Int, [Maybe Bool])
forall a. Monoid a => a
mempty
    }
  where
    go :: (IntMap Int, [Maybe Bool]) -> Instr -> (IntMap Int, [Maybe Bool])
    go :: (IntMap Int, [Maybe Bool]) -> Instr -> (IntMap Int, [Maybe Bool])
go (!IntMap Int
mp, ![Maybe Bool]
msk) = \case
      Mask  [Maybe Bool]
msk'   -> (IntMap Int
mp, [Maybe Bool]
msk')
      Write Int
addr Int
n -> ([(Int, Int)] -> IntMap Int
forall a. [(Int, a)] -> IntMap a
IM.fromList ((,Int
n) (Int -> (Int, Int)) -> [Int] -> [(Int, Int)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> [Maybe Bool] -> [Int]
applyMask2 Int
addr [Maybe Bool]
msk) IntMap Int -> IntMap Int -> IntMap Int
forall a. Semigroup a => a -> a -> a
<> IntMap Int
mp, [Maybe Bool]
msk)

parseInstr :: CharParser Instr
parseInstr :: Parsec Void String Instr
parseInstr = ([Maybe Bool] -> Instr
Mask ([Maybe Bool] -> Instr)
-> ParsecT Void String Identity [Maybe Bool]
-> Parsec Void String Instr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity [Maybe Bool]
-> ParsecT Void String Identity [Maybe Bool]
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try ParsecT Void String Identity [Maybe Bool]
masker) Parsec Void String Instr
-> Parsec Void String Instr -> Parsec Void String Instr
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
P.<|> ((Int -> Int -> Instr) -> (Int, Int) -> Instr
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> Instr
Write ((Int, Int) -> Instr)
-> ParsecT Void String Identity (Int, Int)
-> Parsec Void String Instr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity (Int, Int)
memer)
  where
    masker :: ParsecT Void String Identity [Maybe Bool]
masker = do
      ParsecT Void String Identity String
-> ParsecT Void String Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT Void String Identity String
"mask = "
      [Maybe Bool] -> [Maybe Bool]
forall a. [a] -> [a]
reverse ([Maybe Bool] -> [Maybe Bool])
-> ParsecT Void String Identity [Maybe Bool]
-> ParsecT Void String Identity [Maybe Bool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity (Maybe Bool)
-> ParsecT Void String Identity [Maybe Bool]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.many ParsecT Void String Identity (Maybe Bool)
bitter
    bitter :: ParsecT Void String Identity (Maybe Bool)
bitter = [ParsecT Void String Identity (Maybe Bool)]
-> ParsecT Void String Identity (Maybe Bool)
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
P.choice
      [ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True  Maybe Bool
-> ParsecT Void String Identity Char
-> ParsecT Void String Identity (Maybe Bool)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Token String -> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token String
'1'
      , Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False Maybe Bool
-> ParsecT Void String Identity Char
-> ParsecT Void String Identity (Maybe Bool)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Token String -> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token String
'0'
      , Maybe Bool
forall a. Maybe a
Nothing    Maybe Bool
-> ParsecT Void String Identity Char
-> ParsecT Void String Identity (Maybe Bool)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Token String -> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token String
'X'
      ]
    memer :: ParsecT Void String Identity (Int, Int)
memer = (,)
      (Int -> Int -> (Int, Int))
-> ParsecT Void String Identity Int
-> ParsecT Void String Identity (Int -> (Int, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT Void String Identity String
"mem[" ParsecT Void String Identity String
-> ParsecT Void String Identity Int
-> ParsecT Void String Identity Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void String Identity Int
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
PP.decimal ParsecT Void String Identity Int
-> ParsecT Void String Identity String
-> ParsecT Void String Identity Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void String Identity String
"]")
      ParsecT Void String Identity (Int -> (Int, Int))
-> ParsecT Void String Identity Int
-> ParsecT Void String Identity (Int, Int)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ParsecT Void String Identity String
" = "  ParsecT Void String Identity String
-> ParsecT Void String Identity Int
-> ParsecT Void String Identity Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void String Identity Int
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
PP.decimal)