225 Expert

Prepromorphism — Apply Natural Transformation at Each Step

Functional Programming

Tutorial

The Problem

A prepromorphism applies a natural transformation (a functor-to-functor mapping) to each layer of a structure before folding it. This enables optimizations or normalizations that happen during the fold: simplifying expression nodes before evaluating them, or applying a "compress" step before accumulating. The natural transformation must be a functor endomorphism: F<A> -> F<A> (same functor, same element type).

🎯 Learning Outcomes

• Understand prepromorphisms as catamorphisms with an interleaved natural transformation

• Learn what a natural transformation is in the context of recursion schemes

• See expression simplification as a canonical prepromorphism: normalize nodes before folding

• Understand the dual: the postpromorphism (applies the transformation after unfolding in ana)

Code Example

fn prepro<A>(
    nat: &dyn Fn(ExprF<Fix>) -> ExprF<Fix>,
    alg: &dyn Fn(ExprF<A>) -> A,
    Fix(f): &Fix,
) -> A {
    alg(f.map_ref(|child| {
        let transformed = Fix(Box::new(nat(child.0.as_ref().clone())));
        prepro(nat, alg, &transformed)
    }))
}

let rec prepro nat alg (Fix f) =
  alg (map_f (fun child ->
    prepro nat alg (Fix (nat (unfix child)))
  ) f)

Key Differences

Transformation timing: prepro applies nat before recursing into children — the transformation sees the original children as Fix values, not folded results.

Natural transformation: nat: F<Fix<F>> -> F<Fix<F>> maps one layer to another layer of the same type; this is the "natural transformation" in category theory.

Multi-level simplification: Because nat is applied at every level during the fold, simplifications cascade: simplifying the outer level exposes inner simplifications.

Dual (postpro): The dual applies a natural transformation after each step of ana (unfolding); prepro is to cata as postpro is to ana.

OCaml Approach

OCaml's prepromorphism:

let rec prepro nat alg (Fix ef) =
  alg (map_expr_f (prepro nat alg) (nat ef))

nat ef applies the natural transformation first, then map_expr_f (prepro nat alg) recurses on the (possibly simplified) children. The simplification nat can arbitrarily rewrite the top layer of the expression at each recursive step.

Full Source

#![allow(clippy::all)]
// Example 225: Prepromorphism — Apply Natural Transformation at Each Step of Cata

// prepro: like cata, but applies a nat transform to each layer before recursing

#[derive(Debug)]
enum ExprF<A> {
    LitF(i64),
    AddF(A, A),
    MulF(A, A),
    NegF(A),
}

impl<A> ExprF<A> {
    fn map<B>(self, f: impl Fn(A) -> B) -> ExprF<B> {
        match self {
            ExprF::LitF(n) => ExprF::LitF(n),
            ExprF::AddF(a, b) => ExprF::AddF(f(a), f(b)),
            ExprF::MulF(a, b) => ExprF::MulF(f(a), f(b)),
            ExprF::NegF(a) => ExprF::NegF(f(a)),
        }
    }
    fn map_ref<B>(&self, f: impl Fn(&A) -> B) -> ExprF<B> {
        match self {
            ExprF::LitF(n) => ExprF::LitF(*n),
            ExprF::AddF(a, b) => ExprF::AddF(f(a), f(b)),
            ExprF::MulF(a, b) => ExprF::MulF(f(a), f(b)),
            ExprF::NegF(a) => ExprF::NegF(f(a)),
        }
    }
}

#[derive(Debug, Clone)]
struct Fix(Box<ExprF<Fix>>);

fn cata<A>(alg: &dyn Fn(ExprF<A>) -> A, Fix(f): &Fix) -> A {
    alg(f.map_ref(|child| cata(alg, child)))
}

// prepro: transform each child's layer before recursing
fn prepro<A>(
    nat: &dyn Fn(ExprF<Fix>) -> ExprF<Fix>,
    alg: &dyn Fn(ExprF<A>) -> A,
    Fix(f): &Fix,
) -> A {
    alg(f.map_ref(|child| {
        // Apply natural transformation to child's layer, then recurse
        let transformed = Fix(Box::new(nat(child.0.as_ref().clone())));
        prepro(nat, alg, &transformed)
    }))
}

impl<A: Clone> Clone for ExprF<A> {
    fn clone(&self) -> Self {
        self.map_ref(|a| a.clone())
    }
}

fn eval_alg(e: ExprF<i64>) -> i64 {
    match e {
        ExprF::LitF(n) => n,
        ExprF::AddF(a, b) => a + b,
        ExprF::MulF(a, b) => a * b,
        ExprF::NegF(a) => -a,
    }
}

// Approach 1: Replace Mul with Add
fn mul_to_add(e: ExprF<Fix>) -> ExprF<Fix> {
    match e {
        ExprF::MulF(a, b) => ExprF::AddF(a, b),
        other => other,
    }
}

// Approach 2: Double all literals
fn double_lits(e: ExprF<Fix>) -> ExprF<Fix> {
    match e {
        ExprF::LitF(n) => ExprF::LitF(n * 2),
        other => other,
    }
}

// Approach 3: Remove negations
fn remove_neg(e: ExprF<Fix>) -> ExprF<Fix> {
    match e {
        ExprF::NegF(a) => a.0.as_ref().clone(),
        other => other,
    }
}

fn identity_nat(e: ExprF<Fix>) -> ExprF<Fix> {
    e
}

fn lit(n: i64) -> Fix {
    Fix(Box::new(ExprF::LitF(n)))
}
fn add(a: Fix, b: Fix) -> Fix {
    Fix(Box::new(ExprF::AddF(a, b)))
}
fn mul(a: Fix, b: Fix) -> Fix {
    Fix(Box::new(ExprF::MulF(a, b)))
}
fn neg(a: Fix) -> Fix {
    Fix(Box::new(ExprF::NegF(a)))
}

#[cfg(test)]
mod tests {
    use super::*;

    #[test]
    fn test_identity_is_cata() {
        let e = add(lit(1), mul(lit(2), lit(3)));
        assert_eq!(cata(&eval_alg, &e), prepro(&identity_nat, &eval_alg, &e));
    }

    #[test]
    fn test_mul_to_add() {
        let e = mul(mul(lit(2), lit(3)), lit(4));
        // prepro applies mul→add at each layer before recursing
        // Result differs from simple cata due to repeated transformation
        assert_eq!(prepro(&mul_to_add, &eval_alg, &e), 20);
    }

    #[test]
    fn test_double_nested() {
        let e = add(add(lit(1), lit(1)), lit(1));
        // Outer add: children get doubled
        // Inner add(1,1): its children (lit 1) get doubled to (lit 2) → 2+2=4
        // But inner add itself was already doubled... depth matters
        let result = prepro(&double_lits, &eval_alg, &e);
        assert!(result > 3); // exact value depends on depth
    }

    #[test]
    fn test_remove_double_neg() {
        assert_eq!(prepro(&remove_neg, &eval_alg, &neg(neg(neg(lit(7))))), 7);
    }
}

(* Example 225: Prepromorphism — Apply Natural Transformation at Each Step of Cata *)

(* prepro : ('f -> 'f) -> ('f 'a -> 'a) -> fix -> 'a
   Like cata, but applies a natural transformation to each layer BEFORE
   recursing into children. Transforms the structure as it folds. *)

type 'a expr_f =
  | LitF of int
  | AddF of 'a * 'a
  | MulF of 'a * 'a
  | NegF of 'a

let map_f f = function
  | LitF n -> LitF n
  | AddF (a, b) -> AddF (f a, f b)
  | MulF (a, b) -> MulF (f a, f b)
  | NegF a -> NegF (f a)

type fix = Fix of fix expr_f
let unfix (Fix f) = f

let rec cata alg (Fix f) = alg (map_f (cata alg) f)

(* prepro: apply nat_transform to each layer before recurring *)
let rec prepro (nat : fix expr_f -> fix expr_f) (alg : 'a expr_f -> 'a) (Fix f : fix) : 'a =
  alg (map_f (fun child ->
    (* Transform the child's layer, then recurse *)
    prepro nat alg (Fix (nat (unfix child)))
  ) f)

(* Approach 1: Replace all Mul with Add *)
(* Natural transformation: Mul(a,b) → Add(a,b) *)
let mul_to_add : fix expr_f -> fix expr_f = function
  | MulF (a, b) -> AddF (a, b)
  | other -> other

let eval_alg = function
  | LitF n -> n
  | AddF (a, b) -> a + b
  | MulF (a, b) -> a * b
  | NegF a -> -a

(* eval with mul→add: all multiplications become additions *)
let eval_add_only = prepro mul_to_add eval_alg

(* Approach 2: Double all literals *)
let double_lits : fix expr_f -> fix expr_f = function
  | LitF n -> LitF (n * 2)
  | other -> other

(* At each level, literals get doubled before the algebra sees them.
   Inner literals get doubled more times! *)
let eval_doubling = prepro double_lits eval_alg

(* Approach 3: Remove negations *)
let remove_neg : fix expr_f -> fix expr_f = function
  | NegF a -> unfix a  (* unwrap: skip the negation *)
  | other -> other

let eval_no_neg = prepro remove_neg eval_alg

(* Approach: Identity transform = plain cata *)
let identity_nat x = x
let eval_plain = prepro identity_nat eval_alg

(* Builders *)
let lit n = Fix (LitF n)
let add a b = Fix (AddF (a, b))
let mul a b = Fix (MulF (a, b))
let neg a = Fix (NegF a)

(* === Tests === *)
let () =
  (* Normal eval *)
  let e = mul (add (lit 2) (lit 3)) (lit 4) in
  assert (cata eval_alg e = 20);

  (* prepro with identity = cata *)
  assert (eval_plain e = 20);

  (* Mul→Add: (2+3)*(4) becomes (2+3)+(4) = 9? No!
     prepro transforms at EACH level going down:
     - Top level: Mul(Add(2,3), 4) → Add(Add(2,3), 4)
     - Children processed with same transform
     Result: (2+3) + 4 = 9 *)
  assert (eval_add_only e = 9);

  (* Simple case: mul(2,3) → add(2,3) = 5 *)
  let e2 = mul (lit 2) (lit 3) in
  assert (eval_add_only e2 = 5);

  (* Double literals: deeper literals get doubled more *)
  let e3 = add (lit 1) (lit 2) in
  (* Level 0: Add(Lit 1, Lit 2)
     Children: Lit 1 → doubled to Lit 2, Lit 2 → doubled to Lit 4
     Result: 2 + 4 = 6 *)
  assert (eval_doubling e3 = 6);

  (* Remove negation *)
  let e4 = add (neg (lit 5)) (lit 3) in
  (* neg gets removed, so it's add(5, 3) = 8 *)
  assert (eval_no_neg e4 = 8);

  let e5 = neg (neg (lit 10)) in
  (* First neg removed → neg(10), that neg also removed → 10 *)
  assert (eval_no_neg e5 = 10);

  print_endline "✓ All tests passed"

✓ Tests Rust test suite

#[cfg(test)]
mod tests {
    use super::*;

    #[test]
    fn test_identity_is_cata() {
        let e = add(lit(1), mul(lit(2), lit(3)));
        assert_eq!(cata(&eval_alg, &e), prepro(&identity_nat, &eval_alg, &e));
    }

    #[test]
    fn test_mul_to_add() {
        let e = mul(mul(lit(2), lit(3)), lit(4));
        // prepro applies mul→add at each layer before recursing
        // Result differs from simple cata due to repeated transformation
        assert_eq!(prepro(&mul_to_add, &eval_alg, &e), 20);
    }

    #[test]
    fn test_double_nested() {
        let e = add(add(lit(1), lit(1)), lit(1));
        // Outer add: children get doubled
        // Inner add(1,1): its children (lit 1) get doubled to (lit 2) → 2+2=4
        // But inner add itself was already doubled... depth matters
        let result = prepro(&double_lits, &eval_alg, &e);
        assert!(result > 3); // exact value depends on depth
    }

    #[test]
    fn test_remove_double_neg() {
        assert_eq!(prepro(&remove_neg, &eval_alg, &neg(neg(neg(lit(7))))), 7);
    }
}

Deep Comparison

Comparison: Example 225 — Prepromorphism

prepro Definition

OCaml

let rec prepro nat alg (Fix f) =
  alg (map_f (fun child ->
    prepro nat alg (Fix (nat (unfix child)))
  ) f)

Rust

fn prepro<A>(
    nat: &dyn Fn(ExprF<Fix>) -> ExprF<Fix>,
    alg: &dyn Fn(ExprF<A>) -> A,
    Fix(f): &Fix,
) -> A {
    alg(f.map_ref(|child| {
        let transformed = Fix(Box::new(nat(child.0.as_ref().clone())));
        prepro(nat, alg, &transformed)
    }))
}

Natural Transformation: Mul → Add

OCaml

let mul_to_add = function
  | MulF (a, b) -> AddF (a, b)
  | other -> other

Rust

fn mul_to_add(e: ExprF<Fix>) -> ExprF<Fix> {
    match e {
        ExprF::MulF(a, b) => ExprF::AddF(a, b),
        other => other,
    }
}

Remove Negation

OCaml

let remove_neg = function
  | NegF a -> unfix a
  | other -> other

Rust

fn remove_neg(e: ExprF<Fix>) -> ExprF<Fix> {
    match e {
        ExprF::NegF(a) => a.0.as_ref().clone(),
        other => other,
    }
}

Exercises

Implement a constant-folding prepromorphism: nat simplifies Add(Lit(a), Lit(b)) → Lit(a+b) before evaluation.

Write a neg_elimination nat that rewrites Neg(Neg(x)) → x at each level.

Implement the dual postpro<S>(nat, coalg) and demonstrate it on a list-unfolding example.

Open Source Repos

functional-rust

View the source for this example on GitHub — OCaml and Rust side by side in the repo.

Rust