https://adventofcode.com/2017/day/24

Bridge.hs

module Bridge where

import Data.List
import Data.Maybe
import qualified Data.Tree as DTree
import qualified Data.Map as Map

-- Note that user must ensure there is at least one (0, x) in pieces
pieces :: [Piece]
pieces = [(0,2), (2,2), (2,3), (3,4), (3,5), (0,1), (10,1), (9,10)]

main = do
  print $ calcPaths . buildTree $ (0, buildPool pieces)
  print $ bestChain pieces
  
type Piece = (Int, Int)

type Pool = Map.Map Int [Int]

type Path = [Int]

type Chain = [Piece]

addPiece :: Piece -> Pool -> Pool
addPiece (m, n) = if m /= n
                  then add m n . add n m
                  else add m n
  where
    add m n pool =
      case Map.lookup m pool of
        Nothing  -> Map.insert m [n] pool
        Just lst -> Map.insert m (n : lst) pool

removePiece :: Piece -> Pool -> Pool
removePiece (m, n) = if m /= n
                     then rem m n . rem n m
                     else rem m n
  where
    rem :: Int -> Int -> Pool -> Pool
    rem m n pool =
      case fromJust $ Map.lookup m pool of
        []  -> Map.delete m pool
        lst -> Map.insert m (delete n lst) pool

buildPool :: [Piece] -> Pool
buildPool = foldr addPiece Map.empty

buildTree :: (Int, Pool) -> DTree.Tree Int
buildTree = DTree.unfoldTree f
  where f :: (Int, Pool) -> (Int, [(Int, Pool)])
        f (n, pool) = case Map.lookup n pool of
                        Nothing -> (n, [])
                        Just ms -> (n, [(m, removePiece (n, m) pool)| m <-ms])

calcPaths :: DTree.Tree Int -> [Path]
calcPaths = DTree.foldTree f
  where f :: Int -> [[Path]] -> [Path]
        f n [] = [[n]]
        f n xs = map (n:) $ concat xs

pairs :: [a] -> [(a,a)]
pairs xs = zip xs (tail xs)

bestChain :: [Piece] -> Int
bestChain xs = maxScore . pathsToChains . calcPaths . buildTree $ (0, buildPool xs)
  where pathsToChains :: [Path] -> [Chain]
        pathsToChains = map pairs
        maxScore :: [Chain] -> Int
        maxScore = maximum . map (\xs -> sum . map (\(m,n) -> m + n) $ xs)

Made 2 changes to https://bartoszmilewski.com/2017/12/29/stalking-a-hylomorphism-in-the-wild

1. Use foldTree f and unfoldTree g in Data.Tree directly.

buildTree :: (Int, Pool) -> DTree.Tree Int
buildTree = DTree.unfoldTree f
  where f :: (Int, Pool) -> (Int, [(Int, Pool)])
        f (n, pool) = case Map.lookup n pool of
                        Nothing -> (n, [])
                        Just ms -> (n, [(m, removePiece (n, m) pool)| m <- ms])
 
calcPaths :: DTree.Tree Int -> [Path]
calcPaths = DTree.foldTree f
  where f :: Int -> [[Path]] -> [Path]
        f n [] = [[n]]
        f n xs = map (n:) $ concat xs

2. Turn a rose tree into a list of paths instead of a list of chains and then convert paths to chains by zip. To me, it seems to be more clear.

pairs :: [a] -> [(a,a)]
pairs xs = zip xs (tail xs)
 
bestChain :: [Piece] -> Int
bestChain xs = maxScore . pathsToChains . calcPaths . buildTree $ (0, buildPool xs)
  where pathsToChains :: [Path] -> [Chain]
        pathsToChains = map pairs
        maxScore :: [Chain] -> Int
        maxScore = maximum . map (\xs -> sum . map (\(m,n) -> m + n) $ xs)