Add solution for 2021 day 16

2021/README.md

@@ -19,7 +19,7 @@
 | 13  |   ✓    |   ✓    | [C++]     |
 | 14  |   ✓    |   ✓    | [Erlang]  |
 | 15  |   ✓    |   ✓    | [D]       |
-| 16  |        |        |           |
+| 16  |   ✓    |   ✓    | [Haskell] |
 | 17  |        |        |           |
 | 18  |        |        |           |
 | 19  |        |        |           |
@@ -51,3 +51,4 @@
 [c++]: https://isocpp.org
 [erlang]: https://www.erlang.org
 [d]: https://dlang.org
+[haskell]: https://www.haskell.org

2021/day-16/.gitignore

@@ -0,0 +1,2 @@
+*.hi
+*.o

2021/day-16/Justfile

@@ -0,0 +1,6 @@
+@part PART INPUT_FILE="inputs/puzzle.txt":
+    ghc part_{{PART}}.hs common.hs
+    ./part_{{PART}} {{INPUT_FILE}}
+
+clean:
+    rm -f *.hi *.o part_one part_two

2021/day-16/common.hs

@@ -0,0 +1,150 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
+
+module Common
+  ( parseFile,
+    parsePackets,
+    sumPacketVersions,
+    evalPackets,
+  )
+where
+
+import Control.Monad (mfilter)
+import Data.Char (digitToInt)
+import Data.Maybe (mapMaybe)
+import Numeric (readHex)
+import System.IO (readFile)
+import Text.Printf (printf)
+
+type Bit = Int
+
+parseFile :: String -> IO [Bit]
+parseFile path = do
+  content <- readFile path
+  let intList = concat (mapMaybe hexCharToBits content)
+  return intList
+
+hexCharToBits :: Char -> Maybe [Bit]
+hexCharToBits char =
+  case readHex [char] of
+    [(val, _)] -> Just $ intToBits (val :: Int)
+    _ -> Nothing
+  where
+    intToBits i = map digitToInt $ printf "%04b" i
+
+bitsToInt :: [Bit] -> Int
+bitsToInt [] = 0
+bitsToInt bs =
+  bitsToInt' bs (length bs - 1)
+  where
+    bitsToInt' [] _ = 0
+    bitsToInt' (0 : bs) p = bitsToInt' bs (p - 1)
+    bitsToInt' (1 : bs) p = (2 ^ p) + bitsToInt' bs (p - 1)
+
+data Op = Sum | Product | Min | Max | Gt | Lt | Eq
+  deriving (Show)
+
+data PacketData = Literal Int | Operator Op [Packet]
+  deriving (Show)
+
+data Packet = Packet
+  { version :: Int,
+    content :: PacketData
+  }
+  deriving (Show)
+
+sumPacketVersions :: [Packet] -> Int -> Int
+sumPacketVersions [] memo = memo
+sumPacketVersions (Packet {version, content} : rem) memo =
+  case content of
+    Literal _ -> sumPacketVersions rem (memo + version)
+    Operator _ packets -> sumPacketVersions packets 0 + sumPacketVersions rem (memo + version)
+
+parsePackets :: [Bit] -> [Packet] -> Maybe [Packet]
+parsePackets [] packets = Just packets
+parsePackets bits packets = do
+  (pkgConsumed, packet) <- parsePacket bits
+  let nextBits = removePadding (drop pkgConsumed bits)
+  parsePackets nextBits (packets ++ [packet])
+  where
+    removePadding [] = []
+    removePadding bits@(1 : _ : _ : xs) = bits
+    removePadding bits@(0 : 1 : _ : xs) = bits
+    removePadding bits@(0 : 0 : 1 : xs) = bits
+    removePadding (0 : bs) = removePadding bs
+
+evalPackets :: [Packet] -> Int
+evalPackets packets = sum (map evalPacket packets)
+
+evalPacket :: Packet -> Int
+evalPacket Packet {content} =
+  case content of
+    Literal val -> val
+    Operator Sum packets -> sum (map evalPacket packets)
+    Operator Product packets -> product (map evalPacket packets)
+    Operator Min packets -> minimum (map evalPacket packets)
+    Operator Max packets -> maximum (map evalPacket packets)
+    Operator Gt [x, y] ->
+      let (px, py) = (evalPacket x, evalPacket y) in if px > py then 1 else 0
+    Operator Lt [x, y] ->
+      let (px, py) = (evalPacket x, evalPacket y) in if px < py then 1 else 0
+    Operator Eq [x, y] ->
+      let (px, py) = (evalPacket x, evalPacket y) in if px == py then 1 else 0
+
+parsePacket :: [Bit] -> Maybe (Int, Packet)
+parsePacket [] = Nothing
+parsePacket bits = do
+  (consumed, content) <- case kind of
+    0 -> parseOperator (drop 6 bits) Sum (6, [])
+    1 -> parseOperator (drop 6 bits) Product (6, [])
+    2 -> parseOperator (drop 6 bits) Min (6, [])
+    3 -> parseOperator (drop 6 bits) Max (6, [])
+    4 -> parseLiteral (drop 6 bits) (6, [])
+    5 -> parseOperator (drop 6 bits) Gt (6, [])
+    6 -> parseOperator (drop 6 bits) Lt (6, [])
+    7 -> parseOperator (drop 6 bits) Eq (6, [])
+  let packet = Packet {version, content}
+  Just (consumed, packet)
+  where
+    version = bitsToInt $ take 3 bits
+    kind = bitsToInt $ take 3 $ drop 3 bits
+
+parseOperator :: [Bit] -> Op -> (Int, [Packet]) -> Maybe (Int, PacketData)
+parseOperator bits op (consumed, memo) =
+  case bits of
+    (0 : bs) -> do
+      let totalBitLength = bitsToInt (take 15 bs)
+      let opConsumed = consumed + 16
+      let nextBits = take totalBitLength (drop 15 bs)
+      packets <- parsePacketsDense nextBits totalBitLength []
+      let newConsumed = opConsumed + totalBitLength
+      Just (newConsumed, Operator op packets)
+    (1 : bs) -> do
+      let subPacketCount = bitsToInt (take 11 bs)
+      let opConsumed = consumed + 12
+      let nextBits = drop 11 bs
+      (pkgConsumed, packets) <- subPackets nextBits subPacketCount (0, [])
+      let newConsumed = opConsumed + pkgConsumed
+      Just (newConsumed, Operator op packets)
+    _ ->
+      Nothing
+  where
+    parsePacketsDense bs 0 packets = Just packets
+    parsePacketsDense bs rem packets = do
+      (pkgConsumed, packet) <- parsePacket bs
+      parsePacketsDense (drop pkgConsumed bs) (rem - pkgConsumed) (packets ++ [packet])
+    subPackets bs 0 (consumed, packets) = Just (consumed, packets)
+    subPackets bs n (consumed, packets) = do
+      (pkgConsumed, packet) <- parsePacket bs
+      let nextBits = drop pkgConsumed bs
+      subPackets nextBits (n - 1) (consumed + pkgConsumed, packets ++ [packet])
+
+parseLiteral :: [Bit] -> (Int, [Bit]) -> Maybe (Int, PacketData)
+parseLiteral bits (consumed, memo) =
+  case bits of
+    (1 : bs) ->
+      parseLiteral (drop 4 bs) (consumed + 5, memo ++ take 4 bs)
+    (0 : bs) ->
+      Just (consumed + 5, Literal (bitsToInt (memo ++ take 4 bs)))
+    _ ->
+      Nothing

2021/day-16/inputs/puzzle.txt

@@ -0,0 +1 @@
+A20D5CECBD6C061006E7801224AF251AEA06D2319904921880113A931A1402A9D83D43C9FFCC1E56FF29890E00C42984337BF22C502008C26982801009426937320124E602BC01192F4A74FD7B70692F4A74FD7B700403170400F7002DC00E7003C400B0023700082C601DF8C00D30038005AA0013F40044E7002D400D10030C008000574000AB958B4B8011074C0249769913893469A72200B42673F26A005567FCC13FE673004F003341006615421830200F4608E7142629294F92861A840118F1184C0129637C007C24B19AA2C96335400013B0C0198F716213180370AE39C7620043E0D4788B440232CB34D80260008645C86D16C401B85D0BA2D18025A00ACE7F275324137FD73428200ECDFBEFF2BDCDA70D5FE5339D95B3B6C98C1DA006772F9DC9025B057331BF7D8B65108018092599C669B4B201356763475D00480010E89709E090002130CA28C62300265C188034BA007CA58EA6FB4CDA12799FD8098021400F94A6F95E3ECC73A77359A4EFCB09CEF799A35280433D1BCCA666D5EFD6A5A389542A7DCCC010958D85EC0119EED04A73F69703669466A048C01E14FFEFD229ADD052466ED37BD8B4E1D10074B3FF8CF2BBE0094D56D7E38CADA0FA80123C8F75F9C764D29DA814E4693C4854C0118AD3C0A60144E364D944D02C99F4F82100607600AC8F6365C91EC6CBB3A072C404011CE8025221D2A0337158200C97001F6978A1CE4FFBE7C4A5050402E9ECEE709D3FE7296A894F4C6A75467EB8959F4C013815C00FACEF38A7297F42AD2600B7006A0200EC538D51500010B88919624CE694C0027B91951125AFF7B9B1682040253D006E8000844138F105C0010D84D1D2304B213007213900D95B73FE914CC9FCBFA9EEA81802FA0094A34CA3649F019800B48890C2382002E727DF7293C1B900A160008642B87312C0010F8DB08610080331720FC580

2021/day-16/inputs/sample1.txt

@@ -0,0 +1 @@
+D2FE28

2021/day-16/inputs/sample2.txt

@@ -0,0 +1 @@
+38006F45291200

2021/day-16/inputs/sample3.txt

@@ -0,0 +1 @@
+EE00D40C823060

2021/day-16/part_one.hs

@@ -0,0 +1,10 @@
+import Common (parseFile, parsePackets, sumPacketVersions)
+import System.Environment (getArgs)
+
+main = do
+  args <- getArgs
+  intList <- parseFile $ head args
+
+  let packets = parsePackets intList []
+  let results = maybe 0 (`sumPacketVersions` 0) packets
+  print results

2021/day-16/part_two.hs

@@ -0,0 +1,11 @@
+import Common (evalPackets, parseFile, parsePackets)
+import System.Environment (getArgs)
+
+main =
+  do
+    args <- getArgs
+    intList <- parseFile $ head args
+
+    let packets = parsePackets intList []
+    let results = maybe 0 evalPackets packets
+    print results

README.md

@@ -8,4 +8,4 @@
 -   [2018](2018/README.md) (0% completed)
 -   [2019](2019/README.md) (0% completed)
 -   [2020](2020/README.md) (20% completed)
--   [2021](2021/README.md) (60% completed)
+-   [2021](2021/README.md) (64% completed)