initial algebra

Fibonacci.hs

{-# LANGUAGE StandaloneDeriving     #-}
{-# LANGUAGE DeriveFunctor          #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE PatternSynonyms        #-}
{-# LANGUAGE ViewPatterns           #-}
{-# LANGUAGE LambdaCase             #-}

module Fibonacci where

import Prelude hiding (Maybe(..), (+), fst, snd)

class Functor f => InitialAlgebra f a | a -> f where
  initial :: f a -> a
  terminal :: a -> f a

cata :: InitialAlgebra f a => (f b -> b) -> a -> b
cata f = f . fmap (cata f) . terminal

data Product a b = Product a b deriving Show
data CoProduct a b = CoFst a | CoSnd b deriving Show
data Terminal = Terminal deriving Show
newtype Maybe a = Maybe (CoProduct Terminal a) deriving (Functor, Show)
newtype Mu f = Mu (f (Mu f))
newtype Nat = Nat (Mu Maybe)

deriving instance Functor (CoProduct a)

pattern Nothing :: Maybe a
pattern Nothing = Maybe (CoFst Terminal)

pattern Just :: a -> Maybe a
pattern Just x = Maybe (CoSnd x)

instance InitialAlgebra Maybe Nat where
  initial Nothing         = Nat (Mu Nothing)
  initial (Just (Nat n')) = Nat (Mu (Just n'))
  terminal (Nat (Mu Nothing))   = Nothing
  terminal (Nat (Mu (Just n'))) = Just (Nat n')

pattern Z :: Nat
pattern Z = Nat (Mu Nothing)

pattern S :: Nat -> Nat
pattern S n <- (terminal -> Just n)
  where
    S = initial . Just

instance Show Nat where
  show n = flip cata n $ \case
    Nothing -> "Z"
    Just m  -> "S " ++ m

fst :: Product a b -> a
fst (Product x y) = x

snd :: Product a b -> b
snd (Product x y) = y

(+) :: Nat -> Nat -> Nat
m + n = flip cata m $ \case
  Nothing -> n
  Just m  -> S m

fib :: Nat -> Nat
fib n = fst $ flip cata n $ \case
  Nothing            -> Product Z (S Z)
  Just (Product x y) -> Product y (x+y)