hylomorphism-in-the-wild.hs

-- https://adventofcode.com/2017/day/24
-- https://bartoszmilewski.com/2017/12/29/stalking-a-hylomorphism-in-the-wild/amp/

{-# LANGUAGE DeriveFunctor #-}

import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.List as List
import Data.List.Split (splitOn)
import Data.Function ((&))

(|>) = (&)

---

--newtype Fix f = Fix { unFix :: f (Fix f) }
type Coalgebra f a = a -> f a
type Algebra f a = f a -> a

-- ana :: Functor f => Coalgebra f a -> a -> Fix f
-- ana coalg = Fix . fmap (ana coalg) . coalg

-- cata :: Functor f => Algebra f a -> Fix f -> a
-- cata alg = alg . fmap (cata alg) . unFix

hylo :: Functor f => Algebra f a -> Coalgebra f b -> b -> a
hylo f g = f . fmap (hylo f g) . g

---

data TreeF a = NodeF Int [a] deriving (Functor)
--type Tree = Fix TreeF


class Pool pool where
    plookup :: Int -> pool -> Maybe [Int]
    premove :: (Int,Int) -> pool -> pool
    pinsert :: (Int,Int) -> pool -> pool
    pempty :: pool

data PoolImpl = P (Map Int [Int])

instance Pool PoolImpl where
    pinsert (m,n) (P pool) = P $ Map.insertWith mappend m [n] $ Map.insertWith mappend n [m] $ pool
    premove (m,n) (P pool) = P $ Map.adjust (List.delete n) m $ Map.adjust (List.delete m) n $ pool
    plookup m (P pool) = Map.lookup m pool
    pempty = P Map.empty

mkTreeCoalg :: Pool pool => Coalgebra TreeF (Int, pool)
mkTreeCoalg (n, pool) =
    case plookup n pool of
        Nothing -> NodeF n []
        Just xs -> NodeF n [ (x, premove (n,x) pool) | x <- xs]

--mkTree :: Pool pool => (Int,pool) -> Tree
--mkTree = ana grow

--Node 4 [Node (5, []), Node (6, [])]

getChainsAlg :: Algebra TreeF (Int,[[(Int,Int)]])
getChainsAlg (NodeF n []) = (n, [])
getChainsAlg (NodeF n states) = (n, concat [ push (n,m) segs  | (m, segs) <- states])
    where
        push :: a -> [[a]] -> [[a]]
        push s [] = [[s]]
        push s segs = map (s:) segs

main :: IO Int
main = do
    content <- readFile "input.txt"
    let segs :: [(Int,Int)] 
        segs = content |> lines |> map (\s -> let [m,n] = splitOn "/" s |> map read in (m, n))
        pool = foldr pinsert (pempty :: PoolImpl) segs
        (_, chains) = hylo getChainsAlg mkTreeCoalg (0, pool)
        getScore :: [(Int,Int)] -> Int
        getScore c = c |> map (\(m,n) -> m + n) |> sum
        result = map getScore chains |> maximum
    putStrLn $ "result=" ++ show result
    return result