{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Main where

import Data.Functor

main :: IO ()
main = putStrLn "Hello :)"

newtype Fix f = Fix
  { unFix :: f (Fix f)
  }

class (Functor f, Functor g) =>
      f :~> g
  where
  transform :: f a -> g a

instance Functor f => f :~> f where
  transform = id

type Algebra f a = f a -> a

type Coalgebra f a = a -> f a

data BinTreeF e a
  = Leaf e
  | Branch a
           a

instance Functor (BinTreeF e) where
  fmap f (Leaf x) = Leaf x
  fmap f (Branch x y) = Branch (f x) (f y)

k :: Algebra (BinTreeF Int) Int
k (Leaf x) = x
k (Branch x y) = max x y

data TreeF e a =
  Tree e
       [a]

instance Functor (TreeF e) where
  fmap f (Tree x xs) = Tree x (fmap f xs)

h :: Algebra (TreeF Int) Int
h (Tree x xs) = maximum (x : xs)

p :: Algebra (TreeF Int) Int
p (Tree x xs) = x + sum xs

i :: Coalgebra (TreeF Int) (Int, [Int])
i (i, []) = Tree i []
i (i, x:xs) = Tree x [(i + 1, xs)]

data ExprF a
  = Const Int
  | Add a
        a
  | Mul a
        a
  deriving (Show)

instance Functor ExprF where
  fmap f (Add x y) = Add (f x) (f y)
  fmap f (Mul x y) = Mul (f x) (f y)
  fmap f (Const x) = Const x

f :: Algebra ExprF Int
f (Add x y) = x + y
f (Mul x y) = x * y
f (Const x) = x

g :: Coalgebra ExprF [Int]
g [] = Const 0
g [x] = Const x
g (x:xs) = Add [x] xs

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

ana :: Functor f => Coalgebra f a -> a -> Fix f
ana coalg =
  let f = Fix . fmap f . coalg
   in f

hylo ::
     (Functor f, Functor g, f :~> g) => Algebra g b -> Coalgebra f a -> a -> b
hylo alg coalg =
  let f = alg . transform . fmap f . coalg
   in f

y :: Int
y = hylo f g [1, 2, 3, 4, 5]

z :: Int
z = hylo p i (0, [1, 2, 3, 4, 5])

c = ana i (0, [1, 2, 3, 4, 5])