Free/forgetful adjunctions

Adjunctions.scala

import scalaz._, Scalaz._

// Adjunction between `F` and `G` means there is an
// isomorphism between `A => G[B]` and `F[A] => B`.
trait Adjunction[F[_],G[_]] {
  def leftAdjunct[A, B](a: A)(f: F[A] => B): G[B]
  def rightAdjunct[A, B](a: F[A])(f: A => G[B]): B
}

// Adjunction between free and forgetful functor.
// We can think of the forgetful functor as taking `P a => a` to just `a`.
// That is, given `P[A]`, `Forget[P,A] = A`.
trait FreeForgetAdjunction[F[_], P[_]] {
  def left[A,B](f: F[A] => B): A => B
  def right[A,B:P](f: A => B): F[A] => B
}

// Class for pointed sets
case class Pointed[P](point: P)

object Pointed {
  def apply[P](implicit P: Pointed[P]): Pointed[P] = P
}

// `Option[A]` is the free pointed set on `A`.
// It is left-adjoint to the functor that "loses the point".
// The `unit` is `Some` and the `counit` is `fold`.
new FreeForgetAdjunction[Option, Pointed] {
  def left[A,B](f: Option[A] => B): A => B =
    a => f(Some(a))
  def right[A,B:Pointed](f: A => B): Option[A] => B =
    _.fold(Pointed[B].point)(f)
  }

// `List[A]` is the free monoid on `A`.
// It is left-adjoint to the functor that takes `Monoid[M]` to just `M`,
// as witnessed by the singleton list constructor and `foldMap`.
new FreeForgetAdjunction[List, Monoid] {
  def left[A,B](f: List[A] => B): A => B =
    a => f(List(a))
  def right[A,B:Monoid](f: A => B): List[A] => B =
    _.foldRight(Monoid[B].zero)((a, b) => Monoid[B].append(f(a), b))
}

// The higher-kinded case
trait FreeForgetAdjunction[C[_[_],_], P[_[_]]] {
  def left[F[_],G[_]](f: C[F,?] ~> G): F ~> G
  def right[F[_],G[_]:P](f: F ~> G): C[F,?] ~> G
}

// `Free[F,?]` is the free monad on `F`
// It is left-adjoint to the functor that takes `Monad[M]` to just `M`,
// as witnessed by `liftF` and `foldMap`
new FreeForgetAdjunction[Free, Monad] {
  def left[F[_],G[_]](f: Free[F,?] ~> G): F ~> G = new (F ~> G) {
    def apply[A](a: F[A]) = f(Free.liftF(a))
  }
  def right[F[_],G[_]:Monad](f: F ~> G): Free[F,?] ~> G = new (Free[F,?] ~> G) {
    def apply[A](a: Free[F,A]) = a.foldMap(f)
  }
}


////////////

// Monoid adjunction:
// 
// Free -| Forget
// 
// F -| G
// 
// F[A] for a type A is the free monoid generated by A.
// G[M] for a monoid M is the type M, forgetting that it's a monoid.


// Adjunction between free and forgetful functor.
// We can think of the forgetful functor as taking `P a => a` to just `a`.
// That is, given `P[A]`, `Forget[P,A] = A`.
trait FreeForgetAdjunction[F[_], P[_]] {
  def left[A,B](f: F[A] => B): A => B
  def right[A,B:P](f: A => B): F[A] => B
}

// `List[A]` is the free monoid on `A`.
// It is left-adjoint to the functor that takes `Monoid[M]` to just `M`,
// as witnessed by the singleton list constructor and `foldMap`.
new FreeForgetAdjunction[List, Monoid] {
  def left[A,B](f: List[A] => B): A => B =
    a => f(List(a))
  def right[A,B:Monoid](f: A => B): List[A] => B =
    _.foldRight(Monoid[B].zero)((a, b) => Monoid[B].append(f(a), b))

  def unit[A](a: A): List[A] =
    left(identity[List[A]])(a)

  def counit[A:Monoid](as: List[A]): A =
    right(identity[A])(as)

  // So the counit is `fold` in a monoid!
  // `List` is a comonad in the category of monoids.
  //
  // What does the duplicate look like?
  // It gives us the "substructure" of the free monoid.
  // So, one list per element in the original list.
  def duplicate[A:Monoid](as: List[A]): List[List[A]] =
    as.map(unit(_))
}

// The higher-kinded case
trait FreeForgetAdjunction[C[_[_],_], P[_[_]]] {
  def left[F[_],G[_]](f: C[F,?] ~> G): F ~> G
  def right[F[_],G[_]:P](f: F ~> G): C[F,?] ~> G
}

trait CofreeForgetAdjunction[C[_[_],_], P[_[_]]] {
  def left[F[_]:P,G[_]](f: F ~> G): F ~> C[G,?]
  def right[F[_],G[_]](f: F ~> C[G,?]): F ~> G
}

object CofreeComonad extends CofreeForgetAdjunction[Cofree, Comonad] {
  def left[F[_]:Comonad,G[_]](f: F ~> G): F ~> Cofree[G,?] = new (F ~> Cofree[G,?]) {
    def apply[A](as: F[A]) = mapUnfold(as)(f)
  }
  // if `f` generates a G-branching stream, then we get a function `F ~> G` that
  // "skims" the head of all the branches
  def right[F[_]:Functor,G[_]](f: F ~> Cofree[G,?]): F ~> G = new (F ~> G) {
    def apply[A](as: F[A]) = f(as).tail.map(_.head)
  }

  // The unit takes `F[A]` to `Cofree[F,A]` for any comonad `F`
  // `Cofree` is a monad in the category of comonads.
  // The head of the cofree is the counit of the `F` and its tail is `unit` extended over the `F`.
  def unit[F[_]:Comonad]: F ~> Cofree[F,A] =
    left(NaturalTransformation.identity[F])

  // The counit here is the head of the tail.
  // Comonad in an endofunctor category
  def counit[F[_]]: Cofree[F,A] ~> F =
    right(NaturalTransformation.identity[Cofree[F,?]])
}

def mapUnfold[F[_],W[_],A](z: W[A])(f: W ~> F)(implicit W: Comonad[W]): Cofree[F,A]