falgebra.hs

falgebra.hs

{-# LANGUAGE DeriveFunctor #-}

import Data.Char(ord, chr)

data Fix f = Fx (f (Fix f))

unFix :: Functor f => Fix f -> f (Fix f)
unFix (Fx x) = x

type Algebra f a = f a -> a
type CoAlgebra f a = a -> f a

cata :: Functor f => Algebra f b -> Fix f -> b
cata alg = alg . fmap (cata alg) . unFix

ana :: Functor f => CoAlgebra f b -> b -> Fix f
ana coalg = Fx . fmap (ana coalg) . coalg

hylo :: Functor f => Algebra f a  -> CoAlgebra f b  -> b -> a
hylo alg coalg = cata alg . ana coalg

--------------------------------------------------------------------------------

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

algi :: ExprF (Fix ExprF) -> Fix ExprF
algi = Fx

alg1 :: Algebra ExprF Int
alg1 (Const x) = x
alg1 (Add a b) = a + b
alg1 (Mul a b) = a * b

eval1 = cata alg where
  alg :: Algebra ExprF Int
  alg (Const x) = x
  alg (Add a b) = a + b
  alg (Mul a b) = a * b

eval2 = cata alg where
  alg :: ExprF String -> String
  alg (Const i)   = [chr (ord 'a' + i)]
  alg (x `Add` y) = x ++ y
  alg (x `Mul` y) = concat [[a, b] | a <- x, b <- y]

fibs = hylo alg coalg where
  alg (Const x) = x
  alg (Add a b) = a + b
  alg (Mul a b) = a * b
  coalg 1 = Const 1
  coalg 2 = Const 2
  coalg n = Add (n-1) (n-2)


fact n = (hylo alg coalg) (1,n) where
  alg (Const x) = x
  alg (Add a b) = a * b
  coalg (f, end) =  if f >= end then Const f
                    else let r = (end + f) `div` 2
                    in Add (f, r) (r+1, end)

e1 = Fx $ (Fx $ Const 2) `Mul` (Fx $ Const 4)

--------------------------------------------------------------------------------

data NatF a = Z | S a deriving(Eq, Show, Functor)
type Nat = Fix NatF

add :: Nat -> Nat -> Nat
add n = cata alg where
  alg Z = n
  alg (S m) = Fx $ S m

nat :: Int -> Nat
nat = ana (coalg Z S) where
  coalg z _ 0 = z
  coalg _ s n = s (n-1)

inc :: Nat -> Nat
inc = cata alg where
  alg Z = Fx $ S $ Fx Z
  alg (S x) = Fx $ S x

mul :: Nat -> Nat -> Nat
mul n = cata alg where
  alg Z = Fx $ Z
  alg (S m) = add m n

int :: Nat -> Int
int = cata alg where
  alg Z = 0
  alg (S n) = 1 + n