https://ocaml.org/learn/tutorials/99problems.html#Multiway-Trees

graphs.re

type graph_term('a) = {
  nodes: list('a),
  edges: list(('a, 'a)),
};

let example_graph = {
  nodes: ['b', 'c', 'd', 'f', 'g', 'h', 'k'],
  edges: [('h', 'g'), ('k', 'f'), ('f', 'b'), ('f', 'c'), ('c', 'b')],
};

let neighbors = (g, a, cond) => {
  let edge = (l, (b, c)) =>
    if (b == a && cond(c)) {
      [c, ...l];
    } else if (c == a && cond(b)) {
      [b, ...l];
    } else {
      l;
    };
  List.fold_left(edge, [], g.edges);
};

let rec list_path = (g, a, to_b) =>
  switch (to_b) {
  | [] => assert false
  | [a', ..._] =>
    if (a' == a) {
      [to_b];
    } else {
      let n = neighbors(g, a', c => ! List.mem(c, to_b));
      List.concat(List.map(c => list_path(g, a, [c, ...to_b]), n));
    }
  };

let paths = (g, a, b) => {
  assert (a != b);
  list_path(g, a, [b]);
};

let cycles = (g, a) => {
  let n = neighbors(g, a, (_) => true);
  let p = List.concat(List.map(c => list_path(g, a, [c]), n));
  List.map(p => p @ [a], p);
};

type labeled_graph('a, 'b) = {
  nodes: list('a),
  labeled_edges: list(('a, 'a, 'b)),
};

let g = {
  nodes: ['a', 'b', 'c', 'd', 'e', 'f', 'g', 'h'],
  labeled_edges: [
    ('a', 'b', 5),
    ('a', 'd', 3),
    ('b', 'c', 2),
    ('b', 'e', 4),
    ('c', 'e', 6),
    ('d', 'e', 7),
    ('d', 'f', 4),
    ('d', 'g', 3),
    ('e', 'h', 5),
    ('f', 'g', 4),
    ('g', 'h', 1),
  ],
};

module type GRAPH = {
  type node = char;
  type t;
  let of_adjacency: list((node, list(node))) => t;
  let dfs_fold: (t, node, ('a, node) => 'a, 'a) => 'a;
};

module M: GRAPH = {
  module Char_map = Map.Make(Char);
  type node = char;
  type t = Char_map.t(list(node));
  let of_adjacency = l =>
    List.fold_right(((x, y)) => Char_map.add(x, y), l, Char_map.empty);
  type colors =
    | White
    | Gray
    | Black;
  type state('a) = {
    d: Char_map.t(int),
    f: Char_map.t(int),
    pred: Char_map.t(char),
    color: Char_map.t(colors),
    acc: 'a,
  };
  let dfs_fold = (g, c, fn, acc) => {
    let rec dfs_visit = (t, u, {d, f, pred, color, acc}) => {
      let edge = ((t, state), v) =>
        if (Char_map.find(v, state.color) == White) {
          dfs_visit(t, v, {...state, pred: Char_map.add(v, u, state.pred)});
        } else {
          (t, state);
        };
      let (t, {d, f, pred, color, acc}) = {
        let t = t + 1;
        List.fold_left(
          edge,
          (
            t,
            {
              d: Char_map.add(u, t, d),
              f,
              pred,
              color: Char_map.add(u, Gray, color),
              acc: fn(acc, u),
            },
          ),
          Char_map.find(u, g),
        );
      };
      let t = t + 1;
      (
        t,
        {
          d,
          f: Char_map.add(u, t, f),
          pred,
          color: Char_map.add(u, Black, color),
          acc,
        },
      );
    };
    let v =
      List.fold_left((k, (x, _)) => [x, ...k], [], Char_map.bindings(g));
    let initial_state = {
      d: Char_map.empty,
      f: Char_map.empty,
      pred: Char_map.empty,
      color: List.fold_right(x => Char_map.add(x, White), v, Char_map.empty),
      acc,
    };
    snd(dfs_visit(0, c, initial_state)).acc;
  };
};

let g =
  M.of_adjacency([
    ('u', ['v', 'x']),
    ('v', ['y']),
    ('w', ['z', 'y']),
    ('x', ['v']),
    ('y', ['x']),
    ('z', ['z']),
  ]);

let res = List.rev(M.dfs_fold(g, 'w', (acc, c) => [c, ...acc], []));

let identifier = {
  let is_letter = c => 'a' <= c && c <= 'z';
  let is_letter_or_digit = c => is_letter(c) || '0' <= c && c <= '9';
  let rec is_valid = (s, i, not_after_dash) =>
    if (i < 0) {
      not_after_dash;
    } else if (is_letter_or_digit(s.[i])) {
      is_valid(s, i - 1, true);
    } else if (s.[i] == '-' && not_after_dash) {
      is_valid(s, i - 1, false);
    } else {
      false;
    };
  s => {
    let n = String.length(s);
    n > 0 && is_letter(s.[n - 1]) && is_valid(s, n - 2, true);
  };
};

Js.log(identifier("foo-"));

logic.re

type bool_expr =
  | Var(string)
  | Not(bool_expr)
  | And(bool_expr, bool_expr)
  | Or(bool_expr, bool_expr);

let ex = And(Or(Var("a"), Var("b")), And(Var("a"), Var("b")));

let rec eval2 = (a, val_a, b, val_b) =>
  fun
  | Var(x) =>
    if (x == a) {
      val_a;
    } else if (x == b) {
      val_b;
    } else {
      failwith("The expression contains an invalid variable");
    }
  | Not(e) => ! eval2(a, val_a, b, val_b, e)
  | And(e1, e2) =>
    eval2(a, val_a, b, val_b, e1) && eval2(a, val_a, b, val_b, e2)
  | Or(e1, e2) =>
    eval2(a, val_a, b, val_b, e1) || eval2(a, val_a, b, val_b, e2);

let table2 = (a, b, expr) => [
  (true, true, eval2(a, true, b, true, expr)),
  (true, false, eval2(a, true, b, false, expr)),
  (false, true, eval2(a, false, b, true, expr)),
  (false, false, eval2(a, false, b, false, expr)),
];

let table2ex = table2("a", "b", And(Var("a"), Or(Var("a"), Var("b"))));

let rec eval = val_vars =>
  fun
  | Var(x) => List.assoc(x, val_vars)
  | Not(e) => ! eval(val_vars, e)
  | [@implicit_arity] And(e1, e2) =>
    eval(val_vars, e1) && eval(val_vars, e2)
  | [@implicit_arity] Or(e1, e2) =>
    eval(val_vars, e1) || eval(val_vars, e2);

let rec table_make = (val_vars, vars, expr) =>
  switch (vars) {
  | [] => [(List.rev(val_vars), eval(val_vars, expr))]
  | [v, ...tl] =>
    table_make([(v, true), ...val_vars], tl, expr)
    @ table_make([(v, false), ...val_vars], tl, expr)
  };

let table = (vars, expr) => table_make([], vars, expr);

let tableEx = table(["a", "b"], And(Var("a"), Or(Var("a"), Var("b"))));

let gray = n => {
  let rec gray_next_level = (k, l) =>
    if (k < n) {
      /* This is the core part of the Gray code construction.
       * first_half is reversed and has a "0" attached to every element.
       * Second part is reversed (it must be reversed for correct gray code).
       * Every element has "1" attached to the front.*/
      let (first_half, second_half) =
        List.fold_left(
          ((acc1, acc2), x) => (["0" ++ x, ...acc1], ["1" ++ x, ...acc2]),
          ([], []),
          l,
        );
      /* List.rev_append turns first_half around and attaches it to second_half.
       * The result is the modified first_half in correct order attached to
       * the second_half modified in reversed order.*/
      gray_next_level(k + 1, List.rev_append(first_half, second_half));
    } else {
      l;
    };
  gray_next_level(1, ["0", "1"]);
};

Js.log(gray(3));

multi-way-tree.re

type graph('a) =
  | Par(graph('a), 'a, graph('a))
  | Seq(graph('a), 'a, graph('a))
  | Root('a, graph('a))
  | Leaff('a);

let g = Root("root", Leaff("leaf 1"));

type mult_tree('a) =
  | T('a, list(mult_tree('a)));

let rec count_nodes = (T(_, sub)) =>
  List.fold_left((n, t) => n + count_nodes(t), 1, sub);

let t' = T('g', [T('g', []), T('g', [])]);

let t =
  T(
    'a',
    [
      T('f', [T('g', [T('g', [])])]),
      T('c', []),
      T('b', [T('d', []), T('e', [])]),
    ],
  );
/* We could build the final string by string concatenation but
   this is expensive due to the number of operations.  We use a
   buffer instead. */
let rec add_string_of_tree = (buf, T(c, sub)) => {
  Buffer.add_char(buf, c);
  List.iter(add_string_of_tree(buf), sub);
  Buffer.add_char(buf, '^');
};

let string_of_tree = t => {
  let buf = Buffer.create(128);
  add_string_of_tree(buf, t);
  Buffer.contents(buf);
};

let rec tree_of_substring = (t, s, i, len) =>
  if (i >= len || s.[i] == '^') {
    (List.rev(t), i + 1);
  } else {
    let (sub, j) = tree_of_substring([], s, i + 1, len);
    tree_of_substring([T(s.[i], sub), ...t], s, j, len);
  };

let tree_of_string = s =>
  switch (tree_of_substring([], s, 0, String.length(s))) {
  | ([t], _) => t
  | _ => failwith("tree_of_string")
  };

let rec ipl_sub = (len, T(_, sub)) =>
  List.fold_left((sum, t) => sum + ipl_sub(len + 1, t), len, sub);

let ipl = t => ipl_sub(0, t);

let rec prepend_bottom_up = ([@implicit_arity] T(c, sub), l) =>
  List.fold_right((t, l) => prepend_bottom_up(t, l), sub, [c, ...l]);

let bottom_up = t => prepend_bottom_up(t, []);

let rec add_lispy = buf =>
  fun
  | T(c, []) => Buffer.add_char(buf, c)
  | T(c, sub) => {
      Buffer.add_char(buf, '(');
      Buffer.add_char(buf, c);
      List.iter(
        t => {
          Buffer.add_char(buf, ' ');
          add_lispy(buf, t);
        },
        sub,
      );
      Buffer.add_char(buf, ')');
    };

let lispy = t => {
  let buf = Buffer.create(128);
  add_lispy(buf, t);
  Buffer.contents(buf);
};

Js.log(lispy(t));

nonorgamms.re

type element =
  | Empty
  | X; /* ensure we do not miss cases in patterns */

/* Whether [row.(c)] for [col0 ≤ c < col1] are all set to [X]. */
let rec is_set_range = (row, col0, col1) =>
  col0 >= col1 || row[col0] == X && is_set_range(row, col0 + 1, col1);

/* Whether all [row.(ncol)] .. [row.(ncol + width - 1)] equal [X]. */
let is_set_sub = (row, col0, width) =>
  col0 + width <= Array.length(row) && is_set_range(row, col0, col0 + width);

/* Check that [row.(col0 ..)] conforms the pattern [patt_row]. */
let rec check_row = (row, col0, patt_row) =>
  if (col0 >= Array.length(row)) {
    patt_row == [];
  } else {
    /* row exhausted, no pattern must remain */
    switch (row[col0]) {
    | Empty => check_row(row, col0 + 1, patt_row)
    | X =>
      switch (patt_row) {
      | [] => false
      | [nX, ...tl] =>
        if (is_set_sub(row, col0, nX)) {
          let col0 = col0 + nX;
          (col0 >= Array.length(row) || row[col0] == Empty)
          && check_row(row, col0 + 1, tl);
        } else {
          false;
        }
      }
    };
  };

/* Check that each row of the table conforms [patts_row].  It is
   assumed that the length of [patts_row] is equal to the number of
   lines of [table]. */
let rec check_rows = (table, row0, patts_row) =>
  row0 >= Array.length(table)
  || (
    switch (patts_row) {
    | [patt_row, ...tl] =>
      check_row(table[row0], 0, patt_row) && check_rows(table, row0 + 1, tl)
    | [] => assert false
    }
  );

let char_of_element =
  fun
  | Empty => '_'
  | X => 'X';

let print_tbl = table => {
  let print_row = r => {
    Array.iter(
      e => {
        print_char('|');
        print_char(char_of_element(e));
      },
      r,
    );
    print_string("|\n");
  };
  Array.iter(print_row, table);
};

let solve = (patts_row, patts_col) => {
  let height = List.length(patts_row)
  and width = List.length(patts_col);
  let table = Array.make_matrix(height, width, Empty);
  /* Generate all possibilities for columns and filter according
     to row patterns.  [patts_col] are the patterns left for the
     current column. */
  let rec gen = (col, row, patts_col) =>
    if (col >= width) {
      if (check_rows(table, 0, patts_row)) {
        print_tbl(table);
      };
    } else {
      switch (patts_col) {
      | [[], ...rest_patt] =>
        /* No pattern left for this column, go to the next one. */
        gen(col + 1, 0, rest_patt)
      | [[nX, ...tl], ...rest_patt] =>
        assert (nX > 0);
        if (row + nX <= height) {
          for (r in row to row + nX - 1) {
            table[r][col] = X;
          };
          gen(col, row + nX + 1, [tl, ...rest_patt]);
          for (r in row to row + nX - 1) {
            table[r][col] = Empty;
          };
          /* Try the same pattern from next row: */
          gen(col, row + 1, patts_col);
        };
      | [] => assert false
      };
    };
  gen(0, 0, patts_col);
};

Js.log(
  solve(
    [
      [14],
      [1, 1],
      [7, 1],
      [3, 3],
      [2, 3, 2],
      [2, 3, 2],
      [1, 3, 6, 1, 1],
      [1, 8, 2, 1],
      [1, 4, 6, 1],
      [1, 3, 2, 5, 1, 1],
      [1, 5, 1],
      [2, 2],
      [2, 1, 1, 1, 2],
      [6, 5, 3],
      [12],
    ],
    [
      [7],
      [2, 2],
      [2, 2],
      [2, 1, 1, 1, 1],
      [1, 2, 4, 2],
      [1, 1, 4, 2],
      [1, 1, 2, 3],
      [1, 1, 3, 2],
      [1, 1, 1, 2, 2, 1],
      [1, 1, 5, 1, 2],
      [1, 1, 7, 2],
      [1, 6, 3],
      [1, 1, 3, 2],
      [1, 4, 3],
      [1, 3, 1],
      [1, 2, 2],
      [2, 1, 1, 1, 1],
      [2, 2],
      [2, 2],
      [7],
    ],
  ),
);

pointer.re

type pointer('a) =
  | Null
  | Pointer(ref('a));

let (!^) =
  fun
  | Null => invalid_arg("Attempt to dereference the null pointer")
  | Pointer(r) => r^;

let (^:=) = (p, v) =>
  switch (p) {
  | Null => invalid_arg("Attempt to assign the null pointer")
  | Pointer(r) => r := v
  };

let new_pointer = x => Pointer(ref(x));

let p = new_pointer(0);

p ^:= 1;

!^p;

type ilist = pointer(icell)
and icell = {
  mutable hd: int,
  mutable tl: ilist,
};

let new_cell = () => {hd: 0, tl: Null};

let cons = (x, l) => {
  let c = new_cell();
  c.hd = x;
  c.tl = l;
  (new_pointer(c): ilist);
};

let hd = (l: ilist) => (!^l).hd;

let tl = (l: ilist) => (!^l).tl;

type lists('a) = pointer(cell('a))
and cell('a) = {
  mutable hd: pointer('a),
  mutable tl: lists('a),
};

let new_cell = () => {hd: Null, tl: Null};

let cons = (x, l) => {
  let c = new_cell();
  c.hd = new_pointer(x);
  c.tl = l;
  (new_pointer(c): lists('a));
};

let hd = (l: lists('a)) => (!^l).hd;

let tl = (l: lists('a)) => (!^l).tl;

let append = (l1: lists('a), l2: lists('a)) => {
  let temp = ref(l1);
  while (tl(temp^) != Null) {
    temp := tl(temp^);
  };
  (!^temp^).tl = l2;
};

sudoku.re

open Printf;

module Board = {
  type t = array(int);
  let is_valid = c => c >= 1;
  let get = (b: t, (x, y)) => b[x + y * 9];
  let get_as_string = (b: t, pos) => {
    let i = get(b, pos);
    if (is_valid(i)) {
      string_of_int(i);
    } else {
      ".";
    };
  };
  let with_val = (b: t, (x, y), v) => {
    let b = Array.copy(b);
    b[x + y * 9] = v;
    b;
  };
  let of_list = l : t => {
    let b = Array.make(81, 0);
    List.iteri(
      (y, r) =>
        List.iteri(
          (x, e) =>
            b[x + y * 9] = (
              if (e >= 0 && e <= 9) {
                e;
              } else {
                0;
              }
            ),
          r,
        ),
      l,
    );
    b;
  };
  let print = b =>
    for (y in 0 to 8) {
      for (x in 0 to 8) {
        printf(
          if (x == 0) {
            "%s";
          } else if (x mod 3 == 0) {
            " | %s";
          } else {
            "  %s";
          },
          get_as_string(b, (x, y)),
        );
      };
      if (y < 8) {
        if (y mod 3 == 2) {
          printf("\n");
          printf("--------+---------+--------");
          printf("\n");
        } else {
          printf("\n");
          printf("        |         |        ");
          printf("\n");
        };
      } else {
        printf("\n");
      };
    };
  let available = (b, (x, y)) => {
    let avail = Array.make(10, true);
    for (i in 0 to 8) {
      avail[get(b, (x, i))] = false;
      avail[get(b, (i, y))] = false;
    };
    let sq_x = x - x mod 3
    and sq_y = y - y mod 3;
    for (x in sq_x to sq_x + 2) {
      for (y in sq_y to sq_y + 2) {
        avail[get(b, (x, y))] = false;
      };
    };
    let av = ref([]);
    for (i in 1 to 9) {
      if (avail[i]) {
        av := [i, ...av^];
      };
    };
    av^;
  };
  let next = ((x, y)) =>
    if (x < 8) {
      (x + 1, y);
    } else {
      (0, y + 1);
    };
  /** Try to fill the undecided entries. */
  let rec fill = (b, (x, y) as pos) =>
    if (y > 8) {
      Some(b);
    } else if (is_valid(get(b, pos))) {
      fill(b, next(pos));
    } else {
      switch (available(b, pos)) {
      | [] => None
      | l => try_values(b, pos, l)
      };
    }
  and try_values = (b, pos) =>
    fun
    | [v, ...l] =>
      switch (fill(with_val(b, pos, v), next(pos))) {
      | Some(_) as res => res
      | None => try_values(b, pos, l)
      }
    | [] => None;
};

let sudoku = b =>
  switch (Board.fill(b, (0, 0))) {
  | Some(b) => b
  | None => failwith("sudoku: no solution")
  };

let initial_board =
  Board.of_list([
    [0, 0, 4, 8, 0, 0, 0, 1, 7],
    [6, 7, 0, 9, 0, 0, 0, 0, 0],
    [5, 0, 8, 0, 3, 0, 0, 0, 4],
    [3, 0, 0, 7, 4, 0, 1, 0, 0],
    [0, 6, 9, 0, 0, 0, 7, 8, 0],
    [0, 0, 1, 0, 6, 9, 0, 0, 5],
    [1, 0, 0, 0, 8, 0, 3, 0, 6],
    [0, 0, 0, 0, 0, 6, 0, 9, 1],
    [2, 4, 0, 0, 0, 1, 5, 0, 0],
  ]);

Board.print(sudoku(initial_board));

trees.re

type binary_tree('a) =
  | Empty
  | Node('a, binary_tree('a), binary_tree('a));

let add_trees_with = (left, right, all) => {
  let add_right_tree = (all, l) =>
    List.fold_left(
      (a, r) => [[@implicit_arity] Node('x', l, r), ...a],
      all,
      right,
    );
  List.fold_left(add_right_tree, all, left);
};

let rec cbal_tree = n =>
  if (n == 0) {
    [Empty];
  } else if (n mod 2 == 1) {
    let t = cbal_tree(n / 2);
    add_trees_with(t, t, []);
  } else {
    let t1 = cbal_tree(n / 2 - 1);
    let t2 = cbal_tree(n / 2);
    add_trees_with(t1, t2, add_trees_with(t2, t1, []));
  };

let example_tree =
  Node(
    'a',
    Node('b', Node('d', Empty, Empty), Node('e', Empty, Empty)),
    Node('c', Empty, Node('f', Node('g', Empty, Empty), Empty)),
  );

let rec is_mirror = (t1, t2) =>
  switch (t1, t2) {
  | (Empty, Empty) => true
  | (Node(_, l1, r1), Node(_, l2, r2)) =>
    is_mirror(l1, r2) && is_mirror(r1, l2)
  | _ => false
  };

let is_symmetric =
  fun
  | Empty => true
  | Node(_, l, r) => is_mirror(l, r);

let example = cbal_tree(4);

Js.log(example);

let rec insert = (tree, x) =>
  switch (tree) {
  | Empty => Node(x, Empty, Empty)
  | Node(y, l, r) =>
    if (x == y) {
      tree;
    } else if (x < y) {
      Node(y, insert(l, x), r);
    } else {
      Node(y, l, insert(r, x));
    }
  };

let construct = l => List.fold_left(insert, Empty, l);

Js.log3(
  construct([3, 2, 5, 7, 1]),
  is_symmetric(construct([5, 3, 18, 1, 4, 12, 21])),
  ! is_symmetric(construct([3, 2, 5, 7, 4])),
);

let sym_cbal_trees = n => List.filter(is_symmetric, cbal_tree(n));

Js.log((
  List.length(sym_cbal_trees(57)),
  List.map(n => (n, List.length(sym_cbal_trees(n)))),
));

let rec hbal_tree = n =>
  if (n == 0) {
    [Empty];
  } else if (n == 1) {
    [[@implicit_arity] Node('x', Empty, Empty)];
  } else {
    let t1 = hbal_tree(n - 1)
    and t2 = hbal_tree(n - 2);
    add_trees_with(
      t1,
      t1,
      add_trees_with(t1, t2, add_trees_with(t2, t1, [])),
    );
  };

let rec split_n = (lst, acc, n) =>
  switch (n, lst) {
  | (0, _) => (List.rev(acc), lst)
  | (_, []) => (List.rev(acc), [])
  | (_, [h, ...t]) => split_n(t, [h, ...acc], n - 1)
  };

let rec myflatten = (p, c) =>
  switch (p, c) {
  | (p, []) => List.map(x => [@implicit_arity] Node(x, Empty, Empty), p)
  | ([x, ...t], [y]) => [
      [@implicit_arity] Node(x, y, Empty),
      ...myflatten(t, []),
    ]
  | ([ph, ...pt], [x, y, ...t]) => [
      [@implicit_arity] Node(ph, x, y),
      ...myflatten(pt, t),
    ]
  | _ => invalid_arg("myflatten")
  };

let complete_binary_tree =
  fun
  | [] => Empty
  | lst => {
      let rec aux = l => (
        fun
        | [] => []
        | lst => {
            let (p, c) = split_n(lst, [], 1 lsl l);
            myflatten(p, aux(l + 1, c));
          }
      );
      List.hd(aux(0, lst));
    };

Js.log(complete_binary_tree([1, 2, 3, 4, 5, 6]));