99 Problems (solved) in OCaml

# (* There is no nested list type in OCaml, so we need to define one
     first. A node of a nested list is either an element, or a list of
     nodes. *)
  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>

# flatten [ One `a ; Many [ One `b ; Many [ One `c ; One `d ] ; One `e ] ]
  = [ `a ; `b ; `c ; `d ; `e ];;
- : bool = true

# 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>

# compress [`a;`a;`a;`a;`b;`c;`c;`a;`a;`d;`e;`e;`e;`e] = [`a;`b;`c;`a;`d;`e];;
- : bool = true

# 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>

# pack [`a;`a;`a;`a;`b;`c;`c;`a;`a;`d;`d;`e;`e;`e;`e]
  = [[`a;`a;`a;`a]; [`b]; [`c;`c]; [`a;`a]; [`d;`d]; [`e;`e;`e;`e]];;
- : bool = true

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

# 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>

# decode [Many (4,`a); One `b; Many (2,`c); Many (2,`a); One `d; Many (4,`e)]
  = [`a;`a;`a;`a;`b;`c;`c;`a;`a;`d;`e;`e;`e;`e];;
- : bool = true

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.

# 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>

# encode [`a;`a;`a;`a;`b;`c;`c;`a;`a;`d;`e;`e;`e;`e] =
  [Many (4,`a); One `b; Many (2,`c); Many (2,`a); One `d; Many (4,`e)];;
- : bool = true

# 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>

# replicate [`a;`b;`c] 3 = [`a;`a;`a;`b;`b;`b;`c;`c;`c];;
- : bool = true

# 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>

# drop [`a;`b;`c;`d;`e;`f;`g;`h;`i;`j] 3 = [`a;`b;`d;`e;`g;`h;`j];;
- : bool = true

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).

# 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>

# slice [`a;`b;`c;`d;`e;`f;`g;`h;`i;`j] 2 6 = [`c;`d;`e;`f;`g];;
- : bool = true

# 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>

# rotate [`a;`b;`c;`d;`e;`f;`g;`h] 3 = [`d;`e;`f;`g;`h;`a;`b;`c];;
- : bool = true
# rotate [`a;`b;`c;`d;`e;`f;`g;`h] (-2) = [`g;`h;`a;`b;`c;`d;`e;`f];;
- : bool = true

The selected items shall be returned in a list. We use the Random module but do not initialize it with Random.self_init for reproducibility.

# let rec rand_select list n =
    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>

# rand_select [`a;`b;`c;`d;`e;`f;`g;`h] 3;;
- : [> `a | `b | `c | `d | `e | `f | `g | `h ] list = [`g; `d; `a]

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.

# let extract k list =
    let rec aux k acc emit = function
      | [] -> acc
      | h :: t ->
        if k = 1 then aux k (emit [h] acc) emit t else
          let new_emit x = emit (h :: x) in
          aux k (aux (k-1) acc new_emit t) emit t
    in
    let emit x acc = x :: acc in
    aux k [] emit list;;
val extract : int -> 'a list -> 'a list list = <fun>

# extract 2 [`a;`b;`c;`d]
  = [[`c;`d]; [`b;`d]; [`b;`c]; [`a;`d]; [`a;`c]; [`a;`b]];;
- : bool = true

a) 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.

b) 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.

# (* 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 (List.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>

# group [`a;`b;`c;`d] [2;1]
  = [[[`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]]];;
- : bool = true

a) 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.

b) 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.

# (* 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;;
val insert : ('a -> 'a -> int) -> 'a -> 'a list -> 'a list = <fun>
val sort : ('a -> 'a -> int) -> 'a list -> 'a list = <fun>
val length_sort : 'a list list -> 'a list list = <fun>
# (* Sorting according to length frequency : prepend frequency, sort,
     remove frequency. Frequencies are extracted by sorting lengths
     and applying RLE to count occurences 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;;
val rle : 'a list -> ('a * int) list = <fun>
val frequency_sort : 'a list list -> 'a list list = <fun>

# length_sort [ [`a;`b;`c]; [`d;`e]; [`f;`g;`h]; [`d;`e];
                [`i;`j;`k;`l]; [`m;`n]; [`o] ]
  = [[`o]; [`d; `e]; [`d; `e]; [`m; `n]; [`a; `b; `c]; [`f; `g; `h];
     [`i; `j; `k; `l]];;
- : bool = true
# frequency_sort [ [`a;`b;`c]; [`d;`e]; [`f;`g;`h]; [`d;`e];
                   [`i;`j;`k;`l]; [`m;`n]; [`o] ]
  = [[`i; `j; `k; `l]; [`o]; [`a; `b; `c]; [`f; `g; `h]; [`d; `e]; [`d; `e];
     [`m; `n]];;
- : bool = true

# 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>

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

Use Euclid's algorithm.

# let rec gcd a b =
    if b = 0 then a else gcd b (a mod b);;
val gcd : int -> int -> int = <fun>

# gcd 13 27 = 1;;
- : bool = true
# gcd 20536 7826 = 2;;
- : bool = true

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 phi(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).

# (* [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>

# phi 10 = 4;;
- : bool = true
# phi 13 = 12;;
- : bool = true

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

# (* 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>

# factors 315 = [3;3;5;7];;
- : bool = true

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).

# 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>

# factors 315 = [3,2 ; 5,1 ; 7,1];;
- : bool = true

See problem “Calculate Euler's totient function phi(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:

# (* Naive power function. *)
  let rec pow n p = if p < 1 then 1 else n * pow n (p-1);;
val pow : int -> int -> int = <fun>
# (* [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);;
val phi_improved : int -> int = <fun>

# phi_improved 10 = 4;;
- : bool = true
# phi_improved 13 = 12;;
- : bool = true

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.

# (* [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>

# goldbach 28 = (5,23);;
- : bool = true

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] 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>

# goldbach_list 9 20
  = [(10, (3, 7)); (12, (5, 7)); (14, (3, 11)); (16, (3, 13)); (18, (5, 13));
     (20, (3, 17))];;
- : bool = true
# goldbach_limit 1 2000 50
  = [(992, (73, 919)); (1382, (61, 1321)); (1856, (67, 1789));
     (1928, (61, 1867))];;
- : bool = true

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, balue_of_b, value_of_expr).

# 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>

# table2 "a" "b" (And(Var "a", Or(Var "a", Var "b")))
  = [(true, true, true);
     (true, false, true);
     (false, true, false);
     (false, false, false) ];;
- : bool = true

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.

# (* [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>

# table ["a"; "b"] (And(Var "a", Or(Var "a", Var "b")))
  = [["a", true; "b", true], true;
     ["a", true; "b", false], true;
     ["a", false; "b", true], false;
     ["a", false; "b", false], false ];;
- : bool = true
# let a = Var "a" and b = Var "b" and c = Var "c" in
  table ["a"; "b"; "c"] (Or(And(a, Or(b,c)), Or(And(a,b), And(a,c))));;
- : ((string * bool) list * bool) list =
[([("a", true); ("b", true); ("c", true)], true);
 ([("a", true); ("b", ...); ...], ...); ...]

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.

# let prepend c s =
  (* Prepend the char [c] to the string [s]. *)
  let s' = String.create (String.length s + 1) in
  s'.[0] <- c;
  String.blit s 0 s' 1 (String.length s);
  s'

let rec gray n =
  if n <= 1 then ["0"; "1"]
  else let g = gray (n - 1) in
       List.map (prepend '0') g @ List.map (prepend '1') g;;
val prepend : char -> string -> string = <fun>
val gray : int -> string list = <fun>

# gray 1 = ["0"; "1"];;
- : bool = true
# gray 2 = ["00"; "01"; "11"; "10"];;
- : bool = false
# gray 3 = ["000"; "001"; "011"; "010"; "110"; "111"; "101"; "100"];;
- : bool = false

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.

# (* Build all trees with given [left] and [right] subtrees. *)
  let add_trees_with left right all =
    let add_right_tree all l =
      List.fold_left (fun a r -> Node('x', l, r) :: a) all right in
    List.fold_left add_right_tree all left
  
  let rec cbal_tree n =
    if n = 0 then [Empty]
    else if n mod 2 = 1 then
      let t = cbal_tree (n / 2) in
      add_trees_with t t []
    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
      add_trees_with t1 t2 (add_trees_with t2 t1 []);;
val add_trees_with :
  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>

# cbal_tree 4
  = [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)); ];;
- : bool = true
# List.length(cbal_tree 40);;
- : int = 524288

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>

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

# 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>

# construct [3;2;5;7;1]
  = Node(3, Node(2, Node(1, Empty, Empty), Empty),
         Node(5, Empty, Node(7, Empty, Empty)));;
- : bool = true

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

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

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

# sym_cbal_trees 5
  = [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)) ];;
- : bool = true

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
# List.map (fun n -> n, List.length(sym_cbal_trees n)) (range 10 20)
  = [(10, 0); (11, 4); (12, 0); (13, 4); (14, 0); (15, 1);
     (16, 0); (17, 8); (18, 0); (19, 16); (20, 0)];;
- : bool = true

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 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
      add_trees_with t1 t1 (add_trees_with t1 t2 (add_trees_with t2 t1 []));;
val hbal_tree : int -> char binary_tree list = <fun>

# 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 (...), ...); ...]
# let x = 'x';;
val x : char = 'x'
# List.mem (Node(x, Node(x, Node(x, Empty, Empty), Node(x, Empty, Empty)),
                 Node(x, Node(x, Empty, Empty), Node(x, Empty, Empty)))) t;;
- : bool = true
# List.mem (Node(x, Node(x, Node(x, Empty, Empty), Node(x, Empty, Empty)),
                 Node(x, Node(x, Empty, Empty), Empty))) t;;
- : bool = true
# List.length t = 15;;
- : bool = true

Consider a height-balanced binary tree of height h. What is the maximum number of nodes it can contain? Clearly, maxN = 2^h - 1. However, what is the minimum number minN? This question is more difficult. Try to find a recursive statement and turn it into a function minNodes defined as follows: minNodes h returns the minimum number of nodes in a height-balanced binary tree of height h.

# ;;

On the other hand, we might ask: what is the maximum height H a height-balanced binary tree with N nodes can have? maxHeight n returns the maximum height of a height-balanced binary tree with n nodes.

# ;;

Now, we can attack the main problem: construct all the height-balanced binary trees with a given nuber 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);;
File "", line 1, characters 13-28:
Error: Unbound value hbal_tree_nodes

A complete binary tree with height H is defined as follows: The levels 1,2,3,...,H-1 contain the maximum number of nodes (i.e 2^i-1 at the level i, note that we start counting the levels from 1 at the root). In level H, which may contain less than the maximum possible number of nodes, all the nodes are "left-adjusted". This means that in a levelorder tree traversal all internal nodes come first, the leaves come second, and empty successors (the nil's which are not really nodes!) come last.

Particularly, complete binary trees are used as data structures (or addressing schemes) for heaps.

We can assign an address number to each node in a complete binary tree by enumerating the nodes in levelorder, starting at the root with number 1. In doing so, we realize that for every node X with address A the following property holds: The address of X's left and right successors are 2*A and 2*A+1, respectively, supposed the successors do exist. This fact can be used to elegantly construct a complete binary tree structure. Write a function is_complete_binary_tree with the following specification: is_complete_binary_tree n t returns true iff t is a complete binary tree with n nodes.

# ;;

# ;;

As a preparation for drawing the tree, a layout algorithm is required to determine the position of each node in a rectangular grid. Several layout methods are conceivable, one of them is shown in the illustration below.

In this layout strategy, the position of a node v is obtained by the following two rules:

• x(v) is equal to the position of the node v in the inorder sequence;
• y(v) is equal to the depth of the node v in the tree.

In order to store the position of the nodes, we redefine the OCaml type representing a node (and its successors) as follows:

# type 'a pos_binary_tree =
    | E (* represents the empty tree *)
    | N of 'a * int * int * 'a pos_binary_tree * 'a pos_binary_tree;;
type 'a pos_binary_tree =
    E
  | N of 'a * int * int * 'a pos_binary_tree * 'a pos_binary_tree

N(w,x,y,l,r) represents a (non-empty) binary tree with root w "positioned" at (x,y), and subtrees l and r. Write a function layout_binary_tree with the following specification: layout_binary_tree t returns the "positioned" binary tree obtained from the binary tree t.

# ;;

# ;;

An alternative layout method is depicted in the above illustration. Find out the rules and write the corresponding OCaml function.

Hint: On a given level, the horizontal distance between neighboring nodes is constant.

# ;;

# ;;

Somebody represents binary trees as strings of the following type (see example): "a(b(d,e),c(,f(g,)))".

• Write an OCaml function which generates this string representation, if the tree is given as usual (as Empty or Node(x,l,r) term). Then write a function which does this inverse; i.e. given the string representation, construct the tree in the usual form. Finally, combine the two predicates in a single function tree_string which can be used in both directions.
• Write the same predicate tree_string using difference lists and a single predicate tree_dlist which does the conversion between a tree and a difference list in both directions.

For simplicity, suppose the information in the nodes is a single letter and there are no spaces in the string.

# ;;

# ;;

We consider binary trees with nodes that are identified by single lower-case letters, as in the example of the previous problem.

1. Write functions preorder and inorder that construct the preorder and inorder sequence of a given binary tree, respectively. The results should be atoms, e.g. 'abdecfg' for the preorder sequence of the example in the previous problem.
2. Can you use preorder from problem part 1. in the reverse direction; i.e. given a preorder sequence, construct a corresponding tree? If not, make the necessary arrangements.
3. If both the preorder sequence and the inorder sequence of the nodes of a binary tree are given, then the tree is determined unambiguously. Write a function pre_in_tree that does the job.
4. Solve problems 1. to 3. using difference lists. Cool! Use the function timeit (defined in problem “Compare the two methods of calculating Euler's totient function.”) to compare the solutions.

What happens if the same character appears in more than one node. Try for instance pre_in_tree "aba" "baa".

# ;;

# ;;

We consider again binary trees with nodes that are identified by single lower-case letters, as in the example of problem “A string representation of binary trees”. Such a tree can be represented by the preorder sequence of its nodes in which dots (.) are inserted where an empty subtree (nil) is encountered during the tree traversal. For example, the tree shown in problem “A string representation of binary trees” is represented as 'abd..e..c.fg...'. First, try to establish a syntax (BNF or syntax diagrams) and then write a function tree_dotstring which does the conversion in both directions. Use difference lists.

# ;;

# ;;

We suppose that the nodes of a multiway tree contain single characters. In the depth-first order sequence of its nodes, a special character ^ has been inserted whenever, during the tree traversal, the move is a backtrack to the previous level.

By this rule, the tree in the figure opposite is represented as: afg^^c^bd^e^^^.

Write functions string_of_tree : char mult_tree -> string to construct the string representing the tree and tree_of_string : string -> char mult_tree to construct the tree when the string is given.

# (* 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 in
    add_string_of_tree buf t;
    Buffer.contents buf;;
val add_string_of_tree : Buffer.t -> char mult_tree -> unit = <fun>
val string_of_tree : char mult_tree -> string = <fun>
# let rec tree_of_substring t s i len =
    if i >= len || s.[i] = '^' then List.rev t, i + 1
    else
      let sub, j = tree_of_substring [] s (i+1) len in
      tree_of_substring (T(s.[i], sub) ::t) s j len
  let tree_of_string s =
    match tree_of_substring [] s 0 (String.length s) with
    | [t], _ -> t
    | _ -> failwith "tree_of_string";;
val tree_of_substring :
  char mult_tree list -> string -> int -> int -> char mult_tree list * int =
  <fun>
val tree_of_string : string -> char mult_tree = <fun>

# let t =
    T('a', [T('f',[T('g',[])]); T('c',[]); T('b',[T('d',[]); T('e',[])])]);;
val t : char mult_tree =
  T ('a',
   [T ('f', [T ('g', [])]); T ('c', []);
    T ('b', [T ('d', []); T ('e', ...); ...]); ...])
# string_of_tree t = "afg^^c^bd^e^^^";;
- : bool = true
# tree_of_string "afg^^c^bd^e^^^" = t;;
- : bool = true

There is a particular notation for multiway trees in Lisp. The following pictures show how multiway tree structures are represented in Lisp.

Note that in the "lispy" notation a node with successors (children) in the tree is always the first element in a list, followed by its children. The "lispy" representation of a multiway tree is a sequence of atoms and parentheses '(' and ')'. This is very close to the way trees are represented in OCaml, except that no constructor T is used. Write a function lispy : char mult_tree -> string that returns the lispy notation of the tree.

# let rec add_lispy buf = function
    | T(c, []) -> Buffer.add_char buf c
    | T(c, sub) ->
       Buffer.add_char buf '(';
       Buffer.add_char buf c;
       List.iter (fun t -> Buffer.add_char buf ' '; add_lispy buf t) sub;
       Buffer.add_char buf ')'
  let lispy t =
    let buf = Buffer.create 128 in
    add_lispy buf t;
    Buffer.contents buf;;
val add_lispy : Buffer.t -> char mult_tree -> unit = <fun>
val lispy : char mult_tree -> string = <fun>

# lispy (T('a', [])) = "a";;
- : bool = true
# lispy (T('a', [T('b', [])])) = "(a b)";;
- : bool = true
# lispy t = "(a (f g) c (b d e))";;
- : bool = true

Write a function paths g a b that returns all acyclic path p from node a to node b ≠ a in the graph g. The function should return the list of all paths via backtracking.

# (* The datastructures used here are far from the most efficient ones
     but allow for a straightforward implementation. *)
  (* Returns all neighbors satisfying the condition. *)
  let neighbors g a cond =
    let edge l (b,c) = if b = a && cond c then c :: l
                       else if c = a && cond b then b :: l
                       else l in
    List.fold_left edge [] g.edges
  let rec list_path g a to_b = match to_b with
    | [] -> assert false (* [to_b] contains the path to [b]. *)
    | a' :: _ ->
       if a' = a then [to_b]
       else
         let n = neighbors g a' (fun c -> not(List.mem c to_b)) in
         List.concat(List.map (fun c -> list_path g a (c :: to_b)) n)

  let paths g a b =
    assert(a <> b);
    list_path g a [b];;
val neighbors : 'a graph_term -> 'a -> ('a -> bool) -> 'a list = <fun>
val list_path : 'a graph_term -> 'a -> 'a list -> 'a list list = <fun>
val paths : 'a graph_term -> 'a -> 'a -> 'a list list = <fun>

# paths example_graph 'f' 'b' = [['f'; 'c'; 'b']; ['f'; 'b']];;
- : bool = true

Write a function s_tree g to construct (by backtracking) all spanning trees of a given graph g. With this predicate, find out how many spanning trees there are for the graph depicted to the left. The data of this example graph can be found in the test below. When you have a correct solution for the s_tree function, use it to define two other useful functions: is_tree graph and is_connected Graph. Both are five-minutes tasks!

# ;;

# let g = { nodes = ['a'; 'b'; 'c'; 'd'; 'e'; 'f'; 'g'; 'h'];
            edges = [('a', 'b'); ('a', 'd'); ('b', 'c'); ('b', 'e');
                     ('c', 'e'); ('d', 'e'); ('d', 'f'); ('d', 'g');
                     ('e', 'h'); ('f', 'g'); ('g', 'h')] };;
val g : char graph_term =
  {nodes = ['a'; 'b'; 'c'; 'd'; 'e'; 'f'; 'g'; 'h'];
   edges = [('a', 'b'); ('a', 'd'); ('b', 'c'); ...]}

Write a function ms_tree graph to construct the minimal spanning tree of a given labelled graph. A labelled graph will be represented as follows:

# type ('a, 'b) labeled_graph = { nodes : 'a list;
                                  edges : ('a * 'a * 'b) list };;
type ('a, 'b) labeled_graph = {
  nodes : 'a list;
  edges : ('a * 'a * 'b) list;
}

(Beware that from now on nodes and edges mask the previous fields of the same name.)

Hint: Use the algorithm of Prim. A small modification of the solution of P83 does the trick. The data of the example graph to the right can be found below.

# ;;

# let g = { nodes = ['a'; 'b'; 'c'; 'd'; 'e'; 'f'; 'g'; 'h'];
            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)] };;
val g : (char, int) labeled_graph =
  {nodes = ['a'; 'b'; 'c'; 'd'; 'e'; 'f'; 'g'; 'h'];
   edges = [('a', 'b', 5); ('a', 'd', 3); (...); ...]}

Two graphs G1(N1,E1) and G2(N2,E2) are isomorphic if there is a bijection f: N1 → N2 such that for any nodes X,Y of N1, X and Y are adjacent if and only if f(X) and f(Y) are adjacent.

Write a function that determines whether two graphs are isomorphic. Hint: Use an open-ended list to represent the function f.

# ;;

# ;;

• Write a function degree graph node that determines the degree of a given node.
• Write a function that generates a list of all nodes of a graph sorted according to decreasing degree.
• Use Welsh-Powell's algorithm to paint the nodes of a graph in such a way that adjacent nodes have different colors.

# ;;

# ;;

Write a function that generates a depth-first order graph traversal sequence. The starting point should be specified, and the output should be a list of nodes that are reachable from this starting point (in depth-first order).

# ;;

# ;;

Write a predicate that splits a graph into its connected components.

# ;;

# ;;

Write a predicate that finds out whether a given graph is bipartite.

# ;;

# ;;

This is a classical problem in computer science. The objective is to place eight queens on a chessboard so that no two queens are attacking each other; i.e., no two queens are in the same row, the same column, or on the same diagonal.

Hint: Represent the positions of the queens as a list of numbers 1..N. Example: [4;2;7;3;6;8;5;1] means that the queen in the first column is in row 4, the queen in the second column is in row 2, etc. Use the generate-and-test paradigm.

# ;;

# ;;

Another famous problem is this one: How can a knight jump on an N×N chessboard in such a way that it visits every square exactly once?

Hints: Represent the squares by pairs of their coordinates (x,y), where both x and y are integers between 1 and N. Define the function jump n (x,y) that returns all coordinates (u,v) to which a knight can jump from (x,y) to on a n×n chessboard. And finally, represent the solution of our problem as a list knight positions (the knight's tour).

# ;;

# ;;

On financial documents, like cheques, numbers must sometimes be written in full words. Example: 175 must be written as one-seven-five. Write a function full_words to print (non-negative) integer numbers in full words.

# ;;

# ;;

In a certain programming language (Ada) identifiers are defined by the syntax diagram (railroad chart) opposite. Transform the syntax diagram into a system of syntax diagrams which do not contain loops; i.e. which are purely recursive. Using these modified diagrams, write a function identifier : string -> bool that can check whether or not a given string is a legal identifier.

# ;;

# ;;

Sudoku puzzles go like this:

   Problem statement                 Solution

    .  .  4 | 8  .  . | .  1  7	     9  3  4 | 8  2  5 | 6  1  7
            |         |                      |         |
    6  7  . | 9  .  . | .  .  .	     6  7  2 | 9  1  4 | 8  5  3
            |         |                      |         |
    5  .  8 | .  3  . | .  .  4      5  1  8 | 6  3  7 | 9  2  4
    --------+---------+--------      --------+---------+--------
    3  .  . | 7  4  . | 1  .  .      3  2  5 | 7  4  8 | 1  6  9
            |         |                      |         |
    .  6  9 | .  .  . | 7  8  .      4  6  9 | 1  5  3 | 7  8  2
            |         |                      |         |
    .  .  1 | .  6  9 | .  .  5      7  8  1 | 2  6  9 | 4  3  5
    --------+---------+--------      --------+---------+--------
    1  .  . | .  8  . | 3  .  6	     1  9  7 | 5  8  2 | 3  4  6
            |         |                      |         |
    .  .  . | .  .  6 | .  9  1	     8  5  3 | 4  7  6 | 2  9  1
            |         |                      |         |
    2  4  . | .  .  1 | 5  .  .      2  4  6 | 3  9  1 | 5  7  8

Every spot in the puzzle belongs to a (horizontal) row and a (vertical) column, as well as to one single 3x3 square (which we call "square" for short). At the beginning, some of the spots carry a single-digit number between 1 and 9. The problem is to fill the missing spots with digits in such a way that every number between 1 and 9 appears exactly once in each row, in each column, and in each square.

# ;;

# ;;