aoc2022/day11/main.hs

import System.IO

import Data.List
import Data.List.Split

--import Debug.Trace



data Monkey = Monkey { name :: Int
                     , items :: [Integer]
                     , op :: (Integer -> Integer)
                     , cond :: (Integer -> Bool)
                     , dest :: (Bool -> Int)
                     , counter :: Int
                     }

instance Show Monkey where
    show (Monkey n i _ _ _ c) = "Monkey " ++ show n ++ " " ++ show i ++ " " ++ show c

instance Eq Monkey where
    m1 == m2 = (name m1) == (name m2)

instance Ord Monkey where
    compare m1 m2 = compare (counter m1) (counter m2)



parseOFunc :: [String] -> (Integer -> Integer)
parseOFunc ["+","old"] = (\x -> x + x)
parseOFunc ["+",num]   = (\x -> x + n) where n = read num :: Integer
parseOFunc ["*","old"] = (\x -> x * x)
parseOFunc ["*",num]   = (\x -> x * n) where n = read num :: Integer

parseTFunc :: Integer -> (Integer -> Bool)
parseTFunc d = (\x -> (x `mod` d) == 0)

parseMonkey :: [String] -> (Monkey,Integer)
parseMonkey xs = (Monkey n i o t d 0,t')
    where
        n = read [head $ drop 7 (xs !! 0)] :: Int
        i = map (\x -> read x :: Integer) $ splitOn ", " $ drop 18 (xs !! 1)
        o = parseOFunc $ splitOn " " $ drop 23 (xs !! 2)
        t'= read (last $ splitOn " " (xs !! 3)) :: Integer
        t = parseTFunc t'
        d'= map (\x -> read (last $ splitOn " " x) :: Int) $ drop 4 xs
        d = (\x -> if x then head d' else last d')




throw :: Monkey -> [(Integer,Int)] -> [Monkey] -> [Monkey]
throw (Monkey from _ _ _ de _) throws = map throwMod -- trace ("THROWS: " ++ show throws)
    where
        deT = de True
        deF = de False
        (thT,thF) = partition (\(_,y) -> y == deT) throws
        toT = map (\(x,_) -> x) thT
        toF = map (\(x,_) -> x) thF
        throwMod m@(Monkey n i o t d c)
            | n == from = Monkey n [] o t d (c + length throws)
            | n == deT  = Monkey n (i ++ toT) o t d c
            | n == deF  = Monkey n (i ++ toF) o t d c
            | otherwise = m

applyTurn :: Integer -> Integer -> Monkey -> [Monkey] -> [Monkey]
applyTurn lcmd wrd m@(Monkey n i o t d _) ms = nms -- trace ("NEW: " ++ show nms)
    where
        postInsp = map ((`mod` lcmd) . o) i -- trace ("TURN: " ++ show m)
        postBore = map (`div` wrd) postInsp
        postTest = map t postBore
        throwTo  = map d postTest
        nms      = throw m (zip postBore throwTo) ms

applyTurns :: Integer -> Integer -> [Monkey] -> [Monkey] -> [Monkey]
applyTurns _ _ [] ms = ms
applyTurns l wrd (t:ts) ms = applyTurns l wrd ts (applyTurn l wrd (ms !! (name t)) ms)





handler :: String -> String
handler s = (show p1) ++ "\n" ++
            (show p2) ++ "\n"
    where
        (monkeys,divisors) = unzip $ map parseMonkey $ splitOn [""] $ lines s
        lcmd    = foldl1 lcm divisors
        turns   = (\nt -> take (nt * length monkeys) $ concat $ repeat monkeys)
        final1  = applyTurns lcmd 3 (turns 20) monkeys
        final2  = applyTurns lcmd 1 (turns 10000) monkeys
        topprod = product . map counter . take 2 . reverse . sort
        [p1,p2] = map topprod [final1,final2]

main :: IO ()
main = do
    interact handler