-- <pre>

-- An F-algebra over a carrier sort x is set of functions (and constants)
-- whose types involve x. In Haskell we can simulate this by a data definition
-- for a functor (F x) and a function (F x) -> x

data Algebra f c = Algebra (f c -> c)

data F1 x = Zero | One | Plus x x

f :: F1 Int -> Int
f Zero = 0
f One = 1
f (Plus x y) = x+y

g :: F1 [Int] -> [Int]
g Zero = []
g One = [1]
g (Plus x y) = x ++ y

alg1 :: Algebra F1 Int
alg1 = Algebra f

alg2 :: Algebra F1 [Int]
alg2 = Algebra g

data ListF a x = Nil | Cons a x

h :: ListF b Int -> Int
h Nil = 0
h (Cons x xs) = 1 + xs

alg3 :: Algebra (ListF a) Int
alg3 = Algebra h

-- An initial Algebra is the set of terms we can obtain be iteratively applying
-- the functions to the constants and other function applications. This set
-- can be simulated in Haskell by the data definitions.
-- here the function is        Init :: alg (Init alg) -> Init alg
-- Note how this fits the pattern f :: T x -> x

data Initial alg = Init (alg (Initial alg))

ex1 :: Initial F1
ex1 = Init(Plus (Init One) (Init Zero))

ex2 :: Initial (ListF Int)
ex2 = Init(Cons 2 (Init Nil))

initialAlg :: Algebra f (Initial f)
initialAlg = Algebra Init

-- We can write functions by a case analysis over the functions and
-- constants that generate the initial algebra

len :: Num a => Initial (ListF b) -> a
len (Init Nil) = 0
len (Init (Cons x xs)) = 1 + len xs

app :: Initial (ListF a) -> Initial (ListF a) -> Initial (ListF a)
app (Init Nil) ys = ys
app (Init (Cons x xs)) ys = Init(Cons x (app xs ys))


-- An F-algebra, f, is said to be initial to any other algebra, g, if there
-- is a UNIQUE homomorphism, from f to g (this is an arrow in the category of
-- F algebras). We can show the existence of this homomorphism by building
-- it as a datatype in Haskell. Note: that for each "f", (Arrow f a b) denotes
-- an arrow in the category of f-algebras.

data Arrow f a b = Arr (Algebra f a) (Algebra f b) (a->b)

-- For every Arrow (Arr (Algebra f) (Algebra g) h) it must be the case that
--
--   F a ---- fmap h -----> F b
--    |                      |
--    | f                    | g
--    |                      |
--    V                      V
--    a -------- h --------> b

valid :: (Eq b, Functor f) => Arrow f a b -> f a -> Bool
valid (Arr (Algebra f) (Algebra g) h) x =  h(f x) == g(fmap h x)

-- To show the existence of "h" for any F-algebra means we can compute
-- a function with the type (a -> b) from the algebra. To do this we first define cata:

cata :: Functor f => (Algebra f b) -> Initial f -> b
cata (Algebra phi) (Init x) = phi(fmap (cata (Algebra phi)) x)

exhibit :: Functor f => Algebra f a -> Arrow f (Initial f) a
exhibit x = Arr initialAlg x (cata x)

-- Lots of functions can be written directly as cata's

len2 x = cata (Algebra phi) x
   where phi Nil = 0
         phi (Cons x n) = 1 + n

app2 x y = cata (Algebra phi) x
  where phi Nil = y
        phi (Cons x xs) = Init(Cons x xs)

-- With initiality comes the inductive proof method. So to prove something
-- (prop x) where x::Initial A

prop1 :: Initial (ListF Int) -> Bool
prop1 x = len(Init(Cons 1 x)) == 1 + len x

-- Prove:  prop1 (Init Nil)
-- Assume prop1 xs
-- The prove:  prop1 (Init (Cons x xs))


-- we need a function from A(prop x) -> prop x

data Proof = Simple Bool | Induct (Algebra (ListF Int) Proof)

p1 :: ListF a Proof -> Proof
p1 Nil = Simple(prop1 (Init Nil))
p1 (Cons x xs) = undefined
                 -- xs = Proof that prop1 ys holds
                 -- we need a proof that (prop1 (Init (Cons x ys))) holds


prop2 :: Initial (ListF a) -> Initial (ListF a) -> Bool
prop2 x y = len(app x y) == len x + len y

-------------------------------------------------------------------
-- CoAlgebras

data CoAlgebra f c = CoAlgebra (c -> f c)
unCoAlgebra (CoAlgebra x) = x

countdown :: CoAlgebra (ListF Int) Int
countdown = CoAlgebra f
  where f 0 = Nil
        f n = Cons n (n-1)

data StreamF n x = C n x

-----------------------------------------------------------
-- We can write CoAlgebras by expanding a "seed" into an F structure
-- filled with new seeds. seed -> F seed, the non-parameterized slots
-- can be filled with things computed from the seed. These are
-- sometimes called observations.

endsIn0s :: CoAlgebra (StreamF Integer) [Integer]
endsIn0s = CoAlgebra f
  where f [] = C 0 []
        f (x:xs) = C x xs

split :: CoAlgebra F1 Integer
split = CoAlgebra f
  where f 0 = Zero
        f 1 = One
        f n = Plus (n-1) (n-2)

fibs :: CoAlgebra (StreamF Int) (Int,Int)
fibs = CoAlgebra f
  where f (x,y) = C (x+y) (y,x+y)

instance Functor (StreamF n) where
  fmap f (C x y) = C x (f y)

instance Functor F1 where
  fmap f Zero = Zero
  fmap f One = One
  fmap f (Plus x y) = Plus (f x) (f y)


-----------------------------------------
-- Final CoAlgebras
-- sequences (branching trees?) of observations of the internal state
-- This allows us to iterate all the possible observations.
-- Sometimes these are infinite structures.

data Final f = Final (f (Final f))

unFinal :: Final a -> a (Final a)
unFinal (Final x) = x

finalCoalg :: CoAlgebra a (Final a)
finalCoalg = CoAlgebra unFinal

f1 :: Final (ListF a)
f1 = Final Nil

ones :: Final (StreamF Integer)
ones = Final(C 1 ones)


-----------------------------------------------------------
-- We can write functions producing elements in the sort of
-- Final CoAlgebras by expanding a "seed" into an F structure
-- filled with observations and recursive calls in the "slots"
-- then all thats really left is the observations.

nats :: Final (StreamF Integer)
nats = g 0 where g n = Final (C n (g (n+1)))

data NatF x = Z | S x

omega :: Final NatF
omega = f undefined
  where f x = Final(S(f x))

n :: Int -> Final NatF
n x = f x
  where f 0 = Final Z
        f n = Final(S (f (n-1)))

----------------------------------------------------------------
-- A CoHomomorphism is an arrow in the category of F-CoAlgebras

data CoHom f a b = CoHom (CoAlgebra f a) (CoAlgebra f b) (a->b)

-- For every arrow in the category
-- (CoHom (CoAlgebra f) (CoAlgebra g) h) it must be the case that
--
--   F a ---- fmap h -----> F b
--    ^                      ^
--    |                      |
--    | f                    | g
--    |                      |
--    a -------- h --------> b

covalid :: (Eq (f b), Functor f) => CoHom f a b -> a -> Bool
covalid (CoHom (CoAlgebra f) (CoAlgebra g) h) x =  fmap h (f x) == g(h x)

-------------------------------------------------------------------------
-- A F-CoAlgebra, g, is Final if for any other F-CoAlgebra, f, there
-- is a unique F-CoAlgebra homomorphism, h, from f to g. We can show
-- its existence be building a function that computes it from the
-- CoAlgebra, f.

ana :: Functor f => (CoAlgebra f seed) -> seed -> (Final f)
ana (CoAlgebra phi) seed = Final(fmap (ana (CoAlgebra phi)) (phi seed))

exhibit2 :: Functor f => CoAlgebra f seed -> CoHom f seed (Final f)
exhibit2 x = CoHom x finalCoalg (ana x)

------------------------------------------------------------------
-- we use ana to iteratively unfold any coAgebra to record its observations

final1 = ana endsIn0s
final2 = ana split
final3 = ana fibs

tak :: Num a => a -> Final (StreamF b) -> [b]
tak 0 _ = []
tak n (Final (C x xs)) = x : tak (n-1) xs

fibs5 = tak 5 (final3 (1,1))

------------------------------------------------------
-- Lets use CoAlgebras to represent Points in the 2-D
-- plane as we would in an OO-language

data P x = P { xcoord :: Float
             , ycoord :: Float
             , move :: Float -> Float -> x}

pointF :: (Float,Float) -> P (Float,Float)
pointF (x,y) = P {xcoord = x, ycoord = y, move = \ m n -> (m+x,n+y) }

type Point = CoAlgebra P (Float,Float)

point1 :: Point
point1 = CoAlgebra pointF


-- </pre>