Example of transformable irregular data type in OCaml

irregular_tree.ml

(** Irregular representation of a binary leaf tree.
 *)
type 'item t =
  | Leaf of 'item
  | Branch of ('item * 'item) t


(** Some examples of such trees:
 *)
let test_tuple0_3 = ((0, 1), (2, 3))
let test_tuple4_7 = ((4, 5), (6, 7))

let test_tree0_3 = Branch (Branch (Leaf test_tuple0_3))
let test_tree4_7 = Branch (Branch (Leaf test_tuple4_7))
let test_tree = Branch (Branch (Branch (Leaf (test_tuple0_3, test_tuple4_7))))


(** Length of initial 'Branch (Branch (Branch ... ))' constructor list of
 *  a irregular tree structure is equal to the height of representing
 *  binary leaf tree.
 *)
let rec height : 'item. 'item t -> int = function
  | Leaf _ -> 0
  | Branch tail -> 1 + height tail


(** If you have two instances of an irregular tree with the same heights,
 *  you can join them to build a single tree with doubled number of
 *  items and a height increased by one. Of course, join operation
 *  is not commutative.
 *)
let rec join : 'item. 'item t -> 'item t -> 'item t = fun left right ->
  match (left, right) with
  | (Leaf l, Leaf r) -> Branch (Leaf (l, r))
  | (Branch l, Branch r) -> Branch (join l r)
  | _ -> failwith "join failed: joining irregular trees has different heights"


(** If you have an irregular tree of height greater than zero, you can
 *  split it into two equal sized trees of heights decreased by one.
 *)
let rec split : 'item. 'item t -> 'item t * 'item t = function
  | Branch (Leaf (l, r)) -> (Leaf l, Leaf r)
  | Branch tail ->
      let (l, r) = split tail in
      (Branch l, Branch r)
  | Leaf _ -> failwith "split failed: can't split a leaf!"


(** Fold irregular tree with binary operation.
 *)
let rec fold (combine : 'item -> 'item -> 'item) (tree : 'item t) : 'item =
  match tree with
  | Leaf item -> item
  | Branch _ as whole ->
    let (l, r) = split whole in
    combine (fold combine l) (fold combine r)


(** Fold list of irregular tree items, obtained in symmetric order, from right.
 *)
let fold_right (combine : 'item -> 'acc -> 'acc) (init : 'acc) (tree : 'item t) : 'acc =
  let rec fold acc = function
    | Leaf item -> combine item acc
    | Branch _ as whole ->
        let (l, r) = split whole in
        fold (fold acc r) l
  in
  fold init tree


(** Flatten an irregular tree to list of items in symmetric order.
 *)
let to_list (tree : 'item t) : 'item list =
  fold_right (fun head tail -> head :: tail) [] tree


(** Build an irregular tree as big as possible from a list of items.
 *  Note that size of an irregular tree is always like 2 ^ height of it.
 *  Builded tree will satisfy the equations:
 *
 *    from_list (to_list tree) = tree        (1)
 *
 *    to_list (from_list items) = prefix    (2)
 *      where items = prefix @ suffix,
 *            length suffix < length prefix.
 *)
let from_list (items : 'item list) : 'item t =
  let rec from_list_with_size items size =
    match (items, size) with
    | (head :: tail, 1) -> (Leaf head, tail)
    | _ ->
        let (left_subtree, rest) = from_list_with_size items (size / 2) in
        let (right_subtree, rest') = from_list_with_size rest (size / 2) in
        (join left_subtree right_subtree, rest')
  in
  let numof_items = List.length items in
  if numof_items = 0 then
    failwith "from_list: can't build an irregular tree from an empty list!";
  fst (from_list_with_size items numof_items)


(** Ordinary map.
 *)
let rec map transform = function
  | Leaf item -> Leaf (transform item)
  | Branch _ as whole ->
      let (l, r) = split whole in
      join (map transform l) (map transform r)


(** Make string represenation of an irregular tree logic structure. For example,
 *
 *    show string_of_int (Branch (Branch (Leaf ((0, 1), (2, 3))))) =
 *      "Branch (Branch (Leaf 0, Leaf 1), Branch (Leaf 2, Leaf 3))"
 *)
let show ?(leaf_label="Leaf ") ?(branch_label="Branch ")
         (string_of_item : 'item -> string) (tree : 'item t) : string =
  map (fun item -> leaf_label ^ string_of_item item) tree
  |> fold (Printf.sprintf "%s(%s, %s)" branch_label)


(** Make string representation of an irregular tree internals. Result will be
 *  correct OCaml expression, which can be parsed back to the same tree.
 *  For example,
 *
 *    show_repr string_of_int (Branch (Branch (Leaf ((0, 1), (2, 3))))) =
 *      = "Branch (Branch (Leaf ((0, 1), (2, 3))))"
 *)
let show_repr (string_of_item : 'item -> string) (tree : 'item t) : string =
  let tuple_tree =
    show ~leaf_label:"" ~branch_label:"" string_of_item tree
  in
  let tree_height = height tree in
  let height_prefix =
    String.concat "" (Array.to_list (Array.make tree_height "Branch ("))
  in
  height_prefix ^ "Leaf " ^ tuple_tree ^ (String.make tree_height ')')


(** Build one-item tree.
 *)
let singleton item = Leaf item



let test_height () =
  assert (height (Leaf "0") = 0);
  assert (height test_tree0_3 = 2);
  assert (height test_tree4_7 = 2);
  assert (height test_tree = 3)

let test_join () =
  assert (join test_tree0_3 test_tree4_7 = test_tree);
  assert (join (Branch (Leaf (2, 3))) (Branch (Leaf (0, 1))) <> test_tree0_3)

let test_split () =
  assert (split test_tree0_3 = (Branch (Leaf (0, 1)), Branch (Leaf (2, 3))));
  let (l, r) = split test_tree in
  assert (l = test_tree0_3);
  assert (r = test_tree4_7)

let test_fold () =
  let some_tree = Branch (Branch (Branch (Leaf (
      ((10,  7),  (3,  4)),  ((11,  2),  (8,  12))))))
  in
  let expected =
      ((10 - 7) - (3 - 4)) - ((11 - 2) - (8 - 12))
  in
  let actual = fold ( - ) some_tree in
  assert (actual = expected)

let test_fold_right () =
  assert (fold_right ( + ) 0 test_tree = 28);
  let actual =
    fold_right (fun item acc -> string_of_int item ^ acc) "" test_tree
  in
  let expected = "01234567" in
  assert (actual = expected)

let test_to_list () =
  let actual = to_list test_tree in
  let expected = [0; 1; 2; 3; 4; 5; 6; 7] in
  assert (actual = expected)

let test_from_list () =
  let test_list = [0; 1; 2; 3; 4; 5; 6; 7] in
  let actual = from_list test_list in
  let actual2 = from_list (test_list @ [8]) in
  let actual3 = from_list (test_list @ [8; 9]) in
  let actual4 = from_list (test_list @ [8; 9; 10; 11; 12; 13; 14]) in
  let expected = test_tree in
  assert (actual = expected);
  assert (actual2 = expected);
  assert (actual3 = expected);
  assert (actual4 = expected);
  let big_list = test_list @ test_list in
  assert (from_list big_list = join test_tree test_tree)


let gen_random_list size =
  Array.init size (fun _ -> Random.int (1 lsl 30 - 1))
  |> Array.to_list

let massive_check_equations check_equations =
  for size = 1 to 1000 do
    check_equations size
  done;
  for i = 1 to 10 do
    check_equations (Random.int 100000 + 1000)
  done


let test_to_and_from_list () =
  let check_equation_1 tree =
    from_list (to_list tree) = tree
  in
  let rec chop_prefix prefix whole =
    match (prefix, whole) with
    | ([], _) -> Some whole
    | (prefix_hd :: prefix_tl, whole_hd :: whole_tl) when prefix_hd = whole_hd ->
        chop_prefix prefix_tl whole_tl
    | _ -> None
  in
  let check_equation_2 items =
    let prefix = to_list (from_list items) in
    match chop_prefix prefix items with
    | None -> false
    | Some suffix -> List.length suffix < List.length prefix
  in
  let check_equations size =
    let random_list = gen_random_list size in
    assert (check_equation_1 (from_list random_list));
    assert (check_equation_2 random_list)
  in
  massive_check_equations check_equations

let test_map () =
  let actual = map (fun x -> x + 10) test_tree0_3 in
  let expected = Branch (Branch (Leaf ((10, 11), (12, 13)))) in
  assert (actual = expected);
  let check_identity_equation size =
    let random_tree = from_list (gen_random_list size) in
    map succ (map pred random_tree) = random_tree
  in
  massive_check_equations check_identity_equation

let test_show () =
  let actual = show string_of_int test_tree0_3 in
  let expected = "Branch (Branch (Leaf 0, Leaf 1), Branch (Leaf 2, Leaf 3))" in
  assert (actual = expected)

let test_show_repr () =
  let actual = show_repr string_of_int test_tree0_3 in
  let expected = "Branch (Branch (Leaf ((0, 1), (2, 3))))" in
  assert (actual = expected)


let run_test : (unit -> unit) -> string -> unit =
  let max_name_len = ref 10 in
  fun test test_name ->
    max_name_len := max !max_name_len (String.length test_name);
    Printf.printf "test %-*s %!" (!max_name_len + 5) (test_name ^ " ...");
    test ();
    Printf.printf "[  OK  ]\n%!"

let test_irregular_tree () =
  Random.self_init ();
  List.iter (fun (test, test_name) -> run_test test test_name) [
    (test_height, "height");
    (test_join, "join");
    (test_split, "split");
    (test_fold, "fold");
    (test_fold_right, "fold_right");
    (test_to_list, "to_list");
    (test_from_list, "from_list");
    (test_to_and_from_list, "to_and_from_list");
    (test_map, "map");
    (test_show, "show");
    (test_show_repr, "show_repr");
  ]

irregular_tree.mli

type 'item t

val singleton : 'item -> 'item t
val join : 'item t -> 'item t -> 'item t
val split : 'item t -> 'item t * 'item t

val from_list : 'item list -> 'item t
val to_list : 'item t -> 'item list

val fold : ('item -> 'item -> 'item) -> 'item t -> 'item
val fold_right : ('item -> 'acc -> 'acc) -> 'acc -> 'item t -> 'acc
val map : ('a -> 'b) -> 'a t -> 'b t

val height : 'item t -> int
val show : ?leaf_label:string -> ?branch_label:string ->
           ('item -> string) -> 'item t -> string
val show_repr : ('item -> string) -> 'item t -> string

val test_irregular_tree : unit -> unit

Makefile

run_tests: irregular_tree.mli irregular_tree.ml run_tests.ml
	ocamlopt irregular_tree.mli irregular_tree.ml run_tests.ml -o $@

run_tests.ml

let () =
  Irregular_tree.test_irregular_tree ()