recursion_memes.cpp

#include <stdio.h>
#include <functional>
#include <unordered_map>

template<template<typename> typename F>
struct fix { F<fix<F>> f; };

enum kind {
  Int, Var, Add, Div, Mul, Sub
};

template<typename A>
struct expr {
  kind tag;
  union {
    int i;
    const char* s;
    struct { A* a,* b; } p;
  };
};

template<typename A, typename B>
expr<B> map(std::function<B(A)> f, expr<A> a) {
  switch (a.tag) {
    case Int:
      expr<B> e1;
      e1.tag = Int;
      e1.i = a.i;
      return e1;
    case Var:
      expr<B> e2;
      e2.tag = Var;
      e2.s = a.s;
      return e2;
    case Add:
    case Div:
    case Mul:
    case Sub:
      expr<B> e3;
      e3.tag = a.tag;
      e3.p.a = new B(f(*a.p.a));
      e3.p.b = new B(f(*a.p.b));
      return e3;
  }
}

template<template<typename> typename F, typename A>
std::function<A(fix<F>)> cata(std::function<A(F<A>)> f) {
  return [f](fix<F> x) {
    return f(map(cata(f), x.f));
  };
}

template<template<typename> typename F, typename A>
std::function<fix<F>(A)> ana(std::function<F<A>(A)> f) {
  return [f](A x) {
    return map(ana(f), f(x));
  };
}

int eval(std::unordered_map<const char*, int> env, fix<expr> e) {
  auto algebra = [&env](expr<int> e) -> int {
    switch (e.tag) {
      case Int:
        return e.i;
      case Var:
        return env[e.s];
      case Add:
        return *e.p.a + *e.p.b;
      case Div:
        return *e.p.a / *e.p.b;
      case Mul:
        return *e.p.a * *e.p.b;
      case Sub:
        return *e.p.a - *e.p.b;
    }
  };
  return cata<expr, int>(algebra)(e);
}

int main() {
  std::unordered_map<const char*, int> env{{"x", 20}, {"y", 6}};
  fix<expr> x; x.f.tag = Var; x.f.s = "x";
  fix<expr> y; y.f.tag = Var; y.f.s = "y";
  fix<expr> ten; ten.f.tag = Int; ten.f.i = 10;
  fix<expr> two; two.f.tag = Int; two.f.i = 2;
  fix<expr> a; a.f.tag = Mul; a.f.p.a = &x; a.f.p.b = &ten;
  fix<expr> b; b.f.tag = Div; b.f.p.a = &y; b.f.p.b = &two;
  fix<expr> e; e.f.tag = Add; e.f.p.a = &a; e.f.p.b = &b;

  printf("%d\n", eval(env, e));
}

recursion_memes.ml

type 'a expr =
  | Int of int
  | Var of string
  | Add of 'a * 'a
  | Div of 'a * 'a
  | Mul of 'a * 'a
  | Sub of 'a * 'a

let map f = function
  | Int _ | Var _ as x -> x
  | Add (x, y) -> Add (f x, f y)
  | Div (x, y) -> Div (f x, f y)
  | Mul (x, y) -> Mul (f x, f y)
  | Sub (x, y) -> Sub (f x, f y)

let rec cata f x = map (cata f) x |> f

let rec ana f x = f x |> map (ana f)

let eval env =
  let algebra = function
    | Int x      -> x
    | Var x      -> List.assoc x env
    | Add (x, y) -> x + y
    | Div (x, y) -> x / y
    | Mul (x, y) -> x * y
    | Sub (x, y) -> x - y
  in
  cata algebra

let pp =
  let algebra = function
    | Int x      -> string_of_int x
    | Var x      -> x
    | Add (x, y) -> Printf.sprintf "(%s + %s)" x y
    | Div (x, y) -> Printf.sprintf "(%s / %s)" x y
    | Mul (x, y) -> Printf.sprintf "(%s * %s)" x y
    | Sub (x, y) -> Printf.sprintf "(%s - %s)" x y
  in
  cata algebra

let fix f x =
  let rec go x y =
    if x <> y then go y (f y)
    else x
  in
  go x (f x)

let rec help = function
  | Int _ as e -> e
  | Var _ as e -> e
  | Add (x, y) ->
     let x', y' = reorder x, reorder y in
     let res = match x', y' with
       | _, Int _ -> Add (y', x')
       | _, _     -> Add (x', y')
     in
     res
  | Div (_, _) as e -> e
  | Mul (x, y) ->
     let x', y' = reorder x, reorder y in
     let res = match x', y' with
       | _, Int _ -> Mul (y', x')
       | _, _     -> Mul (x', y')
     in
     res
  | Sub (_, _) as e -> e
and reorder x = fix help x

let simplify = function
  | Add (Int x, Add (Int y, z)) -> Add (Int (x + y), z)
  | _ as e -> e

let expr = Add (Mul (Var "x", Int 10),
                Div (Var "y", Int  2))

let env = ["x", 20; "y", 6]

let () = Printf.printf "%s = %d\n" (pp expr) (eval env expr)

let () =
  let expr = Add (Int 3, (Add (Var "x", Int 3))) in
  let reordered = reorder expr in
  let simpled = simplify reordered in
  Printf.printf "%s = %s = %s\n" (pp expr) (pp reordered) (pp simpled)