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

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

Decode an expression from a bitstream.

This solution uses the ReadP parser combinator module.
Since ReadP only operates on 'String' parsing bits is
simulated by parsing strings of the characters @'0'@ and @'1'@.
ReadP's 'ReadP.gather' operation is useful for computing
the bitsize of a packet which comes up in some of the
operator packets.

= Examples

>>> vers <$> parse (decodeHex "8A004A801A8002F478")
Just 16

>>> vers <$> parse (decodeHex "620080001611562C8802118E34")
Just 12

>>> vers <$> parse (decodeHex "C0015000016115A2E0802F182340")
Just 23

>>> vers <$> parse (decodeHex "A0016C880162017C3686B18A3D4780")
Just 31

>>> eval <$> parse (decodeHex "C200B40A82")
Just 3

>>> eval <$> parse (decodeHex "04005AC33890")
Just 54

>>> eval <$> parse (decodeHex "880086C3E88112")
Just 7

>>> eval <$> parse (decodeHex "CE00C43D881120")
Just 9

>>> eval <$> parse (decodeHex "D8005AC2A8F0")
Just 1

>>> eval <$> parse (decodeHex "F600BC2D8F")
Just 0

>>> eval <$> parse (decodeHex "9C005AC2F8F0")
Just 0

>>> eval <$> parse (decodeHex "9C0141080250320F1802104A08")
Just 1

-}
module Main (main) where

import Advent (fromDigits, format)
import Data.Char (digitToInt)
import Text.ParserCombinators.ReadP (ReadP)
import Text.ParserCombinators.ReadP qualified as ReadP

-- | >>> :main
-- 843
-- 5390807940351
main :: IO ()
main :: IO ()
main =
 do [Char]
inp <- [format|16 %s%n|]
    let Just Packet
p = [Char] -> Maybe Packet
parse ([Char] -> [Char]
decodeHex [Char]
inp)
    Int -> IO ()
forall a. Show a => a -> IO ()
print (Packet -> Int
vers Packet
p)
    Int -> IO ()
forall a. Show a => a -> IO ()
print (Packet -> Int
eval Packet
p)

-- | A /BITS/ packet
data Packet
  = Lit Int Int -- ^ Literal with version and value
  | Op Int Int [Packet] -- ^ Operator with version, opcode, and arguments
  deriving Int -> Packet -> [Char] -> [Char]
[Packet] -> [Char] -> [Char]
Packet -> [Char]
(Int -> Packet -> [Char] -> [Char])
-> (Packet -> [Char])
-> ([Packet] -> [Char] -> [Char])
-> Show Packet
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [Packet] -> [Char] -> [Char]
$cshowList :: [Packet] -> [Char] -> [Char]
show :: Packet -> [Char]
$cshow :: Packet -> [Char]
showsPrec :: Int -> Packet -> [Char] -> [Char]
$cshowsPrec :: Int -> Packet -> [Char] -> [Char]
Show

-- | Compute the sum of the versions of all nested packets
vers :: Packet -> Int
vers :: Packet -> Int
vers (Lit Int
v Int
_   ) = Int
v
vers (Op  Int
v Int
_ [Packet]
xs) = Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Packet -> Int) -> [Packet] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Packet -> Int
vers [Packet]
xs)

-- | Evaluate the packet as an expression
eval :: Packet -> Int
eval :: Packet -> Int
eval (Lit Int
_ Int
n     ) = Int
n
eval (Op Int
_ Int
0 [Packet]
xs   ) = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum      (Packet -> Int
eval (Packet -> Int) -> [Packet] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Packet]
xs     )
eval (Op Int
_ Int
1 [Packet]
xs   ) = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product  (Packet -> Int
eval (Packet -> Int) -> [Packet] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Packet]
xs     )
eval (Op Int
_ Int
2 [Packet]
xs   ) = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum  (Packet -> Int
eval (Packet -> Int) -> [Packet] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Packet]
xs     )
eval (Op Int
_ Int
3 [Packet]
xs   ) = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum  (Packet -> Int
eval (Packet -> Int) -> [Packet] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Packet]
xs     )
eval (Op Int
_ Int
5 [Packet
x,Packet
y]) = Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Packet -> Int
eval Packet
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>  Packet -> Int
eval Packet
y)
eval (Op Int
_ Int
6 [Packet
x,Packet
y]) = Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Packet -> Int
eval Packet
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<  Packet -> Int
eval Packet
y)
eval (Op Int
_ Int
7 [Packet
x,Packet
y]) = Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Packet -> Int
eval Packet
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Packet -> Int
eval Packet
y)
eval Packet
o = [Char] -> Int
forall a. HasCallStack => [Char] -> a
error ([Char]
"bad expression: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Packet -> [Char]
forall a. Show a => a -> [Char]
show Packet
o)

-- | Parser for strings of @'1'@ and @'0'@ to 'Packet'
--
-- >>> parse "110100101111111000101000"
-- Just (Lit 6 2021)
--
-- >>> parse "00111000000000000110111101000101001010010001001000000000"
-- Just (Op 1 6 [Lit 6 10,Lit 2 20])
--
-- >>> parse "11101110000000001101010000001100100000100011000001100000"
-- Just (Op 7 3 [Lit 2 1,Lit 4 2,Lit 1 3])
parse :: String -> Maybe Packet
parse :: [Char] -> Maybe Packet
parse (ReadP Packet -> ReadS Packet
forall a. ReadP a -> ReadS a
ReadP.readP_to_S ReadP Packet
pPacket -> [(Packet
p,[Char]
_)]) = Packet -> Maybe Packet
forall a. a -> Maybe a
Just Packet
p
parse [Char]
_ = Maybe Packet
forall a. Maybe a
Nothing

-- | Decode a hex string into bit string
--
-- >>> decodeHex "D2FE28"
-- "110100101111111000101000"
--
-- >>> decodeHex "38006F45291200"
-- "00111000000000000110111101000101001010010001001000000000"
decodeHex :: String -> String
decodeHex :: [Char] -> [Char]
decodeHex = (Char -> [Char]) -> [Char] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap \case
  Char
'0' -> [Char]
"0000"; Char
'1' -> [Char]
"0001"; Char
'2' -> [Char]
"0010"; Char
'3' -> [Char]
"0011"
  Char
'4' -> [Char]
"0100"; Char
'5' -> [Char]
"0101"; Char
'6' -> [Char]
"0110"; Char
'7' -> [Char]
"0111"
  Char
'8' -> [Char]
"1000"; Char
'9' -> [Char]
"1001"; Char
'A' -> [Char]
"1010"; Char
'B' -> [Char]
"1011"
  Char
'C' -> [Char]
"1100"; Char
'D' -> [Char]
"1101"; Char
'E' -> [Char]
"1110"; Char
'F' -> [Char]
"1111"
  Char
x -> [Char] -> [Char]
forall a. HasCallStack => [Char] -> a
error ([Char]
"decodeHex: bad argument " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Char -> [Char]
forall a. Show a => a -> [Char]
show Char
x)

-- * 'ReadP' parser combinators

-- | Parse a single packet
pPacket :: ReadP Packet
pPacket :: ReadP Packet
pPacket =
 do Int
v <- Int -> ReadP Int
field Int
3; Int
t <- Int -> ReadP Int
field Int
3
    if Int
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4
      then Int -> Int -> Packet
Lit Int
v   (Int -> Packet) -> ReadP Int -> ReadP Packet
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP Int
pLiteral
      else Int -> Int -> [Packet] -> Packet
Op  Int
v Int
t ([Packet] -> Packet) -> ReadP [Packet] -> ReadP Packet
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP [Packet]
pArguments

-- | Parse an @n@-bit fixed-width big-endian, binary number
field :: Int {- ^ bit width -} -> ReadP Int
field :: Int -> ReadP Int
field Int
n = Int -> [Int] -> Int
forall a. Integral a => a -> [a] -> a
fromDigits Int
2 ([Int] -> Int) -> ([Char] -> [Int]) -> [Char] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Int) -> [Char] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Int
digitToInt ([Char] -> Int) -> ReadP [Char] -> ReadP Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> ReadP Char -> ReadP [Char]
forall a. Int -> ReadP a -> ReadP [a]
ReadP.count Int
n ReadP Char
ReadP.get

-- | Parse a single bit as a boolean flag
flag :: ReadP Bool
flag :: ReadP Bool
flag = (Char
'1' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) (Char -> Bool) -> ReadP Char -> ReadP Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP Char
ReadP.get

-- | Parse a variable-sized number in 4-bit chunks
pLiteral :: ReadP Int
pLiteral :: ReadP Int
pLiteral = Int -> ReadP Int
go Int
0
  where
    go :: Int -> ReadP Int
go Int
acc =
     do Bool
more <- ReadP Bool
flag; Int
chunk <- Int -> ReadP Int
field Int
4
        (if Bool
more then Int -> ReadP Int
go else Int -> ReadP Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure) (Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
chunk)

-- | Parse a list of sub-packets either by packet count or bit-size
pArguments :: ReadP [Packet]
pArguments :: ReadP [Packet]
pArguments =
 do Bool
mode <- ReadP Bool
flag
    if Bool
mode
      then do Int
n <- Int -> ReadP Int
field Int
11; Int -> ReadP Packet -> ReadP [Packet]
forall a. Int -> ReadP a -> ReadP [a]
ReadP.count Int
n ReadP Packet
pPacket
      else do Int
n <- Int -> ReadP Int
field Int
15; Int -> ReadP [Packet]
pSized Int
n

-- | Parse a list of packets that fit exactly in @n@ bits
pSized :: Int {- ^ bit width -} -> ReadP [Packet]
pSized :: Int -> ReadP [Packet]
pSized Int
n =
  case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
n Int
0 of
    Ordering
LT -> ReadP [Packet]
forall a. ReadP a
ReadP.pfail
    Ordering
GT -> do ([Char]
str, Packet
p) <- ReadP Packet -> ReadP ([Char], Packet)
forall a. ReadP a -> ReadP ([Char], a)
ReadP.gather ReadP Packet
pPacket
             (Packet
pPacket -> [Packet] -> [Packet]
forall a. a -> [a] -> [a]
:) ([Packet] -> [Packet]) -> ReadP [Packet] -> ReadP [Packet]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> ReadP [Packet]
pSized (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
str)
    Ordering
EQ -> [Packet] -> ReadP [Packet]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []