{-# 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 initial' :: a -> f a cata :: InitialAlgebra f a => (f b -> b) -> a -> b cata f = f . fmap (cata f) . initial' data Product a b = Product a b deriving Show data CoProduct a b = CP1 a | CP2 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 (CP1 Terminal) pattern Just :: a -> Maybe a pattern Just x = Maybe (CP2 x) instance InitialAlgebra Maybe Nat where initial Nothing = Nat (Mu Nothing) initial (Just (Nat n')) = Nat (Mu (Just n')) initial' (Nat (Mu Nothing)) = Nothing initial' (Nat (Mu (Just n'))) = Just (Nat n') pattern Z :: Nat pattern Z = Nat (Mu Nothing) pattern S :: Nat -> Nat pattern S n <- (initial' -> 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)