Day 11 advent of code 2022

main.hs

    {-# LANGUAGE BlockArguments, BangPatterns, LambdaCase, NoMonomorphismRestriction #-}
    import Control.Monad.State.Strict
    import Data.List
    import Data.Bifunctor
    import Data.Maybe

    forEach xs st f = snd $ foldM (\st x -> runState (f x) st) st xs
    alterF = modify . first
    alterS = modify . second
    getF = gets fst
    
    data Monkey = Monkey { inspections :: Int
                         , items :: [Int]
                         , operation :: (String, String, String)
                         , divisionNumber :: Int
                         , onTrue :: Int
                         , onFalse ::Int
                         } deriving (Show)

    mkPartialMonkey = Monkey 0 undefined undefined undefined undefined undefined

    takeBy2 [] = []
    takeBy2 ((a:b:_):xs) = read @Int [a,b] : takeBy2 xs

    makeMonkeys input = reverse . snd $ forEach input (undefined,[]) $ \case
      ["Monkey",_]                -> alterF $ const mkPartialMonkey
      ("Starting":_:items')       -> alterF (\m -> m { items = takeBy2 items' })
      ["Operation:",_,_,x,op,y]   -> alterF (\m -> m { operation = (x,op,y) })
      ["Test:",_,_,num]           -> alterF (\m -> m { divisionNumber = read @Int num })
      ["If","true:",_,_,_,index]  -> alterF (\m -> m { onTrue = read @Int index })
      ["If","false:",_,_,_,index] -> alterF (\m -> m { onFalse = read @Int index })
      _                           -> getF >>= \monkey -> alterS (monkey :)


    apply (x,op,y) item = case op of
        "*" -> (voi x item) * (voi y item)
        "+" -> (voi x item) + (voi y item)
        where voi "old" = id
              voi int   = const (read @Int int)

    throwToMonkey n v = modify $ map appender 
      where appender (i,m) | i == n    = (i, m { items = (items m) ++ [v] })
                           | otherwise = (i, m)

    modifyAt n f = modify $ map (mapAt n f)
      where mapAt n f (i,v) | n == i    = (i,f v)
                            | otherwise = (i,v)


    solve monkeys = result $ forEach [1..20] monkeys \_ -> gets head >>= compute
      where
        result = product . take 2 . reverse . sort . map (inspections . snd)
        next index f =
          do monkeys <- get
             let found = lookup (index + 1) monkeys
             if isJust found then f (index + 1, fromJust found)
                             else pure ()
        compute (index, monkey)
          | null (items monkey) = next index compute
          | otherwise = do
              let (item:items') = items monkey
              let value = apply (operation monkey) item `div` 3
              if value `mod` divisionNumber monkey == 0
                then throwToMonkey (onTrue monkey + 1) value
                else throwToMonkey (onFalse monkey + 1) value
              let monkey' = monkey { items = items', inspections = inspections monkey + 1 }
              modifyAt index (const monkey')
              compute (index,monkey')



    main = do
      input <- ((++ [[""]]) . map words . lines) <$> readFile "/tmp/input.txt"
      
      print $ solve (zipWith (,) [1..] (makeMonkeys input))
      pure ()