Advent of Code 2020

.gitignore

inputs

Day01.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wall #-}

module Main where

import Criterion.Main (bench, bgroup, defaultMain, whnf)
import Data.Maybe (listToMaybe)
import SubsetSum (sumToTarget)

parseInput :: String -> [Int]
parseInput = map (read @Int) . words

part1 :: [Int] -> Maybe Int
part1 = fmap product . listToMaybe . sumToTarget 2 2020

part2 :: [Int] -> Maybe Int
part2 = fmap product . listToMaybe . sumToTarget 3 2020

main :: IO ()
main = do
  nums <- parseInput <$> getContents
  print $ part1 nums
  print $ part2 nums

  defaultMain
    [ bgroup
        "Part 1"
        [ bench "Solve" (whnf part1 nums)
        ],
      bgroup
        "Part 2"
        [ bench "Solve" (whnf part2 nums)
        ]
    ]

Day02.hs

{-# OPTIONS_GHC -Wall #-}

module Main where

import Control.Applicative (some)
import Control.Arrow ((&&&))
import Data.Bits (xor)
import Data.Char (isAlpha, isDigit)
import Data.Function ((&))
import Data.List (elemIndices)
import Data.Maybe (listToMaybe)
import Text.ParserCombinators.ReadP
  ( ReadP,
    char,
    eof,
    readP_to_S,
    satisfy,
    string,
  )

type Parser a = ReadP a

type Range = (Int, Int)

type Rule = (Range, Char)

type Entry = (Rule, String)

intP :: Parser Int
intP = read <$> some (satisfy isDigit)

rangeP :: Parser Range
rangeP = (,) <$> intP <* char '-' <*> intP

ruleP :: Parser Rule
ruleP = (,) <$> rangeP <* char ' ' <*> satisfy isAlpha

entryP :: Parser Entry
entryP = (,) <$> ruleP <* string ": " <*> some (satisfy isAlpha)

entriesP :: Parser [Entry]
entriesP = some (entryP <* char '\n') <* eof

parseInput :: String -> Maybe [Entry]
parseInput = fmap fst . listToMaybe . readP_to_S entriesP

isWithin :: Range -> Int -> Bool
isWithin (lo, hi) n = lo <= n && n <= hi

occurances :: Char -> String -> Int
occurances c = length . filter (== c)

isValid :: Entry -> Bool
isValid ((range, c), password) =
  password
    & occurances c
    & isWithin range

isValid' :: Entry -> Bool
isValid' (((posA, posB), c), password) =
  password
    & elemIndices c
    & map (+ 1)
    & (elem posA &&& elem posB)
    & uncurry xor

main :: IO ()
main = do
  Just entries <- parseInput <$> getContents
  print $ length . filter isValid $ entries
  print $ length . filter isValid' $ entries

Day03.hs

{-# LANGUAGE BlockArguments #-}
{-# OPTIONS_GHC -Wall #-}

module Main where

import Control.Applicative (many)
import Control.Arrow ((***))
import Control.Monad (guard)
import Control.Monad.Reader (ReaderT, asks, runReaderT)
import Control.Monad.State (State, evalState, get, put)
import Control.Monad.Trans.Maybe (MaybeT, runMaybeT)
import Data.Array (Array, array, bounds, (!))
import Data.Bifunctor (first)
import Data.Function ((&))

type Position = (Int, Int)

type GridSquare = Bool -- False = Empty & True = Tree

type Grid = Array Position GridSquare

gridSquare :: Char -> GridSquare
gridSquare '#' = True
gridSquare _ = False

grid :: [String] -> Grid
grid rows =
  array ((0, 0), (width, height)) do
    (y, row) <- zip [0 ..] rows
    (x, val) <- zip [0 ..] row
    return ((x, y), gridSquare val)
  where
    width = maximum (map length rows) - 1
    height = length rows - 1

type Journey a = MaybeT (ReaderT Grid (State Position)) a

move :: Int -> Int -> Journey ()
move dx dy = do
  (maxX, maxY) <- asks (snd . bounds)
  (x, y) <- get
  let y' = dy + y
  guard (y' <= maxY)
  put ((x + dx) `mod` (maxX + 1), y')

amOnTree :: Journey Bool
amOnTree = asks (!) <*> get

countTreesOnRoute :: Int -> Int -> Journey Int
countTreesOnRoute dx dy =
  length . filter id <$> many do
    move dx dy
    amOnTree

evalJourney :: Grid -> Position -> Journey a -> Maybe a
evalJourney g p = (`evalState` p) . (`runReaderT` g) . runMaybeT

countingTrees :: Grid -> Int -> Int -> Maybe Int
countingTrees g dx dy = evalJourney g (0, 0) (countTreesOnRoute dx dy)

parseInput :: String -> Grid
parseInput = grid . lines

solveTersely :: Array (Int, Int) Bool -> (Int, Int) -> Int
solveTersely forest (dx, dy) =
  -- generate infinite grid positions
  iterate ((+ dx) *** (+ dy)) (0, 0)
    -- ensure that the right moves 'wrap'
    & map (first (`mod` (fst (snd (bounds forest)) + 1)))
    -- stop producing when we go off the bottom
    & takeWhile ((<= snd (snd (bounds forest))) . snd)
    -- read the grid at every position
    & map (forest !)
    -- filter out empty cells
    & filter id
    -- count
    & length

main :: IO ()
main = do
  g <- parseInput <$> getContents
  print $ countingTrees g 3 1
  print $ product <$> traverse (uncurry (countingTrees g)) [(1, 1), (3, 1), (5, 1), (7, 1), (1, 2)]
  print $ solveTersely g (3, 1)
  print $ product (map (solveTersely g) [(1, 1), (3, 1), (5, 1), (7, 1), (1, 2)])

Day04.hs

{-# LANGUAGE BlockArguments #-}
{-# OPTIONS_GHC -Wall #-}

module Main where

import Control.Applicative (some, (<|>))
import Control.Monad (guard, replicateM)
import Data.Char (isDigit, isSpace)
import Data.Foldable (asum)
import Data.Functor (void)
import Data.Maybe (isJust)
import Parser
  ( Parser,
    char,
    eof,
    parse,
    satisfy,
    string,
  )
import Text.Read (readMaybe)

type Field = (String, String)

type Object = [Field]

space :: Parser ()
space = void (satisfy isSpace)

fieldP :: Parser Field
fieldP = (,) <$> chars <* char ':' <*> chars <* (space <|> eof)
  where
    chars = some (satisfy (not . isSpace))

newline :: Parser ()
newline = void (char '\n')

objectP :: Parser Object
objectP = some fieldP <* (newline <|> eof)

objectsP :: Parser [Object]
objectsP = some objectP <* eof

parseInput :: String -> Maybe [Object]
parseInput = parse objectsP

isValid :: Object -> Bool
isValid e =
  all
    (isJust . (`lookup` e))
    [ "byr",
      "iyr",
      "eyr",
      "hgt",
      "hcl",
      "ecl",
      "pid"
    ]

number :: Parser Int
number = do
  digits <- some (satisfy isDigit)
  case readMaybe digits of
    Nothing -> fail "No parse"
    Just n -> pure n

year :: Parser Int
year = do
  digits <- replicateM 4 (satisfy isDigit)
  case readMaybe digits of
    Nothing -> fail "No parse"
    Just n -> pure n

-- four digits; at least 1920 and at most 2002.
newtype BirthYear = BirthYear Int
  deriving (Show)

decodeBirthYear :: String -> Maybe BirthYear
decodeBirthYear str = do
  n <- parse (year <* eof) str
  guard (n >= 1920 && n <= 2002)
  pure (BirthYear n)

-- four digits; at least 2010 and at most 2020.
newtype IssueYear = IssueYear Int
  deriving (Show)

decodeIssueYear :: String -> Maybe IssueYear
decodeIssueYear str = do
  n <- parse (year <* eof) str
  guard (n >= 2010 && n <= 2020)
  pure (IssueYear n)

-- four digits; at least 2020 and at most 2030.
newtype ExpirationYear = ExpirationYear Int
  deriving (Show)

decodeExpirationYear :: String -> Maybe ExpirationYear
decodeExpirationYear str = do
  n <- parse (year <* eof) str
  guard (n >= 2020 && n <= 2030)
  pure (ExpirationYear n)

-- | a number followed by either cm or in:
-- If cm, the number must be at least 150 and at most 193.
-- If in, the number must be at least 59 and at most 76.
data Unit = Inches | Centimeters
  deriving (Show)

data Height = Height Int Unit
  deriving (Show)

decodeHeight :: String -> Maybe Height
decodeHeight str = do
  (n, u) <- parse ((,) <$> number <*> unit <* eof) str
  case u of
    Centimeters -> do
      guard (n >= 150 && n <= 193)
      pure (Height n u)
    Inches -> do
      guard (n >= 59 && n <= 76)
      pure (Height n u)
  where
    unit :: Parser Unit
    unit = (Centimeters <$ string "cm") <|> (Inches <$ string "in")

-- a # followed by exactly six characters 0-9 or a-f.
newtype HairColor = HairColor String
  deriving (Show)

decodeHairColor :: String -> Maybe HairColor
decodeHairColor =
  parse (HairColor <$> hex <* eof)
  where
    hex :: Parser String
    hex = (:) <$> char '#' <*> replicateM 6 hexDigit
    hexDigit :: Parser Char
    hexDigit = satisfy isDigit <|> satisfy (`elem` ['a' .. 'f'])

-- exactly one of: amb blu brn gry grn hzl oth.
data EyeColor
  = AMB
  | BLU
  | BRN
  | GRY
  | GRN
  | HZL
  | OTH
  deriving (Show)

decodeEyeColor :: String -> Maybe EyeColor
decodeEyeColor =
  parse
    ( asum
        [ AMB <$ string "amb",
          BLU <$ string "blu",
          BRN <$ string "brn",
          GRY <$ string "gry",
          GRN <$ string "grn",
          HZL <$ string "hzl",
          OTH <$ string "oth"
        ]
    )

-- a nine-digit number, including leading zeroes.
newtype PassportID = PassportID String
  deriving (Show)

decodePassportID :: String -> Maybe PassportID
decodePassportID = (PassportID <$>) . parse (replicateM 9 (satisfy isDigit) <* eof)

-- ignored, missing or not.
newtype CountryID = CountryID String
  deriving (Show)

decodeCountryID :: String -> Maybe CountryID
decodeCountryID = Just . CountryID

data Passport = Passport
  { byr :: BirthYear,
    iyr :: IssueYear,
    eyr :: ExpirationYear,
    hgt :: Height,
    hcl :: HairColor,
    ecl :: EyeColor,
    pid :: PassportID,
    cid :: Maybe CountryID
  }
  deriving (Show)

field :: String -> (String -> Maybe a) -> Object -> Maybe a
field name valueDecoder object = valueDecoder =<< lookup name object

optionalField :: String -> (String -> Maybe a) -> Object -> Maybe (Maybe a)
optionalField name valueDecoder object =
  case lookup name object of
    Nothing -> Just Nothing
    Just v -> Just <$> valueDecoder v

decodePassport :: Object -> Maybe Passport
decodePassport object =
  Passport
    <$> field "byr" decodeBirthYear object
    <*> field "iyr" decodeIssueYear object
    <*> field "eyr" decodeExpirationYear object
    <*> field "hgt" decodeHeight object
    <*> field "hcl" decodeHairColor object
    <*> field "ecl" decodeEyeColor object
    <*> field "pid" decodePassportID object
    <*> optionalField "cid" decodeCountryID object

main :: IO ()
main = do
  Just objects <- parseInput <$> getContents
  print $ length (filter id (map isValid objects))
  print $ length (filter isJust (map decodePassport objects))

Day05.hs

{-# OPTIONS_GHC -Wall #-}

module Main where

import Data.List (find, sort)
import Data.Maybe (fromMaybe, listToMaybe)
import Numeric (readInt)

rowSpace :: Char -> Maybe Int
rowSpace c =
  case c of
    'F' -> Just 0
    'B' -> Just 1
    _ -> Nothing

readRowNumber :: String -> Maybe Int
readRowNumber =
  fmap fst
    . listToMaybe
    . readInt 2 (`elem` ['F', 'B']) (fromMaybe (-1) . rowSpace)
    . take 7

columnSpace :: Char -> Maybe Int
columnSpace c =
  case c of
    'L' -> Just 0
    'R' -> Just 1
    _ -> Nothing

readColumnNumber :: String -> Maybe Int
readColumnNumber =
  fmap fst
    . listToMaybe
    . readInt 2 (`elem` ['L', 'R']) (fromMaybe (-1) . columnSpace)
    . take 3
    . drop 7

type Seat = (Int, Int)

readSeat :: String -> Maybe Seat
readSeat str = (,) <$> readRowNumber str <*> readColumnNumber str

seatID :: Seat -> Int
seatID (r, c) = r * 8 + c

readSeatID :: String -> Maybe Int
readSeatID = fmap seatID . readSeat

findHole :: [Int] -> Maybe Int
findHole =
  fmap ((+ 1) . fst)
    . find ((> 1) . uncurry subtract)
    . (zip <$> id <*> drop 1)
    . sort

main :: IO ()
main = do
  Just seatIds <- traverse readSeatID . lines <$> getContents
  print $ maximum seatIds
  print $ findHole seatIds

Day06.hs

{-# OPTIONS_GHC -Wall #-}

module Main where

import Control.Applicative (some, (<|>))
import Data.Set (Set)
import qualified Data.Set as Set
import Parser (Parser, eof, newline, parse, satisfy)

alphabet :: String
alphabet = ['a' .. 'z']

singleAnswerP :: Parser String
singleAnswerP = some (satisfy (`elem` alphabet)) <* newline

groupAnswersP :: Parser [String]
groupAnswersP = some singleAnswerP <* (newline <|> eof)

parseInput :: String -> Maybe [[String]]
parseInput = parse (some groupAnswersP <* eof)

uniqueGroupAnswers :: [String] -> Set Char
uniqueGroupAnswers = foldMap Set.fromList

sharedGroupAnswers :: [String] -> Set Char
sharedGroupAnswers = foldr (Set.intersection . Set.fromList) (Set.fromList alphabet)

main :: IO ()
main = do
  Just groups <- parseInput <$> getContents
  print $ sum (map (Set.size . uniqueGroupAnswers) groups)
  print $ sum (map (Set.size . sharedGroupAnswers) groups)

Day07.hs

{-# LANGUAGE BlockArguments #-}
{-# OPTIONS_GHC -Wall #-}

module Main where

import Control.Applicative (some, (<|>))
import Data.Functor (void)
import Data.Graph
  ( Graph,
    Vertex,
    graphFromEdges,
    reachable,
    transposeG,
  )
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Tuple (swap)
import Numeric.Natural (Natural)
import Parser
  ( Parser,
    alpha,
    char,
    eof,
    natural,
    newline,
    parse,
    space,
    string,
  )

type Finish = String

type Colour = String

type Bag = (Finish, Colour)

bagP :: Parser Bag
bagP = (,) <$> some alpha <* space <*> some alpha

type Content = (Natural, Bag)

contentP :: Parser Content
contentP = do
  count <- natural
  space
  bag <- bagP
  space
  void (string "bags" <|> string "bag")
  pure (count, bag)

type Rule = (Bag, [Content])

noContentsP :: Parser [Content]
noContentsP = [] <$ string "no other bags."

contentsP :: Parser [Content]
contentsP = some (contentP <* (void (string ", ") <|> void (char '.')))

ruleP :: Parser Rule
ruleP = do
  bag <- bagP
  void (string " bags contain ")
  content <- noContentsP <|> contentsP
  pure (bag, content)

parseInput :: String -> Maybe [Rule]
parseInput = parse (some (ruleP <* (newline <|> eof)) <* eof)

type BagGraphEdge = (Bag, Bag, [Bag])

type BagGraph = (Graph, Vertex -> BagGraphEdge, Bag -> Maybe Vertex)

bagGraph :: [Rule] -> BagGraph
bagGraph = graphFromEdges . map ruleToEdge
  where
    ruleToEdge :: Rule -> (Bag, Bag, [Bag])
    ruleToEdge (outer, inners) = (outer, outer, map snd inners)

edgeToBag :: BagGraphEdge -> Bag
edgeToBag (b, _, _) = b

allWhichCanContain :: Bag -> BagGraph -> Maybe [Bag]
allWhichCanContain bag (graph, nodeFromVertex, vertexFromKey) =
  map (edgeToBag . nodeFromVertex) . reachable (transposeG graph) <$> vertexFromKey bag

type RuleMap = Map Bag (Map Bag Natural)

ruleMap :: [Rule] -> RuleMap
ruleMap = foldMap (\(bag, contents) -> Map.singleton bag (Map.fromList (map swap contents)))

countChildren :: RuleMap -> Bag -> Natural
countChildren rules bag =
  let children = maybe [] Map.assocs (Map.lookup bag rules)
   in 1 + sum (map (\(child, count) -> count * countChildren rules child) children)

main :: IO ()
main = do
  Just rules <- parseInput <$> getContents
  print $ subtract 1 . length <$> allWhichCanContain ("shiny", "gold") (bagGraph rules)
  print $ subtract 1 (countChildren (ruleMap rules) ("shiny", "gold"))

Day08.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wall #-}

module Main where

import Control.Applicative (some, (<|>))
import Control.Arrow ((&&&))
import Control.Monad.State (evalState, get, modify)
import Data.Function ((&))
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import Data.List (find, unfoldr)
import Data.Maybe (mapMaybe)
import qualified Data.Set as Set
import Parser
  ( Parser,
    char,
    eof,
    natural,
    newline,
    parse,
    space,
    string,
  )

data Instruction
  = Acc Int
  | Jmp Int
  | Nop Int
  deriving (Show)

instructionP :: Parser Instruction
instructionP = op <*> (space *> (sign <*> (fromIntegral <$> natural)))
  where
    sign :: Parser (Int -> Int)
    sign = (* 1) <$ char '+' <|> (* (-1)) <$ char '-'
    op :: Parser (Int -> Instruction)
    op = Acc <$ string "acc" <|> Jmp <$ string "jmp" <|> Nop <$ string "nop"

type Program = IntMap Instruction

parseInput :: String -> Maybe Program
parseInput =
  fmap (IntMap.fromList . zip [0 ..])
    . parse (some (instructionP <* (newline <|> eof)) <* eof)

move :: Instruction -> Int
move ins =
  case ins of
    Acc _ -> 1
    Nop _ -> 1
    Jmp v -> v

indexes :: Program -> [Int]
indexes program = unfoldr step 0
  where
    step :: Int -> Maybe (Int, Int)
    step current =
      (current,) . ((current +) . move)
        <$> IntMap.lookup current program

takeWhileM :: (Monad m) => (a -> m Bool) -> [a] -> m [a]
takeWhileM _ [] = return []
takeWhileM p (x : xs) = do
  q <- p x
  if q
    then takeWhileM p xs >>= (return . (:) x)
    else return []

takeWhileUnique :: Ord a => [a] -> [a]
takeWhileUnique =
  flip evalState Set.empty . takeWhileM \n -> do
    ns <- get
    modify (Set.insert n)
    pure (not (Set.member n ns))

-- This is a bit slower ... interesting
-- takeWhileUnique' :: Eq a => [a] -> [a]
-- takeWhileUnique' as =
--   case as of
--     [] -> []
--     (a : as') -> a : takeWhileUnique' (takeWhile (/= a) as')

delta :: Instruction -> Int
delta ins =
  case ins of
    Acc v -> v
    Nop _ -> 0
    Jmp _ -> 0

deltas :: Program -> [Int] -> [Int]
deltas program = mapMaybe (fmap delta . (`IntMap.lookup` program))

run :: Program -> Int
run program = sum (deltas program (takeWhileUnique (indexes program)))

repair :: Program -> Maybe (Program, [Int])
repair program =
  program
    & IntMap.keys
    & map (\k -> IntMap.adjust change k program)
    & map (id &&& (takeWhileUnique . indexes))
    & find ((lastIndex ==) . maximum . snd)
  where
    lastIndex :: Int
    lastIndex = IntSet.findMax (IntMap.keysSet program)

    change :: Instruction -> Instruction
    change instruction =
      case instruction of
        Nop v -> Jmp v
        Jmp v -> Nop v
        Acc v -> Acc v

run' :: Program -> Maybe Int
run' = fmap (sum . uncurry deltas) . repair

main :: IO ()
main = do
  Just program <- parseInput <$> getContents
  print (run program)
  print (run' program)

Day09.hs

{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wall #-}

module Main where

import Control.Arrow ((&&&))
import Criterion.Main (bench, bgroup, defaultMain, whnf)
import Data.List (find, tails)
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe (mapMaybe)
import Data.Sequence (Seq, (|>))
import qualified Data.Sequence as Seq
import SubsetSum (sumToTarget)
import Text.Read (readMaybe)

chunksOf :: Int -> [a] -> [[a]]
chunksOf n = takeWhile ((== n) . length) . map (take n) . tails

withPreamblesOf :: Int -> [a] -> [NonEmpty a]
withPreamblesOf n = mapMaybe (nonEmpty . reverse) . chunksOf (n + 1)

uncons :: NonEmpty a -> (a, [a])
uncons = NonEmpty.head &&& NonEmpty.tail

isValid :: NonEmpty Int -> Bool
isValid =
  not
    . null
    . uncurry (sumToTarget 2)
    . uncons

part1 :: Int -> [Int] -> Maybe Int
part1 preambleSize =
  fmap NonEmpty.head
    . find (not . isValid)
    . withPreamblesOf preambleSize

type Window = (Int, Seq Int)

narrow :: Int -> Window -> Window
narrow target (total, s)
  | total <= target = (total, s)
  | otherwise = narrow target (total - sum (Seq.take 1 s), Seq.drop 1 s)

step :: Int -> Window -> Int -> Window
step target (total, s) n = narrow target (total + n, s |> n)

findSequenceSumTo :: Int -> [Int] -> Maybe (Seq Int)
findSequenceSumTo target =
  fmap snd . find ((== target) . fst) . scanl (step target) (0, Seq.empty)

part2 :: Int -> [Int] -> Maybe Int
part2 target =
  fmap (uncurry (+) . (minimum &&& maximum))
    . findSequenceSumTo target

main :: IO ()
main = do
  Just nums <- traverse (readMaybe @Int) . lines <$> getContents
  let Just invalidNumber = part1 25 nums

  print invalidNumber
  print $ part2 invalidNumber nums

  defaultMain
    [ bgroup
        "Part 1"
        [ bench "1" (whnf (part1 25) nums)
        ],
      bgroup
        "Part 2"
        [ bench "1" (whnf (part2 invalidNumber) nums)
        ]
    ]

Parser.hs

{-# OPTIONS_GHC -Wall #-}

module Parser
  ( module ReadP,
    Parser,
    alpha,
    digit,
    natural,
    newline,
    parse,
    space,
  )
where

import Control.Applicative (some)
import Data.Char (isAlpha, isDigit)
import Data.Functor (void)
import Data.Maybe (listToMaybe)
import Numeric.Natural (Natural)
import Text.ParserCombinators.ReadP as ReadP

parse :: Parser a -> String -> Maybe a
parse p = fmap fst . listToMaybe . readP_to_S p

type Parser a = ReadP a

space :: Parser ()
space = void (char ' ')

alpha :: Parser Char
alpha = satisfy isAlpha

newline :: Parser ()
newline = void (char '\n')

digit :: Parser Char
digit = satisfy isDigit

natural :: Parser Natural
natural = read <$> some digit

shell.nix

let
  nixpkgs = import <nixpkgs> {};
  ghcWithPackages = nixpkgs.haskellPackages.ghcWithPackages (p: with p; [
    criterion
  ]);
in
  nixpkgs.mkShell {
    buildInputs = [
      ghcWithPackages
    ];
  }

SubsetSum.hs

{-# OPTIONS_GHC -Wall #-}

module SubsetSum
  ( sumToTarget,
  )
where

import Control.Monad ((<=<))
import Data.Function ((&))
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.Maybe (mapMaybe)

lessThanOrEqual :: Int -> IntMap a -> IntMap a
lessThanOrEqual n im =
  case IntMap.splitLookup n im of
    (less, mv, _) -> maybe less (\v -> IntMap.insert n v less) mv

updateSums :: Int -> IntMap (IntMap [Int]) -> Int -> IntMap (IntMap [Int])
updateSums target sums n =
  sums
    & lessThanOrEqual (target - n)
    & IntMap.foldrWithKey
      ( \s ->
          IntMap.insertWith (<>) (s + n)
            . IntMap.foldMapWithKey
              (\l -> IntMap.singleton (l + 1) . (n :))
      )
      sums
    & IntMap.insertWith (<>) n (IntMap.singleton 1 [n])

sumToTarget :: Int -> Int -> [Int] -> [[Int]]
sumToTarget size target =
  mapMaybe (IntMap.lookup size <=< IntMap.lookup target)
    . scanl (updateSums target) IntMap.empty