ct.scala

package test

import scala.language.higherKinds

object CT {
    trait Category[Obj[_],C[_,_]] { // Obj is the value representation of objects, C the type representation of morphisms
        def id[A:Obj]: C[A,A]
        def compose[X:Obj,Y:Obj,Z:Obj](f: C[Y,Z], g: C[X,Y]): C[X,Z]
    }
    
    abstract class Functor[ObjC[_],HomC[_,_],ObjD[_],HomD[_,_],F[_]](implicit val c: Category[ObjC,HomC],implicit val d: Category[ObjD,HomD]) {
        def fmap[A:ObjC,B:ObjC](f: HomC[A,B]):HomD[F[A],F[B]] 
        implicit def apply[A:ObjC] : ObjD[F[A]]
    }

    abstract class Monad[Obj[_],Hom[_,_],M[_] ](implicit val C: Category[Obj,Hom]) extends Functor[Obj,Hom,Obj,Hom,M]{
        def unit[A:Obj]:Hom[A,M[A]]
        def bind[A:Obj,B:Obj](f: Hom[A,M[B]]) : Hom[M[A],M[B]]
        def fmap[A:Obj, B:Obj](f: Hom[A,B]): Hom[M[A],M[B]] = bind(C.compose(unit, f))
        
    }

    abstract class Comonad[Obj[_],Hom[_,_],M[_] ](implicit val C: Category[Obj,Hom]) extends Functor[Obj,Hom,Obj,Hom,M] {
        def counit[A:Obj]:Hom[M[A],A]
        def cobind[A:Obj,B:Obj](f: Hom[M[A],B]) : Hom[M[A],M[B]]
        def fmap[A:Obj, B:Obj](f: Hom[A,B]): Hom[M[A],M[B]] = {
            cobind(C.compose(f,counit))
        }
    }

    abstract class Adjunction[CObj[_],CHom[_,_],DObj[_],DHom[_,_],F[_],G[_]]
      (val F: Functor[CObj,CHom,DObj,DHom,F], val G: Functor[DObj,DHom,CObj,CHom,G])(implicit val C: Category[CObj,CHom], D: Category[DObj,DHom]) { ad =>
        protected implicit def ev[A:CObj] : DObj[F[A]] = F(implicitly)
        protected implicit def ev2[A:CObj] : CObj[G[F[A]]] = G(F(implicitly))
        protected implicit def ev3[B:DObj] : CObj[G[B]] = G(implicitly[DObj[B]])
        protected implicit def ev4[B:DObj] : DObj[F[G[B]]] = F(G(implicitly))
          
        def unit[A:CObj]: CHom[A,G[F[A]]]
        def counit[A: DObj]: DHom[F[G[A]],A]  
        def leftAdjunct[A:CObj,B:DObj](f : DHom[F[A],B]) : CHom[A,G[B]] = {
           C.compose(G.fmap(f),unit)
       }
        def rightAdjunct[A:CObj,B:DObj](f : CHom[A,G[B]]) : DHom[F[A],B] = {
           D.compose(counit(implicitly[DObj[B]]),F.fmap(f))
       }
        def monad : Monad[CObj,CHom,({type λ[α] = G[F[α]]})#λ] = new Monad[CObj,CHom,({type λ[α] = G[F[α]]})#λ]{
            def bind[A:CObj, B:CObj](f: CHom[A,G[F[B]]]): CHom[G[F[A]],G[F[B]]] = G.fmap(rightAdjunct(f))
            def unit[A:CObj]:CHom[A,G[F[A]]] = ad.unit
            def apply[A: CObj] : CObj[G[F[A]]] = implicitly
        } 
        def comonad : Comonad[DObj,DHom,({type λ[α] = F[G[α]]})#λ] = new Comonad[DObj,DHom,({type λ[α] = F[G[α]]})#λ] {
            def counit[A:DObj] = ad.counit
            def cobind[A:DObj,B:DObj](f: DHom[F[G[A]],B]) : DHom[F[G[A]],F[G[B]]] = F.fmap(leftAdjunct(f))
            def apply[A:DObj] : DObj[F[G[A]]] = implicitly          
        }
    }

    // The category of Scala types and functions
    
    implicit object ScalO {}
    type ScalObj[A] = ScalO.type  // no value representation of the objects (= Scala types)
    type ScalHom[A,B] = A => B
    
    implicit object Scal extends Category[ScalObj,ScalHom] {
        def id[A:ScalObj] = (x:A) => x
        def compose[X:ScalObj,Y:ScalObj,Z:ScalObj](f: Y=>Z, g: X=>Y ): X=>Z = f.compose(g)
    }

    // The category of monoids
    trait Monoid[M] {
        def plus(x: M, y: M) : M
        def zero : M
    }
    
    type MonHom[M,N] = M => N
    type MonObj[M] = Monoid[M]

    implicit object Mon extends Category[MonObj,MonHom] {
        def id[A:Monoid] = (x: A) => x
        def compose[X:Monoid,Y:Monoid,Z:Monoid](f: Y=>Z, g: X=>Y): X=>Z = f.compose(g)
    }

    // some concrete monoids    
    def freeMonoid[M] = new Monoid[List[M]] {
        def plus(x: List[M], y: List[M]) = x ++ y
        def zero = List.empty
    }
    
    def intplusMonoid = new Monoid[Int] {
        def plus(x: Int, y: Int) = x+y
        def zero = 0
    }
    
    // The free/forgetful adjunction for monoids:
    
    object FreeMonoidFunctor extends Functor[ScalObj,ScalHom,MonObj,MonHom,List] {
        def fmap[A:ScalObj,B:ScalObj](f: A=>B) : List[A] => List[B] = m => m.map(f) 
        def apply[A:ScalObj] : MonObj[List[A]] = freeMonoid[A]
    }
    
    object MonoidForgetFunctor extends Functor[MonObj,MonHom,ScalObj,ScalHom,({type λ[α] = α})#λ] {
        def fmap[A:MonObj,B:MonObj](f: A=>B) =f
        def apply[A:MonObj] = ScalO
    }
    
    object FreeForgetfulMonoidAdjunction extends Adjunction[ScalObj,ScalHom,MonObj,MonHom,List,({type λ[α] = α})#λ](FreeMonoidFunctor,MonoidForgetFunctor) {
        def counit[A:MonObj]: List[A] => A = as => as.foldRight(implicitly[Monoid[A]].zero)(implicitly[Monoid[A]].plus _)
        def unit[A:ScalObj]: A => List[A] = a => List(a)
    }
    
    // just for completeness, the curry/uncurry adjunction
    def pairFunctor[S] = new Functor[ScalObj,ScalHom,ScalObj,ScalHom,({type λ[α] = (S, α)})#λ] {
        def fmap[A:ScalObj,B:ScalObj](f: A=>B) = (p) => (p._1,f(p._2)) 
        def apply[A: ScalObj] = ScalO
    }

    def readerFunctor[S] = new Functor[ScalObj,ScalHom,ScalObj,ScalHom,({type λ[α] = S => α})#λ] {
        def fmap[A:ScalObj,B:ScalObj](f: A=>B) = g => s => f(g(s))
        def apply[A: ScalObj] = ScalO
    }
    def CurryUncurryAdjunction[S] = new Adjunction[ScalObj,ScalHom,ScalObj,ScalHom,({type λ[α] = (S,α)})#λ,({type λ[α] = S => α})#λ](pairFunctor,readerFunctor)  {
        def counit[A:ScalObj] = p  => p._2(p._1)
        def unit[A:ScalObj]: A => S => (S, A) = a => s => (s,a)
    } 

    // The category of partial orders
    trait PartialOrder[T] {
        def leq(x: T, y: T) : Boolean
    }
    
    def PosetCategory[T](po: PartialOrder[T]) = new Category[({type λ[α] = T})#λ, ({type λ[X,Y] = (T,T)})#λ] {
        def compose[X, Y, Z](f: (T, T), g: (T, T))(implicit x: T, y: T, z: T) = (x,z)
        def id[A](implicit o: T): (T,T) = (o,o)
    }
    
    // the category of sets partially ordered by subset inclusion
    implicit def subsetPO[T] = PosetCategory(new PartialOrder[Set[T]] { def leq(x: Set[T], y:Set[T]) = x.subsetOf(y) })
    
    // the category of integer intervals ordered by interval inclusion
    implicit def intervalPO = PosetCategory[(Int,Int)](new PartialOrder[(Int,Int)] { def leq(x: (Int,Int), y: (Int,Int)) = x._1 >= y._1 && x._2 <= y._2 })
    
    // the Galois connection between sets of integers and integer intervals
    def abstractionFunctor = new Functor[({type λ[α] = Set[Int]})#λ,
                                         ({type λ[X,Y] = (Set[Int],Set[Int])})#λ,
                                         ({type λ[α] = (Int,Int)})#λ, 
                                         ({type λ[X,Y] = ((Int,Int),(Int,Int))})#λ,
                                         ({type λ[X] = (Int,Int)})#λ]()(subsetPO[Int],intervalPO) {
       override def apply[A](implicit x: Set[Int]): (Int,Int) = (x.min, x.max)
       override def fmap[A, B](f: (Set[Int],Set[Int]))(implicit x: Set[Int], y: Set[Int]): ((Int, Int),(Int,Int)) = (this(f._1),this(f._2))                                           
    }
    def concretizationFunctor = new Functor[({type λ[α] = (Int,Int)})#λ, 
                                         ({type λ[X,Y] = ((Int,Int),(Int,Int))})#λ,
                                         ({type λ[α] = Set[Int]})#λ,
                                         ({type λ[X,Y] = (Set[Int],Set[Int])})#λ,
                                         ({type λ[X] = Set[Int]})#λ]()(intervalPO,subsetPO[Int]) {
       def apply[A](implicit x: (Int,Int)): Set[Int] = (x._1 to x._2).toSet
       def fmap[A, B](f: ((Int,Int),(Int,Int)))(implicit x: (Int,Int), y: (Int,Int)): (Set[Int],Set[Int]) = (this(f._1),this(f._2))                                           
    }
    
    object GaloisConnection extends Adjunction[({type λ[α] = Set[Int]})#λ,
                                               ({type λ[X,Y] = (Set[Int],Set[Int])})#λ,
                                               ({type λ[α] = (Int,Int)})#λ, 
                                               ({type λ[X,Y] = ((Int,Int),(Int,Int))})#λ,
                                               ({type λ[X] = (Int,Int)})#λ,
                                               ({type λ[X] = Set[Int]})#λ](abstractionFunctor,concretizationFunctor)  {
       def counit[A](implicit x: (Int, Int)): ((Int, Int), (Int, Int)) = (x,x)                                                   
       def unit[A](implicit x: Set[Int]): (Set[Int], Set[Int]) = (x,x)
    }
  
}