Ends and Coends

; A profunctor takes two arguments with mixed variance.
; dimap : (c -> a) -> (b -> d) -> P(a,b) -> P(c,d)
; Contravariant in the first argument, covariant in the second.

; The hom-profunctor: P(a,b) = functions from a to b.
; dimap pre-composes on the left, post-composes on the right.

(define (dimap-hom f g h)
  ; f : c -> a (pre-compose)
  ; g : b -> d (post-compose)
  ; h : a -> b (the original morphism)
  (lambda (x) (g (h (f x)))))

; Example: h : Int -> Int is (* 2)
; f : String -> Int is string-length (contravariant)
; g : Int -> String is number->string (covariant)
(define h (lambda (n) (* n 2)))
(define f string-length)
(define g number->string)

(define lifted (dimap-hom f g h))

(display "h(5) = ") (display (h 5)) (newline)
(display "lifted(\"hello\") = ") (display (lifted "hello")) (newline)
; "hello" -> 5 -> 10 -> "10"
; dimap routes through both variance directions.

; Wedge condition: for any f : a -> b,
;   dimap id f . alpha_a  =  dimap f id . alpha_b
;
; Both sides land in P(a,b). The two paths must agree.
;
; Think of a diamond:
;           w
;          / \
;    alpha_a   alpha_b
;        |       |
;      P(a,a)  P(b,b)
;         \     /
;     P(id,f)  P(f,id)
;           \ /
;          P(a,b)

; Concrete: P = Hom, so P(a,a) = (a -> a), P(b,b) = (b -> b)
; alpha_a picks out the identity at each type: alpha_a = id_a
; Wedge condition: (f . id_a) = (id_b . f) -- trivially true!

(define (alpha-id type-name)
  ; The identity function at every type is a wedge for Hom
  (lambda (x) x))

; Check: for f : Int -> String = number->string
(define f number->string)

; Path 1: alpha_Int then post-compose f
; alpha_Int = id, so: f . id = f
(define path1 (lambda (x) (f ((alpha-id 'Int) x))))

; Path 2: alpha_String then pre-compose f
; alpha_String = id, so: id . f = f
(define path2 (lambda (x) ((alpha-id 'String) (f x))))

(display "path1(42): ") (display (path1 42)) (newline)
(display "path2(42): ") (display (path2 42)) (newline)
(display "Wedge condition holds? ") (display (equal? (path1 42) (path2 42)))
; Both paths give "42". The identity family is a wedge.

; End of P = the universal wedge.
; In Haskell: forall a. p a a
; In Set over a finite category: the subset of the product
; of all P(a,a) that satisfies the wedge condition.

; Finite category: objects = {0, 1}, one non-identity morphism f: 0 -> 1
; Profunctor P = Hom, so:
;   P(0,0) = Hom(0,0) = {id_0}
;   P(1,1) = Hom(1,1) = {id_1}
;   P(0,1) = Hom(0,1) = {f}
;   P(1,0) = Hom(1,0) = {}

; A wedge is (w0, w1) in P(0,0) x P(1,1) satisfying:
;   P(id, f)(w0) = P(f, id)(w1)
; i.e., f . w0 = w1 . f

; Only option: w0 = id_0, w1 = id_1
; Check: f . id_0 = f = id_1 . f. Yes!

; The end is a single element: the pair (id_0, id_1).

(define objects '(0 1))

; Morphisms in our category
(define (compose g f)
  (cond ((eq? f 'id-0) g)
        ((eq? g 'id-1) f)
        ((and (eq? f 'id-0) (eq? g 'f01)) 'f01)
        (else 'undefined)))

; All elements of the product P(0,0) x P(1,1)
(define P00 '(id-0))
(define P11 '(id-1))

; Wedge condition: for morphism f: 0 -> 1,
; compose f w0 = compose w1 f
(define (wedge-ok? w0 w1)
  (equal? (compose 'f01 w0) (compose w1 'f01)))

; Find all wedges (= the end)
(define end-elements
  (let loop ((xs P00) (result '()))
    (if (null? xs) (reverse result)
        (let inner ((ys P11) (acc result))
          (if (null? ys) (loop (cdr xs) acc)
              (if (wedge-ok? (car xs) (car ys))
                  (inner (cdr ys) (cons (list (car xs) (car ys)) acc))
                  (inner (cdr ys) acc)))))))

(display "End (universal wedge): ") (display end-elements) (newline)
; ((id-0 id-1)) -- a single element: the identity natural transformation.
(display "This is the set of natural transformations Id => Id.")

; Nat(F,G) = End_a Hom(F(a), G(a))
;
; Category: {0, 1} with f: 0 -> 1
; F = "double": F(0) = 0, F(1) = 2, F(f) = (lambda (x) (* 2 x))
; G = "add-ten": G(0) = 10, G(1) = 11, G(f) = (lambda (x) (+ 10 x))
;
; Wait -- functors on finite categories map objects to sets.
; Let's use a simpler model.

; Category C = {a, b}, one morphism f: a -> b
; F maps: F(a) = {0,1}, F(b) = {0,1,2}, F(f) = identity embedding
; G maps: G(a) = {10,11}, G(b) = {10,11,12}, G(f) = identity embedding

; A natural transformation alpha: F => G needs:
;   alpha_a : F(a) -> G(a)  and  alpha_b : F(b) -> G(b)
;   such that G(f) . alpha_a = alpha_b . F(f)

; Profunctor: P(x,y) = Hom(F(x), G(y))
; End = all (alpha_a, alpha_b) in Hom(F(a),G(a)) x Hom(F(b),G(b))
;   satisfying the wedge (= naturality) condition.

; Simple model: F(a)={0,1}, G(a)={0,1}, F(b)={0,1}, G(b)={0,1}
; F(f) = id, G(f) = id
; Then naturality says: id . alpha_a = alpha_b . id
; i.e., alpha_a = alpha_b

(define Fa '(0 1))
(define Ga '(0 1))

; All functions Fa -> Ga (there are 4)
(define (all-functions domain codomain)
  (if (null? domain) '(())
      (let ((rest (all-functions (cdr domain) codomain)))
        (apply append
          (map (lambda (val)
            (map (lambda (r) (cons (cons (car domain) val) r)) rest))
            codomain)))))

(define hom-fa-ga (all-functions Fa Ga))

; Apply a function-as-alist
(define (apply-fn fn x) (cdr (assoc x fn)))

; Naturality: alpha_a(x) = alpha_b(x) for all x (since F(f)=G(f)=id)
(define (every pred lst) (if (null? lst) #t (if (pred (car lst)) (every pred (cdr lst)) #f)))

(define nat-transformations
  (filter (lambda (pair)
    (let ((alpha-a (car pair)) (alpha-b (cadr pair)))
      (every (lambda (x) (equal? (apply-fn alpha-a x) (apply-fn alpha-b x)))
             Fa)))
    (apply append
      (map (lambda (a) (map (lambda (b) (list a b)) hom-fa-ga))
           hom-fa-ga))))

(display "Number of natural transformations: ")
(display (length nat-transformations)) (newline)
(display "They are (alpha_a = alpha_b):") (newline)
(for-each (lambda (pair)
  (display "  ") (display (car pair)) (newline))
  nat-transformations)
; 4 natural transformations, each determined by alpha_a alone.
; The end enforces alpha_a = alpha_b -- that's naturality.

; Coend = coproduct of all P(a,a), quotiented by dinaturality.
;
; For each f : a -> b, identify:
;   P(id,f)(x)  in P(a,b)  with  P(f,id)(y)  in P(a,b)
;
; Example: P(a,b) = {labeled pairs (a,b)}
; Category: {0, 1, 2}, morphisms: f01: 0->1, f12: 1->2, f02: 0->2

; P(a,a) elements with source labels
(define diagonal-elements
  '((0 . "elem-00")
    (1 . "elem-11")
    (2 . "elem-22")))

; Dinaturality identifications from morphism f01: 0 -> 1
; P(id, f01) sends elem-00 to something in P(0,1)
; P(f01, id) sends elem-11 to something in P(0,1)
; These get identified in the coend.

; Build equivalence classes
(define (union-find elements identifications)
  (let ((parent (map (lambda (e) (cons e e)) elements)))
    (define (find x)
      (let ((p (cdr (assoc x parent))))
        (if (equal? p x) x (find p))))
    (define (union! a b)
      (let ((ra (find a)) (rb (find b)))
        (if (not (equal? ra rb))
          (begin (set! parent
            (map (lambda (p)
              (if (equal? (cdr p) rb) (cons (car p) ra) p))
              parent))))))
    (for-each (lambda (id) (union! (car id) (cdr id))) identifications)
    ; Return equivalence classes
    (let ((classes '()))
      (for-each (lambda (e)
        (let ((root (find e)))
          (let ((existing (assoc root classes)))
            (if existing
                (set-cdr! existing (cons e (cdr existing)))
                (set! classes (cons (cons root (list e)) classes))))))
        elements)
      (map cdr classes))))

(define elements '("elem-00" "elem-11" "elem-22"))

; Identifications from dinaturality:
; f01 identifies elem-00 ~ elem-11
; f12 identifies elem-11 ~ elem-22
(define identifications
  '(("elem-00" . "elem-11")
    ("elem-11" . "elem-22")))

(define coend-classes (union-find elements identifications))

(display "Diagonal elements: ") (display elements) (newline)
(display "After dinaturality quotient:") (newline)
(for-each (lambda (cls)
  (display "  class: ") (display cls) (newline))
  coend-classes)
; All three collapse into one class: the coend is a single point.
; In a connected category, the coend of Hom is a single element.

; Ninja Yoneda (coend version):
; integral^z  C(z,a) x F(z)  ~=  F(a)
;
; Take all pairs (f: z -> a, x in F(z)) and quotient by
; dinaturality. The result is just F(a).
;
; Intuition: the pair (f, x) means "x lives at z,
; and f tells you how to move it to a."
; The quotient says: if you can factor through an intermediate
; object, the result is the same.

; Category: {0, 1, 2}, morphisms include id's and f: 0->1, g: 1->2, gf: 0->2
; Functor F: F(0) = {a,b}, F(1) = {c}, F(2) = {d,e}
; Target: a = 2

; C(z, 2) x F(z) for each z:
;   z=0: C(0,2) x F(0) = {gf} x {a,b} = {(gf,a), (gf,b)}
;   z=1: C(1,2) x F(1) = {g}  x {c}   = {(g,c)}
;   z=2: C(2,2) x F(2) = {id} x {d,e} = {(id,d), (id,e)}

; F on morphisms: F(f)(a)=c, F(f)(b)=c, F(g)(c)=d

; Dinaturality identifies:
;   (gf, a) ~ (g, F(f)(a)) = (g, c) ~ (id, F(g)(c)) = (id, d)
;   (gf, b) ~ (g, F(f)(b)) = (g, c) ~ (id, d)
;   (g, c) ~ (id, d)

; After quotient:
;   class 1: {(gf,a), (gf,b), (g,c), (id,d)}  ~>  d
;   class 2: {(id,e)}                           ~>  e

; Result: {d, e} = F(2) = F(a). Ninja Yoneda confirmed!

(define pairs '((gf a) (gf b) (g c) (id-2 d) (id-2 e)))

; Apply the morphism to get the element in F(a)
(define (evaluate pair)
  (let ((mor (car pair)) (elem (cadr pair)))
    (cond
      ; F(gf)(a) = d, F(gf)(b) = d
      ((eq? mor 'gf) (cond ((eq? elem 'a) 'd) ((eq? elem 'b) 'd)))
      ; F(g)(c) = d
      ((eq? mor 'g)  (cond ((eq? elem 'c) 'd)))
      ; F(id)(x) = x
      ((eq? mor 'id-2) elem))))

(display "Pairs and their images in F(a):") (newline)
(for-each (lambda (p)
  (display "  ") (display p) (display " => ") (display (evaluate p)) (newline))
  pairs)
(display "Image: ") (display (delete-duplicates (map evaluate pairs))) (newline)
(display "F(2) = {d, e}") (newline)
(display "Ninja Yoneda: coend ~= F(a). Confirmed.")