Exercise Categories

Lists

Arithmetic

Logic and Codes

Binary Trees

Multiway Trees

Graphs

Miscellaneous

# Exercises

This section is inspired by Ninety-Nine Lisp Problems which in turn was based on “Prolog problem list” by Werner Hett. For each of these questions, some simple tests are shown—they may also serve to make the question clearer if needed. To work on these problems, we recommend you first install OCaml or use it inside your browser. The source of the following problems is available on GitHub.

Every exercise has a difficulty level, ranging from beginner to advanced. This difficulty level is indicated with the symbol "☡". The absence of marks represents the beginner level, one mark the intermediate level and two marks the advanced level.

## Tail of a List

Beginner

Write a function `last : 'a list -> 'a option` that returns the last element of a list

``````# last ["a" ; "b" ; "c" ; "d"];;
- : string option = Some "d"
# last [];;
- : 'a option = None
``````
``````# let rec last = function
| [] -> None
| [ x ] -> Some x
| _ :: t -> last t;;
val last : 'a list -> 'a option = <fun>
``````

## Last Two Elements of a List

Beginner

Find the last but one (last and penultimate) elements of a list.

``````# last_two ["a"; "b"; "c"; "d"];;
- : (string * string) option = Some ("c", "d")
# last_two ["a"];;
- : (string * string) option = None
``````
``````# let rec last_two = function
| [] | [_] -> None
| [x; y] -> Some (x,y)
| _ :: t -> last_two t;;
val last_two : 'a list -> ('a * 'a) option = <fun>
``````

## N'th Element of a List

Beginner

Find the N'th element of a list.

Remark: OCaml has `List.nth` which numbers elements from `0` and raises an exception if the index is out of bounds.

``````# List.nth ["a"; "b"; "c"; "d"; "e"] 2;;
- : string = "c"
# List.nth ["a"] 2;;
Exception: Failure "nth".
``````
``````# let rec at k = function
| [] -> None
| h :: t -> if k = 0 then Some h else at (k - 1) t;;
val at : int -> 'a list -> 'a option = <fun>
``````

## Length of a List

Beginner

Find the number of elements of a list.

OCaml standard library has `List.length` but we ask that you reimplement it. Bonus for a tail recursive solution.

``````# length ["a"; "b"; "c"];;
- : int = 3
# length [];;
- : int = 0
``````

This function is tail-recursive: it uses a constant amount of stack memory regardless of list size.

``````# let length list =
let rec aux n = function
| [] -> n
| _ :: t -> aux (n + 1) t
in
aux 0 list;;
val length : 'a list -> int = <fun>
``````

## Reverse a List

Beginner

Reverse a list.

OCaml standard library has `List.rev` but we ask that you reimplement it.

``````# rev ["a"; "b"; "c"];;
- : string list = ["c"; "b"; "a"]
``````
``````# let rev list =
let rec aux acc = function
| [] -> acc
| h :: t -> aux (h :: acc) t
in
aux [] list;;
val rev : 'a list -> 'a list = <fun>
``````

## Palindrome

Beginner

Find out whether a list is a palindrome.

Hint: A palindrome is its own reverse.

``````# is_palindrome ["x"; "a"; "m"; "a"; "x"];;
- : bool = true
# not (is_palindrome ["a"; "b"]);;
- : bool = true
``````
``````# let is_palindrome list =
(* One can use either the rev function from the previous problem, or the built-in List.rev *)
list = List.rev list;;
val is_palindrome : 'a list -> bool = <fun>
``````

## Flatten a List

Intermediate

Flatten a nested list structure.

``````type 'a node =
| One of 'a
| Many of 'a node list
``````
``````# flatten [One "a"; Many [One "b"; Many [One "c" ;One "d"]; One "e"]];;
- : string list = ["a"; "b"; "c"; "d"; "e"]
``````
``````# type 'a node =
| One of 'a
| Many of 'a node list;;
type 'a node = One of 'a | Many of 'a node list
# (* This function traverses the list, prepending any encountered elements
to an accumulator, which flattens the list in inverse order. It can
then be reversed to obtain the actual flattened list. *);;
# let flatten list =
let rec aux acc = function
| [] -> acc
| One x :: t -> aux (x :: acc) t
| Many l :: t -> aux (aux acc l) t
in
List.rev (aux [] list);;
val flatten : 'a node list -> 'a list = <fun>
``````

## Eliminate Duplicates

Intermediate

Eliminate consecutive duplicates of list elements.

``````# compress ["a"; "a"; "a"; "a"; "b"; "c"; "c"; "a"; "a"; "d"; "e"; "e"; "e"; "e"];;
- : string list = ["a"; "b"; "c"; "a"; "d"; "e"]
``````
``````# let rec compress = function
| a :: (b :: _ as t) -> if a = b then compress t else a :: compress t
| smaller -> smaller;;
val compress : 'a list -> 'a list = <fun>
``````

## Pack Consecutive Duplicates

Intermediate

Pack consecutive duplicates of list elements into sublists.

``````# pack ["a"; "a"; "a"; "a"; "b"; "c"; "c"; "a"; "a"; "d"; "d"; "e"; "e"; "e"; "e"];;
- : string list list =
[["a"; "a"; "a"; "a"]; ["b"]; ["c"; "c"]; ["a"; "a"]; ["d"; "d"];
["e"; "e"; "e"; "e"]]
``````
``````# let pack list =
let rec aux current acc = function
| [] -> []    (* Can only be reached if original list is empty *)
| [x] -> (x :: current) :: acc
| a :: (b :: _ as t) ->
if a = b then aux (a :: current) acc t
else aux [] ((a :: current) :: acc) t  in
List.rev (aux [] [] list);;
val pack : 'a list -> 'a list list = <fun>
``````

## Run-Length Encoding

Beginner

Here is an example:

``````# encode ["a"; "a"; "a"; "a"; "b"; "c"; "c"; "a"; "a"; "d"; "e"; "e"; "e"; "e"];;
- : (int * string) list =
[(4, "a"); (1, "b"); (2, "c"); (2, "a"); (1, "d"); (4, "e")]
``````
``````# let encode list =
let rec aux count acc = function
| [] -> [] (* Can only be reached if original list is empty *)
| [x] -> (count + 1, x) :: acc
| a :: (b :: _ as t) -> if a = b then aux (count + 1) acc t
else aux 0 ((count + 1, a) :: acc) t in
List.rev (aux 0 [] list);;
val encode : 'a list -> (int * 'a) list = <fun>
``````

An alternative solution, which is shorter but requires more memory, is to use the `pack` function declared in problem 9:

``````# let pack list =
let rec aux current acc = function
| [] -> []    (* Can only be reached if original list is empty *)
| [x] -> (x :: current) :: acc
| a :: (b :: _ as t) ->
if a = b then aux (a :: current) acc t
else aux [] ((a :: current) :: acc) t  in
List.rev (aux [] [] list);;
val pack : 'a list -> 'a list list = <fun>
# let encode list =
List.map (fun l -> (List.length l, List.hd l)) (pack list);;
val encode : 'a list -> (int * 'a) list = <fun>
``````

## Modified Run-Length Encoding

Beginner

Modify the result of the previous problem in such a way that if an element has no duplicates it is simply copied into the result list. Only elements with duplicates are transferred as (N E) lists.

Since OCaml lists are homogeneous, one needs to define a type to hold both single elements and sub-lists.

``````type 'a rle =
| One of 'a
| Many of int * 'a
``````
``````# encode ["a"; "a"; "a"; "a"; "b"; "c"; "c"; "a"; "a"; "d"; "e"; "e"; "e"; "e"];;
- : string rle list =
[Many (4, "a"); One "b"; Many (2, "c"); Many (2, "a"); One "d";
Many (4, "e")]
``````
``````# type 'a rle =
| One of 'a
| Many of int * 'a;;
type 'a rle = One of 'a | Many of int * 'a
# let encode l =
let create_tuple cnt elem =
if cnt = 1 then One elem
else Many (cnt, elem) in
let rec aux count acc = function
| [] -> []
| [x] -> (create_tuple (count + 1) x) :: acc
| hd :: (snd :: _ as tl) ->
if hd = snd then aux (count + 1) acc tl
else aux 0 ((create_tuple (count + 1) hd) :: acc) tl in
List.rev (aux 0 [] l);;
val encode : 'a list -> 'a rle list = <fun>
``````

## Decode a Run-Length Encoded List

Intermediate

Given a run-length code list generated as specified in the previous problem, construct its uncompressed version.

``````#  decode [Many (4, "a"); One "b"; Many (2, "c"); Many (2, "a"); One "d"; Many (4, "e")];;
- : string list =
["a"; "a"; "a"; "a"; "b"; "c"; "c"; "a"; "a"; "d"; "e"; "e"; "e"; "e"]
``````
``````# let decode list =
let rec many acc n x =
if n = 0 then acc else many (x :: acc) (n - 1) x
in
let rec aux acc = function
| [] -> acc
| One x :: t -> aux (x :: acc) t
| Many (n, x) :: t -> aux (many acc n x) t
in
aux [] (List.rev list);;
val decode : 'a rle list -> 'a list = <fun>
``````

## Run-Length Encoding of a List (Direct Solution)

Intermediate

Implement the so-called run-length encoding data compression method directly. I.e. don't explicitly create the sublists containing the duplicates, as in problem "Pack consecutive duplicates of list elements into sublists", but only count them. As in problem "Modified run-length encoding", simplify the result list by replacing the singleton lists (1 X) by X.

``````# encode ["a";"a";"a";"a";"b";"c";"c";"a";"a";"d";"e";"e";"e";"e"];;
- : string rle list =
[Many (4, "a"); One "b"; Many (2, "c"); Many (2, "a"); One "d";
Many (4, "e")]
``````
``````# let encode list =
let rle count x = if count = 0 then One x else Many (count + 1, x) in
let rec aux count acc = function
| [] -> [] (* Can only be reached if original list is empty *)
| [x] -> rle count x :: acc
| a :: (b :: _ as t) -> if a = b then aux (count + 1) acc t
else aux 0 (rle count a :: acc) t
in
List.rev (aux 0 [] list);;
val encode : 'a list -> 'a rle list = <fun>
``````

## Duplicate the Elements of a List

Beginner

Duplicate the elements of a list.

``````# duplicate ["a"; "b"; "c"; "c"; "d"];;
- : string list = ["a"; "a"; "b"; "b"; "c"; "c"; "c"; "c"; "d"; "d"]
``````
``````# let rec duplicate = function
| [] -> []
| h :: t -> h :: h :: duplicate t;;
val duplicate : 'a list -> 'a list = <fun>
``````

Remark: this function is not tail recursive. Can you modify it so it becomes so?

## Replicate the Elements of a List a Given Number of Times

Intermediate

Replicate the elements of a list a given number of times.

``````# replicate ["a"; "b"; "c"] 3;;
- : string list = ["a"; "a"; "a"; "b"; "b"; "b"; "c"; "c"; "c"]
``````
``````# let replicate list n =
let rec prepend n acc x =
if n = 0 then acc else prepend (n-1) (x :: acc) x in
let rec aux acc = function
| [] -> acc
| h :: t -> aux (prepend n acc h) t in
(* This could also be written as:
List.fold_left (prepend n) [] (List.rev list) *)
aux [] (List.rev list);;
val replicate : 'a list -> int -> 'a list = <fun>
``````

Note that `List.rev list` is needed only because we want `aux` to be tail recursive.

## Drop Every N'th Element From a List

Intermediate

Drop every N'th element from a list.

``````# drop ["a"; "b"; "c"; "d"; "e"; "f"; "g"; "h"; "i"; "j"] 3;;
- : string list = ["a"; "b"; "d"; "e"; "g"; "h"; "j"]
``````
``````# let drop list n =
let rec aux i = function
| [] -> []
| h :: t -> if i = n then aux 1 t else h :: aux (i + 1) t  in
aux 1 list;;
val drop : 'a list -> int -> 'a list = <fun>
``````

## Split a List Into Two Parts; The Length of the First Part Is Given

Beginner

Split a list into two parts; the length of the first part is given.

If the length of the first part is longer than the entire list, then the first part is the list and the second part is empty.

``````# split ["a"; "b"; "c"; "d"; "e"; "f"; "g"; "h"; "i"; "j"] 3;;
- : string list * string list =
(["a"; "b"; "c"], ["d"; "e"; "f"; "g"; "h"; "i"; "j"])
# split ["a"; "b"; "c"; "d"] 5;;
- : string list * string list = (["a"; "b"; "c"; "d"], [])
``````
``````# let split list n =
let rec aux i acc = function
| [] -> List.rev acc, []
| h :: t as l -> if i = 0 then List.rev acc, l
else aux (i - 1) (h :: acc) t
in
aux n [] list;;
val split : 'a list -> int -> 'a list * 'a list = <fun>
``````

## Extract a Slice From a List

Intermediate

Given two indices, `i` and `k`, the slice is the list containing the elements between the `i`'th and `k`'th element of the original list (both limits included). Start counting the elements with 0 (this is the way the `List` module numbers elements).

``````# slice ["a"; "b"; "c"; "d"; "e"; "f"; "g"; "h"; "i"; "j"] 2 6;;
- : string list = ["c"; "d"; "e"; "f"; "g"]
``````
``````# let slice list i k =
let rec take n = function
| [] -> []
| h :: t -> if n = 0 then [] else h :: take (n - 1) t
in
let rec drop n = function
| [] -> []
| h :: t as l -> if n = 0 then l else drop (n - 1) t
in
take (k - i + 1) (drop i list);;
val slice : 'a list -> int -> int -> 'a list = <fun>
``````

This solution has a drawback, namely that the `take` function is not tail recursive so it may exhaust the stack when given a very long list. You may also notice that the structure of `take` and `drop` is similar and you may want to abstract their common skeleton in a single function. Here is a solution.

``````# let rec fold_until f acc n = function
| [] -> (acc, [])
| h :: t as l -> if n = 0 then (acc, l)
else fold_until f (f acc h) (n - 1) t
let slice list i k =
let _, list = fold_until (fun _ _ -> []) [] i list in
let taken, _ = fold_until (fun acc h -> h :: acc) [] (k - i + 1) list in
List.rev taken;;
val fold_until : ('a -> 'b -> 'a) -> 'a -> int -> 'b list -> 'a * 'b list =
<fun>
val slice : 'a list -> int -> int -> 'a list = <fun>
``````

## Rotate a List N Places to the Left

Intermediate

Rotate a list N places to the left.

``````# rotate ["a"; "b"; "c"; "d"; "e"; "f"; "g"; "h"] 3;;
- : string list = ["d"; "e"; "f"; "g"; "h"; "a"; "b"; "c"]
``````
``````# let split list n =
let rec aux i acc = function
| [] -> List.rev acc, []
| h :: t as l -> if i = 0 then List.rev acc, l
else aux (i - 1) (h :: acc) t  in
aux n [] list

let rotate list n =
let len = List.length list in
(* Compute a rotation value between 0 and len - 1 *)
let n = if len = 0 then 0 else (n mod len + len) mod len in
if n = 0 then list
else let a, b = split list n in b @ a;;
val split : 'a list -> int -> 'a list * 'a list = <fun>
val rotate : 'a list -> int -> 'a list = <fun>
``````

## Remove the K'th Element From a List

Beginner

Remove the K'th element from a list.

The first element of the list is numbered 0, the second 1,...

``````# remove_at 1 ["a"; "b"; "c"; "d"];;
- : string list = ["a"; "c"; "d"]
``````
``````# let rec remove_at n = function
| [] -> []
| h :: t -> if n = 0 then t else h :: remove_at (n - 1) t;;
val remove_at : int -> 'a list -> 'a list = <fun>
``````

## Insert an Element at a Given Position Into a List

Beginner

Start counting list elements with 0. If the position is larger or equal to the length of the list, insert the element at the end. (The behavior is unspecified if the position is negative.)

``````# insert_at "alfa" 1 ["a"; "b"; "c"; "d"];;
- : string list = ["a"; "alfa"; "b"; "c"; "d"]
``````
``````# let rec insert_at x n = function
| [] -> [x]
| h :: t as l -> if n = 0 then x :: l else h :: insert_at x (n - 1) t;;
val insert_at : 'a -> int -> 'a list -> 'a list = <fun>
``````

## Create a List Containing All Integers Within a Given Range

Beginner

If first argument is greater than second, produce a list in decreasing order.

``````# range 4 9;;
- : int list = [4; 5; 6; 7; 8; 9]
``````
``````# let range a b =
let rec aux a b =
if a > b then [] else a :: aux (a + 1) b
in
if a > b then List.rev (aux b a) else aux a b;;
val range : int -> int -> int list = <fun>
``````

A tail recursive implementation:

``````# let range a b =
let rec aux acc high low =
if high >= low then
aux (high :: acc) (high - 1) low
else acc
in
if a < b then aux [] b a else List.rev (aux [] a b);;
val range : int -> int -> int list = <fun>
``````

## Extract a Given Number of Randomly Selected Elements From a List

Intermediate

The selected items shall be returned in a list. We use the `Random` module but and initialise it with `Random.init 0` at the start of the function for reproducibility and validate the solution. To make the function truly random, however, one should remove the call to `Random.init 0`

``````# rand_select ["a"; "b"; "c"; "d"; "e"; "f"; "g"; "h"] 3;;
- : string list = ["e"; "c"; "g"]
``````
``````# let rand_select list n =
Random.init 0;
let rec extract acc n = function
| [] -> raise Not_found
| h :: t -> if n = 0 then (h, acc @ t) else extract (h :: acc) (n - 1) t
in
let extract_rand list len =
extract [] (Random.int len) list
in
let rec aux n acc list len =
if n = 0 then acc else
let picked, rest = extract_rand list len in
aux (n - 1) (picked :: acc) rest (len - 1)
in
let len = List.length list in
aux (min n len) [] list len;;
val rand_select : 'a list -> int -> 'a list = <fun>
``````

## Lotto: Draw N Different Random Numbers From the Set 1..M

Beginner

Draw N different random numbers from the set `1..M`.

The selected numbers shall be returned in a list.

``````# lotto_select 6 49;;
- : int list = [20; 28; 45; 16; 24; 38]
``````
``````# (* [range] and [rand_select] defined in problems above *)
let lotto_select n m = rand_select (range 1 m) n;;
val lotto_select : int -> int -> int list = <fun>
``````

## Generate a Random Permutation of the Elements of a List

Beginner

Generate a random permutation of the elements of a list.

``````# permutation ["a"; "b"; "c"; "d"; "e"; "f"];;
- : string list = ["c"; "d"; "f"; "e"; "b"; "a"]
``````
``````# let rec permutation list =
let rec extract acc n = function
| [] -> raise Not_found
| h :: t -> if n = 0 then (h, acc @ t) else extract (h :: acc) (n - 1) t
in
let extract_rand list len =
extract [] (Random.int len) list
in
let rec aux acc list len =
if len = 0 then acc else
let picked, rest = extract_rand list len in
aux (picked :: acc) rest (len - 1)
in
aux [] list (List.length list);;
val permutation : 'a list -> 'a list = <fun>
``````

## Generate the Combinations of K Distinct Objects Chosen From the N Elements of a List

Intermediate

Generate the combinations of K distinct objects chosen from the N elements of a list.

In how many ways can a committee of 3 be chosen from a group of 12 people? We all know that there are C(12,3) = 220 possibilities (C(N,K) denotes the well-known binomial coefficients). For pure mathematicians, this result may be great. But we want to really generate all the possibilities in a list.

``````# extract 2 ["a"; "b"; "c"; "d"];;
- : string list list =
[["a"; "b"]; ["a"; "c"]; ["a"; "d"]; ["b"; "c"]; ["b"; "d"]; ["c"; "d"]]
``````
``````# let rec extract k list =
if k <= 0 then [[]]
else match list with
| [] -> []
| h :: tl ->
let with_h = List.map (fun l -> h :: l) (extract (k - 1) tl) in
let without_h = extract k tl in
with_h @ without_h;;
val extract : int -> 'a list -> 'a list list = <fun>
``````

## Group the Elements of a Set Into Disjoint Subsets

Intermediate

Group the elements of a set into disjoint subsets

1. In how many ways can a group of 9 people work in 3 disjoint subgroups of 2, 3 and 4 persons? Write a function that generates all the possibilities and returns them in a list.
2. Generalize the above function in a way that we can specify a list of group sizes and the function will return a list of groups.
``````# group ["a"; "b"; "c"; "d"] [2; 1];;
- : string list list list =
[[["a"; "b"]; ["c"]]; [["a"; "c"]; ["b"]]; [["b"; "c"]; ["a"]];
[["a"; "b"]; ["d"]]; [["a"; "c"]; ["d"]]; [["b"; "c"]; ["d"]];
[["a"; "d"]; ["b"]]; [["b"; "d"]; ["a"]]; [["a"; "d"]; ["c"]];
[["b"; "d"]; ["c"]]; [["c"; "d"]; ["a"]]; [["c"; "d"]; ["b"]]]
``````
``````# (* This implementation is less streamlined than the one-extraction
version, because more work is done on the lists after each
transform to prepend the actual items. The end result is cleaner
in terms of code, though. *)

let group list sizes =
let initial = List.map (fun size -> size, []) sizes in
(* The core of the function. Prepend accepts a list of groups,
each with the number of items that should be added, and
prepends the item to every group that can support it, thus
turning [1,a ; 2,b ; 0,c] into [ [0,x::a ; 2,b ; 0,c ];
[1,a ; 1,x::b ; 0,c]; [ 1,a ; 2,b ; 0,c ]]

Again, in the prolog language (for which these questions are
originally intended), this function is a whole lot simpler.  *)
let prepend p list =
let emit l acc = l :: acc in
let rec aux emit acc = function
| [] -> emit [] acc
| (n, l) as h :: t ->
let acc = if n > 0 then emit ((n - 1, p :: l) :: t) acc
else acc in
aux (fun l acc -> emit (h :: l) acc) acc t
in
aux emit [] list
in
let rec aux = function
| [] -> [initial]
| h :: t -> List.concat_map (prepend h) (aux t)
in
let all = aux list in
(* Don't forget to eliminate all group sets that have non-full
groups *)
let complete = List.filter (List.for_all (fun (x, _) -> x = 0)) all in
List.map (List.map snd) complete;;
val group : 'a list -> int list -> 'a list list list = <fun>
``````

## Sorting a List of Lists According to Length of Sublists

Intermediate

Sorting a list of lists according to length of sublists.

1. We suppose that a list contains elements that are lists themselves. The objective is to sort the elements of this list according to their length. E.g. short lists first, longer lists later, or vice versa.

2. Again, we suppose that a list contains elements that are lists themselves. But this time the objective is to sort the elements of this list according to their length frequency; i.e., in the default, where sorting is done ascendingly, lists with rare lengths are placed first, others with a more frequent length come later.

``````# length_sort [["a"; "b"; "c"]; ["d"; "e"]; ["f"; "g"; "h"]; ["d"; "e"];
["i"; "j"; "k"; "l"]; ["m"; "n"]; ["o"]];;
- : string list list =
[["o"]; ["d"; "e"]; ["d"; "e"]; ["m"; "n"]; ["a"; "b"; "c"]; ["f"; "g"; "h"];
["i"; "j"; "k"; "l"]]
# frequency_sort [["a"; "b"; "c"]; ["d"; "e"]; ["f"; "g"; "h"]; ["d"; "e"];
["i"; "j"; "k"; "l"]; ["m"; "n"]; ["o"]];;
- : string list list =
[["i"; "j"; "k"; "l"]; ["o"]; ["a"; "b"; "c"]; ["f"; "g"; "h"]; ["d"; "e"];
["d"; "e"]; ["m"; "n"]]
``````
``````(* We might not be allowed to use built-in List.sort, so here's an
eight-line implementation of insertion sort — O(n²) time
complexity. *)
let rec insert cmp e = function
| [] -> [e]
| h :: t as l -> if cmp e h <= 0 then e :: l else h :: insert cmp e t

let rec sort cmp = function
| [] -> []
| h :: t -> insert cmp h (sort cmp t)

(* Sorting according to length : prepend length, sort, remove length *)
let length_sort lists =
let lists = List.map (fun list -> List.length list, list) lists in
let lists = sort (fun a b -> compare (fst a) (fst b)) lists in
List.map snd lists
;;

(* Sorting according to length frequency : prepend frequency, sort,
remove frequency. Frequencies are extracted by sorting lengths
and applying RLE to count occurrences of each length (see problem
"Run-length encoding of a list.") *)
let rle list =
let rec aux count acc = function
| [] -> [] (* Can only be reached if original list is empty *)
| [x] -> (x, count + 1) :: acc
| a :: (b :: _ as t) ->
if a = b then aux (count + 1) acc t
else aux 0 ((a, count + 1) :: acc) t in
aux 0 [] list

let frequency_sort lists =
let lengths = List.map List.length lists in
let freq = rle (sort compare lengths) in
let by_freq =
List.map (fun list -> List.assoc (List.length list) freq , list) lists in
let sorted = sort (fun a b -> compare (fst a) (fst b)) by_freq in
List.map snd sorted
``````

## Determine Whether a Given Integer Number Is Prime

Intermediate

Determine whether a given integer number is prime.

``````# not (is_prime 1);;
- : bool = true
# is_prime 7;;
- : bool = true
# not (is_prime 12);;
- : bool = true
``````

Recall that `d` divides `n` iff `n mod d = 0`. This is a naive solution. See the Sieve of Eratosthenes for a more clever one.

``````# let is_prime n =
let n = abs n in
let rec is_not_divisor d =
d * d > n || (n mod d <> 0 && is_not_divisor (d + 1)) in
n <> 1 && is_not_divisor 2;;
val is_prime : int -> bool = <fun>
``````

## Determine the Greatest Common Divisor of Two Positive Integer Numbers

Intermediate

Determine the greatest common divisor of two positive integer numbers.

Use Euclid's algorithm.

``````# gcd 13 27;;
- : int = 1
# gcd 20536 7826;;
- : int = 2
``````
``````# let rec gcd a b =
if b = 0 then a else gcd b (a mod b);;
val gcd : int -> int -> int = <fun>
``````

## Determine Whether Two Positive Integer Numbers Are Coprime

Beginner

Determine whether two positive integer numbers are coprime.

Two numbers are coprime if their greatest common divisor equals 1.

``````# coprime 13 27;;
- : bool = true
# not (coprime 20536 7826);;
- : bool = true
``````
``````# (* [gcd] is defined in the previous question *)
let coprime a b = gcd a b = 1;;
val coprime : int -> int -> bool = <fun>
``````

## Calculate Euler's Totient Function Φ(m)

Intermediate

Euler's so-called totient function φ(m) is defined as the number of positive integers r (1 ≤ r < m) that are coprime to m. We let φ(1) = 1.

Find out what the value of φ(m) is if m is a prime number. Euler's totient function plays an important role in one of the most widely used public key cryptography methods (RSA). In this exercise you should use the most primitive method to calculate this function (there are smarter ways that we shall discuss later).

``````# phi 10;;
- : int = 4
``````
``````# (* [coprime] is defined in the previous question *)
let phi n =
let rec count_coprime acc d =
if d < n then
count_coprime (if coprime n d then acc + 1 else acc) (d + 1)
else acc
in
if n = 1 then 1 else count_coprime 0 1;;
val phi : int -> int = <fun>
``````

## Determine the Prime Factors of a Given Positive Integer

Intermediate

Construct a flat list containing the prime factors in ascending order.

``````# factors 315;;
- : int list = [3; 3; 5; 7]
``````
``````# (* Recall that d divides n iff [n mod d = 0] *)
let factors n =
let rec aux d n =
if n = 1 then [] else
if n mod d = 0 then d :: aux d (n / d) else aux (d + 1) n
in
aux 2 n;;
val factors : int -> int list = <fun>
``````

## Determine the Prime Factors of a Given Positive Integer (2)

Intermediate

Construct a list containing the prime factors and their multiplicity.

Hint: The problem is similar to problem Run-length encoding of a list (direct solution).

``````# factors 315;;
- : (int * int) list = [(3, 2); (5, 1); (7, 1)]
``````
``````# let factors n =
let rec aux d n =
if n = 1 then [] else
if n mod d = 0 then
match aux d (n / d) with
| (h, n) :: t when h = d -> (h, n + 1) :: t
| l -> (d, 1) :: l
else aux (d + 1) n
in
aux 2 n;;
val factors : int -> (int * int) list = <fun>
``````

## Calculate Euler's Totient Function Φ(m) (Improved)

Intermediate

See problem "Calculate Euler's totient function φ(m)" for the definition of Euler's totient function. If the list of the prime factors of a number m is known in the form of the previous problem then the function phi(m) can be efficiently calculated as follows: Let `[(p1, m1); (p2, m2); (p3, m3); ...]` be the list of prime factors (and their multiplicities) of a given number m. Then φ(m) can be calculated with the following formula:

φ(m) = (p1 - 1) × p1m1 - 1 × (p2 - 1) × p2m2 - 1 × (p3 - 1) × p3m3 - 1 × ⋯

``````# phi_improved 10;;
- : int = 4
# phi_improved 13;;
- : int = 12
``````
``````(* Naive power function. *)
let rec pow n p = if p < 1 then 1 else n * pow n (p - 1)

(* [factors] is defined in the previous question. *)
let phi_improved n =
let rec aux acc = function
| [] -> acc
| (p, m) :: t -> aux ((p - 1) * pow p (m - 1) * acc) t
in
aux 1 (factors n)
``````

## Compare the Two Methods of Calculating Euler's Totient Function

Beginner

Use the solutions of problems "Calculate Euler's totient function φ(m)" and "Calculate Euler's totient function φ(m) (improved)" to compare the algorithms. Take the number of logical inferences as a measure for efficiency. Try to calculate φ(10090) as an example.

``````timeit phi 10090
``````
``````# (* Naive [timeit] function.  It requires the [Unix] module to be loaded. *)
let timeit f a =
let t0 = Unix.gettimeofday() in
ignore (f a);
let t1 = Unix.gettimeofday() in
t1 -. t0;;
val timeit : ('a -> 'b) -> 'a -> float = <fun>
``````

## A List of Prime Numbers

Beginner

Given a range of integers by its lower and upper limit, construct a list of all prime numbers in that range.

``````# List.length (all_primes 2 7920);;
- : int = 1000
``````
``````# let is_prime n =
let n = max n (-n) in
let rec is_not_divisor d =
d * d > n || (n mod d <> 0 && is_not_divisor (d + 1))
in
is_not_divisor 2

let rec all_primes a b =
if a > b then [] else
let rest = all_primes (a + 1) b in
if is_prime a then a :: rest else rest;;
val is_prime : int -> bool = <fun>
val all_primes : int -> int -> int list = <fun>
``````

## Goldbach's Conjecture

Intermediate

Goldbach's conjecture says that every positive even number greater than 2 is the sum of two prime numbers. Example: 28 = 5 + 23. It is one of the most famous facts in number theory that has not been proved to be correct in the general case. It has been numerically confirmed up to very large numbers. Write a function to find the two prime numbers that sum up to a given even integer.

``````# goldbach 28;;
- : int * int = (5, 23)
``````
``````# (* [is_prime] is defined in the previous solution *)
let goldbach n =
let rec aux d =
if is_prime d && is_prime (n - d) then (d, n - d)
else aux (d + 1)
in
aux 2;;
val goldbach : int -> int * int = <fun>
``````

## A List of Goldbach Compositions

Intermediate

Given a range of integers by its lower and upper limit, print a list of all even numbers and their Goldbach composition.

In most cases, if an even number is written as the sum of two prime numbers, one of them is very small. Very rarely, the primes are both bigger than say 50. Try to find out how many such cases there are in the range 2..3000.

``````# goldbach_list 9 20;;
- : (int * (int * int)) list =
[(10, (3, 7)); (12, (5, 7)); (14, (3, 11)); (16, (3, 13)); (18, (5, 13));
(20, (3, 17))]
``````
``````# (* [goldbach] is defined in the previous question. *)
let rec goldbach_list a b =
if a > b then [] else
if a mod 2 = 1 then goldbach_list (a + 1) b
else (a, goldbach a) :: goldbach_list (a + 2) b

let goldbach_limit a b lim =
List.filter (fun (_, (a, b)) -> a > lim && b > lim) (goldbach_list a b);;
val goldbach_list : int -> int -> (int * (int * int)) list = <fun>
val goldbach_limit : int -> int -> int -> (int * (int * int)) list = <fun>
``````

## Truth Tables for Logical Expressions (2 Variables)

Intermediate

Let us define a small "language" for boolean expressions containing variables:

``````# type bool_expr =
| Var of string
| Not of bool_expr
| And of bool_expr * bool_expr
| Or of bool_expr * bool_expr;;
type bool_expr =
Var of string
| Not of bool_expr
| And of bool_expr * bool_expr
| Or of bool_expr * bool_expr
``````

A logical expression in two variables can then be written in prefix notation. For example, `(a ∨ b) ∧ (a ∧ b)` is written:

``````# And (Or (Var "a", Var "b"), And (Var "a", Var "b"));;
- : bool_expr = And (Or (Var "a", Var "b"), And (Var "a", Var "b"))
``````

Define a function, `table2` which returns the truth table of a given logical expression in two variables (specified as arguments). The return value must be a list of triples containing `(value_of_a, value_of_b, value_of_expr)`.

``````# table2 "a" "b" (And (Var "a", Or (Var "a", Var "b")));;
- : (bool * bool * bool) list =
[(true, true, true); (true, false, true); (false, true, false);
(false, false, false)]
``````
``````# let rec eval2 a val_a b val_b = function
| Var x -> if x = a then val_a
else if x = b then val_b
else failwith "The expression contains an invalid variable"
| Not e -> not (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)];;
val eval2 : string -> bool -> string -> bool -> bool_expr -> bool = <fun>
val table2 : string -> string -> bool_expr -> (bool * bool * bool) list =
<fun>
``````

## Truth Tables for Logical Expressions

Intermediate

Generalize the previous problem in such a way that the logical expression may contain any number of logical variables. Define `table` in a way that `table variables expr` returns the truth table for the expression `expr`, which contains the logical variables enumerated in `variables`.

``````# table ["a"; "b"] (And (Var "a", Or (Var "a", Var "b")));;
- : ((string * bool) list * bool) list =
[([("a", true); ("b", true)], true); ([("a", true); ("b", false)], true);
([("a", false); ("b", true)], false); ([("a", false); ("b", false)], false)]
``````
``````# (* [val_vars] is an associative list containing the truth value of
each variable.  For efficiency, a Map or a Hashtlb should be
preferred. *)

let rec eval val_vars = function
| Var x -> List.assoc x val_vars
| Not e -> not (eval val_vars e)
| And(e1, e2) -> eval val_vars e1 && eval val_vars e2
| Or(e1, e2) -> eval val_vars e1 || eval val_vars e2

(* Again, this is an easy and short implementation rather than an
efficient one. *)
let rec table_make val_vars vars expr =
match vars with
| [] -> [(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;;
val eval : (string * bool) list -> bool_expr -> bool = <fun>
val table_make :
(string * bool) list ->
string list -> bool_expr -> ((string * bool) list * bool) list = <fun>
val table : string list -> bool_expr -> ((string * bool) list * bool) list =
<fun>
``````

## Gray Code

Intermediate

An n-bit Gray code is a sequence of n-bit strings constructed according to certain rules. For example,

``````n = 1: C(1) = ['0', '1'].
n = 2: C(2) = ['00', '01', '11', '10'].
n = 3: C(3) = ['000', '001', '011', '010', '110', '111', '101', '100'].
``````

Find out the construction rules and write a function with the following specification: `gray n` returns the `n`-bit Gray code.

``````# gray 1;;
- : string list = ["0"; "1"]
# gray 2;;
- : string list = ["00"; "01"; "11"; "10"]
# gray 3;;
- : string list = ["000"; "001"; "011"; "010"; "110"; "111"; "101"; "100"]
``````
``````# let gray n =
let rec gray_next_level k l =
if k < n then
(* 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 (fun (acc1,acc2) x ->
(("0" ^ x) :: acc1, ("1" ^ x) :: acc2)) ([], []) l
in
(* 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
in
gray_next_level 1 ["0"; "1"];;
val gray : int -> string list = <fun>
``````

## Huffman Code

First of all, consult a good book on discrete mathematics or algorithms for a detailed description of Huffman codes (you can start with the Wikipedia page)!

We consider a set of symbols with their frequencies. For example, if the alphabet is `"a"`,..., `"f"` (represented as the positions 0,...5) and respective frequencies are 45, 13, 12, 16, 9, 5:

``````# let fs = [("a", 45); ("b", 13); ("c", 12); ("d", 16);
("e", 9); ("f", 5)];;
val fs : (string * int) list =
[("a", 45); ("b", 13); ("c", 12); ("d", 16); ("e", 9); ("f", 5)]
``````

Our objective is to construct the Huffman code `c` word for all symbols `s`. In our example, the result could be `hs = [("a", "0"); ("b", "101"); ("c", "100"); ("d", "111"); ("e", "1101"); ("f", "1100")]` (or `hs = [("a", "1");...]`). The task shall be performed by the function `huffman` defined as follows: `huffman(fs)` returns the Huffman code table for the frequency table `fs`

``````# huffman fs;;
- : (string * string) list =
[("a", "0"); ("c", "100"); ("b", "101"); ("f", "1100"); ("e", "1101");
("d", "111")]
``````
``````# (* Simple priority queue where the priorities are integers 0..100.
The node with the lowest probability comes first. *)
module Pq = struct
type 'a t = {data: 'a list array; mutable first: int}
let make() = {data = Array.make 101 []; first = 101}
let add q p x =
q.data.(p) <- x :: q.data.(p);  q.first <- min p q.first
let get_min q =
if q.first = 101 then None else
match q.data.(q.first) with
| [] -> assert false
| x :: tl ->
let p = q.first in
q.data.(q.first) <- tl;
while q.first < 101 && q.data.(q.first) = [] do
q.first <- q.first + 1
done;
Some(p, x)
end
type tree =
| Leaf of string
| Node of tree * tree
let rec huffman_tree q =
match Pq.get_min q, Pq.get_min q with
| Some(p1, t1), Some(p2, t2) -> Pq.add q (p1 + p2) (Node(t1, t2));
huffman_tree q
| Some(_, t), None | None, Some(_, t) -> t
| None, None -> assert false
(* Build the prefix-free binary code from the tree *)
let rec prefixes_of_tree prefix = function
| Leaf s -> [(s, prefix)]
| Node(t0, t1) ->  prefixes_of_tree (prefix ^ "0") t0
@ prefixes_of_tree (prefix ^ "1") t1
let huffman fs =
if List.fold_left (fun s (_, p) -> s + p) 0 fs <> 100 then
failwith "huffman: sum of weights must be 100";
let q = Pq.make () in
List.iter (fun (s, f) -> Pq.add q f (Leaf s)) fs;
prefixes_of_tree "" (huffman_tree q);;
module Pq :
sig
type 'a t = { data : 'a list array; mutable first : int; }
val make : unit -> 'a t
val add : 'a t -> int -> 'a -> unit
val get_min : 'a t -> (int * 'a) option
end
type tree = Leaf of string | Node of tree * tree
val huffman_tree : tree Pq.t -> tree = <fun>
val prefixes_of_tree : string -> tree -> (string * string) list = <fun>
val huffman : (string * int) list -> (string * string) list = <fun>
``````

## Construct Completely Balanced Binary Trees

Intermediate

A binary tree is either empty or it is composed of a root element and two successors, which are binary trees themselves.

In OCaml, one can define a new type `binary_tree` that carries an arbitrary value of type `'a` (thus is polymorphic) at each node.

``````# type 'a binary_tree =
| Empty
| Node of 'a * 'a binary_tree * 'a binary_tree;;
type 'a binary_tree = Empty | Node of 'a * 'a binary_tree * 'a binary_tree
``````

An example of tree carrying `char` data is:

``````# 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)));;
val example_tree : char binary_tree =
Node ('a', Node ('b', Node ('d', Empty, Empty), Node ('e', Empty, Empty)),
Node ('c', Empty, Node ('f', Node ('g', Empty, Empty), Empty)))
``````

In OCaml, the strict type discipline guarantees that, if you get a value of type `binary_tree`, then it must have been created with the two constructors `Empty` and `Node`.

In a completely balanced binary tree, the following property holds for every node: The number of nodes in its left subtree and the number of nodes in its right subtree are almost equal, which means their difference is not greater than one.

Write a function `cbal_tree` to construct completely balanced binary trees for a given number of nodes. The function should generate all solutions via backtracking. Put the letter `'x'` as information into all nodes of the tree.

``````# cbal_tree 4;;
- : char binary_tree/2 list =
[Node ('x', Node ('x', Empty, Empty),
Node ('x', Node ('x', Empty, Empty), Empty));
Node ('x', Node ('x', Empty, Empty),
Node ('x', Empty, Node ('x', Empty, Empty)));
Node ('x', Node ('x', Node ('x', Empty, Empty), Empty),
Node ('x', Empty, Empty));
Node ('x', Node ('x', Empty, Node ('x', Empty, Empty)),
Node ('x', Empty, Empty))]
``````
``````# (* Build all trees with given [left] and [right] subtrees. *)
let add_trees_with left right all =
List.fold_left (fun a r -> Node ('x', l, r) :: a) all right in

let rec cbal_tree n =
if n = 0 then [Empty]
else if n mod 2 = 1 then
let t = cbal_tree (n / 2) in
else (* n even: n-1 nodes for the left & right subtrees altogether. *)
let t1 = cbal_tree (n / 2 - 1) in
let t2 = cbal_tree (n / 2) in
char binary_tree list ->
char binary_tree list -> char binary_tree list -> char binary_tree list =
<fun>
val cbal_tree : int -> char binary_tree list = <fun>
``````

## Symmetric Binary Trees

Intermediate

Let us call a binary tree symmetric if you can draw a vertical line through the root node and then the right subtree is the mirror image of the left subtree. Write a function `is_symmetric` to check whether a given binary tree is symmetric.

Hint: Write a function `is_mirror` first to check whether one tree is the mirror image of another. We are only interested in the structure, not in the contents of the nodes.

``````# let rec is_mirror t1 t2 =
match t1, t2 with
| Empty, Empty -> true
| Node(_, l1, r1), Node(_, l2, r2) ->
is_mirror l1 r2 && is_mirror r1 l2
| _ -> false

let is_symmetric = function
| Empty -> true
| Node(_, l, r) -> is_mirror l r;;
val is_mirror : 'a binary_tree -> 'b binary_tree -> bool = <fun>
val is_symmetric : 'a binary_tree -> bool = <fun>
``````

## Binary Search Trees (Dictionaries)

Intermediate

Construct a binary search tree from a list of integer numbers.

``````# construct [3; 2; 5; 7; 1];;
- : int binary_tree =
Node (3, Node (2, Node (1, Empty, Empty), Empty),
Node (5, Empty, Node (7, Empty, Empty)))
``````

Then use this function to test the solution of the previous problem.

``````# is_symmetric (construct [5; 3; 18; 1; 4; 12; 21]);;
- : bool = true
# not (is_symmetric (construct [3; 2; 5; 7; 4]));;
- : bool = true
``````
``````# let rec insert tree x = match tree with
| Empty -> Node (x, Empty, Empty)
| Node (y, l, r) ->
if x = y then tree
else if x < y then Node (y, insert l x, r)
else Node (y, l, insert r x)
let construct l = List.fold_left insert Empty l;;
val insert : 'a binary_tree -> 'a -> 'a binary_tree = <fun>
val construct : 'a list -> 'a binary_tree = <fun>
``````

Intermediate

Apply the generate-and-test paradigm to construct all symmetric, completely balanced binary trees with a given number of nodes.

``````# sym_cbal_trees 5;;
- : char binary_tree list =
[Node ('x', Node ('x', Node ('x', Empty, Empty), Empty),
Node ('x', Empty, Node ('x', Empty, Empty)));
Node ('x', Node ('x', Empty, Node ('x', Empty, Empty)),
Node ('x', Node ('x', Empty, Empty), Empty))]
``````

How many such trees are there with 57 nodes? Investigate about how many solutions there are for a given number of nodes? What if the number is even? Write an appropriate function.

``````# List.length (sym_cbal_trees 57);;
- : int = 256
``````
``````# let sym_cbal_trees n =
List.filter is_symmetric (cbal_tree n);;
val sym_cbal_trees : int -> char binary_tree list = <fun>
``````

## Construct Height-Balanced Binary Trees

Intermediate

In a height-balanced binary tree, the following property holds for every node: The height of its left subtree and the height of its right subtree are almost equal, which means their difference is not greater than one.

Write a function `hbal_tree` to construct height-balanced binary trees for a given height. The function should generate all solutions via backtracking. Put the letter `'x'` as information into all nodes of the tree.

``````# let t = hbal_tree 3;;
val t : char binary_tree list =
[Node ('x', Node ('x', Empty, Node ('x', Empty, Empty)),
Node ('x', Empty, Node ('x', Empty, Empty)));
Node ('x', Node ('x', Empty, Node ('x', Empty, Empty)),
Node ('x', Node ('x', Empty, Empty), Empty));
Node ('x', Node ('x', Empty, Node ('x', Empty, Empty)),
Node ('x', Node ('x', Empty, Empty), Node ('x', Empty, Empty)));
Node ('x', Node ('x', Node ('x', Empty, Empty), Empty),
Node ('x', Empty, Node ('x', Empty, Empty)));
Node ('x', Node ('x', Node ('x', Empty, Empty), Empty),
Node ('x', Node ('x', Empty, Empty), Empty));
Node ('x', Node ('x', Node ('x', Empty, Empty), Empty),
Node ('x', Node ('x', Empty, Empty), Node ('x', Empty, Empty)));
Node ('x', Node ('x', Node ('x', Empty, Empty), Node ('x', Empty, Empty)),
Node ('x', Empty, Node ('x', Empty, Empty)));
Node ('x', Node ('x', Node ('x', Empty, Empty), Node ('x', Empty, Empty)),
Node ('x', Node ('x', Empty, Empty), Empty));
Node ('x', Node ('x', Node ('x', Empty, Empty), Node ('x', Empty, Empty)),
Node ('x', Node ('x', Empty, Empty), Node ('x', Empty, Empty)));
Node ('x', Node ('x', Empty, Node ('x', Empty, Empty)),
Node ('x', Empty, Empty));
Node ('x', Node ('x', Node ('x', Empty, Empty), Empty),
Node ('x', Empty, Empty));
Node ('x', Node ('x', Node ('x', Empty, Empty), Node ('x', Empty, Empty)),
Node ('x', Empty, Empty));
Node ('x', Node ('x', Empty, Empty),
Node ('x', Empty, Node ('x', Empty, Empty)));
Node ('x', Node ('x', Empty, Empty),
Node ('x', Node ('x', Empty, Empty), Empty));
Node ('x', Node ('x', Empty, Empty),
Node ('x', Node ('x', Empty, Empty), Node ('x', Empty, Empty)))]
``````

The function `add_trees_with` is defined in the solution of Construct completely balanced binary trees.

``````# let rec hbal_tree n =
if n = 0 then [Empty]
else if n = 1 then [Node ('x', Empty, Empty)]
else
(* [add_trees_with left right trees] is defined in a question above. *)
let t1 = hbal_tree (n - 1)
and t2 = hbal_tree (n - 2) in
val hbal_tree : int -> char binary_tree list = <fun>
``````

## Construct Height-Balanced Binary Trees With a Given Number of Nodes

Intermediate

Consider a height-balanced binary tree of height `h`. What is the maximum number of nodes it can contain? Clearly, max_nodes = 2`h` - 1.

``````# let max_nodes h = 1 lsl h - 1;;
val max_nodes : int -> int = <fun>
``````

## Minimum of nodes

However, what is the minimum number min_nodes? This question is more difficult. Try to find a recursive statement and turn it into a function `min_nodes` defined as follows: `min_nodes h` returns the minimum number of nodes in a height-balanced binary tree of height `h`.

## Minimum height

On the other hand, we might ask: what are the minimum (resp. maximum) height H a height-balanced binary tree with N nodes can have? `min_height` (resp. `max_height n`) returns the minimum (resp. maximum) height of a height-balanced binary tree with `n` nodes.

## Constructing trees

Now, we can attack the main problem: construct all the height-balanced binary trees with a given number of nodes. `hbal_tree_nodes n` returns a list of all height-balanced binary tree with `n` nodes.

Find out how many height-balanced trees exist for `n = 15`.

``````# List.length (hbal_tree_nodes 15);;
- : int = 1553
``````

## Minimum of nodes

The following solution comes directly from translating the question.

``````# let rec min_nodes h =
if h <= 0 then 0
else if h = 1 then 1
else min_nodes (h - 1) + min_nodes (h - 2) + 1;;
val min_nodes : int -> int = <fun>
``````

It is not the more efficient one however. One should use the last two values as the state to avoid the double recursion.

``````# let rec min_nodes_loop m0 m1 h =
if h <= 1 then m1
else min_nodes_loop m1 (m1 + m0 + 1) (h - 1)
let min_nodes h =
if h <= 0 then 0 else min_nodes_loop 0 1 h;;
val min_nodes_loop : int -> int -> int -> int = <fun>
val min_nodes : int -> int = <fun>
``````

It is not difficult to show that `min_nodes h` = Fh+2‌ - 1, where (Fn) is the Fibonacci sequence.

## Minimum height

Inverting the formula max_nodes = 2`h` - 1, one directly find that Hₘᵢₙ(n) = ⌈log₂(n+1)⌉ which is readily implemented:

``````# let min_height n = int_of_float (ceil (log (float(n + 1)) /. log 2.));;
val min_height : int -> int = <fun>
``````

Let us give a proof that the formula for Hₘᵢₙ is valid. First, if h = `min_height` n, there exists a height-balanced tree of height h with n nodes. Thus 2ʰ - 1 = `max_nodes h` ≥ n i.e., h ≥ log₂(n+1). To establish equality for Hₘᵢₙ(n), one has to show that, for any n, there exists a height-balanced tree with height Hₘᵢₙ(n). This is due to the relation Hₘᵢₙ(n) = 1 + Hₘᵢₙ(n/2) where n/2 is the integer division. For n odd, this is readily proved — so one can build a tree with a top node and two sub-trees with n/2 nodes of height Hₘᵢₙ(n) - 1. For n even, the same proof works if one first remarks that, in that case, ⌈log₂(n+2)⌉ = ⌈log₂(n+1)⌉ — use log₂(n+1) ≤ h ∈ ℕ ⇔ 2ʰ ≥ n + 1 and the fact that 2ʰ is even for that. This allows to have a sub-tree with n/2 nodes. For the other sub-tree with n/2-1 nodes, one has to establish that Hₘᵢₙ(n/2-1) ≥ Hₘᵢₙ(n) - 2 which is easy because, if h = Hₘᵢₙ(n/2-1), then h+2 ≥ log₂(2n) ≥ log₂(n+1).

The above function is not the best one however. Indeed, not every 64 bits integer can be represented exactly as a floating point number. Here is one that only uses integer operations:

``````# let rec ceil_log2_loop log plus1 n =
if n = 1 then if plus1 then log + 1 else log
else ceil_log2_loop (log + 1) (plus1 || n land 1 <> 0) (n / 2)
let ceil_log2 n = ceil_log2_loop 0 false n;;
val ceil_log2_loop : int -> bool -> int -> int = <fun>
val ceil_log2 : int -> int = <fun>
``````

This algorithm is still not the fastest however. See for example the Hacker's Delight, section 5-3 (and 11-4).

Following the same idea as above, if h = `max_height` n, then one easily deduces that `min_nodes` h ≤ n < `min_nodes`(h+1). This yields the following code:

``````# let rec max_height_search h n =
if min_nodes h <= n then max_height_search (h + 1) n else h - 1
let max_height n = max_height_search 0 n;;
val max_height_search : int -> int -> int = <fun>
val max_height : int -> int = <fun>
``````

Of course, since `min_nodes` is computed recursively, there is no need to recompute everything to go from `min_nodes h` to `min_nodes(h+1)`:

``````# let rec max_height_search h m_h m_h1 n =
if m_h <= n then max_height_search (h + 1) m_h1 (m_h1 + m_h + 1) n else h - 1
let max_height n = max_height_search 0 0 1 n;;
val max_height_search : int -> int -> int -> int -> int = <fun>
val max_height : int -> int = <fun>
``````

## Constructing trees

First, we define some convenience functions `fold_range` that folds a function `f` on the range `n0`...`n1` i.e., it computes `f (... f (f (f init n0) (n0+1)) (n0+2) ...) n1`. You can think it as performing the assignment `init ← f init n` for `n = n0,..., n1` except that there is no mutable variable in the code.

``````# let rec fold_range ~f ~init n0 n1 =
if n0 > n1 then init else fold_range ~f ~init:(f init n0) (n0 + 1) n1;;
val fold_range : f:('a -> int -> 'a) -> init:'a -> int -> int -> 'a = <fun>
``````

When constructing trees, there is an obvious symmetry: if one swaps the left and right sub-trees of a balanced tree, we still have a balanced tree. The following function returns all trees in `trees` together with their permutation.

``````# let rec add_swap_left_right trees =
List.fold_left (fun a n -> match n with
| Node (v, t1, t2) -> Node (v, t2, t1) :: a
| Empty -> a) trees trees;;
val add_swap_left_right : 'a binary_tree list -> 'a binary_tree list = <fun>
``````

Finally we generate all trees recursively, using a priori the bounds computed above. It could be further optimized but our aim is to straightforwardly express the idea.

``# let rec hbal_tree_nodes_height ``