patterns.hs

-- Wrapper for recursive types
data Fix f = In { out :: f (Fix f) }

-- 1-layer fold and unfold
type Algebra   f a = f a -> a
type Coalgebra f a = a -> f a

cata :: Functor f => Algebra   f b -> Fix f -> b
ana  :: Functor f => Coalgebra f a -> a -> Fix f
-- 1-layer "fold" and "unfold" -> all-layer ones
cata algebra   = algebra . fmap (cata algebra)   . out
ana  coalgebra = In      . fmap (ana  coalgebra) . coalgebra

(~>) :: Functor f => Coalgebra f a -> Algebra f b -> a -> b
-- "unfold" followed by "fold"
-- (without building of intermediate structure)
coalgebra ~> algebra = algebra . fmap (coalgebra ~> algebra) . coalgebra

nexus :: Functor f => Coalgebra f a -> Algebra f b -> a -> b
-- "unfold" followed by "fold"
-- (with building of intermediate structure)
nexus coalgebra algebra = cata algebra . ana coalgebra

-- 1-layer list
data ListLayer a self
    = Nil
    | Cons a self

instance Functor (ListLayer a) where
    fmap f  Nil       = Nil
    fmap f (Cons a b) = Cons a (f b)

countTo 0 = Nil
countTo n = Cons n (n - 1)

product' Nil = 1
product' (Cons a b) = a * b

fact = countTo ~> product'

main = print (fact 10)
 -- prints 3628800

patterns.sml

signature FUNCTOR = 
sig
    type 'a t
    val map : ('a -> 'b) -> ('a t -> 'b t)
end

functor Fixpoint (Functor : FUNCTOR) =
struct
    type 'a layer = 'a Functor.t

    datatype spiral = In of spiral layer

    type t = spiral

    fun out (In spiral) = spiral

    fun catamorphism 
        (algebra : 'a layer -> 'a) 
        (spiral  : spiral)
                 : 'a =
            (algebra o Functor.map (catamorphism algebra) o out) spiral

    fun anamorphism
        (coalgebra : 'a -> 'a layer)
        (seed      : 'a) 
                   : spiral =
            (In o Functor.map (anamorphism coalgebra) o coalgebra) seed

    fun hylomorphism
        (coalgebra : 'a -> 'a layer)
        (  algebra : 'b layer -> 'b)
                   : 'a -> 'b =
        algebra o Functor.map (hylomorphism coalgebra algebra) o coalgebra

    fun nexus
        (coalgebra : 'a -> 'a layer)
        (  algebra : 'b layer -> 'b)
                   : 'a -> 'b =
        catamorphism algebra o anamorphism coalgebra
end

signature TYPE = 
sig
    type t
end

functor ListFunctor (carried : TYPE) = 
struct
    type elem = carried.t

    datatype 'a t 
        = NIL 
        | CONS of elem * 'a

    fun map f  NIL          = NIL
      | map f (CONS(x, xs)) = CONS(x, f xs)

    fun build algebra seed = case algebra seed
         of SOME (x, new_seed) => CONS(x, new_seed)
          | NONE               => NIL

    fun consume 
        (coalgebra : (elem * 'a) option -> 'a) 
        (layer     : 'a t) 
                   : 'a = 
        case layer
         of CONS(x, rest) => coalgebra (SOME (x, rest))
          | NIL           => coalgebra  NONE
end

structure IntList = ListFunctor(struct type t = int end);

structure ListAsFixpoint = Fixpoint(IntList);

let
    fun count 1 = NONE 
      | count x = SOME (x, x - 1)

    fun sum  NONE        = 1
      | sum (SOME(x, y)) = x * y

    val it = ListAsFixpoint.nexus (IntList.build count) (IntList.consume sum) 10
in
    (*prints 3628800*)
    print (Int.toString it)
end;;