Rust Recursion schemes

recursion_schemes.rs

#![allow(unused)]
use std::{borrow::Borrow, convert::Infallible};

trait Functor {
  type F<T>;
  fn fmap<A, B>(f: impl Fn(A) -> B, x: Self::F<A>) -> Self::F<B>;
}

trait Rec: Sized {
  type Fix;
  type F: Functor;
  fn fmap<A, B>(f: impl Fn(A) -> B) -> impl Fn(<Self::F as Functor>::F<A>) -> <Self::F as Functor>::F<B> {
    move |x| <Self::F as Functor>::fmap(&f, x)
  }

  fn prj(t: Self::Fix) -> <Self::F as Functor>::F<Self::Fix>;
  fn inj(t: <Self::F as Functor>::F<Self::Fix>) -> Self::Fix;

  // these should be in an extension trait

  fn fmap_ref<A>(x: &<Self::F as Functor>::F<A>) -> <Self::F as Functor>::F<&A>;
}

fn cata<R: Rec, Ret>(alg: impl Fn(RecF<R, Ret>) -> Ret) -> impl Fn(R::Fix) -> Ret {
  fn cata_<'a, R: Rec, Ret>(alg: &'a impl Fn(RecF<R, Ret>) -> Ret) -> impl Fn(R::Fix) -> Ret + 'a {
    move |x| alg(R::fmap(cata_::<R, Ret>(alg))(R::prj(x)))
  }
  move |x| cata_::<R, Ret>(&alg)(x)
}

type RecF<R, T> = <<R as Rec>::F as Functor>::F<T>;

fn ana<R: Rec, Seed>(coalg: impl Fn(Seed) -> RecF<R, Seed>) -> impl Fn(Seed) -> R::Fix {
  fn ana_<'a, R: Rec, Seed>(coalg: &'a impl Fn(Seed) -> RecF<R, Seed>) -> impl Fn(Seed) -> R::Fix + 'a {
    move |x| R::inj(R::fmap(ana_::<R, Seed>(coalg))(coalg(x)))
  }
  move |x| ana_::<R, Seed>(&coalg)(x)
}
fn hylo<R: Rec, Seed, Ret>(alg: impl Fn(RecF<R, Ret>) -> Ret, coalg: impl Fn(Seed) -> RecF<R, Seed>) -> impl Fn(Seed) -> Ret {
  fn hylo_<'a, 'b, R: Rec, Seed, Ret>(alg: &'a impl Fn(RecF<R, Ret>) -> Ret, coalg: &'a impl Fn(Seed) -> RecF<R, Seed>) -> impl Fn(Seed) -> Ret + 'a {
    move |x| alg(R::fmap(hylo_::<R, Seed, Ret>(alg, coalg))(coalg(x)))
  }
  move |x| hylo_::<R,Seed, Ret>(&alg, &coalg)(x)
}

fn accumulation<R: Rec, Acc, Ret>(st: impl Fn(RecF<R, R::Fix>, &Acc) -> RecF<R, (R::Fix, Acc)>, alg: impl Fn(RecF<R, Ret>, Acc) -> Ret) -> impl Fn((R::Fix, Acc)) -> Ret {
  fn accumulation_<'a, R: Rec, Acc, Ret>(st: &'a impl Fn(RecF<R, R::Fix>, &Acc) -> RecF<R, (R::Fix, Acc)>, alg: &'a impl Fn(RecF<R, Ret>, Acc) -> Ret) -> impl Fn((R::Fix, Acc)) -> Ret +'a {
    move |(x, acc)| alg(R::fmap(accumulation_::<R, Acc, Ret>(st, alg))(st(R::prj(x), &acc)), acc)
  }
  move |x| accumulation_::<R,Acc,Ret>(&st, &alg)(x)
}

/// the mutumorphism is different than in the literature in that it computes both mutually recursive functions
/// and returns both results of both.
/// This is the most reasonable way to do with without introducing the Clone trait.
/// So this is limited to having a consuming function, and an inspecting function
fn mutu<R: Rec, A, B>(alg1: impl Fn(RecF<R, (A, B)>) -> A, alg2: impl Fn(&RecF<R, (A, B)>) -> B) -> impl Fn(R::Fix) -> (A, B) {
  cata::<R, (A, B)>(move |x| {
    let alg2_ = alg2(&x);
    (alg1(x), alg2_)
  })
}

// This function cannot be used as is naively, it can only be used efficiently with
// persistant datatypes
fn para<R: Rec, Ret>(alg: impl Fn(RecF<R, (R::Fix, Ret)>) -> Ret) -> impl Fn(R::Fix) -> Ret
where
  R::Fix: Clone,
{
  fn para_<'a, R: Rec, Ret>(alg: &'a impl Fn(RecF<R, (R::Fix, Ret)>) -> Ret) -> impl Fn(R::Fix) -> Ret + 'a
  where
    R::Fix: Clone, {
    move |x|{
      let map = move |y: R::Fix| (y.clone(), para_::<R, Ret>(alg)(y));
      alg(R::fmap(map)(R::prj(x)))
    }
  }
  move |x| para_::<R,Ret>(&alg)(x)
}

trait RecPrjRef: Rec {
  fn prj_ref(t: &Self::Fix) -> <Self::F as Functor>::F<&Self::Fix>;
}

fn para_ref<R: RecPrjRef, Ret>(alg: impl Fn(RecF<R, (&R::Fix, Ret)>) -> Ret) -> impl Fn(&R::Fix) -> Ret {
  fn para_ref_<'a, R: RecPrjRef, Ret>(alg: &'a impl Fn(RecF<R, (&R::Fix, Ret)>) -> Ret) -> impl Fn(&R::Fix) -> Ret + 'a {
    move |x| alg(R::fmap(|y| (y, para_ref_::<R, Ret>(alg)(y)))(R::prj_ref(x)))
  }
  move|x| para_ref_::<R,Ret>(&alg)(x)
}

fn apo<R: Rec, Seed>(coalg: impl Fn(Seed) -> RecF<R, std::ops::ControlFlow<R::Fix, Seed>>) -> impl Fn(Seed) -> R::Fix {
  move |x| {
    let coalg = &coalg;
    R::inj(R::fmap(move |y| match y {
      std::ops::ControlFlow::Continue(x) => apo::<R, Seed>(coalg)(x),
      std::ops::ControlFlow::Break(x) => x,
    })(coalg(x)))
  }
}

fn zygo<R: Rec, Ret, Aux>(alg1: impl Fn(RecF<R, (Ret, Aux)>) -> Ret, alg2: impl Fn(RecF<R, &Aux>) -> Aux) -> impl Fn(R::Fix) -> Ret
where
  Aux: Clone,
{
  move |x| mutu::<R, Ret, Aux>(&alg1, |y| alg2(R::fmap(|(_, a): &(_, _)| a)(R::fmap_ref(y))))(x).0
}

enum Free<F: Functor, A> {
  Ret(A),
  Op(F::F<Free<F, A>>),
}
impl<F: Functor, A> Free<F, A> {
  fn advance(coalg: impl Fn(A) -> F::F<Self>) -> impl Fn(Self) -> F::F<Self> {
    move |x| match x {
      Free::Ret(a) => coalg(a),
      Free::Op(k) => k,
    }
  }
}

struct Cofree<F: Functor, A> {
  tag: A,
  cofree: F::F<Cofree<F, A>>,
}

impl<F: Functor, A> Cofree<F, A> {
  fn extract(self) -> A {
    self.tag
  }
  fn extend(alg: impl Fn(&F::F<Self>) -> A) -> impl Fn(F::F<Self>) -> Self {
    move |x| Cofree { tag: alg(&x), cofree: x }
  }
}

fn histo<R: Rec, Ret>(alg: impl Fn(&RecF<R, Cofree<R::F, Ret>>) -> Ret) -> impl Fn(R::Fix) -> Ret {
  move |x| Cofree::extract(cata::<R, Cofree<R::F, Ret>>(Cofree::extend(&alg))(x))
}

fn dyna<R: Rec, Seed, Ret>(alg: impl Fn(&RecF<R, Cofree<R::F, Ret>>) -> Ret, coalg: impl Fn(Seed) -> RecF<R, Seed>) -> impl Fn(Seed) -> Ret {
  move |x| Cofree::extract(hylo::<R, Seed, Cofree<R::F, Ret>>(Cofree::extend(&alg), &coalg)(x))
}

fn futu<R: Rec, Seed>(coalg: impl Fn(Seed) -> RecF<R, Free<R::F, Seed>>) -> impl Fn(Seed) -> R::Fix {
  move |x| {
    let coalg = &coalg;
    ana::<R, _>(Free::<R::F, Seed>::advance(coalg))(Free::<R::F, Seed>::Ret(x))
  }
}

#[derive(Debug)]
pub enum BinaryTree {
  Leaf(i32),
  Branch(Box<BinaryTree>, Box<BinaryTree>),
}

fn l(i: i32) -> BinaryTree {
  BinaryTree::Leaf(i)
}

fn b(l: BinaryTree, r: BinaryTree) -> BinaryTree {
  BinaryTree::Branch(Box::new(l), Box::new(r))
}

pub enum FBinaryTree<T = Infallible> {
  Leaf(i32),
  Branch(T, T),
}

impl Functor for FBinaryTree {
  type F<T> = FBinaryTree<T>;
  fn fmap<A, B>(f: impl Fn(A) -> B, x: Self::F<A>) -> Self::F<B> {
    match x {
      FBinaryTree::Leaf(n) => FBinaryTree::Leaf(n),
      FBinaryTree::Branch(l, r) => FBinaryTree::Branch(f(l), f(r)),
    }
  }
}

impl Rec for BinaryTree {
  type Fix = Self;
  type F = FBinaryTree;

  fn inj(t: <Self::F as Functor>::F<Self>) -> Self {
    match t {
      FBinaryTree::Leaf(n) => BinaryTree::Leaf(n),
      FBinaryTree::Branch(l, r) => BinaryTree::Branch(Box::new(l), Box::new(r)),
    }
  }
  fn prj(t: Self) -> <Self::F as Functor>::F<Self> {
    match t {
      BinaryTree::Leaf(n) => FBinaryTree::Leaf(n),
      BinaryTree::Branch(l, r) => FBinaryTree::Branch(*l, *r),
    }
  }
  fn fmap_ref<A>(x: &<Self::F as Functor>::F<A>) -> <Self::F as Functor>::F<&A> {
    match x {
      FBinaryTree::Leaf(n) => FBinaryTree::Leaf(*n),
      FBinaryTree::Branch(l, r) => FBinaryTree::Branch(l, r),
    }
  }
}

enum Nat<T = Infallible> {
  S(T),
  Z,
}

impl Functor for Nat {
  type F<T> = Nat<T>;
  fn fmap<A, B>(f: impl Fn(A) -> B, x: Self::F<A>) -> Self::F<B> {
    match x {
      Nat::S(n) => Nat::S(f(n)),
      Nat::Z => Nat::Z,
    }
  }
}

impl Rec for u8 {
  type Fix = Self;
  type F = Nat;

  fn prj(t: Self) -> <Self::F as Functor>::F<Self> {
    match t {
      0 => Nat::Z,
      n => Nat::S(n - 1),
    }
  }
  fn inj(t: <Self::F as Functor>::F<Self>) -> Self {
    match t {
      Nat::S(n) => n + 1,
      Nat::Z => 0,
    }
  }

  fn fmap_ref<A>(x: &<Self::F as Functor>::F<A>) -> <Self::F as Functor>::F<&A> {
    match x {
      Nat::S(n) => Nat::S(n),
      Nat::Z => Nat::Z,
    }
  }
}

fn g() {
  let tree_ = ana::<BinaryTree, i32>(&|x| match x {
    0 => FBinaryTree::Leaf(0),
    b => FBinaryTree::Branch(b / 2, b / 2),
  })(10);
  println!("tree : {tree_:#?}");

  // let count = cata_::<BinaryTree,usize>(
  //   &|x| match x {
  //       FBinaryTree::Leaf(_) => 1,
  //       FBinaryTree::Branch(l, r) => l+r,
  //   })(tree_);
  // println!("count : {count:?}");

  let n = ana::<u8, BinaryTree>(&|x| match x {
    BinaryTree::Leaf(_) => Nat::Z,
    BinaryTree::Branch(l, r) => match *l {
      BinaryTree::Leaf(_) => Nat::S(*r),
      BinaryTree::Branch(l1, r1) => Nat::S(b(*l1, b(*r1, *r))),
    },
  })(tree_);
  // println!("n : {n:?}");

  let double = cata::<u8, u16>(|x| match x {
    Nat::S(n) => {
      println!("S");
      2 + n
    }
    Nat::Z => {
      println!("Z");
      0
    }
  })(n);
  println!("double : {double:?}");

  let wtf = cata::<u8, Box<dyn FnOnce(u16) -> u16>>(|x| match x {
    Nat::S(f) => Box::new(|x| f(x + 2)),
    Nat::Z => Box::new(|x| x),
  })(n);

  println!("wtf(0) : {:?}", wtf(0));

  let tree = b(b(l(1), l(2)), b(b(l(3), l(4)), l(5)));

  let sum = cata::<BinaryTree, Box<dyn FnOnce(isize) -> isize>>(|x| match x {
    FBinaryTree::Leaf(n) => Box::new(move |x| {
      println!("L");
      x + n as isize
    }),
    FBinaryTree::Branch(l, r) => Box::new(|x| {
      println!("B");
      l(r(x))
    }),
  })(tree);
  println!("sum : {}", sum(0));
}

fn main() {
  g()
}