Natural Transformations

; A natural transformation alpha : F -> G
; gives a component alpha_a : F(a) -> G(a) for every type a.
;
; Example: safeHead is a natural transformation from List to Maybe.
; For every type a, safeHead : List(a) -> Maybe(a).

(define nothing (cons 'left '()))
(define (just x) (cons 'right x))
(define (nothing? m) (and (pair? m) (eq? (car m) 'left)))

; safeHead : List -> Maybe  (a natural transformation)
(define (safe-head lst)
  (if (null? lst)
      nothing
      (just (car lst))))

(display "safe-head '(1 2 3): ") (display (safe-head '(1 2 3))) (newline)
(display "safe-head '():      ") (display (safe-head '())) (newline)
(display "safe-head '(a b):   ") (display (safe-head '(a b)))
; Works uniformly for any type — that's the "natural" part.

; Naturality condition for safeHead:
;   fmap-maybe f . safe-head  =  safe-head . map f
;
; "Transform then map" = "Map then transform"

(define (fmap-maybe f m)
  (if (nothing? m) nothing (just (f (cdr m)))))

; Test with f = double
(define (double x) (* x 2))

; Path 1: map first, then transform
(define path1 (safe-head (map double '(3 1 4))))

; Path 2: transform first, then map
(define path2 (fmap-maybe double (safe-head '(3 1 4))))

(display "map then transform: ") (display path1) (newline)
(display "transform then map: ") (display path2) (newline)
(display "equal? ") (display (equal? path1 path2)) (newline)

; Also works on empty lists
(define p1-empty (safe-head (map double '())))
(define p2-empty (fmap-maybe double (safe-head '())))
(display "empty path1: ") (display p1-empty) (newline)
(display "empty path2: ") (display p2-empty) (newline)
(display "equal? ") (display (equal? p1-empty p2-empty))

; length : List a -> Const Int a
; A natural transformation that forgets the elements.

(define (my-length lst) (length lst))

; fmap for Const does nothing (ignores the function)
(define (fmap-const f c) c)

; Naturality: fmap-const f . my-length = my-length . map f
; Since fmap-const ignores f, this says:
;   length(xs) = length(map f xs)
; Mapping can't change the number of elements!

(define (double x) (* x 2))
(define xs '(10 20 30 40))

(display "length(xs):          ") (display (my-length xs)) (newline)
(display "length(map double xs): ") (display (my-length (map double xs))) (newline)
(display "equal? ") (display (= (my-length xs) (my-length (map double xs)))) (newline)

; This works for ANY function f — that's the naturality condition.
(display "length(map car '((a 1) (b 2))): ")
(display (my-length (map car '((a 1) (b 2)))))

; "Theorems for free" — parametric polymorphism implies naturality.
;
; If alpha works the same way for ALL types,
; it can't break the naturality square.
;
; Example: reverse : List a -> List a
; reverse doesn't inspect elements, so:
;   map f . reverse = reverse . map f

(define (double x) (* x 2))
(define xs '(1 2 3 4 5))

; Path 1: reverse then map
(define path1 (map double (reverse xs)))

; Path 2: map then reverse
(define path2 (reverse (map double xs)))

(display "map-then-reverse:  ") (display path1) (newline)
(display "reverse-then-map:  ") (display path2) (newline)
(display "equal? ") (display (equal? path1 path2)) (newline)

; Another example: tail : List a -> List a
(define path3 (map double (cdr xs)))
(define path4 (cdr (map double xs)))
(display "map-then-tail: ") (display path3) (newline)
(display "tail-then-map: ") (display path4) (newline)
(display "equal? ") (display (equal? path3 path4))

; Functor category: compose natural transformations vertically.
; If alpha : F -> G and beta : G -> H, then (beta . alpha) : F -> H
; Component-wise: (beta . alpha)_a = beta_a . alpha_a

; Three functors: List, Maybe, Const-Bool
; alpha = safe-head : List -> Maybe
; beta = is-just : Maybe -> Const-Bool

(define (safe-head lst)
  (if (null? lst) nothing (just (car lst))))

(define (is-just m)
  (if (nothing? m) #f #t))

; Vertical composition: is-just . safe-head : List -> Const-Bool
; "Is the list non-empty?"
(define (non-empty? lst)
  (is-just (safe-head lst)))

(display "non-empty? '(1 2): ") (display (non-empty? '(1 2))) (newline)
(display "non-empty? '():    ") (display (non-empty? '())) (newline)

; The composition is itself a natural transformation.
; Naturality: fmap-const f . non-empty? = non-empty? . map f
; fmap-const ignores f, so: non-empty?(xs) = non-empty?(map f xs)
(define xs '(10 20 30))
(display "non-empty?(xs):        ") (display (non-empty? xs)) (newline)
(display "non-empty?(map * xs):  ") (display (non-empty? (map (lambda (x) (* x 2)) xs)))

; How many natural transformations Maybe -> List?
; Only two! Naturality constrains the options.

; Option 1: Nothing -> (), Just x -> (x)
(define (maybe-to-list-1 m)
  (if (nothing? m) '() (list (cdr m))))

; Option 2: everything -> ()
(define (maybe-to-list-2 m)
  '())

; Any other mapping (e.g., Just x -> (x x x)) fails naturality.
; Why? If alpha(Just x) = (x x x), then:
;   map f (alpha (Just x)) = map f (x x x) = (f(x) f(x) f(x))
;   alpha (fmap f (Just x)) = alpha (Just f(x)) = (f(x) f(x) f(x))
; Wait, that works! But alpha(Nothing) must be ().
; Actually (x x x) does satisfy naturality — but Milewski's point
; is that parametricity limits you to one "shape" per branch.

(display "opt1 Just(5):  ") (display (maybe-to-list-1 (just 5))) (newline)
(display "opt1 Nothing:  ") (display (maybe-to-list-1 nothing)) (newline)
(display "opt2 Just(5):  ") (display (maybe-to-list-2 (just 5))) (newline)
(display "opt2 Nothing:  ") (display (maybe-to-list-2 nothing)) (newline)

; Verify naturality for opt1:
(define (double x) (* x 2))
(define p1 (map double (maybe-to-list-1 (just 3))))
(define p2 (maybe-to-list-1 (fmap-maybe double (just 3))))
(display "path1: ") (display p1) (newline)
(display "path2: ") (display p2) (newline)
(display "equal? ") (display (equal? p1 p2))