fibo.hs

{-# LANGUAGE DeriveFunctor #-}
import Control.Arrow ((&&&))
import Data.Bifunctor

-- Recursion Schemes for Dynamic Programming
-- Kabanov and Vene, Mathematics for Program Construction 2006

-- Basic stuff

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

type Alg f a = f a -> a

type CoAlg f a = a -> f a

cata :: Functor f => Alg f a -> (Mu f -> a)
cata f = f . fmap (cata f) . out

ana :: Functor f => CoAlg f a -> (a -> Mu f)
ana f = In . fmap (ana f) . f

hylo :: Functor f => CoAlg f a -> Alg f a -> a -> a
hylo coalg alg = cata alg . ana coalg

-- Histomorphisms

-- Annotate one level of (Mu f) for some functor f
-- FxA(X)
newtype AnnotF f ann x = AnnotF { unAnnotF :: (ann, f x) }
instance Functor f => Functor (AnnotF f ann) where
  fmap f = AnnotF . fmap (fmap f) . unAnnotF

-- Annotate an entire tree by 'a'
-- F-squiggle(A)
type Annotated f ann = Mu (AnnotF f ann)

annotated :: Functor f
          => (a -> ann)
          -> CoAlg f a
          -> (a -> Annotated f ann)
annotated annF coalg = ana (AnnotF . (annF &&& coalg))

epsilon :: Functor f => Annotated f ann -> ann
epsilon = fst . unAnnotF . out

theta :: Functor f => Annotated f ann -> FAnnotated f ann
theta = snd . unAnnotF . out

-- FF-squiggle(A)
type FAnnotated f ann = f (Mu (AnnotF f ann))

-- histo-as-cata
histo :: Functor f => (f (Mu (AnnotF f ann)) -> ann) -> Mu f -> ann
histo phi = epsilon . cata (In . AnnotF . (phi &&& id))

type NatF = Either ()

nats :: Int -> Mu NatF
nats = ana (\x -> if x == 0 then Left () else Right (x - 1))

fibo :: Int -> Int
fibo = histo phi . nats
  where
    phi (Left ()) = 0
    phi (Right x) = case theta x of
      Left () -> 1
      Right y -> epsilon x + epsilon y

Hahah dangit this is so great and so bad at the same time.