tournament.hs

{- cabal:
build-depends: base, comonad
ghc-options: -Wall
-}

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}

import Control.Comonad (Comonad (extract, extend))
import Data.Foldable (Foldable (fold))

main :: IO ()
main = do
  let
    tournament :: Tree Win
    tournament =
      Node
        (Win Nothing)
        do Leaf $ Win $ Just $ Team "Alpha" 4
        do
          Node
            (Win Nothing)
            do
              Node
                (Win Nothing)
                do Leaf $ Win $ Just $ Team "Bravo" 3
                do Leaf $ Win $ Just $ Team "Charlie" 2
            do Leaf $ Win $ Just $ Team "Delta" 3
  putStrLn $ pretty tournament
  putStrLn $ pretty $ extend fold tournament

data Tree a = Leaf a | Node a (Tree a) (Tree a) deriving Show

newtype Win = Win (Maybe Team) deriving (Show, Pretty)

data Team = Team { name :: String, strength :: Word } deriving Show

instance Functor Tree where
  fmap f (Leaf a) = Leaf $ f a
  fmap f (Node a t0 t1) = Node (f a) (fmap f t0) (fmap f t1)

instance Comonad Tree where
  extract (Leaf a) = a
  extract (Node a _ _) = a

  extend f t@(Leaf _) = Leaf $ f t
  extend f t@(Node _ t0 t1) = Node (f t) (extend f t0) (extend f t1)

instance Foldable Tree where
  foldMap f (Leaf a) = f a
  foldMap f (Node a t0 t1) = mconcat [f a, foldMap f t0, foldMap f t1]

instance Semigroup Win where
  Win Nothing <> w = w
  w <> Win Nothing = w
  l@(Win (Just (Team ln ls))) <> r@(Win (Just (Team rn rs)))
    | ls > rs = l
    | ls < rs = r
    | otherwise = Win (Just (Team (ln <> ", " <> rn) ls))

instance Monoid Win where
  mempty = Win Nothing

class Pretty a where
  pretty :: a -> String

instance Pretty a => Pretty (Tree a) where
  pretty =
    go 0
    where
      go n (Leaf a) = replicate (4 * n) ' ' ++ pretty a ++ "\n"
      go n (Node a t0 t1) = replicate (4 * n) ' ' ++ pretty a ++ "\n" ++ go (n + 1) t0 ++ go (n + 1) t1

instance Pretty Team where
  pretty Team { name, strength } = name ++ " (" ++ show strength ++ ")"

instance Pretty a => Pretty (Maybe a) where
  pretty Nothing = "--"
  pretty (Just a) = pretty a