OCaml bits list to tree

Question

I have made this following function :

let rec arbre_vers_bits_rec arb l =
  match arb with
  | Feuille f -> (match f with
                            | Blanc -> 0 :: 0 :: l;
                            | Noir -> 0 :: 1 :: l;)
  | Noeud(a,b,c,d) -> (
      1 :: 
      arbre_vers_bits_rec a (
      arbre_vers_bits_rec b ( 
      arbre_vers_bits_rec c ( 
      arbre_vers_bits_rec d (l))));
  );;


let arbre_vers_bits arb =
    arbre_vers_bits_rec arb [];;

Which give me a bits list like : [1;0;0;0;1;0;1;0;0]

Now I'm trying to make the reverse function : tree to bits list

So I have made this :

let rec bits_vers_arbres_aux lb res =
    match lb with 
    | [] -> res;
    | 1 :: tl -> (Noeud((bits_vers_arbres_aux (sublist 1 9 tl) res),
                        (bits_vers_arbres_aux (sublist 10 18 tl) res),
                        (bits_vers_arbres_aux (sublist 19 27 tl) res), 
                        (bits_vers_arbres_aux (sublist 28 35 tl) res)));
    | 0 :: a :: 0 :: b :: 0 :: c :: 0 :: d :: tl -> (bits_vers_feuille a b c d);
    | _ -> failwith "error";;

let bits_vers_arbres lb = 
    let a = Noeud(Feuille Blanc, Feuille Blanc, Feuille Blanc, Feuille Blanc) in
    bits_vers_arbres_aux lb a;;

with bits_vers_feuille which return me a tree with 4 node a b c d.

I understand how I need to do but I can't figure out how to split the list without using sublist ( it works with bits list like [1;1;...] but not bigger.

sublist :

let rec sublist b e l = 
  match l with
    [] -> failwith "sublist"
  | h :: t -> 
     let tail = 
       if e = 0 then [] 
       else sublist (b-1) (e-1) t 
     in
     if b > 0 then tail 
     else h :: tail

My tree type:

type arbre = 
  Feuille of couleur 
| Noeud of arbre * arbre * arbre * arbre

couleur type:

type couleur = Noir | Blanc

What should I try ?

Answer 1

I have translated a lot of this to English, because I can read the French, and I can reason out coding problems, but doing both at the same time is really taxing.

type color = White | Black

type tree =
| Leaf of color
| Node of tree * tree * tree * tree

let tree_to_bits t = 
  let rec aux t bit_list =
    match t with   
    | Leaf White -> 0 :: 0 :: bit_list
    | Leaf Black -> 0 :: 1 :: bit_list
    | Node (a, b, c, d) -> 
        1 :: aux a (aux b (aux c (aux d bit_list)))
  in
    aux t []
    
let rec bits_to_tree bit_list =

  let rec consume_leaves bit_list leaves_acc =
    if List.length leaves_acc >= 4 then  
      (List.rev leaves_acc, bit_list)
    else
      match bit_list with   
      | [] | 1 :: _ -> (List.rev leaves_acc, bit_list)
      | 0 :: 0 :: rest -> consume_leaves rest (Leaf White :: leaves_acc)
      | 0 :: 1 :: rest -> consume_leaves rest (Leaf Black :: leaves_acc)
  in
  
  match bit_list with
  | [] -> failwith "ill formed" 
  | 0 :: 0 :: rest -> (Leaf White, rest)
  | 0 :: 1 :: rest -> (Leaf Black, rest)
  (* A node with at least one leaf! *)
  | 1 :: (0 :: _ as rest) ->
      print_endline "Found node";
      let leaves, rest = consume_leaves rest [] in
      Printf.printf "Consumed %d leaves\n" (List.length leaves);
      (match leaves with 
       | [a] -> 
           let (b, rest') = bits_to_tree rest in
           let (c, rest'') = bits_to_tree rest' in  
           let (d, rest''') = bits_to_tree rest'' in
           Node (a, b, c, d), rest'''
       | [a; b] -> 
           let (c, rest') = bits_to_tree rest in
           let (d, rest'') = bits_to_tree rest' in
           Node (a, b, c, d), rest''
       | [a; b; c] -> 
           let (d, rest') = bits_to_tree rest in
           Node (a, b, c, d), rest'
       | [a; b; c; d] -> 
           Node (a, b, c, d), rest)  
  (* A node that contains a node immediately *)        
  | 1 :: (1 :: _ as rest) ->
      let (a, rest') = bits_to_tree rest in
      let (b, rest'') = bits_to_tree rest' in
      let (c, rest''') = bits_to_tree rest'' in
      let (d, rest'''') = bits_to_tree rest''' in    
      Node (a, b, c, d), rest''''        

It throws all kinds of non-exhaustive pattern matching warnings, and I am as certain that there is a more elegant way to do this as I am that water is wet, but...

# t;;
- : tree =
Node (Leaf White, Node (Leaf White, Leaf Black, Leaf White, Leaf Black),
 Leaf White, Leaf White)
# tree_to_bits t;;
- : int list = [1; 0; 0; 1; 0; 0; 0; 1; 0; 0; 0; 1; 0; 0; 0; 0]
# tree_to_bits t |> bits_to_tree;;
Found node
Consumed 1 leaves
Found node
Consumed 4 leaves
- : tree * int list =
(Node (Leaf White, Node (Leaf White, Leaf Black, Leaf White, Leaf Black),
  Leaf White, Leaf White),
 [])
# tree_to_bits t |> bits_to_tree |> fst |> tree_to_bits;;
Found node
Consumed 1 leaves
Found node
Consumed 4 leaves
- : int list = [1; 0; 0; 1; 0; 0; 0; 1; 0; 0; 0; 1; 0; 0; 0; 0]
# let t =
    let w = Leaf White
    and b = Leaf Black
    in
    Node (Node (w, b, w, b), Node (b, w, b, w),
          Node (w, w, b, b), Node (b, b, w, w));;
val t : tree =
  Node (Node (Leaf White, Leaf Black, Leaf White, Leaf Black),
   Node (Leaf Black, Leaf White, Leaf Black, Leaf White),
   Node (Leaf White, Leaf White, Leaf Black, Leaf Black),
   Node (Leaf Black, Leaf Black, Leaf White, Leaf White))
# tree_to_bits t ;;
- : int list =
[1; 1; 0; 0; 0; 1; 0; 0; 0; 1; 1; 0; 1; 0; 0; 0; 1; 0; 0; 1; 0; 0; 0; 0; 0; 1;
 0; 1; 1; 0; 1; 0; 1; 0; 0; 0; 0]
# tree_to_bits t |> bits_to_tree;;
Found node
Consumed 4 leaves
Found node
Consumed 4 leaves
Found node
Consumed 4 leaves
Found node
Consumed 4 leaves
- : tree * int list =
(Node (Node (Leaf White, Leaf Black, Leaf White, Leaf Black),
  Node (Leaf Black, Leaf White, Leaf Black, Leaf White),
  Node (Leaf White, Leaf White, Leaf Black, Leaf Black),
  Node (Leaf Black, Leaf Black, Leaf White, Leaf White)),
 [])

More Elegant

Having more time to think about this while out on a walk, we end up with a more elegant approach that still passes the same tests as before.

let rec bits_to_tree' = function
  | 0 :: 0 :: rest -> Leaf White, rest
  | 0 :: 1 :: rest -> Leaf Black, rest
  | 1 :: rest ->
      let (a, rest'   ) = bits_to_tree' rest    in
      let (b, rest''  ) = bits_to_tree' rest'   in
      let (c, rest''' ) = bits_to_tree' rest''  in
      let (d, rest'''') = bits_to_tree' rest''' in
      Node (a, b, c, d), rest''''
  | _ -> failwith "Ill-formed bit list"

If the first two elements in the bit list are 0 and 0, this indicates a Leaf White. If 0 and 1, then this indicates a Leaf Black. Either way, we return the rest of the bit list as well.

If the first number is 1, then it indicates a Node. We know a Node contains four trees, so we use a chain of let bindings to recursively call the function on the rest. Each time we get the tree, but also the remaining bit list. Doing this ensures we "consume" the bit list.

If the bit list doesn't start with 0 followed by 0 or 1; or a 1, then the bit list is ill-formed.

The ' suffixes on rest are not necessary, but they demonstrate how we're changing this value. We could just call all of these rest because we don't access previous rest values.

As a further exercise, this could be a locally scoped function, that hides the passing of rest.

let bits_to_tree bit_list =
  let rec bits_to_tree' = function
    | 0 :: 0 :: rest -> Leaf White, rest
    | 0 :: 1 :: rest -> Leaf Black, rest
    | 1 :: rest ->
        let (a, rest) = bits_to_tree' rest in
        let (b, rest) = bits_to_tree' rest in
        let (c, rest) = bits_to_tree' rest in
        let (d, rest) = bits_to_tree' rest in
        Node (a, b, c, d), rest
    | _ -> failwith "Ill-formed bit list"
  in
  bits_to_tree' bit_list |> fst 

Answer 2

The intuition is that you want to work through the string of bits with the rule that if you see 1 you have a subtree at that point and if you see 0 you have a leaf. This seems pretty close to the definition of a recursive function. The only problem (it seems to me) is in tracking the remainder of the list of bits after you extract a subtree. Hence your function needs to return not only a tree, but also the remaining undecoded bits:

let rec bits_vers_arbres lb =
    match lb with
    | [] -> failwith "Ill-formed bit string"
    | 0 :: bn :: rest -> (Feuille (if bn = 0 then Blanc else Noir), rest)
    | 1 :: rest ->
        let (a, rest') = bits_vers_arbres rest in
        let (b, rest'') = bits_vers_arbres rest' in
. . .

I think this will work, but I haven't finished coding it myself.