HistoFib.hs

module Intro where

import Control.Arrow ((&&&))

newtype Term f =
  In { out :: f (Term f) }

type Algebra f a = f a -> a

cata :: (Functor f) => Algebra f a -> Term f -> a
cata f = f . fmap (cata f) . out
-- bottomUp f = cata (f . In)

type Coalgebra f a = a -> f a

ana :: (Functor f) => Coalgebra f a -> a -> Term f
ana f = In . fmap (ana f) . f
-- topDown f = ana (out . f)

type RAlgebra f a = f (Term f, a) -> a

para :: (Functor f) => RAlgebra f a -> Term f -> a
para f = f . fmap (id &&& para f) . out
-- cata f = para (f . fmap snd)

type RCoalgebra f a = a -> f (Either (Term f) a)

apo :: (Functor f) => RCoalgebra f a -> a -> Term f
apo f = In . fmap (id `either` apo f) . f
-- ana f = apo (fmap Right . f)

data Cofree f a =
  a :< f (Cofree f a)

type CVAlgebra f a = f (Cofree f a) -> a

histo :: Functor f => CVAlgebra f a -> Term f -> a
histo f = (\(a :< cf) -> a) . histo' f

histo' :: Functor f => CVAlgebra f a -> Term f -> Cofree f a
histo' f = uncurry (:<) . (f &&& id) . fmap (histo' f) . out

data Nat a
  = Zero
  | Next a
  deriving (Functor, Show, Eq)

deriving instance Show a => Show (Cofree Nat a)

expand :: Int -> Term Nat
expand 0 = In Zero
expand n = In (Next (expand (n - 1)))

fibAlg :: CVAlgebra Nat Integer
fibAlg Zero = 0
fibAlg (Next (_ :< Zero)) = 1
fibAlg (Next (p :< (Next (pp :< _)))) = p + pp

test :: Cofree Nat Integer
test = histo' fibAlg $ expand 8

{-
λ test
21 :< Next
    ( 13 :< Next
        ( 8 :< Next
            ( 5 :< Next
                ( 3 :< Next
                    ( 2 :< Next
                        ( 1 :< Next
                            ( 1 :< Next
                                ( 0 :< Zero )
                            )
                        )
                    )
                )
            )
        )
    )
it :: Cofree Nat Integer
-}