discussed https://twitter.com/giuliohome_2017/status/947196667635396615 from https://bartoszmilewski.com/2017/12/29/stalking-a-hylomorphism-in-the-wild/

FindAllBestChains.hs

{-# LANGUAGE DeriveFunctor #-}

-- Is there a trick to getting this done easier?
-- yep, look at TryAgainFromScratch.hs

module Bridge where
  
import Data.List
import Data.Ord
import qualified Data.Map as Map
import Data.Maybe

main :: IO ()
main = do
  --input <- readFile "Data.txt"
  let input = unlines test
  let pool = fmap toPiece (lines input)
  let best = bestChain pool
  print $ score $ head best
  print "---"
  print $ best
  print "---"
  let poolScored = fmap toScoredPiece (lines input)
  print $ hylo chainScoredAlg coalgScored (0, presortScored poolScored)
  
type Piece = (Int, Int)
type ScoredPiece = ((Int, Int), Score)

data Score = Assign Int
  deriving Show

type Chain = [Piece]
type ScoredChain = ([Piece], Score)

getScore :: ScoredChain -> Int
getScore (gchain, Assign gscore) = gscore

type Pool = Map.Map Int [Int]
type ScoredPool = Map.Map Int ([Int],Score)

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

addScoredPiece :: ScoredPiece -> ScoredPool -> ScoredPool
addScoredPiece ((m, n),score) = if m /= n 
                  then add ((m, n),score) . add ((n, m),score)
                  else add ((m, n),score)
  where 
    add ((m, n), Assign score) pool = 
      case Map.lookup m pool of
        Nothing  -> Map.insert m ([n], Assign score) pool
        Just (lst, Assign lstscore) -> 
          Map.insert m ((n : lst), Assign $ score + lstscore) 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
        
removeScoredPiece :: Piece -> ScoredPool -> ScoredPool
removeScoredPiece (m, n) = if m /= n
                     then rem m n . rem n m
                     else rem m n
  where
    rem :: Int -> Int -> ScoredPool -> ScoredPool
    rem m n pool = 
      case fromJust $ Map.lookup m pool of
        ([],_)  -> Map.delete m pool
        (lst, Assign lstscore) -> Map.insert m ((delete n lst), Assign(lstscore-n-m)) pool

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

presortScored :: [ScoredPiece] -> ScoredPool
presortScored = foldr addScoredPiece Map.empty 

-- Tree of chains
-- Each node contains a port
-- and a list of smaller chains
-- Top node will contain port 0

-- data Node b a = Node { me :: a, kids :: [Node a b] } deriving Show
-- data NodeR a b = Rev (Node b a) deriving Show

data Rose = NodeR Int [Rose]
  deriving Show

data ScoredRose = NodeSR (Int,Score) [Rose]
  deriving Show

-- Represent the tree as a fixed point of a functor

data TreeF a = NodeF Int [a]
  deriving Functor

-- data ScoredTreeF a = NodeSF (Int,Score) [a]
--  deriving Functor
  
newtype Fix f = Fix { unFix :: f (Fix f) }

type Tree = Fix TreeF

type Coalgebra f a = a -> f a

-- This coalgebra builds a tree using anamorphism

coalg :: Coalgebra TreeF (Int, Pool)
coalg (n, pool) = 
  case Map.lookup n pool of
    Nothing -> NodeF n []
    Just ms -> NodeF n [(m, removePiece (m, n) pool) | m <- ms]

coalgScored :: Coalgebra TreeF (Int, ScoredPool)
coalgScored (n, pool) = 
  case Map.lookup n pool of
    Nothing -> NodeF n []
    Just (ms, Assign scorems) -> NodeF n
      [ (m, removeScoredPiece (m, n) pool) | m <- ms] 
    
ana :: Functor f => Coalgebra f a -> a -> Fix f
ana coalg = Fix . fmap (ana coalg) . coalg

type Algebra f a = f a -> a

-- This algebra is for testing

tAlg :: Algebra TreeF Rose
tAlg (NodeF n lst) = NodeR n lst

-- This algebra turns a tree into a list of chains
chainAlg :: Algebra TreeF (Int, [Chain])
chainAlg (NodeF n []) = (n, [])
chainAlg (NodeF n lst) = (n, concat [push (n, m) bs | (m, bs) <- lst])
  where
    push :: (Int, Int) -> [Chain] -> [Chain]
    push (n, m) [] = [[(n, m)]]
    push (n, m) bs = [(n, m) : br | br <- bs]

-- This algebra turns a tree into a list of scored chains

extrScore :: [ScoredChain] -> Int
extrScore bs = maximum $ fmap getScore bs

chainScoredAlg :: Algebra TreeF (Int, [ScoredChain])
chainScoredAlg (NodeF n []) = (n, [])
chainScoredAlg (NodeF n lst) = 
    (n, concat [push (n, m) bs | (m, bs) <- lst])
  where
    push :: (Int, Int) -> [ScoredChain] -> [ScoredChain]
    push (n, m) [] = [ ([(n, m)],  Assign (m + n))]
    push (n, m) bs = 
      ([(n, m)], Assign (n + m + (extrScore bs))) : bs

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

score :: Chain -> Int
score = sum . fmap score1
  where score1 (m, n) = m + n

bestChain :: [Piece] -> [Chain]
bestChain pieces =
  let pool = presort pieces
      (_, chains) = hylo chainAlg coalg (0, pool)
  -- in maximumBy (comparing score) chains
      maxscore = maximum $ fmap score chains
  in filter (\c -> score c == maxscore) chains

toPiece :: String -> Piece
toPiece s = let (a, b) = break (== '/') s
         in (read a, read (tail b))

toScoredPiece :: String -> ScoredPiece
toScoredPiece s = let (a, b) = break (== '/') s
         in ((read a, read (tail b)), Assign (read a + read (tail b)))
 
test = ["0/2",
 "2/2",
 "2/3",
 "3/4",
 "3/5",
 "0/1",
 "10/1",
 "9/10"]

TryAgainFromScratch

{-# LANGUAGE DeriveFunctor #-}

module Bridge where
  
import Data.List
import Data.Ord
import qualified Data.Map as Map
import Data.Maybe

main :: IO ()
main = do
  --input <- readFile "Data.txt"
  let input = unlines test
  let pool = fmap toPiece (lines input)
  let best = bestChain pool
  print $ score $ head best
  print "---"
  print $ best
  print "---"
  let (_,chains) = hylo chainAlg coalg (0, presort pool)
  print $ sortBy (comparing $ negate . fst) $ map (\c -> (score c, c))  chains

type Piece = (Int, Int)

type Chain = [Piece]

type Pool = Map.Map Int [Int]

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

presort :: [Piece] -> Pool
presort = foldr addPiece Map.empty 
          
-- Tree of chains
-- Each node contains a port
-- and a list of smaller chains
-- Top node will contain port 0
data Rose = NodeR Int [Rose]
  deriving Show

-- Represent the tree as a fixed point of a functor

data TreeF a = NodeF Int [a]
  deriving Functor
  
newtype Fix f = Fix { unFix :: f (Fix f) }

type Tree = Fix TreeF

type Coalgebra f a = a -> f a

-- This coalgebra builds a tree using anamorphism

coalg :: Coalgebra TreeF (Int, Pool)
coalg (n, pool) = 
  case Map.lookup n pool of
    Nothing -> NodeF n []
    Just ms -> NodeF n [(m, removePiece (m, n) pool) | m <- ms]
    
ana :: Functor f => Coalgebra f a -> a -> Fix f
ana coalg = Fix . fmap (ana coalg) . coalg

type Algebra f a = f a -> a

-- This algebra is for testing

tAlg :: Algebra TreeF Rose
tAlg (NodeF n lst) = NodeR n lst

-- This algebra turns a tree into a list of chains
chainAlg :: Algebra TreeF (Int, [Chain])
chainAlg (NodeF n []) = (n, [])
chainAlg (NodeF n lst) = (n, concat [push (n, m) bs | (m, bs) <- lst])
  where
    push :: (Int, Int) -> [Chain] -> [Chain]
    push (n, m) [] = [[(n, m)]]
    push (n, m) bs = [(n, m) : br | br <- bs]

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

score :: Chain -> Int
score = sum . fmap score1
  where score1 (m, n) = m + n

bestChain :: [Piece] -> [Chain]
bestChain pieces =
  let pool = presort pieces
      (_, chains) = hylo chainAlg coalg (0, pool)
  -- in maximum $ fmap score chains
      maxscore = maximum $ fmap score chains
  in filter (\c -> score c == maxscore) chains

toPiece :: String -> Piece
toPiece s = let (a, b) = break (== '/') s
         in (read a, read (tail b))
 
test = ["0/2",
 "2/2",
 "2/3",
 "3/4",
 "3/5",
 "0/1",
 "10/1",
 "9/10",
 "5/7"]